use Carp qw(confess);
use Scalar::Util qw(reftype);
+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
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;
}
=method name
=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};
}
{
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};
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 ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') {
- $self->add_package_symbol($variable, []);
- }
- elsif ($opts{vivify} && $type eq 'HASH') {
- $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 {
- # FIXME
- $self->add_package_symbol($variable)
+ 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);
+ }
}
}
: $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) = (
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 BUGS
+
+No known bugs.
+
+Please report any bugs through RT: email
+C<bug-package-stash at rt.cpan.org>, or browse to
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Package-Stash>.
+
=head1 SEE ALSO
=over 4
=back
+=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<http://annocpan.org/dist/Package-Stash>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Package-Stash>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Package-Stash>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Package-Stash>
+
+=back
+
+=head1 AUTHOR
+
+Jesse Luehrs <doy at tozt dot net>
+
+Mostly copied from code from L<Class::MOP::Package>, by Stevan Little and the
+Moose Cabal.
+
=cut
1;
projects / gitmo/Package-Stash-PP.git / blobdiff