lib/Class/MOP/Class.pm

   1
   2 package Class::MOP::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'reftype';
   9 use Sub::Name    'subname';
  10 use B            'svref_2object';
  11 use Clone         ();
  12
  13 our $VERSION = '0.04';
  14
  15 # Self-introspection
  16
  17 sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
  18
  19 # Creation
  20
  21 {
  22     # Metaclasses are singletons, so we cache them here.
  23     # there is no need to worry about destruction though
  24     # because they should die only when the program dies.
  25     # After all, do package definitions even get reaped?
  26     my %METAS;
  27
  28     sub initialize {
  29         my $class        = shift;
  30         my $package_name = shift;
  31         (defined $package_name && $package_name)
  32             || confess "You must pass a package name";
  33         # make sure the package name is not blessed
  34         $package_name = blessed($package_name) || $package_name;
  35         $class->construct_class_instance(':package' => $package_name, @_);
  36     }
  37
  38     # NOTE: (meta-circularity)
  39     # this is a special form of &construct_instance
  40     # (see below), which is used to construct class
  41     # meta-object instances for any Class::MOP::*
  42     # class. All other classes will use the more
  43     # normal &construct_instance.
  44     sub construct_class_instance {
  45         my $class        = shift;
  46         my %options      = @_;
  47         my $package_name = $options{':package'};
  48         (defined $package_name && $package_name)
  49             || confess "You must pass a package name";
  50         return $METAS{$package_name} if exists $METAS{$package_name};
  51         $class = blessed($class) || $class;
  52         # now create the metaclass
  53         my $meta;
  54         if ($class =~ /^Class::MOP::/) {
  55             $meta = bless {
  56                 '$:package'             => $package_name,
  57                 '%:attributes'          => {},
  58                 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
  59                 '$:method_metaclass'    => $options{':method_metaclass'}    || 'Class::MOP::Method',
  60             } => $class;
  61         }
  62         else {
  63             # NOTE:
  64             # it is safe to use meta here because
  65             # class will always be a subclass of
  66             # Class::MOP::Class, which defines meta
  67             $meta = bless $class->meta->construct_instance(%options) => $class
  68         }
  69         # and check the metaclass compatibility
  70         $meta->check_metaclass_compatability();
  71         $METAS{$package_name} = $meta;
  72     }
  73
  74     sub check_metaclass_compatability {
  75         my $self = shift;
  76
  77         # this is always okay ...
  78         return if blessed($self) eq 'Class::MOP::Class';
  79
  80         my @class_list = $self->class_precedence_list;
  81         shift @class_list; # shift off $self->name
  82
  83         foreach my $class_name (@class_list) {
  84             my $meta = $METAS{$class_name};
  85             ($self->isa(blessed($meta)))
  86                 || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
  87                            " is not compatible with the " .
  88                            $class_name . "->meta => (" . (blessed($meta)) . ")";
  89         }
  90     }
  91 }
  92
  93 sub create {
  94     my ($class, $package_name, $package_version, %options) = @_;
  95     (defined $package_name && $package_name)
  96         || confess "You must pass a package name";
  97     my $code = "package $package_name;";
  98     $code .= "\$$package_name\:\:VERSION = '$package_version';"
  99         if defined $package_version;
 100     eval $code;
 101     confess "creation of $package_name failed : $@" if $@;
 102     my $meta = $class->initialize($package_name);
 103
 104     $meta->add_method('meta' => sub {
 105         Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
 106     });
 107
 108     $meta->superclasses(@{$options{superclasses}})
 109         if exists $options{superclasses};
 110     # NOTE:
 111     # process attributes first, so that they can
 112     # install accessors, but locally defined methods
 113     # can then overwrite them. It is maybe a little odd, but
 114     # I think this should be the order of things.
 115     if (exists $options{attributes}) {
 116         foreach my $attr (@{$options{attributes}}) {
 117             $meta->add_attribute($attr);
 118         }
 119     }
 120     if (exists $options{methods}) {
 121         foreach my $method_name (keys %{$options{methods}}) {
 122             $meta->add_method($method_name, $options{methods}->{$method_name});
 123         }
 124     }
 125     return $meta;
 126 }
 127
 128 ## Attribute readers
 129
 130 # NOTE:
 131 # all these attribute readers will be bootstrapped
 132 # away in the Class::MOP bootstrap section
 133
 134 sub name                { $_[0]->{'$:package'}             }
 135 sub get_attribute_map   { $_[0]->{'%:attributes'}          }
 136 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
 137 sub method_metaclass    { $_[0]->{'$:method_metaclass'}    }
 138
 139 # Instance Construction & Cloning
 140
 141 sub new_object {
 142     my $class = shift;
 143     # NOTE:
 144     # we need to protect the integrity of the
 145     # Class::MOP::Class singletons here, so we
 146     # delegate this to &construct_class_instance
 147     # which will deal with the singletons
 148     return $class->construct_class_instance(@_)
 149         if $class->name->isa('Class::MOP::Class');
 150     bless $class->construct_instance(@_) => $class->name;
 151 }
 152
 153 sub construct_instance {
 154     my ($class, %params) = @_;
 155     my $instance = {};
 156     foreach my $attr ($class->compute_all_applicable_attributes()) {
 157         my $init_arg = $attr->init_arg();
 158         # try to fetch the init arg from the %params ...
 159         my $val;
 160         $val = $params{$init_arg} if exists $params{$init_arg};
 161         # if nothing was in the %params, we can use the
 162         # attribute's default value (if it has one)
 163         $val ||= $attr->default($instance) if $attr->has_default();
 164         $instance->{$attr->name} = $val;
 165     }
 166     return $instance;
 167 }
 168
 169 sub clone_object {
 170     my $class    = shift;
 171     my $instance = shift;
 172     (blessed($instance) && $instance->isa($class->name))
 173         || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
 174     # NOTE:
 175     # we need to protect the integrity of the
 176     # Class::MOP::Class singletons here, they
 177     # should not be cloned.
 178     return $instance if $instance->isa('Class::MOP::Class');
 179     bless $class->clone_instance($instance, @_) => blessed($instance);
 180 }
 181
 182 sub clone_instance {
 183     my ($class, $instance, %params) = @_;
 184     (blessed($instance))
 185         || confess "You can only clone instances, \$self is not a blessed instance";
 186     # NOTE:
 187     # This will deep clone, which might
 188     # not be what you always want. So
 189     # the best thing is to write a more
 190     # controled &clone method locally
 191     # in the class (see Class::MOP)
 192     my $clone = Clone::clone($instance);
 193     foreach my $attr ($class->compute_all_applicable_attributes()) {
 194         my $init_arg = $attr->init_arg();
 195         # try to fetch the init arg from the %params ...
 196         $clone->{$attr->name} = $params{$init_arg}
 197             if exists $params{$init_arg};
 198     }
 199     return $clone;
 200 }
 201
 202 # Informational
 203
 204 # &name should be here too, but it is above
 205 # because it gets bootstrapped away
 206
 207 sub version {
 208     my $self = shift;
 209     no strict 'refs';
 210     ${$self->name . '::VERSION'};
 211 }
 212
 213 # Inheritance
 214
 215 sub superclasses {
 216     my $self = shift;
 217     no strict 'refs';
 218     if (@_) {
 219         my @supers = @_;
 220         @{$self->name . '::ISA'} = @supers;
 221     }
 222     @{$self->name . '::ISA'};
 223 }
 224
 225 sub class_precedence_list {
 226     my $self = shift;
 227     # NOTE:
 228     # We need to check for ciruclar inheirtance here.
 229     # This will do nothing if all is well, and blow
 230     # up otherwise. Yes, it's an ugly hack, better
 231     # suggestions are welcome.
 232     { $self->name->isa('This is a test for circular inheritance') }
 233     # ... and no back to our regularly scheduled program
 234     (
 235         $self->name,
 236         map {
 237             $self->initialize($_)->class_precedence_list()
 238         } $self->superclasses()
 239     );
 240 }
 241
 242 ## Methods
 243
 244 sub add_method {
 245     my ($self, $method_name, $method) = @_;
 246     (defined $method_name && $method_name)
 247         || confess "You must define a method name";
 248     # use reftype here to allow for blessed subs ...
 249     (reftype($method) && reftype($method) eq 'CODE')
 250         || confess "Your code block must be a CODE reference";
 251     my $full_method_name = ($self->name . '::' . $method_name);
 252
 253     no strict 'refs';
 254     no warnings 'redefine';
 255 #    *{$full_method_name} = subname $full_method_name => $method;
 256     *{$full_method_name} = $method;
 257 }
 258
 259 sub alias_method {
 260     my ($self, $method_name, $method) = @_;
 261     (defined $method_name && $method_name)
 262         || confess "You must define a method name";
 263     # use reftype here to allow for blessed subs ...
 264     (reftype($method) && reftype($method) eq 'CODE')
 265         || confess "Your code block must be a CODE reference";
 266     my $full_method_name = ($self->name . '::' . $method_name);
 267
 268     no strict 'refs';
 269     no warnings 'redefine';
 270     *{$full_method_name} = $method;
 271 }
 272
 273 {
 274
 275     ## private utility functions for has_method
 276     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
 277     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } || '' };
 278
 279     sub has_method {
 280         my ($self, $method_name) = @_;
 281         (defined $method_name && $method_name)
 282             || confess "You must define a method name";
 283
 284         my $sub_name = ($self->name . '::' . $method_name);
 285
 286         no strict 'refs';
 287         return 0 if !defined(&{$sub_name});
 288         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 289                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 290         return 1;
 291     }
 292
 293 }
 294
 295 sub get_method {
 296     my ($self, $method_name) = @_;
 297     (defined $method_name && $method_name)
 298         || confess "You must define a method name";
 299
 300     no strict 'refs';
 301     return \&{$self->name . '::' . $method_name}
 302         if $self->has_method($method_name);
 303     return; # <- make sure to return undef
 304 }
 305
 306 sub remove_method {
 307     my ($self, $method_name) = @_;
 308     (defined $method_name && $method_name)
 309         || confess "You must define a method name";
 310
 311     my $removed_method = $self->get_method($method_name);
 312
 313     no strict 'refs';
 314     delete ${$self->name . '::'}{$method_name}
 315         if defined $removed_method;
 316
 317     return $removed_method;
 318 }
 319
 320 sub get_method_list {
 321     my $self = shift;
 322     no strict 'refs';
 323     grep { $self->has_method($_) } %{$self->name . '::'};
 324 }
 325
 326 sub compute_all_applicable_methods {
 327     my $self = shift;
 328     my @methods;
 329     # keep a record of what we have seen
 330     # here, this will handle all the
 331     # inheritence issues because we are
 332     # using the &class_precedence_list
 333     my (%seen_class, %seen_method);
 334     foreach my $class ($self->class_precedence_list()) {
 335         next if $seen_class{$class};
 336         $seen_class{$class}++;
 337         # fetch the meta-class ...
 338         my $meta = $self->initialize($class);
 339         foreach my $method_name ($meta->get_method_list()) {
 340             next if exists $seen_method{$method_name};
 341             $seen_method{$method_name}++;
 342             push @methods => {
 343                 name  => $method_name,
 344                 class => $class,
 345                 code  => $meta->get_method($method_name)
 346             };
 347         }
 348     }
 349     return @methods;
 350 }
 351
 352 sub find_all_methods_by_name {
 353     my ($self, $method_name) = @_;
 354     (defined $method_name && $method_name)
 355         || confess "You must define a method name to find";
 356     my @methods;
 357     # keep a record of what we have seen
 358     # here, this will handle all the
 359     # inheritence issues because we are
 360     # using the &class_precedence_list
 361     my %seen_class;
 362     foreach my $class ($self->class_precedence_list()) {
 363         next if $seen_class{$class};
 364         $seen_class{$class}++;
 365         # fetch the meta-class ...
 366         my $meta = $self->initialize($class);;
 367         push @methods => {
 368             name  => $method_name,
 369             class => $class,
 370             code  => $meta->get_method($method_name)
 371         } if $meta->has_method($method_name);
 372     }
 373     return @methods;
 374
 375 }
 376
 377 ## Attributes
 378
 379 sub add_attribute {
 380     my $self      = shift;
 381     # either we have an attribute object already
 382     # or we need to create one from the args provided
 383     my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
 384     # make sure it is derived from the correct type though
 385     ($attribute->isa('Class::MOP::Attribute'))
 386         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
 387     $attribute->attach_to_class($self);
 388     $attribute->install_accessors();
 389     $self->get_attribute_map->{$attribute->name} = $attribute;
 390 }
 391
 392 sub has_attribute {
 393     my ($self, $attribute_name) = @_;
 394     (defined $attribute_name && $attribute_name)
 395         || confess "You must define an attribute name";
 396     exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
 397 }
 398
 399 sub get_attribute {
 400     my ($self, $attribute_name) = @_;
 401     (defined $attribute_name && $attribute_name)
 402         || confess "You must define an attribute name";
 403     return $self->get_attribute_map->{$attribute_name}
 404         if $self->has_attribute($attribute_name);
 405 }
 406
 407 sub remove_attribute {
 408     my ($self, $attribute_name) = @_;
 409     (defined $attribute_name && $attribute_name)
 410         || confess "You must define an attribute name";
 411     my $removed_attribute = $self->get_attribute_map->{$attribute_name};
 412     delete $self->get_attribute_map->{$attribute_name}
 413         if defined $removed_attribute;
 414     $removed_attribute->remove_accessors();
 415     $removed_attribute->detach_from_class();
 416     return $removed_attribute;
 417 }
 418
 419 sub get_attribute_list {
 420     my $self = shift;
 421     keys %{$self->get_attribute_map};
 422 }
 423
 424 sub compute_all_applicable_attributes {
 425     my $self = shift;
 426     my @attrs;
 427     # keep a record of what we have seen
 428     # here, this will handle all the
 429     # inheritence issues because we are
 430     # using the &class_precedence_list
 431     my (%seen_class, %seen_attr);
 432     foreach my $class ($self->class_precedence_list()) {
 433         next if $seen_class{$class};
 434         $seen_class{$class}++;
 435         # fetch the meta-class ...
 436         my $meta = $self->initialize($class);
 437         foreach my $attr_name ($meta->get_attribute_list()) {
 438             next if exists $seen_attr{$attr_name};
 439             $seen_attr{$attr_name}++;
 440             push @attrs => $meta->get_attribute($attr_name);
 441         }
 442     }
 443     return @attrs;
 444 }
 445
 446 # Class attributes
 447
 448 sub add_package_variable {
 449     my ($self, $variable, $initial_value) = @_;
 450     (defined $variable && $variable =~ /^[\$\@\%]/)
 451         || confess "variable name does not have a sigil";
 452
 453     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 454     if (defined $initial_value) {
 455         no strict 'refs';
 456         *{$self->name . '::' . $name} = $initial_value;
 457     }
 458     else {
 459         eval $sigil . $self->name . '::' . $name;
 460         confess "Could not create package variable ($variable) because : $@" if $@;
 461     }
 462 }
 463
 464 sub has_package_variable {
 465     my ($self, $variable) = @_;
 466     (defined $variable && $variable =~ /^[\$\@\%]/)
 467         || confess "variable name does not have a sigil";
 468     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 469     no strict 'refs';
 470     defined ${$self->name . '::'}{$name} ? 1 : 0;
 471 }
 472
 473 sub get_package_variable {
 474     my ($self, $variable) = @_;
 475     (defined $variable && $variable =~ /^[\$\@\%]/)
 476         || confess "variable name does not have a sigil";
 477     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 478     no strict 'refs';
 479     # try to fetch it first,.. see what happens
 480     eval '\\' . $sigil . $self->name . '::' . $name;
 481     confess "Could not get the package variable ($variable) because : $@" if $@;
 482     # if we didn't die, then we can return it
 483     # NOTE:
 484     # this is not ideal, better suggestions are welcome
 485     eval '\\' . $sigil . $self->name . '::' . $name;
 486 }
 487
 488 sub remove_package_variable {
 489     my ($self, $variable) = @_;
 490     (defined $variable && $variable =~ /^[\$\@\%]/)
 491         || confess "variable name does not have a sigil";
 492     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 493     no strict 'refs';
 494     delete ${$self->name . '::'}{$name};
 495 }
 496
 497 1;
 498
 499 __END__
 500
 501 =pod
 502
 503 =head1 NAME
 504
 505 Class::MOP::Class - Class Meta Object
 506
 507 =head1 SYNOPSIS
 508
 509   # use this for introspection ...
 510
 511   # add a method to Foo ...
 512   Foo->meta->add_method('bar' => sub { ... })
 513
 514   # get a list of all the classes searched
 515   # the method dispatcher in the correct order
 516   Foo->meta->class_precedence_list()
 517
 518   # remove a method from Foo
 519   Foo->meta->remove_method('bar');
 520
 521   # or use this to actually create classes ...
 522
 523   Class::MOP::Class->create('Bar' => '0.01' => (
 524       superclasses => [ 'Foo' ],
 525       attributes => [
 526           Class::MOP:::Attribute->new('$bar'),
 527           Class::MOP:::Attribute->new('$baz'),
 528       ],
 529       methods => {
 530           calculate_bar => sub { ... },
 531           construct_baz => sub { ... }
 532       }
 533   ));
 534
 535 =head1 DESCRIPTION
 536
 537 This is the largest and currently most complex part of the Perl 5
 538 meta-object protocol. It controls the introspection and
 539 manipulation of Perl 5 classes (and it can create them too). The
 540 best way to understand what this module can do, is to read the
 541 documentation for each of it's methods.
 542
 543 =head1 METHODS
 544
 545 =head2 Self Introspection
 546
 547 =over 4
 548
 549 =item B<meta>
 550
 551 This will return a B<Class::MOP::Class> instance which is related
 552 to this class. Thereby allowing B<Class::MOP::Class> to actually
 553 introspect itself.
 554
 555 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
 556 bootstrap this module by installing a number of attribute meta-objects
 557 into it's metaclass. This will allow this class to reap all the benifits
 558 of the MOP when subclassing it.
 559
 560 =back
 561
 562 =head2 Class construction
 563
 564 These methods will handle creating B<Class::MOP::Class> objects,
 565 which can be used to both create new classes, and analyze
 566 pre-existing classes.
 567
 568 This module will internally store references to all the instances
 569 you create with these methods, so that they do not need to be
 570 created any more than nessecary. Basically, they are singletons.
 571
 572 =over 4
 573
 574 =item B<create ($package_name, ?$package_version,
 575                 superclasses =E<gt> ?@superclasses,
 576                 methods      =E<gt> ?%methods,
 577                 attributes   =E<gt> ?%attributes)>
 578
 579 This returns a B<Class::MOP::Class> object, bringing the specified
 580 C<$package_name> into existence and adding any of the
 581 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
 582 to it.
 583
 584 =item B<initialize ($package_name)>
 585
 586 This initializes and returns returns a B<Class::MOP::Class> object
 587 for a given a C<$package_name>.
 588
 589 =item B<construct_class_instance (%options)>
 590
 591 This will construct an instance of B<Class::MOP::Class>, it is
 592 here so that we can actually "tie the knot" for B<Class::MOP::Class>
 593 to use C<construct_instance> once all the bootstrapping is done. This
 594 method is used internally by C<initialize> and should never be called
 595 from outside of that method really.
 596
 597 =item B<check_metaclass_compatability>
 598
 599 This method is called as the very last thing in the
 600 C<construct_class_instance> method. This will check that the
 601 metaclass you are creating is compatible with the metaclasses of all
 602 your ancestors. For more inforamtion about metaclass compatibility
 603 see the C<About Metaclass compatibility> section in L<Class::MOP>.
 604
 605 =back
 606
 607 =head2 Object instance construction and cloning
 608
 609 These methods are B<entirely optional>, it is up to you whether you want
 610 to use them or not.
 611
 612 =over 4
 613
 614 =item B<new_object (%params)>
 615
 616 This is a convience method for creating a new object of the class, and
 617 blessing it into the appropriate package as well. Ideally your class
 618 would call a C<new> this method like so:
 619
 620   sub MyClass::new {
 621       my ($class, %param) = @_;
 622       $class->meta->new_object(%params);
 623   }
 624
 625 Of course the ideal place for this would actually be in C<UNIVERSAL::>
 626 but that is considered bad style, so we do not do that.
 627
 628 =item B<construct_instance (%params)>
 629
 630 This method is used to construct an instace structure suitable for
 631 C<bless>-ing into your package of choice. It works in conjunction
 632 with the Attribute protocol to collect all applicable attributes.
 633
 634 This will construct and instance using a HASH ref as storage
 635 (currently only HASH references are supported). This will collect all
 636 the applicable attributes and layout out the fields in the HASH ref,
 637 it will then initialize them using either use the corresponding key
 638 in C<%params> or any default value or initializer found in the
 639 attribute meta-object.
 640
 641 =item B<clone_object ($instance, %params)>
 642
 643 This is a convience method for cloning an object instance, then
 644 blessing it into the appropriate package. Ideally your class
 645 would call a C<clone> this method like so:
 646
 647   sub MyClass::clone {
 648       my ($self, %param) = @_;
 649       $self->meta->clone_object($self, %params);
 650   }
 651
 652 Of course the ideal place for this would actually be in C<UNIVERSAL::>
 653 but that is considered bad style, so we do not do that.
 654
 655 =item B<clone_instance($instance, %params)>
 656
 657 This method is a compliment of C<construct_instance> (which means if
 658 you override C<construct_instance>, you need to override this one too).
 659
 660 This method will clone the C<$instance> structure created by the
 661 C<construct_instance> method, and apply any C<%params> passed to it
 662 to change the attribute values. The structure returned is (like with
 663 C<construct_instance>) an unC<bless>ed HASH reference, it is your
 664 responsibility to then bless this cloned structure into the right
 665 class.
 666
 667 =back
 668
 669 =head2 Informational
 670
 671 =over 4
 672
 673 =item B<name>
 674
 675 This is a read-only attribute which returns the package name for the
 676 given B<Class::MOP::Class> instance.
 677
 678 =item B<version>
 679
 680 This is a read-only attribute which returns the C<$VERSION> of the
 681 package for the given B<Class::MOP::Class> instance.
 682
 683 =back
 684
 685 =head2 Inheritance Relationships
 686
 687 =over 4
 688
 689 =item B<superclasses (?@superclasses)>
 690
 691 This is a read-write attribute which represents the superclass
 692 relationships of the class the B<Class::MOP::Class> instance is
 693 associated with. Basically, it can get and set the C<@ISA> for you.
 694
 695 B<NOTE:>
 696 Perl will occasionally perform some C<@ISA> and method caching, if
 697 you decide to change your superclass relationship at runtime (which
 698 is quite insane and very much not recommened), then you should be
 699 aware of this and the fact that this module does not make any
 700 attempt to address this issue.
 701
 702 =item B<class_precedence_list>
 703
 704 This computes the a list of all the class's ancestors in the same order
 705 in which method dispatch will be done. This is similair to
 706 what B<Class::ISA::super_path> does, but we don't remove duplicate names.
 707
 708 =back
 709
 710 =head2 Methods
 711
 712 =over 4
 713
 714 =item B<method_metaclass>
 715
 716 =item B<add_method ($method_name, $method)>
 717
 718 This will take a C<$method_name> and CODE reference to that
 719 C<$method> and install it into the class's package.
 720
 721 B<NOTE>:
 722 This does absolutely nothing special to C<$method>
 723 other than use B<Sub::Name> to make sure it is tagged with the
 724 correct name, and therefore show up correctly in stack traces and
 725 such.
 726
 727 =item B<alias_method ($method_name, $method)>
 728
 729 This will take a C<$method_name> and CODE reference to that
 730 C<$method> and alias the method into the class's package.
 731
 732 B<NOTE>:
 733 Unlike C<add_method>, this will B<not> try to name the
 734 C<$method> using B<Sub::Name>, it only aliases the method in
 735 the class's package.
 736
 737 =item B<has_method ($method_name)>
 738
 739 This just provides a simple way to check if the class implements
 740 a specific C<$method_name>. It will I<not> however, attempt to check
 741 if the class inherits the method (use C<UNIVERSAL::can> for that).
 742
 743 This will correctly handle functions defined outside of the package
 744 that use a fully qualified name (C<sub Package::name { ... }>).
 745
 746 This will correctly handle functions renamed with B<Sub::Name> and
 747 installed using the symbol tables. However, if you are naming the
 748 subroutine outside of the package scope, you must use the fully
 749 qualified name, including the package name, for C<has_method> to
 750 correctly identify it.
 751
 752 This will attempt to correctly ignore functions imported from other
 753 packages using B<Exporter>. It breaks down if the function imported
 754 is an C<__ANON__> sub (such as with C<use constant>), which very well
 755 may be a valid method being applied to the class.
 756
 757 In short, this method cannot always be trusted to determine if the
 758 C<$method_name> is actually a method. However, it will DWIM about
 759 90% of the time, so it's a small trade off I think.
 760
 761 =item B<get_method ($method_name)>
 762
 763 This will return a CODE reference of the specified C<$method_name>,
 764 or return undef if that method does not exist.
 765
 766 =item B<remove_method ($method_name)>
 767
 768 This will attempt to remove a given C<$method_name> from the class.
 769 It will return the CODE reference that it has removed, and will
 770 attempt to use B<Sub::Name> to clear the methods associated name.
 771
 772 =item B<get_method_list>
 773
 774 This will return a list of method names for all I<locally> defined
 775 methods. It does B<not> provide a list of all applicable methods,
 776 including any inherited ones. If you want a list of all applicable
 777 methods, use the C<compute_all_applicable_methods> method.
 778
 779 =item B<compute_all_applicable_methods>
 780
 781 This will return a list of all the methods names this class will
 782 respond to, taking into account inheritance. The list will be a list of
 783 HASH references, each one containing the following information; method
 784 name, the name of the class in which the method lives and a CODE
 785 reference for the actual method.
 786
 787 =item B<find_all_methods_by_name ($method_name)>
 788
 789 This will traverse the inheritence hierarchy and locate all methods
 790 with a given C<$method_name>. Similar to
 791 C<compute_all_applicable_methods> it returns a list of HASH references
 792 with the following information; method name (which will always be the
 793 same as C<$method_name>), the name of the class in which the method
 794 lives and a CODE reference for the actual method.
 795
 796 The list of methods produced is a distinct list, meaning there are no
 797 duplicates in it. This is especially useful for things like object
 798 initialization and destruction where you only want the method called
 799 once, and in the correct order.
 800
 801 =back
 802
 803 =head2 Attributes
 804
 805 It should be noted that since there is no one consistent way to define
 806 the attributes of a class in Perl 5. These methods can only work with
 807 the information given, and can not easily discover information on
 808 their own. See L<Class::MOP::Attribute> for more details.
 809
 810 =over 4
 811
 812 =item B<attribute_metaclass>
 813
 814 =item B<get_attribute_map>
 815
 816 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 817
 818 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
 819 instance associated with the given class, and associates it with
 820 the C<$attribute_name>. Unlike methods, attributes within the MOP
 821 are stored as meta-information only. They will be used later to
 822 construct instances from (see C<construct_instance> above).
 823 More details about the attribute meta-objects can be found in the
 824 L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
 825 section.
 826
 827 It should be noted that any accessor, reader/writer or predicate
 828 methods which the C<$attribute_meta_object> has will be installed
 829 into the class at this time.
 830
 831 =item B<has_attribute ($attribute_name)>
 832
 833 Checks to see if this class has an attribute by the name of
 834 C<$attribute_name> and returns a boolean.
 835
 836 =item B<get_attribute ($attribute_name)>
 837
 838 Returns the attribute meta-object associated with C<$attribute_name>,
 839 if none is found, it will return undef.
 840
 841 =item B<remove_attribute ($attribute_name)>
 842
 843 This will remove the attribute meta-object stored at
 844 C<$attribute_name>, then return the removed attribute meta-object.
 845
 846 B<NOTE:>
 847 Removing an attribute will only affect future instances of
 848 the class, it will not make any attempt to remove the attribute from
 849 any existing instances of the class.
 850
 851 It should be noted that any accessor, reader/writer or predicate
 852 methods which the attribute meta-object stored at C<$attribute_name>
 853 has will be removed from the class at this time. This B<will> make
 854 these attributes somewhat inaccessable in previously created
 855 instances. But if you are crazy enough to do this at runtime, then
 856 you are crazy enough to deal with something like this :).
 857
 858 =item B<get_attribute_list>
 859
 860 This returns a list of attribute names which are defined in the local
 861 class. If you want a list of all applicable attributes for a class,
 862 use the C<compute_all_applicable_attributes> method.
 863
 864 =item B<compute_all_applicable_attributes>
 865
 866 This will traverse the inheritance heirachy and return a list of all
 867 the applicable attributes for this class. It does not construct a
 868 HASH reference like C<compute_all_applicable_methods> because all
 869 that same information is discoverable through the attribute
 870 meta-object itself.
 871
 872 =back
 873
 874 =head2 Package Variables
 875
 876 Since Perl's classes are built atop the Perl package system, it is
 877 fairly common to use package scoped variables for things like static
 878 class variables. The following methods are convience methods for
 879 the creation and inspection of package scoped variables.
 880
 881 =over 4
 882
 883 =item B<add_package_variable ($variable_name, ?$initial_value)>
 884
 885 Given a C<$variable_name>, which must contain a leading sigil, this
 886 method will create that variable within the package which houses the
 887 class. It also takes an optional C<$initial_value>, which must be a
 888 reference of the same type as the sigil of the C<$variable_name>
 889 implies.
 890
 891 =item B<get_package_variable ($variable_name)>
 892
 893 This will return a reference to the package variable in
 894 C<$variable_name>.
 895
 896 =item B<has_package_variable ($variable_name)>
 897
 898 Returns true (C<1>) if there is a package variable defined for
 899 C<$variable_name>, and false (C<0>) otherwise.
 900
 901 =item B<remove_package_variable ($variable_name)>
 902
 903 This will attempt to remove the package variable at C<$variable_name>.
 904
 905 =back
 906
 907 =head1 AUTHOR
 908
 909 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 910
 911 =head1 COPYRIGHT AND LICENSE
 912
 913 Copyright 2006 by Infinity Interactive, Inc.
 914
 915 L<http://www.iinteractive.com>
 916
 917 This library is free software; you can redistribute it and/or modify
 918 it under the same terms as Perl itself.
 919
 920 =cut