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