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 =cut
 163
 164 sub remove_package_glob {
 165     my ($self, $name) = @_;
 166     no strict 'refs';
 167     delete ${$self->name . '::'}{$name};
 168 }
 169
 170 # ... these functions deal with stuff on the namespace level
 171
 172 =method has_package_symbol $variable
 173
 174 Returns whether or not the given package variable (including sigil) exists.
 175
 176 =cut
 177
 178 sub has_package_symbol {
 179     my ($self, $variable) = @_;
 180
 181     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 182         ? @{$variable}{qw[name sigil type]}
 183         : $self->_deconstruct_variable_name($variable);
 184
 185     my $namespace = $self->namespace;
 186
 187     return unless exists $namespace->{$name};
 188
 189     my $entry_ref = \$namespace->{$name};
 190     if (reftype($entry_ref) eq 'GLOB') {
 191         # XXX: assigning to any typeglob slot also initializes the SCALAR slot,
 192         # and saying that an undef scalar variable doesn't exist is probably
 193         # vaguely less surprising than a scalar variable popping into existence
 194         # without anyone defining it
 195         if ($type eq 'SCALAR') {
 196             return defined ${ *{$entry_ref}{$type} };
 197         }
 198         else {
 199             return defined *{$entry_ref}{$type};
 200         }
 201     }
 202     else {
 203         # a symbol table entry can be -1 (stub), string (stub with prototype),
 204         # or reference (constant)
 205         return $type eq 'CODE';
 206     }
 207 }
 208
 209 =method get_package_symbol $variable
 210
 211 Returns the value of the given package variable (including sigil).
 212
 213 =cut
 214
 215 sub get_package_symbol {
 216     my ($self, $variable, %opts) = @_;
 217
 218     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 219         ? @{$variable}{qw[name sigil type]}
 220         : $self->_deconstruct_variable_name($variable);
 221
 222     my $namespace = $self->namespace;
 223
 224     if (!exists $namespace->{$name}) {
 225         if ($opts{vivify}) {
 226             if ($type eq 'ARRAY') {
 227                 if (BROKEN_ISA_ASSIGNMENT) {
 228                     $self->add_package_symbol(
 229                         $variable,
 230                         $name eq 'ISA' ? () : ([])
 231                     );
 232                 }
 233                 else {
 234                     $self->add_package_symbol($variable, []);
 235                 }
 236             }
 237             elsif ($type eq 'HASH') {
 238                 $self->add_package_symbol($variable, {});
 239             }
 240             elsif ($type eq 'SCALAR') {
 241                 $self->add_package_symbol($variable);
 242             }
 243             elsif ($type eq 'IO') {
 244                 $self->add_package_symbol($variable, Symbol::geniosym);
 245             }
 246             elsif ($type eq 'CODE') {
 247                 confess "Don't know how to vivify CODE variables";
 248             }
 249             else {
 250                 confess "Unknown type $type in vivication";
 251             }
 252         }
 253         else {
 254             if ($type eq 'CODE') {
 255                 # this effectively "de-vivifies" the code slot. if we don't do
 256                 # this, referencing the coderef at the end of this function
 257                 # will cause perl to auto-vivify a stub coderef in the slot,
 258                 # which isn't what we want
 259                 $self->add_package_symbol($variable);
 260             }
 261         }
 262     }
 263
 264     my $entry_ref = \$namespace->{$name};
 265
 266     if (ref($entry_ref) eq 'GLOB') {
 267         return *{$entry_ref}{$type};
 268     }
 269     else {
 270         if ($type eq 'CODE') {
 271             no strict 'refs';
 272             return \&{ $self->name . '::' . $name };
 273         }
 274         else {
 275             return undef;
 276         }
 277     }
 278 }
 279
 280 =method get_or_add_package_symbol $variable
 281
 282 Like C<get_package_symbol>, except that it will return an empty hashref or
 283 arrayref if the variable doesn't exist.
 284
 285 =cut
 286
 287 sub get_or_add_package_symbol {
 288     my $self = shift;
 289     $self->get_package_symbol(@_, vivify => 1);
 290 }
 291
 292 =method remove_package_symbol $variable
 293
 294 Removes the package variable described by C<$variable> (which includes the
 295 sigil); other variables with the same name but different sigils will be
 296 untouched.
 297
 298 =cut
 299
 300 sub remove_package_symbol {
 301     my ($self, $variable) = @_;
 302
 303     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 304         ? @{$variable}{qw[name sigil type]}
 305         : $self->_deconstruct_variable_name($variable);
 306
 307     # FIXME:
 308     # no doubt this is grossly inefficient and
 309     # could be done much easier and faster in XS
 310
 311     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 312         { sigil => '$', type => 'SCALAR', name => $name },
 313         { sigil => '@', type => 'ARRAY',  name => $name },
 314         { sigil => '%', type => 'HASH',   name => $name },
 315         { sigil => '&', type => 'CODE',   name => $name },
 316         { sigil => '',  type => 'IO',     name => $name },
 317     );
 318
 319     my ($scalar, $array, $hash, $code, $io);
 320     if ($type eq 'SCALAR') {
 321         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 322         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 323         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 324         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 325     }
 326     elsif ($type eq 'ARRAY') {
 327         $scalar = $self->get_package_symbol($scalar_desc);
 328         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 329         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 330         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 331     }
 332     elsif ($type eq 'HASH') {
 333         $scalar = $self->get_package_symbol($scalar_desc);
 334         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 335         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 336         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 337     }
 338     elsif ($type eq 'CODE') {
 339         $scalar = $self->get_package_symbol($scalar_desc);
 340         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 341         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 342         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 343     }
 344     elsif ($type eq 'IO') {
 345         $scalar = $self->get_package_symbol($scalar_desc);
 346         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 347         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 348         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 349     }
 350     else {
 351         confess "This should never ever ever happen";
 352     }
 353
 354     $self->remove_package_glob($name);
 355
 356     $self->add_package_symbol($scalar_desc => $scalar);
 357     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 358     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 359     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 360     $self->add_package_symbol($io_desc     => $io)     if defined $io;
 361 }
 362
 363 =method list_all_package_symbols $type_filter
 364
 365 Returns a list of package variable names in the package, without sigils. If a
 366 C<type_filter> is passed, it is used to select package variables of a given
 367 type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
 368 etc). Note that if the package contained any C<BEGIN> blocks, perl will leave
 369 an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is
 370 used (and similarly for C<INIT>, C<END>, etc).
 371
 372 =cut
 373
 374 sub list_all_package_symbols {
 375     my ($self, $type_filter) = @_;
 376
 377     my $namespace = $self->namespace;
 378     return keys %{$namespace} unless defined $type_filter;
 379
 380     # NOTE:
 381     # or we can filter based on
 382     # type (SCALAR|ARRAY|HASH|CODE)
 383     if ($type_filter eq 'CODE') {
 384         return grep {
 385             # any non-typeglob in the symbol table is a constant or stub
 386             ref(\$namespace->{$_}) ne 'GLOB'
 387                 # regular subs are stored in the CODE slot of the typeglob
 388                 || defined(*{$namespace->{$_}}{CODE})
 389         } keys %{$namespace};
 390     }
 391     elsif ($type_filter eq 'SCALAR') {
 392         return grep {
 393             ref(\$namespace->{$_}) eq 'GLOB'
 394                 && defined(${*{$namespace->{$_}}{'SCALAR'}})
 395         } keys %{$namespace};
 396     }
 397     else {
 398         return grep {
 399             ref(\$namespace->{$_}) eq 'GLOB'
 400                 && defined(*{$namespace->{$_}}{$type_filter})
 401         } keys %{$namespace};
 402     }
 403 }
 404
 405 =head1 BUGS
 406
 407 No known bugs.
 408
 409 Please report any bugs through RT: email
 410 C<bug-package-stash at rt.cpan.org>, or browse to
 411 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
 412
 413 =head1 SEE ALSO
 414
 415 =over 4
 416
 417 =item * L<Class::MOP::Package>
 418
 419 This module is a factoring out of code that used to live here
 420
 421 =back
 422
 423 =head1 SUPPORT
 424
 425 You can find this documentation for this module with the perldoc command.
 426
 427     perldoc Package::Stash
 428
 429 You can also look for information at:
 430
 431 =over 4
 432
 433 =item * AnnoCPAN: Annotated CPAN documentation
 434
 435 L<http://annocpan.org/dist/Package-Stash>
 436
 437 =item * CPAN Ratings
 438
 439 L<http://cpanratings.perl.org/d/Package-Stash>
 440
 441 =item * RT: CPAN's request tracker
 442
 443 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
 444
 445 =item * Search CPAN
 446
 447 L<http://search.cpan.org/dist/Package-Stash>
 448
 449 =back
 450
 451 =head1 AUTHOR
 452
 453 Jesse Luehrs <doy at tozt dot net>
 454
 455 Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
 456 Moose Cabal.
 457
 458 =cut
 459
 460 1;