Commit | Line | Data |
---|---|---|
5f05dabc | 1 | package VMS::DCLsym; |
2 | ||
3 | use Carp; | |
4 | use DynaLoader; | |
5 | use vars qw( @ISA $VERSION ); | |
6 | use strict; | |
7 | ||
8 | # Package globals | |
9 | @ISA = ( 'DynaLoader' ); | |
692dce08 | 10 | $VERSION = '1.05'; |
5f05dabc | 11 | my(%Locsyms) = ( ':ID' => 'LOCAL' ); |
12 | my(%Gblsyms) = ( ':ID' => 'GLOBAL'); | |
13 | my $DoCache = 1; | |
14 | my $Cache_set = 0; | |
15 | ||
16 | ||
17 | #====> OO methods | |
18 | ||
19 | sub new { | |
20 | my($pkg,$type) = @_; | |
692dce08 CB |
21 | $type ||= 'LOCAL'; |
22 | $type = 'LOCAL' unless $type eq 'GLOBAL'; | |
5f05dabc | 23 | bless { TYPE => $type }, $pkg; |
24 | } | |
25 | ||
26 | sub DESTROY { } | |
27 | ||
28 | sub 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 | ||
39 | sub 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 | ||
51 | sub 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 | ||
63 | sub 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 | ||
77 | sub TIEHASH { | |
692dce08 | 78 | shift->new(@_); |
5f05dabc | 79 | } |
80 | ||
81 | sub 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 | ||
88 | sub 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 | ||
95 | sub DELETE { | |
96 | my($self,$name) = @_; | |
97 | ||
98 | $self->delsym($name); | |
99 | } | |
100 | ||
101 | sub 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+) (=+) (.+)/ | |
b89b8d61 | 111 | or carp "VMS::DCLsym: unparseable line $_"; |
5f05dabc | 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 | ||
129 | sub 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 | ||
141 | sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 } | |
142 | ||
143 | sub CLEAR { } | |
144 | ||
145 | ||
146 | bootstrap VMS::DCLsym; | |
147 | ||
148 | 1; | |
149 | ||
150 | __END__ | |
151 | ||
152 | =head1 NAME | |
153 | ||
154 | VMS::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 | ||
b89b8d61 | 162 | $handle = new VMS::DCLsym; |
5f05dabc | 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 | ||
170 | The VMS::DCLsym extension provides access to DCL symbols using a | |
171 | tied hash interface. This allows Perl scripts to manipulate symbols in | |
172 | a manner similar to the way in which logical names are manipulated via | |
173 | the built-in C<%ENV> hash. Alternatively, one can call methods in this | |
174 | package directly to read, create, and delete symbols. | |
175 | ||
176 | =head2 Tied hash interface | |
177 | ||
178 | This interface lets you treat the DCL symbol table as a Perl associative array, | |
179 | in which the key of each element is the symbol name, and the value of the | |
180 | element is that symbol's value. Case is not significant in the key string, as | |
181 | DCL converts symbol names to uppercase, but it is significant in the value | |
182 | string. All of the usual operations on associative arrays are supported. | |
183 | Reading an element retrieves the current value of the symbol, assigning to it | |
184 | defines a new symbol (or overwrites the old value of an existing symbol), and | |
185 | deleting an element deletes the corresponding symbol. Setting an element to | |
186 | C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null | |
187 | string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out | |
188 | whether a default symbol table has been specified for this hash (see C<table> | |
189 | below), or set either or these keys to specify a default symbol table. | |
190 | ||
191 | When you call the C<tie> function to bind an associative array to this package, | |
192 | you may specify as an optional argument the symbol table in which you wish to | |
193 | create and delete symbols. If the argument is the string 'GLOBAL', then the | |
194 | global symbol table is used; any other string causes the local symbol table to | |
195 | be used. Note that this argument does not affect attempts to read symbols; if | |
196 | a symbol with the specified name exists in the local symbol table, it is always | |
197 | returned in preference to a symbol by the same name in the global symbol table. | |
198 | ||
199 | =head2 Object interface | |
200 | ||
201 | Although it's less convenient in some ways than the tied hash interface, you | |
202 | can also call methods directly to manipulate individual symbols. In some | |
203 | cases, this allows you finer control than using a tied hash aggregate. The | |
204 | following methods are supported: | |
205 | ||
4ac9195f | 206 | =over 4 |
2ceaccd7 | 207 | |
5f05dabc | 208 | =item new |
209 | ||
210 | This creates a C<VMS::DCLsym> object which can be used as a handle for later | |
211 | method calls. The single optional argument specifies the symbol table used | |
212 | by default in future method calls, in the same way as the optional argument to | |
213 | C<tie> described above. | |
214 | ||
215 | =item getsym | |
216 | ||
217 | If called in a scalar context, C<getsym> returns the value of the symbol whose | |
218 | name is given as the argument to the call, or C<undef> if no such symbol | |
219 | exists. Symbols in the local symbol table are always used in preference to | |
91e74348 | 220 | symbols in the global symbol table. If called in a list context, C<getsym> |
5f05dabc | 221 | returns a two-element list, whose first element is the value of the symbol, and |
222 | whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table | |
223 | from which the symbol's value was read. | |
224 | ||
225 | =item setsym | |
226 | ||
227 | The first two arguments taken by this method are the name of the symbol and the | |
228 | value which should be assigned to it. The optional third argument is a string | |
229 | specifying the symbol table to be used; 'GLOBAL' specifies the global symbol | |
230 | table, and any other string specifies the local symbol table. If this argument | |
231 | is omitted, the default symbol table for the object is used. C<setsym> returns | |
232 | TRUE if successful, and FALSE otherwise. | |
233 | ||
234 | =item delsym | |
235 | ||
236 | This method deletes the symbol whose name is given as the first argument. The | |
237 | optional second argument specifies the symbol table, as described above under | |
238 | C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE | |
239 | if it was not. | |
240 | ||
241 | =item clearcache | |
242 | ||
243 | Because of the overhead associated with obtaining the list of defined symbols | |
244 | for the tied hash iterator, it is only done once, and the list is reused for | |
245 | subsequent iterations. Changes to symbols made through this package are | |
246 | recorded, but in the rare event that someone changes the process' symbol table | |
247 | from outside (as is possible using some software from the net), the iterator | |
248 | will be out of sync with the symbol table. If you expect this to happen, you | |
249 | can reset the cache by calling this method. In addition, if you pass a FALSE | |
98ccfbbf | 250 | value as the first argument, caching will be disabled. It can be re-enabled |
5f05dabc | 251 | later by calling C<clearcache> again with a TRUE value as the first argument. |
252 | It returns TRUE or FALSE to indicate whether caching was previously enabled or | |
253 | disabled, respectively. | |
254 | ||
255 | This method is a stopgap until we can incorporate code into this extension to | |
256 | traverse the process' symbol table directly, so it may disappear in a future | |
257 | version of this package. | |
258 | ||
4ac9195f MS |
259 | =back |
260 | ||
5f05dabc | 261 | =head1 AUTHOR |
262 | ||
bd3fa61c | 263 | Charles Bailey bailey@newman.upenn.edu |
5f05dabc | 264 | |
265 | =head1 VERSION | |
266 | ||
692dce08 | 267 | 1.05 12-Feb-2011 |
5f05dabc | 268 | |
269 | =head1 BUGS | |
270 | ||
271 | The list of symbols for the iterator is assembled by spawning off a | |
272 | subprocess, which can be slow. Ideally, we should just traverse the | |
273 | process' symbol table directly from C. | |
274 |