From: Stevan Little Date: Mon, 6 Feb 2006 01:52:08 +0000 (+0000) Subject: cleaned up the class_construct_instance handleing so that it works like construct... X-Git-Tag: 0_06~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=651955fb509042e19195fe9c926a84c4e8b8bfe1;p=gitmo%2FClass-MOP.git cleaned up the class_construct_instance handleing so that it works like construct instance does --- diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod index 9b6d9bf..6087196 100644 --- a/examples/ClassEncapsulatedAttributes.pod +++ b/examples/ClassEncapsulatedAttributes.pod @@ -27,7 +27,7 @@ sub construct_instance { my $attr = $meta->get_attribute($attr_name); # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + my $init_arg = $attr->init_arg(); # try to fetch the init arg from the %params ... my $val; $val = $params{$current_class}->{$init_arg} diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 5ea7e78..d82cd03 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -19,7 +19,7 @@ sub construct_instance { foreach my $attr ($class->compute_all_applicable_attributes()) { # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + my $init_arg = $attr->init_arg(); # try to fetch the init arg from the %params ... my $val; $val = $params{$init_arg} if exists $params{$init_arg}; diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index cb678b1..e3c0b42 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -15,7 +15,7 @@ sub construct_instance { foreach my $attr ($class->compute_all_applicable_attributes()) { # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + my $init_arg = $attr->init_arg(); # try to fetch the init arg from the %params ... my $val; $val = $params{$init_arg} if exists $params{$init_arg}; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 255b868..f40f794 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -151,7 +151,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { || 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}; - + bless $class->meta->construct_instance(name => $name, %options) => blessed($class) || $class; }); diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 1634c8c..529b4f6 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -22,7 +22,8 @@ sub meta { Class::MOP::Class->initialize($_[0]) } # there is no need to worry about destruction though # because they should die only when the program dies. # After all, do package definitions even get reaped? - my %METAS; + my %METAS; + sub initialize { my $class = shift; my $package_name = shift; @@ -30,8 +31,7 @@ sub meta { Class::MOP::Class->initialize($_[0]) } || confess "You must pass a package name"; # make sure the package name is not blessed $package_name = blessed($package_name) || $package_name; - return $METAS{$package_name} if exists $METAS{$package_name}; - $METAS{$package_name} = $class->construct_class_instance($package_name, @_); + $class->construct_class_instance(':package' => $package_name, @_); } # NOTE: (meta-circularity) @@ -42,12 +42,14 @@ sub meta { Class::MOP::Class->initialize($_[0]) } # normal &construct_instance. sub construct_class_instance { my $class = shift; - my $package_name = shift; + my %options = @_; + my $package_name = $options{':package'}; (defined $package_name && $package_name) - || confess "You must pass a package name"; + || confess "You must pass a package name"; + return $METAS{$package_name} if exists $METAS{$package_name}; $class = blessed($class) || $class; if ($class =~ /^Class::MOP::/) { - bless { + $METAS{$package_name} = bless { '$:package' => $package_name, '%:attributes' => {}, '$:attribute_metaclass' => 'Class::MOP::Attribute', @@ -59,7 +61,7 @@ sub meta { Class::MOP::Class->initialize($_[0]) } # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta - bless $class->meta->construct_instance(':package' => $package_name, @_) => $class + $METAS{$package_name} = bless $class->meta->construct_instance(%options) => $class } } } @@ -109,6 +111,13 @@ sub method_metaclass { $_[0]->{'$:method_metaclass'} } sub new_object { my $class = shift; + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, so we + # delegate this to &construct_class_instance + # which will deal with the singletons + return $class->construct_class_instance(@_) + if $class->name->isa('Class::MOP::Class'); bless $class->construct_instance(@_) => $class->name; } @@ -116,7 +125,7 @@ sub construct_instance { my ($class, %params) = @_; my $instance = {}; foreach my $attr ($class->compute_all_applicable_attributes()) { - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + my $init_arg = $attr->init_arg(); # try to fetch the init arg from the %params ... my $val; $val = $params{$init_arg} if exists $params{$init_arg}; @@ -131,21 +140,28 @@ sub construct_instance { sub clone_object { my $class = shift; my $instance = shift; - bless $class->clone_instance($instance, @_) => $class->name; + (blessed($instance) && $instance->isa($class->name)) + || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")"; + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, they + # should not be cloned + return $instance if $instance->isa('Class::MOP::Class'); + bless $class->clone_instance($instance, @_) => blessed($instance); } sub clone_instance { - my ($class, $self, %params) = @_; - (blessed($self)) + my ($class, $instance, %params) = @_; + (blessed($instance)) || confess "You can only clone instances, \$self is not a blessed instance"; # NOTE: # this should actually do a deep clone # instead of this cheap hack. I will # add that in later. # (use the Class::Cloneable::Util code) - my $clone = { %{$self} }; + my $clone = { %{$instance} }; foreach my $attr ($class->compute_all_applicable_attributes()) { - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + 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}; @@ -530,7 +546,7 @@ to it. This initializes and returns returns a B object for a given a C<$package_name>. -=item B +=item B This will construct an instance of B, it is here so that we can actually "tie the knot" for B