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