X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash%2FPP.pm;h=8d958403d1953871348d51d8649c026db0731154;hb=e88665a5772fd94a541366c984ecbade0b39fc95;hp=227970abb8b873ec85632901a75f478fdd6936a6;hpb=7ef54f40657ca05b95a31e7c81c28c2446b2cf37;p=gitmo%2FPackage-Stash.git

diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm
index 227970a..8d95840 100644
--- a/lib/Package/Stash/PP.pm
+++ b/lib/Package/Stash/PP.pm
@@ -16,6 +16,9 @@ use constant BROKEN_WEAK_STASH     => ($] < 5.010);
 # before 5.10, the scalar slot was always treated as existing if the
 # glob existed
 use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010);
+# add_method on anon stashes triggers rt.perl #1804 otherwise
+# fixed in perl commit v5.13.3-70-g0fe688f
+use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004);
 
 =head1 SYNOPSIS
 
@@ -31,24 +34,35 @@ sub new {
     my $class = shift;
     my ($package) = @_;
 
-    if (!defined($package) || (ref($package) && ref($package) ne 'HASH')) {
+    if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) {
         confess "Package::Stash->new must be passed the name of the "
               . "package to access";
     }
-    elsif (ref($package) eq 'HASH') {
-        confess "The pure perl implementation of Package::Stash doesn't "
-              . "currently support anonymous stashes. You should install "
-              . "Package::Stash::XS";
+    elsif (ref($package) && reftype($package) eq 'HASH') {
+        confess "The PP implementation of Package::Stash does not support "
+              . "anonymous stashes before perl 5.14"
+            if BROKEN_GLOB_ASSIGNMENT;
+
+        return bless {
+            'namespace' => $package,
+        }, $class;
+    }
+    elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
+        return bless {
+            'package' => $package,
+        }, $class;
+    }
+    else {
+        confess "$package is not a module name";
     }
 
-    return bless {
-        'package' => $package,
-    }, $class;
 }
 
 sub name {
     confess "Can't call name as a class method"
         unless blessed($_[0]);
+    confess "Can't get the name of an anonymous package"
+        unless defined($_[0]->{package});
     return $_[0]->{package};
 }
 
@@ -74,6 +88,10 @@ sub namespace {
     }
 }
 
+sub _is_anon {
+    return !defined $_[0]->{package};
+}
+
 {
     my %SIGIL_MAP = (
         '$' => 'SCALAR',
@@ -86,17 +104,31 @@ sub namespace {
     sub _deconstruct_variable_name {
         my ($self, $variable) = @_;
 
-        (defined $variable && length $variable)
-            || confess "You must pass a variable name";
-
-        my $sigil = substr($variable, 0, 1, '');
-
-        if (exists $SIGIL_MAP{$sigil}) {
-            return ($variable, $sigil, $SIGIL_MAP{$sigil});
+        my @ret;
+        if (ref($variable) eq 'HASH') {
+            @ret = @{$variable}{qw[name sigil type]};
         }
         else {
-            return ("${sigil}${variable}", '', $SIGIL_MAP{''});
+            (defined $variable && length $variable)
+                || confess "You must pass a variable name";
+
+            my $sigil = substr($variable, 0, 1, '');
+
+            if (exists $SIGIL_MAP{$sigil}) {
+                @ret = ($variable, $sigil, $SIGIL_MAP{$sigil});
+            }
+            else {
+                @ret = ("${sigil}${variable}", '', $SIGIL_MAP{''});
+            }
         }
+
+        # XXX in pure perl, this will access things in inner packages,
+        # in xs, this will segfault - probably look more into this at
+        # some point
+        ($ret[0] !~ /::/)
+            || confess "Variable names may not contain ::";
+
+        return @ret;
     }
 }
 
@@ -116,11 +148,7 @@ sub _valid_for_type {
 sub add_symbol {
     my ($self, $variable, $initial_value, %opts) = @_;
 
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
-
-    my $pkg = $self->name;
+    my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 
     if (@_ > 2) {
         $self->_valid_for_type($initial_value, $type)
@@ -137,13 +165,30 @@ sub add_symbol {
             my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
 
             # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
-            $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
+            $DB::sub{$self->name . '::' . $name} = "$filename:$first_line_num-$last_line_num";
+        }
+    }
+
+    if (BROKEN_GLOB_ASSIGNMENT) {
+        if (@_ > 2) {
+            no strict 'refs';
+            *{ $self->name . '::' . $name } = ref $initial_value
+                ? $initial_value : \$initial_value;
+        }
+        else {
+            no strict 'refs';
+            *{ $self->name . '::' . $name };
         }
     }
+    else {
+        my $namespace = $self->namespace;
+        $namespace->{$name} ||= *{ Symbol::gensym() };
 
-    no strict 'refs';
-    no warnings 'redefine', 'misc', 'prototype';
-    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+        if (@_ > 2) {
+            *{ $namespace->{$name} } = ref $initial_value
+                ? $initial_value : \$initial_value;
+        }
+    }
 }
 
 sub remove_glob {
@@ -154,9 +199,7 @@ sub remove_glob {
 sub has_symbol {
     my ($self, $variable) = @_;
 
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
+    my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 
     my $namespace = $self->namespace;
 
@@ -186,9 +229,7 @@ sub has_symbol {
 sub get_symbol {
     my ($self, $variable, %opts) = @_;
 
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
+    my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 
     my $namespace = $self->namespace;
 
@@ -233,8 +274,25 @@ sub get_symbol {
     }
     else {
         if ($type eq 'CODE') {
-            no strict 'refs';
-            return \&{ $self->name . '::' . $name };
+            if (BROKEN_GLOB_ASSIGNMENT || !$self->_is_anon) {
+                no strict 'refs';
+                return \&{ $self->name . '::' . $name };
+            }
+
+            # XXX we should really be able to support arbitrary anonymous
+            # stashes here... (not just via Package::Anon)
+            if (blessed($namespace) && $namespace->isa('Package::Anon')) {
+                # ->can will call gv_init for us, which inflates the glob
+                # don't know how to do this in general
+                $namespace->bless(\(my $foo))->can($name);
+            }
+            else {
+                confess "Don't know how to inflate a " . ref($entry_ref)
+                      . " into a full coderef (perhaps you could use"
+                      . " Package::Anon instead of a bare stash?)"
+            }
+
+            return *{ $namespace->{$name} }{CODE};
         }
         else {
             return undef;
@@ -250,9 +308,7 @@ sub get_or_add_symbol {
 sub remove_symbol {
     my ($self, $variable) = @_;
 
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
+    my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 
     # FIXME:
     # no doubt this is grossly inefficient and