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