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 ($namespace) = @_;
  37     return bless { 'package' => $namespace }, $class;
  38 }
  39
  40 =method name
  41
  42 Returns the name of the package that this object represents.
  43
  44 =cut
  45
  46 sub name {
  47     return $_[0]->{package};
  48 }
  49
  50 =method namespace
  51
  52 Returns the raw stash itself.
  53
  54 =cut
  55
  56 sub namespace {
  57     # NOTE:
  58     # because of issues with the Perl API
  59     # to the typeglob in some versions, we
  60     # need to just always grab a new
  61     # reference to the hash here. Ideally
  62     # we could just store a ref and it would
  63     # Just Work, but oh well :\
  64     no strict 'refs';
  65     return \%{$_[0]->name . '::'};
  66 }
  67
  68 {
  69     my %SIGIL_MAP = (
  70         '$' => 'SCALAR',
  71         '@' => 'ARRAY',
  72         '%' => 'HASH',
  73         '&' => 'CODE',
  74         ''  => 'IO',
  75     );
  76
  77     sub _deconstruct_variable_name {
  78         my ($self, $variable) = @_;
  79
  80         (defined $variable && length $variable)
  81             || confess "You must pass a variable name";
  82
  83         my $sigil = substr($variable, 0, 1, '');
  84
  85         if (exists $SIGIL_MAP{$sigil}) {
  86             return ($variable, $sigil, $SIGIL_MAP{$sigil});
  87         }
  88         else {
  89             return ("${sigil}${variable}", '', $SIGIL_MAP{''});
  90         }
  91     }
  92 }
  93
  94 =method add_package_symbol $variable $value %opts
  95
  96 Adds a new package symbol, for the symbol given as C<$variable>, and optionally
  97 gives it an initial value of C<$value>. C<$variable> should be the name of
  98 variable including the sigil, so
  99
 100   Package::Stash->new('Foo')->add_package_symbol('%foo')
 101
 102 will create C<%Foo::foo>.
 103
 104 Valid options (all optional) are C<filename>, C<first_line_num>, and
 105 C<last_line_num>.
 106
 107 C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
 108 be used to indicate where the symbol should be regarded as having been defined.
 109 Currently these values are only used if the symbol is a subroutine ('C<&>'
 110 sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
 111 hash is updated to record the values of C<filename>, C<first_line_num>, and
 112 C<last_line_num> for the subroutine. If these are not passed, their values are
 113 inferred (as much as possible) from C<caller> information.
 114
 115 This is especially useful for debuggers and profilers, which use C<%DB::sub> to
 116 determine where the source code for a subroutine can be found.  See
 117 L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
 118 information about C<%DB::sub>.
 119
 120 =cut
 121
 122 sub _valid_for_type {
 123     my $self = shift;
 124     my ($value, $type) = @_;
 125     if ($type eq 'HASH' || $type eq 'ARRAY'
 126      || $type eq 'IO'   || $type eq 'CODE') {
 127         return reftype($value) eq $type;
 128     }
 129     else {
 130         my $ref = reftype($value);
 131         return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
 132     }
 133 }
 134
 135 sub add_package_symbol {
 136     my ($self, $variable, $initial_value, %opts) = @_;
 137
 138     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 139         ? @{$variable}{qw[name sigil type]}
 140         : $self->_deconstruct_variable_name($variable);
 141
 142     my $pkg = $self->name;
 143
 144     if (@_ > 2) {
 145         $self->_valid_for_type($initial_value, $type)
 146             || confess "$initial_value is not of type $type";
 147
 148         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
 149         if ($^P and $^P & 0x10 && $sigil eq '&') {
 150             my $filename = $opts{filename};
 151             my $first_line_num = $opts{first_line_num};
 152
 153             (undef, $filename, $first_line_num) = caller
 154                 if not defined $filename;
 155
 156             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 157
 158             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 159             $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 160         }
 161     }
 162
 163     no strict 'refs';
 164     no warnings 'redefine', 'misc', 'prototype';
 165     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 166 }
 167
 168 =method remove_package_glob $name
 169
 170 Removes all package variables with the given name, regardless of sigil.
 171
 172 =cut
 173
 174 sub remove_package_glob {
 175     my ($self, $name) = @_;
 176     no strict 'refs';
 177     delete ${$self->name . '::'}{$name};
 178 }
 179
 180 # ... these functions deal with stuff on the namespace level
 181
 182 =method has_package_symbol $variable
 183
 184 Returns whether or not the given package variable (including sigil) exists.
 185
 186 =cut
 187
 188 sub has_package_symbol {
 189     my ($self, $variable) = @_;
 190
 191     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 192         ? @{$variable}{qw[name sigil type]}
 193         : $self->_deconstruct_variable_name($variable);
 194
 195     my $namespace = $self->namespace;
 196
 197     return unless exists $namespace->{$name};
 198
 199     my $entry_ref = \$namespace->{$name};
 200     if (reftype($entry_ref) eq 'GLOB') {
 201         if ( $type eq 'SCALAR' ) {
 202             return defined ${ *{$entry_ref}{SCALAR} };
 203         }
 204         else {
 205             return defined *{$entry_ref}{$type};
 206         }
 207     }
 208     else {
 209         # a symbol table entry can be -1 (stub), string (stub with prototype),
 210         # or reference (constant)
 211         return $type eq 'CODE';
 212     }
 213 }
 214
 215 =method get_package_symbol $variable
 216
 217 Returns the value of the given package variable (including sigil).
 218
 219 =cut
 220
 221 sub get_package_symbol {
 222     my ($self, $variable, %opts) = @_;
 223
 224     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 225         ? @{$variable}{qw[name sigil type]}
 226         : $self->_deconstruct_variable_name($variable);
 227
 228     my $namespace = $self->namespace;
 229
 230     if (!exists $namespace->{$name}) {
 231         # assigning to the result of this function like
 232         #   @{$stash->get_package_symbol('@ISA')} = @new_ISA
 233         # makes the result not visible until the variable is explicitly
 234         # accessed... in the case of @ISA, this might never happen
 235         # for instance, assigning like that and then calling $obj->isa
 236         # will fail. see t/005-isa.t
 237         if ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') {
 238             $self->add_package_symbol($variable, []);
 239         }
 240         elsif ($opts{vivify} && $type eq 'HASH') {
 241             $self->add_package_symbol($variable, {});
 242         }
 243         else {
 244             # FIXME
 245             $self->add_package_symbol($variable)
 246         }
 247     }
 248
 249     my $entry_ref = \$namespace->{$name};
 250
 251     if (ref($entry_ref) eq 'GLOB') {
 252         return *{$entry_ref}{$type};
 253     }
 254     else {
 255         if ($type eq 'CODE') {
 256             no strict 'refs';
 257             return \&{ $self->name . '::' . $name };
 258         }
 259         else {
 260             return undef;
 261         }
 262     }
 263 }
 264
 265 =method get_or_add_package_symbol $variable
 266
 267 Like C<get_package_symbol>, except that it will return an empty hashref or
 268 arrayref if the variable doesn't exist.
 269
 270 =cut
 271
 272 sub get_or_add_package_symbol {
 273     my $self = shift;
 274     $self->get_package_symbol(@_, vivify => 1);
 275 }
 276
 277 =method remove_package_symbol $variable
 278
 279 Removes the package variable described by C<$variable> (which includes the
 280 sigil); other variables with the same name but different sigils will be
 281 untouched.
 282
 283 =cut
 284
 285 sub remove_package_symbol {
 286     my ($self, $variable) = @_;
 287
 288     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 289         ? @{$variable}{qw[name sigil type]}
 290         : $self->_deconstruct_variable_name($variable);
 291
 292     # FIXME:
 293     # no doubt this is grossly inefficient and
 294     # could be done much easier and faster in XS
 295
 296     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 297         { sigil => '$', type => 'SCALAR', name => $name },
 298         { sigil => '@', type => 'ARRAY',  name => $name },
 299         { sigil => '%', type => 'HASH',   name => $name },
 300         { sigil => '&', type => 'CODE',   name => $name },
 301         { sigil => '',  type => 'IO',     name => $name },
 302     );
 303
 304     my ($scalar, $array, $hash, $code, $io);
 305     if ($type eq 'SCALAR') {
 306         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 307         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 308         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 309         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 310     }
 311     elsif ($type eq 'ARRAY') {
 312         $scalar = $self->get_package_symbol($scalar_desc);
 313         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 314         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 315         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 316     }
 317     elsif ($type eq 'HASH') {
 318         $scalar = $self->get_package_symbol($scalar_desc);
 319         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 320         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 321         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 322     }
 323     elsif ($type eq 'CODE') {
 324         $scalar = $self->get_package_symbol($scalar_desc);
 325         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 326         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 327         $io     = $self->get_package_symbol($io_desc)     if $self->has_package_symbol($io_desc);
 328     }
 329     elsif ($type eq 'IO') {
 330         $scalar = $self->get_package_symbol($scalar_desc);
 331         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 332         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 333         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 334     }
 335     else {
 336         confess "This should never ever ever happen";
 337     }
 338
 339     $self->remove_package_glob($name);
 340
 341     $self->add_package_symbol($scalar_desc => $scalar);
 342     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 343     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 344     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 345     $self->add_package_symbol($io_desc     => $io)     if defined $io;
 346 }
 347
 348 =method list_all_package_symbols $type_filter
 349
 350 Returns a list of package variable names in the package, without sigils. If a
 351 C<type_filter> is passed, it is used to select package variables of a given
 352 type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
 353 etc).
 354
 355 =cut
 356
 357 sub list_all_package_symbols {
 358     my ($self, $type_filter) = @_;
 359
 360     my $namespace = $self->namespace;
 361     return keys %{$namespace} unless defined $type_filter;
 362
 363     # NOTE:
 364     # or we can filter based on
 365     # type (SCALAR|ARRAY|HASH|CODE)
 366     if ($type_filter eq 'CODE') {
 367         return grep {
 368             (ref($namespace->{$_})
 369                 ? (ref($namespace->{$_}) eq 'SCALAR')
 370                 : (ref(\$namespace->{$_}) eq 'GLOB'
 371                    && defined(*{$namespace->{$_}}{CODE})));
 372         } keys %{$namespace};
 373     } else {
 374         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 375     }
 376 }
 377
 378 =head1 SEE ALSO
 379
 380 =over 4
 381
 382 =item * L<Class::MOP::Package>
 383
 384 This module is a factoring out of code that used to live here
 385
 386 =back
 387
 388 =cut
 389
 390 1;