#line 1
package Class::MOP::Package;
BEGIN {
$Class::MOP::Package::AUTHORITY = 'cpan:STEVAN';
}
BEGIN {
$Class::MOP::Package::VERSION = '2.0009';
}
use strict;
use warnings;
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Carp 'confess';
use Devel::GlobalDestruction 'in_global_destruction';
use Package::Stash;
use base 'Class::MOP::Object';
# creation ...
sub initialize {
my ( $class, @args ) = @_;
unshift @args, "package" if @args % 2;
my %options = @args;
my $package_name = delete $options{package};
# we hand-construct the class
# until we can bootstrap it
if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
return $meta;
} else {
my $meta = ( ref $class || $class )->_new({
'package' => $package_name,
%options,
});
Class::MOP::store_metaclass_by_name($package_name, $meta);
Class::MOP::weaken_metaclass($package_name) if $options{weaken};
return $meta;
}
}
sub reinitialize {
my ( $class, @args ) = @_;
unshift @args, "package" if @args % 2;
my %options = @args;
my $package_name = delete $options{package};
(defined $package_name && $package_name
&& (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
|| confess "You must pass a package name or an existing Class::MOP::Package instance";
$package_name = $package_name->name
if blessed $package_name;
Class::MOP::remove_metaclass_by_name($package_name);
$class->initialize($package_name, %options); # call with first arg form for compat
}
sub create {
my $class = shift;
my @args = @_;
return $class->initialize(@args);
}
## ANON packages
{
# NOTE:
# this should be sufficient, if you have a
# use case where it is not, write a test and
# I will change it.
my $ANON_SERIAL = 0;
my %ANON_PACKAGE_CACHE;
# NOTE:
# we need a sufficiently annoying prefix
# this should suffice for now, this is
# used in a couple of places below, so
# need to put it up here for now.
sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
sub is_anon {
my $self = shift;
no warnings 'uninitialized';
my $prefix = $self->_anon_package_prefix;
$self->name =~ /^\Q$prefix/;
}
sub create_anon {
my ($class, %options) = @_;
my $cache_ok = delete $options{cache};
$options{weaken} = !$cache_ok unless exists $options{weaken};
my $cache_key;
if ($cache_ok) {
$cache_key = $class->_anon_cache_key(%options);
undef $cache_ok if !defined($cache_key);
}
if ($cache_ok) {
if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
return $ANON_PACKAGE_CACHE{$cache_key};
}
}
my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
my $meta = $class->create($package_name, %options);
if ($cache_ok) {
$ANON_PACKAGE_CACHE{$cache_key} = $meta;
weaken($ANON_PACKAGE_CACHE{$cache_key});
}
return $meta;
}
sub _anon_cache_key { confess "Packages are not cacheable" }
sub DESTROY {
my $self = shift;
return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
$self->_free_anon
if $self->is_anon;
}
sub _free_anon {
my $self = shift;
my $name = $self->name;
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# that because Moose will explicitly update the singleton
# cache in Class::MOP.
no warnings 'uninitialized';
my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if $current_meta ne $self;
my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
no strict 'refs';
@{$name . '::ISA'} = ();
%{$name . '::'} = ();
delete ${$first_fragments . '::'}{$last_fragment . '::'};
Class::MOP::remove_metaclass_by_name($name);
}
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# Need to quote package to avoid a problem with PPI mis-parsing this
# as a package statement.
'package' => $params->{package},
# 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 in the accessor.
# Ideally we could just store a ref and
# it would Just Work, but oh well :\
namespace => \undef,
} => $class;
}
# Attributes
# NOTE:
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
sub _package_stash {
$_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
}
sub namespace {
$_[0]->_package_stash->namespace
}
# Class attributes
# ... these functions have to touch the symbol table itself,.. yuk
sub add_package_symbol {
my $self = shift;
$self->_package_stash->add_symbol(@_);
}
sub remove_package_glob {
my $self = shift;
$self->_package_stash->remove_glob(@_);
}
# ... these functions deal with stuff on the namespace level
sub has_package_symbol {
my $self = shift;
$self->_package_stash->has_symbol(@_);
}
sub get_package_symbol {
my $self = shift;
$self->_package_stash->get_symbol(@_);
}
sub get_or_add_package_symbol {
my $self = shift;
$self->_package_stash->get_or_add_symbol(@_);
}
sub remove_package_symbol {
my $self = shift;
$self->_package_stash->remove_symbol(@_);
}
sub list_all_package_symbols {
my $self = shift;
$self->_package_stash->list_all_symbols(@_);
}
sub get_all_package_symbols {
my $self = shift;
$self->_package_stash->get_all_symbols(@_);
}
1;
# ABSTRACT: Package Meta Object
#line 396
__END__