From f10f6217cffc0c5dea63b2962dc33a552ebd8d4f Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Mon, 10 May 2010 22:01:03 -0500 Subject: initial import of code from Class::MOP::Package --- lib/Stash/Manip.pm | 205 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 202 insertions(+), 3 deletions(-) (limited to 'lib/Stash/Manip.pm') 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 -- cgit v1.2.3-54-g00ecf