[Moose-commits] r7323 - Class-MOP/trunk/lib/Class/MOP/Method
nothingmuch at code2.0beta.co.uk
nothingmuch at code2.0beta.co.uk
Sat Jan 17 22:59:56 GMT 2009
Author: nothingmuch
Date: 2009-01-17 14:59:55 -0800 (Sat, 17 Jan 2009)
New Revision: 7323
Modified:
Class-MOP/trunk/lib/Class/MOP/Method/Accessor.pm
Class-MOP/trunk/lib/Class/MOP/Method/Constructor.pm
Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm
Log:
Merge method_generation_cleanup branch
Modified: Class-MOP/trunk/lib/Class/MOP/Method/Accessor.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP/Method/Accessor.pm 2009-01-17 22:36:34 UTC (rev 7322)
+++ Class-MOP/trunk/lib/Class/MOP/Method/Accessor.pm 2009-01-17 22:59:55 UTC (rev 7323)
@@ -114,41 +114,54 @@
sub generate_accessor_method_inline {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->instance_metaclass;
- my $code = eval 'sub {'
- . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]') . ' if scalar(@_) == 2; '
+ my $code = $self->_eval_closure(
+ {},
+ 'sub {'
+ . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
+ . ' if scalar(@_) == 2; '
. $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
- . '}';
+ . '}'
+ );
confess "Could not generate inline accessor because : $@" if $@;
return $code;
}
sub generate_reader_method_inline {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->instance_metaclass;
- my $code = eval 'sub {'
+ my $code = $self->_eval_closure(
+ {},
+ 'sub {'
. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
. $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
- . '}';
+ . '}'
+ );
confess "Could not generate inline accessor because : $@" if $@;
return $code;
}
sub generate_writer_method_inline {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->instance_metaclass;
- my $code = eval 'sub {'
+ my $code = $self->_eval_closure(
+ {},
+ 'sub {'
. $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
- . '}';
+ . '}'
+ );
confess "Could not generate inline accessor because : $@" if $@;
return $code;
@@ -156,26 +169,34 @@
sub generate_predicate_method_inline {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->instance_metaclass;
- my $code = eval 'sub {' .
- $meta_instance->inline_is_slot_initialized('$_[0]', "'$attr_name'")
- . '}';
+ my $code = $self->_eval_closure(
+ {},
+ 'sub {'
+ . $meta_instance->inline_is_slot_initialized('$_[0]', "'$attr_name'")
+ . '}'
+ );
confess "Could not generate inline predicate because : $@" if $@;
return $code;
}
sub generate_clearer_method_inline {
- my $attr = (shift)->associated_attribute;
+ my $self = shift;
+ my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->instance_metaclass;
- my $code = eval 'sub {'
+ my $code = $self->_eval_closure(
+ {},
+ 'sub {'
. $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
- . '}';
+ . '}'
+ );
confess "Could not generate inline clearer because : $@" if $@;
return $code;
Modified: Class-MOP/trunk/lib/Class/MOP/Method/Constructor.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP/Method/Constructor.pm 2009-01-17 22:36:34 UTC (rev 7322)
+++ Class-MOP/trunk/lib/Class/MOP/Method/Constructor.pm 2009-01-17 22:59:55 UTC (rev 7323)
@@ -89,6 +89,8 @@
sub generate_constructor_method_inline {
my $self = shift;
+ my $close_over = {};
+
my $source = 'sub {';
$source .= "\n" . 'my $class = shift;';
@@ -99,7 +101,7 @@
$source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
$source .= ";\n" . (join ";\n" => map {
- $self->_generate_slot_initializer($_)
+ $self->_generate_slot_initializer($_, $close_over)
} 0 .. (@{$self->attributes} - 1));
$source .= ";\n" . 'return $instance';
$source .= ";\n" . '}';
@@ -110,9 +112,11 @@
# NOTE:
# create the nessecary lexicals
# to be picked up in the eval
- my $attrs = $self->attributes;
- $code = eval $source;
+ $code = $self->_eval_closure(
+ $close_over,
+ $source
+ );
confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
}
return $code;
@@ -121,6 +125,7 @@
sub _generate_slot_initializer {
my $self = shift;
my $index = shift;
+ my $close = shift;
my $attr = $self->attributes->[$index];
@@ -133,7 +138,9 @@
# in which case we can just deal with them
# in the code we eval.
if ($attr->is_default_a_coderef) {
- $default = '$attrs->[' . $index . ']->default($instance)';
+ my $idx = @{$close->{'@defaults'}||=[]};
+ push(@{$close->{'@defaults'}}, $attr->default);
+ $default = '$defaults[' . $idx . ']->($instance)';
}
else {
$default = $attr->default;
Modified: Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm
===================================================================
--- Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm 2009-01-17 22:36:34 UTC (rev 7322)
+++ Class-MOP/trunk/lib/Class/MOP/Method/Generated.pm 2009-01-17 22:59:55 UTC (rev 7323)
@@ -26,8 +26,41 @@
return $self;
}
+sub _new {
+ my $class = shift;
+ my $options = @_ == 1 ? $_[0] : {@_};
-sub _prepare_code {
+ $options->{is_inline} ||= 0;
+ $options->{body} ||= undef;
+
+ bless $options, $class;
+}
+
+## accessors
+
+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";
+}
+
+sub _eval_closure {
+ # my ($self, $captures, $sub_body) = @_;
+ my $__captures = $_[1];
+ eval join(
+ "\n",
+ (map {
+ /^([\@\%\$])/
+ or die "capture key should start with \@, \% or \$: $_";
+ q!my !.$_.q! = !.$1.q!{$__captures->{'!.$_.q!'}};!;
+ } keys %$__captures),
+ $_[2]
+ );
+}
+
+sub _add_line_directive {
my ( $self, %args ) = @_;
my ( $line, $file );
@@ -52,27 +85,14 @@
return qq{#line $line "$file"\n} . $code;
}
-sub _new {
- my $class = shift;
- my $options = @_ == 1 ? $_[0] : {@_};
+sub _compile_code {
+ my ( $self, %args ) = @_;
- $options->{is_inline} ||= 0;
- $options->{body} ||= undef;
+ my $code = $self->_add_line_directive(%args);
- bless $options, $class;
+ $self->_eval_closure($args{environment}, $code);
}
-## accessors
-
-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__
More information about the Moose-commits
mailing list