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