1package VMS::DCLsym; 2 3use Carp; 4use DynaLoader; 5use vars qw( @ISA $VERSION ); 6use strict; 7 8# Package globals 9@ISA = ( 'DynaLoader' ); 10$VERSION = '1.05'; 11my(%Locsyms) = ( ':ID' => 'LOCAL' ); 12my(%Gblsyms) = ( ':ID' => 'GLOBAL'); 13my $DoCache = 1; 14my $Cache_set = 0; 15 16 17#====> OO methods 18 19sub new { 20 my($pkg,$type) = @_; 21 $type ||= 'LOCAL'; 22 $type = 'LOCAL' unless $type eq 'GLOBAL'; 23 bless { TYPE => $type }, $pkg; 24} 25 26sub DESTROY { } 27 28sub getsym { 29 my($self,$name) = @_; 30 my($val,$table); 31 32 if (($val,$table) = _getsym($name)) { 33 if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } 34 else { $Locsyms{$name} = $val; } 35 } 36 wantarray ? ($val,$table) : $val; 37} 38 39sub setsym { 40 my($self,$name,$val,$table) = @_; 41 42 $table = $self->{TYPE} unless $table; 43 if (_setsym($name,$val,$table)) { 44 if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; } 45 else { $Locsyms{$name} = $val; } 46 1; 47 } 48 else { 0; } 49} 50 51sub delsym { 52 my($self,$name,$table) = @_; 53 54 $table = $self->{TYPE} unless $table; 55 if (_delsym($name,$table)) { 56 if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; } 57 else { delete $Locsyms{$name}; } 58 1; 59 } 60 else { 0; } 61} 62 63sub clearcache { 64 my($self,$perm) = @_; 65 my($old); 66 67 $Cache_set = 0; 68 %Locsyms = ( ':ID' => 'LOCAL'); 69 %Gblsyms = ( ':ID' => 'GLOBAL'); 70 $old = $DoCache; 71 $DoCache = $perm if defined($perm); 72 $old; 73} 74 75#====> TIEHASH methods 76 77sub TIEHASH { 78 shift->new(@_); 79} 80 81sub FETCH { 82 my($self,$name) = @_; 83 if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; } 84 elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; } 85 else { scalar($self->getsym($name)); } 86} 87 88sub STORE { 89 my($self,$name,$val) = @_; 90 if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; } 91 elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; } 92 else { $self->setsym($name,$val); } 93} 94 95sub DELETE { 96 my($self,$name) = @_; 97 98 $self->delsym($name); 99} 100 101sub FIRSTKEY { 102 my($self) = @_; 103 my($name,$eqs,$val); 104 105 if (!$DoCache || !$Cache_set) { 106 # We should eventually replace this with a C routine which walks the 107 # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . . 108 open(P,'Show Symbol * |'); 109 while (<P>) { 110 ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/ 111 or carp "VMS::DCLsym: unparseable line $_"; 112 $name =~ s#\*##; 113 $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/; 114 if ($eqs eq '==') { $Gblsyms{$name} = $val; } 115 else { $Locsyms{$name} = $val; } 116 } 117 close P; 118 $Cache_set = 1; 119 } 120 $self ->{IDX} = 0; 121 $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms; 122 while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { 123 if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } 124 $self->{CACHE} = \%Gblsyms; 125 } 126 $name; 127} 128 129sub NEXTKEY { 130 my($self) = @_; 131 my($name,$val); 132 133 while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) { 134 if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; } 135 $self->{CACHE} = \%Gblsyms; 136 } 137 $name; 138} 139 140 141sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 } 142 143sub CLEAR { } 144 145 146bootstrap VMS::DCLsym; 147 1481; 149 150__END__ 151 152=head1 NAME 153 154VMS::DCLsym - Perl extension to manipulate DCL symbols 155 156=head1 SYNOPSIS 157 158 tie %allsyms, VMS::DCLsym; 159 tie %cgisyms, VMS::DCLsym, 'GLOBAL'; 160 161 162 $handle = new VMS::DCLsym; 163 $value = $handle->getsym($name); 164 $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n"; 165 $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n"; 166 $handle->clearcache(); 167 168=head1 DESCRIPTION 169 170The VMS::DCLsym extension provides access to DCL symbols using a 171tied hash interface. This allows Perl scripts to manipulate symbols in 172a manner similar to the way in which logical names are manipulated via 173the built-in C<%ENV> hash. Alternatively, one can call methods in this 174package directly to read, create, and delete symbols. 175 176=head2 Tied hash interface 177 178This interface lets you treat the DCL symbol table as a Perl associative array, 179in which the key of each element is the symbol name, and the value of the 180element is that symbol's value. Case is not significant in the key string, as 181DCL converts symbol names to uppercase, but it is significant in the value 182string. All of the usual operations on associative arrays are supported. 183Reading an element retrieves the current value of the symbol, assigning to it 184defines a new symbol (or overwrites the old value of an existing symbol), and 185deleting an element deletes the corresponding symbol. Setting an element to 186C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null 187string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out 188whether a default symbol table has been specified for this hash (see C<table> 189below), or set either or these keys to specify a default symbol table. 190 191When you call the C<tie> function to bind an associative array to this package, 192you may specify as an optional argument the symbol table in which you wish to 193create and delete symbols. If the argument is the string 'GLOBAL', then the 194global symbol table is used; any other string causes the local symbol table to 195be used. Note that this argument does not affect attempts to read symbols; if 196a symbol with the specified name exists in the local symbol table, it is always 197returned in preference to a symbol by the same name in the global symbol table. 198 199=head2 Object interface 200 201Although it's less convenient in some ways than the tied hash interface, you 202can also call methods directly to manipulate individual symbols. In some 203cases, this allows you finer control than using a tied hash aggregate. The 204following methods are supported: 205 206=over 4 207 208=item new 209 210This creates a C<VMS::DCLsym> object which can be used as a handle for later 211method calls. The single optional argument specifies the symbol table used 212by default in future method calls, in the same way as the optional argument to 213C<tie> described above. 214 215=item getsym 216 217If called in a scalar context, C<getsym> returns the value of the symbol whose 218name is given as the argument to the call, or C<undef> if no such symbol 219exists. Symbols in the local symbol table are always used in preference to 220symbols in the global symbol table. If called in a list context, C<getsym> 221returns a two-element list, whose first element is the value of the symbol, and 222whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table 223from which the symbol's value was read. 224 225=item setsym 226 227The first two arguments taken by this method are the name of the symbol and the 228value which should be assigned to it. The optional third argument is a string 229specifying the symbol table to be used; 'GLOBAL' specifies the global symbol 230table, and any other string specifies the local symbol table. If this argument 231is omitted, the default symbol table for the object is used. C<setsym> returns 232TRUE if successful, and FALSE otherwise. 233 234=item delsym 235 236This method deletes the symbol whose name is given as the first argument. The 237optional second argument specifies the symbol table, as described above under 238C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE 239if it was not. 240 241=item clearcache 242 243Because of the overhead associated with obtaining the list of defined symbols 244for the tied hash iterator, it is only done once, and the list is reused for 245subsequent iterations. Changes to symbols made through this package are 246recorded, but in the rare event that someone changes the process' symbol table 247from outside (as is possible using some software from the net), the iterator 248will be out of sync with the symbol table. If you expect this to happen, you 249can reset the cache by calling this method. In addition, if you pass a FALSE 250value as the first argument, caching will be disabled. It can be re-enabled 251later by calling C<clearcache> again with a TRUE value as the first argument. 252It returns TRUE or FALSE to indicate whether caching was previously enabled or 253disabled, respectively. 254 255This method is a stopgap until we can incorporate code into this extension to 256traverse the process' symbol table directly, so it may disappear in a future 257version of this package. 258 259=back 260 261=head1 AUTHOR 262 263Charles Bailey bailey@newman.upenn.edu 264 265=head1 VERSION 266 2671.05 12-Feb-2011 268 269=head1 BUGS 270 271The list of symbols for the iterator is assembled by spawning off a 272subprocess, which can be slow. Ideally, we should just traverse the 273process' symbol table directly from C. 274 275