[Moose-commits] r7293 - in Class-MOP/trunk: lib/Class lib/Class/MOP
lib/Class/MOP/Method t
nothingmuch at code2.0beta.co.uk
nothingmuch at code2.0beta.co.uk
Mon Jan 12 06:45:09 GMT 2009
Author: nothingmuch
Date: 2009-01-11 22:45:08 -0800 (Sun, 11 Jan 2009)
New Revision: 7293
Modified:
Class-MOP/trunk/lib/Class/MOP.pm
Class-MOP/trunk/lib/Class/MOP/Attribute.pm
Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm
Class-MOP/trunk/t/014_attribute_introspection.t
Log:
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.
Modified: Class-MOP/trunk/lib/Class/MOP/Attribute.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP/Attribute.pm 2009-01-12 05:53:32 UTC (rev 7292)
+++ Class-MOP/trunk/lib/Class/MOP/Attribute.pm 2009-01-12 06:45:08 UTC (rev 7293)
@@ -60,16 +60,17 @@
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_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 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 @@
$method,
package_name => $self->associated_class->name,
name => $name,
+ definition_context => $method_ctx,
);
$self->associate_method($method);
return ($name, $method);
@@ -346,12 +356,22 @@
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 $@;
Modified: Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm 2009-01-12 05:53:32 UTC (rev 7292)
+++ Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm 2009-01-12 06:45:08 UTC (rev 7293)
@@ -26,6 +26,32 @@
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 @@
## 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__
Modified: Class-MOP/trunk/lib/Class/MOP.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP.pm 2009-01-12 05:53:32 UTC (rev 7292)
+++ Class-MOP/trunk/lib/Class/MOP.pm 2009-01-12 06:45:08 UTC (rev 7293)
@@ -449,6 +449,12 @@
);
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::Attribute->new('definition_context' => (
+ reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context },
+ ))
+);
+
## --------------------------------------------------------
## Class::MOP::Method::Accessor
Modified: Class-MOP/trunk/t/014_attribute_introspection.t
===================================================================
--- Class-MOP/trunk/t/014_attribute_introspection.t 2009-01-12 05:53:32 UTC (rev 7292)
+++ Class-MOP/trunk/t/014_attribute_introspection.t 2009-01-12 06:45:08 UTC (rev 7293)
@@ -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 @@
has_default default is_default_a_coderef
has_initializer initializer
+ definition_context
+
slots
get_value
set_value
@@ -77,6 +79,7 @@
'builder',
'init_arg',
'initializer',
+ 'definition_context',
'default',
'associated_class',
'associated_methods',
More information about the Moose-commits
mailing list