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