Permalink
Browse files

testing

  • Loading branch information...
1 parent d7290c9 commit fdbdb5e6eb0e4f6c54629f0bde376aba5e69df14 Stevan Little committed Nov 2, 2006
View
@@ -373,56 +373,6 @@ Class::MOP::Method::Wrapped->meta->add_attribute(
);
## --------------------------------------------------------
-## Class::MOP::Method::Accessor
-
-Class::MOP::Method::Accessor->meta->add_attribute(
- Class::MOP::Attribute->new('attribute' => (
- reader => {
- 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
- },
- ))
-);
-
-Class::MOP::Method::Accessor->meta->add_attribute(
- Class::MOP::Attribute->new('accessor_type' => (
- reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
- ))
-);
-
-Class::MOP::Method::Accessor->meta->add_attribute(
- Class::MOP::Attribute->new('is_inline' => (
- reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline },
- ))
-);
-
-## --------------------------------------------------------
-## Class::MOP::Method::Constructor
-
-Class::MOP::Method::Constructor->meta->add_attribute(
- Class::MOP::Attribute->new('options' => (
- reader => {
- 'options' => \&Class::MOP::Method::Constructor::options
- },
- ))
-);
-
-Class::MOP::Method::Constructor->meta->add_attribute(
- Class::MOP::Attribute->new('meta_instance' => (
- reader => {
- 'meta_instance' => \&Class::MOP::Method::Constructor::meta_instance
- },
- ))
-);
-
-Class::MOP::Method::Constructor->meta->add_attribute(
- Class::MOP::Attribute->new('attributes' => (
- reader => {
- 'attributes' => \&Class::MOP::Method::Constructor::attributes
- },
- ))
-);
-
-## --------------------------------------------------------
## Class::MOP::Instance
# NOTE:
@@ -462,8 +412,7 @@ $_->meta->make_immutable(
Class::MOP::Object
Class::MOP::Method::Accessor
- Class::MOP::Method::Constructor
- Class::MOP::Method::Wrapped
+ Class::MOP::Method::Wrapped
/;
1;
@@ -211,7 +211,7 @@ sub process_accessors {
eval {
$method = $self->accessor_metaclass->new(
attribute => $self,
- is_inline => $inline_me,
+ as_inline => $inline_me,
accessor_type => $type,
);
};
View
@@ -70,6 +70,7 @@ sub construct_class_instance {
: blessed($class))
: $class);
+ $class = blessed($class) || $class;
# now create the metaclass
my $meta;
if ($class =~ /^Class::MOP::Class$/) {
@@ -4,10 +4,8 @@ package Class::MOP::Class::Immutable;
use strict;
use warnings;
-use Class::MOP::Method::Constructor;
-
use Carp 'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util 'blessed', 'looks_like_number';
our $VERSION = '0.03';
our $AUTHORITY = 'cpan:STEVAN';
@@ -43,6 +41,19 @@ for my $meth (qw(
};
}
+sub get_package_symbol {
+ my ($self, $variable) = @_;
+ my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
+ return *{$self->namespace->{$name}}{$type}
+ if exists $self->namespace->{$name};
+ # NOTE:
+ # we have to do this here in order to preserve
+ # perl's autovivification of variables. However
+ # we do cut off direct access to add_package_symbol
+ # as shown above.
+ $self->Class::MOP::Package::add_package_symbol($variable);
+}
+
# NOTE:
# superclasses is an accessor, so
# it just cannot be changed
@@ -77,37 +88,87 @@ sub make_metaclass_immutable {
if ($options{inline_accessors}) {
foreach my $attr_name ($metaclass->get_attribute_list) {
- # inline the accessors
- $metaclass->get_attribute($attr_name)
- ->install_accessors(1);
+ my $attr = $metaclass->get_attribute($attr_name);
+ $attr->install_accessors(1); # inline the accessors
}
}
if ($options{inline_constructor}) {
- my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
$metaclass->add_method(
$options{constructor_name},
- $constructor_class->new(
- options => \%options,
- meta_instance => $meta_instance,
- attributes => $metaclass->{'___compute_all_applicable_attributes'}
- )
+ $class->_generate_inline_constructor(
+ \%options,
+ $meta_instance,
+ $metaclass->{'___compute_all_applicable_attributes'}
+ )
);
}
# now cache the method map ...
- $metaclass->{'___get_method_map'} = $metaclass->get_method_map;
+ $metaclass->{'___method_map'} = $metaclass->get_method_map;
bless $metaclass => $class;
}
+sub _generate_inline_constructor {
+ my ($class, $options, $meta_instance, $attrs) = @_;
+ # TODO:
+ # the %options should also include a both
+ # a call 'initializer' and call 'SUPER::'
+ # options, which should cover approx 90%
+ # of the possible use cases (even if it
+ # requires some adaption on the part of
+ # the author, after all, nothing is free)
+ my $source = 'sub {';
+ $source .= "\n" . 'my ($class, %params) = @_;';
+ $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
+ $source .= ";\n" . (join ";\n" => map {
+ $class->_generate_slot_initializer($meta_instance, $attrs, $_)
+ } 0 .. (@$attrs - 1));
+ $source .= ";\n" . 'return $instance';
+ $source .= ";\n" . '}';
+ warn $source if $options->{debug};
+ my $code = eval $source;
+ confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
+ return $code;
+}
+
+sub _generate_slot_initializer {
+ my ($class, $meta_instance, $attrs, $index) = @_;
+ my $attr = $attrs->[$index];
+ my $default;
+ if ($attr->has_default) {
+ # NOTE:
+ # default values can either be CODE refs
+ # in which case we need to call them. Or
+ # they can be scalars (strings/numbers)
+ # 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)';
+ }
+ else {
+ $default = $attrs->[$index]->default;
+ # make sure to quote strings ...
+ unless (looks_like_number($default)) {
+ $default = "'$default'";
+ }
+ }
+ }
+ $meta_instance->inline_set_slot_value(
+ '$instance',
+ ("'" . $attr->name . "'"),
+ ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
+ )
+}
+
# cached methods
sub get_meta_instance { (shift)->{'___get_meta_instance'} }
sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
-sub get_method_map { (shift)->{'___get_method_map'} }
+sub get_method_map { (shift)->{'___method_map'} }
1;
@@ -228,6 +289,11 @@ to this method, which
This method becomes read-only in an immutable class.
+=item B<get_package_symbol>
+
+This method must handle package variable autovivification
+correctly, while still disallowing C<add_package_symbol>.
+
=back
=head2 Cached methods
@@ -30,7 +30,7 @@ sub new {
body => undef,
# specific to this subclass
attribute => $options{attribute},
- is_inline => ($options{is_inline} || 0),
+ as_inline => ($options{as_inline} || 0),
accessor_type => $options{accessor_type},
} => $class;
@@ -48,7 +48,7 @@ sub new {
sub associated_attribute { (shift)->{attribute} }
sub accessor_type { (shift)->{accessor_type} }
-sub is_inline { (shift)->{is_inline} }
+sub as_inline { (shift)->{as_inline} }
## factory
@@ -59,7 +59,7 @@ sub intialize_body {
'generate',
$self->accessor_type,
'method',
- ($self->is_inline ? 'inline' : ())
+ ($self->as_inline ? 'inline' : ())
);
eval { $self->{body} = $self->$method_name() };
@@ -202,7 +202,7 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors
=item B<accessor_type>
-=item B<is_inline>
+=item B<as_inline>
=item B<associated_attribute>
@@ -232,6 +232,8 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors
Stevan Little E<lt>stevan@iinteractive.comE<gt>
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
=head1 COPYRIGHT AND LICENSE
Copyright 2006 by Infinity Interactive, Inc.
Oops, something went wrong.

0 comments on commit fdbdb5e

Please sign in to comment.