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