From: gfx Date: Sun, 12 Jul 2009 07:04:38 +0000 (+0900) Subject: Implement an idea of reducing inline constructors in basic metaclasses X-Git-Tag: 0.90~17^2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ec9e38e5fd24916a3b5a4b67b5e7c7d20674d0f5;hp=dbea6de4246cb1d75716f20bf5863ca4e15671a1;p=gitmo%2FClass-MOP.git Implement an idea of reducing inline constructors in basic metaclasses put all the inlined constructors _new() in modules directly. --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e3c38ff..1f54f1d 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -691,8 +691,7 @@ undef Class::MOP::Instance->meta->{_package_cache_flag}; # the compile time of the MOP, and gives us no actual benefits. $_->meta->make_immutable( - inline_constructor => 1, - replace_constructor => 1, + inline_constructor => 0, constructor_name => "_new", inline_accessors => 0, ) for qw/ diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 3e41652..b6b3f52 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -57,6 +57,10 @@ sub new { sub _new { my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $options = @_ == 1 ? $_[0] : {@_}; bless { diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index bb2385b..32eec6a 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -107,9 +107,12 @@ sub _construct_class_instance { sub _new { my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $options = @_ == 1 ? $_[0] : {@_}; - bless { + return bless { # inherited from Class::MOP::Package 'package' => $options->{package}, diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 8643e3e..b617afa 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -45,8 +45,12 @@ sub new { } sub _new { - my ( $class, %options ) = @_; - bless { + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { # NOTE: # I am not sure that it makes # sense to pass in the meta @@ -57,10 +61,10 @@ sub _new { # which is *probably* a safe # assumption,.. but you can # never tell <:) - 'associated_metaclass' => $options{associated_metaclass}, - 'attributes' => $options{attributes}, - 'slots' => $options{slots}, - 'slot_hash' => $options{slot_hash}, + 'associated_metaclass' => $params->{associated_metaclass}, + 'attributes' => $params->{attributes}, + 'slots' => $params->{slots}, + 'slot_hash' => $params->{slot_hash}, } => $class; } diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index ea580ab..112a038 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -43,13 +43,17 @@ sub wrap { sub _new { my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $params = @_ == 1 ? $_[0] : {@_}; - my $self = bless { + return bless { 'body' => $params->{body}, 'associated_metaclass' => $params->{associated_metaclass}, 'package_name' => $params->{package_name}, 'name' => $params->{name}, + 'original_method' => $params->{original_method}, } => $class; } diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index ecc84ad..4d0aa8f 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -43,11 +43,28 @@ sub new { sub _new { my $class = shift; - my $options = @_ == 1 ? $_[0] : {@_}; - $options->{is_inline} ||= 0; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; - return bless $options, $class; + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + associated_metaclass => $params->{associated_metaclass}, + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherit from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # defined in this class + attribute => $params->{attribute}, + accessor_type => $params->{accessor_type}, + } => $class; } ## accessors diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 9a1bf3f..8382286 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -38,17 +38,29 @@ sub new { sub _new { my $class = shift; - my $options = @_ == 1 ? $_[0] : {@_}; - - bless { - # from our superclass - 'body' => undef, - 'package_name' => $options->{package_name}, - 'name' => $options->{name}, - # specific to this subclass - 'options' => $options->{options} || {}, - 'associated_metaclass' => $options->{metaclass}, - 'is_inline' => ($options->{is_inline} || 0), + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + # inherited from Class::MOP::Method + body => $params->{body}, + # associated_metaclass => $params->{associated_metaclass}, # overriden + package_name => $params->{package_name}, + name => $params->{name}, + original_method => $params->{original_method}, + + # inherited from Class::MOP::Generated + is_inline => $params->{is_inline} || 0, + definition_context => $params->{definition_context}, + + # inherited from Class::MOP::Inlined + _expected_method_class => $params->{_expected_method_class}, + + # defined in this subclass + options => $params->{options} || {}, + associated_metaclass => $params->{metaclass}, }, $class; } diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm index 2c125f5..24eeaca 100644 --- a/lib/Class/MOP/Module.pm +++ b/lib/Class/MOP/Module.pm @@ -13,6 +13,23 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Package'; +sub _new{ + my $class = shift; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + + my $params = @_ == 1 ? $_[0] : {@_}; + return bless { + # from Class::MOP::Package + package => $params->{package}, + namespace => \undef, + + # attributes + version => \undef, + authority => \undef + } => $class; +} + sub version { my $self = shift; ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })}; diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 0336a57..d2cc021 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -58,18 +58,25 @@ sub reinitialize { sub _new { my $class = shift; - my $options = @_ == 1 ? $_[0] : {@_}; + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; - # NOTE: - # because of issues with the Perl API - # to the typeglob in some versions, we - # need to just always grab a new - # reference to the hash in the accessor. - # Ideally we could just store a ref and - # it would Just Work, but oh well :\ - $options->{namespace} ||= \undef; + my $params = @_ == 1 ? $_[0] : {@_}; + + return bless { + package => $params->{package}, + + # NOTE: + # because of issues with the Perl API + # to the typeglob in some versions, we + # need to just always grab a new + # reference to the hash in the accessor. + # Ideally we could just store a ref and + # it would Just Work, but oh well :\ + + namespace => \undef, - bless $options, $class; + } => $class; } # Attributes