make CMOP::Package a thin wrapper around Package::Stash

diff --git a/Makefile.PL b/Makefile.PL
index 4b7cf9f..12c6a96 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -22,6 +22,7 @@ requires 'Data::OptList';
 requires 'Devel::GlobalDestruction';
 requires 'List::MoreUtils' => '0.12';
 requires 'MRO::Compat'  => '0.05';
+requires 'Package::Stash';
 requires 'Scalar::Util' => '1.18';
 requires 'Sub::Name'    => '0.04';
 requires 'Try::Tiny'    => '0.02';

diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index e34ec1b..35f7acb 100644 (file)
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -6,6 +6,7 @@ use warnings;
 
 use Scalar::Util 'blessed', 'reftype';
 use Carp         'confess';
+use Package::Stash;
 
 our $VERSION   = '1.02';
 $VERSION = eval $VERSION;
@@ -89,44 +90,11 @@ sub _new {
 # all these attribute readers will be bootstrapped 
 # away in the Class::MOP bootstrap section
 
-sub namespace { 
-    # NOTE:
-    # because of issues with the Perl API 
-    # to the typeglob in some versions, we 
-    # need to just always grab a new 
-    # reference to the hash here. Ideally 
-    # we could just store a ref and it would
-    # Just Work, but oh well :\    
-    no strict 'refs';    
-    \%{$_[0]->{'package'} . '::'} 
+sub _package_stash {
+    $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
 }
-
-# utility methods
-
-{
-    my %SIGIL_MAP = (
-        '$' => 'SCALAR',
-        '@' => 'ARRAY',
-        '%' => 'HASH',
-        '&' => 'CODE',
-    );
-    
-    sub _deconstruct_variable_name {
-        my ($self, $variable) = @_;
-
-        (defined $variable)
-            || confess "You must pass a variable name";    
-
-        my $sigil = substr($variable, 0, 1, '');
-
-        (defined $sigil)
-            || confess "The variable name must include a sigil";    
-
-        (exists $SIGIL_MAP{$sigil})
-            || confess "I do not recognize that sigil '$sigil'";    
-        
-        return ($variable, $sigil, $SIGIL_MAP{$sigil});
-    }
+sub namespace {
+    $_[0]->_package_stash->namespace
 }
 
 # Class attributes
@@ -134,155 +102,35 @@ sub namespace {
 # ... these functions have to touch the symbol table itself,.. yuk
 
 sub add_package_symbol {
-    my ($self, $variable, $initial_value) = @_;
-
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
-
-    my $pkg = $self->{'package'};
-
-    no strict 'refs';
-    no warnings 'redefine', 'misc', 'prototype';
-    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+    my $self = shift;
+    $self->_package_stash->add_package_symbol(@_);
 }
 
 sub remove_package_glob {
-    my ($self, $name) = @_;
-    no strict 'refs';        
-    delete ${$self->name . '::'}{$name};     
+    my $self = shift;
+    $self->_package_stash->remove_package_glob(@_);
 }
 
 # ... these functions deal with stuff on the namespace level
 
 sub has_package_symbol {
-    my ( $self, $variable ) = @_;
-
-    my ( $name, $sigil, $type )
-        = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
-
-    my $namespace = $self->namespace;
-
-    return 0 unless exists $namespace->{$name};
-
-    my $entry_ref = \$namespace->{$name};
-    if ( reftype($entry_ref) eq 'GLOB' ) {
-        if ( $type eq 'SCALAR' ) {
-            return defined( ${ *{$entry_ref}{SCALAR} } );
-        }
-        else {
-            return defined( *{$entry_ref}{$type} );
-        }
-    }
-    else {
-
-        # a symbol table entry can be -1 (stub), string (stub with prototype),
-        # or reference (constant)
-        return $type eq 'CODE';
-    }
+    my $self = shift;
+    $self->_package_stash->has_package_symbol(@_);
 }
 
 sub get_package_symbol {
-    my ($self, $variable) = @_;    
-
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
-
-    my $namespace = $self->namespace;
-
-    # FIXME
-    $self->add_package_symbol($variable)
-        unless exists $namespace->{$name};
-
-    my $entry_ref = \$namespace->{$name};
-
-    if ( ref($entry_ref) eq 'GLOB' ) {
-        return *{$entry_ref}{$type};
-    }
-    else {
-        if ( $type eq 'CODE' ) {
-            no strict 'refs';
-            return \&{ $self->name . '::' . $name };
-        }
-        else {
-            return undef;
-        }
-    }
+    my $self = shift;
+    $self->_package_stash->get_package_symbol(@_);
 }
 
 sub remove_package_symbol {
-    my ($self, $variable) = @_;
-
-    my ($name, $sigil, $type) = ref $variable eq 'HASH'
-        ? @{$variable}{qw[name sigil type]}
-        : $self->_deconstruct_variable_name($variable);
-
-    # FIXME:
-    # no doubt this is grossly inefficient and 
-    # could be done much easier and faster in XS
-
-    my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
-        { sigil => '$', type => 'SCALAR', name => $name },
-        { sigil => '@', type => 'ARRAY',  name => $name },
-        { sigil => '%', type => 'HASH',   name => $name },
-        { sigil => '&', type => 'CODE',   name => $name },
-    );
-
-    my ($scalar, $array, $hash, $code);
-    if ($type eq 'SCALAR') {
-        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
-        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
-        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);     
-    }
-    elsif ($type eq 'ARRAY') {
-        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
-        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
-        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
-    }
-    elsif ($type eq 'HASH') {
-        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
-        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
-        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);      
-    }
-    elsif ($type eq 'CODE') {
-        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
-        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
-        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);        
-    }    
-    else {
-        confess "This should never ever ever happen";
-    }
-        
-    $self->remove_package_glob($name);
-    
-    $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;      
-    $self->add_package_symbol($array_desc  => $array)  if defined $array;    
-    $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
-    $self->add_package_symbol($code_desc   => $code)   if defined $code;            
+    my $self = shift;
+    $self->_package_stash->remove_package_symbol(@_);
 }
 
 sub list_all_package_symbols {
-    my ($self, $type_filter) = @_;
-
-    my $namespace = $self->namespace;
-    return keys %{$namespace} unless defined $type_filter;
-    
-    # NOTE:
-    # or we can filter based on 
-    # type (SCALAR|ARRAY|HASH|CODE)
-    if ( $type_filter eq 'CODE' ) {
-        return grep { 
-        (ref($namespace->{$_})
-                ? (ref($namespace->{$_}) eq 'SCALAR')
-                : (ref(\$namespace->{$_}) eq 'GLOB'
-                   && defined(*{$namespace->{$_}}{CODE})));
-        } keys %{$namespace};
-    } else {
-        return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
-    }
+    my $self = shift;
+    $self->_package_stash->list_all_package_symbols(@_);
 }
 
 1;

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index f24118c..e5e1bed 100644 (file)
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -34,7 +34,7 @@ my @class_mop_package_methods = qw(
     add_package_symbol get_package_symbol has_package_symbol remove_package_symbol
     list_all_package_symbols get_all_package_symbols remove_package_glob
 
-    _deconstruct_variable_name
+    _package_stash
 
     get_method_map
 );

