Commit | Line | Data |
e94260da |
1 | package Package::Stash; |
f10f6217 |
2 | use strict; |
3 | use warnings; |
988beb41 |
4 | # ABSTRACT: routines for manipulating stashes |
f10f6217 |
5 | |
6 | use Carp qw(confess); |
7 | use Scalar::Util qw(reftype); |
f4979588 |
8 | |
f4979588 |
9 | =head1 SYNOPSIS |
10 | |
e94260da |
11 | my $stash = Package::Stash->new('Foo'); |
683542f5 |
12 | $stash->add_package_symbol('%foo', {bar => 1}); |
13 | # $Foo::foo{bar} == 1 |
14 | $stash->has_package_symbol('$foo') # false |
15 | my $namespace = $stash->namespace; |
16 | *{ $namespace->{foo} }{HASH} # {bar => 1} |
f4979588 |
17 | |
18 | =head1 DESCRIPTION |
19 | |
683542f5 |
20 | Manipulating stashes (Perl's symbol tables) is occasionally necessary, but |
21 | incredibly messy, and easy to get wrong. This module hides all of that behind a |
22 | simple API. |
23 | |
56a29840 |
24 | NOTE: Most methods in this class require a variable specification that includes |
25 | a sigil. If this sigil is absent, it is assumed to represent the IO slot. |
26 | |
988beb41 |
27 | =method new $package_name |
683542f5 |
28 | |
e94260da |
29 | Creates a new C<Package::Stash> object, for the package given as the only |
683542f5 |
30 | argument. |
f4979588 |
31 | |
32 | =cut |
33 | |
f10f6217 |
34 | sub new { |
35 | my $class = shift; |
36 | my ($namespace) = @_; |
60146e1c |
37 | return bless { 'package' => $namespace }, $class; |
f10f6217 |
38 | } |
39 | |
988beb41 |
40 | =method name |
683542f5 |
41 | |
42 | Returns the name of the package that this object represents. |
43 | |
44 | =cut |
45 | |
f10f6217 |
46 | sub name { |
47 | return $_[0]->{package}; |
48 | } |
49 | |
988beb41 |
50 | =method namespace |
683542f5 |
51 | |
52 | Returns the raw stash itself. |
53 | |
54 | =cut |
55 | |
f10f6217 |
56 | sub namespace { |
57 | # NOTE: |
9a3d1390 |
58 | # because of issues with the Perl API |
59 | # to the typeglob in some versions, we |
60 | # need to just always grab a new |
61 | # reference to the hash here. Ideally |
f10f6217 |
62 | # we could just store a ref and it would |
9a3d1390 |
63 | # Just Work, but oh well :\ |
f10f6217 |
64 | no strict 'refs'; |
65 | return \%{$_[0]->name . '::'}; |
66 | } |
67 | |
68 | { |
69 | my %SIGIL_MAP = ( |
70 | '$' => 'SCALAR', |
71 | '@' => 'ARRAY', |
72 | '%' => 'HASH', |
73 | '&' => 'CODE', |
56a29840 |
74 | '' => 'IO', |
f10f6217 |
75 | ); |
76 | |
77 | sub _deconstruct_variable_name { |
78 | my ($self, $variable) = @_; |
79 | |
56a29840 |
80 | (defined $variable && length $variable) |
f10f6217 |
81 | || confess "You must pass a variable name"; |
82 | |
83 | my $sigil = substr($variable, 0, 1, ''); |
84 | |
56a29840 |
85 | if (exists $SIGIL_MAP{$sigil}) { |
86 | return ($variable, $sigil, $SIGIL_MAP{$sigil}); |
87 | } |
88 | else { |
89 | return ("${sigil}${variable}", '', $SIGIL_MAP{''}); |
90 | } |
f10f6217 |
91 | } |
92 | } |
93 | |
988beb41 |
94 | =method add_package_symbol $variable $value %opts |
683542f5 |
95 | |
96 | Adds a new package symbol, for the symbol given as C<$variable>, and optionally |
97 | gives it an initial value of C<$value>. C<$variable> should be the name of |
98 | variable including the sigil, so |
99 | |
e94260da |
100 | Package::Stash->new('Foo')->add_package_symbol('%foo') |
683542f5 |
101 | |
102 | will create C<%Foo::foo>. |
103 | |
c61010aa |
104 | Valid options (all optional) are C<filename>, C<first_line_num>, and |
105 | C<last_line_num>. |
106 | |
107 | C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can |
108 | be used to indicate where the symbol should be regarded as having been defined. |
4ada57e0 |
109 | Currently these values are only used if the symbol is a subroutine ('C<&>' |
c61010aa |
110 | sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub> |
111 | hash is updated to record the values of C<filename>, C<first_line_num>, and |
112 | C<last_line_num> for the subroutine. If these are not passed, their values are |
113 | inferred (as much as possible) from C<caller> information. |
4ada57e0 |
114 | |
115 | This is especially useful for debuggers and profilers, which use C<%DB::sub> to |
116 | determine where the source code for a subroutine can be found. See |
117 | L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more |
118 | information about C<%DB::sub>. |
119 | |
683542f5 |
120 | =cut |
121 | |
3634ce60 |
122 | sub _valid_for_type { |
123 | my $self = shift; |
124 | my ($value, $type) = @_; |
125 | if ($type eq 'HASH' || $type eq 'ARRAY' |
126 | || $type eq 'IO' || $type eq 'CODE') { |
127 | return reftype($value) eq $type; |
128 | } |
129 | else { |
130 | my $ref = reftype($value); |
131 | return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE'; |
132 | } |
133 | } |
134 | |
f10f6217 |
135 | sub add_package_symbol { |
640de369 |
136 | my ($self, $variable, $initial_value, %opts) = @_; |
f10f6217 |
137 | |
138 | my ($name, $sigil, $type) = ref $variable eq 'HASH' |
139 | ? @{$variable}{qw[name sigil type]} |
140 | : $self->_deconstruct_variable_name($variable); |
141 | |
4ada57e0 |
142 | my $pkg = $self->name; |
143 | |
3634ce60 |
144 | if (@_ > 2) { |
145 | $self->_valid_for_type($initial_value, $type) |
146 | || confess "$initial_value is not of type $type"; |
3634ce60 |
147 | |
4ada57e0 |
148 | # cheap fail-fast check for PERLDBf_SUBLINE and '&' |
149 | if ($^P and $^P & 0x10 && $sigil eq '&') { |
640de369 |
150 | my $filename = $opts{filename}; |
151 | my $first_line_num = $opts{first_line_num}; |
4ada57e0 |
152 | |
640de369 |
153 | (undef, $filename, $first_line_num) = caller |
4ada57e0 |
154 | if not defined $filename; |
640de369 |
155 | |
156 | my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0); |
4ada57e0 |
157 | |
158 | # http://perldoc.perl.org/perldebguts.html#Debugger-Internals |
640de369 |
159 | $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num"; |
4ada57e0 |
160 | } |
161 | } |
f10f6217 |
162 | |
163 | no strict 'refs'; |
164 | no warnings 'redefine', 'misc', 'prototype'; |
165 | *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; |
166 | } |
167 | |
988beb41 |
168 | =method remove_package_glob $name |
683542f5 |
169 | |
170 | Removes all package variables with the given name, regardless of sigil. |
171 | |
172 | =cut |
173 | |
f10f6217 |
174 | sub remove_package_glob { |
175 | my ($self, $name) = @_; |
176 | no strict 'refs'; |
177 | delete ${$self->name . '::'}{$name}; |
178 | } |
179 | |
180 | # ... these functions deal with stuff on the namespace level |
181 | |
988beb41 |
182 | =method has_package_symbol $variable |
683542f5 |
183 | |
184 | Returns whether or not the given package variable (including sigil) exists. |
185 | |
186 | =cut |
187 | |
f10f6217 |
188 | sub has_package_symbol { |
189 | my ($self, $variable) = @_; |
190 | |
191 | my ($name, $sigil, $type) = ref $variable eq 'HASH' |
192 | ? @{$variable}{qw[name sigil type]} |
193 | : $self->_deconstruct_variable_name($variable); |
194 | |
195 | my $namespace = $self->namespace; |
196 | |
197 | return unless exists $namespace->{$name}; |
198 | |
199 | my $entry_ref = \$namespace->{$name}; |
200 | if (reftype($entry_ref) eq 'GLOB') { |
201 | if ( $type eq 'SCALAR' ) { |
202 | return defined ${ *{$entry_ref}{SCALAR} }; |
203 | } |
204 | else { |
205 | return defined *{$entry_ref}{$type}; |
206 | } |
207 | } |
208 | else { |
209 | # a symbol table entry can be -1 (stub), string (stub with prototype), |
210 | # or reference (constant) |
211 | return $type eq 'CODE'; |
212 | } |
213 | } |
214 | |
988beb41 |
215 | =method get_package_symbol $variable |
683542f5 |
216 | |
217 | Returns the value of the given package variable (including sigil). |
218 | |
219 | =cut |
220 | |
f10f6217 |
221 | sub get_package_symbol { |
e55803fc |
222 | my ($self, $variable, %opts) = @_; |
f10f6217 |
223 | |
224 | my ($name, $sigil, $type) = ref $variable eq 'HASH' |
225 | ? @{$variable}{qw[name sigil type]} |
226 | : $self->_deconstruct_variable_name($variable); |
227 | |
228 | my $namespace = $self->namespace; |
229 | |
30d1a098 |
230 | if (!exists $namespace->{$name}) { |
e55803fc |
231 | # assigning to the result of this function like |
232 | # @{$stash->get_package_symbol('@ISA')} = @new_ISA |
233 | # makes the result not visible until the variable is explicitly |
234 | # accessed... in the case of @ISA, this might never happen |
235 | # for instance, assigning like that and then calling $obj->isa |
236 | # will fail. see t/005-isa.t |
237 | if ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') { |
238 | $self->add_package_symbol($variable, []); |
239 | } |
240 | elsif ($opts{vivify} && $type eq 'HASH') { |
241 | $self->add_package_symbol($variable, {}); |
242 | } |
243 | else { |
244 | # FIXME |
245 | $self->add_package_symbol($variable) |
246 | } |
30d1a098 |
247 | } |
f10f6217 |
248 | |
249 | my $entry_ref = \$namespace->{$name}; |
250 | |
251 | if (ref($entry_ref) eq 'GLOB') { |
252 | return *{$entry_ref}{$type}; |
253 | } |
254 | else { |
255 | if ($type eq 'CODE') { |
256 | no strict 'refs'; |
257 | return \&{ $self->name . '::' . $name }; |
258 | } |
259 | else { |
260 | return undef; |
261 | } |
262 | } |
263 | } |
264 | |
988beb41 |
265 | =method get_or_add_package_symbol $variable |
e55803fc |
266 | |
267 | Like C<get_package_symbol>, except that it will return an empty hashref or |
268 | arrayref if the variable doesn't exist. |
269 | |
270 | =cut |
271 | |
272 | sub get_or_add_package_symbol { |
273 | my $self = shift; |
274 | $self->get_package_symbol(@_, vivify => 1); |
275 | } |
276 | |
988beb41 |
277 | =method remove_package_symbol $variable |
683542f5 |
278 | |
279 | Removes the package variable described by C<$variable> (which includes the |
280 | sigil); other variables with the same name but different sigils will be |
281 | untouched. |
282 | |
283 | =cut |
284 | |
f10f6217 |
285 | sub remove_package_symbol { |
286 | my ($self, $variable) = @_; |
287 | |
288 | my ($name, $sigil, $type) = ref $variable eq 'HASH' |
289 | ? @{$variable}{qw[name sigil type]} |
290 | : $self->_deconstruct_variable_name($variable); |
291 | |
292 | # FIXME: |
9a3d1390 |
293 | # no doubt this is grossly inefficient and |
f10f6217 |
294 | # could be done much easier and faster in XS |
295 | |
b1a00d0e |
296 | my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = ( |
f10f6217 |
297 | { sigil => '$', type => 'SCALAR', name => $name }, |
298 | { sigil => '@', type => 'ARRAY', name => $name }, |
299 | { sigil => '%', type => 'HASH', name => $name }, |
300 | { sigil => '&', type => 'CODE', name => $name }, |
b1a00d0e |
301 | { sigil => '', type => 'IO', name => $name }, |
f10f6217 |
302 | ); |
303 | |
b1a00d0e |
304 | my ($scalar, $array, $hash, $code, $io); |
f10f6217 |
305 | if ($type eq 'SCALAR') { |
306 | $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); |
307 | $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); |
308 | $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); |
b1a00d0e |
309 | $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); |
f10f6217 |
310 | } |
311 | elsif ($type eq 'ARRAY') { |
42fa5cfc |
312 | $scalar = $self->get_package_symbol($scalar_desc); |
f10f6217 |
313 | $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); |
314 | $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); |
b1a00d0e |
315 | $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); |
f10f6217 |
316 | } |
317 | elsif ($type eq 'HASH') { |
42fa5cfc |
318 | $scalar = $self->get_package_symbol($scalar_desc); |
f10f6217 |
319 | $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); |
320 | $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); |
b1a00d0e |
321 | $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); |
f10f6217 |
322 | } |
323 | elsif ($type eq 'CODE') { |
42fa5cfc |
324 | $scalar = $self->get_package_symbol($scalar_desc); |
f10f6217 |
325 | $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); |
326 | $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); |
b1a00d0e |
327 | $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); |
328 | } |
329 | elsif ($type eq 'IO') { |
42fa5cfc |
330 | $scalar = $self->get_package_symbol($scalar_desc); |
b1a00d0e |
331 | $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); |
332 | $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); |
333 | $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); |
f10f6217 |
334 | } |
335 | else { |
336 | confess "This should never ever ever happen"; |
337 | } |
338 | |
339 | $self->remove_package_glob($name); |
340 | |
42fa5cfc |
341 | $self->add_package_symbol($scalar_desc => $scalar); |
f10f6217 |
342 | $self->add_package_symbol($array_desc => $array) if defined $array; |
343 | $self->add_package_symbol($hash_desc => $hash) if defined $hash; |
344 | $self->add_package_symbol($code_desc => $code) if defined $code; |
b1a00d0e |
345 | $self->add_package_symbol($io_desc => $io) if defined $io; |
f10f6217 |
346 | } |
347 | |
988beb41 |
348 | =method list_all_package_symbols $type_filter |
683542f5 |
349 | |
350 | Returns a list of package variable names in the package, without sigils. If a |
351 | C<type_filter> is passed, it is used to select package variables of a given |
352 | type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', |
353 | etc). |
354 | |
355 | =cut |
356 | |
f10f6217 |
357 | sub list_all_package_symbols { |
358 | my ($self, $type_filter) = @_; |
359 | |
360 | my $namespace = $self->namespace; |
361 | return keys %{$namespace} unless defined $type_filter; |
362 | |
363 | # NOTE: |
9a3d1390 |
364 | # or we can filter based on |
f10f6217 |
365 | # type (SCALAR|ARRAY|HASH|CODE) |
366 | if ($type_filter eq 'CODE') { |
367 | return grep { |
368 | (ref($namespace->{$_}) |
369 | ? (ref($namespace->{$_}) eq 'SCALAR') |
370 | : (ref(\$namespace->{$_}) eq 'GLOB' |
371 | && defined(*{$namespace->{$_}}{CODE}))); |
372 | } keys %{$namespace}; |
373 | } else { |
374 | return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace}; |
375 | } |
376 | } |
f4979588 |
377 | |
f4979588 |
378 | =head1 SEE ALSO |
379 | |
f4979588 |
380 | =over 4 |
381 | |
988beb41 |
382 | =item * L<Class::MOP::Package> |
f4979588 |
383 | |
988beb41 |
384 | This module is a factoring out of code that used to live here |
f4979588 |
385 | |
386 | =back |
387 | |
f4979588 |
388 | =cut |
389 | |
390 | 1; |