File Coverage

blib/lib/Symbol/Table.pm
Criterion Covered Total %
statement 307 324 94.7
branch 16 26 61.5
condition n/a
subroutine 88 93 94.6
pod 0 7 0.0
total 411 450 91.3


line stmt bran cond sub pod time code
1             package Symbol::Table;
2              
3 5     5   125836 use 5.008;
  5         20  
  5         207  
4              
5 5     5   31 use strict;
  5         10  
  5         212  
6 5     5   24 use warnings;
  5         31  
  5         155  
7 5     5   4498 use Data::Dumper;
  5         52741  
  5         418  
8 5     5   64 use Carp;
  5         11  
  5         7725  
9              
10             our $VERSION = '1.01';
11              
12             #########################################################################
13             sub _callers_package_name
14             #########################################################################
15             {
16             # @_ contains 0 or 1 item
17             # item is a string containing the name of the package
18             # whose symbol table we want to create.
19             # note: package name looks like a regular perl package name,
20             # it does NOT look like a perl symbol table name
21             # i.e. use 'main::mypackage', dont use 'main::mypackage::'
22             # if item is missing, use package name of caller.
23              
24 5     5   10 my $pkg_name;
25 5 100       20 if(scalar(@_)==1)
26             {
27             # if caller passes in a package
28 3         10 $pkg_name=shift(@_) ;
29             }
30             else
31             {
32             # by default, create a symbol table for callers package
33 2         14 $pkg_name='main::'. ((caller(1))[0]);
34             }
35              
36 5 50       95 unless($pkg_name=~m{^[\w:]+$})
37             {
38 0         0 croak "bad package name '$pkg_name'";
39             }
40              
41 5         15 return $pkg_name;
42             }
43              
44              
45             my %warehouse;
46              
47             # no GLOB and no NAME
48             my @element_types_array = qw(SCALAR ARRAY HASH CODE );
49             sub ElementTypes
50             {
51 0     0 0 0 return (@element_types_array);
52             }
53              
54             my @hierarchy_types_array = qw(PACKAGE);
55             sub HierarchyTypes
56             {
57 0     0 0 0 return (@hierarchy_types_array);
58             }
59              
60             sub AllTypes
61             {
62 5     5 0 17 return (@element_types_array, @hierarchy_types_array);
63             }
64              
65              
66             my %valid_type_hash;
67             map{$valid_type_hash{$_}=1;} AllTypes;
68              
69             #########################################################################
70             # Create a tied hash that access things of a particular type in symbol table
71             # (type is scalar, array, hash, code, glob, filehandle, name, package)
72             #########################################################################
73             sub New
74             {
75 5     5 0 660 my $class=shift(@_);
76              
77 5         11 my $type = 'PACKAGE';
78 5 50       26 $type = shift(@_) if (scalar(@_));
79              
80 5 50       27 unless(exists($valid_type_hash{$type}))
81             {
82 0         0 print "I can handle the following types "
83             .join(" ", AllTypes)."\n";
84 0         0 croak "Error: bad type '$type'";
85             }
86              
87              
88 5         26 my $pkg_name = _callers_package_name(@_);
89              
90 5         12 my %hash;
91 5         50 tie %hash, 'Symbol::Table::Tie', $pkg_name.'::', $type;
92              
93 5         11 my $ref = \%hash;
94              
95 5         13 bless $ref, $class;
96              
97 5         45 $warehouse{$ref}=
98             {
99             PackageName => $pkg_name,
100             Type => $type,
101             };
102              
103 5         38 return $ref;
104            
105             }
106              
107              
108             sub Package
109             {
110 0     0 0 0 return $warehouse{$_[0]}->{PackageName};
111             }
112              
113             sub Type
114             {
115 0     0 0 0 return $warehouse{$_[0]}->{Type};
116             }
117              
118             sub InvoiceWarehouse
119             {
120 0     0 0 0 print Dumper \%warehouse;
121             }
122              
123             sub DESTROY
124             {
125 5     5   4647 my $obj=$_[0];
126 5         46 delete($warehouse{$_[0]});
127             }
128              
129             #########################################################################
130             #########################################################################
131             package Symbol::Table::Tie;
132             #########################################################################
133             #########################################################################
134 5     5   62 use Data::Dumper;
  5         10  
  5         287  
135 5     5   25 use Carp;
  5         12  
  5         1720  
