error when trying to init a stash slot with a value of the wrong type
[gitmo/Package-Stash-PP.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) = @_;
44 return bless { package => $namespace }, $class;
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
207 # FIXME
30d1a098 208 if (!exists $namespace->{$name}) {
209 my $initial = $type eq 'ARRAY' ? []
210 : $type eq 'HASH' ? {}
211 : \undef;
212 $self->add_package_symbol($variable, $initial)
213 }
f10f6217 214
215 my $entry_ref = \$namespace->{$name};
216
217 if (ref($entry_ref) eq 'GLOB') {
218 return *{$entry_ref}{$type};
219 }
220 else {
221 if ($type eq 'CODE') {
222 no strict 'refs';
223 return \&{ $self->name . '::' . $name };
224 }
225 else {
226 return undef;
227 }
228 }
229}
230
683542f5 231=head2 remove_package_symbol $variable
232
233Removes the package variable described by C<$variable> (which includes the
234sigil); other variables with the same name but different sigils will be
235untouched.
236
237=cut
238
f10f6217 239sub remove_package_symbol {
240 my ($self, $variable) = @_;
241
242 my ($name, $sigil, $type) = ref $variable eq 'HASH'
243 ? @{$variable}{qw[name sigil type]}
244 : $self->_deconstruct_variable_name($variable);
245
246 # FIXME:
247 # no doubt this is grossly inefficient and
248 # could be done much easier and faster in XS
249
b1a00d0e 250 my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
f10f6217 251 { sigil => '$', type => 'SCALAR', name => $name },
252 { sigil => '@', type => 'ARRAY', name => $name },
253 { sigil => '%', type => 'HASH', name => $name },
254 { sigil => '&', type => 'CODE', name => $name },
b1a00d0e 255 { sigil => '', type => 'IO', name => $name },
f10f6217 256 );
257
b1a00d0e 258 my ($scalar, $array, $hash, $code, $io);
f10f6217 259 if ($type eq 'SCALAR') {
260 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
261 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
262 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
b1a00d0e 263 $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
f10f6217 264 }
265 elsif ($type eq 'ARRAY') {
266 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
267 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
268 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
b1a00d0e 269 $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
f10f6217 270 }
271 elsif ($type eq 'HASH') {
272 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
273 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
274 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
b1a00d0e 275 $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
f10f6217 276 }
277 elsif ($type eq 'CODE') {
278 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
279 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
280 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
b1a00d0e 281 $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc);
282 }
283 elsif ($type eq 'IO') {
284 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
285 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
286 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
287 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
f10f6217 288 }
289 else {
290 confess "This should never ever ever happen";
291 }
292
293 $self->remove_package_glob($name);
294
295 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
296 $self->add_package_symbol($array_desc => $array) if defined $array;
297 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
298 $self->add_package_symbol($code_desc => $code) if defined $code;
b1a00d0e 299 $self->add_package_symbol($io_desc => $io) if defined $io;
f10f6217 300}
301
683542f5 302=head2 list_all_package_symbols $type_filter
303
304Returns a list of package variable names in the package, without sigils. If a
305C<type_filter> is passed, it is used to select package variables of a given
306type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
307etc).
308
309=cut
310
f10f6217 311sub list_all_package_symbols {
312 my ($self, $type_filter) = @_;
313
314 my $namespace = $self->namespace;
315 return keys %{$namespace} unless defined $type_filter;
316
317 # NOTE:
318 # or we can filter based on
319 # type (SCALAR|ARRAY|HASH|CODE)
320 if ($type_filter eq 'CODE') {
321 return grep {
322 (ref($namespace->{$_})
323 ? (ref($namespace->{$_}) eq 'SCALAR')
324 : (ref(\$namespace->{$_}) eq 'GLOB'
325 && defined(*{$namespace->{$_}}{CODE})));
326 } keys %{$namespace};
327 } else {
328 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
329 }
330}
f4979588 331
332=head1 BUGS
333
334No known bugs.
335
336Please report any bugs through RT: email
337C<bug-stash-manip at rt.cpan.org>, or browse to
338L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Stash-Manip>.
339
340=head1 SEE ALSO
341
683542f5 342L<Class::MOP::Package> - this module is a factoring out of code that used to
343live here
f4979588 344
345=head1 SUPPORT
346
347You can find this documentation for this module with the perldoc command.
348
349 perldoc Stash::Manip
350
351You can also look for information at:
352
353=over 4
354
355=item * AnnoCPAN: Annotated CPAN documentation
356
357L<http://annocpan.org/dist/Stash-Manip>
358
359=item * CPAN Ratings
360
361L<http://cpanratings.perl.org/d/Stash-Manip>
362
363=item * RT: CPAN's request tracker
364
365L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Stash-Manip>
366
367=item * Search CPAN
368
369L<http://search.cpan.org/dist/Stash-Manip>
370
371=back
372
373=head1 AUTHOR
374
375 Jesse Luehrs <doy at tozt dot net>
376
683542f5 377Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
378Moose Cabal.
379
f4979588 380=head1 COPYRIGHT AND LICENSE
381
382This software is copyright (c) 2010 by Jesse Luehrs.
383
384This is free software; you can redistribute it and/or modify it under
385the same terms as perl itself.
386
387=cut
388
3891;