1package VMS::DCLsym;
2
3use Carp;
4use DynaLoader;
5use strict;
6
7# Package globals
8our @ISA = ( 'DynaLoader' );
9our $VERSION = '1.09';              # remember to update version in POD!
10my(%Locsyms) = ( ':ID' => 'LOCAL' );
11my(%Gblsyms) = ( ':ID' => 'GLOBAL');
12my $DoCache = 1;
13my $Cache_set = 0;
14
15
16#====> OO methods
17
18sub new {
19  my($pkg,$type) = @_;
20  $type ||= 'LOCAL';
21  $type = 'LOCAL' unless $type eq 'GLOBAL';
22  bless { TYPE => $type }, $pkg;
23}
24
25sub DESTROY { }
26
27sub getsym {
28  my($self,$name) = @_;
29  my($val,$table);
30
31  if (($val,$table) = _getsym($name)) {
32    if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
33    else                    { $Locsyms{$name} = $val; }
34  }
35  wantarray ? ($val,$table) : $val;
36}
37
38sub setsym {
39  my($self,$name,$val,$table) = @_;
40
41  $table = $self->{TYPE} unless $table;
42  if (_setsym($name,$val,$table)) {
43    if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
44    else                    { $Locsyms{$name} = $val; }
45    1;
46  }
47  else { 0; }
48}
49
50sub delsym {
51  my($self,$name,$table) = @_;
52
53  $table = $self->{TYPE} unless $table;
54  if (_delsym($name,$table)) {
55    if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; }
56    else                    { delete $Locsyms{$name}; }
57    1;
58  }
59  else { 0; }
60}
61
62sub clearcache {
63  my($self,$perm) = @_;
64  my($old);
65
66  $Cache_set = 0;
67  %Locsyms = ( ':ID' => 'LOCAL');
68  %Gblsyms = ( ':ID' => 'GLOBAL');
69  $old = $DoCache;
70  $DoCache = $perm if defined($perm);
71  $old;
72}
73
74#====> TIEHASH methods
75
76sub TIEHASH {
77  shift->new(@_);
78}
79
80sub FETCH {
81  my($self,$name) = @_;
82  if    ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; }
83  elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL';  }
84  else                       { scalar($self->getsym($name)); }
85}
86
87sub STORE {
88  my($self,$name,$val) = @_;
89  if    ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; }
90  elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL';  }
91  else                       { $self->setsym($name,$val); }
92}
93
94sub DELETE {
95  my($self,$name) = @_;
96
97  $self->delsym($name);
98}
99
100sub FIRSTKEY {
101  my($self) = @_;
102  my($name,$eqs,$val);
103
104  if (!$DoCache || !$Cache_set) {
105    # We should eventually replace this with a C routine which walks the
106    # CLI symbol table directly.  If I ever get 'hold of an I&DS manual . . .
107    open(P, '-|', 'Show Symbol *');
108    while (<P>) {
109      ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/
110        or carp "VMS::DCLsym: unparseable line $_";
111      $name =~ s#\*##;
112      $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/;
113      if ($eqs eq '==') { $Gblsyms{$name} = $val; }
114      else              { $Locsyms{$name} = $val; }
115    }
116    close P;
117    $Cache_set = 1;
118  }
119  $self ->{IDX} = 0;
120  $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms;
121  while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
122    if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
123    $self->{CACHE} = \%Gblsyms;
124  }
125  $name;
126}
127
128sub NEXTKEY {
129  my($self) = @_;
130  my($name,$val);
131
132  while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
133    if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
134    $self->{CACHE} = \%Gblsyms;
135  }
136  $name;
137}
138
139
140sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 }
141
142sub CLEAR { }
143
144
145bootstrap VMS::DCLsym;
146
1471;
148
149__END__
150
151=head1 NAME
152
153VMS::DCLsym - Perl extension to manipulate DCL symbols
154
155=head1 SYNOPSIS
156
157  tie %allsyms, VMS::DCLsym;
158  tie %cgisyms, VMS::DCLsym, 'GLOBAL';
159
160
161  $handle = new VMS::DCLsym;
162  $value = $handle->getsym($name);
163  $handle->setsym($name, $value, 'GLOBAL')
164      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 the next
189paragraph), 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.09
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