From: Stevan Little Date: Wed, 8 Nov 2006 16:32:36 +0000 (+0000) Subject: fixed all the attribute name to be more Perl6ish and then removed the : in the init_a... X-Git-Tag: 0_37_002~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=81c8a65bf02bb1b0e240d8f5b626b0ceabf9a37c;p=gitmo%2FClass-MOP.git fixed all the attribute name to be more Perl6ish and then removed the : in the init_args as well (this aint LISP :P) --- diff --git a/Changes b/Changes index 4f2dc7c..8268375 100644 --- a/Changes +++ b/Changes @@ -1,29 +1,33 @@ Revision history for Perl extension Class-MOP. -0.36 +0.36 Sun. Nov. 5, 2006 * Class::MOP::Class - added a few 'no warnings' lines to keep annoying (and meaningless) warnings from chirping during global destruction. - - - A t/072_immutable_w_constructors.t - U t/000_load.t - U t/014_attribute_introspection.t - U t/050_scala_style_mixin_composition.t - U t/005_attributes.t - U lib/Class/MOP.pm - G lib/Class/MOP/Class.pm - A lib/Class/MOP/Method - A lib/Class/MOP/Method/Constructor.pm - A lib/Class/MOP/Method/Accessor.pm - A lib/Class/MOP/Method/Wrapped.pm - U lib/Class/MOP/Class/Immutable.pm - U lib/Class/MOP/Method.pm - U lib/Class/MOP/Attribute.pm - U examples/AttributesWithHistory.pod - U examples/LazyClass.pod - U examples/InsideOutClass.pod + + * Class::MOP + - some more bootstrapping is now done on the new + classes + + * Class::MOP::Class::Immutable + *** API CHANGE *** + - constructor generation is now handled by + the Class::MOP::Method::Constructor class + + * Class::MOP::Method::Constructor + - created this to handle constructor generation + in Class::MOP::Class::Immutable + + * Class::MOP::Attribute + *** API CHANGE *** + - attributes now delegate to the + Class::MOP::Method::Accessor to generate + accessors + + * Class::MOP::Method::Accessor + - all accessor generation functions from + Class::MOP::Attribute have been moved here 0.35 Sat. Sept. 30, 2006 diff --git a/MANIFEST b/MANIFEST index 9053a56..12aec29 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,7 +1,7 @@ Build.PL Changes -Makefile.PL META.yml +Makefile.PL MANIFEST MANIFEST.SKIP README @@ -23,6 +23,9 @@ 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 scripts/class_browser.pl t/000_load.t t/001_basic.t @@ -55,6 +58,7 @@ t/060_instance.t t/061_instance_inline.t t/070_immutable_metaclass.t t/071_immutable_w_custom_metaclass.t +t/072_immutable_w_constructors.t t/080_meta_package.t t/081_meta_package_extension.t t/100_BinaryTree_test.t diff --git a/bench/all.yml b/bench/all.yml index 13ec57f..e2cf145 100644 --- a/bench/all.yml +++ b/bench/all.yml @@ -5,8 +5,8 @@ - 'MOP::Point3D' - 'MOP::Immutable::Point' - 'MOP::Immutable::Point3D' - - 'MOP::Installed::Point' - - 'MOP::Installed::Point3D' +# - 'MOP::Installed::Point' +# - 'MOP::Installed::Point3D' - 'Plain::Point' - 'Plain::Point3D' benchmarks: 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 66db0e2..e5a80c9 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -13,7 +13,7 @@ use Class::MOP::Method; use Class::MOP::Class::Immutable; -our $VERSION = '0.35'; +our $VERSION = '0.36'; 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,7 +396,63 @@ 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' => ( + 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' => ( + 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' => ( + init_arg => 'is_inline', + reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline }, + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Constructor + +Class::MOP::Method::Constructor->meta->add_attribute( + 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' => ( + init_arg => 'meta_instance', + reader => { + 'meta_instance' => \&Class::MOP::Method::Constructor::meta_instance + }, + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('@!attributes' => ( + init_arg => 'attributes', + reader => { + 'attributes' => \&Class::MOP::Method::Constructor::attributes + }, + )) ); ## -------------------------------------------------------- @@ -380,11 +463,11 @@ Class::MOP::Method::Wrapped->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') ); ## -------------------------------------------------------- @@ -412,7 +495,8 @@ $_->meta->make_immutable( Class::MOP::Object Class::MOP::Method::Accessor - Class::MOP::Method::Wrapped + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped /; 1; diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c8ab6c0..db13b1a 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -9,7 +9,7 @@ use Class::MOP::Method::Accessor; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.12'; +our $VERSION = '0.14'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -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 @@ -211,7 +211,7 @@ sub process_accessors { eval { $method = $self->accessor_metaclass->new( attribute => $self, - as_inline => $inline_me, + is_inline => $inline_me, accessor_type => $type, ); }; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index afd2789..0a16c25 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -28,7 +28,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 +37,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 +49,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: @@ -70,14 +70,13 @@ sub construct_class_instance { : blessed($class)) : $class); - $class = blessed($class) || $class; # now create the metaclass my $meta; if ($class =~ /^Class::MOP::Class$/) { no strict 'refs'; $meta = bless { # inherited from Class::MOP::Package - '$:package' => $package_name, + '$!package' => $package_name, # NOTE: # since the following attributes will @@ -87,17 +86,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 { @@ -260,16 +260,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; @@ -341,11 +341,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; } @@ -727,8 +728,35 @@ sub find_attribute_by_name { sub is_mutable { 1 } sub is_immutable { 0 } -sub make_immutable { - return Class::MOP::Class::Immutable->make_metaclass_immutable(@_); +{ + use Class::MOP::Immutable; + + my $IMMUTABLE_META; + + sub make_immutable { + my ($self) = @_; + + $IMMUTABLE_META ||= Class::MOP::Immutable->new($self->meta, { + 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', + } + })->create_immutable_metaclass; + + $IMMUTABLE_META->make_metaclass_immutable(@_); + } } 1; diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index 942708c..aa9ad68 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -4,10 +4,12 @@ package Class::MOP::Class::Immutable; use strict; use warnings; +use Class::MOP::Method::Constructor; + use Carp 'confess'; -use Scalar::Util 'blessed', 'looks_like_number'; +use Scalar::Util 'blessed'; -our $VERSION = '0.03'; +our $VERSION = '0.04'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Class'; @@ -41,19 +43,6 @@ for my $meth (qw( }; } -sub get_package_symbol { - my ($self, $variable) = @_; - my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); - return *{$self->namespace->{$name}}{$type} - if exists $self->namespace->{$name}; - # NOTE: - # we have to do this here in order to preserve - # perl's autovivification of variables. However - # we do cut off direct access to add_package_symbol - # as shown above. - $self->Class::MOP::Package::add_package_symbol($variable); -} - # NOTE: # superclasses is an accessor, so # it just cannot be changed @@ -88,87 +77,37 @@ sub make_metaclass_immutable { if ($options{inline_accessors}) { foreach my $attr_name ($metaclass->get_attribute_list) { - my $attr = $metaclass->get_attribute($attr_name); - $attr->install_accessors(1); # inline the accessors + # 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}, - $class->_generate_inline_constructor( - \%options, - $meta_instance, - $metaclass->{'___compute_all_applicable_attributes'} - ) + $constructor_class->new( + options => \%options, + meta_instance => $meta_instance, + attributes => $metaclass->{'___compute_all_applicable_attributes'} + ) ); } # now cache the method map ... - $metaclass->{'___method_map'} = $metaclass->get_method_map; + $metaclass->{'___get_method_map'} = $metaclass->get_method_map; bless $metaclass => $class; } -sub _generate_inline_constructor { - my ($class, $options, $meta_instance, $attrs) = @_; - # TODO: - # the %options should also include a both - # a call 'initializer' and call 'SUPER::' - # options, which should cover approx 90% - # of the possible use cases (even if it - # requires some adaption on the part of - # the author, after all, nothing is free) - my $source = 'sub {'; - $source .= "\n" . 'my ($class, %params) = @_;'; - $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class'); - $source .= ";\n" . (join ";\n" => map { - $class->_generate_slot_initializer($meta_instance, $attrs, $_) - } 0 .. (@$attrs - 1)); - $source .= ";\n" . 'return $instance'; - $source .= ";\n" . '}'; - warn $source if $options->{debug}; - my $code = eval $source; - confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; - return $code; -} - -sub _generate_slot_initializer { - my ($class, $meta_instance, $attrs, $index) = @_; - my $attr = $attrs->[$index]; - my $default; - if ($attr->has_default) { - # NOTE: - # default values can either be CODE refs - # in which case we need to call them. Or - # they can be scalars (strings/numbers) - # in which case we can just deal with them - # in the code we eval. - if ($attr->is_default_a_coderef) { - $default = '$attrs->[' . $index . ']->default($instance)'; - } - else { - $default = $attrs->[$index]->default; - # make sure to quote strings ... - unless (looks_like_number($default)) { - $default = "'$default'"; - } - } - } - $meta_instance->inline_set_slot_value( - '$instance', - ("'" . $attr->name . "'"), - ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) - ) -} - # 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)->{'___method_map'} } +sub get_method_map { (shift)->{'___get_method_map'} } 1; @@ -289,11 +228,6 @@ to this method, which This method becomes read-only in an immutable class. -=item B - -This method must handle package variable autovivification -correctly, while still disallowing C. - =back =head2 Cached methods diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index b2e406a..764a39c 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 diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 247b333..55b22fb 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -8,7 +8,7 @@ use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; use B 'svref_2object'; -our $VERSION = '0.04'; +our $VERSION = '0.05'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -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 1c0ea40..1c03e31 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -7,7 +7,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.02'; +our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Method'; @@ -27,17 +27,17 @@ sub new { my $self = bless { # from our superclass - body => undef, + '&!body' => undef, # specific to this subclass - attribute => $options{attribute}, - as_inline => ($options{as_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 as_inline { (shift)->{as_inline} } +sub associated_attribute { (shift)->{'$!attribute'} } +sub accessor_type { (shift)->{'$!accessor_type'} } +sub is_inline { (shift)->{'$!is_inline'} } ## factory @@ -59,10 +59,10 @@ sub intialize_body { 'generate', $self->accessor_type, 'method', - ($self->as_inline ? 'inline' : ()) + ($self->is_inline ? 'inline' : ()) ); - eval { $self->{body} = $self->$method_name() }; + eval { $self->{'&!body'} = $self->$method_name() }; die $@ if $@; } @@ -202,7 +202,7 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors =item B -=item B +=item B =item B @@ -232,8 +232,6 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors Stevan Little Estevan@iinteractive.comE -Yuval Kogman Enothingmuch@woobling.comE - =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc. diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm new file mode 100644 index 0000000..f420fb3 --- /dev/null +++ b/lib/Class/MOP/Method/Constructor.pm @@ -0,0 +1,169 @@ + +package Class::MOP::Method::Constructor; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken', 'looks_like_number'; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method'; + +sub new { + my $class = shift; + my %options = @_; + + (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, + # specific to this subclass + '%!options' => $options{options}, + '$!meta_instance' => $options{meta_instance}, + '@!attributes' => $options{attributes}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{'$!meta_instance'}); + + $self->intialize_body; + + return $self; +} + +## accessors + +sub options { (shift)->{'%!options'} } +sub meta_instance { (shift)->{'$!meta_instance'} } +sub attributes { (shift)->{'@!attributes'} } + +## method + +sub intialize_body { + my $self = shift; + # TODO: + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of + # the author, after all, nothing is free) + my $source = 'sub {'; + $source .= "\n" . 'my ($class, %params) = @_;'; + $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); + $source .= ";\n" . (join ";\n" => map { + $self->_generate_slot_initializer($_) + } 0 .. (@{$self->attributes} - 1)); + $source .= ";\n" . 'return $instance'; + $source .= ";\n" . '}'; + warn $source if $self->options->{debug}; + + my $code; + { + # NOTE: + # create the nessecary lexicals + # to be picked up in the eval + my $attrs = $self->attributes; + + $code = eval $source; + confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; + } + $self->{body} = $code; +} + +sub _generate_slot_initializer { + my $self = shift; + my $index = shift; + + my $attr = $self->attributes->[$index]; + + my $default; + if ($attr->has_default) { + # NOTE: + # default values can either be CODE refs + # in which case we need to call them. Or + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + $default = '$attrs->[' . $index . ']->default($instance)'; + } + else { + $default = $attr->default; + # make sure to quote strings ... + unless (looks_like_number($default)) { + $default = "'$default'"; + } + } + } + $self->meta_instance->inline_set_slot_value( + '$instance', + ("'" . $attr->name . "'"), + ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) + ); +} + +1; + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Constructor - Method Meta Object for constructors + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=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/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 cb43aef..b3e27b9 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -3,13 +3,19 @@ use strict; use warnings; -use Test::More tests => 22; +use Test::More tests => 29; BEGIN { use_ok('Class::MOP'); + 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::Attribute'); - use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Accessor'); + use_ok('Class::MOP::Method::Constructor'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } @@ -18,14 +24,15 @@ BEGIN { my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, - 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, 'Class::MOP::Package' => Class::MOP::Package->meta, 'Class::MOP::Module' => Class::MOP::Module->meta, - 'Class::MOP::Class' => Class::MOP::Class->meta, + 'Class::MOP::Class' => Class::MOP::Class->meta, '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; @@ -42,7 +49,8 @@ is_deeply( Class::MOP::Class->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, - Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Constructor->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, @@ -57,7 +65,8 @@ is_deeply( Class::MOP::Class Class::MOP::Instance Class::MOP::Method - Class::MOP::Method::Accessor + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor Class::MOP::Method::Wrapped Class::MOP::Module Class::MOP::Object @@ -73,6 +82,7 @@ is_deeply( "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", + "Class::MOP::Method::Constructor-" . $Class::MOP::Method::Constructor::VERSION . "-cpan:STEVAN", "Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN", "Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN", "Class::MOP::Object-" . $Class::MOP::Object::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/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/072_immutable_w_constructors.t b/t/072_immutable_w_constructors.t new file mode 100644 index 0000000..aeeaff6 --- /dev/null +++ b/t/072_immutable_w_constructors.t @@ -0,0 +1,242 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 76; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Class::Immutable'); +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar' => ( + reader => 'bar', + default => 'BAR', + )); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz' => ( + reader => 'baz', + default => sub { 'BAZ' }, + )); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah' => ( + reader => 'bah', + default => 'BAH', + )); +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 0, + ); + } '... 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 :) + can_ok('Foo', 'new'); + + { + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAR', '... got the right default value'); + } + + { + my $foo = Foo->new(bar => 'BAZ'); + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAZ', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + } +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 1, + ); + } '... 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 :) + can_ok('Bar', 'new'); + + { + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAR', '... got the right default value'); + is($bar->baz, 'BAZ', '... got the right default value'); + } + + { + my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAZ!', '... got the right parameter value'); + is($bar->baz, 'BAR!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 0, + inline_accessors => 1, + ); + } '... 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'); + + { + my $baz = Baz->meta->construct_instance; + isa_ok($baz, 'Bar'); + is($baz->bar, 'BAR', '... got the right default value'); + is($baz->baz, 'BAZ', '... got the right default value'); + } + + { + my $baz = Baz->meta->construct_instance(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); + isa_ok($baz, 'Baz'); + is($baz->bar, 'BAZ!', '... got the right parameter value'); + is($baz->baz, 'BAR!', '... got the right parameter value'); + is($baz->bah, 'BAH!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + 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' => (