X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FPackage.pm;h=ea3a44932cf83628952d4baa1983026cb93a8064;hb=d519662a06488c8d15eecbb2858f9bad58986731;hp=9324418867bb4b0109261be7caf3ae27b0d608af;hpb=2f1f7e5ab9780a927b1930b76ec231d98eb20e27;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 9324418..ea3a449 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -7,7 +7,8 @@ use warnings; use Scalar::Util 'blessed'; use Carp 'confess'; -our $VERSION = '0.65'; +our $VERSION = '0.64_01'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -15,22 +16,59 @@ use base 'Class::MOP::Object'; # creation ... sub initialize { - my $class = shift; - my $package_name = shift; + my ( $class, @args ) = @_; + + unshift @args, "package" if @args % 2; + + my %options = @args; + my $package_name = $options{package}; + + # we hand-construct the class # until we can bootstrap it - no strict 'refs'; - return bless { - 'package' => $package_name, - # 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; + if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { + return $meta; + } else { + my $meta = ( ref $class || $class )->_new({ + 'package' => $package_name, + }); + + Class::MOP::store_metaclass_by_name($package_name, $meta); + + 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)) + || confess "You must pass a package name and it cannot be blessed"; + + Class::MOP::remove_metaclass_by_name($package_name); + + $class->initialize($package_name, %options); # call with first arg form for compat +} + +sub _new { + my $class = shift; + my $options = @_ == 1 ? $_[0] : {@_}; + + # 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 :\ + $options->{namespace} ||= \undef; + + bless $options, $class; } # Attributes @@ -127,14 +165,14 @@ sub has_package_symbol { # then this is broken. if (ref($namespace->{$name}) eq 'SCALAR') { - return ($type eq 'CODE' ? 1 : 0); + return ($type eq 'CODE'); } elsif ($type eq 'SCALAR') { my $val = *{$namespace->{$name}}{$type}; - return defined(${$val}) ? 1 : 0; + return defined(${$val}); } else { - defined(*{$namespace->{$name}}{$type}) ? 1 : 0; + defined(*{$namespace->{$name}}{$type}); } } @@ -239,6 +277,7 @@ sub list_all_package_symbols { sub get_all_package_symbols { my ($self, $type_filter) = @_; my $namespace = $self->namespace; + return %$namespace unless defined $type_filter; # for some reason this nasty impl is orders of magnitude aster than a clean version @@ -247,8 +286,8 @@ sub get_all_package_symbols { no strict 'refs'; return map { (ref($namespace->{$_}) - ? ( $_ => \&{$pkg ||= $self->name . "::$_"} ) - : ( *{$namespace->{$_}}{CODE} + ? ( $_ => \&{$pkg ||= $self->name . "::$_"} ) + : ( *{$namespace->{$_}}{CODE} ? ( $_ => *{$namespace->{$_}}{$type_filter} ) : ())) } keys %$namespace; @@ -290,6 +329,12 @@ Returns a metaclass for this package. This will initialize a Class::MOP::Package instance which represents the package of C<$package_name>. +=item B + +This removes the old metaclass, and creates a new one in it's place. +Do B use this unless you really know what you are doing, it could +very easily make a very large mess of your program. + =item B This is a read-only attribute which returns the package name for the