VMS::Lock
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__