From: Stevan Little Date: Sat, 27 Jan 2007 20:28:21 +0000 (+0000) Subject: merging the immutable branch into trunk X-Git-Tag: 0_37~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c23184fc39306590f9e481d76c199020a638bb28;p=gitmo%2FClass-MOP.git merging the immutable branch into trunk --- diff --git a/Changes b/Changes index 265035e..05ac1b0 100644 --- a/Changes +++ b/Changes @@ -5,6 +5,37 @@ Revision history for Perl extension Class-MOP. - default now checks the instance with defined to avoid setting off bool-overloads (found by Carl Franks) +0.37_002 + * /t + - bad name in a test, causing meaningless failuress. + No other changes. + +0.37_001 + + ~~ GLOBAL CHANGES ~~ + - All attribute names are now consistent and follow Perl 6 + style (prefixed with the sigil, and ! as the twigil for + private attrs). This should not affect any code, unless + you broke encapsulation, in which case, it is your problem + anyway. + + !! Class::MOP::Class::Immutable has been removed + + * Class::MOP::Method::Constructor + - this has been moved out of Class::MOP::Class::Immutable + and is a proper subclass of Class::MOP::Method now. + + * Class::MOP::Class + - this module now uses Class::MOP::Immutable for the + immutable transformation instead of + Class::MOP::Class::Immutable. + + + Class::MOP::Immutable + - this module now controls the transformation from a mutable + to an immutable version of the class. Docs for this will + be coming eventually. + + 0.36 Sun. Nov. 5, 2006 * Class::MOP::Class - added a few 'no warnings' lines to keep annoying diff --git a/MANIFEST b/MANIFEST index 12aec29..0367ffa 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,7 +1,7 @@ Build.PL Changes -META.yml Makefile.PL +META.yml MANIFEST MANIFEST.SKIP README @@ -17,12 +17,12 @@ lib/metaclass.pm lib/Class/MOP.pm lib/Class/MOP/Attribute.pm lib/Class/MOP/Class.pm +lib/Class/MOP/Immutable.pm lib/Class/MOP/Instance.pm lib/Class/MOP/Method.pm lib/Class/MOP/Module.pm lib/Class/MOP/Object.pm lib/Class/MOP/Package.pm -lib/Class/MOP/Class/Immutable.pm lib/Class/MOP/Method/Accessor.pm lib/Class/MOP/Method/Constructor.pm lib/Class/MOP/Method/Wrapped.pm diff --git a/README b/README index 1e32e38..a0afd06 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Class::MOP version 0.35 +Class::MOP version 0.37 =========================== See the individual module documentation for more information diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod index bc5a19b..1c23505 100644 --- a/examples/ArrayBasedStorage.pod +++ b/examples/ArrayBasedStorage.pod @@ -15,7 +15,7 @@ sub new { my ($class, $meta, @attrs) = @_; my $self = $class->SUPER::new($meta, @attrs); my $index = 0; - $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots }; + $self->{'%!slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; return $self; } @@ -31,7 +31,7 @@ sub clone_instance { # operations on meta instance -sub get_slot_index_map { (shift)->{slot_index_map} } +sub get_slot_index_map { (shift)->{'%!slot_index_map'} } sub get_all_slots { my $self = shift; @@ -40,12 +40,12 @@ sub get_all_slots { sub get_slot_value { my ($self, $instance, $slot_name) = @_; - return $instance->[ $self->{slot_index_map}->{$slot_name} ]; + return $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ]; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; - $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value; + $instance->[ $self->{'%!slot_index_map'}->{$slot_name} ] = $value; } sub is_slot_initialized { diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod index 5e33d0d..6365e79 100644 --- a/examples/AttributesWithHistory.pod +++ b/examples/AttributesWithHistory.pod @@ -12,7 +12,7 @@ use base 'Class::MOP::Attribute'; # this is for an extra attribute constructor # option, which is to be able to create a # way for the class to access the history -AttributesWithHistory->meta->add_attribute('history_accessor' => ( +AttributesWithHistory->meta->add_attribute('$!history_accessor' => ( reader => 'history_accessor', init_arg => 'history_accessor', predicate => 'has_history_accessor', @@ -20,7 +20,7 @@ AttributesWithHistory->meta->add_attribute('history_accessor' => ( # this is a place to store the actual # history of the attribute -AttributesWithHistory->meta->add_attribute('_history' => ( +AttributesWithHistory->meta->add_attribute('$!_history' => ( accessor => '_history', default => sub { {} }, )); diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 326f527..c869dd5 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -12,7 +12,7 @@ use base 'Class::MOP::Class'; sub initialize { (shift)->SUPER::initialize(@_, # use the custom attribute metaclass here - ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', + 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', ); } diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index e99237e..e106113 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -14,13 +14,13 @@ use base 'Class::MOP::Attribute'; sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; - my $init_arg = $self->{init_arg}; + my $init_arg = $self->init_arg; # try to fetch the init arg from the %params ... my $val; $val = $params->{$init_arg} if exists $params->{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) - if (!defined $val && defined $self->{default}) { + if (!defined $val && defined $self->default) { $val = $self->default($instance); } my $_meta_instance = $self->associated_class->get_meta_instance; @@ -107,25 +107,25 @@ sub create_instance { sub get_slot_value { my ($self, $instance, $slot_name) = @_; - $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance}; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; - $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; } sub initialize_slot { my ($self, $instance, $slot_name) = @_; - $self->{meta}->add_package_symbol(('%' . $slot_name) => {}) - unless $self->{meta}->has_package_symbol('%' . $slot_name); - $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; + $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) + unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; } sub is_slot_initialized { my ($self, $instance, $slot_name) = @_; - return 0 unless $self->{meta}->has_package_symbol('%' . $slot_name); - return exists $self->{meta}->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; + return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); + return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; } 1; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 81dc70b..a4c9f04 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,7 +11,7 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -use Class::MOP::Class::Immutable; +use Class::MOP::Immutable; our $VERSION = '0.37'; our $AUTHORITY = 'cpan:STEVAN'; @@ -69,7 +69,7 @@ our $AUTHORITY = 'cpan:STEVAN'; ## Class::MOP::Package Class::MOP::Package->meta->add_attribute( - Class::MOP::Attribute->new('$:package' => ( + Class::MOP::Attribute->new('$!package' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to @@ -79,12 +79,12 @@ Class::MOP::Package->meta->add_attribute( # rather than re-produce it here 'name' => \&Class::MOP::Package::name }, - init_arg => ':package', + init_arg => 'package', )) ); Class::MOP::Package->meta->add_attribute( - Class::MOP::Attribute->new('%:namespace' => ( + Class::MOP::Attribute->new('%!namespace' => ( reader => { # NOTE: # we just alias the original method @@ -104,7 +104,7 @@ Class::MOP::Package->meta->add_attribute( Class::MOP::Package->meta->add_method('initialize' => sub { my $class = shift; my $package_name = shift; - $class->meta->new_object(':package' => $package_name, @_); + $class->meta->new_object('package' => $package_name, @_); }); ## -------------------------------------------------------- @@ -121,7 +121,7 @@ Class::MOP::Package->meta->add_method('initialize' => sub { # the metaclass, isn't abstraction great :) Class::MOP::Module->meta->add_attribute( - Class::MOP::Attribute->new('$:version' => ( + Class::MOP::Attribute->new('$!version' => ( reader => { # NOTE: # we just alias the original method @@ -142,7 +142,7 @@ Class::MOP::Module->meta->add_attribute( # well. Class::MOP::Module->meta->add_attribute( - Class::MOP::Attribute->new('$:authority' => ( + Class::MOP::Attribute->new('$!authority' => ( reader => { # NOTE: # we just alias the original method @@ -160,7 +160,7 @@ Class::MOP::Module->meta->add_attribute( ## Class::MOP::Class Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('%:attributes' => ( + Class::MOP::Attribute->new('%!attributes' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to @@ -170,13 +170,14 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, - init_arg => ':attributes', + init_arg => 'attributes', default => sub { {} } )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('%:methods' => ( + Class::MOP::Attribute->new('%!methods' => ( + init_arg => 'methods', reader => { # NOTE: # we just alias the original method @@ -188,33 +189,48 @@ Class::MOP::Class->meta->add_attribute( ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:attribute_metaclass' => ( + Class::MOP::Attribute->new('@!superclasses' => ( + accessor => { + # NOTE: + # we just alias the original method + # rather than re-produce it here + 'superclasses' => \&Class::MOP::Class::superclasses + }, + # NOTE: + # protect this from silliness + init_arg => '!............( DO NOT DO THIS )............!', + default => sub { \undef } + )) +); + +Class::MOP::Class->meta->add_attribute( + Class::MOP::Attribute->new('$!attribute_metaclass' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, - init_arg => ':attribute_metaclass', + init_arg => 'attribute_metaclass', default => 'Class::MOP::Attribute', )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:method_metaclass' => ( + Class::MOP::Attribute->new('$!method_metaclass' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - init_arg => ':method_metaclass', + init_arg => 'method_metaclass', default => 'Class::MOP::Method', )) ); Class::MOP::Class->meta->add_attribute( - Class::MOP::Attribute->new('$:instance_metaclass' => ( + Class::MOP::Attribute->new('$!instance_metaclass' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to @@ -224,7 +240,7 @@ Class::MOP::Class->meta->add_attribute( # rather than re-produce it here 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, - init_arg => ':instance_metaclass', + init_arg => 'instance_metaclass', default => 'Class::MOP::Instance', )) ); @@ -239,8 +255,9 @@ Class::MOP::Class->meta->add_attribute( ## Class::MOP::Attribute Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('name' => ( - reader => { + Class::MOP::Attribute->new('$!name' => ( + init_arg => 'name', + reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death @@ -253,8 +270,9 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('associated_class' => ( - reader => { + Class::MOP::Attribute->new('$!associated_class' => ( + init_arg => 'associated_class', + reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death @@ -267,58 +285,66 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('accessor' => ( + Class::MOP::Attribute->new('$!accessor' => ( + init_arg => 'accessor', reader => { 'accessor' => \&Class::MOP::Attribute::accessor }, predicate => { 'has_accessor' => \&Class::MOP::Attribute::has_accessor }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('reader' => ( + Class::MOP::Attribute->new('$!reader' => ( + init_arg => 'reader', reader => { 'reader' => \&Class::MOP::Attribute::reader }, predicate => { 'has_reader' => \&Class::MOP::Attribute::has_reader }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('writer' => ( + Class::MOP::Attribute->new('$!writer' => ( + init_arg => 'writer', reader => { 'writer' => \&Class::MOP::Attribute::writer }, predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('predicate' => ( + Class::MOP::Attribute->new('$!predicate' => ( + init_arg => 'predicate', reader => { 'predicate' => \&Class::MOP::Attribute::predicate }, predicate => { 'has_predicate' => \&Class::MOP::Attribute::has_predicate }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('clearer' => ( + Class::MOP::Attribute->new('$!clearer' => ( + init_arg => 'clearer', reader => { 'clearer' => \&Class::MOP::Attribute::clearer }, predicate => { 'has_clearer' => \&Class::MOP::Attribute::has_clearer }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('init_arg' => ( + Class::MOP::Attribute->new('$!init_arg' => ( + init_arg => 'init_arg', reader => { 'init_arg' => \&Class::MOP::Attribute::init_arg }, predicate => { 'has_init_arg' => \&Class::MOP::Attribute::has_init_arg }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('default' => ( + Class::MOP::Attribute->new('$!default' => ( + init_arg => 'default', # default has a custom 'reader' method ... predicate => { 'has_default' => \&Class::MOP::Attribute::has_default }, )) ); Class::MOP::Attribute->meta->add_attribute( - Class::MOP::Attribute->new('associated_methods' => ( - reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, - default => sub { [] } + Class::MOP::Attribute->new('@!associated_methods' => ( + init_arg => 'associated_methods', + reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, + default => sub { [] } )) ); @@ -355,8 +381,9 @@ Class::MOP::Attribute->meta->add_method('clone' => sub { ## Class::MOP::Method Class::MOP::Method->meta->add_attribute( - Class::MOP::Attribute->new('body' => ( - reader => { 'body' => \&Class::MOP::Method::body }, + Class::MOP::Attribute->new('&!body' => ( + init_arg => 'body', + reader => { 'body' => \&Class::MOP::Method::body }, )) ); @@ -369,29 +396,32 @@ Class::MOP::Method->meta->add_attribute( # practices of attributes, but we put # it here for completeness Class::MOP::Method::Wrapped->meta->add_attribute( - Class::MOP::Attribute->new('modifier_table') + Class::MOP::Attribute->new('%!modifier_table') ); ## -------------------------------------------------------- ## Class::MOP::Method::Accessor Class::MOP::Method::Accessor->meta->add_attribute( - Class::MOP::Attribute->new('attribute' => ( - reader => { + Class::MOP::Attribute->new('$!attribute' => ( + init_arg => 'attribute', + reader => { 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute }, )) ); Class::MOP::Method::Accessor->meta->add_attribute( - Class::MOP::Attribute->new('accessor_type' => ( - reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, + Class::MOP::Attribute->new('$!accessor_type' => ( + init_arg => 'accessor_type', + reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, )) ); Class::MOP::Method::Accessor->meta->add_attribute( - Class::MOP::Attribute->new('is_inline' => ( - reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline }, + Class::MOP::Attribute->new('$!is_inline' => ( + init_arg => 'is_inline', + reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline }, )) ); @@ -399,26 +429,20 @@ Class::MOP::Method::Accessor->meta->add_attribute( ## Class::MOP::Method::Constructor Class::MOP::Method::Constructor->meta->add_attribute( - Class::MOP::Attribute->new('options' => ( - reader => { + Class::MOP::Attribute->new('%!options' => ( + init_arg => 'options', + reader => { 'options' => \&Class::MOP::Method::Constructor::options }, )) ); Class::MOP::Method::Constructor->meta->add_attribute( - Class::MOP::Attribute->new('meta_instance' => ( - reader => { - 'meta_instance' => \&Class::MOP::Method::Constructor::meta_instance - }, - )) -); - -Class::MOP::Method::Constructor->meta->add_attribute( - Class::MOP::Attribute->new('attributes' => ( - reader => { - 'attributes' => \&Class::MOP::Method::Constructor::attributes - }, + Class::MOP::Attribute->new('$!associated_metaclass' => ( + init_arg => 'metaclass', + reader => { + 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass + }, )) ); @@ -430,11 +454,11 @@ Class::MOP::Method::Constructor->meta->add_attribute( # included for completeness Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('meta') + Class::MOP::Attribute->new('$!meta') ); Class::MOP::Instance->meta->add_attribute( - Class::MOP::Attribute->new('slots') + Class::MOP::Attribute->new('@!slots') ); ## -------------------------------------------------------- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 3ff383d..2935d35 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -45,20 +45,20 @@ sub new { if exists $options{default} && ref $options{default}; bless { - name => $name, - accessor => $options{accessor}, - reader => $options{reader}, - writer => $options{writer}, - predicate => $options{predicate}, - clearer => $options{clearer}, - init_arg => $options{init_arg}, - default => $options{default}, + '$!name' => $name, + '$!accessor' => $options{accessor}, + '$!reader' => $options{reader}, + '$!writer' => $options{writer}, + '$!predicate' => $options{predicate}, + '$!clearer' => $options{clearer}, + '$!init_arg' => $options{init_arg}, + '$!default' => $options{default}, # keep a weakened link to the # class we are associated with - associated_class => undef, + '$!associated_class' => undef, # and a list of the methods # associated with this attr - associated_methods => [], + '@!associated_methods' => [], } => $class; } @@ -77,13 +77,13 @@ sub clone { sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; - my $init_arg = $self->{init_arg}; + my $init_arg = $self->{'$!init_arg'}; # try to fetch the init arg from the %params ... my $val; $val = $params->{$init_arg} if exists $params->{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) - if (!defined $val && defined $self->{default}) { + if (!defined $val && defined $self->{'$!default'}) { $val = $self->default($instance); } $meta_instance->set_slot_value($instance, $self->name, $val); @@ -93,31 +93,31 @@ sub initialize_instance_slot { # the next bunch of methods will get bootstrapped # away in the Class::MOP bootstrapping section -sub name { $_[0]->{name} } +sub name { $_[0]->{'$!name'} } -sub associated_class { $_[0]->{associated_class} } -sub associated_methods { $_[0]->{associated_methods} } +sub associated_class { $_[0]->{'$!associated_class'} } +sub associated_methods { $_[0]->{'@!associated_methods'} } -sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 } -sub has_reader { defined($_[0]->{reader}) ? 1 : 0 } -sub has_writer { defined($_[0]->{writer}) ? 1 : 0 } -sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 } -sub has_clearer { defined($_[0]->{clearer}) ? 1 : 0 } -sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 } -sub has_default { defined($_[0]->{default}) ? 1 : 0 } +sub has_accessor { defined($_[0]->{'$!accessor'}) ? 1 : 0 } +sub has_reader { defined($_[0]->{'$!reader'}) ? 1 : 0 } +sub has_writer { defined($_[0]->{'$!writer'}) ? 1 : 0 } +sub has_predicate { defined($_[0]->{'$!predicate'}) ? 1 : 0 } +sub has_clearer { defined($_[0]->{'$!clearer'}) ? 1 : 0 } +sub has_init_arg { defined($_[0]->{'$!init_arg'}) ? 1 : 0 } +sub has_default { defined($_[0]->{'$!default'}) ? 1 : 0 } -sub accessor { $_[0]->{accessor} } -sub reader { $_[0]->{reader} } -sub writer { $_[0]->{writer} } -sub predicate { $_[0]->{predicate} } -sub clearer { $_[0]->{clearer} } -sub init_arg { $_[0]->{init_arg} } +sub accessor { $_[0]->{'$!accessor'} } +sub reader { $_[0]->{'$!reader'} } +sub writer { $_[0]->{'$!writer'} } +sub predicate { $_[0]->{'$!predicate'} } +sub clearer { $_[0]->{'$!clearer'} } +sub init_arg { $_[0]->{'$!init_arg'} } # end bootstrapped away method section. # (all methods below here are kept intact) sub is_default_a_coderef { - ('CODE' eq (reftype($_[0]->{default}) || '')) + ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || '')) } sub default { @@ -127,9 +127,9 @@ sub default { # we pass in the instance and default # can return a value based on that # instance. Somewhat crude, but works. - return $self->{default}->($instance); + return $self->{'$!default'}->($instance); } - $self->{default}; + $self->{'$!default'}; } # slots @@ -142,19 +142,19 @@ sub attach_to_class { my ($self, $class) = @_; (blessed($class) && $class->isa('Class::MOP::Class')) || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - weaken($self->{associated_class} = $class); + weaken($self->{'$!associated_class'} = $class); } sub detach_from_class { my $self = shift; - $self->{associated_class} = undef; + $self->{'$!associated_class'} = undef; } # method association sub associate_method { my ($self, $method) = @_; - push @{$self->{associated_methods}} => $method; + push @{$self->{'@!associated_methods'}} => $method; } ## Slot management diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 96d1402..bf92bf2 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,6 +4,7 @@ package Class::MOP::Class; use strict; use warnings; +use Class::MOP::Immutable; use Class::MOP::Instance; use Class::MOP::Method::Wrapped; @@ -28,7 +29,7 @@ sub initialize { my $package_name = shift; (defined $package_name && $package_name && !blessed($package_name)) || confess "You must pass a package name and it cannot be blessed"; - $class->construct_class_instance(':package' => $package_name, @_); + $class->construct_class_instance('package' => $package_name, @_); } sub reinitialize { @@ -37,7 +38,7 @@ sub reinitialize { (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->construct_class_instance(':package' => $package_name, @_); + $class->construct_class_instance('package' => $package_name, @_); } # NOTE: (meta-circularity) @@ -49,7 +50,7 @@ sub reinitialize { sub construct_class_instance { my $class = shift; my %options = @_; - my $package_name = $options{':package'}; + my $package_name = $options{'package'}; (defined $package_name && $package_name) || confess "You must pass a package name"; # NOTE: @@ -76,7 +77,7 @@ sub construct_class_instance { no strict 'refs'; $meta = bless { # inherited from Class::MOP::Package - '$:package' => $package_name, + '$!package' => $package_name, # NOTE: # since the following attributes will @@ -86,17 +87,18 @@ sub construct_class_instance { # listed here for reference, because they # should not actually have a value associated # with the slot. - '%:namespace' => \undef, + '%!namespace' => \undef, # inherited from Class::MOP::Module - '$:version' => \undef, - '$:authority' => \undef, + '$!version' => \undef, + '$!authority' => \undef, # defined in Class::MOP::Class + '@!superclasses' => \undef, - '%:methods' => {}, - '%:attributes' => {}, - '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', - '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', - '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance', + '%!methods' => {}, + '%!attributes' => {}, + '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', + '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', + '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', } => $class; } else { @@ -259,16 +261,16 @@ sub create { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub get_attribute_map { $_[0]->{'%:attributes'} } -sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } -sub method_metaclass { $_[0]->{'$:method_metaclass'} } -sub instance_metaclass { $_[0]->{'$:instance_metaclass'} } +sub get_attribute_map { $_[0]->{'%!attributes'} } +sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} } +sub method_metaclass { $_[0]->{'$!method_metaclass'} } +sub instance_metaclass { $_[0]->{'$!instance_metaclass'} } # FIXME: # this is a prime canidate for conversion to XS sub get_method_map { my $self = shift; - my $map = $self->{'%:methods'}; + my $map = $self->{'%!methods'}; my $class_name = $self->name; my $method_metaclass = $self->method_metaclass; @@ -340,11 +342,12 @@ sub clone_instance { (blessed($instance)) || confess "You can only clone instances, \$self is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); - my $clone = $meta_instance->clone_instance($instance); - foreach my $key (keys %params) { - next unless $meta_instance->is_valid_slot($key); - $meta_instance->set_slot_value($clone, $key, $params{$key}); - } + my $clone = $meta_instance->clone_instance($instance); + foreach my $attr ($class->compute_all_applicable_attributes()) { + if ($params{$attr->init_arg}) { + $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg}); + } + } return $clone; } @@ -726,8 +729,38 @@ sub find_attribute_by_name { sub is_mutable { 1 } sub is_immutable { 0 } -sub make_immutable { - return Class::MOP::Class::Immutable->make_metaclass_immutable(@_); +{ + # NOTE: + # the immutable version of a + # particular metaclass is + # really class-level data so + # we don't want to regenerate + # it any more than we need to + my $IMMUTABLE_METACLASS; + sub make_immutable { + my ($self) = @_; + + $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, { + read_only => [qw/superclasses/], + cannot_call => [qw/ + add_method + alias_method + remove_method + add_attribute + remove_attribute + add_package_symbol + remove_package_symbol + /], + memoize => { + class_precedence_list => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', + } + }); + + $IMMUTABLE_METACLASS->make_metaclass_immutable(@_) + } } 1; diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm deleted file mode 100644 index aa9ad68..0000000 --- a/lib/Class/MOP/Class/Immutable.pm +++ /dev/null @@ -1,262 +0,0 @@ - -package Class::MOP::Class::Immutable; - -use strict; -use warnings; - -use Class::MOP::Method::Constructor; - -use Carp 'confess'; -use Scalar::Util 'blessed'; - -our $VERSION = '0.04'; -our $AUTHORITY = 'cpan:STEVAN'; - -use base 'Class::MOP::Class'; - -# enforce the meta-circularity here -# and hide the Immutable part - -sub meta { - my $self = shift; - # if it is not blessed, then someone is asking - # for the meta of Class::MOP::Class::Immutable - return Class::MOP::Class->initialize($self) unless blessed($self); - # otherwise, they are asking for the metaclass - # which has been made immutable, which is itself - return $self; -} - -# methods which can *not* be called -for my $meth (qw( - add_method - alias_method - remove_method - add_attribute - remove_attribute - add_package_symbol - remove_package_symbol -)) { - no strict 'refs'; - *{$meth} = sub { - confess "Cannot call method '$meth' on an immutable instance"; - }; -} - -# NOTE: -# superclasses is an accessor, so -# it just cannot be changed -sub superclasses { - my $class = shift; - (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance'; - @{$class->get_package_symbol('@ISA')}; -} - -# predicates - -sub is_mutable { 0 } -sub is_immutable { 1 } - -sub make_immutable { () } - -sub make_metaclass_immutable { - my ($class, $metaclass, %options) = @_; - - # NOTE: - # i really need the // (defined-or) operator here - $options{inline_accessors} = 1 unless exists $options{inline_accessors}; - $options{inline_constructor} = 1 unless exists $options{inline_constructor}; - $options{constructor_name} = 'new' unless exists $options{constructor_name}; - $options{debug} = 0 unless exists $options{debug}; - - my $meta_instance = $metaclass->get_meta_instance; - $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; - $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; - $metaclass->{'___get_meta_instance'} = $meta_instance; - $metaclass->{'___original_class'} = blessed($metaclass); - - if ($options{inline_accessors}) { - foreach my $attr_name ($metaclass->get_attribute_list) { - # inline the accessors - $metaclass->get_attribute($attr_name) - ->install_accessors(1); - } - } - - if ($options{inline_constructor}) { - my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; - $metaclass->add_method( - $options{constructor_name}, - $constructor_class->new( - options => \%options, - meta_instance => $meta_instance, - attributes => $metaclass->{'___compute_all_applicable_attributes'} - ) - ); - } - - # now cache the method map ... - $metaclass->{'___get_method_map'} = $metaclass->get_method_map; - - bless $metaclass => $class; -} - -# cached methods - -sub get_meta_instance { (shift)->{'___get_meta_instance'} } -sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} } -sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} } -sub get_mutable_metaclass_name { (shift)->{'___original_class'} } -sub get_method_map { (shift)->{'___get_method_map'} } - -1; - -__END__ - -=pod - -=head1 NAME - -Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class - -=head1 SYNOPSIS - - package Point; - use metaclass; - - __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); - __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); - - sub new { - my $class = shift; - $class->meta->new_object(@_); - } - - sub clear { - my $self = shift; - $self->x(0); - $self->y(0); - } - - __PACKAGE__->meta->make_immutable(); # close the class - -=head1 DESCRIPTION - -Class::MOP offers many benefits to object oriented development but it -comes at a cost. Pure Class::MOP classes can be quite a bit slower than -the typical hand coded Perl classes. This is because just about -I is recalculated on the fly, and nothing is cached. The -reason this is so, is because Perl itself allows you to modify virtually -everything at runtime. Class::MOP::Class::Immutable offers an alternative -to this. - -By making your class immutable, you are promising that you will not -modify your inheritence tree or the attributes of any classes in -that tree. Since runtime modifications like this are fairly atypical -(and usually recomended against), this is not usally a very hard promise -to make. For making this promise you are given a wide range of -optimization options which bring speed close to (and sometimes above) -those of typical hand coded Perl. - -=head1 METHODS - -=over 4 - -=item B - -This will return a B instance which is related -to this class. - -=back - -=head2 Introspection and Construction - -=over 4 - -=item B - -The arguments to C are passed -to this method, which - -=over 4 - -=item I - -=item I - -=item I - -=item I - -=back - -=item B - -=item B - -=item B - -=item B - -=back - -=head2 Methods which will die if you touch them. - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=back - -=head2 Methods which work slightly differently. - -=over 4 - -=item B - -This method becomes read-only in an immutable class. - -=back - -=head2 Cached methods - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=back - -=head1 AUTHORS - -Stevan Little Estevan@iinteractive.comE - -Yuval Kogman Enothingmuch@woobling.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm new file mode 100644 index 0000000..1af082a --- /dev/null +++ b/lib/Class/MOP/Immutable.pm @@ -0,0 +1,236 @@ + +package Class::MOP::Immutable; + +use strict; +use warnings; + +use Class::MOP::Method::Constructor; + +use Carp 'confess'; +use Scalar::Util 'blessed'; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +sub new { + my ($class, $metaclass, $options) = @_; + + my $self = bless { + '$!metaclass' => $metaclass, + '%!options' => $options, + '$!immutable_metaclass' => undef, + } => $class; + + # NOTE: + # we initialize the immutable + # version of the metaclass here + $self->create_immutable_metaclass; + + return $self; +} + +sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} } +sub metaclass { (shift)->{'$!metaclass'} } +sub options { (shift)->{'%!options'} } + +sub create_immutable_metaclass { + my $self = shift; + + # NOTE: + # The immutable version of the + # metaclass is just a anon-class + # which shadows the methods + # appropriately + $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class( + superclasses => [ blessed($self->metaclass) ], + methods => $self->create_methods_for_immutable_metaclass, + ); +} + +my %DEFAULT_METHODS = ( + meta => sub { + my $self = shift; + # if it is not blessed, then someone is asking + # for the meta of Class::MOP::Class::Immutable + return Class::MOP::Class->initialize($self) unless blessed($self); + # otherwise, they are asking for the metaclass + # which has been made immutable, which is itself + return $self; + }, + is_mutable => sub { 0 }, + is_immutable => sub { 1 }, + make_immutable => sub { ( ) }, +); + +# NOTE: +# this will actually convert the +# existing metaclass to an immutable +# version of itself +sub make_metaclass_immutable { + my ($self, $metaclass, %options) = @_; + + $options{inline_accessors} = 1 unless exists $options{inline_accessors}; + $options{inline_constructor} = 1 unless exists $options{inline_constructor}; + $options{inline_destructor} = 0 unless exists $options{inline_destructor}; + $options{constructor_name} = 'new' unless exists $options{constructor_name}; + $options{debug} = 0 unless exists $options{debug}; + + if ($options{inline_accessors}) { + foreach my $attr_name ($metaclass->get_attribute_list) { + # inline the accessors + $metaclass->get_attribute($attr_name) + ->install_accessors(1); + } + } + + if ($options{inline_constructor}) { + my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; + + $metaclass->add_method( + $options{constructor_name}, + $constructor_class->new( + options => \%options, + metaclass => $metaclass, + ) + ) unless $metaclass->has_method($options{constructor_name}); + } + + if ($options{inline_destructor}) { + (exists $options{destructor_class}) + || confess "The 'inline_destructor' option is present, but " + . "no destructor class was specified"; + + my $destructor_class = $options{destructor_class}; + + my $destructor = $destructor_class->new( + options => \%options, + metaclass => $metaclass, + ); + + $metaclass->add_method('DESTROY' => $destructor) + # NOTE: + # we allow the destructor to determine + # if it is needed or not, it can perform + # all sorts of checks because it has the + # metaclass instance + if $destructor->is_needed; + } + + my $memoized_methods = $self->options->{memoize}; + foreach my $method_name (keys %{$memoized_methods}) { + my $type = $memoized_methods->{$method_name}; + + ($metaclass->can($method_name)) + || confess "Could not find the method '$method_name' in " . $metaclass->name; + + my $memoized_method; + if ($type eq 'ARRAY') { + $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ]; + } + elsif ($type eq 'HASH') { + $metaclass->{'___' . $method_name} = { $metaclass->$method_name }; + } + elsif ($type eq 'SCALAR') { + $metaclass->{'___' . $method_name} = $metaclass->$method_name; + } + } + $metaclass->{'___original_class'} = blessed($metaclass); + + bless $metaclass => $self->immutable_metaclass->name; +} + +sub create_methods_for_immutable_metaclass { + my $self = shift; + + my %methods = %DEFAULT_METHODS; + + foreach my $read_only_method (@{$self->options->{read_only}}) { + my $method = $self->metaclass->meta->find_method_by_name($read_only_method); + + (defined $method) + || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name; + + $methods{$read_only_method} = sub { + confess "This method is read-only" if scalar @_ > 1; + goto &{$method->body} + }; + } + + foreach my $cannot_call_method (@{$self->options->{cannot_call}}) { + $methods{$cannot_call_method} = sub { + confess "This method ($cannot_call_method) cannot be called on an immutable instance"; + }; + } + + my $memoized_methods = $self->options->{memoize}; + + foreach my $method_name (keys %{$memoized_methods}) { + my $type = $memoized_methods->{$method_name}; + if ($type eq 'ARRAY') { + $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} }; + } + elsif ($type eq 'HASH') { + $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} }; + } + elsif ($type eq 'SCALAR') { + $methods{$method_name} = sub { $_[0]->{'___' . $method_name} }; + } + } + + $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} }; + + return \%methods; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=back + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index b2e406a..89ea9c8 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -17,7 +17,7 @@ sub meta { sub new { my ($class, $meta, @attrs) = @_; my @slots = map { $_->slots } @attrs; - bless { + my $instance = bless { # NOTE: # I am not sure that it makes # sense to pass in the meta @@ -28,11 +28,17 @@ sub new { # which is *probably* a safe # assumption,.. but you can # never tell <:) - meta => $meta, - slots => { map { $_ => undef } @slots }, + '$!meta' => $meta, + '@!slots' => { map { $_ => undef } @slots }, } => $class; + + weaken($instance->{'$!meta'}); + + return $instance; } +sub associated_metaclass { (shift)->{'$!meta'} } + sub create_instance { my $self = shift; $self->bless_instance_structure({}); @@ -40,7 +46,7 @@ sub create_instance { sub bless_instance_structure { my ($self, $instance_structure) = @_; - bless $instance_structure, $self->{meta}->name; + bless $instance_structure, $self->associated_metaclass->name; } sub clone_instance { @@ -52,12 +58,12 @@ sub clone_instance { sub get_all_slots { my $self = shift; - return keys %{$self->{slots}}; + return keys %{$self->{'@!slots'}}; } sub is_valid_slot { my ($self, $slot_name) = @_; - exists $self->{slots}->{$slot_name} ? 1 : 0; + exists $self->{'@!slots'}->{$slot_name} ? 1 : 0; } # operations on created instances @@ -238,6 +244,8 @@ we will add then when we need them basically. =over 4 +=item B + =item B This will return the current list of slots based on what was diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 4ba0566..55b22fb 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -16,7 +16,7 @@ use base 'Class::MOP::Object'; # NOTE: # if poked in the right way, # they should act like CODE refs. -use overload '&{}' => sub { $_[0]->{body} }, fallback => 1; +use overload '&{}' => sub { $_[0]->body }, fallback => 1; # introspection @@ -33,13 +33,13 @@ sub wrap { ('CODE' eq (reftype($code) || '')) || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; bless { - body => $code + '&!body' => $code } => blessed($class) || $class; } ## accessors -sub body { (shift)->{body} } +sub body { (shift)->{'&!body'} } # TODO - add associated_class @@ -51,7 +51,7 @@ sub body { (shift)->{body} } # This gets the package stash name # associated with the actual CODE-ref sub package_name { - my $code = (shift)->{body}; + my $code = (shift)->body; svref_2object($code)->GV->STASH->NAME; } @@ -61,7 +61,7 @@ sub package_name { # with. This gets the name associated # with the actual CODE-ref sub name { - my $code = (shift)->{body}; + my $code = (shift)->body; svref_2object($code)->GV->NAME; } diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index d55e233..1c03e31 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -27,17 +27,17 @@ sub new { my $self = bless { # from our superclass - body => undef, + '&!body' => undef, # specific to this subclass - attribute => $options{attribute}, - is_inline => ($options{is_inline} || 0), - accessor_type => $options{accessor_type}, + '$!attribute' => $options{attribute}, + '$!is_inline' => ($options{is_inline} || 0), + '$!accessor_type' => $options{accessor_type}, } => $class; # we don't want this creating # a cycle in the code, if not # needed - weaken($self->{attribute}); + weaken($self->{'$!attribute'}); $self->intialize_body; @@ -46,9 +46,9 @@ sub new { ## accessors -sub associated_attribute { (shift)->{attribute} } -sub accessor_type { (shift)->{accessor_type} } -sub is_inline { (shift)->{is_inline} } +sub associated_attribute { (shift)->{'$!attribute'} } +sub accessor_type { (shift)->{'$!accessor_type'} } +sub is_inline { (shift)->{'$!is_inline'} } ## factory @@ -62,7 +62,7 @@ sub intialize_body { ($self->is_inline ? 'inline' : ()) ); - eval { $self->{body} = $self->$method_name() }; + eval { $self->{'&!body'} = $self->$method_name() }; die $@ if $@; } diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 08812bc..7e389db 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -18,41 +18,44 @@ sub new { (exists $options{options} && ref $options{options} eq 'HASH') || confess "You must pass a hash of options"; - - (blessed $options{meta_instance} && $options{meta_instance}->isa('Class::MOP::Instance')) - || confess "You must supply a meta-instance"; - - (exists $options{attributes} && ref $options{attributes} eq 'ARRAY') - || confess "You must pass an array of options"; - - (blessed($_) && $_->isa('Class::MOP::Attribute')) - || confess "You must supply a list of attributes which is a 'Class::MOP::Attribute' instance" - for @{$options{attributes}}; my $self = bless { # from our superclass - body => undef, + '&!body' => undef, # specific to this subclass - options => $options{options}, - meta_instance => $options{meta_instance}, - attributes => $options{attributes}, + '%!options' => $options{options}, + '$!meta_instance' => $options{metaclass}->get_meta_instance, + '@!attributes' => [ $options{metaclass}->compute_all_applicable_attributes ], + # ... + '$!associated_metaclass' => $options{metaclass}, } => $class; # we don't want this creating # a cycle in the code, if not # needed - weaken($self->{meta_instance}); +# weaken($self->{'$!meta_instance'}); + weaken($self->{'$!associated_metaclass'}); $self->intialize_body; return $self; } +## predicates + +# NOTE: +# if it is blessed into this class, +# then it is always inlined, that is +# pretty much what this class is for. +sub is_inline { 1 } + ## accessors -sub options { (shift)->{options} } -sub meta_instance { (shift)->{meta_instance} } -sub attributes { (shift)->{attributes} } +sub options { (shift)->{'%!options'} } +sub meta_instance { (shift)->{'$!meta_instance'} } +sub attributes { (shift)->{'@!attributes'} } + +sub associated_metaclass { (shift)->{'$!associated_metaclass'} } ## method @@ -85,7 +88,7 @@ sub intialize_body { $code = eval $source; confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; } - $self->{body} = $code; + $self->{'&!body'} = $code; } sub _generate_slot_initializer { @@ -142,10 +145,14 @@ Class::MOP::Method::Constructor - Method Meta Object for constructors =item B +=item B + =item B =item B +=item B + =item B =item B diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm index 0aa4a3b..ba1451b 100644 --- a/lib/Class/MOP/Method/Wrapped.pm +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -85,27 +85,27 @@ sub wrap { }; $_build_wrapped_method->($modifier_table); my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); - $method->{modifier_table} = $modifier_table; + $method->{'%!modifier_table'} = $modifier_table; $method; } sub get_original_method { my $code = shift; - $code->{modifier_table}->{orig}; + $code->{'%!modifier_table'}->{orig}; } sub add_before_modifier { my $code = shift; my $modifier = shift; - unshift @{$code->{modifier_table}->{before}} => $modifier; - $_build_wrapped_method->($code->{modifier_table}); + unshift @{$code->{'%!modifier_table'}->{before}} => $modifier; + $_build_wrapped_method->($code->{'%!modifier_table'}); } sub add_after_modifier { my $code = shift; my $modifier = shift; - push @{$code->{modifier_table}->{after}} => $modifier; - $_build_wrapped_method->($code->{modifier_table}); + push @{$code->{'%!modifier_table'}->{after}} => $modifier; + $_build_wrapped_method->($code->{'%!modifier_table'}); } { @@ -126,12 +126,12 @@ sub add_after_modifier { sub add_around_modifier { my $code = shift; my $modifier = shift; - unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier; - $code->{modifier_table}->{around}->{cache} = $compile_around_method->( - @{$code->{modifier_table}->{around}->{methods}}, - $code->{modifier_table}->{orig}->body + unshift @{$code->{'%!modifier_table'}->{around}->{methods}} => $modifier; + $code->{'%!modifier_table'}->{around}->{cache} = $compile_around_method->( + @{$code->{'%!modifier_table'}->{around}->{methods}}, + $code->{'%!modifier_table'}->{orig}->body ); - $_build_wrapped_method->($code->{modifier_table}); + $_build_wrapped_method->($code->{'%!modifier_table'}); } } diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 2e507fe..912072b 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -28,7 +28,7 @@ sub initialize { # until we can bootstrap it no strict 'refs'; return bless { - '$:package' => $package_name, + '$!package' => $package_name, # NOTE: # because of issues with the Perl API # to the typeglob in some versions, we @@ -36,7 +36,7 @@ sub initialize { # reference to the hash in the accessor. # Ideally we could just store a ref and # it would Just Work, but oh well :\ - '%:namespace' => \undef, + '%!namespace' => \undef, } => $class; } @@ -46,7 +46,7 @@ sub initialize { # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section -sub name { $_[0]->{'$:package'} } +sub name { $_[0]->{'$!package'} } sub namespace { # NOTE: # because of issues with the Perl API diff --git a/lib/metaclass.pm b/lib/metaclass.pm index a66b323..e1bd16a 100644 --- a/lib/metaclass.pm +++ b/lib/metaclass.pm @@ -15,7 +15,7 @@ use Class::MOP; sub import { shift; my $metaclass; - if (!defined($_[0]) || $_[0] =~ /^\:(attribute|method|instance)_metaclass/) { + if (!defined($_[0]) || $_[0] =~ /^(attribute|method|instance)_metaclass/) { $metaclass = 'Class::MOP::Class'; } else { @@ -62,16 +62,16 @@ metaclass - a pragma for installing and using Class::MOP metaclasses # and custom attribute and method # metaclasses use metaclass 'MyMetaClass' => ( - ':attribute_metaclass' => 'MyAttributeMetaClass', - ':method_metaclass' => 'MyMethodMetaClass', + 'attribute_metaclass' => 'MyAttributeMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', ); # ... or just specify custom attribute # and method classes, and Class::MOP::Class # is the assumed metaclass use metaclass ( - ':attribute_metaclass' => 'MyAttributeMetaClass', - ':method_metaclass' => 'MyMethodMetaClass', + 'attribute_metaclass' => 'MyAttributeMetaClass', + 'method_metaclass' => 'MyMethodMetaClass', ); =head1 DESCRIPTION diff --git a/t/000_load.t b/t/000_load.t index c7ba2c5..324ff6b 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -10,7 +10,7 @@ BEGIN { use_ok('Class::MOP::Package'); use_ok('Class::MOP::Module'); use_ok('Class::MOP::Class'); - use_ok('Class::MOP::Class::Immutable'); + use_ok('Class::MOP::Immutable'); use_ok('Class::MOP::Attribute'); use_ok('Class::MOP::Method'); use_ok('Class::MOP::Method::Wrapped'); @@ -22,6 +22,8 @@ BEGIN { # make sure we are tracking metaclasses correctly +my $CLASS_MOP_CLASS_IMMUTABLE_CLASS = 'Class::MOP::Class::__ANON__::SERIAL::1'; + my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, @@ -32,14 +34,17 @@ my %METAS = ( 'Class::MOP::Method' => Class::MOP::Method->meta, 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, 'Class::MOP::Instance' => Class::MOP::Instance->meta, - 'Class::MOP::Object' => Class::MOP::Object->meta, + 'Class::MOP::Object' => Class::MOP::Object->meta, ); ok($_->is_immutable(), '... ' . $_->name . ' is immutable') for values %METAS; is_deeply( { Class::MOP::get_all_metaclasses }, - \%METAS, + { + %METAS, + $CLASS_MOP_CLASS_IMMUTABLE_CLASS => $CLASS_MOP_CLASS_IMMUTABLE_CLASS->meta + }, '... got all the metaclasses'); is_deeply( @@ -47,6 +52,7 @@ is_deeply( [ Class::MOP::Attribute->meta, Class::MOP::Class->meta, + $CLASS_MOP_CLASS_IMMUTABLE_CLASS->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, Class::MOP::Method::Accessor->meta, @@ -54,13 +60,13 @@ is_deeply( Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, - Class::MOP::Package->meta, + Class::MOP::Package->meta, ], '... got all the metaclass instances'); is_deeply( [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], - [ qw/ + [ sort qw/ Class::MOP::Attribute Class::MOP::Class Class::MOP::Instance @@ -71,7 +77,7 @@ is_deeply( Class::MOP::Module Class::MOP::Object Class::MOP::Package - / ], + /, $CLASS_MOP_CLASS_IMMUTABLE_CLASS ], '... got all the metaclass names'); is_deeply( @@ -79,6 +85,7 @@ is_deeply( [ "Class::MOP::Attribute-" . $Class::MOP::Attribute::VERSION . "-cpan:STEVAN", "Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN", + $CLASS_MOP_CLASS_IMMUTABLE_CLASS, "Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN", "Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN", "Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN", diff --git a/t/006_new_and_clone_metaclasses.t b/t/006_new_and_clone_metaclasses.t index 6e972d9..b30e03b 100644 --- a/t/006_new_and_clone_metaclasses.t +++ b/t/006_new_and_clone_metaclasses.t @@ -15,7 +15,7 @@ BEGIN { my $meta = Class::MOP::Class->meta(); isa_ok($meta, 'Class::MOP::Class'); -my $new_meta = $meta->new_object(':package' => 'Class::MOP::Class'); +my $new_meta = $meta->new_object('package' => 'Class::MOP::Class'); isa_ok($new_meta, 'Class::MOP::Class'); is($new_meta, $meta, '... it still creates the singleton'); @@ -33,7 +33,7 @@ is($cloned_meta, $meta, '... it creates the singleton even if you try to clone i my $foo_meta = Foo->meta; isa_ok($foo_meta, 'Class::MOP::Class'); -is($meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); +is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); # make sure subclassed of Class::MOP::Class do the right thing @@ -46,7 +46,7 @@ is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->me my $my_meta = MyMetaClass->meta; isa_ok($my_meta, 'Class::MOP::Class'); -my $new_my_meta = $my_meta->new_object(':package' => 'MyMetaClass'); +my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass'); isa_ok($new_my_meta, 'Class::MOP::Class'); is($new_my_meta, $my_meta, '... even subclasses still create the singleton'); @@ -54,12 +54,12 @@ my $cloned_my_meta = $meta->clone_object($my_meta); isa_ok($cloned_my_meta, 'Class::MOP::Class'); is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it'); -is($my_meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); +is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)'); # now create a metaclass for real -my $bar_meta = $my_meta->new_object(':package' => 'Bar'); +my $bar_meta = $my_meta->new_object('package' => 'Bar'); isa_ok($bar_meta, 'Class::MOP::Class'); is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass'); @@ -78,7 +78,7 @@ my $baz_meta = Baz->meta; isa_ok($baz_meta, 'Class::MOP::Class'); isa_ok($baz_meta, 'MyMetaClass'); -is($my_meta->new_object(':package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); +is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton'); $baz_meta->superclasses('Bar'); diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 7f42a40..fba4d05 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 189; +use Test::More tests => 191; use Test::Exception; BEGIN { @@ -134,20 +134,22 @@ foreach my $non_method_name (qw( # check for the right attributes my @class_mop_package_attributes = ( - '$:package', - '%:namespace', + '$!package', + '%!namespace', ); my @class_mop_module_attributes = ( - '$:version', '$:authority' + '$!version', + '$!authority' ); my @class_mop_class_attributes = ( - '%:methods', - '%:attributes', - '$:attribute_metaclass', - '$:method_metaclass', - '$:instance_metaclass' + '@!superclasses', + '%!methods', + '%!attributes', + '$!attribute_metaclass', + '$!method_metaclass', + '$!instance_metaclass' ); # check class @@ -205,58 +207,58 @@ foreach my $attribute_name (@class_mop_module_attributes) { # ... package -ok($class_mop_package_meta->get_attribute('$:package')->has_reader, '... Class::MOP::Class $:package has a reader'); -is(ref($class_mop_package_meta->get_attribute('$:package')->reader), 'HASH', '... Class::MOP::Class $:package\'s a reader is { name => sub { ... } }'); +ok($class_mop_package_meta->get_attribute('$!package')->has_reader, '... Class::MOP::Class $!package has a reader'); +is(ref($class_mop_package_meta->get_attribute('$!package')->reader), 'HASH', '... Class::MOP::Class $!package\'s a reader is { name => sub { ... } }'); -ok($class_mop_package_meta->get_attribute('$:package')->has_init_arg, '... Class::MOP::Class $:package has a init_arg'); -is($class_mop_package_meta->get_attribute('$:package')->init_arg, ':package', '... Class::MOP::Class $:package\'s a init_arg is :package'); +ok($class_mop_package_meta->get_attribute('$!package')->has_init_arg, '... Class::MOP::Class $!package has a init_arg'); +is($class_mop_package_meta->get_attribute('$!package')->init_arg, 'package', '... Class::MOP::Class $!package\'s a init_arg is package'); # ... class -ok($class_mop_class_meta->get_attribute('%:attributes')->has_reader, '... Class::MOP::Class %:attributes has a reader'); -is_deeply($class_mop_class_meta->get_attribute('%:attributes')->reader, +ok($class_mop_class_meta->get_attribute('%!attributes')->has_reader, '... Class::MOP::Class %!attributes has a reader'); +is_deeply($class_mop_class_meta->get_attribute('%!attributes')->reader, { 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, - '... Class::MOP::Class %:attributes\'s a reader is &get_attribute_map'); + '... Class::MOP::Class %!attributes\'s a reader is &get_attribute_map'); -ok($class_mop_class_meta->get_attribute('%:attributes')->has_init_arg, '... Class::MOP::Class %:attributes has a init_arg'); -is($class_mop_class_meta->get_attribute('%:attributes')->init_arg, - ':attributes', - '... Class::MOP::Class %:attributes\'s a init_arg is :attributes'); +ok($class_mop_class_meta->get_attribute('%!attributes')->has_init_arg, '... Class::MOP::Class %!attributes has a init_arg'); +is($class_mop_class_meta->get_attribute('%!attributes')->init_arg, + 'attributes', + '... Class::MOP::Class %!attributes\'s a init_arg is attributes'); -ok($class_mop_class_meta->get_attribute('%:attributes')->has_default, '... Class::MOP::Class %:attributes has a default'); -is_deeply($class_mop_class_meta->get_attribute('%:attributes')->default('Foo'), +ok($class_mop_class_meta->get_attribute('%!attributes')->has_default, '... Class::MOP::Class %!attributes has a default'); +is_deeply($class_mop_class_meta->get_attribute('%!attributes')->default('Foo'), {}, - '... Class::MOP::Class %:attributes\'s a default of {}'); + '... Class::MOP::Class %!attributes\'s a default of {}'); -ok($class_mop_class_meta->get_attribute('$:attribute_metaclass')->has_reader, '... Class::MOP::Class $:attribute_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$:attribute_metaclass')->reader, +ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_reader, '... Class::MOP::Class $!attribute_metaclass has a reader'); +is_deeply($class_mop_class_meta->get_attribute('$!attribute_metaclass')->reader, { 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, - '... Class::MOP::Class $:attribute_metaclass\'s a reader is &attribute_metaclass'); + '... Class::MOP::Class $!attribute_metaclass\'s a reader is &attribute_metaclass'); -ok($class_mop_class_meta->get_attribute('$:attribute_metaclass')->has_init_arg, '... Class::MOP::Class $:attribute_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('$:attribute_metaclass')->init_arg, - ':attribute_metaclass', - '... Class::MOP::Class $:attribute_metaclass\'s a init_arg is :attribute_metaclass'); +ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_init_arg, '... Class::MOP::Class $!attribute_metaclass has a init_arg'); +is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->init_arg, + 'attribute_metaclass', + '... Class::MOP::Class $!attribute_metaclass\'s a init_arg is attribute_metaclass'); -ok($class_mop_class_meta->get_attribute('$:attribute_metaclass')->has_default, '... Class::MOP::Class $:attribute_metaclass has a default'); -is($class_mop_class_meta->get_attribute('$:attribute_metaclass')->default, +ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_default, '... Class::MOP::Class $!attribute_metaclass has a default'); +is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->default, 'Class::MOP::Attribute', - '... Class::MOP::Class $:attribute_metaclass\'s a default is Class::MOP:::Attribute'); + '... Class::MOP::Class $!attribute_metaclass\'s a default is Class::MOP:::Attribute'); -ok($class_mop_class_meta->get_attribute('$:method_metaclass')->has_reader, '... Class::MOP::Class $:method_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$:method_metaclass')->reader, +ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_reader, '... Class::MOP::Class $!method_metaclass has a reader'); +is_deeply($class_mop_class_meta->get_attribute('$!method_metaclass')->reader, { 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - '... Class::MOP::Class $:method_metaclass\'s a reader is &method_metaclass'); + '... Class::MOP::Class $!method_metaclass\'s a reader is &method_metaclass'); -ok($class_mop_class_meta->get_attribute('$:method_metaclass')->has_init_arg, '... Class::MOP::Class $:method_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('$:method_metaclass')->init_arg, - ':method_metaclass', - '... Class::MOP::Class $:method_metaclass\'s init_arg is :method_metaclass'); +ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_init_arg, '... Class::MOP::Class $!method_metaclass has a init_arg'); +is($class_mop_class_meta->get_attribute('$!method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Class $:method_metaclass\'s init_arg is method_metaclass'); -ok($class_mop_class_meta->get_attribute('$:method_metaclass')->has_default, '... Class::MOP::Class $:method_metaclass has a default'); -is($class_mop_class_meta->get_attribute('$:method_metaclass')->default, +ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_default, '... Class::MOP::Class $!method_metaclass has a default'); +is($class_mop_class_meta->get_attribute('$!method_metaclass')->default, 'Class::MOP::Method', - '... Class::MOP::Class $:method_metaclass\'s a default is Class::MOP:::Method'); + '... Class::MOP::Class $!method_metaclass\'s a default is Class::MOP:::Method'); # check the values of some of the methods diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index 30af573..7fe3b0e 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -62,9 +62,17 @@ BEGIN { ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')'); } - my @attributes = qw( - name accessor reader writer predicate clearer - init_arg default associated_class associated_methods + my @attributes = ( + '$!name', + '$!accessor', + '$!reader', + '$!writer', + '$!predicate', + '$!clearer', + '$!init_arg', + '$!default', + '$!associated_class', + '@!associated_methods', ); is_deeply( diff --git a/t/018_anon_class.t b/t/018_anon_class.t index 1eb3aa6..ad048eb 100644 --- a/t/018_anon_class.t +++ b/t/018_anon_class.t @@ -49,7 +49,7 @@ my $instance; ok($anon_class->has_method('foo'), '... we have a foo method now'); $instance = $anon_class->new_object(); - isa_ok($instance, $anon_class->name); + isa_ok($instance, $anon_class->name); isa_ok($instance, 'Foo'); is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); diff --git a/t/040_metaclass.t b/t/040_metaclass.t index b8f4918..190d8b0 100644 --- a/t/040_metaclass.t +++ b/t/040_metaclass.t @@ -33,8 +33,8 @@ isa_ok(Foo->meta, 'Class::MOP::Class'); package Bar; use metaclass 'BarMeta' => ( - ':attribute_metaclass' => 'BarMeta::Attribute', - ':method_metaclass' => 'BarMeta::Method', + 'attribute_metaclass' => 'BarMeta::Attribute', + 'method_metaclass' => 'BarMeta::Method', ); } diff --git a/t/043_instance_metaclass_incompatibility.t b/t/043_instance_metaclass_incompatibility.t index 9c53486..3e64164 100644 --- a/t/043_instance_metaclass_incompatibility.t +++ b/t/043_instance_metaclass_incompatibility.t @@ -24,14 +24,14 @@ BEGIN { $@ = undef; eval { package Foo; - metaclass->import(':instance_metaclass' => 'Foo::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; $@ = undef; eval { package Bar; - metaclass->import(':instance_metaclass' => 'Bar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; @@ -39,7 +39,7 @@ $@ = undef; eval { package Foo::Foo; use base 'Foo'; - metaclass->import(':instance_metaclass' => 'Bar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; @@ -47,7 +47,7 @@ $@ = undef; eval { package Bar::Bar; use base 'Bar'; - metaclass->import(':instance_metaclass' => 'Foo::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; @@ -55,7 +55,7 @@ $@ = undef; eval { package FooBar; use base 'Foo'; - metaclass->import(':instance_metaclass' => 'FooBar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); }; ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; @@ -63,7 +63,7 @@ $@ = undef; eval { package FooBar2; use base 'Bar'; - metaclass->import(':instance_metaclass' => 'FooBar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); }; ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; diff --git a/t/044_instance_metaclass_incompatibility_dynamic.t b/t/044_instance_metaclass_incompatibility_dynamic.t index e52b24a..9587930 100644 --- a/t/044_instance_metaclass_incompatibility_dynamic.t +++ b/t/044_instance_metaclass_incompatibility_dynamic.t @@ -24,21 +24,21 @@ BEGIN { $@ = undef; eval { package Foo; - metaclass->import(':instance_metaclass' => 'Foo::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; $@ = undef; eval { package Bar; - metaclass->import(':instance_metaclass' => 'Bar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; $@ = undef; eval { package Foo::Foo; - metaclass->import(':instance_metaclass' => 'Bar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); Foo::Foo->meta->superclasses('Foo'); }; ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; @@ -46,7 +46,7 @@ ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; $@ = undef; eval { package Bar::Bar; - metaclass->import(':instance_metaclass' => 'Foo::Meta::Instance'); + metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); Bar::Bar->meta->superclasses('Bar'); }; ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; @@ -54,7 +54,7 @@ ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; $@ = undef; eval { package FooBar; - metaclass->import(':instance_metaclass' => 'FooBar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); FooBar->meta->superclasses('Foo'); }; ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; @@ -62,7 +62,7 @@ ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; $@ = undef; eval { package FooBar2; - metaclass->import(':instance_metaclass' => 'FooBar::Meta::Instance'); + metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); FooBar2->meta->superclasses('Bar'); }; ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index d057136..5b1a1ca 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -3,12 +3,11 @@ use strict; use warnings; -use Test::More tests => 77; +use Test::More tests => 73; use Test::Exception; BEGIN { use_ok('Class::MOP'); - use_ok('Class::MOP::Class::Immutable'); } { @@ -57,7 +56,6 @@ BEGIN { ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); dies_ok { $meta->add_method() } '... exception thrown as expected'; @@ -119,7 +117,6 @@ BEGIN { ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); dies_ok { $meta->add_method() } '... exception thrown as expected'; @@ -181,7 +178,6 @@ BEGIN { ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); dies_ok { $meta->add_method() } '... exception thrown as expected'; diff --git a/t/072_immutable_w_constructors.t b/t/072_immutable_w_constructors.t index aeeaff6..70a59d1 100644 --- a/t/072_immutable_w_constructors.t +++ b/t/072_immutable_w_constructors.t @@ -3,12 +3,12 @@ use strict; use warnings; -use Test::More tests => 76; +use Test::More tests => 73; use Test::Exception; BEGIN { use_ok('Class::MOP'); - use_ok('Class::MOP::Class::Immutable'); + use_ok('Class::MOP::Immutable'); } { @@ -72,7 +72,6 @@ BEGIN { } '... changed Foo to be immutable'; ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); # they made a constructor for us :) @@ -128,7 +127,6 @@ BEGIN { } '... changed Bar to be immutable'; ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); # they made a constructor for us :) @@ -198,7 +196,6 @@ BEGIN { } '... changed Bar to be immutable'; ok($meta->is_immutable, '... our class is now immutable'); - isa_ok($meta, 'Class::MOP::Class::Immutable'); isa_ok($meta, 'Class::MOP::Class'); ok(!Baz->meta->has_method('new'), '... no constructor was made'); diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index b8c5d62..615203d 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -19,8 +19,8 @@ BEGIN { use warnings; use metaclass ( - ':attribute_metaclass' => 'InsideOutClass::Attribute', - ':instance_metaclass' => 'InsideOutClass::Instance' + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' ); Foo->meta->add_attribute('foo' => ( @@ -56,8 +56,8 @@ BEGIN { use strict; use warnings; use metaclass ( - ':attribute_metaclass' => 'InsideOutClass::Attribute', - ':instance_metaclass' => 'InsideOutClass::Instance' + 'attribute_metaclass' => 'InsideOutClass::Attribute', + 'instance_metaclass' => 'InsideOutClass::Instance' ); Baz->meta->add_attribute('bling' => ( diff --git a/t/106_LazyClass_test.t b/t/106_LazyClass_test.t index d9a8924..f457f55 100644 --- a/t/106_LazyClass_test.t +++ b/t/106_LazyClass_test.t @@ -15,13 +15,13 @@ BEGIN { package BinaryTree; use metaclass ( - ':attribute_metaclass' => 'LazyClass::Attribute', - ':instance_metaclass' => 'LazyClass::Instance', + 'attribute_metaclass' => 'LazyClass::Attribute', + 'instance_metaclass' => 'LazyClass::Instance', ); BinaryTree->meta->add_attribute('$:node' => ( accessor => 'node', - init_arg => ':node' + init_arg => 'node' )); BinaryTree->meta->add_attribute('$:left' => ( @@ -40,7 +40,7 @@ BEGIN { } } -my $root = BinaryTree->new(':node' => 0); +my $root = BinaryTree->new('node' => 0); isa_ok($root, 'BinaryTree'); ok(exists($root->{'$:node'}), '... node attribute has been initialized yet'); diff --git a/t/108_ArrayBasedStorage_test.t b/t/108_ArrayBasedStorage_test.t index c36a111..0757a61 100644 --- a/t/108_ArrayBasedStorage_test.t +++ b/t/108_ArrayBasedStorage_test.t @@ -18,7 +18,7 @@ BEGIN { use strict; use warnings; use metaclass ( - ':instance_metaclass' => 'ArrayBasedStorage::Instance', + 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); Foo->meta->add_attribute('foo' => ( @@ -54,7 +54,7 @@ BEGIN { use strict; use warnings; use metaclass ( - ':instance_metaclass' => 'ArrayBasedStorage::Instance', + 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); Baz->meta->add_attribute('bling' => (