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