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             if ($type eq 'CODE') {
 200                 # this effectively "de-vivifies" the code slot. if we don't do
 201                 # this, referencing the coderef at the end of this function
 202                 # will cause perl to auto-vivify a stub coderef in the slot,
 203                 # which isn't what we want
 204                 $self->add_symbol($variable);
 205             }
 206         }
 207     }
 208
 209     my $entry_ref = \$namespace->{$name};
 210
 211     if (ref($entry_ref) eq 'GLOB') {
 212         return *{$entry_ref}{$type};
 213     }
 214     else {
 215         if ($type eq 'CODE') {
 216             no strict 'refs';
 217             return \&{ $self->name . '::' . $name };
 218         }
 219         else {
 220             return undef;
 221         }
 222     }
 223 }
 224
 225 sub get_or_add_symbol {
 226     my $self = shift;
 227     $self->get_symbol(@_, vivify => 1);
 228 }
 229
 230 sub remove_symbol {
 231     my ($self, $variable) = @_;
 232
 233     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 234         ? @{$variable}{qw[name sigil type]}
 235         : $self->_deconstruct_variable_name($variable);
 236
 237     # FIXME:
 238     # no doubt this is grossly inefficient and
 239     # could be done much easier and faster in XS
 240
 241     my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = (
 242         { sigil => '$', type => 'SCALAR', name => $name },
 243         { sigil => '@', type => 'ARRAY',  name => $name },
 244         { sigil => '%', type => 'HASH',   name => $name },
 245         { sigil => '&', type => 'CODE',   name => $name },
 246         { sigil => '',  type => 'IO',     name => $name },
 247     );
 248
 249     my ($scalar, $array, $hash, $code, $io);
 250     if ($type eq 'SCALAR') {
 251         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_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 'ARRAY') {
 257         $scalar = $self->get_symbol($scalar_desc);
 258         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_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 'HASH') {
 263         $scalar = $self->get_symbol($scalar_desc);
 264         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 265         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 266         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 267     }
 268     elsif ($type eq 'CODE') {
 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         $io     = $self->get_symbol($io_desc)     if $self->has_symbol($io_desc);
 273     }
 274     elsif ($type eq 'IO') {
 275         $scalar = $self->get_symbol($scalar_desc);
 276         $array  = $self->get_symbol($array_desc)  if $self->has_symbol($array_desc);
 277         $hash   = $self->get_symbol($hash_desc)   if $self->has_symbol($hash_desc);
 278         $code   = $self->get_symbol($code_desc)   if $self->has_symbol($code_desc);
 279     }
 280     else {
 281         confess "This should never ever ever happen";
 282     }
 283
 284     $self->remove_glob($name);
 285
 286     $self->add_symbol($scalar_desc => $scalar);
 287     $self->add_symbol($array_desc  => $array)  if defined $array;
 288     $self->add_symbol($hash_desc   => $hash)   if defined $hash;
 289     $self->add_symbol($code_desc   => $code)   if defined $code;
 290     $self->add_symbol($io_desc     => $io)     if defined $io;
 291 }
 292
 293 sub list_all_symbols {
 294     my ($self, $type_filter) = @_;
 295
 296     my $namespace = $self->namespace;
 297     return keys %{$namespace} unless defined $type_filter;
 298
 299     # NOTE:
 300     # or we can filter based on
 301     # type (SCALAR|ARRAY|HASH|CODE)
 302     if ($type_filter eq 'CODE') {
 303         return grep {
 304             # any non-typeglob in the symbol table is a constant or stub
 305             ref(\$namespace->{$_}) ne 'GLOB'
 306                 # regular subs are stored in the CODE slot of the typeglob
 307                 || defined(*{$namespace->{$_}}{CODE})
 308         } keys %{$namespace};
 309     }
 310     elsif ($type_filter eq 'SCALAR') {
 311         return grep {
 312             ref(\$namespace->{$_}) eq 'GLOB'
 313                 && defined(${*{$namespace->{$_}}{'SCALAR'}})
 314         } keys %{$namespace};
 315     }
 316     else {
 317         return grep {
 318             ref(\$namespace->{$_}) eq 'GLOB'
 319                 && defined(*{$namespace->{$_}}{$type_filter})
 320         } keys %{$namespace};
 321     }
 322 }
 323
 324 sub get_all_symbols {
 325     my ($self, $type_filter) = @_;
 326
 327     my $namespace = $self->namespace;
 328     return { %{$namespace} } unless defined $type_filter;
 329
 330     return {
 331         map { $_ => $self->get_symbol({name => $_, type => $type_filter}) }
 332             $self->list_all_symbols($type_filter)
 333     }
 334 }
 335
 336 =head1 BUGS
 337
 338 =over 4
 339
 340 =item * Scalar slots are only considered to exist if they are defined
 341
 342 This is due to a shortcoming within perl itself. See
 343 L<perlref/Making References> point 7 for more information.
 344
 345 =item * remove_symbol also replaces the associated typeglob
 346
 347 This can cause unexpected behavior when doing manipulation at compile time -
 348 removing subroutines will still allow them to be called from within the package
 349 as subroutines (although they will not be available as methods). This can be
 350 considered a feature in some cases (this is how L<namespace::clean> works, for
 351 instance), but should not be relied upon - use C<remove_glob> directly if you
 352 want this behavior.
 353
 354 =back
 355
 356 Please report any bugs through RT: email
 357 C<bug-package-stash at rt.cpan.org>, or browse to
 358 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
 359
 360 =head1 SEE ALSO
 361
 362 =over 4
 363
 364 =item * L<Class::MOP::Package>
 365
 366 This module is a factoring out of code that used to live here
 367
 368 =back
 369
 370 =head1 SUPPORT
 371
 372 You can find this documentation for this module with the perldoc command.
 373
 374     perldoc Package::Stash
 375
 376 You can also look for information at:
 377
 378 =over 4
 379
 380 =item * AnnoCPAN: Annotated CPAN documentation
 381
 382 L<http://annocpan.org/dist/Package-Stash>
 383
 384 =item * CPAN Ratings
 385
 386 L<http://cpanratings.perl.org/d/Package-Stash>
 387
 388 =item * RT: CPAN's request tracker
 389
 390 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
 391
 392 =item * Search CPAN
 393
 394 L<http://search.cpan.org/dist/Package-Stash>
 395
 396 =back
 397
 398 =head1 AUTHOR
 399
 400 Jesse Luehrs <doy at tozt dot net>
 401
 402 Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
 403 Moose Cabal.
 404
 405 =cut
 406
 407 1;