package Package::Stash;
use strict;
use warnings;
+# ABSTRACT: routines for manipulating stashes
use Carp qw(confess);
use Scalar::Util qw(reftype);
-
-=head1 NAME
-
-Package::Stash - routines for manipulating stashes
+use Symbol;
+# before 5.12, assigning to the ISA glob would make it lose its magical ->isa
+# powers
+use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
=head1 SYNOPSIS
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
+=method new $package_name
Creates a new C<Package::Stash> object, for the package given as the only
argument.
sub new {
my $class = shift;
- my ($namespace) = @_;
- return bless { 'package' => $namespace }, $class;
+ my ($package) = @_;
+ my $namespace;
+ {
+ no strict 'refs';
+ # supposedly this caused a bug in earlier perls, but I can't reproduce
+ # it, so re-enabling the caching
+ $namespace = \%{$package . '::'};
+ }
+ return bless {
+ 'package' => $package,
+ 'namespace' => $namespace,
+ }, $class;
}
-=head2 name
+=method name
Returns the name of the package that this object represents.
return $_[0]->{package};
}
-=head2 namespace
+=method 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 . '::'};
+ return $_[0]->{namespace};
}
{
}
}
-=head2 add_package_symbol $variable $value %opts
+=method add_package_symbol $variable $value %opts
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
*{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
}
-=head2 remove_package_glob $name
+=method remove_package_glob $name
Removes all package variables with the given name, regardless of sigil.
# ... these functions deal with stuff on the namespace level
-=head2 has_package_symbol $variable
+=method has_package_symbol $variable
Returns whether or not the given package variable (including sigil) exists.
my $entry_ref = \$namespace->{$name};
if (reftype($entry_ref) eq 'GLOB') {
- if ( $type eq 'SCALAR' ) {
- return defined ${ *{$entry_ref}{SCALAR} };
+ # XXX: assigning to any typeglob slot also initializes the SCALAR slot,
+ # and saying that an undef scalar variable doesn't exist is probably
+ # vaguely less surprising than a scalar variable popping into existence
+ # without anyone defining it
+ if ($type eq 'SCALAR') {
+ return defined ${ *{$entry_ref}{$type} };
}
else {
return defined *{$entry_ref}{$type};
}
}
-=head2 get_package_symbol $variable
+=method get_package_symbol $variable
Returns the value of the given package variable (including sigil).
=cut
sub get_package_symbol {
- my ($self, $variable) = @_;
+ my ($self, $variable, %opts) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
? @{$variable}{qw[name sigil type]}
my $namespace = $self->namespace;
if (!exists $namespace->{$name}) {
- $self->add_package_symbol($variable)
+ if ($opts{vivify}) {
+ if ($type eq 'ARRAY') {
+ if (BROKEN_ISA_ASSIGNMENT) {
+ $self->add_package_symbol(
+ $variable,
+ $name eq 'ISA' ? () : ([])
+ );
+ }
+ else {
+ $self->add_package_symbol($variable, []);
+ }
+ }
+ elsif ($type eq 'HASH') {
+ $self->add_package_symbol($variable, {});
+ }
+ elsif ($type eq 'SCALAR') {
+ $self->add_package_symbol($variable);
+ }
+ elsif ($type eq 'IO') {
+ $self->add_package_symbol($variable, Symbol::geniosym);
+ }
+ elsif ($type eq 'CODE') {
+ confess "Don't know how to vivify CODE variables";
+ }
+ else {
+ confess "Unknown type $type in vivication";
+ }
+ }
+ else {
+ if ($type eq 'CODE') {
+ # this effectively "de-vivifies" the code slot. if we don't do
+ # this, referencing the coderef at the end of this function
+ # will cause perl to auto-vivify a stub coderef in the slot,
+ # which isn't what we want
+ $self->add_package_symbol($variable);
+ }
+ }
}
my $entry_ref = \$namespace->{$name};
}
}
-=head2 remove_package_symbol $variable
+=method get_or_add_package_symbol $variable
+
+Like C<get_package_symbol>, except that it will return an empty hashref or
+arrayref if the variable doesn't exist.
+
+=cut
+
+sub get_or_add_package_symbol {
+ my $self = shift;
+ $self->get_package_symbol(@_, vivify => 1);
+}
+
+=method 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
: $self->_deconstruct_variable_name($variable);
# FIXME:
- # no doubt this is grossly inefficient and
+ # 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) = (
$self->add_package_symbol($io_desc => $io) if defined $io;
}
-=head2 list_all_package_symbols $type_filter
+=method list_all_package_symbols $type_filter
Returns a list of package variable names in the package, without sigils. If a
C<type_filter> 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).
+etc). Note that if the package contained any C<BEGIN> blocks, perl will leave
+an empty typeglob in the C<BEGIN> slot, so this will show up if no filter is
+used (and similarly for C<INIT>, C<END>, etc).
=cut
return keys %{$namespace} unless defined $type_filter;
# NOTE:
- # or we can filter based on
+ # 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})));
+ # any non-typeglob in the symbol table is a constant or stub
+ ref(\$namespace->{$_}) ne 'GLOB'
+ # regular subs are stored in the CODE slot of the typeglob
+ || defined(*{$namespace->{$_}}{CODE})
+ } keys %{$namespace};
+ }
+ elsif ($type_filter eq 'SCALAR') {
+ return grep {
+ ref(\$namespace->{$_}) eq 'GLOB'
+ && defined(${*{$namespace->{$_}}{'SCALAR'}})
+ } keys %{$namespace};
+ }
+ else {
+ return grep {
+ ref(\$namespace->{$_}) eq 'GLOB'
+ && defined(*{$namespace->{$_}}{$type_filter})
} keys %{$namespace};
- } else {
- return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
}
}
=head1 SEE ALSO
-L<Class::MOP::Package> - this module is a factoring out of code that used to
-live here
+=over 4
+
+=item * L<Class::MOP::Package>
+
+This module is a factoring out of code that used to live here
+
+=back
=head1 SUPPORT
=head1 AUTHOR
- Jesse Luehrs <doy at tozt dot net>
+Jesse Luehrs <doy at tozt dot net>
Mostly copied from code from L<Class::MOP::Package>, 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;
projects / gitmo/Package-Stash-PP.git / blobdiff