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';
};
}
+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
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;
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