lib/Package/Stash.pm

   1 package Package::Stash;
   2 use strict;
   3 use warnings;
   4 # ABSTRACT: routines for manipulating stashes
   5
   6 use Carp qw(confess);
   7 use Scalar::Util qw(reftype);
   8 use Sub::Name;
   9 use Symbol;
  10
  11 =head1 SYNOPSIS
  12
  13   my $stash = Package::Stash->new('Foo');
  14   $stash->add_package_symbol('%foo', {bar => 1});
  15   # $Foo::foo{bar} == 1
  16   $stash->has_package_symbol('$foo') # false
  17   my $namespace = $stash->namespace;
  18   *{ $namespace->{foo} }{HASH} # {bar => 1}
  19
  20 =head1 DESCRIPTION
  21
  22 Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
  23 incredibly messy, and easy to get wrong. This module hides all of that behind a
  24 simple API.
  25
  26 NOTE: Most methods in this class require a variable specification that includes
  27 a sigil. If this sigil is absent, it is assumed to represent the IO slot.
  28
  29 =method new $package_name
  30
  31 Creates a new C<Package::Stash> object, for the package given as the only
  32 argument.
  33
  34 =cut
  35
  36 sub new {
  37     my $class = shift;
  38     my ($package) = @_;
  39     my $namespace;
  40     {
  41         no strict 'refs';
  42         # supposedly this caused a bug in earlier perls, but I can't reproduce
  43         # it, so re-enabling the caching
  44         $namespace = \%{$package . '::'};
  45     }
  46     return bless {
  47         'package'   => $package,
  48         'namespace' => $namespace,
  49     }, $class;
  50 }
  51
  52 =method name
  53
  54 Returns the name of the package that this object represents.
  55
  56 =cut
  57
  58 sub name {
  59     return $_[0]->{package};
  60 }
  61
  62 =method namespace
  63
  64 Returns the raw stash itself.
  65
  66 =cut
  67
  68 sub namespace {
  69     return $_[0]->{namespace};
  70 }
  71
  72 {
  73     my %SIGIL_MAP = (
  74         '$' => 'SCALAR',
  75         '@' => 'ARRAY',
  76         '%' => 'HASH',
  77         '&' => 'CODE',
  78         ''  => 'IO',
  79     );
  80
  81     sub _deconstruct_variable_name {
  82         my ($self, $variable) = @_;
  83
  84         (defined $variable && length $variable)
  85             || confess "You must pass a variable name";
  86
  87         my $sigil = substr($variable, 0, 1, '');
  88
  89         if (exists $SIGIL_MAP{$sigil}) {
  90             return ($variable, $sigil, $SIGIL_MAP{$sigil});
  91         }
  92         else {
  93             return ("${sigil}${variable}", '', $SIGIL_MAP{''});
  94         }
  95     }
  96 }
  97
  98 =method add_package_symbol $variable $value %opts
  99
 100 Adds a new package symbol, for the symbol given as C<$variable>, and optionally
 101 gives it an initial value of C<$value>. C<$variable> should be the name of
 102 variable including the sigil, so
 103
 104   Package::Stash->new('Foo')->add_package_symbol('%foo')
 105
 106 will create C<%Foo::foo>.
 107
 108 Valid options (all optional) are C<filename>, C<first_line_num>,
 109 C<last_line_num>, and C<subname>.
 110
 111 C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
 112 be used to indicate where the symbol should be regarded as having been defined.
 113 Currently these values are only used if the symbol is a subroutine ('C<&>'
 114 sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
 115 hash is updated to record the values of C<filename>, C<first_line_num>, and
 116 C<last_line_num> for the subroutine. If these are not passed, their values are
 117 inferred (as much as possible) from C<caller> information.
 118
 119 This is especially useful for debuggers and profilers, which use C<%DB::sub> to
 120 determine where the source code for a subroutine can be found.  See
 121 L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
 122 information about C<%DB::sub>.
 123
 124 C<$opts{subname}> is used to set the name for the installed subroutine (it is
 125 ignored if the symbol isn't a subroutine). It uses L<Sub::Name> to set the
 126 name. If an unqualified name is given, it will add the name of the package
 127 corresponding to this C<Package::Stash> instance.
 128
 129 =cut
 130
 131 sub _valid_for_type {
 132     my $self = shift;
 133     my ($value, $type) = @_;
 134     if ($type eq 'HASH' || $type eq 'ARRAY'
 135      || $type eq 'IO'   || $type eq 'CODE') {
 136         return reftype($value) eq $type;
 137     }
 138     else {
 139         my $ref = reftype($value);
 140         return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
 141     }
 142 }
 143
 144 sub add_package_symbol {
 145     my ($self, $variable, $initial_value, %opts) = @_;
 146
 147     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 148         ? @{$variable}{qw[name sigil type]}
 149         : $self->_deconstruct_variable_name($variable);
 150
 151     my $pkg = $self->name;
 152
 153     if (@_ > 2) {
 154         $self->_valid_for_type($initial_value, $type)
 155             || confess "$initial_value is not of type $type";
 156
 157         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
 158         if ($^P and $^P & 0x10 && $sigil eq '&') {
 159             my $filename = $opts{filename};
 160             my $first_line_num = $opts{first_line_num};
 161
 162             (undef, $filename, $first_line_num) = caller
 163                 if not defined $filename;
 164
 165             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 166
 167             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 168             $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 169         }
 170     }
 171
 172     no strict 'refs';
 173     no warnings 'redefine', 'misc', 'prototype';
 174     if ($type eq 'CODE' && $initial_value && exists $opts{subname}) {
 175         $opts{subname} = $pkg . '::' . $opts{subname}
 176             if $opts{subname} !~ /::/;
 177         *{$pkg . '::' . $name} = subname $opts{subname} => $initial_value;
 178     }
 179     else {
 180         *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 181     }
 182 }
 183
 184 =method remove_package_glob $name
 185
 186 Removes all package variables with the given name, regardless of sigil.
 187
 188 =cut
 189
 190 sub remove_package_glob {
 191     my ($self, $name) = @_;
 192     no strict 'refs';
 193     delete ${$self->name . '::'}{$name};
 194 }
 195
 196 # ... these functions deal with stuff on the namespace level
 197
 198 =method has_package_symbol $variable
 199
 200 Returns whether or not the given package variable (including sigil) exists.
 201
 202 =cut
 203
 204 sub has_package_symbol {
 205     my ($self, $variable) = @_;
 206
 207     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 208         ? @{$variable}{qw[name sigil type]}
 209         : $self->_deconstruct_variable_name($variable);
 210
 211     my $namespace = $self->namespace;
 212
 213     return unless exists $namespace->{$name};
 214
 215     my $entry_ref = \$namespace->{$name};
 216     if (reftype($entry_ref) eq 'GLOB') {
 217         if ( $type eq 'SCALAR' ) {
 218             return defined ${ *{$entry_ref}{SCALAR} };
 219         }
 220         else {
 221             return defined *{$entry_ref}{$type};
 222         }
 223     }
 224     else {
 225         # a symbol table entry can be -1 (stub), string (stub with prototype),
 226         # or reference (constant)
 227         return $type eq 'CODE';
 228     }
 229 }
 230
 231 =method get_package_symbol $variable
 232
 233 Returns the value of the given package variable (including sigil).
 234
 235 =cut
 236
 237 sub get_package_symbol {
 238     my ($self, $variable, %opts) = @_;
 239
 240     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 241         ? @{$variable}{qw[name sigil type]}
 242         : $self->_deconstruct_variable_name($variable);
 243
 244     my $namespace = $self->namespace;
 245
 246     if ($opts{vivify} && !exists $namespace->{$name}) {
 247         if ($type eq 'ARRAY') {
 248             $self->add_package_symbol(
 249                 $variable,
 250                 # setting our own arrayref manually loses the magicalness or
 251                 # something
 252                 $name eq 'ISA' ? () : ([])
 253             );
 254         }
 255         elsif ($type eq 'HASH') {
 256             $self->add_package_symbol($variable, {});
 257         }
 258         elsif ($type eq 'SCALAR') {
 259             $self->add_package_symbol($variable);
 260         }
 261         elsif ($type eq 'IO') {
 262             $self->add_package_symbol($variable, Symbol::geniosym);
 263         }
 264         elsif ($type eq 'CODE') {
 265             # ignoring this case for now, since i don't know what would
 266             # be useful to do here (and subs in the stash autovivify in weird
 267             # ways too)
 268             #$self->add_package_symbol($variable, sub {});
 269         }
 270         else {
 271             confess "Unknown type $type in vivication";
 272         }
 273     }
 274
 275     my $entry_ref = \$namespace->{$name};
 276
 277     if (ref($entry_ref) eq 'GLOB') {
 278         return *{$entry_ref}{$type};
 279     }
 280     else {
 281         if ($type eq 'CODE') {
 282             no strict 'refs';
 283             return \&{ $self->name . '::' . $name };
 284         }
 285         else {
 286             return undef;
 287         }
 288     }
 289 }
 290
 291 =method get_or_add_package_symbol $variable
 292
 293 Like C<get_package_symbol>, except that it will return an empty hashref or
 294 arrayref if the variable doesn't exist.
 295
 296 =cut
 297
 298 sub get_or_add_package_symbol {
 299     my $self = shift;
 300     $self->get_package_symbol(@_, vivify => 1);
 301 }
 302
 303 =method remove_package_symbol $variable
 304
 305 Removes the package variable described by C<$variable> (which includes the
 306 sigil); other variables with the same name but different sigils will be
 307 untouched.
 308
 309 =cut
 310
 311 sub remove_package_symbol {
 312     my ($self, $variable) = @_;
 313
 314     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 315         ? @{$variable}{qw[name sigil type]}
 316         : $self->_deconstruct_variable_name($variable);
 317
 318     # FIXME:
 319     # no doubt this is grossly inefficient and
 320     # could be done much easier and faster in XS
 321
 322     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 323         { sigil => '$', type => 'SCALAR', name => $name },
 324         { sigil => '@', type => 'ARRAY',  name => $name },
 325         { sigil => '%', type => 'HASH',   name => $name },
 326         { sigil => '&', type => 'CODE',   name => $name },
 327         { sigil => '',  type => 'IO',     name => $name },
 328     );
 329
 330     my ($scalar, $array, $hash, $code, $io);
 331     if ($type eq 'SCALAR') {
 332         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 333         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 334         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 335         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 336     }
 337     elsif ($type eq 'ARRAY') {
 338         $scalar = $self->get_package_symbol($scalar_desc);
 339         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 340         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 341         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 342     }
 343     elsif ($type eq 'HASH') {
 344         $scalar = $self->get_package_symbol($scalar_desc);
 345         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 346         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 347         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 348     }
 349     elsif ($type eq 'CODE') {
 350         $scalar = $self->get_package_symbol($scalar_desc);
 351         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 352         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 353         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 354     }
 355     elsif ($type eq 'IO') {
 356         $scalar = $self->get_package_symbol($scalar_desc);
 357         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 358         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 359         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 360     }
 361     else {
 362         confess "This should never ever ever happen";
 363     }
 364
 365     $self->remove_package_glob($name);
 366
 367     $self->add_package_symbol($scalar_desc => $scalar);
 368     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 369     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 370     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 371     $self->add_package_symbol($io_desc     => $io)     if defined $io;
 372 }
 373
 374 =method list_all_package_symbols $type_filter
 375
 376 Returns a list of package variable names in the package, without sigils. If a
 377 C<type_filter> is passed, it is used to select package variables of a given
 378 type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
 379 etc).
 380
 381 =cut
 382
 383 sub list_all_package_symbols {
 384     my ($self, $type_filter) = @_;
 385
 386     my $namespace = $self->namespace;
 387     return keys %{$namespace} unless defined $type_filter;
 388
 389     # NOTE:
 390     # or we can filter based on
 391     # type (SCALAR|ARRAY|HASH|CODE)
 392     if ($type_filter eq 'CODE') {
 393         return grep {
 394             (ref($namespace->{$_})
 395                 ? (ref($namespace->{$_}) eq 'SCALAR')
 396                 : (ref(\$namespace->{$_}) eq 'GLOB'
 397                    && defined(*{$namespace->{$_}}{CODE})));
 398         } keys %{$namespace};
 399     } else {
 400         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 401     }
 402 }
 403
 404 =head1 BUGS
 405
 406 No known bugs.
 407
 408 Please report any bugs through RT: email
 409 C<bug-package-stash at rt.cpan.org>, or browse to
 410 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
 411
 412 =head1 SEE ALSO
 413
 414 =over 4
 415
 416 =item * L<Class::MOP::Package>
 417
 418 This module is a factoring out of code that used to live here
 419
 420 =back
 421
 422 =head1 SUPPORT
 423
 424 You can find this documentation for this module with the perldoc command.
 425
 426     perldoc Package::Stash
 427
 428 You can also look for information at:
 429
 430 =over 4
 431
 432 =item * AnnoCPAN: Annotated CPAN documentation
 433
 434 L<http://annocpan.org/dist/Package-Stash>
 435
 436 =item * CPAN Ratings
 437
 438 L<http://cpanratings.perl.org/d/Package-Stash>
 439
 440 =item * RT: CPAN's request tracker
 441
 442 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
 443
 444 =item * Search CPAN
 445
 446 L<http://search.cpan.org/dist/Package-Stash>
 447
 448 =back
 449
 450 =head1 AUTHOR
 451
 452 Jesse Luehrs <doy at tozt dot net>
 453
 454 Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
 455 Moose Cabal.
 456
 457 =cut
 458
 459 1;