- clean up bootstrapping to include the accessors, etc for attributes
-(PARTIALLY DONE) - could use some tests
+(DONE)
Having all this meta-info is useful actually, so why not add it, and
let the methods get overwritten if they need to be, its a small price
- clean up all ->initialize($_[0]) handling
-(PARTIALLY DONE) - needs tests
+(DONE)
We should always be sure that $_[0] is a package name, and not
a blessed intstance.
- General Purpose &new_object and &clone_object method
-(PARTIALLY DONE) - needs tests
+(PARTIALLY DONE) - needs more tests
I seem to be writing a new method each time, but since we dont
have a Object class to always inherit from, this is needed.
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
=head1 DESCRIPTION
use strict;
use warnings;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
use base 'Class::MOP::Class';
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
package Bar;
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
- }
+ $class->meta->new_object(@_);
+ }
# now you can just use the class as normal
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
# ... meanwhile, somewhere in the code
default => sub { BinaryTree->new() }
));
- sub new {
+ sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
# ... later in code
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
=head1 DESCRIPTION
(defined $name && $name)
|| confess "You must provide a name for the attribute";
- (!exists $options{reader} && !exists $options{writer})
- || confess "You cannot declare an accessor and reader and/or writer functions"
- if exists $options{accessor};
- $options{init_arg} = $name if not exists $options{init_arg};
+ $options{init_arg} = $name
+ if not exists $options{init_arg};
- bless $class->meta->construct_instance(name => $name, %options) => blessed($class) || $class;
+ # return the new object
+ $class->meta->new_object(name => $name, %options);
+});
+
+Class::MOP::Attribute->meta->add_method('clone' => sub {
+ my $self = shift;
+ $self->meta->clone_object($self, @_);
});
1;
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
-our $VERSION = '0.02';
+our $VERSION = '0.03';
sub meta {
require Class::MOP::Class;
(defined $name && $name)
|| confess "You must provide a name for the attribute";
- (!exists $options{reader} && !exists $options{writer})
- || confess "You cannot declare an accessor and reader and/or writer functions"
- if exists $options{accessor};
-
- $options{init_arg} = $name if not exists $options{init_arg};
+ $options{init_arg} = $name
+ if not exists $options{init_arg};
bless {
name => $name,
}
# NOTE:
+# this is a primative (and kludgy) clone operation
+# for now, it will be repleace in the Class::MOP
+# bootstrap with a proper one, however we know
+# that this one will work fine for now.
+sub clone {
+ my $self = shift;
+ my %options = @_;
+ (blessed($self))
+ || confess "Can only clone an instance";
+ return bless { %{$self}, %options } => blessed($self);
+}
+
+# NOTE:
# the next bunch of methods will get bootstrapped
# away in the Class::MOP bootstrapping section
C<%options> are contained added as key-value pairs. Acceptable keys
are as follows:
+=item B<clone (%options)>
+
=over 4
=item I<init_arg>
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
+use Hash::Util 'lock_keys';
use Sub::Name 'subname';
use B 'svref_2object';
bless $class->clone_instance($instance, @_) => blessed($instance);
}
+#{
+# sub _deep_clone {
+# my ($object, $cache) = @_;
+# return $object unless ref($object);
+# # check for an active cache
+# return _deep_clone_ref($object, ($cache = {}), 'HASH') if not defined $cache;
+# # if we have it in the cache them return the cached clone
+# return $cache->{$object} if exists $cache->{$object};
+# # now try it as an object, which will in
+# # turn try it as ref if its not an object
+# # and store it in case we run into a circular ref
+# $cache->{$object} = _deep_clone_object($object, $cache);
+# }
+#
+# sub _deep_clone_object {
+# my ($object, $cache) = @_;
+# # check to see if its an object, with a clone method
+# # or if we have an object, with no clone method, then
+# # we will respect its encapsulation, and not muck with
+# # its internals. Basically, we assume it does not want
+# # to be cloned
+# return $cache->{$object} = ($object->can('clone') ? $object->clone() : $object)
+# if blessed($object);
+# return $cache->{$object} = _deep_clone_ref($object, $cache);
+# }
+#
+# sub _deep_clone_ref {
+# my ($object, $cache, $ref_type) = @_;
+# $ref_type ||= ref($object);
+# my ($clone, $tied);
+# if ($ref_type eq 'HASH') {
+# $clone = {};
+# tie %{$clone}, ref $tied if $tied = tied(%{$object});
+# %{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } %{$object};
+# }
+# elsif ($ref_type eq 'ARRAY') {
+# $clone = [];
+# tie @{$clone}, ref $tied if $tied = tied(@{$object});
+# @{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } @{$object};
+# }
+# elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
+# my $var = "";
+# $clone = \$var;
+# tie ${$clone}, ref $tied if $tied = tied(${$object});
+# ${$clone} = _deep_clone(${$object}, $cache);
+# }
+# else {
+# # shallow copy reference to code, glob, regex
+# $clone = $object;
+# }
+# # store it in our cache
+# $cache->{$object} = $clone;
+# # and return the clone
+# return $clone;
+# }
+#}
+
sub clone_instance {
my ($class, $instance, %params) = @_;
(blessed($instance))
# instead of this cheap hack. I will
# add that in later.
# (use the Class::Cloneable::Util code)
- my $clone = { %{$instance} };
+ my $clone = { %{$instance} }; #_deep_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 ...
use strict;
use warnings;
-use Test::More tests => 29;
+use Test::More tests => 32;
use Test::Exception;
BEGIN {
isa_ok($bar, 'Bar');
isa_ok($bar, 'Foo');
+my $baz = $baz_meta->new_object();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
my $cloned_foo = $foo_meta->clone_object($foo);
isa_ok($cloned_foo, 'Foo');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 38;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ my $meta = Class::MOP::Attribute->meta();
+ isa_ok($meta, 'Class::MOP::Class');
+
+ my @methods = qw(
+ meta
+ new clone
+ name
+ has_accessor accessor
+ has_writer writer
+ has_reader reader
+ has_predicate predicate
+ has_init_arg init_arg
+ has_default default
+
+ associated_class
+ attach_to_class detach_from_class
+
+ generate_accessor_method
+ generate_reader_method
+ generate_writer_method
+ generate_predicate_method
+
+ process_accessors
+ install_accessors
+ remove_accessors
+ );
+
+ is_deeply(
+ [ sort @methods ],
+ [ sort $meta->get_method_list ],
+ '... our method list matches');
+
+ foreach my $method_name (@methods) {
+ ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
+ }
+
+ my @attributes = qw(
+ name accessor reader writer predicate
+ init_arg default associated_class
+ );
+
+ is_deeply(
+ [ sort @attributes ],
+ [ sort $meta->get_attribute_list ],
+ '... our attribute list matches');
+
+ foreach my $attribute_name (@attributes) {
+ ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');
+ }
+
+ # We could add some tests here to make sure that
+ # the attribute have the appropriate
+ # accessor/reader/writer/predicate combinations,
+ # but that is getting a little excessive so I
+ # wont worry about it for now. Maybe if I get
+ # bored I will do it.
+}
\ No newline at end of file
use strict;
use warnings;
-use Test::More tests => 65;
+use Test::More tests => 62;
use Test::Exception;
BEGIN {
ok(!$attr->has_accessor, '... $attr does not have an accessor');
ok(!$attr->has_reader, '... $attr does not have an reader');
ok(!$attr->has_writer, '... $attr does not have an writer');
- ok(!$attr->has_default, '... $attr does not have an default');
+ ok(!$attr->has_default, '... $attr does not have an default');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
ok(!$attr->has_accessor, '... $attr does not have an accessor');
ok(!$attr->has_reader, '... $attr does not have an reader');
- ok(!$attr->has_writer, '... $attr does not have an writer');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
is($attr->accessor, 'foo', '... $attr->accessor == foo');
ok(!$attr->has_reader, '... $attr does not have an reader');
- ok(!$attr->has_writer, '... $attr does not have an writer');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instnaces');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
{
ok($attr->has_writer, '... $attr does have an writer');
is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
- ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instnaces');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
}
-dies_ok {
+# NOTE:
+# the next three tests once tested that
+# the code would fail, but we lifted the
+# restriction so you can have an accessor
+# along with a reader/writer pair (I mean
+# why not really). So now they test that
+# it works, which is kinda silly, but it
+# tests the API change, so I keep it.
+
+lives_ok {
Class::MOP::Attribute->new('$foo', (
accessor => 'foo',
reader => 'get_foo',
));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
-dies_ok {
+lives_ok {
Class::MOP::Attribute->new('$foo', (
accessor => 'foo',
writer => 'set_foo',
));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
-dies_ok {
+lives_ok {
Class::MOP::Attribute->new('$foo', (
accessor => 'foo',
reader => 'get_foo',
writer => 'set_foo',
));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
dies_ok {
Class::MOP::Attribute->new();
dies_ok {
Class::MOP::Attribute->remove_accessors(bless {} => 'Fail');
} '... bad remove_accessors argument';
-
-
-{
- my $meta = Class::MOP::Attribute->meta();
- isa_ok($meta, 'Class::MOP::Class');
-
- foreach my $method_name (qw(
- meta
- new
- has_accessor accessor
- has_writer writer
- has_reader reader
- has_init_arg init_arg
- has_default default
- install_accessors
- remove_accessors
- )) {
- ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
- }
-
-
-}
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
package Bar;
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
}
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
- }
+ $class->meta->new_object(@_);
+ }
}
my $foo = Foo->new();
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
- }
+ $class->meta->new_object(@_);
+ }
}
my $foo = Foo->new();
sub new {
my $class = shift;
- bless $class->meta->construct_instance(@_) => $class;
+ $class->meta->new_object(@_);
}
package Bar;
projects / gitmo/Class-MOP.git / commitdiff