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