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 use XSLoader;
  11 XSLoader::load(
  12     __PACKAGE__,
  13     # we need to be careful not to touch $VERSION at compile time, otherwise
  14     # DynaLoader will assume it's set and check against it, which will cause
  15     # fail when being run in the checkout without dzil having set the actual
  16     # $VERSION
  17     exists $Package::Stash::{VERSION}
  18         ? ${ $Package::Stash::{VERSION} } : (),
  19 );
  20
  21 # before 5.12, assigning to the ISA glob would make it lose its magical ->isa
  22 # powers
  23 use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
  24
  25 =head1 SYNOPSIS
  26
  27   my $stash = Package::Stash->new('Foo');
  28   $stash->add_package_symbol('%foo', {bar => 1});
  29   # $Foo::foo{bar} == 1
  30   $stash->has_package_symbol('$foo') # false
  31   my $namespace = $stash->namespace;
  32   *{ $namespace->{foo} }{HASH} # {bar => 1}
  33
  34 =head1 DESCRIPTION
  35
  36 Manipulating stashes (Perl's symbol tables) is occasionally necessary, but
  37 incredibly messy, and easy to get wrong. This module hides all of that behind a
  38 simple API.
  39
  40 NOTE: Most methods in this class require a variable specification that includes
  41 a sigil. If this sigil is absent, it is assumed to represent the IO slot.
  42
  43 =method new $package_name
  44
  45 Creates a new C<Package::Stash> object, for the package given as the only
  46 argument.
  47
  48 =method name
  49
  50 Returns the name of the package that this object represents.
  51
  52 =method namespace
  53
  54 Returns the raw stash itself.
  55
  56 =cut
  57
  58 {
  59     my %SIGIL_MAP = (
  60         '$' => 'SCALAR',
  61         '@' => 'ARRAY',
  62         '%' => 'HASH',
  63         '&' => 'CODE',
  64         ''  => 'IO',
  65     );
  66
  67     sub _deconstruct_variable_name {
  68         my ($self, $variable) = @_;
  69
  70         (defined $variable && length $variable)
  71             || confess "You must pass a variable name";
  72
  73         my $sigil = substr($variable, 0, 1, '');
  74
  75         if (exists $SIGIL_MAP{$sigil}) {
  76             return ($variable, $sigil, $SIGIL_MAP{$sigil});
  77         }
  78         else {
  79             return ("${sigil}${variable}", '', $SIGIL_MAP{''});
  80         }
  81     }
  82 }
  83
  84 =method add_package_symbol $variable $value %opts
  85
  86 Adds a new package symbol, for the symbol given as C<$variable>, and optionally
  87 gives it an initial value of C<$value>. C<$variable> should be the name of
  88 variable including the sigil, so
  89
  90   Package::Stash->new('Foo')->add_package_symbol('%foo')
  91
  92 will create C<%Foo::foo>.
  93
  94 Valid options (all optional) are C<filename>, C<first_line_num>, and
  95 C<last_line_num>.
  96
  97 C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
  98 be used to indicate where the symbol should be regarded as having been defined.
  99 Currently these values are only used if the symbol is a subroutine ('C<&>'
 100 sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub>
 101 hash is updated to record the values of C<filename>, C<first_line_num>, and
 102 C<last_line_num> for the subroutine. If these are not passed, their values are
 103 inferred (as much as possible) from C<caller> information.
 104
 105 This is especially useful for debuggers and profilers, which use C<%DB::sub> to
 106 determine where the source code for a subroutine can be found.  See
 107 L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
 108 information about C<%DB::sub>.
 109
 110 =cut
 111
 112 sub _valid_for_type {
 113     my $self = shift;
 114     my ($value, $type) = @_;
 115     if ($type eq 'HASH' || $type eq 'ARRAY'
 116      || $type eq 'IO'   || $type eq 'CODE') {
 117         return reftype($value) eq $type;
 118     }
 119     else {
 120         my $ref = reftype($value);
 121         return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
 122     }
 123 }
 124
 125 sub add_package_symbol {
 126     my ($self, $variable, $initial_value, %opts) = @_;
 127
 128     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 129         ? @{$variable}{qw[name sigil type]}
 130         : $self->_deconstruct_variable_name($variable);
 131
 132     my $pkg = $self->name;
 133
 134     if (@_ > 2) {
 135         $self->_valid_for_type($initial_value, $type)
 136             || confess "$initial_value is not of type $type";
 137
 138         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
 139         if ($^P and $^P & 0x10 && $sigil eq '&') {
 140             my $filename = $opts{filename};
 141             my $first_line_num = $opts{first_line_num};
 142
 143             (undef, $filename, $first_line_num) = caller
 144                 if not defined $filename;
 145
 146             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 147
 148             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 149             $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 150         }
 151     }
 152
 153     no strict 'refs';
 154     no warnings 'redefine', 'misc', 'prototype';
 155     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 156 }
 157
 158 =method remove_package_glob $name
 159
 160 Removes all package variables with the given name, regardless of sigil.
 161
 162 =method has_package_symbol $variable
 163
 164 Returns whether or not the given package variable (including sigil) exists.
 165
 166 =cut
 167
 168 sub has_package_symbol {
 169     my ($self, $variable) = @_;
 170
 171     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 172         ? @{$variable}{qw[name sigil type]}
 173         : $self->_deconstruct_variable_name($variable);
 174
 175     my $namespace = $self->namespace;
 176
 177     return unless exists $namespace->{$name};
 178
 179     my $entry_ref = \$namespace->{$name};
 180     if (reftype($entry_ref) eq 'GLOB') {
 181         # XXX: assigning to any typeglob slot also initializes the SCALAR slot,
 182         # and saying that an undef scalar variable doesn't exist is probably
 183         # vaguely less surprising than a scalar variable popping into existence
 184         # without anyone defining it
 185         if ($type eq 'SCALAR') {
 186             return defined ${ *{$entry_ref}{$type} };
 187         }
 188         else {
 189             return defined *{$entry_ref}{$type};
 190         }
 191     }
 192     else {
 193         # a symbol table entry can be -1 (stub), string (stub with prototype),
 194         # or reference (constant)
 195         return $type eq 'CODE';
 196     }
 197 }
 198
 199 =method get_package_symbol $variable
 200
 201 Returns the value of the given package variable (including sigil).
 202
 203 =cut
 204
 205 sub get_package_symbol {
 206     my ($self, $variable, %opts) = @_;
 207
 208     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 209         ? @{$variable}{qw[name sigil type]}
 210         : $self->_deconstruct_variable_name($variable);
 211
 212     my $namespace = $self->namespace;
 213
 214     if (!exists $namespace->{$name}) {
 215         if ($opts{vivify}) {
 216             if ($type eq 'ARRAY') {
 217                 if (BROKEN_ISA_ASSIGNMENT) {
 218                     $self->add_package_symbol(
 219                         $variable,
 220                         $name eq 'ISA' ? () : ([])
 221                     );
 222                 }
 223                 else {
 224                     $self->add_package_symbol($variable, []);
 225                 }
 226             }
 227             elsif ($type eq 'HASH') {
 228                 $self->add_package_symbol($variable, {});
 229             }
 230             elsif ($type eq 'SCALAR') {
 231                 $self->add_package_symbol($variable);
 232             }
 233             elsif ($type eq 'IO') {
 234                 $self->add_package_symbol($variable, Symbol::geniosym);
 235             }
 236             elsif ($type eq 'CODE') {
 237                 confess "Don't know how to vivify CODE variables";
 238             }
 239             else {
 240                 confess "Unknown type $type in vivication";
 241             }
 242         }
 243         else {
 244             if ($type eq 'CODE') {
 245                 # this effectively "de-vivifies" the code slot. if we don't do
 246                 # this, referencing the coderef at the end of this function
 247                 # will cause perl to auto-vivify a stub coderef in the slot,
 248                 # which isn't what we want
 249                 $self->add_package_symbol($variable);
 250             }
 251         }
 252     }
 253
 254     my $entry_ref = \$namespace->{$name};
 255
 256     if (ref($entry_ref) eq 'GLOB') {
 257         return *{$entry_ref}{$type};
 258     }
 259     else {
 260         if ($type eq 'CODE') {
 261             no strict 'refs';
 262             return \&{ $self->name . '::' . $name };
 263         }
 264         else {
 265             return undef;
 266         }
 267     }
 268 }
 269
 270 =method get_or_add_package_symbol $variable
 271
 272 Like C<get_package_symbol>, except that it will return an empty hashref or
 273 arrayref if the variable doesn't exist.
 274
 275 =cut
 276
 277 sub get_or_add_package_symbol {
 278     my $self = shift;
 279     $self->get_package_symbol(@_, vivify => 1);
 280 }
 281
 282 =method remove_package_symbol $variable
 283
 284 Removes the package variable described by C<$variable> (which includes the
 285 sigil); other variables with the same name but different sigils will be
 286 untouched.
 287
 288 =method list_all_package_symbols $type_filter
 289
 290 Returns a list of package variable names in the package, without sigils. If a
 291 C<type_filter> is passed, it is used to select package variables of a given
 292 type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH',
 293 etc). Note that if the package contained any C<BEGIN> blocks, perl will leave
 294 an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is
 295 used (and similarly for C<INIT>, C<END>, etc).
 296
 297 =head1 BUGS
 298
 299 No known bugs.
 300
 301 Please report any bugs through RT: email
 302 C<bug-package-stash at rt.cpan.org>, or browse to
 303 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
 304
 305 =head1 SEE ALSO
 306
 307 =over 4
 308
 309 =item * L<Class::MOP::Package>
 310
 311 This module is a factoring out of code that used to live here
 312
 313 =back
 314
 315 =head1 SUPPORT
 316
 317 You can find this documentation for this module with the perldoc command.
 318
 319     perldoc Package::Stash
 320
 321 You can also look for information at:
 322
 323 =over 4
 324
 325 =item * AnnoCPAN: Annotated CPAN documentation
 326
 327 L<http://annocpan.org/dist/Package-Stash>
 328
 329 =item * CPAN Ratings
 330
 331 L<http://cpanratings.perl.org/d/Package-Stash>
 332
 333 =item * RT: CPAN's request tracker
 334
 335 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
 336
 337 =item * Search CPAN
 338
 339 L<http://search.cpan.org/dist/Package-Stash>
 340
 341 =back
 342
 343 =head1 AUTHOR
 344
 345 Jesse Luehrs <doy at tozt dot net>
 346
 347 Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
 348 Moose Cabal.
 349
 350 =cut
 351
 352 1;