lib/Package/Stash/PP.pm

   1 package Package::Stash::PP;
   2 use strict;
   3 use warnings;
   4 # ABSTRACT: pure perl implementation of the Package::Stash API
   5
   6 use Carp qw(confess);
   7 use Scalar::Util qw(blessed reftype weaken);
   8 use Symbol;
   9 # before 5.12, assigning to the ISA glob would make it lose its magical ->isa
  10 # powers
  11 use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
  12 # before 5.10, stashes don't ever seem to drop to a refcount of zero, so
  13 # weakening them isn't helpful
  14 use constant BROKEN_WEAK_STASH     => ($] < 5.010);
  15
  16 =head1 SYNOPSIS
  17
  18   use Package::Stash;
  19
  20 =head1 DESCRIPTION
  21
  22 This is a backend for L<Package::Stash> implemented in pure perl, for those without a compiler or who would like to use this inline in scripts.
  23
  24 =cut
  25
  26 sub new {
  27     my $class = shift;
  28     my ($package) = @_;
  29     return bless {
  30         'package' => $package,
  31     }, $class;
  32 }
  33
  34 sub name {
  35     confess "Can't call name as a class method"
  36         unless blessed($_[0]);
  37     return $_[0]->{package};
  38 }
  39
  40 sub namespace {
  41     confess "Can't call namespace as a class method"
  42         unless blessed($_[0]);
  43
  44     if (BROKEN_WEAK_STASH) {
  45         no strict 'refs';
  46         return \%{$_[0]->name . '::'};
  47     }
  48     else {
  49         return $_[0]->{namespace} if defined $_[0]->{namespace};
  50
  51         {
  52             no strict 'refs';
  53             $_[0]->{namespace} = \%{$_[0]->name . '::'};
  54         }
  55
  56         weaken($_[0]->{namespace});
  57
  58         return $_[0]->{namespace};
  59     }
  60 }
  61
  62 {
  63     my %SIGIL_MAP = (
  64         '$' => 'SCALAR',
  65         '@' => 'ARRAY',
  66         '%' => 'HASH',
  67         '&' => 'CODE',
  68         ''  => 'IO',
  69     );
  70
  71     sub _deconstruct_variable_name {
  72         my ($self, $variable) = @_;
  73
  74         (defined $variable && length $variable)
  75             || confess "You must pass a variable name";
  76
  77         my $sigil = substr($variable, 0, 1, '');
  78
  79         if (exists $SIGIL_MAP{$sigil}) {
  80             return ($variable, $sigil, $SIGIL_MAP{$sigil});
  81         }
  82         else {
  83             return ("${sigil}${variable}", '', $SIGIL_MAP{''});
  84         }
  85     }
  86 }
  87
  88 sub _valid_for_type {
  89     my $self = shift;
  90     my ($value, $type) = @_;
  91     if ($type eq 'HASH' || $type eq 'ARRAY'
  92      || $type eq 'IO'   || $type eq 'CODE') {
  93         return reftype($value) eq $type;
  94     }
  95     else {
  96         my $ref = reftype($value);
  97         return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
  98     }
  99 }
 100
 101 sub add_symbol {
 102     my ($self, $variable, $initial_value, %opts) = @_;
 103
 104     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 105         ? @{$variable}{qw[name sigil type]}
 106         : $self->_deconstruct_variable_name($variable);
 107
 108     my $pkg = $self->name;
 109
 110     if (@_ > 2) {
 111         $self->_valid_for_type($initial_value, $type)
 112             || confess "$initial_value is not of type $type";
 113
 114         # cheap fail-fast check for PERLDBf_SUBLINE and '&'
 115         if ($^P and $^P & 0x10 && $sigil eq '&') {
 116             my $filename = $opts{filename};
 117             my $first_line_num = $opts{first_line_num};
 118
 119             (undef, $filename, $first_line_num) = caller
 120                 if not defined $filename;
 121
 122             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 123
 124             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
 125             $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
 126         }
 127     }
 128
 129     no strict 'refs';
 130     no warnings 'redefine', 'misc', 'prototype';
 131     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 132 }
 133
 134 sub remove_glob {
 135     my ($self, $name) = @_;
 136     delete $self->namespace->{$name};
 137 }
 138
 139 sub has_symbol {
 140     my ($self, $variable) = @_;
 141
 142     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 143         ? @{$variable}{qw[name sigil type]}
 144         : $self->_deconstruct_variable_name($variable);
 145
 146     my $namespace = $self->namespace;
 147
 148     return unless exists $namespace->{$name};
 149
 150     my $entry_ref = \$namespace->{$name};
 151     if (reftype($entry_ref) eq 'GLOB') {
 152         # XXX: assigning to any typeglob slot also initializes the SCALAR slot,
 153         # and saying that an undef scalar variable doesn't exist is probably
 154         # vaguely less surprising than a scalar variable popping into existence
 155         # without anyone defining it
 156         if ($type eq 'SCALAR') {
 157             return defined ${ *{$entry_ref}{$type} };
 158         }
 159         else {
 160             return defined *{$entry_ref}{$type};
 161         }
 162     }
 163     else {
 164         # a symbol table entry can be -1 (stub), string (stub with prototype),
 165         # or reference (constant)
 166         return $type eq 'CODE';
 167     }
 168 }
 169
 170 sub get_symbol {
 171     my ($self, $variable, %opts) = @_;
 172
 173     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 174         ? @{$variable}{qw[name sigil type]}
 175         : $self->_deconstruct_variable_name($variable);
 176
 177     my $namespace = $self->namespace;
 178
 179     if (!exists $namespace->{$name}) {
 180         if ($opts{vivify}) {
 181             if ($type eq 'ARRAY') {
 182                 if (BROKEN_ISA_ASSIGNMENT) {
 183                     $self->add_symbol(
 184                         $variable,
 185                         $name eq 'ISA' ? () : ([])
 186                     );
 187                 }
 188                 else {
 189                     $self->add_symbol($variable, []);
 190                 }
 191             }
 192             elsif ($type eq 'HASH') {
 193                 $self->add_symbol($variable, {});
 194             }
 195             elsif ($type eq 'SCALAR') {
 196                 $self->add_symbol($variable);
 197             }
 198             elsif ($type eq 'IO') {
 199                 $self->add_symbol($variable, Symbol::geniosym);
 200             }
 201             elsif ($type eq 'CODE') {
 202                 confess "Don't know how to vivify CODE variables";
 203             }
 204             else {
 205                 confess "Unknown type $type in vivication";
 206             }
 207         }
 208         else {
 209             return undef;
 210         }
 211     }
 212
 213     my $entry_ref = \$namespace->{$name};
 214
 215     if (ref($entry_ref) eq 'GLOB') {
 216         return *{$entry_ref}{$type};
 217     }
 218     else {
 219         if ($type eq 'CODE') {
 220             no strict 'refs';
 221             return \&{ $self->name . '::' . $name };
 222         }
 223         else {
 224             return undef;
 225         }
 226     }
 227 }
 228
 229 sub get_or_add_symbol {
 230     my $self = shift;
 231     $self->get_symbol(@_, vivify => 1);
 232 }
 233
 234 sub remove_symbol {
 235     my ($self, $variable) = @_;
 236
 237     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 238         ? @{$variable}{qw[name sigil type]}
 239         : $self->_deconstruct_variable_name($variable);
 240
 241     # FIXME:
 242     # no doubt this is grossly inefficient and
 243     # could be done much easier and faster in XS
 244
 245     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 246         { sigil => '$', type => 'SCALAR', name => $name },
 247         { sigil => '@', type => 'ARRAY',  name => $name },
 248         { sigil => '%', type => 'HASH',   name => $name },
 249         { sigil => '&', type => 'CODE',   name => $name },
 250         { sigil => '',  type => 'IO',     name => $name },
 251     );
 252
 253     my ($scalar, $array, $hash, $code, $io);
 254     if ($type eq 'SCALAR') {
 255         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 256         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
 257         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 258         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 259     }
 260     elsif ($type eq 'ARRAY') {
 261         $scalar = $self->get_symbol($scalar_desc);
 262         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
 263         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 264         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 265     }
 266     elsif ($type eq 'HASH') {
 267         $scalar = $self->get_symbol($scalar_desc);
 268         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 269         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 270         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 271     }
 272     elsif ($type eq 'CODE') {
 273         $scalar = $self->get_symbol($scalar_desc);
 274         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 275         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
 276         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 277     }
 278     elsif ($type eq 'IO') {
 279         $scalar = $self->get_symbol($scalar_desc);
 280         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 281         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
 282         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 283     }
 284     else {
 285         confess "This should never ever ever happen";
 286     }
 287
 288     $self->remove_glob($name);
 289
 290     $self->add_symbol($scalar_desc => $scalar);
 291     $self->add_symbol($array_desc  => $array)  if defined $array;
 292     $self->add_symbol($hash_desc   => $hash)   if defined $hash;
 293     $self->add_symbol($code_desc   => $code)   if defined $code;
 294     $self->add_symbol($io_desc     => $io)     if defined $io;
 295 }
 296
 297 sub list_all_symbols {
 298     my ($self, $type_filter) = @_;
 299
 300     my $namespace = $self->namespace;
 301     return keys %{$namespace} unless defined $type_filter;
 302
 303     # NOTE:
 304     # or we can filter based on
 305     # type (SCALAR|ARRAY|HASH|CODE)
 306     if ($type_filter eq 'CODE') {
 307         return grep {
 308             # any non-typeglob in the symbol table is a constant or stub
 309             ref(\$namespace->{$_}) ne 'GLOB'
 310                 # regular subs are stored in the CODE slot of the typeglob
 311                 || defined(*{$namespace->{$_}}{CODE})
 312         } keys %{$namespace};
 313     }
 314     elsif ($type_filter eq 'SCALAR') {
 315         return grep {
 316             ref(\$namespace->{$_}) eq 'GLOB'
 317                 && defined(${*{$namespace->{$_}}{'SCALAR'}})
 318         } keys %{$namespace};
 319     }
 320     else {
 321         return grep {
 322             ref(\$namespace->{$_}) eq 'GLOB'
 323                 && defined(*{$namespace->{$_}}{$type_filter})
 324         } keys %{$namespace};
 325     }
 326 }
 327
 328 sub get_all_symbols {
 329     my ($self, $type_filter) = @_;
 330
 331     my $namespace = $self->namespace;
 332     return { %{$namespace} } unless defined $type_filter;
 333
 334     return {
 335         map { $_ => $self->get_symbol({name => $_, type => $type_filter}) }
 336             $self->list_all_symbols($type_filter)
 337     }
 338 }
 339
 340 =head1 BUGS
 341
 342 =over 4
 343
 344 =item * Scalar slots are only considered to exist if they are defined
 345
 346 This is due to a shortcoming within perl itself. See
 347 L<perlref/Making References> point 7 for more information.
 348
 349 =item * remove_symbol also replaces the associated typeglob
 350
 351 This can cause unexpected behavior when doing manipulation at compile time -
 352 removing subroutines will still allow them to be called from within the package
 353 as subroutines (although they will not be available as methods). This can be
 354 considered a feature in some cases (this is how L<namespace::clean> works, for
 355 instance), but should not be relied upon - use C<remove_glob> directly if you
 356 want this behavior.
 357
 358 =item * Some minor memory leaks
 359
 360 The pure perl implementation has a couple minor memory leaks (see the TODO
 361 tests in t/20-leaks.t) that I'm having a hard time tracking down - these may be
 362 core perl bugs, it's hard to tell.
 363
 364 =back
 365
 366 Please report any bugs through RT: email
 367 C<bug-package-stash at rt.cpan.org>, or browse to
 368 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
 369
 370 =head1 SEE ALSO
 371
 372 =over 4
 373
 374 =item * L<Class::MOP::Package>
 375
 376 This module is a factoring out of code that used to live here
 377
 378 =back
 379
 380 =head1 SUPPORT
 381
 382 You can find this documentation for this module with the perldoc command.
 383
 384     perldoc Package::Stash
 385
 386 You can also look for information at:
 387
 388 =over 4
 389
 390 =item * AnnoCPAN: Annotated CPAN documentation
 391
 392 L<http://annocpan.org/dist/Package-Stash>
 393
 394 =item * CPAN Ratings
 395
 396 L<http://cpanratings.perl.org/d/Package-Stash>
 397
 398 =item * RT: CPAN's request tracker
 399
 400 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
 401
 402 =item * Search CPAN
 403
 404 L<http://search.cpan.org/dist/Package-Stash>
 405
 406 =back
 407
 408 =head1 AUTHOR
 409
 410 Jesse Luehrs <doy at tozt dot net>
 411
 412 Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
 413 Moose Cabal.
 414
 415 =begin Pod::Coverage
 416
 417 BROKEN_ISA_ASSIGNMENT
 418 add_symbol
 419 get_all_symbols
 420 get_or_add_symbol
 421 get_symbol
 422 has_symbol
 423 list_all_symbols
 424 name
 425 namespace
 426 new
 427 remove_glob
 428
 429 =end Pod::Coverage
 430
 431 =cut
 432
 433 1;