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