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