Moose-2.1405HEADMoose-2.1405master

1 files changed, 464 insertions, 0 deletions

diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
new file mode 100644
index 0000000..135ad68
--- /dev/null
+++ b/lib/Class/MOP/Package.pm
@@ -0,0 +1,464 @@
+package Class::MOP::Package;
+our $VERSION = '2.1405';
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'weaken';
+use Devel::GlobalDestruction 'in_global_destruction';
+use Module::Runtime 'module_notional_filename';
+use Package::Stash;
+
+use parent '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')))
+        || $class->_throw_exception( MustPassAPackageNameOrAnExistingClassMOPPackageInstance => params => \%options,
+                                                                                       class  => $class
+                          );
+
+    $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 = @_;
+
+    my $meta = $class->initialize(@args);
+    my $filename = module_notional_filename($meta->name);
+    $INC{$filename} = '(set by Moose)'
+        unless exists $INC{$filename};
+
+    return $meta;
+}
+
+## 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 {
+        my $class = shift;
+        my %options = @_;
+        $class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class,
+                                                             params     => \%options,
+                                                             is_module  => 0
+                       );
+    }
+
+    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 using store_metaclass_by_name, which
+        # means that the new metaclass will already exist in the cache
+        # by this point.
+        # The other options here are that $current_meta can be undef if
+        # remove_metaclass_by_name is called explicitly (since the hash
+        # entry is removed first, and then this destructor is called),
+        # or that $current_meta can be the same as $self, which happens
+        # when the metaclass goes out of scope (since the weak reference
+        # in the metaclass cache won't be freed until after this
+        # destructor runs).
+        my $current_meta = Class::MOP::get_metaclass_by_name($name);
+        return if defined($current_meta) && $current_meta ne $self;
+
+        my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
+
+        no strict 'refs';
+        # clear @ISA first, to avoid a memory leak
+        # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708
+        @{$name . '::ISA'} = ();
+        %{$name . '::'}    = ();
+        delete ${$first_fragments . '::'}{$last_fragment . '::'};
+
+        Class::MOP::remove_metaclass_by_name($name);
+
+        delete $INC{module_notional_filename($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
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Package - Package Meta Object
+
+=head1 VERSION
+
+version 2.1405
+
+=head1 DESCRIPTION
+
+The Package Protocol provides an abstraction of a Perl 5 package. A
+package is basically namespace, and this module provides methods for
+looking at and changing that namespace's symbol table.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Package->initialize($package_name, %options) >>
+
+This method creates a new C<Class::MOP::Package> instance which
+represents specified package. If an existing metaclass object exists
+for the package, that will be returned instead. No options are valid at the
+package level.
+
+=item B<< Class::MOP::Package->reinitialize($package, %options) >>
+
+This method forcibly removes any existing metaclass for the package
+before calling C<initialize>. In contrast to C<initialize>, you may
+also pass an existing C<Class::MOP::Package> instance instead of just
+a package name as C<$package>.
+
+Do not call this unless you know what you are doing.
+
+=item B<< Class::MOP::Package->create($package, %options) >>
+
+Creates a new C<Class::MOP::Package> instance which represents the specified
+package, and also does some initialization of that package. Currently, this
+just does the same thing as C<initialize>, but is overridden in subclasses,
+such as C<Class::MOP::Class>.
+
+=item B<< Class::MOP::Package->create_anon(%options) >>
+
+Creates a new anonymous package. Valid keys for C<%options> are:
+
+=over 4
+
+=item C<cache>
+
+If this will be C<true> (the default is C<false>), the instance will be cached
+in C<Class::MOP>'s metaclass cache.
+
+=item C<weaken>
+
+If this is C<true> (the default C<true> when L<cache> is C<false>), the instance
+stored in C<Class::MOP>'s metaclass cache will be weakened, so that the
+anonymous package will be garbage collected when the returned instance goes out
+of scope.
+
+=back
+
+=item B<< $metapackage->is_anon >>
+
+Returns true if the package is an anonymous package.
+
+=item B<< $metapackage->name >>
+
+This is returns the package's name, as passed to the constructor.
+
+=item B<< $metapackage->namespace >>
+
+This returns a hash reference to the package's symbol table. The keys
+are symbol names and the values are typeglob references.
+
+=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
+
+This method accepts a variable name and an optional initial value. The
+C<$variable_name> must contain a leading sigil.
+
+This method creates the variable in the package's symbol table, and
+sets it to the initial value if one was provided.
+
+=item B<< $metapackage->get_package_symbol($variable_name) >>
+
+Given a variable name, this method returns the variable as a reference
+or undef if it does not exist. The C<$variable_name> must contain a
+leading sigil.
+
+=item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
+
+Given a variable name, this method returns the variable as a reference.
+If it does not exist, a default value will be generated if possible. The
+C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->has_package_symbol($variable_name) >>
+
+Returns true if there is a package variable defined for
+C<$variable_name>. The C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->remove_package_symbol($variable_name) >>
+
+This will remove the package variable specified C<$variable_name>. The
+C<$variable_name> must contain a leading sigil.
+
+=item B<< $metapackage->remove_package_glob($glob_name) >>
+
+Given the name of a glob, this will remove that glob from the
+package's symbol table. Glob names do not include a sigil. Removing
+the glob removes all variables and subroutines with the specified
+name.
+
+=item B<< $metapackage->list_all_package_symbols($type_filter) >>
+
+This will list all the glob names associated with the current
+package. These names do not have leading sigils.
+
+You can provide an optional type filter, which should be one of
+'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
+
+=item B<< $metapackage->get_all_package_symbols($type_filter) >>
+
+This works much like C<list_all_package_symbols>, but it returns a
+hash reference. The keys are glob names and the values are references
+to the value for that name.
+
+=item B<< Class::MOP::Package->meta >>
+
+This will return a L<Class::MOP::Class> instance for this class.
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Stevan Little <stevan.little@iinteractive.com>
+
+=item *
+
+Dave Rolsky <autarch@urth.org>
+
+=item *
+
+Jesse Luehrs <doy@tozt.net>
+
+=item *
+
+Shawn M Moore <code@sartak.org>
+
+=item *
+
+יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Florian Ragwitz <rafl@debian.org>
+
+=item *
+
+Hans Dieter Pearcey <hdp@weftsoar.net>
+
+=item *
+
+Chris Prather <chris@prather.org>
+
+=item *
+
+Matt S Trout <mst@shadowcat.co.uk>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2006 by Infinity Interactive, Inc..
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut