package VMS::Lock; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(); @EXPORT_OK = qw(VLOCK_NLMODE VLOCK_CRMODE VLOCK_CWMODE VLOCK_PRMODE VLOCK_PWMODE VLOCK_EXMODE VLOCK_KERNEL VLOCK_EXEC VLOCK_SUPER VLOCK_USER); %EXPORT_TAGS = (lockmodes => [qw(VLOCK_NLMODE VLOCK_CRMODE VLOCK_CWMODE VLOCK_PRMODE VLOCK_PWMODE VLOCK_EXMODE)], accmodes => [qw(VLOCK_KERNEL VLOCK_EXEC VLOCK_SUPER VLOCK_USER)]); $VERSION = '1.02'; my $DEBUG = 0; my $DISPLAY_MODE = 0; my %comment = ( RESOURCE_NAME => 'Name string to be locked. Up to 31 bytes long.', SYSLOCK => 'Denotes a system lock. Requires SYSLCK priv.', ACCESS_MODE => 'Denotes least priveleged access mode for this resource name.', NOQUEUE => 'Sets LCK$M_NOQUEUE flag for convert.', LOCK_ID => 'Lock id.', LOCK_MODE => '0..5 => [NL,CR,CW,PR,PW,EX]', VALUE_BLOCK => 'Lock Value Block passed about in Lock Status Block.', INV_VALBLOCK => 'Set to 1 if SS$_VALNOTVALID returned in LSB.', DEADLOCK => 'Set to 1 if SS$_DEADLOCK returned in LSB.', EXPEDITE => 'Sets LCK$M_EXPEDITE flag for new lock.', DEBUG => 'Level of debugging for this object.', ); my %quote = ( RESOURCE_NAME => "'", SYSLOCK => "", ACCESS_MODE => "", NOQUEUE => "", LOCK_ID => "", LOCK_MODE => "", VALUE_BLOCK => "'", INV_VALBLOCK => "", DEADLOCK => "", EXPEDITE => "", DEBUG => "", ); sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. If a constant is not found then control is passed # to the AUTOLOAD in AutoLoader. my $constname; ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { die "Your vendor has not defined VMS::Lock macro $constname"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap VMS::Lock $VERSION; # Preloaded methods go here. sub new { my $class = shift; my %param = @_; my $status; my $tdebug =0; my $self = { RESOURCE_NAME => '', SYSLOCK => 0, ACCESS_MODE => 0, NOQUEUE => 0, LOCK_ID => 0, LOCK_MODE => 0, VALUE_BLOCK => "\0" x 16, INV_VALBLOCK => 0, DEADLOCK => 0, EXPEDITE => 0, DEBUG => 0, }; for my $tparam (qw(RESOURCE_NAME SYSLOCK ACCESS_MODE EXPEDITE DEBUG)) { if (exists $param{$tparam}) { $self->{$tparam} = $param{$tparam}; delete $param{$tparam}; } } $tdebug = $DEBUG | $self->{DEBUG}; if ($tdebug & 1) { print "Entering new.\n"; if (scalar %param) { display (\%param, "VMS::Lock::new called with extra params, these will be ignored"); undef %param; } print "Calling _new.\n"; } $status = _new ($self->{RESOURCE_NAME}, $self->{SYSLOCK}, $self->{ACCESS_MODE}, $self->{LOCK_ID}, $self->{VALUE_BLOCK}, $self->{INV_VALBLOCK}, $self->{EXPEDITE}, $tdebug); if ($tdebug & 1) { display ($self, "In new; result of _new; status = [$status]") } if (! $status) { if ($tdebug & 1) { print "Error [$!][$^E] from _new; returning undef.\n" } return undef; } if ($tdebug & 1) { print "Leaving new.\n" } return bless $self, $class; } sub convert { my $self = shift; my %param = @_; my $status; my $tdebug; $param{DEBUG} = 0 if ! exists $param{DEBUG}; $param{VALUE_BLOCK} = '' if ! exists $param{VALUE_BLOCK}; $param{NOQUEUE} = 0 if ! exists $param{NOQUEUE}; $tdebug = $DEBUG | $self->{DEBUG} | $param{DEBUG}; if ($tdebug & 1) { print "Entering convert\n"; display (\%param, "convert called with:"); } if (! exists $param{LOCK_MODE}) { die "no LOCK_MODE passed into convert"; } $status = _convert ($self->{LOCK_ID}, $param{LOCK_MODE}, $param{VALUE_BLOCK}, $param{NOQUEUE}, $self->{INV_VALBLOCK}, $self->{DEADLOCK}, $tdebug); if (! defined $status) { if ($tdebug & 1) { print "Error [$!][$^E] from _convert; returning undef.\n" } return undef; } elsif ($status == 0) { if ($tdebug & 1) { print "Status of 0 from _convert; noqueue = [",$param{NOQUEUE},"].\n" } $self->{NOQUEUE} = $param{NOQUEUE}; } else { $self->{LOCK_MODE} = $param{LOCK_MODE}; # potentially modified $self->{VALUE_BLOCK} = $param{VALUE_BLOCK}; # by _convert } if ($tdebug & 1) { display ($self, "Result of _convert") } return $status; } sub value_block { my $self = shift; return $self->{VALUE_BLOCK}; } sub expedite { my $self = shift; return $self->{EXPEDITE}; } sub deadlock { my $self = shift; return $self->{DEADLOCK}; } sub noqueue { my $self = shift; return $self->{NOQUEUE}; } sub lock_id { my $self = shift; return $self->{LOCK_ID}; } sub lock_mode { my $self = shift; return $self->{LOCK_MODE}; } sub inv_valblock { my $self = shift; return $self->{INV_VALBLOCK}; } sub resource_name { my $self = shift; return $self->{RESOURCE_NAME}; } sub delete { my $self = shift; my %param = @_; my $tdebug = $DEBUG | $self->{DEBUG} | $param{DEBUG}; if ($tdebug & 1) { print "Entering delete.\n" } undef $self; } sub DESTROY { my $self = shift; my $tdebug = $DEBUG | $self->{DEBUG}; if ($tdebug & 1) { print "Entering DESTROY\n" } _deq ($self->{LOCK_ID}, $tdebug) or die "error [$!][$^E] from _deq in DESTROY"; if ($tdebug & 1) { print "Leaving DESTROY\n" } } sub debug { my $self = shift; if (@_) { my $level = shift; if (_debug($level)) { print "Turning on XS debugging.\n" } return ref $self ? $self->{DEBUG} = $level : $DEBUG = $level; } else { return ref $self ? $self->{DEBUG} : $DEBUG; } } sub display_mode { my $self = shift; if (@_) { my $mode = shift; return $DISPLAY_MODE = $mode; } else { return $DISPLAY_MODE; } } sub display { my ($hash, $header) = @_; $header = $hash unless defined $header; my $tmode = $DISPLAY_MODE & 1; my $tcomment = $DISPLAY_MODE & 2; my $tmaxsize; my $tvalue; foreach $tvalue (values %$hash) { $tmaxsize = length($tvalue) if length($tvalue) > length($tmaxsize) } if ($DEBUG) { print "mode = [$tmode], comment = [$tcomment]\n" } if ($tmode == 0) { print "$header ", '-' x (60 - length($header)), "\n"; foreach my $key (sort keys %$hash) { $tvalue = defined $$hash{$key} ? $$hash{$key} : "undef"; print " key = [$key],", ' ' x (15 - length($key)), " value = [$tvalue]"; if ($tcomment == 2) { print ' ' x ($tmaxsize + 2 - length($tvalue)), $comment{$key} } print "\n"; } print '-' x 60, "\n"; } elsif ($tmode == 1) { print "$header = {\n"; foreach my $key (sort keys %$hash) { $tvalue = defined $$hash{$key} ? "$quote{$key}$$hash{$key}$quote{$key}" : "undef"; print " $key" . ' ' x (15 - length($key)), " => $tvalue,"; if ($tcomment == 2) { print ' ' x ($tmaxsize + 2 - length($tvalue)), "# $comment{$key}," } print "\n"; } print "}\n"; } } sub package_vars { print "DEBUG = [$DEBUG]\n"; print "DISPLAY_MODE = [$DISPLAY_MODE]\n"; } # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ =cut