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
  12 our $VERSION = '0.01';
  13
  14 # Self-introspection
  15
  16 sub meta { $_[0]->initialize($_[0]) }
  17
  18 # Creation
  19
  20 {
  21     # Metaclasses are singletons, so we cache them here.
  22     # there is no need to worry about destruction though
  23     # because they should die only when the program dies.
  24     # After all, do package definitions even get reaped?
  25     my %METAS;
  26     sub initialize {
  27         my ($class, $package_name) = @_;
  28         (defined $package_name && $package_name)
  29             || confess "You must pass a package name";
  30         return $METAS{$package_name} if exists $METAS{$package_name};
  31         $METAS{$package_name} = $class->construct_class_instance($package_name);
  32     }
  33
  34     # NOTE: (meta-circularity)
  35     # this is a special form of &construct_instance
  36     # (see below), which is used to construct class
  37     # meta-object instances for any Class::MOP::*
  38     # class. All other classes will use the more
  39     # normal &construct_instance.
  40     sub construct_class_instance {
  41         my ($class, $package_name) = @_;
  42         (defined $package_name && $package_name)
  43             || confess "You must pass a package name";
  44         $class = blessed($class) || $class;
  45         if ($class =~ /^Class::MOP::/) {
  46             bless {
  47                 '$:pkg'   => $package_name,
  48                 '%:attrs' => {}
  49             } => $class;
  50         }
  51         else {
  52             bless $class->meta->construct_instance(':pkg' => $package_name) => $class
  53         }
  54     }
  55 }
  56
  57 sub create {
  58     my ($class, $package_name, $package_version, %options) = @_;
  59     (defined $package_name && $package_name)
  60         || confess "You must pass a package name";
  61     my $code = "package $package_name;";
  62     $code .= "\$$package_name\:\:VERSION = '$package_version';"
  63         if defined $package_version;
  64     eval $code;
  65     confess "creation of $package_name failed : $@" if $@;
  66     my $meta = $class->initialize($package_name);
  67     $meta->superclasses(@{$options{superclasses}})
  68         if exists $options{superclasses};
  69     # NOTE:
  70     # process attributes first, so that they can
  71     # install accessors, but locally defined methods
  72     # can then overwrite them. It is maybe a little odd, but
  73     # I think this should be the order of things.
  74     if (exists $options{attributes}) {
  75         foreach my $attr (@{$options{attributes}}) {
  76             $meta->add_attribute($attr);
  77         }
  78     }
  79     if (exists $options{methods}) {
  80         foreach my $method_name (keys %{$options{methods}}) {
  81             $meta->add_method($method_name, $options{methods}->{$method_name});
  82         }
  83     }
  84     return $meta;
  85 }
  86
  87 # Instance Construction
  88
  89 sub construct_instance {
  90     my ($class, %params) = @_;
  91     my $instance = {};
  92     foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
  93         # if the attr has an init_arg, use that, otherwise,
  94         # use the attributes name itself as the init_arg
  95         my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
  96         # try to fetch the init arg from the %params ...
  97         my $val;
  98         $val = $params{$init_arg} if exists $params{$init_arg};
  99         # if nothing was in the %params, we can use the
 100         # attribute's default value (if it has one)
 101         $val ||= $attr->default($instance) if $attr->has_default();
 102         # now add this to the instance structure
 103         $instance->{$attr->name} = $val;
 104     }
 105     return $instance;
 106 }
 107
 108 # Informational
 109
 110 sub name { $_[0]->{'$:pkg'} }
 111
 112 sub version {
 113     my $self = shift;
 114     no strict 'refs';
 115     ${$self->name . '::VERSION'};
 116 }
 117
 118 # Inheritance
 119
 120 sub superclasses {
 121     my $self = shift;
 122     no strict 'refs';
 123     if (@_) {
 124         my @supers = @_;
 125         @{$self->name . '::ISA'} = @supers;
 126     }
 127     @{$self->name . '::ISA'};
 128 }
 129
 130 sub class_precedence_list {
 131     my $self = shift;
 132     # NOTE:
 133     # We need to check for ciruclar inheirtance here.
 134     # This will do nothing if all is well, and blow
 135     # up otherwise. Yes, it's an ugly hack, better
 136     # suggestions are welcome.
 137     { $self->name->isa('This is a test for circular inheritance') }
 138     # ... and no back to our regularly scheduled program
 139     (
 140         $self->name,
 141         map {
 142             $self->initialize($_)->class_precedence_list()
 143         } $self->superclasses()
 144     );
 145 }
 146
 147 ## Methods
 148
 149 sub add_method {
 150     my ($self, $method_name, $method) = @_;
 151     (defined $method_name && $method_name)
 152         || confess "You must define a method name";
 153     # use reftype here to allow for blessed subs ...
 154     (reftype($method) && reftype($method) eq 'CODE')
 155         || confess "Your code block must be a CODE reference";
 156     my $full_method_name = ($self->name . '::' . $method_name);
 157
 158     no strict 'refs';
 159     no warnings 'redefine';
 160     *{$full_method_name} = subname $full_method_name => $method;
 161 }
 162
 163 {
 164
 165     ## private utility functions for has_method
 166     my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
 167     my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } || '' };
 168
 169     sub has_method {
 170         my ($self, $method_name) = @_;
 171         (defined $method_name && $method_name)
 172             || confess "You must define a method name";
 173
 174         my $sub_name = ($self->name . '::' . $method_name);
 175
 176         no strict 'refs';
 177         return 0 if !defined(&{$sub_name});
 178         return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
 179                     $_find_subroutine_name->(\&{$sub_name})         ne '__ANON__';
 180         return 1;
 181     }
 182
 183 }
 184
 185 sub get_method {
 186     my ($self, $method_name) = @_;
 187     (defined $method_name && $method_name)
 188         || confess "You must define a method name";
 189
 190     no strict 'refs';
 191     return \&{$self->name . '::' . $method_name}
 192         if $self->has_method($method_name);
 193     return; # <- make sure to return undef
 194 }
 195
 196 sub remove_method {
 197     my ($self, $method_name) = @_;
 198     (defined $method_name && $method_name)
 199         || confess "You must define a method name";
 200
 201     my $removed_method = $self->get_method($method_name);
 202
 203     no strict 'refs';
 204     delete ${$self->name . '::'}{$method_name}
 205         if defined $removed_method;
 206
 207     return $removed_method;
 208 }
 209
 210 sub get_method_list {
 211     my $self = shift;
 212     no strict 'refs';
 213     grep { $self->has_method($_) } %{$self->name . '::'};
 214 }
 215
 216 sub compute_all_applicable_methods {
 217     my $self = shift;
 218     my @methods;
 219     # keep a record of what we have seen
 220     # here, this will handle all the
 221     # inheritence issues because we are
 222     # using the &class_precedence_list
 223     my (%seen_class, %seen_method);
 224     foreach my $class ($self->class_precedence_list()) {
 225         next if $seen_class{$class};
 226         $seen_class{$class}++;
 227         # fetch the meta-class ...
 228         my $meta = $self->initialize($class);
 229         foreach my $method_name ($meta->get_method_list()) {
 230             next if exists $seen_method{$method_name};
 231             $seen_method{$method_name}++;
 232             push @methods => {
 233                 name  => $method_name,
 234                 class => $class,
 235                 code  => $meta->get_method($method_name)
 236             };
 237         }
 238     }
 239     return @methods;
 240 }
 241
 242 sub find_all_methods_by_name {
 243     my ($self, $method_name) = @_;
 244     (defined $method_name && $method_name)
 245         || confess "You must define a method name to find";
 246     my @methods;
 247     # keep a record of what we have seen
 248     # here, this will handle all the
 249     # inheritence issues because we are
 250     # using the &class_precedence_list
 251     my %seen_class;
 252     foreach my $class ($self->class_precedence_list()) {
 253         next if $seen_class{$class};
 254         $seen_class{$class}++;
 255         # fetch the meta-class ...
 256         my $meta = $self->initialize($class);
 257         push @methods => {
 258             name  => $method_name,
 259             class => $class,
 260             code  => $meta->get_method($method_name)
 261         } if $meta->has_method($method_name);
 262     }
 263     return @methods;
 264
 265 }
 266
 267 ## Attributes
 268
 269 sub add_attribute {
 270     my ($self,$attribute) = @_;
 271     (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
 272         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
 273     $attribute->install_accessors($self);
 274     $self->{'%:attrs'}->{$attribute->name} = $attribute;
 275 }
 276
 277 sub has_attribute {
 278     my ($self, $attribute_name) = @_;
 279     (defined $attribute_name && $attribute_name)
 280         || confess "You must define an attribute name";
 281     exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0;
 282 }
 283
 284 sub get_attribute {
 285     my ($self, $attribute_name) = @_;
 286     (defined $attribute_name && $attribute_name)
 287         || confess "You must define an attribute name";
 288     return $self->{'%:attrs'}->{$attribute_name}
 289         if $self->has_attribute($attribute_name);
 290 }
 291
 292 sub remove_attribute {
 293     my ($self, $attribute_name) = @_;
 294     (defined $attribute_name && $attribute_name)
 295         || confess "You must define an attribute name";
 296     my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
 297     delete $self->{'%:attrs'}->{$attribute_name}
 298         if defined $removed_attribute;
 299     $removed_attribute->remove_accessors($self);
 300     return $removed_attribute;
 301 }
 302
 303 sub get_attribute_list {
 304     my $self = shift;
 305     keys %{$self->{'%:attrs'}};
 306 }
 307
 308 sub compute_all_applicable_attributes {
 309     my $self = shift;
 310     my @attrs;
 311     # keep a record of what we have seen
 312     # here, this will handle all the
 313     # inheritence issues because we are
 314     # using the &class_precedence_list
 315     my (%seen_class, %seen_attr);
 316     foreach my $class ($self->class_precedence_list()) {
 317         next if $seen_class{$class};
 318         $seen_class{$class}++;
 319         # fetch the meta-class ...
 320         my $meta = $self->initialize($class);
 321         foreach my $attr_name ($meta->get_attribute_list()) {
 322             next if exists $seen_attr{$attr_name};
 323             $seen_attr{$attr_name}++;
 324             push @attrs => {
 325                 name      => $attr_name,
 326                 class     => $class,
 327                 attribute => $meta->get_attribute($attr_name)
 328             };
 329         }
 330     }
 331     return @attrs;
 332 }
 333
 334 1;
 335
 336 __END__
 337
 338 =pod
 339
 340 =head1 NAME
 341
 342 Class::MOP::Class - Class Meta Object
 343
 344 =head1 SYNOPSIS
 345
 346   # use this for introspection ...
 347
 348   package Foo;
 349   sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
 350
 351   # elsewhere in the code ...
 352
 353   # add a method to Foo ...
 354   Foo->meta->add_method('bar' => sub { ... })
 355
 356   # get a list of all the classes searched
 357   # the method dispatcher in the correct order
 358   Foo->meta->class_precedence_list()
 359
 360   # remove a method from Foo
 361   Foo->meta->remove_method('bar');
 362
 363   # or use this to actually create classes ...
 364
 365   Class::MOP::Class->create('Bar' => '0.01' => (
 366       superclasses => [ 'Foo' ],
 367       attributes => [
 368           Class::MOP:::Attribute->new('$bar'),
 369           Class::MOP:::Attribute->new('$baz'),
 370       ],
 371       methods => {
 372           calculate_bar => sub { ... },
 373           construct_baz => sub { ... }
 374       }
 375   ));
 376
 377 =head1 DESCRIPTION
 378
 379 This is the largest and currently most complex part of the Perl 5
 380 meta-object protocol. It controls the introspection and
 381 manipulation of Perl 5 classes (and it can create them too). The
 382 best way to understand what this module can do, is to read the
 383 documentation for each of it's methods.
 384
 385 =head1 METHODS
 386
 387 =head2 Self Introspection
 388
 389 =over 4
 390
 391 =item B<meta>
 392
 393 This will return a B<Class::MOP::Class> instance which is related
 394 to this class. Thereby allowing B<Class::MOP::Class> to actually
 395 introspect itself.
 396
 397 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
 398 bootstrap this module by installing a number of attribute meta-objects
 399 into it's metaclass. This will allow this class to reap all the benifits
 400 of the MOP when subclassing it.
 401
 402 =back
 403
 404 =head2 Class construction
 405
 406 These methods handle creating Class objects, which can be used to
 407 both create new classes, and analyze pre-existing ones.
 408
 409 This module will internally store references to all the instances
 410 you create with these methods, so that they do not need to be
 411 created any more than nessecary. Basically, they are singletons.
 412
 413 =over 4
 414
 415 =item B<create ($package_name, ?$package_version,
 416                 superclasses => ?@superclasses,
 417                 methods      => ?%methods,
 418                 attributes   => ?%attributes)>
 419
 420 This returns the basic Class object, bringing the specified
 421 C<$package_name> into existence and adding any of the
 422 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
 423 to it.
 424
 425 =item B<initialize ($package_name)>
 426
 427 This initializes a Class object for a given a C<$package_name>.
 428
 429 =back
 430
 431 =head2 Instance construction
 432
 433 =over 4
 434
 435 =item B<construct_instance (%params)>
 436
 437 This will construct and instance using a HASH ref as storage
 438 (currently only HASH references are supported). This will collect all
 439 the applicable attribute meta-objects and layout out the fields in the
 440 HASH ref, it will then initialize them using either use the
 441 corresponding key in C<%params> or any default value or initializer
 442 found in the attribute meta-object.
 443
 444 =item B<construct_class_instance ($package_name)>
 445
 446 This will construct an instance of B<Class::MOP::Class>, it is
 447 here so that we can actually "tie the knot" for B<Class::MOP::Class>
 448 to use C<construct_instance> once all the bootstrapping is done. This
 449 method is used internally by C<initialize> and should never be called
 450 from outside of that method really.
 451
 452 =back
 453
 454 =head2 Informational
 455
 456 =over 4
 457
 458 =item B<name>
 459
 460 This is a read-only attribute which returns the package name that
 461 the Class is stored in.
 462
 463 =item B<version>
 464
 465 This is a read-only attribute which returns the C<$VERSION> of the
 466 package the Class is stored in.
 467
 468 =back
 469
 470 =head2 Inheritance Relationships
 471
 472 =over 4
 473
 474 =item B<superclasses (?@superclasses)>
 475
 476 This is a read-write attribute which represents the superclass
 477 relationships of this Class. Basically, it can get and set the
 478 C<@ISA> for you.
 479
 480 =item B<class_precedence_list>
 481
 482 This computes the a list of the Class's ancestors in the same order
 483 in which method dispatch will be done.
 484
 485 =back
 486
 487 =head2 Methods
 488
 489 =over 4
 490
 491 =item B<add_method ($method_name, $method)>
 492
 493 This will take a C<$method_name> and CODE reference to that
 494 C<$method> and install it into the Class.
 495
 496 B<NOTE> : This does absolutely nothing special to C<$method>
 497 other than use B<Sub::Name> to make sure it is tagged with the
 498 correct name, and therefore show up correctly in stack traces and
 499 such.
 500
 501 =item B<has_method ($method_name)>
 502
 503 This just provides a simple way to check if the Class implements
 504 a specific C<$method_name>. It will I<not> however, attempt to check
 505 if the class inherits the method.
 506
 507 This will correctly handle functions defined outside of the package
 508 that use a fully qualified name (C<sub Package::name { ... }>).
 509
 510 This will correctly handle functions renamed with B<Sub::Name> and
 511 installed using the symbol tables. However, if you are naming the
 512 subroutine outside of the package scope, you must use the fully
 513 qualified name, including the package name, for C<has_method> to
 514 correctly identify it.
 515
 516 This will attempt to correctly ignore functions imported from other
 517 packages using B<Exporter>. It breaks down if the function imported
 518 is an C<__ANON__> sub (such as with C<use constant>), which very well
 519 may be a valid method being applied to the class.
 520
 521 In short, this method cannot always be trusted to determine if the
 522 C<$method_name> is actually a method. However, it will DWIM about
 523 90% of the time, so it's a small trade off IMO.
 524
 525 =item B<get_method ($method_name)>
 526
 527 This will return a CODE reference of the specified C<$method_name>,
 528 or return undef if that method does not exist.
 529
 530 =item B<remove_method ($method_name)>
 531
 532 This will attempt to remove a given C<$method_name> from the Class.
 533 It will return the CODE reference that it has removed, and will
 534 attempt to use B<Sub::Name> to clear the methods associated name.
 535
 536 =item B<get_method_list>
 537
 538 This will return a list of method names for all I<locally> defined
 539 methods. It does B<not> provide a list of all applicable methods,
 540 including any inherited ones. If you want a list of all applicable
 541 methods, use the C<compute_all_applicable_methods> method.
 542
 543 =item B<compute_all_applicable_methods>
 544
 545 This will return a list of all the methods names this Class will
 546 support, taking into account inheritance. The list will be a list of
 547 HASH references, each one containing the following information; method
 548 name, the name of the class in which the method lives and a CODE
 549 reference for the actual method.
 550
 551 =item B<find_all_methods_by_name ($method_name)>
 552
 553 This will traverse the inheritence hierarchy and locate all methods
 554 with a given C<$method_name>. Similar to
 555 C<compute_all_applicable_methods> it returns a list of HASH references
 556 with the following information; method name (which will always be the
 557 same as C<$method_name>), the name of the class in which the method
 558 lives and a CODE reference for the actual method.
 559
 560 The list of methods produced is a distinct list, meaning there are no
 561 duplicates in it. This is especially useful for things like object
 562 initialization and destruction where you only want the method called
 563 once, and in the correct order.
 564
 565 =back
 566
 567 =head2 Attributes
 568
 569 It should be noted that since there is no one consistent way to define
 570 the attributes of a class in Perl 5. These methods can only work with
 571 the information given, and can not easily discover information on
 572 their own.
 573
 574 =over 4
 575
 576 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 577
 578 This stores a C<$attribute_meta_object> in the Class object and
 579 associates it with the C<$attribute_name>. Unlike methods, attributes
 580 within the MOP are stored as meta-information only. They will be used
 581 later to construct instances from (see C<construct_instance> above).
 582 More details about the attribute meta-objects can be found in the
 583 L<The Attribute protocol> section of this document.
 584
 585 =item B<has_attribute ($attribute_name)>
 586
 587 Checks to see if this Class has an attribute by the name of
 588 C<$attribute_name> and returns a boolean.
 589
 590 =item B<get_attribute ($attribute_name)>
 591
 592 Returns the attribute meta-object associated with C<$attribute_name>,
 593 if none is found, it will return undef.
 594
 595 =item B<remove_attribute ($attribute_name)>
 596
 597 This will remove the attribute meta-object stored at
 598 C<$attribute_name>, then return the removed attribute meta-object.
 599
 600 B<NOTE:> Removing an attribute will only affect future instances of
 601 the class, it will not make any attempt to remove the attribute from
 602 any existing instances of the class.
 603
 604 =item B<get_attribute_list>
 605
 606 This returns a list of attribute names which are defined in the local
 607 class. If you want a list of all applicable attributes for a class,
 608 use the C<compute_all_applicable_attributes> method.
 609
 610 =item B<compute_all_applicable_attributes>
 611
 612 This will traverse the inheritance heirachy and return a list of HASH
 613 references for all the applicable attributes for this class. The HASH
 614 references will contain the following information; the attribute name,
 615 the class which the attribute is associated with and the actual
 616 attribute meta-object.
 617
 618 =back
 619
 620 =head1 AUTHOR
 621
 622 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 623
 624 =head1 COPYRIGHT AND LICENSE
 625
 626 Copyright 2006 by Infinity Interactive, Inc.
 627
 628 L<http://www.iinteractive.com>
 629
 630 This library is free software; you can redistribute it and/or modify
 631 it under the same terms as Perl itself.
 632
 633 =cut