sub initialize {
my ($class, $package_name) = @_;
(defined $package_name && $package_name)
- || confess "You must pass a package name";
- $METAS{$package_name} ||= bless {
- '$:pkg' => $package_name,
- '%:attrs' => {}
- } => blessed($class) || $class;
+ || confess "You must pass a package name";
+ return $METAS{$package_name} if exists $METAS{$package_name};
+ $METAS{$package_name} = $class->construct_class_instance($package_name);
+ }
+
+ # NOTE: (meta-circularity)
+ # this is a special form of &construct_instance
+ # (see below), which is used to construct class
+ # meta-object instances for any Class::MOP::*
+ # class. All other classes will use the more
+ # normal &construct_instance.
+ sub construct_class_instance {
+ my ($class, $package_name) = @_;
+ (defined $package_name && $package_name)
+ || confess "You must pass a package name";
+ $class = blessed($class) || $class;
+ if ($class =~ /^Class::MOP::/) {
+ bless {
+ '$:pkg' => $package_name,
+ '%:attrs' => {}
+ } => $class;
+ }
+ else {
+ bless $class->meta->construct_instance(':pkg' => $package_name) => $class
+ }
}
}
# can then overwrite them. It is maybe a little odd, but
# I think this should be the order of things.
if (exists $options{attributes}) {
- foreach my $attr_name (keys %{$options{attributes}}) {
- $meta->add_attribute($attr_name, $options{attributes}->{$attr_name});
+ foreach my $attr (@{$options{attributes}}) {
+ $meta->add_attribute($attr);
}
}
if (exists $options{methods}) {
# Instance Construction
sub construct_instance {
- my ($canidate, %params) = @_;
- # ...
+ my ($class, %params) = @_;
+ my $instance = {};
+ foreach my $attr (map { $_->{attribute} } $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;
+ # try to fetch the init arg from the %params ...
+ my $val;
+ $val = $params{$init_arg} if exists $params{$init_arg};
+ # if nothing was in the %params, we can use the
+ # attribute's default value (if it has one)
+ $val ||= $attr->default($instance) if $attr->has_default();
+ # now add this to the instance structure
+ $instance->{$attr->name} = $val;
+ }
+ return $instance;
}
# Informational
return @attrs;
}
+# Class attributes
+
+sub add_package_variable {
+ my ($self, $variable, $initial_value) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ if (defined $initial_value) {
+ no strict 'refs';
+ *{$self->name . '::' . $name} = $initial_value;
+ }
+ else {
+ eval $sigil . $self->name . '::' . $name;
+ confess "Could not create package variable ($variable) because : $@" if $@;
+ }
+}
+
+sub has_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ no strict 'refs';
+ defined ${$self->name . '::'}{$name} ? 1 : 0;
+}
+
+sub get_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ no strict 'refs';
+ # try to fetch it first,.. see what happens
+ 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;
+}
+
+sub remove_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ no strict 'refs';
+ delete ${$self->name . '::'}{$name};
+}
1;
=head1 SYNOPSIS
+ # use this for introspection ...
+
+ package Foo;
+ sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
+
+ # elsewhere in the code ...
+
+ # add a method to Foo ...
+ Foo->meta->add_method('bar' => sub { ... })
+
+ # get a list of all the classes searched
+ # the method dispatcher in the correct order
+ Foo->meta->class_precedence_list()
+
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
+
+ # or use this to actually create classes ...
+
+ Class::MOP::Class->create('Bar' => '0.01' => (
+ superclasses => [ 'Foo' ],
+ attributes => [
+ Class::MOP:::Attribute->new('$bar'),
+ Class::MOP:::Attribute->new('$baz'),
+ ],
+ methods => {
+ calculate_bar => sub { ... },
+ construct_baz => sub { ... }
+ }
+ ));
+
=head1 DESCRIPTION
+This is the largest and currently most complex part of the Perl 5
+meta-object protocol. It controls the introspection and
+manipulation of Perl 5 classes (and it can create them too). The
+best way to understand what this module can do, is to read the
+documentation for each of it's methods.
+
=head1 METHODS
=head2 Self Introspection
=item B<meta>
-This allows Class::MOP::Class to actually introspect itself.
+This will return a B<Class::MOP::Class> instance which is related
+to this class. Thereby allowing B<Class::MOP::Class> to actually
+introspect itself.
+
+As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
+bootstrap this module by installing a number of attribute meta-objects
+into it's metaclass. This will allow this class to reap all the benifits
+of the MOP when subclassing it.
=back
=over 4
-=item B<construct_instance ($canidate, %params)>
+=item B<construct_instance (%params)>
-This will construct and instance using the C<$canidate> as storage
+This will construct and instance using a HASH ref as storage
(currently only HASH references are supported). This will collect all
the applicable attribute meta-objects and layout out the fields in the
-C<$canidate>, it will then initialize them using either use the
+HASH ref, it will then initialize them using either use the
corresponding key in C<%params> or any default value or initializer
found in the attribute meta-object.
+=item B<construct_class_instance ($package_name)>
+
+This will construct an instance of B<Class::MOP::Class>, it is
+here so that we can actually "tie the knot" for B<Class::MOP::Class>
+to use C<construct_instance> once all the bootstrapping is done. This
+method is used internally by C<initialize> and should never be called
+from outside of that method really.
+
=back
=head2 Informational
=back
+=head2 Package Variables
+
+Since Perl's classes are built atop the Perl package system, it is
+fairly common to use package scoped variables for things like static
+class variables. The following methods are convience methods for
+the creation and inspection of package scoped variables.
+
+=over 4
+
+=item B<add_package_variable ($variable_name, ?$initial_value)>
+
+Given a C<$variable_name>, which must contain a leading sigil, this
+method will create that variable within the package which houses the
+class. It also takes an optional C<$initial_value>, which must be a
+reference of the same type as the sigil of the C<$variable_name>
+implies.
+
+=item B<get_package_variable ($variable_name)>
+
+This will return a reference to the package variable in
+C<$variable_name>.
+
+=item B<has_package_variable ($variable_name)>
+
+Returns true (C<1>) if there is a package variable defined for
+C<$variable_name>, and false (C<0>) otherwise.
+
+=item B<remove_package_variable ($variable_name)>
+
+This will attempt to remove the package variable at C<$variable_name>.
+
+=back
+
=head1 AUTHOR
Stevan Little E<gt>stevan@iinteractive.comE<lt>
projects / gitmo/Class-MOP.git / blobdiff