From: Stevan Little Date: Fri, 4 Aug 2006 04:23:52 +0000 (+0000) Subject: more-package-refactoring X-Git-Tag: 0_33~11^2~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a5e51f0baa6e418d27bf9f1514a5ac63fc879acb;p=gitmo%2FClass-MOP.git more-package-refactoring --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 05176ef..359abfa 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -53,6 +53,22 @@ Class::MOP::Package->meta->add_attribute( )) ); +Class::MOP::Package->meta->add_attribute( + Class::MOP::Attribute->new('%:namespace' => ( + reader => { + 'namespace' => sub { (shift)->{'%:namespace'} } + }, + default => sub { + my ($class) = @_; + no strict 'refs'; + return \%{$class->name . '::'}; + }, + # NOTE: + # protect this from silliness + init_arg => '............something no one will guess ...............', + )) +); + # NOTE: # use the metaclass to construct the meta-package # which is a superclass of the metaclass itself :P diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index b2cb51d..8ec890a 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -93,9 +93,11 @@ my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; $class = blessed($class) || $class; # now create the metaclass my $meta; - if ($class =~ /^Class::MOP::Class$/) { + if ($class =~ /^Class::MOP::Class$/) { + no strict 'refs'; $meta = bless { '$:package' => $package_name, + '%:namespace' => \%{$package_name . '::'}, '%:attributes' => {}, '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', @@ -109,6 +111,7 @@ my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; # Class::MOP::Class, which defines meta $meta = $class->meta->construct_instance(%options) } + # and check the metaclass compatibility $meta->check_metaclass_compatability(); $METAS{$package_name} = $meta; diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index 6cd2e6c..9dca7fa 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -7,7 +7,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'looks_like_number'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; use base 'Class::MOP::Class'; @@ -29,8 +29,7 @@ sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" sub superclasses { my $class = shift; (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance'; - no strict 'refs'; - @{$class->name . '::ISA'}; + @{$class->get_package_symbol('@ISA')}; } # predicates diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 82a7324..184dd13 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -23,7 +23,11 @@ sub initialize { my $package_name = shift; # we hand-construct the class # until we can bootstrap it - return bless { '$:package' => $package_name } => $class; + no strict 'refs'; + return bless { + '$:package' => $package_name, + '%:namespace' => \%{$package_name . '::'}, + } => $class; } # Attributes @@ -32,9 +36,10 @@ sub initialize { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub name { $_[0]->{'$:package'} } +sub name { $_[0]->{'$:package'} } +sub namespace { $_[0]->{'%:namespace'} } -# Class attributes +# utility methods { my %SIGIL_MAP = ( @@ -43,110 +48,94 @@ sub name { $_[0]->{'$:package'} } '%' => 'HASH', '&' => 'CODE', ); - - sub add_package_symbol { - my ($self, $variable, $initial_value) = @_; + sub _deconstruct_variable_name { + my ($self, $variable) = @_; + (defined $variable) || confess "You must pass a variable name"; - + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - + (defined $sigil) || confess "The variable name must include a sigil"; - + (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; - - no strict 'refs'; - no warnings 'misc', 'redefine'; - *{$self->name . '::' . $name} = $initial_value; + || confess "I do not recognize that sigil '$sigil'"; + + return ($name, $sigil, $SIGIL_MAP{$sigil}); } +} - sub has_package_symbol { - my ($self, $variable) = @_; - (defined $variable) - || confess "You must pass a variable name"; +# Class attributes - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - - (defined $sigil) - || confess "The variable name must include a sigil"; - - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; - - no strict 'refs'; - defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0; - - } +sub add_package_symbol { + my ($self, $variable, $initial_value) = @_; - sub get_package_symbol { - my ($self, $variable) = @_; - (defined $variable) - || confess "You must pass a variable name"; - - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - - (defined $sigil) - || confess "The variable name must include a sigil"; - - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; - - no strict 'refs'; - return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}}; + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); - } + no strict 'refs'; + no warnings 'misc', 'redefine'; + *{$self->name . '::' . $name} = $initial_value; +} - sub remove_package_symbol { - my ($self, $variable) = @_; - - (defined $variable) - || confess "You must pass a variable name"; - - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - - (defined $sigil) - || confess "The variable name must include a sigil"; - - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; - - no strict 'refs'; - if ($SIGIL_MAP{$sigil} eq 'SCALAR') { - undef ${$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') { - undef @{$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'HASH') { - undef %{$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'CODE') { - # FIXME: - # this is crap, it is probably much - # easier to write this in XS. - my ($scalar, @array, %hash); - $scalar = ${$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{SCALAR}; - @array = @{$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{ARRAY}; - %hash = %{$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{HASH}; +sub has_package_symbol { + my ($self, $variable) = @_; + + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + + return 0 unless exists $self->namespace->{$name}; + defined *{$self->namespace->{$name}}{$type} ? 1 : 0; +} + +sub get_package_symbol { + my ($self, $variable) = @_; + + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + + return *{$self->namespace->{$name}}{$type} + if exists $self->namespace->{$name}; + $self->add_package_symbol($variable); +} + +sub remove_package_symbol { + my ($self, $variable) = @_; + + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + + if ($type eq 'SCALAR') { + undef ${$self->namespace->{$name}}; + } + elsif ($type eq 'ARRAY') { + undef @{$self->namespace->{$name}}; + } + elsif ($type eq 'HASH') { + undef %{$self->namespace->{$name}}; + } + elsif ($type eq 'CODE') { + # FIXME: + # this is crap, it is probably much + # easier to write this in XS. + my ($scalar, @array, %hash); + $scalar = ${$self->namespace->{$name}} if defined *{$self->namespace->{$name}}{SCALAR}; + @array = @{$self->namespace->{$name}} if defined *{$self->namespace->{$name}}{ARRAY}; + %hash = %{$self->namespace->{$name}} if defined *{$self->namespace->{$name}}{HASH}; + { + no strict 'refs'; delete ${$self->name . '::'}{$name}; - ${$self->name . '::' . $name} = $scalar if defined $scalar; - @{$self->name . '::' . $name} = @array if scalar @array; - %{$self->name . '::' . $name} = %hash if keys %hash; - } - else { - confess "This should never ever ever happen"; } + ${$self->namespace->{$name}} = $scalar if defined $scalar; + @{$self->namespace->{$name}} = @array if scalar @array; + %{$self->namespace->{$name}} = %hash if keys %hash; + } + else { + confess "This should never ever ever happen"; } - } sub list_all_package_symbols { my ($self) = @_; - no strict 'refs'; - return keys %{$self->name . '::'}; + return keys %{$self->namespace}; } 1; @@ -173,6 +162,8 @@ Class::MOP::Package - Package Meta Object =item B +=item B + =item B =item B diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 5972bdb..437e73f 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 173; +use Test::More tests => 179; use Test::Exception; BEGIN { @@ -33,8 +33,11 @@ my @class_mop_package_methods = qw( initialize name + namespace add_package_symbol get_package_symbol has_package_symbol remove_package_symbol list_all_package_symbols + + _deconstruct_variable_name ); my @class_mop_module_methods = qw( @@ -131,6 +134,7 @@ foreach my $non_method_name (qw( my @class_mop_package_attributes = ( '$:package', + '%:namespace', ); my @class_mop_module_attributes = ( diff --git a/t/081_meta_package_extension.t b/t/081_meta_package_extension.t new file mode 100644 index 0000000..4e42d12 --- /dev/null +++ b/t/081_meta_package_extension.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP'); +} + +{ + package My::Meta::Package; + + use strict; + use warnings; + + use Carp 'confess'; + use Symbol 'gensym'; + + use base 'Class::MOP::Package'; + + __PACKAGE__->meta->add_attribute( + '%:namespace' => ( + default => sub { {} } + ) + ); + + sub add_package_symbol { + my ($self, $variable, $initial_value) = @_; + + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = $glob; + } +} + +# No actually package Foo exists :) + +my $meta = My::Meta::Package->initialize('Foo'); + +isa_ok($meta, 'My::Meta::Package'); +isa_ok($meta, 'Class::MOP::Package'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); + +lives_ok { + $meta->add_package_symbol('%foo' => { one => 1 }); +} '... the %foo symbol is created succcessfully'; + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); +ok($meta->has_package_symbol('%foo'), '... the meta agrees'); + +my $foo = $meta->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); +} '... created @Foo::bar successfully'; + +ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +lives_ok { + $meta->add_package_symbol('%baz'); +} '... created %Foo::baz successfully'; + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); +