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