From: Yuval Kogman Date: Mon, 12 Jan 2009 06:45:08 +0000 (+0000) Subject: add definition_context X-Git-Tag: 0.76~16 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9d996899a18e6a1efd4fe741bbe6dc8be5d4de9;p=gitmo%2FClass-MOP.git add definition_context This is used to generate #line declarations for evaled code. Currently only in use for accessors, should be added to constructor as well. --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index b520e2e..d4fce4c 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -449,6 +449,12 @@ Class::MOP::Attribute->meta->add_attribute( ); Class::MOP::Attribute->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Attribute::definition_context }, + )) +); + +Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('writer' => ( reader => { 'writer' => \&Class::MOP::Attribute::writer }, predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer }, @@ -564,6 +570,12 @@ Class::MOP::Method::Generated->meta->add_attribute( )) ); +Class::MOP::Method::Generated->meta->add_attribute( + Class::MOP::Attribute->new('definition_context' => ( + reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context }, + )) +); + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 9afd4f8..d1a1940 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -60,16 +60,17 @@ sub _new { my $options = @_ == 1 ? $_[0] : {@_}; bless { - 'name' => $options->{name}, - 'accessor' => $options->{accessor}, - 'reader' => $options->{reader}, - 'writer' => $options->{writer}, - 'predicate' => $options->{predicate}, - 'clearer' => $options->{clearer}, - 'builder' => $options->{builder}, - 'init_arg' => $options->{init_arg}, - 'default' => $options->{default}, - 'initializer' => $options->{initializer}, + 'name' => $options->{name}, + 'accessor' => $options->{accessor}, + 'reader' => $options->{reader}, + 'writer' => $options->{writer}, + 'predicate' => $options->{predicate}, + 'clearer' => $options->{clearer}, + 'builder' => $options->{builder}, + 'init_arg' => $options->{init_arg}, + 'default' => $options->{default}, + 'initializer' => $options->{initializer}, + 'definition_context' => $options->{definition_context}, # keep a weakened link to the # class we are associated with 'associated_class' => undef, @@ -165,14 +166,15 @@ sub has_init_arg { defined($_[0]->{'init_arg'}) } sub has_default { defined($_[0]->{'default'}) } sub has_initializer { defined($_[0]->{'initializer'}) } -sub accessor { $_[0]->{'accessor'} } -sub reader { $_[0]->{'reader'} } -sub writer { $_[0]->{'writer'} } -sub predicate { $_[0]->{'predicate'} } -sub clearer { $_[0]->{'clearer'} } -sub builder { $_[0]->{'builder'} } -sub init_arg { $_[0]->{'init_arg'} } -sub initializer { $_[0]->{'initializer'} } +sub accessor { $_[0]->{'accessor'} } +sub reader { $_[0]->{'reader'} } +sub writer { $_[0]->{'writer'} } +sub predicate { $_[0]->{'predicate'} } +sub clearer { $_[0]->{'clearer'} } +sub builder { $_[0]->{'builder'} } +sub init_arg { $_[0]->{'init_arg'} } +sub initializer { $_[0]->{'initializer'} } +sub definition_context { $_[0]->{'definition_context'} } # end bootstrapped away method section. # (all methods below here are kept intact) @@ -330,6 +332,13 @@ sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; + + my $method_ctx; + + if ( my $ctx = $self->definition_context ) { + $method_ctx = { %$ctx }; + } + if (ref($accessor)) { (ref($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; @@ -338,6 +347,7 @@ sub process_accessors { $method, package_name => $self->associated_class->name, name => $name, + definition_context => $method_ctx, ); $self->associate_method($method); return ($name, $method); @@ -346,12 +356,22 @@ sub process_accessors { my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); my $method; eval { + if ( $method_ctx ) { + my $desc = "accessor $accessor"; + if ( $accessor ne $self->name ) { + $desc .= " of attribute " . $self->name; + } + + $method_ctx->{description} = $desc; + } + $method = $self->accessor_metaclass->new( attribute => $self, is_inline => $inline_me, accessor_type => $type, package_name => $self->associated_class->name, name => $accessor, + definition_context => $method_ctx, ); }; confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@; diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm index 4b889b0..170e0a1 100644 --- a/lib/Class/MOP/Method/Generated.pm +++ b/lib/Class/MOP/Method/Generated.pm @@ -26,6 +26,32 @@ sub new { return $self; } + +sub _prepare_code { + my ( $self, %args ) = @_; + + my ( $line, $file ); + + if ( my $ctx = ( $args{context} || $self->definition_context ) ) { + $line = $ctx->{line}; + if ( my $desc = $ctx->{description} ) { + $file = "$desc defined at $ctx->{file}"; + } else { + $file = $ctx->{file}; + } + } else { + ( $line, $file ) = ( 0, "generated method (unknown origin)" ); + } + + my $code = $args{code}; + + # if it's an array of lines, join it up + # don't use newlines so that the definition context is more meaningful + $code = join(@$code, ' ') if ref $code; + + return qq{#line $line "$file"\n} . $code; +} + sub _new { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; @@ -38,14 +64,15 @@ sub _new { ## accessors -sub is_inline { (shift)->{'is_inline'} } +sub is_inline { $_[0]{is_inline} } + +sub definition_context { $_[0]{definition_context} } sub initialize_body { confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class"; } - 1; __END__ diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t index 7ba20c0..c8a4864 100644 --- a/t/014_attribute_introspection.t +++ b/t/014_attribute_introspection.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 62; +use Test::More tests => 64; use Test::Exception; use Class::MOP; @@ -35,6 +35,8 @@ use Class::MOP; has_default default is_default_a_coderef has_initializer initializer + definition_context + slots get_value set_value @@ -77,6 +79,7 @@ use Class::MOP; 'builder', 'init_arg', 'initializer', + 'definition_context', 'default', 'associated_class', 'associated_methods',