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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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',