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