diff options
| -rw-r--r-- | lib/Stash/Manip.pm | 205 | ||||
| -rw-r--r-- | t/001-basic.t | 246 | ||||
| -rw-r--r-- | t/002-extension.t | 70 |
3 files changed, 518 insertions, 3 deletions
diff --git a/lib/Stash/Manip.pm b/lib/Stash/Manip.pm index d957424..b6e0061 100644 --- a/lib/Stash/Manip.pm +++ b/lib/Stash/Manip.pm @@ -1,5 +1,9 @@ package Stash::Manip; -use Moose; +use strict; +use warnings; + +use Carp qw(confess); +use Scalar::Util qw(reftype); =head1 NAME @@ -13,8 +17,203 @@ Stash::Manip - =cut -__PACKAGE__->meta->make_immutable; -no Moose; +sub new { + my $class = shift; + my ($namespace) = @_; + return bless { package => $namespace }, $class; +} + +sub name { + return $_[0]->{package}; +} + +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'; + return \%{$_[0]->name . '::'}; +} + +{ + 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 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->name; + + no strict 'refs'; + no warnings 'redefine', 'misc', 'prototype'; + *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; +} + +sub remove_package_glob { + my ($self, $name) = @_; + no strict 'refs'; + delete ${$self->name . '::'}{$name}; +} + +# ... 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 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'; + } +} + +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; + } + } +} + +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; +} + +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}; + } +} =head1 BUGS diff --git a/t/001-basic.t b/t/001-basic.t new file mode 100644 index 0000000..a3ab29d --- /dev/null +++ b/t/001-basic.t @@ -0,0 +1,246 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use Stash::Manip; + +dies_ok { Stash::Manip->name } q{... can't call name() as a class method}; + +{ + package Foo; + + use constant SOME_CONSTANT => 1; +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +my $foo_stash = Stash::Manip->new('Foo'); +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_package_symbol('%foo'), '... the object agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +lives_ok { + $foo_stash->add_package_symbol('%foo' => { one => 1 }); +} '... created %Foo::foo successfully'; + +# ... scalar should NOT be created here + +ok(!$foo_stash->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok($foo_stash->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = $foo_stash->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]); +} '... created @Foo::bar successfully'; + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok($foo_stash->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!$foo_stash->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('$baz' => 10); +} '... created $Foo::baz successfully'; + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok($foo_stash->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!$foo_stash->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${$foo_stash->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${$foo_stash->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk" }); +} '... created &Foo::funk successfully'; + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok($foo_stash->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!$foo_stash->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +lives_ok { + $foo_stash->add_package_symbol('@foo' => $ARRAY); +} '... created @Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +lives_ok { + $foo_stash->add_package_symbol('&foo' => $CODE); +} '... created &Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('&foo'), '... the meta agrees'); +is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +lives_ok { + $foo_stash->add_package_symbol('$foo' => 'Foo::foo'); +} '... created $Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = $foo_stash->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +lives_ok { + $foo_stash->remove_package_symbol('%foo'); +} '... removed %Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok($foo_stash->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +lives_ok { + $foo_stash->remove_package_symbol('&foo'); +} '... removed &Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +lives_ok { + $foo_stash->remove_package_symbol('$foo'); +} '... removed $Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +# check some errors + +dies_ok { + $foo_stash->add_package_symbol('bar'); +} '... no sigil for bar'; + +dies_ok { + $foo_stash->remove_package_symbol('bar'); +} '... no sigil for bar'; + +dies_ok { + $foo_stash->get_package_symbol('bar'); +} '... no sigil for bar'; + +dies_ok { + $foo_stash->has_package_symbol('bar'); +} '... no sigil for bar'; + +done_testing; diff --git a/t/002-extension.t b/t/002-extension.t new file mode 100644 index 0000000..4a9e7c1 --- /dev/null +++ b/t/002-extension.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +{ + package My::Stash::Manip; + use strict; + use warnings; + + use base 'Stash::Manip'; + + use Symbol 'gensym'; + + sub namespace { + $_[0]->{namespace} ||= {} + } + + 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 $foo_stash = My::Stash::Manip->new('Foo'); + +isa_ok($foo_stash, 'My::Stash::Manip'); +isa_ok($foo_stash, 'Stash::Manip'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); + +lives_ok { + $foo_stash->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($foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); + +my $foo = $foo_stash->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the foo_stashs'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + $foo_stash->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 { + $foo_stash->add_package_symbol('%baz'); +} '... created %Foo::baz successfully'; + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; |