use strict;
use warnings;
+use Class::MOP::Method::Constructor;
+
use Carp 'confess';
-use Scalar::Util 'blessed', 'looks_like_number';
+use Scalar::Util 'blessed';
-our $VERSION = '0.01';
+our $VERSION = '0.03';
+our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Class';
-# methods which can *not* be called
-
-sub add_method { confess 'Cannot call method "add_method" on an immutable instance' }
-sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' }
-sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' }
+# enforce the meta-circularity here
+# and hide the Immutable part
+
+sub meta {
+ my $self = shift;
+ # if it is not blessed, then someone is asking
+ # for the meta of Class::MOP::Class::Immutable
+ return Class::MOP::Class->initialize($self) unless blessed($self);
+ # otherwise, they are asking for the metaclass
+ # which has been made immutable, which is itself
+ return $self;
+}
-sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' }
-sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' }
+# methods which can *not* be called
+for my $meth (qw(
+ add_method
+ alias_method
+ remove_method
+ add_attribute
+ remove_attribute
+ add_package_symbol
+ remove_package_symbol
+)) {
+ no strict 'refs';
+ *{$meth} = sub {
+ confess "Cannot call method '$meth' on an immutable instance";
+ };
+}
-sub add_package_symbol { confess 'Cannot call method "add_package_symbol" on an immutable instance' }
-sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" on an immutable instance' }
+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
sub superclasses {
my $class = shift;
(!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
- no strict 'refs';
- @{$class->name . '::ISA'};
+ @{$class->get_package_symbol('@ISA')};
}
# predicates
if ($options{inline_accessors}) {
foreach my $attr_name ($metaclass->get_attribute_list) {
- my $attr = $metaclass->get_attribute($attr_name);
- $attr->install_accessors(1); # inline the accessors
+ # inline the accessors
+ $metaclass->get_attribute($attr_name)
+ ->install_accessors(1);
}
}
if ($options{inline_constructor}) {
+ my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
$metaclass->add_method(
$options{constructor_name},
- $class->_generate_inline_constructor(
- \%options,
- $meta_instance,
- $metaclass->{'___compute_all_applicable_attributes'}
- )
+ $constructor_class->new(
+ options => \%options,
+ meta_instance => $meta_instance,
+ attributes => $metaclass->{'___compute_all_applicable_attributes'}
+ )
);
}
+
+ # now cache the 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) {
- if ($attr->is_default_a_coderef) {
- $default = '$attrs->[' . $index . ']->default($instance)';
- }
- else {
- $default = $attrs->[$index]->default;
- unless (looks_like_number($default)) {
- $default = "'$default'";
- }
- # TODO:
- # we should use Data::Dumper to
- # output any ref's here, obviously
- # we cannot handle Scalar refs, but
- # it should work for Array and Hash
- # refs pretty well.
- }
- }
- $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)->{'___method_map'} }
1;
=item B<remove_package_symbol>
+=back
+
+=head2 Methods which work slightly differently.
+
+=over 4
+
=item B<superclasses>
+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
=item B<get_meta_instance>
+=item B<get_method_map>
+
=back
=head1 AUTHORS
projects / gitmo/Class-MOP.git / blobdiff