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