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