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
# 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 = (
'%' => '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;
=item B<name>
+=item B<namespace>
+
=item B<add_package_symbol>
=item B<get_package_symbol>
--- /dev/null
+#!/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');
+
projects / gitmo/Class-MOP.git / commitdiff