use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
-use B 'svref_2object';
-use Clone ();
-our $VERSION = '0.03';
+our $VERSION = '0.06';
# Self-introspection
sub initialize {
my $class = shift;
my $package_name = shift;
- (defined $package_name && $package_name)
- || confess "You must pass a package name";
- # make sure the package name is not blessed
- $package_name = blessed($package_name) || $package_name;
+ (defined $package_name && $package_name && !blessed($package_name))
+ || confess "You must pass a package name and it cannot be blessed";
$class->construct_class_instance(':package' => $package_name, @_);
}
shift @class_list; # shift off $self->name
foreach my $class_name (@class_list) {
- next unless $METAS{$class_name};
my $meta = $METAS{$class_name};
($self->isa(blessed($meta)))
|| confess $self->name . "->meta => (" . (blessed($self)) . ")" .
my ($class, $instance, %params) = @_;
(blessed($instance))
|| confess "You can only clone instances, \$self is not a blessed instance";
- # NOTE:
- # This will deep clone, which might
- # not be what you always want. So
- # the best thing is to write a more
- # controled &clone method locally
- # in the class (see Class::MOP)
- my $clone = Clone::clone($instance);
- foreach my $attr ($class->compute_all_applicable_attributes()) {
- my $init_arg = $attr->init_arg();
- # try to fetch the init arg from the %params ...
- $clone->{$attr->name} = $params{$init_arg}
- if exists $params{$init_arg};
- }
+ my $clone = { %$instance, %params };
return $clone;
}
(defined $method_name && $method_name)
|| confess "You must define a method name";
# use reftype here to allow for blessed subs ...
- (reftype($method) && reftype($method) eq 'CODE')
+ ('CODE' eq (reftype($method) || ''))
|| confess "Your code block must be a CODE reference";
my $full_method_name = ($self->name . '::' . $method_name);
-
+
+ $method = Class::MOP::Method->new($method) unless blessed($method);
+
no strict 'refs';
no warnings 'redefine';
*{$full_method_name} = subname $full_method_name => $method;
}
+sub add_method_modifier {
+
+}
+
sub alias_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
|| confess "You must define a method name";
# use reftype here to allow for blessed subs ...
- (reftype($method) && reftype($method) eq 'CODE')
+ ('CODE' eq (reftype($method) || ''))
|| confess "Your code block must be a CODE reference";
- my $full_method_name = ($self->name . '::' . $method_name);
+ my $full_method_name = ($self->name . '::' . $method_name);
+
+ $method = Class::MOP::Method->new($method) unless blessed($method);
no strict 'refs';
no warnings 'redefine';
*{$full_method_name} = $method;
}
-{
-
- ## private utility functions for has_method
- my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
- my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
+sub has_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
- sub has_method {
- my ($self, $method_name) = @_;
- (defined $method_name && $method_name)
- || confess "You must define a method name";
+ my $sub_name = ($self->name . '::' . $method_name);
- my $sub_name = ($self->name . '::' . $method_name);
-
- no strict 'refs';
- return 0 if !defined(&{$sub_name});
- return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
- $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
- return 1;
- }
-
+ no strict 'refs';
+ return 0 if !defined(&{$sub_name});
+
+ my $method = \&{$sub_name};
+ $method = Class::MOP::Method->new($method) unless blessed($method);
+
+ return 0 if $method->package_name ne $self->name &&
+ $method->name ne '__ANON__';
+ return 1;
}
sub get_method {
(defined $method_name && $method_name)
|| confess "You must define a method name";
+ return unless $self->has_method($method_name);
+
no strict 'refs';
- return \&{$self->name . '::' . $method_name}
- if $self->has_method($method_name);
- return; # <- make sure to return undef
+ return \&{$self->name . '::' . $method_name};
}
sub remove_method {
} if $meta->has_method($method_name);
}
return @methods;
-
}
## Attributes
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
return $self->get_attribute_map->{$attribute_name}
- if $self->has_attribute($attribute_name);
+ if $self->has_attribute($attribute_name);
+ return;
}
sub remove_attribute {
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
my $removed_attribute = $self->get_attribute_map->{$attribute_name};
- delete $self->get_attribute_map->{$attribute_name}
- if defined $removed_attribute;
+ return unless defined $removed_attribute;
+ delete $self->get_attribute_map->{$attribute_name};
$removed_attribute->remove_accessors();
$removed_attribute->detach_from_class();
return $removed_attribute;
my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
no strict 'refs';
# try to fetch it first,.. see what happens
- eval '\\' . $sigil . $self->name . '::' . $name;
+ my $ref = eval '\\' . $sigil . $self->name . '::' . $name;
confess "Could not get the package variable ($variable) because : $@" if $@;
# if we didn't die, then we can return it
- # NOTE:
- # this is not ideal, better suggestions are welcome
- eval '\\' . $sigil . $self->name . '::' . $name;
+ return $ref;
}
sub remove_package_variable {
delete ${$self->name . '::'}{$name};
}
-# class mixins
-
-sub mixin {
- my ($self, $mixin) = @_;
- $mixin = $self->initialize($mixin)
- unless blessed($mixin);
-
- my @attributes = map {
- $mixin->get_attribute($_)->clone()
- } $mixin->get_attribute_list;
-
- my %methods = map {
- my $method = $mixin->get_method($_);
- (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
- ? () : ($_ => $method)
- } $mixin->get_method_list;
-
- foreach my $attr (@attributes) {
- $self->add_attribute($attr)
- unless $self->has_attribute($attr->name);
- }
-
- foreach my $method_name (keys %methods) {
- $self->alias_method($method_name => $methods{$method_name})
- unless $self->has_method($method_name);
- }
-}
-
1;
__END__
=item B<clone_object ($instance, %params)>
This is a convience method for cloning an object instance, then
-blessing it into the appropriate package. Ideally your class
-would call a C<clone> this method like so:
+blessing it into the appropriate package. This method will call
+C<clone_instance>, which performs a shallow copy of the object,
+see that methods documentation for more details. Ideally your
+class would call a C<clone> this method like so:
sub MyClass::clone {
my ($self, %param) = @_;
=item B<clone_instance($instance, %params)>
This method is a compliment of C<construct_instance> (which means if
-you override C<construct_instance>, you need to override this one too).
+you override C<construct_instance>, you need to override this one too),
+and clones the instance shallowly.
-This method will clone the C<$instance> structure created by the
-C<construct_instance> method, and apply any C<%params> passed to it
-to change the attribute values. The structure returned is (like with
-C<construct_instance>) an unC<bless>ed HASH reference, it is your
-responsibility to then bless this cloned structure into the right
-class.
+The cloned structure returned is (like with C<construct_instance>) an
+unC<bless>ed HASH reference, it is your responsibility to then bless
+this cloned structure into the right class (which C<clone_object> will
+do for you).
+
+As of 0.11, this method will clone the C<$instance> structure shallowly,
+as opposed to the deep cloning implemented in prior versions. After much
+thought, research and discussion, I have decided that anything but basic
+shallow cloning is outside the scope of the meta-object protocol. I
+think Yuval "nothingmuch" Kogman put it best when he said that cloning
+is too I<context-specific> to be part of the MOP.
=back
correct name, and therefore show up correctly in stack traces and
such.
+=item B<add_method_modifier ($modifier_type, $code)>
+
=item B<alias_method ($method_name, $method)>
This will take a C<$method_name> and CODE reference to that
projects / gitmo/Class-MOP.git / blobdiff