lib/Stash/Manip.pm

   1 package Stash::Manip;
   2 use strict;
   3 use warnings;
   4
   5 use Carp qw(confess);
   6 use Scalar::Util qw(reftype);
   7
   8 =head1 NAME
   9
  10 Stash::Manip -
  11
  12 =head1 SYNOPSIS
  13
  14
  15 =head1 DESCRIPTION
  16
  17
  18 =cut
  19
  20 sub new {
  21     my $class = shift;
  22     my ($namespace) = @_;
  23     return bless { package => $namespace }, $class;
  24 }
  25
  26 sub name {
  27     return $_[0]->{package};
  28 }
  29
  30 sub namespace {
  31     # NOTE:
  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 :\
  38     no strict 'refs';
  39     return \%{$_[0]->name . '::'};
  40 }
  41
  42 {
  43     my %SIGIL_MAP = (
  44         '$' => 'SCALAR',
  45         '@' => 'ARRAY',
  46         '%' => 'HASH',
  47         '&' => 'CODE',
  48     );
  49
  50     sub _deconstruct_variable_name {
  51         my ($self, $variable) = @_;
  52
  53         (defined $variable)
  54             || confess "You must pass a variable name";
  55
  56         my $sigil = substr($variable, 0, 1, '');
  57
  58         (defined $sigil)
  59             || confess "The variable name must include a sigil";
  60
  61         (exists $SIGIL_MAP{$sigil})
  62             || confess "I do not recognize that sigil '$sigil'";
  63
  64         return ($variable, $sigil, $SIGIL_MAP{$sigil});
  65     }
  66 }
  67
  68 sub add_package_symbol {
  69     my ($self, $variable, $initial_value) = @_;
  70
  71     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  72         ? @{$variable}{qw[name sigil type]}
  73         : $self->_deconstruct_variable_name($variable);
  74
  75     my $pkg = $self->name;
  76
  77     no strict 'refs';
  78     no warnings 'redefine', 'misc', 'prototype';
  79     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
  80 }
  81
  82 sub remove_package_glob {
  83     my ($self, $name) = @_;
  84     no strict 'refs';
  85     delete ${$self->name . '::'}{$name};
  86 }
  87
  88 # ... these functions deal with stuff on the namespace level
  89
  90 sub has_package_symbol {
  91     my ($self, $variable) = @_;
  92
  93     my ($name, $sigil, $type) = ref $variable eq 'HASH'
  94         ? @{$variable}{qw[name sigil type]}
  95         : $self->_deconstruct_variable_name($variable);
  96
  97     my $namespace = $self->namespace;
  98
  99     return unless exists $namespace->{$name};
 100
 101     my $entry_ref = \$namespace->{$name};
 102     if (reftype($entry_ref) eq 'GLOB') {
 103         if ( $type eq 'SCALAR' ) {
 104             return defined ${ *{$entry_ref}{SCALAR} };
 105         }
 106         else {
 107             return defined *{$entry_ref}{$type};
 108         }
 109     }
 110     else {
 111         # a symbol table entry can be -1 (stub), string (stub with prototype),
 112         # or reference (constant)
 113         return $type eq 'CODE';
 114     }
 115 }
 116
 117 sub get_package_symbol {
 118     my ($self, $variable) = @_;
 119
 120     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 121         ? @{$variable}{qw[name sigil type]}
 122         : $self->_deconstruct_variable_name($variable);
 123
 124     my $namespace = $self->namespace;
 125
 126     # FIXME
 127     $self->add_package_symbol($variable)
 128         unless exists $namespace->{$name};
 129
 130     my $entry_ref = \$namespace->{$name};
 131
 132     if (ref($entry_ref) eq 'GLOB') {
 133         return *{$entry_ref}{$type};
 134     }
 135     else {
 136         if ($type eq 'CODE') {
 137             no strict 'refs';
 138             return \&{ $self->name . '::' . $name };
 139         }
 140         else {
 141             return undef;
 142         }
 143     }
 144 }
 145
 146 sub remove_package_symbol {
 147     my ($self, $variable) = @_;
 148
 149     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 150         ? @{$variable}{qw[name sigil type]}
 151         : $self->_deconstruct_variable_name($variable);
 152
 153     # FIXME:
 154     # no doubt this is grossly inefficient and
 155     # could be done much easier and faster in XS
 156
 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 },
 162     );
 163
 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);
 169     }
 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);
 174     }
 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);
 179     }
 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);
 184     }
 185     else {
 186         confess "This should never ever ever happen";
 187     }
 188
 189     $self->remove_package_glob($name);
 190
 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;
 195 }
 196
 197 sub list_all_package_symbols {
 198     my ($self, $type_filter) = @_;
 199
 200     my $namespace = $self->namespace;
 201     return keys %{$namespace} unless defined $type_filter;
 202
 203     # NOTE:
 204     # or we can filter based on
 205     # type (SCALAR|ARRAY|HASH|CODE)
 206     if ($type_filter eq 'CODE') {
 207         return grep {
 208             (ref($namespace->{$_})
 209                 ? (ref($namespace->{$_}) eq 'SCALAR')
 210                 : (ref(\$namespace->{$_}) eq 'GLOB'
 211                    && defined(*{$namespace->{$_}}{CODE})));
 212         } keys %{$namespace};
 213     } else {
 214         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 215     }
 216 }
 217
 218 =head1 BUGS
 219
 220 No known bugs.
 221
 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>.
 225
 226 =head1 SEE ALSO
 227
 228
 229 =head1 SUPPORT
 230
 231 You can find this documentation for this module with the perldoc command.
 232
 233     perldoc Stash::Manip
 234
 235 You can also look for information at:
 236
 237 =over 4
 238
 239 =item * AnnoCPAN: Annotated CPAN documentation
 240
 241 L<http://annocpan.org/dist/Stash-Manip>
 242
 243 =item * CPAN Ratings
 244
 245 L<http://cpanratings.perl.org/d/Stash-Manip>
 246
 247 =item * RT: CPAN's request tracker
 248
 249 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Stash-Manip>
 250
 251 =item * Search CPAN
 252
 253 L<http://search.cpan.org/dist/Stash-Manip>
 254
 255 =back
 256
 257 =head1 AUTHOR
 258
 259   Jesse Luehrs <doy at tozt dot net>
 260
 261 =head1 COPYRIGHT AND LICENSE
 262
 263 This software is copyright (c) 2010 by Jesse Luehrs.
 264
 265 This is free software; you can redistribute it and/or modify it under
 266 the same terms as perl itself.
 267
 268 =cut
 269
 270 1;