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         if ( $type eq 'SCALAR' ) {
 208             return defined ${ *{$entry_ref}{SCALAR} };
 209         }
 210         else {
 211             return defined *{$entry_ref}{$type};
 212         }
 213     }
 214     else {
 215         # a symbol table entry can be -1 (stub), string (stub with prototype),
 216         # or reference (constant)
 217         return $type eq 'CODE';
 218     }
 219 }
 220
 221 =method get_package_symbol $variable
 222
 223 Returns the value of the given package variable (including sigil).
 224
 225 =cut
 226
 227 sub get_package_symbol {
 228     my ($self, $variable, %opts) = @_;
 229
 230     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 231         ? @{$variable}{qw[name sigil type]}
 232         : $self->_deconstruct_variable_name($variable);
 233
 234     my $namespace = $self->namespace;
 235
 236     if (!exists $namespace->{$name}) {
 237         if ($opts{vivify}) {
 238             if ($type eq 'ARRAY') {
 239                 if (BROKEN_ISA_ASSIGNMENT) {
 240                     $self->add_package_symbol(
 241                         $variable,
 242                         $name eq 'ISA' ? () : ([])
 243                     );
 244                 }
 245                 else {
 246                     $self->add_package_symbol($variable, []);
 247                 }
 248             }
 249             elsif ($type eq 'HASH') {
 250                 $self->add_package_symbol($variable, {});
 251             }
 252             elsif ($type eq 'SCALAR') {
 253                 $self->add_package_symbol($variable);
 254             }
 255             elsif ($type eq 'IO') {
 256                 $self->add_package_symbol($variable, Symbol::geniosym);
 257             }
 258             elsif ($type eq 'CODE') {
 259                 confess "Don't know how to vivify CODE variables";
 260             }
 261             else {
 262                 confess "Unknown type $type in vivication";
 263             }
 264         }
 265         else {
 266             if ($type eq 'CODE') {
 267                 # this effectively "de-vivifies" the code slot. if we don't do
 268                 # this, referencing the coderef at the end of this function
 269                 # will cause perl to auto-vivify a stub coderef in the slot,
 270                 # which isn't what we want
 271                 $self->add_package_symbol($variable);
 272             }
 273         }
 274     }
 275
 276     my $entry_ref = \$namespace->{$name};
 277
 278     if (ref($entry_ref) eq 'GLOB') {
 279         return *{$entry_ref}{$type};
 280     }
 281     else {
 282         if ($type eq 'CODE') {
 283             no strict 'refs';
 284             return \&{ $self->name . '::' . $name };
 285         }
 286         else {
 287             return undef;
 288         }
 289     }
 290 }
 291
 292 =method get_or_add_package_symbol $variable
 293
 294 Like C<get_package_symbol>, except that it will return an empty hashref or
 295 arrayref if the variable doesn't exist.
 296
 297 =cut
 298
 299 sub get_or_add_package_symbol {
 300     my $self = shift;
 301     $self->get_package_symbol(@_, vivify => 1);
 302 }
 303
 304 =method remove_package_symbol $variable
 305
 306 Removes the package variable described by C<$variable> (which includes the
 307 sigil); other variables with the same name but different sigils will be
 308 untouched.
 309
 310 =cut
 311
 312 sub remove_package_symbol {
 313     my ($self, $variable) = @_;
 314
 315     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 316         ? @{$variable}{qw[name sigil type]}
 317         : $self->_deconstruct_variable_name($variable);
 318
 319     # FIXME:
 320     # no doubt this is grossly inefficient and
 321     # could be done much easier and faster in XS
 322
 323     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 324         { sigil => '$', type => 'SCALAR', name => $name },
 325         { sigil => '@', type => 'ARRAY',  name => $name },
 326         { sigil => '%', type => 'HASH',   name => $name },
 327         { sigil => '&', type => 'CODE',   name => $name },
 328         { sigil => '',  type => 'IO',     name => $name },
 329     );
 330
 331     my ($scalar, $array, $hash, $code, $io);
 332     if ($type eq 'SCALAR') {
 333         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 334         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_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 'ARRAY') {
 339         $scalar = $self->get_package_symbol($scalar_desc);
 340         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 341         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 342         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 343     }
 344     elsif ($type eq 'HASH') {
 345         $scalar = $self->get_package_symbol($scalar_desc);
 346         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 347         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 348         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 349     }
 350     elsif ($type eq 'CODE') {
 351         $scalar = $self->get_package_symbol($scalar_desc);
 352         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 353         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 354         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 355     }
 356     elsif ($type eq 'IO') {
 357         $scalar = $self->get_package_symbol($scalar_desc);
 358         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 359         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 360         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 361     }
 362     else {
 363         confess "This should never ever ever happen";
 364     }
 365
 366     $self->remove_package_glob($name);
 367
 368     $self->add_package_symbol($scalar_desc => $scalar);
 369     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 370     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 371     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 372     $self->add_package_symbol($io_desc     => $io)     if defined $io;
 373 }
 374
 375 =method list_all_package_symbols $type_filter
 376
 377 Returns a list of package variable names in the package, without sigils. If a
 378 C<type_filter> is passed, it is used to select package variables of a given
 379 type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
 380 etc).
 381
 382 =cut
 383
 384 sub list_all_package_symbols {
 385     my ($self, $type_filter) = @_;
 386
 387     my $namespace = $self->namespace;
 388     return keys %{$namespace} unless defined $type_filter;
 389
 390     # NOTE:
 391     # or we can filter based on
 392     # type (SCALAR|ARRAY|HASH|CODE)
 393     if ($type_filter eq 'CODE') {
 394         return grep {
 395             (ref($namespace->{$_})
 396                 ? (ref($namespace->{$_}) eq 'SCALAR')
 397                 : (ref(\$namespace->{$_}) eq 'GLOB'
 398                    && defined(*{$namespace->{$_}}{CODE})));
 399         } keys %{$namespace};
 400     } else {
 401         return grep { *{$namespace->{$_}}{$type_filter} } 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;