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