136              
137 51     51   223 sub SYMBOL_TABLE_NAME {0;} # main::mypackage::subpackage::
138 17     17   42 sub SYMBOL_TABLE_TYPE {1;} # CODE or ARRAY etc
139              
140              
141             sub debugging
142             {
143 139 50   139   850 return unless($::DEBUG);
144              
145 0         0 my ($pkg, $filename, $linenum) = caller(0);
146              
147 0         0 my $suffix = " at $filename line $linenum\n";
148              
149 0         0 my $msg = shift(@_);
150              
151 0         0 $msg .= $suffix;
152              
153 0         0 warn $msg;
154             }
155              
156              
157             sub TIEHASH
158             {
159 5     5   22 debugging( "TIEHASH" );
160 5         38 debugging Dumper \@_;
161              
162 5         47 my ($class, $st_name, $type)=@_;
163              
164 5         11 my $st_package = $st_name;
165 5         33 $st_package =~ s{::$}{};
166              
167 5         13 my $obj=[];
168 5         22 $obj->[SYMBOL_TABLE_NAME]=$st_name;
169 5         22 $obj->[SYMBOL_TABLE_TYPE]=$type;
170              
171 5         29 return bless $obj, $class;
172             }
173              
174              
175              
176             sub DESTROY
177             {
178 5     5   20 debugging "DESTROY";
179 5         570 my ($obj)=@_;
180              
181             }
182              
183             sub FETCH
184             {
185 5     5   28 no strict; no warnings;
  5     5   9  
  5         221  
  5         25  
  5         10  
  5         4331  
186              
187 1     1   9 my ($obj, $key)=@_;
188 1         8 debugging "FETCH: looking for key '$key' in ". $obj;
189              
190 1 50       3 if($obj->[SYMBOL_TABLE_TYPE] eq 'PACKAGE')
191             {
192 0         0 my $new_package_name = $obj->[SYMBOL_TABLE_NAME] . $key;
193 0         0 debugging "new_package_name is $new_package_name";
194 0         0 my $new_obj =
195             Symbol::Table->New('PACKAGE', $new_package_name );
196 0         0 return $new_obj;
197             }
198             else
199             {
200 1         2 local *local_val;
201 1         3 my $eval=
202             '*local_val = $'
203             . $obj->[SYMBOL_TABLE_NAME]
204             . "{$key};";
205            
206 1         3 debugging "eval is >>>$eval<<<\n";
207 1         76 eval($eval);
208            
209 1         5 my $st_type = $obj->[SYMBOL_TABLE_TYPE];
210            
211 1         2 my $ret = *local_val{$st_type};
212 1         4 return $ret;
213             }
214              
215              
216             }
217              
218             sub STORE
219             {
220 3     3   802 debugging "STORE";
221 3         7 my ($obj, $key, $value)=@_;
222              
223 3         17 my $st_type = $obj->[SYMBOL_TABLE_TYPE];
224              
225 3         7 my $val_type = ref($value);
226 3 50       27 croak "Must store a reference, not value '$value'"
227             unless($val_type);
228              
229 3 50       11 croak "Type mismatch, $st_type ne $val_type"
230             if ($st_type ne $val_type);
231              
232 3         9 my $eval='*' . $obj->[SYMBOL_TABLE_NAME] . $key."=\$value;";
233              
234 3         20 debugging "eval is >>>$eval<<<\n";
235 3         236 eval($eval);
236              
237              
238             }
239              
240             sub FIRSTKEY
241             {
242 2     2   24 debugging "FIRSTKEY";
243 2         4 my ($obj)=@_;
244              
245 2         13 my $eval='@keys = keys( %'.$obj->[SYMBOL_TABLE_TYPE].');';
246 2         9 debugging "eval is >>>$eval<<<";
247 2         187 eval($eval);
248              
249 2         15 return $obj->NEXTKEY(); #prevkey doesnt matter
250              
251             }
252              
253              
254             my %pass_condition_for_type =
255             (
256             SCALAR => '$boolean=1 if(defined($sym));' ,
257             ARRAY => '$boolean=1 if(defined(@sym));' ,
258             HASH => '$boolean=1 if(defined(%sym));' ,
259             CODE => '$boolean=1 if(defined(&sym));' ,
260             PACKAGE=> '$boolean=1 if($key=~m{::$});' ,
261             );
262              
263             sub NEXTKEY
264             {
265 5     5   18 debugging "NEXTKEY";
266 5         10 my ($obj, $prevkey)=@_; # prev key is ignored
267              
268 5         22 my $st_type = $obj->[SYMBOL_TABLE_TYPE];
269 5         12 my $st_name = $obj->[SYMBOL_TABLE_NAME];
270              
271 5 50       22 die "Error: no pass condition defined for type '$st_type'"
272             unless(exists($pass_condition_for_type{$st_type}));
273              
274 5         8 my ($eval, @keys, $key, $val, $bool);
275              
276 5         13 local *sym;
277              
278 5         8 while(1)
279             {
280 37         266 $eval ='($key, $val) =
281             each( %'. $obj->[SYMBOL_TABLE_NAME] .');';
282 37         95 debugging "eval is >>>$eval<<<";
283 37         2337 eval($eval);
284              
285 37 100       152 return undef unless(defined($key));
286 35 50       110 next if($key =~ m{^(_|[^\w])});
287              
288             # main:: symbol table contains a reference to itself.
289             # which means you get infinitely recursive symbol tables.
290             # main::main::main::main:: etc
291             # which isn't very useful.
292             # if the key is 'main::' just ignore it and
293             # look for the next one
294 35 50       71 next if($key eq 'main::');
295              
296 35         41 my $boolean=0;
297              
298 35         45 $eval = 'no warnings; no strict;';
299 35         68 $eval .= ' *sym = $'.$st_name.'{'.$key.'}; ' ;
300 35         54 $eval .= $pass_condition_for_type{$st_type};
301              
302 35         84 debugging "eval is >>>$eval<<<";
303 35     2   1821 eval($eval);
  2     2   17  
  2     2   3  
  2     2   111  
  2     1   10  
  2     1   4  
  2     1   148  
  2     1   11  
  2     1   4  
  2     1   76  
  2     1   10  
  2     1   3  
  2     1   107  
  1     1   5  
  1     1   2  
  1     1   35  
  1     1   4  
  1     1   2  
  1     1   43  
  1     1   6  
  1     1   2  
  1     1   26  
  1     1   5  
  1     1   1  
  1     1   43  
  1     1   5  
  1     1   1  
  1     1   28  
  1     1   4  
  1     1   2  
  1     1   68  
  1     1   5  
  1     1   2  
  1     1   36  
  1     1   4  
  1     1   2  
  1     1   38  
  1     1   5  
  1     1   1  
  1     1   32  
  1     1   5  
  1     1   2  
  1     1   41  
  1     1   5  
  1     1   1  
  1     1   27  
  1     1   5  
  1     1   1  
  1     1   42  
  1     1   5  
  1     1   2  
  1     1   27  
  1     1   5  
  1     1   2  
  1     1   45  
  1     1   5  
  1     1   2  
  1     1   36  
  1     1   5  
  1     1   1  
  1     1   36  
  1     1   41  
  1     1   2  
  1     1   30  
  1     1   5  
  1     1   1  
  1         38  
  1         5  
  1         1  
  1         47  
  1         5  
  1         1  
  1         42  
  1         12  
  1         2  
  1         31  
  1         6  
  1         1  
  1         52  
  1         6  
  1         1  
  1         29  
  1         5  
  1         2  
  1         48  
  1         5  
  1         3  
  1         30  
  1         5  
  1         15  
  1         50  
  1         6  
  1         1  
  1         31  
  1         5  
  1         2  
  1         55  
  1         5  
  1         2  
  1         31  
  1         5  
  1         2  
  1         49  
  1         6  
  1         1  
  1         42  
  1         5  
  1         2  
  1         41  
  1         5  
  1         2  
  1         37  
  1         5  
  1         1  
  1         47  
  1         6  
  1         1  
  1         39  
  1         4  
  1         2  
  1         47  
  1         5  
  1         8  
  1         26  
  1         4  
  1         2  
  1         39  
  1         5  
  1         2  
  1         32  
  1         4  
  1         2  
  1         36  
  1         4  
  1         2  
  1         26  
  1         5  
  1         1  
  1         42  
  1         4  
  1         3  
  1         26  
  1         4  
  1         1  
  1         41  
  1         5  
  1         1  
  1         39  
  1         5  
  1         2  
  1         64  
  1         5  
  1         2  
  1         26  
  1         4  
  1         2  
  1         37  
  1         5  
  1         1  
  1         26  
  1         4  
  1         2  
  1         45  
  1         5  
  1         3  
  1         42  
  1         5  
  1         1  
  1         44  
  1         6  
  1         2  
  1         34  
  1         5  
  1         2  
  1         40  
  1         5  
  1         1  
  1         32  
  1         5  
  1         2  
  1         36  
  1         5  
  1         2  
  1         35  
  1         5  
  1         1  
  1         43  
  1         5  
  1         1  
  1         33  
  1         5  
  1         1  
  1         41  
  1         4  
  1         2  
  1         26  
  1         5  
  1         1  
  1         43  
304              
305 35         119 debugging "boolean is $boolean";
306              
307 35         68 $key =~ s{::$}{};
308              
309 35 100       89 return $key if ($boolean);
310              
311             }
312              
313             }
314              
315              
316             1;
317              
318              
319              
320              
321             1;
322             __END__