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 # Class attributes
 335
 336 sub add_package_variable {
 337     my ($self, $variable, $initial_value) = @_;
 338     (defined $variable && $variable =~ /^[\$\@\%]/)
 339         || confess "variable name does not have a sigil";
 340
 341     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 342     if (defined $initial_value) {
 343         no strict 'refs';
 344         *{$self->name . '::' . $name} = $initial_value;
 345     }
 346     else {
 347         eval $sigil . $self->name . '::' . $name;
 348         confess "Could not create package variable ($variable) because : $@" if $@;
 349     }
 350 }
 351
 352 sub has_package_variable {
 353     my ($self, $variable) = @_;
 354     (defined $variable && $variable =~ /^[\$\@\%]/)
 355         || confess "variable name does not have a sigil";
 356     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 357     no strict 'refs';
 358     defined ${$self->name . '::'}{$name} ? 1 : 0;
 359 }
 360
 361 sub get_package_variable {
 362     my ($self, $variable) = @_;
 363     (defined $variable && $variable =~ /^[\$\@\%]/)
 364         || confess "variable name does not have a sigil";
 365     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 366     no strict 'refs';
 367     # try to fetch it first,.. see what happens
 368     eval '\\' . $sigil . $self->name . '::' . $name;
 369     confess "Could not get the package variable ($variable) because : $@" if $@;
 370     # if we didn't die, then we can return it
 371     # NOTE:
 372     # this is not ideal, better suggestions are welcome
 373     eval '\\' . $sigil . $self->name . '::' . $name;
 374 }
 375
 376 sub remove_package_variable {
 377     my ($self, $variable) = @_;
 378     (defined $variable && $variable =~ /^[\$\@\%]/)
 379         || confess "variable name does not have a sigil";
 380     my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 381     no strict 'refs';
 382     delete ${$self->name . '::'}{$name};
 383 }
 384
 385 1;
 386
 387 __END__
 388
 389 =pod
 390
 391 =head1 NAME
 392
 393 Class::MOP::Class - Class Meta Object
 394
 395 =head1 SYNOPSIS
 396
 397   # use this for introspection ...
 398
 399   package Foo;
 400   sub meta { Class::MOP::Class->initialize(__PACKAGE__) }
 401
 402   # elsewhere in the code ...
 403
 404   # add a method to Foo ...
 405   Foo->meta->add_method('bar' => sub { ... })
 406
 407   # get a list of all the classes searched
 408   # the method dispatcher in the correct order
 409   Foo->meta->class_precedence_list()
 410
 411   # remove a method from Foo
 412   Foo->meta->remove_method('bar');
 413
 414   # or use this to actually create classes ...
 415
 416   Class::MOP::Class->create('Bar' => '0.01' => (
 417       superclasses => [ 'Foo' ],
 418       attributes => [
 419           Class::MOP:::Attribute->new('$bar'),
 420           Class::MOP:::Attribute->new('$baz'),
 421       ],
 422       methods => {
 423           calculate_bar => sub { ... },
 424           construct_baz => sub { ... }
 425       }
 426   ));
 427
 428 =head1 DESCRIPTION
 429
 430 This is the largest and currently most complex part of the Perl 5
 431 meta-object protocol. It controls the introspection and
 432 manipulation of Perl 5 classes (and it can create them too). The
 433 best way to understand what this module can do, is to read the
 434 documentation for each of it's methods.
 435
 436 =head1 METHODS
 437
 438 =head2 Self Introspection
 439
 440 =over 4
 441
 442 =item B<meta>
 443
 444 This will return a B<Class::MOP::Class> instance which is related
 445 to this class. Thereby allowing B<Class::MOP::Class> to actually
 446 introspect itself.
 447
 448 As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
 449 bootstrap this module by installing a number of attribute meta-objects
 450 into it's metaclass. This will allow this class to reap all the benifits
 451 of the MOP when subclassing it.
 452
 453 =back
 454
 455 =head2 Class construction
 456
 457 These methods handle creating Class objects, which can be used to
 458 both create new classes, and analyze pre-existing ones.
 459
 460 This module will internally store references to all the instances
 461 you create with these methods, so that they do not need to be
 462 created any more than nessecary. Basically, they are singletons.
 463
 464 =over 4
 465
 466 =item B<create ($package_name, ?$package_version,
 467                 superclasses => ?@superclasses,
 468                 methods      => ?%methods,
 469                 attributes   => ?%attributes)>
 470
 471 This returns the basic Class object, bringing the specified
 472 C<$package_name> into existence and adding any of the
 473 C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
 474 to it.
 475
 476 =item B<initialize ($package_name)>
 477
 478 This initializes a Class object for a given a C<$package_name>.
 479
 480 =back
 481
 482 =head2 Instance construction
 483
 484 =over 4
 485
 486 =item B<construct_instance (%params)>
 487
 488 This will construct and instance using a HASH ref as storage
 489 (currently only HASH references are supported). This will collect all
 490 the applicable attribute meta-objects and layout out the fields in the
 491 HASH ref, it will then initialize them using either use the
 492 corresponding key in C<%params> or any default value or initializer
 493 found in the attribute meta-object.
 494
 495 =item B<construct_class_instance ($package_name)>
 496
 497 This will construct an instance of B<Class::MOP::Class>, it is
 498 here so that we can actually "tie the knot" for B<Class::MOP::Class>
 499 to use C<construct_instance> once all the bootstrapping is done. This
 500 method is used internally by C<initialize> and should never be called
 501 from outside of that method really.
 502
 503 =back
 504
 505 =head2 Informational
 506
 507 =over 4
 508
 509 =item B<name>
 510
 511 This is a read-only attribute which returns the package name that
 512 the Class is stored in.
 513
 514 =item B<version>
 515
 516 This is a read-only attribute which returns the C<$VERSION> of the
 517 package the Class is stored in.
 518
 519 =back
 520
 521 =head2 Inheritance Relationships
 522
 523 =over 4
 524
 525 =item B<superclasses (?@superclasses)>
 526
 527 This is a read-write attribute which represents the superclass
 528 relationships of this Class. Basically, it can get and set the
 529 C<@ISA> for you.
 530
 531 =item B<class_precedence_list>
 532
 533 This computes the a list of the Class's ancestors in the same order
 534 in which method dispatch will be done.
 535
 536 =back
 537
 538 =head2 Methods
 539
 540 =over 4
 541
 542 =item B<add_method ($method_name, $method)>
 543
 544 This will take a C<$method_name> and CODE reference to that
 545 C<$method> and install it into the Class.
 546
 547 B<NOTE> : This does absolutely nothing special to C<$method>
 548 other than use B<Sub::Name> to make sure it is tagged with the
 549 correct name, and therefore show up correctly in stack traces and
 550 such.
 551
 552 =item B<has_method ($method_name)>
 553
 554 This just provides a simple way to check if the Class implements
 555 a specific C<$method_name>. It will I<not> however, attempt to check
 556 if the class inherits the method.
 557
 558 This will correctly handle functions defined outside of the package
 559 that use a fully qualified name (C<sub Package::name { ... }>).
 560
 561 This will correctly handle functions renamed with B<Sub::Name> and
 562 installed using the symbol tables. However, if you are naming the
 563 subroutine outside of the package scope, you must use the fully
 564 qualified name, including the package name, for C<has_method> to
 565 correctly identify it.
 566
 567 This will attempt to correctly ignore functions imported from other
 568 packages using B<Exporter>. It breaks down if the function imported
 569 is an C<__ANON__> sub (such as with C<use constant>), which very well
 570 may be a valid method being applied to the class.
 571
 572 In short, this method cannot always be trusted to determine if the
 573 C<$method_name> is actually a method. However, it will DWIM about
 574 90% of the time, so it's a small trade off IMO.
 575
 576 =item B<get_method ($method_name)>
 577
 578 This will return a CODE reference of the specified C<$method_name>,
 579 or return undef if that method does not exist.
 580
 581 =item B<remove_method ($method_name)>
 582
 583 This will attempt to remove a given C<$method_name> from the Class.
 584 It will return the CODE reference that it has removed, and will
 585 attempt to use B<Sub::Name> to clear the methods associated name.
 586
 587 =item B<get_method_list>
 588
 589 This will return a list of method names for all I<locally> defined
 590 methods. It does B<not> provide a list of all applicable methods,
 591 including any inherited ones. If you want a list of all applicable
 592 methods, use the C<compute_all_applicable_methods> method.
 593
 594 =item B<compute_all_applicable_methods>
 595
 596 This will return a list of all the methods names this Class will
 597 support, taking into account inheritance. The list will be a list of
 598 HASH references, each one containing the following information; method
 599 name, the name of the class in which the method lives and a CODE
 600 reference for the actual method.
 601
 602 =item B<find_all_methods_by_name ($method_name)>
 603
 604 This will traverse the inheritence hierarchy and locate all methods
 605 with a given C<$method_name>. Similar to
 606 C<compute_all_applicable_methods> it returns a list of HASH references
 607 with the following information; method name (which will always be the
 608 same as C<$method_name>), the name of the class in which the method
 609 lives and a CODE reference for the actual method.
 610
 611 The list of methods produced is a distinct list, meaning there are no
 612 duplicates in it. This is especially useful for things like object
 613 initialization and destruction where you only want the method called
 614 once, and in the correct order.
 615
 616 =back
 617
 618 =head2 Attributes
 619
 620 It should be noted that since there is no one consistent way to define
 621 the attributes of a class in Perl 5. These methods can only work with
 622 the information given, and can not easily discover information on
 623 their own.
 624
 625 =over 4
 626
 627 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 628
 629 This stores a C<$attribute_meta_object> in the Class object and
 630 associates it with the C<$attribute_name>. Unlike methods, attributes
 631 within the MOP are stored as meta-information only. They will be used
 632 later to construct instances from (see C<construct_instance> above).
 633 More details about the attribute meta-objects can be found in the
 634 L<The Attribute protocol> section of this document.
 635
 636 =item B<has_attribute ($attribute_name)>
 637
 638 Checks to see if this Class has an attribute by the name of
 639 C<$attribute_name> and returns a boolean.
 640
 641 =item B<get_attribute ($attribute_name)>
 642
 643 Returns the attribute meta-object associated with C<$attribute_name>,
 644 if none is found, it will return undef.
 645
 646 =item B<remove_attribute ($attribute_name)>
 647
 648 This will remove the attribute meta-object stored at
 649 C<$attribute_name>, then return the removed attribute meta-object.
 650
 651 B<NOTE:> Removing an attribute will only affect future instances of
 652 the class, it will not make any attempt to remove the attribute from
 653 any existing instances of the class.
 654
 655 =item B<get_attribute_list>
 656
 657 This returns a list of attribute names which are defined in the local
 658 class. If you want a list of all applicable attributes for a class,
 659 use the C<compute_all_applicable_attributes> method.
 660
 661 =item B<compute_all_applicable_attributes>
 662
 663 This will traverse the inheritance heirachy and return a list of HASH
 664 references for all the applicable attributes for this class. The HASH
 665 references will contain the following information; the attribute name,
 666 the class which the attribute is associated with and the actual
 667 attribute meta-object.
 668
 669 =back
 670
 671 =head2 Package Variables
 672
 673 Since Perl's classes are built atop the Perl package system, it is
 674 fairly common to use package scoped variables for things like static
 675 class variables. The following methods are convience methods for
 676 the creation and inspection of package scoped variables.
 677
 678 =over 4
 679
 680 =item B<add_package_variable ($variable_name, ?$initial_value)>
 681
 682 Given a C<$variable_name>, which must contain a leading sigil, this
 683 method will create that variable within the package which houses the
 684 class. It also takes an optional C<$initial_value>, which must be a
 685 reference of the same type as the sigil of the C<$variable_name>
 686 implies.
 687
 688 =item B<get_package_variable ($variable_name)>
 689
 690 This will return a reference to the package variable in
 691 C<$variable_name>.
 692
 693 =item B<has_package_variable ($variable_name)>
 694
 695 Returns true (C<1>) if there is a package variable defined for
 696 C<$variable_name>, and false (C<0>) otherwise.
 697
 698 =item B<remove_package_variable ($variable_name)>
 699
 700 This will attempt to remove the package variable at C<$variable_name>.
 701
 702 =back
 703
 704 =head1 AUTHOR
 705
 706 Stevan Little E<gt>stevan@iinteractive.comE<lt>
 707
 708 =head1 COPYRIGHT AND LICENSE
 709
 710 Copyright 2006 by Infinity Interactive, Inc.
 711
 712 L<http://www.iinteractive.com>
 713
 714 This library is free software; you can redistribute it and/or modify
 715 it under the same terms as Perl itself.
 716
 717 =cut