diff --git a/t/012_package_variables.t b/t/012_package_variables.t
index edba650..98d62cf 100644 (file)
--- a/t/012_package_variables.t
+++ b/t/012_package_variables.t
@@ -227,23 +227,4 @@ is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for
     ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed');
 }
 
-
-# check some errors
-
-dies_ok {
-    Foo->meta->add_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->remove_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->get_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->has_package_symbol('bar');
-} '... no sigil for bar';
-
 done_testing;

diff --git a/t/080_meta_package.t b/t/080_meta_package.t
index 0583d5d..a5d55fa 100644 (file)
--- a/t/080_meta_package.t
+++ b/t/080_meta_package.t
@@ -276,22 +276,5 @@ is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for
         "got the right ones",
     );
 }
-# check some errors
-
-dies_ok {
-    Foo->meta->add_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->remove_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->get_package_symbol('bar');
-} '... no sigil for bar';
-
-dies_ok {
-    Foo->meta->has_package_symbol('bar');
-} '... no sigil for bar';
 
 done_testing;

diff --git a/t/081_meta_package_extension.t b/t/081_meta_package_extension.t
index 4ac0a06..c8b2735 100644 (file)
--- a/t/081_meta_package_extension.t
+++ b/t/081_meta_package_extension.t
@@ -7,15 +7,15 @@ use Test::Exception;
 use Class::MOP;
 
 {
-    package My::Meta::Package;
-
+    package My::Package::Stash;
     use strict;
     use warnings;
 
-    use Carp 'confess';
-    use Symbol 'gensym';
+    use base 'Package::Stash';
 
-    use base 'Class::MOP::Package';
+    use metaclass;
+
+    use Symbol 'gensym';
 
     __PACKAGE__->meta->add_attribute(
         'namespace' => (
@@ -24,6 +24,11 @@ use Class::MOP;
         )
     );
 
+    sub new {
+        my $class = shift;
+        $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_));
+    }
+
     sub add_package_symbol {
         my ($self, $variable, $initial_value) = @_;
 
@@ -35,6 +40,19 @@ use Class::MOP;
     }
 }
 
+{
+    package My::Meta::Package;
+
+    use strict;
+    use warnings;
+
+    use base 'Class::MOP::Package';
+
+    sub _package_stash {
+        $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name);
+    }
+}
+
 # No actually package Foo exists :)
 my $meta = My::Meta::Package->initialize('Foo');