6 use Scalar::Util qw(reftype);
23 return bless { package => $namespace }, $class;
27 return $_[0]->{package};
32 # because of issues with the Perl API
33 # to the typeglob in some versions, we
34 # need to just always grab a new
35 # reference to the hash here. Ideally
36 # we could just store a ref and it would
37 # Just Work, but oh well :\
39 return \%{$_[0]->name . '::'};
50 sub _deconstruct_variable_name {
51 my ($self, $variable) = @_;
54 || confess "You must pass a variable name";
56 my $sigil = substr($variable, 0, 1, '');
59 || confess "The variable name must include a sigil";
61 (exists $SIGIL_MAP{$sigil})
62 || confess "I do not recognize that sigil '$sigil'";
64 return ($variable, $sigil, $SIGIL_MAP{$sigil});
68 sub add_package_symbol {
69 my ($self, $variable, $initial_value) = @_;
71 my ($name, $sigil, $type) = ref $variable eq 'HASH'
72 ? @{$variable}{qw[name sigil type]}
73 : $self->_deconstruct_variable_name($variable);
75 my $pkg = $self->name;
78 no warnings 'redefine', 'misc', 'prototype';
79 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
82 sub remove_package_glob {
83 my ($self, $name) = @_;
85 delete ${$self->name . '::'}{$name};
88 # ... these functions deal with stuff on the namespace level
90 sub has_package_symbol {
91 my ($self, $variable) = @_;
93 my ($name, $sigil, $type) = ref $variable eq 'HASH'
94 ? @{$variable}{qw[name sigil type]}
95 : $self->_deconstruct_variable_name($variable);
97 my $namespace = $self->namespace;
99 return unless exists $namespace->{$name};
101 my $entry_ref = \$namespace->{$name};
102 if (reftype($entry_ref) eq 'GLOB') {
103 if ( $type eq 'SCALAR' ) {
104 return defined ${ *{$entry_ref}{SCALAR} };
107 return defined *{$entry_ref}{$type};
111 # a symbol table entry can be -1 (stub), string (stub with prototype),
112 # or reference (constant)
113 return $type eq 'CODE';
117 sub get_package_symbol {
118 my ($self, $variable) = @_;
120 my ($name, $sigil, $type) = ref $variable eq 'HASH'
121 ? @{$variable}{qw[name sigil type]}
122 : $self->_deconstruct_variable_name($variable);
124 my $namespace = $self->namespace;
127 $self->add_package_symbol($variable)
128 unless exists $namespace->{$name};
130 my $entry_ref = \$namespace->{$name};
132 if (ref($entry_ref) eq 'GLOB') {
133 return *{$entry_ref}{$type};
136 if ($type eq 'CODE') {
138 return \&{ $self->name . '::' . $name };
146 sub remove_package_symbol {
147 my ($self, $variable) = @_;
149 my ($name, $sigil, $type) = ref $variable eq 'HASH'
150 ? @{$variable}{qw[name sigil type]}
151 : $self->_deconstruct_variable_name($variable);
154 # no doubt this is grossly inefficient and
155 # could be done much easier and faster in XS
157 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
158 { sigil => '$', type => 'SCALAR', name => $name },
159 { sigil => '@', type => 'ARRAY', name => $name },
160 { sigil => '%', type => 'HASH', name => $name },
161 { sigil => '&', type => 'CODE', name => $name },
164 my ($scalar, $array, $hash, $code);
165 if ($type eq 'SCALAR') {
166 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
167 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
168 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
170 elsif ($type eq 'ARRAY') {
171 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
172 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
173 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
175 elsif ($type eq 'HASH') {
176 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
177 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
178 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
180 elsif ($type eq 'CODE') {
181 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
182 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
183 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
186 confess "This should never ever ever happen";
189 $self->remove_package_glob($name);
191 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
192 $self->add_package_symbol($array_desc => $array) if defined $array;
193 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
194 $self->add_package_symbol($code_desc => $code) if defined $code;
197 sub list_all_package_symbols {
198 my ($self, $type_filter) = @_;
200 my $namespace = $self->namespace;
201 return keys %{$namespace} unless defined $type_filter;
204 # or we can filter based on
205 # type (SCALAR|ARRAY|HASH|CODE)
206 if ($type_filter eq 'CODE') {
208 (ref($namespace->{$_})
209 ? (ref($namespace->{$_}) eq 'SCALAR')
210 : (ref(\$namespace->{$_}) eq 'GLOB'
211 && defined(*{$namespace->{$_}}{CODE})));
212 } keys %{$namespace};
214 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
222 Please report any bugs through RT: email
223 C<bug-stash-manip at rt.cpan.org>, or browse to
224 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Stash-Manip>.
231 You can find this documentation for this module with the perldoc command.
235 You can also look for information at:
239 =item * AnnoCPAN: Annotated CPAN documentation
241 L<http://annocpan.org/dist/Stash-Manip>
245 L<http://cpanratings.perl.org/d/Stash-Manip>
247 =item * RT: CPAN's request tracker
249 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Stash-Manip>
253 L<http://search.cpan.org/dist/Stash-Manip>
259 Jesse Luehrs <doy at tozt dot net>
261 =head1 COPYRIGHT AND LICENSE
263 This software is copyright (c) 2010 by Jesse Luehrs.
265 This is free software; you can redistribute it and/or modify it under
266 the same terms as perl itself.