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