From: Stevan Little Date: Sun, 18 May 2008 23:12:54 +0000 (+0000) Subject: okay, this is not meant to be used, but since i am not using svk or anything, I have... X-Git-Tag: 0_64~60 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4c1053331a179a6d1dd8e71d49ef05852a81387e;p=gitmo%2FClass-MOP.git okay, this is not meant to be used, but since i am not using svk or anything, I have to commit it, ... shut up, I know,.. blah blah blah....anyway, this version is pretty much all the refactoring I think I might need to do in order for the fake sub-name to work, all we need to test is that it works or doesnt work with the XS off... but I wanna be safe and check in here,.. yeah yah,.. SHUT UP I KNOW I SHOULD USE SVK,GIT, etc --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index adb2f9d..6546902 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -6,8 +6,8 @@ use warnings; use MRO::Compat; -use Carp 'confess'; -use Scalar::Util 'weaken'; +use Carp 'confess'; +use Scalar::Util 'weaken'; use Class::MOP::Class; use Class::MOP::Attribute; @@ -19,19 +19,77 @@ BEGIN { our $VERSION = '0.56'; our $AUTHORITY = 'cpan:STEVAN'; - use XSLoader; - XSLoader::load( 'Class::MOP', $VERSION ); - *IS_RUNNING_ON_5_10 = ($] < 5.009_005) ? sub () { 0 } - : sub () { 1 }; - - # get it from MRO::Compat now ... - *check_package_cache_flag = \&mro::get_pkg_gen; + : sub () { 1 }; - # UNCOMMENT ME TO TEST WITHOUT XS - #no warnings 'prototype', 'redefine'; - #*check_package_cache_flag = \&MRO::Compat::__get_pkg_gen_pp + # NOTE: + # we may not use this yet, but once + # the get_code_info XS gets merged + # upstream to it, we will always use + # it. But for now it is just kinda + # extra overhead. + # - SL + require Sub::Identify; + + # stash these for a sec, and see how things go + my $_PP_subname = sub { $_[1] }; + my $_PP_get_code_info = sub ($) { + return ( + Sub::Identify::stash_name($_[0]), + Sub::Identify::sub_name($_[0]) + ) + }; + + if ($ENV{CLASS_MOP_NO_XS} == 1) { + # NOTE: + # this is if you really want things + # to be slow, then you can force the + # no-XS rule this way, otherwise we + # make an effort to load as much of + # the XS as possible. + # - SL + no warnings 'prototype', 'redefine'; + # get this from MRO::Compat ... + *check_package_cache_flag = \&MRO::Compat::__get_pkg_gen_pp; + # our own version of Sub::Name + *subname = $_PP_subname; + # and the Sub::Identify version of the get_code_info + *get_code_info = $_PP_get_code_info; + } + else { + # now try our best to get as much + # of the XS loaded as possible + { + local $@; + eval { + require XSLoader; + XSLoader::load( 'Class::MOP', $VERSION ); + }; + die $@ if $@ && $@ !~ /object version|loadable object/; + + # okay, so the XS failed to load, so + # use the pure perl one instead. + *get_code_info = $_PP_get_code_info if $@; + } + + # get it from MRO::Compat + *check_package_cache_flag = \&mro::get_pkg_gen; + + # now try and load the Sub::Name + # module and use that as a means + # for naming our CVs, if not, we + # use the workaround instead. + if ( eval { require Sub::Name } ) { + *subname = sub { + #warn "Class::MOP::subname called with @_"; + Sub::Name::subname(@_); + }; + } + else { + *subname = $_PP_subname; + } + } } { @@ -448,6 +506,37 @@ Class::MOP::Method->meta->add_attribute( )) ); +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!package_name' => ( + init_arg => 'package_name', + reader => { 'package_name' => \&Class::MOP::Method::package_name }, + )) +); + +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('$!name' => ( + init_arg => 'name', + reader => { 'name' => \&Class::MOP::Method::name }, + )) +); + +Class::MOP::Method->meta->add_method('wrap' => sub { + my $class = shift; + my $code = shift; + my %options = @_; + + ('CODE' eq (Scalar::Util::reftype($code) || '')) + || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; + + # return the new object + $class->meta->new_object(body => $code, %options); +}); + +Class::MOP::Method->meta->add_method('clone' => sub { + my $self = shift; + $self->meta->clone_object($self, @_); +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Wrapped @@ -467,9 +556,17 @@ Class::MOP::Method::Generated->meta->add_attribute( Class::MOP::Attribute->new('$!is_inline' => ( init_arg => 'is_inline', reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, + default => 0, )) ); +Class::MOP::Method::Generated->meta->add_method('new' => sub { + my ($class, %options) = @_; + my $self = $class->meta->new_object(%options); + $self->initialize_body; + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -489,6 +586,32 @@ Class::MOP::Method::Accessor->meta->add_attribute( )) ); +Class::MOP::Method::Accessor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (exists $options{attribute}) + || confess "You must supply an attribute to construct with"; + + (exists $options{accessor_type}) + || confess "You must supply an accessor_type to construct with"; + + (Scalar::Util::blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) + || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!attribute'}); + + $self->initialize_body; + + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Method::Constructor @@ -499,6 +622,7 @@ Class::MOP::Method::Constructor->meta->add_attribute( reader => { 'options' => \&Class::MOP::Method::Constructor::options }, + default => sub { +{} } )) ); @@ -511,6 +635,27 @@ Class::MOP::Method::Constructor->meta->add_attribute( )) ); +Class::MOP::Method::Constructor->meta->add_method('new' => sub { + my $class = shift; + my %options = @_; + + (Scalar::Util::blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) + || confess "You must pass a metaclass instance if you want to inline" + if $options{is_inline}; + + # return the new object + my $self = $class->meta->new_object(%options); + + # we don't want this creating + # a cycle in the code, if not + # needed + Scalar::Util::weaken($self->{'$!associated_metaclass'}); + + $self->initialize_body; + + $self; +}); + ## -------------------------------------------------------- ## Class::MOP::Instance @@ -789,6 +934,14 @@ This function returns two values, the name of the package the C<$code> is from and the name of the C<$code> itself. This is used by several elements of the MOP to detemine where a given C<$code> reference is from. +=item B + +B + +If possible, we will load the L module and this will function +as C does, otherwise it will just return the C<$code> +argument. + =back =head2 Metaclass cache functions diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 02cfae9..9f4ff49 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -304,7 +304,11 @@ sub process_accessors { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; - $method = $self->accessor_metaclass->wrap($method); + $method = $self->accessor_metaclass->wrap( + $method, + package_name => $self->associated_class->name, + name => $name, + ); $self->associate_method($method); return ($name, $method); } @@ -316,6 +320,8 @@ sub process_accessors { attribute => $self, is_inline => $inline_me, accessor_type => $type, + package_name => $self->associated_class->name, + name => $accessor, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index cb5c463..06914b4 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -10,7 +10,6 @@ use Class::MOP::Method::Wrapped; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; -use Sub::Name 'subname'; our $VERSION = '0.31'; our $AUTHORITY = 'cpan:STEVAN'; @@ -557,17 +556,34 @@ sub add_method { my $body; if (blessed($method)) { $body = $method->body; + if ($method->package_name ne $self->name && + $method->name ne $method_name) { + warn "Hello there, got somethig for you." + . " Method says " . $method->package_name . " " . $method->name + . " Class says " . $self->name . " " . $method_name; + $method = $method->clone( + package_name => $self->name, + name => $method_name + ) if $method->can('clone'); + } } else { $body = $method; ('CODE' eq (reftype($body) || '')) || confess "Your code block must be a CODE reference"; - $method = $self->method_metaclass->wrap($body); + $method = $self->method_metaclass->wrap( + $body => ( + package_name => $self->name, + name => $method_name + ) + ); } $self->get_method_map->{$method_name} = $method; - - my $full_method_name = ($self->name . '::' . $method_name); - $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body); + + my $full_method_name = ($self->name . '::' . $method_name); + $self->add_package_symbol("&${method_name}" => + Class::MOP::subname($full_method_name => $body) + ); $self->update_package_cache_flag; } @@ -602,7 +618,9 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_before_modifier(subname ':before' => $method_modifier); + $method->add_before_modifier( + Class::MOP::subname(':before' => $method_modifier) + ); } sub add_after_method_modifier { @@ -610,7 +628,9 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_after_modifier(subname ':after' => $method_modifier); + $method->add_after_modifier( + Class::MOP::subname(':after' => $method_modifier) + ); } sub add_around_method_modifier { @@ -618,7 +638,9 @@ sub add_method { (defined $method_name && $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_around_modifier(subname ':around' => $method_modifier); + $method->add_around_modifier( + Class::MOP::subname(':around' => $method_modifier) + ); } # NOTE: diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index f767e9a..289a2d5 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -8,7 +8,6 @@ use Class::MOP::Method::Constructor; use Carp 'confess'; use Scalar::Util 'blessed'; -use Sub::Name 'subname'; our $VERSION = '0.06'; our $AUTHORITY = 'cpan:STEVAN'; @@ -99,9 +98,11 @@ sub make_metaclass_immutable { $metaclass->add_method( $options{constructor_name}, $constructor_class->new( - options => \%options, - metaclass => $metaclass, - is_inline => 1, + options => \%options, + metaclass => $metaclass, + is_inline => 1, + package_name => $metaclass->name, + name => $options{constructor_name} ) ) unless $metaclass->has_method($options{constructor_name}); } @@ -114,8 +115,10 @@ sub make_metaclass_immutable { my $destructor_class = $options{destructor_class}; my $destructor = $destructor_class->new( - options => \%options, - metaclass => $metaclass, + options => \%options, + metaclass => $metaclass, + package_name => $metaclass->name, + name => 'DESTROY' ); $metaclass->add_method('DESTROY' => $destructor) diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index b726e7c..5642d70 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -7,7 +7,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; -our $VERSION = '0.06'; +our $VERSION = '0.07'; our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Object'; @@ -20,12 +20,15 @@ use overload '&{}' => sub { $_[0]->body }, fallback => 1; # construction sub wrap { - my $class = shift; - my $code = shift; + my ( $class, $code, %params ) = @_; + ('CODE' eq (reftype($code) || '')) || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; + bless { - '&!body' => $code + '&!body' => $code, + '$!package_name' => $params{package_name}, + '$!name' => $params{name}, } => blessed($class) || $class; } @@ -37,31 +40,27 @@ sub body { (shift)->{'&!body'} } # informational -# NOTE: -# this may not be the same name -# as the class you got it from -# This gets the package stash name -# associated with the actual CODE-ref sub package_name { - my $code = (shift)->body; - (Class::MOP::get_code_info($code))[0]; + my $self = shift; + $self->{'$!package_name'} ||= (Class::MOP::get_code_info($self->body))[0]; } -# NOTE: -# this may not be the same name -# as the method name it is stored -# with. This gets the name associated -# with the actual CODE-ref sub name { - my $code = (shift)->body; - (Class::MOP::get_code_info($code))[1]; + my $self = shift; + $self->{'$!name'} ||= (Class::MOP::get_code_info($self->body))[1]; } sub fully_qualified_name { - my $code = shift; - $code->package_name . '::' . $code->name; + my $code = shift; + $code->package_name . '::' . $code->name; } +# NOTE: +# the Class::MOP bootstrap +# will create this for us +# - SL +# sub clone { ... } + 1; __END__ @@ -95,10 +94,18 @@ to this class. =over 4 -=item B +=item B This is the basic constructor, it returns a B -instance which wraps the given C<$code> reference. +instance which wraps the given C<$code> reference. You can also +set the C and C attributes using the C<%params>. +If these are not set, then thier accessors will attempt to figure +it out using the C function. + +=item B + +This will make a copy of the object, allowing you to override +any values by stuffing them in C<%params>. =back diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 62eaab8..d927a4b 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -28,6 +28,8 @@ sub new { my $self = bless { # from our superclass '&!body' => undef, + '$!package_name' => $options{package_name}, + '$!name' => $options{name}, # specific to this subclass '$!attribute' => $options{attribute}, '$!is_inline' => ($options{is_inline} || 0), diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm index 9ac824d..9395892 100644 --- a/lib/Class/MOP/Method/Constructor.pm +++ b/lib/Class/MOP/Method/Constructor.pm @@ -22,7 +22,9 @@ sub new { my $self = bless { # from our superclass - '&!body' => undef, + '&!body' => undef, + '$!package_name' => $options{package_name}, + '$!name' => $options{name}, # specific to this subclass '%!options' => $options{options} || {}, '$!associated_metaclass' => $options{metaclass}, diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm index 0b3456a..99e1ccc 100644 --- a/lib/Class/MOP/Method/Generated.pm +++ b/lib/Class/MOP/Method/Generated.pm @@ -18,6 +18,8 @@ sub new { my $self = bless { # from our superclass '&!body' => undef, + '$!package_name' => $options{package_name}, + '$!name' => $options{name}, # specific to this subclass '$!is_inline' => ($options{is_inline} || 0), } => $class; diff --git a/lib/Class/MOP/Method/Wrapped.pm b/lib/Class/MOP/Method/Wrapped.pm index c32b506..6e664be 100644 --- a/lib/Class/MOP/Method/Wrapped.pm +++ b/lib/Class/MOP/Method/Wrapped.pm @@ -6,7 +6,6 @@ use warnings; use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; -use Sub::Name 'subname'; our $VERSION = '0.02'; our $AUTHORITY = 'cpan:STEVAN'; @@ -69,10 +68,11 @@ my $_build_wrapped_method = sub { }; sub wrap { - my $class = shift; - my $code = shift; + my ( $class, $code, %params ) = @_; + (blessed($code) && $code->isa('Class::MOP::Method')) || confess "Can only wrap blessed CODE"; + my $modifier_table = { cache => undef, orig => $code, @@ -84,7 +84,13 @@ sub wrap { }, }; $_build_wrapped_method->($modifier_table); - my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) }); + my $method = $class->SUPER::wrap( + sub { $modifier_table->{cache}->(@_) }, + # get these from the original + # unless explicitly overriden + package_name => $params{package_name} || $code->package_name, + name => $params{name} || $code->name, + ); $method->{'%!modifier_table'} = $modifier_table; $method; }