From e94260dab724974551751dbdda9c4c9abde76e6e Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Fri, 14 May 2010 11:39:56 -0500 Subject: rename Stash::Manip -> Package::Stash --- lib/Package/Stash.pm | 400 +++++++++++++++++++++++++++++++++++++++++++++++++++ lib/Stash/Manip.pm | 400 --------------------------------------------------- 2 files changed, 400 insertions(+), 400 deletions(-) create mode 100644 lib/Package/Stash.pm delete mode 100644 lib/Stash/Manip.pm (limited to 'lib') diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm new file mode 100644 index 0000000..84a4d0b --- /dev/null +++ b/lib/Package/Stash.pm @@ -0,0 +1,400 @@ +package Package::Stash; +use strict; +use warnings; + +use Carp qw(confess); +use Scalar::Util qw(reftype); + +=head1 NAME + +Package::Stash - routines for manipulating stashes + +=head1 SYNOPSIS + + my $stash = Package::Stash->new('Foo'); + $stash->add_package_symbol('%foo', {bar => 1}); + # $Foo::foo{bar} == 1 + $stash->has_package_symbol('$foo') # false + my $namespace = $stash->namespace; + *{ $namespace->{foo} }{HASH} # {bar => 1} + +=head1 DESCRIPTION + +Manipulating stashes (Perl's symbol tables) is occasionally necessary, but +incredibly messy, and easy to get wrong. This module hides all of that behind a +simple API. + +NOTE: Most methods in this class require a variable specification that includes +a sigil. If this sigil is absent, it is assumed to represent the IO slot. + +=head1 METHODS + +=cut + +=head2 new $package_name + +Creates a new C object, for the package given as the only +argument. + +=cut + +sub new { + my $class = shift; + my ($namespace) = @_; + return bless { 'package' => $namespace }, $class; +} + +=head2 name + +Returns the name of the package that this object represents. + +=cut + +sub name { + return $_[0]->{package}; +} + +=head2 namespace + +Returns the raw stash itself. + +=cut + +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', + '' => 'IO', + ); + + sub _deconstruct_variable_name { + my ($self, $variable) = @_; + + (defined $variable && length $variable) + || confess "You must pass a variable name"; + + my $sigil = substr($variable, 0, 1, ''); + + if (exists $SIGIL_MAP{$sigil}) { + return ($variable, $sigil, $SIGIL_MAP{$sigil}); + } + else { + return ("${sigil}${variable}", '', $SIGIL_MAP{''}); + } + } +} + +=head2 add_package_symbol $variable $value + +Adds a new package symbol, for the symbol given as C<$variable>, and optionally +gives it an initial value of C<$value>. C<$variable> should be the name of +variable including the sigil, so + + Package::Stash->new('Foo')->add_package_symbol('%foo') + +will create C<%Foo::foo>. + +=cut + +sub _valid_for_type { + my $self = shift; + my ($value, $type) = @_; + if ($type eq 'HASH' || $type eq 'ARRAY' + || $type eq 'IO' || $type eq 'CODE') { + return reftype($value) eq $type; + } + else { + my $ref = reftype($value); + return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE'; + } +} + +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); + + if (@_ > 2) { + $self->_valid_for_type($initial_value, $type) + || confess "$initial_value is not of type $type"; + } + + my $pkg = $self->name; + + no strict 'refs'; + no warnings 'redefine', 'misc', 'prototype'; + *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; +} + +=head2 remove_package_glob $name + +Removes all package variables with the given name, regardless of sigil. + +=cut + +sub remove_package_glob { + my ($self, $name) = @_; + no strict 'refs'; + delete ${$self->name . '::'}{$name}; +} + +# ... these functions deal with stuff on the namespace level + +=head2 has_package_symbol $variable + +Returns whether or not the given package variable (including sigil) exists. + +=cut + +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'; + } +} + +=head2 get_package_symbol $variable + +Returns the value of the given package variable (including sigil). + +=cut + +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; + + if (!exists $namespace->{$name}) { + # assigning to the result of this function like + # @{$stash->get_package_symbol('@ISA')} = @new_ISA + # makes the result not visible until the variable is explicitly + # accessed... in the case of @ISA, this might never happen + # for instance, assigning like that and then calling $obj->isa + # will fail. see t/005-isa.t + if ($type eq 'ARRAY' && $name ne 'ISA') { + $self->add_package_symbol($variable, []); + } + elsif ($type eq 'HASH') { + $self->add_package_symbol($variable, {}); + } + else { + # FIXME + $self->add_package_symbol($variable) + } + } + + 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; + } + } +} + +=head2 remove_package_symbol $variable + +Removes the package variable described by C<$variable> (which includes the +sigil); other variables with the same name but different sigils will be +untouched. + +=cut + +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, $io_desc) = ( + { sigil => '$', type => 'SCALAR', name => $name }, + { sigil => '@', type => 'ARRAY', name => $name }, + { sigil => '%', type => 'HASH', name => $name }, + { sigil => '&', type => 'CODE', name => $name }, + { sigil => '', type => 'IO', name => $name }, + ); + + my ($scalar, $array, $hash, $code, $io); + 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); + $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); + } + elsif ($type eq 'ARRAY') { + $scalar = $self->get_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); + $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); + } + elsif ($type eq 'HASH') { + $scalar = $self->get_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); + $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); + } + elsif ($type eq 'CODE') { + $scalar = $self->get_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); + $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); + } + elsif ($type eq 'IO') { + $scalar = $self->get_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); + $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); + } + else { + confess "This should never ever ever happen"; + } + + $self->remove_package_glob($name); + + $self->add_package_symbol($scalar_desc => $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; + $self->add_package_symbol($io_desc => $io) if defined $io; +} + +=head2 list_all_package_symbols $type_filter + +Returns a list of package variable names in the package, without sigils. If a +C is passed, it is used to select package variables of a given +type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', +etc). + +=cut + +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 + +No known bugs. + +Please report any bugs through RT: email +C, or browse to +L. + +=head1 SEE ALSO + +L - this module is a factoring out of code that used to +live here + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Package::Stash + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * RT: CPAN's request tracker + +L + +=item * Search CPAN + +L + +=back + +=head1 AUTHOR + + Jesse Luehrs + +Mostly copied from code from L, by Stevan Little and the +Moose Cabal. + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2010 by Jesse Luehrs. + +This is free software; you can redistribute it and/or modify it under +the same terms as perl itself. + +=cut + +1; diff --git a/lib/Stash/Manip.pm b/lib/Stash/Manip.pm deleted file mode 100644 index cad3742..0000000 --- a/lib/Stash/Manip.pm +++ /dev/null @@ -1,400 +0,0 @@ -package Stash::Manip; -use strict; -use warnings; - -use Carp qw(confess); -use Scalar::Util qw(reftype); - -=head1 NAME - -Stash::Manip - routines for manipulating stashes - -=head1 SYNOPSIS - - my $stash = Stash::Manip->new('Foo'); - $stash->add_package_symbol('%foo', {bar => 1}); - # $Foo::foo{bar} == 1 - $stash->has_package_symbol('$foo') # false - my $namespace = $stash->namespace; - *{ $namespace->{foo} }{HASH} # {bar => 1} - -=head1 DESCRIPTION - -Manipulating stashes (Perl's symbol tables) is occasionally necessary, but -incredibly messy, and easy to get wrong. This module hides all of that behind a -simple API. - -NOTE: Most methods in this class require a variable specification that includes -a sigil. If this sigil is absent, it is assumed to represent the IO slot. - -=head1 METHODS - -=cut - -=head2 new $package_name - -Creates a new C object, for the package given as the only -argument. - -=cut - -sub new { - my $class = shift; - my ($namespace) = @_; - return bless { 'package' => $namespace }, $class; -} - -=head2 name - -Returns the name of the package that this object represents. - -=cut - -sub name { - return $_[0]->{package}; -} - -=head2 namespace - -Returns the raw stash itself. - -=cut - -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', - '' => 'IO', - ); - - sub _deconstruct_variable_name { - my ($self, $variable) = @_; - - (defined $variable && length $variable) - || confess "You must pass a variable name"; - - my $sigil = substr($variable, 0, 1, ''); - - if (exists $SIGIL_MAP{$sigil}) { - return ($variable, $sigil, $SIGIL_MAP{$sigil}); - } - else { - return ("${sigil}${variable}", '', $SIGIL_MAP{''}); - } - } -} - -=head2 add_package_symbol $variable $value - -Adds a new package symbol, for the symbol given as C<$variable>, and optionally -gives it an initial value of C<$value>. C<$variable> should be the name of -variable including the sigil, so - - Stash::Manip->new('Foo')->add_package_symbol('%foo') - -will create C<%Foo::foo>. - -=cut - -sub _valid_for_type { - my $self = shift; - my ($value, $type) = @_; - if ($type eq 'HASH' || $type eq 'ARRAY' - || $type eq 'IO' || $type eq 'CODE') { - return reftype($value) eq $type; - } - else { - my $ref = reftype($value); - return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE'; - } -} - -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); - - if (@_ > 2) { - $self->_valid_for_type($initial_value, $type) - || confess "$initial_value is not of type $type"; - } - - my $pkg = $self->name; - - no strict 'refs'; - no warnings 'redefine', 'misc', 'prototype'; - *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; -} - -=head2 remove_package_glob $name - -Removes all package variables with the given name, regardless of sigil. - -=cut - -sub remove_package_glob { - my ($self, $name) = @_; - no strict 'refs'; - delete ${$self->name . '::'}{$name}; -} - -# ... these functions deal with stuff on the namespace level - -=head2 has_package_symbol $variable - -Returns whether or not the given package variable (including sigil) exists. - -=cut - -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'; - } -} - -=head2 get_package_symbol $variable - -Returns the value of the given package variable (including sigil). - -=cut - -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; - - if (!exists $namespace->{$name}) { - # assigning to the result of this function like - # @{$stash->get_package_symbol('@ISA')} = @new_ISA - # makes the result not visible until the variable is explicitly - # accessed... in the case of @ISA, this might never happen - # for instance, assigning like that and then calling $obj->isa - # will fail. see t/005-isa.t - if ($type eq 'ARRAY' && $name ne 'ISA') { - $self->add_package_symbol($variable, []); - } - elsif ($type eq 'HASH') { - $self->add_package_symbol($variable, {}); - } - else { - # FIXME - $self->add_package_symbol($variable) - } - } - - 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; - } - } -} - -=head2 remove_package_symbol $variable - -Removes the package variable described by C<$variable> (which includes the -sigil); other variables with the same name but different sigils will be -untouched. - -=cut - -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, $io_desc) = ( - { sigil => '$', type => 'SCALAR', name => $name }, - { sigil => '@', type => 'ARRAY', name => $name }, - { sigil => '%', type => 'HASH', name => $name }, - { sigil => '&', type => 'CODE', name => $name }, - { sigil => '', type => 'IO', name => $name }, - ); - - my ($scalar, $array, $hash, $code, $io); - 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); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'ARRAY') { - $scalar = $self->get_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); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'HASH') { - $scalar = $self->get_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); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'CODE') { - $scalar = $self->get_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); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'IO') { - $scalar = $self->get_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); - $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); - } - else { - confess "This should never ever ever happen"; - } - - $self->remove_package_glob($name); - - $self->add_package_symbol($scalar_desc => $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; - $self->add_package_symbol($io_desc => $io) if defined $io; -} - -=head2 list_all_package_symbols $type_filter - -Returns a list of package variable names in the package, without sigils. If a -C is passed, it is used to select package variables of a given -type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', -etc). - -=cut - -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 - -No known bugs. - -Please report any bugs through RT: email -C, or browse to -L. - -=head1 SEE ALSO - -L - this module is a factoring out of code that used to -live here - -=head1 SUPPORT - -You can find this documentation for this module with the perldoc command. - - perldoc Stash::Manip - -You can also look for information at: - -=over 4 - -=item * AnnoCPAN: Annotated CPAN documentation - -L - -=item * CPAN Ratings - -L - -=item * RT: CPAN's request tracker - -L - -=item * Search CPAN - -L - -=back - -=head1 AUTHOR - - Jesse Luehrs - -Mostly copied from code from L, by Stevan Little and the -Moose Cabal. - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by Jesse Luehrs. - -This is free software; you can redistribute it and/or modify it under -the same terms as perl itself. - -=cut - -1; -- cgit v1.2.3-54-g00ecf