package Stash::Manip;
-use Moose;
+use strict;
+use warnings;
+
+use Carp qw(confess);
+use Scalar::Util qw(reftype);
=head1 NAME
=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
--- /dev/null
+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;
--- /dev/null
+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;
projects / gitmo/Package-Stash-XS.git / commitdiff