lib/Class/MOP.pm

   1
   2 package Class::MOP;
   3
   4 use strict;
   5 use warnings;
   6
   7 use MRO::Compat;
   8
   9 use Carp          'confess';
  10 use Scalar::Util  'weaken';
  11
  12 use Sub::Identify 'get_code_info';
  13
  14 BEGIN {
  15     local $@;
  16     eval {
  17         require Sub::Name;
  18         Sub::Name->import(qw(subname));
  19         1
  20     } or eval 'sub subname { $_[1] }';
  21
  22     # this is either part of core or set up appropriately by MRO::Compat
  23     *check_package_cache_flag = \&mro::get_pkg_gen;
  24
  25     eval {
  26         require Devel::GlobalDestruction;
  27         Devel::GlobalDestruction->import("in_global_destruction");
  28         1;
  29     } or *in_global_destruction = sub () { '' };
  30 }
  31
  32
  33 use Class::MOP::Class;
  34 use Class::MOP::Attribute;
  35 use Class::MOP::Method;
  36
  37 use Class::MOP::Immutable;
  38
  39 BEGIN {
  40     *IS_RUNNING_ON_5_10 = ($] < 5.009_005)
  41         ? sub () { 0 }
  42         : sub () { 1 };
  43
  44     *HAVE_ISAREV = defined(&mro::get_isarev)
  45         ? sub () { 1 }
  46         : sub () { 1 };
  47 }
  48
  49 our $VERSION   = '0.65';
  50 our $AUTHORITY = 'cpan:STEVAN';
  51
  52 # after that everything is loaded, if we're allowed try to load faster XS
  53 # versions of various things
  54 unless ($ENV{CLASS_MOP_NO_XS}) {
  55     my $e = do {
  56         local $@;
  57         eval {
  58             require XSLoader;
  59             __PACKAGE__->XSLoader::load($VERSION);
  60         };
  61         $@;
  62     };
  63
  64     die $e if $e && $e !~ /object version|loadable object/;
  65 }
  66
  67 {
  68     # Metaclasses are singletons, so we cache them here.
  69     # there is no need to worry about destruction though
  70     # because they should die only when the program dies.
  71     # After all, do package definitions even get reaped?
  72     my %METAS;
  73
  74     # means of accessing all the metaclasses that have
  75     # been initialized thus far (for mugwumps obj browser)
  76     sub get_all_metaclasses         {        %METAS         }
  77     sub get_all_metaclass_instances { values %METAS         }
  78     sub get_all_metaclass_names     { keys   %METAS         }
  79     sub get_metaclass_by_name       { $METAS{$_[0]}         }
  80     sub store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
  81     sub weaken_metaclass            { weaken($METAS{$_[0]}) }
  82     sub does_metaclass_exist        { exists $METAS{$_[0]} && defined $METAS{$_[0]} }
  83     sub remove_metaclass_by_name    { $METAS{$_[0]} = undef }
  84
  85     # NOTE:
  86     # We only cache metaclasses, meaning instances of
  87     # Class::MOP::Class. We do not cache instance of
  88     # Class::MOP::Package or Class::MOP::Module. Mostly
  89     # because I don't yet see a good reason to do so.
  90 }
  91
  92 sub load_class {
  93     my $class = shift;
  94
  95     if (ref($class) || !defined($class) || !length($class)) {
  96         my $display = defined($class) ? $class : 'undef';
  97         confess "Invalid class name ($display)";
  98     }
  99
 100     # if the class is not already loaded in the symbol table..
 101     unless (is_class_loaded($class)) {
 102         # require it
 103         my $file = $class . '.pm';
 104         $file =~ s{::}{/}g;
 105         my $e = do { local $@; eval { require($file) }; $@ };
 106         confess "Could not load class ($class) because : $e" if $e;
 107     }
 108
 109     # initialize a metaclass if necessary
 110     unless (does_metaclass_exist($class)) {
 111         my $e = do { local $@; eval { Class::MOP::Class->initialize($class) }; $@ };
 112         confess "Could not initialize class ($class) because : $e" if $e;
 113     }
 114
 115     return get_metaclass_by_name($class) if defined wantarray;
 116 }
 117
 118 sub is_class_loaded {
 119     my $class = shift;
 120
 121     return 0 if ref($class) || !defined($class) || !length($class);
 122
 123     # walk the symbol table tree to avoid autovififying
 124     # \*{${main::}{"Foo::"}} == \*main::Foo::
 125
 126     my $pack = \*::;
 127     foreach my $part (split('::', $class)) {
 128         return 0 unless exists ${$$pack}{"${part}::"};
 129         $pack = \*{${$$pack}{"${part}::"}};
 130     }
 131
 132     # check for $VERSION or @ISA
 133     return 1 if exists ${$$pack}{VERSION}
 134              && defined *{${$$pack}{VERSION}}{SCALAR};
 135     return 1 if exists ${$$pack}{ISA}
 136              && defined *{${$$pack}{ISA}}{ARRAY};
 137
 138     # check for any method
 139     foreach ( keys %{$$pack} ) {
 140         next if substr($_, -2, 2) eq '::';
 141
 142         my $glob = ${$$pack}{$_} || next;
 143
 144         # constant subs
 145         if ( IS_RUNNING_ON_5_10 ) {
 146             return 1 if ref $glob eq 'SCALAR';
 147         }
 148
 149         return 1 if defined *{$glob}{CODE};
 150     }
 151
 152     # fail
 153     return 0;
 154 }
 155
 156
 157 ## ----------------------------------------------------------------------------
 158 ## Setting up our environment ...
 159 ## ----------------------------------------------------------------------------
 160 ## Class::MOP needs to have a few things in the global perl environment so
 161 ## that it can operate effectively. Those things are done here.
 162 ## ----------------------------------------------------------------------------
 163
 164 # ... nothing yet actually ;)
 165
 166 ## ----------------------------------------------------------------------------
 167 ## Bootstrapping
 168 ## ----------------------------------------------------------------------------
 169 ## The code below here is to bootstrap our MOP with itself. This is also
 170 ## sometimes called "tying the knot". By doing this, we make it much easier
 171 ## to extend the MOP through subclassing and such since now you can use the
 172 ## MOP itself to extend itself.
 173 ##
 174 ## Yes, I know, thats weird and insane, but it's a good thing, trust me :)
 175 ## ----------------------------------------------------------------------------
 176
 177 # We need to add in the meta-attributes here so that
 178 # any subclass of Class::MOP::* will be able to
 179 # inherit them using &construct_instance
 180
 181 ## --------------------------------------------------------
 182 ## Class::MOP::Package
 183
 184 Class::MOP::Package->meta->add_attribute(
 185     Class::MOP::Attribute->new('package' => (
 186         reader   => {
 187             # NOTE: we need to do this in order
 188             # for the instance meta-object to
 189             # not fall into meta-circular death
 190             #
 191             # we just alias the original method
 192             # rather than re-produce it here
 193             'name' => \&Class::MOP::Package::name
 194         },
 195     ))
 196 );
 197
 198 Class::MOP::Package->meta->add_attribute(
 199     Class::MOP::Attribute->new('namespace' => (
 200         reader => {
 201             # NOTE:
 202             # we just alias the original method
 203             # rather than re-produce it here
 204             'namespace' => \&Class::MOP::Package::namespace
 205         },
 206         init_arg => undef,
 207         default  => sub { \undef }
 208     ))
 209 );
 210
 211 # NOTE:
 212 # use the metaclass to construct the meta-package
 213 # which is a superclass of the metaclass itself :P
 214 Class::MOP::Package->meta->add_method('initialize' => sub {
 215     my $class        = shift;
 216     my $package_name = shift;
 217     $class->meta->new_object('package' => $package_name, @_);
 218 });
 219
 220 ## --------------------------------------------------------
 221 ## Class::MOP::Module
 222
 223 # NOTE:
 224 # yeah this is kind of stretching things a bit,
 225 # but truthfully the version should be an attribute
 226 # of the Module, the weirdness comes from having to
 227 # stick to Perl 5 convention and store it in the
 228 # $VERSION package variable. Basically if you just
 229 # squint at it, it will look how you want it to look.
 230 # Either as a package variable, or as a attribute of
 231 # the metaclass, isn't abstraction great :)
 232
 233 Class::MOP::Module->meta->add_attribute(
 234     Class::MOP::Attribute->new('version' => (
 235         reader => {
 236             # NOTE:
 237             # we just alias the original method
 238             # rather than re-produce it here
 239             'version' => \&Class::MOP::Module::version
 240         },
 241         init_arg => undef,
 242         default  => sub { \undef }
 243     ))
 244 );
 245
 246 # NOTE:
 247 # By following the same conventions as version here,
 248 # we are opening up the possibility that people can
 249 # use the $AUTHORITY in non-Class::MOP modules as
 250 # well.
 251
 252 Class::MOP::Module->meta->add_attribute(
 253     Class::MOP::Attribute->new('authority' => (
 254         reader => {
 255             # NOTE:
 256             # we just alias the original method
 257             # rather than re-produce it here
 258             'authority' => \&Class::MOP::Module::authority
 259         },
 260         init_arg => undef,
 261         default  => sub { \undef }
 262     ))
 263 );
 264
 265 ## --------------------------------------------------------
 266 ## Class::MOP::Class
 267
 268 Class::MOP::Class->meta->add_attribute(
 269     Class::MOP::Attribute->new('attributes' => (
 270         reader   => {
 271             # NOTE: we need to do this in order
 272             # for the instance meta-object to
 273             # not fall into meta-circular death
 274             #
 275             # we just alias the original method
 276             # rather than re-produce it here
 277             'get_attribute_map' => \&Class::MOP::Class::get_attribute_map
 278         },
 279         default  => sub { {} }
 280     ))
 281 );
 282
 283 Class::MOP::Class->meta->add_attribute(
 284     Class::MOP::Attribute->new('methods' => (
 285         reader   => {
 286             # NOTE:
 287             # we just alias the original method
 288             # rather than re-produce it here
 289             'get_method_map' => \&Class::MOP::Class::get_method_map
 290         },
 291         default => sub { {} }
 292     ))
 293 );
 294
 295 Class::MOP::Class->meta->add_attribute(
 296     Class::MOP::Attribute->new('superclasses' => (
 297         accessor => {
 298             # NOTE:
 299             # we just alias the original method
 300             # rather than re-produce it here
 301             'superclasses' => \&Class::MOP::Class::superclasses
 302         },
 303         init_arg => undef,
 304         default  => sub { \undef }
 305     ))
 306 );
 307
 308 Class::MOP::Class->meta->add_attribute(
 309     Class::MOP::Attribute->new('attribute_metaclass' => (
 310         reader   => {
 311             # NOTE:
 312             # we just alias the original method
 313             # rather than re-produce it here
 314             'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass
 315         },
 316         default  => 'Class::MOP::Attribute',
 317     ))
 318 );
 319
 320 Class::MOP::Class->meta->add_attribute(
 321     Class::MOP::Attribute->new('method_metaclass' => (
 322         reader   => {
 323             # NOTE:
 324             # we just alias the original method
 325             # rather than re-produce it here
 326             'method_metaclass' => \&Class::MOP::Class::method_metaclass
 327         },
 328         default  => 'Class::MOP::Method',
 329     ))
 330 );
 331
 332 Class::MOP::Class->meta->add_attribute(
 333     Class::MOP::Attribute->new('instance_metaclass' => (
 334         reader   => {
 335             # NOTE: we need to do this in order
 336             # for the instance meta-object to
 337             # not fall into meta-circular death
 338             #
 339             # we just alias the original method
 340             # rather than re-produce it here
 341             'instance_metaclass' => \&Class::MOP::Class::instance_metaclass
 342         },
 343         default  => 'Class::MOP::Instance',
 344     ))
 345 );
 346
 347 # NOTE:
 348 # we don't actually need to tie the knot with
 349 # Class::MOP::Class here, it is actually handled
 350 # within Class::MOP::Class itself in the
 351 # construct_class_instance method.
 352
 353 ## --------------------------------------------------------
 354 ## Class::MOP::Attribute
 355
 356 Class::MOP::Attribute->meta->add_attribute(
 357     Class::MOP::Attribute->new('name' => (
 358         reader   => {
 359             # NOTE: we need to do this in order
 360             # for the instance meta-object to
 361             # not fall into meta-circular death
 362             #
 363             # we just alias the original method
 364             # rather than re-produce it here
 365             'name' => \&Class::MOP::Attribute::name
 366         }
 367     ))
 368 );
 369
 370 Class::MOP::Attribute->meta->add_attribute(
 371     Class::MOP::Attribute->new('associated_class' => (
 372         reader   => {
 373             # NOTE: we need to do this in order
 374             # for the instance meta-object to
 375             # not fall into meta-circular death
 376             #
 377             # we just alias the original method
 378             # rather than re-produce it here
 379             'associated_class' => \&Class::MOP::Attribute::associated_class
 380         }
 381     ))
 382 );
 383
 384 Class::MOP::Attribute->meta->add_attribute(
 385     Class::MOP::Attribute->new('accessor' => (
 386         reader    => { 'accessor'     => \&Class::MOP::Attribute::accessor     },
 387         predicate => { 'has_accessor' => \&Class::MOP::Attribute::has_accessor },
 388     ))
 389 );
 390
 391 Class::MOP::Attribute->meta->add_attribute(
 392     Class::MOP::Attribute->new('reader' => (
 393         reader    => { 'reader'     => \&Class::MOP::Attribute::reader     },
 394         predicate => { 'has_reader' => \&Class::MOP::Attribute::has_reader },
 395     ))
 396 );
 397
 398 Class::MOP::Attribute->meta->add_attribute(
 399     Class::MOP::Attribute->new('initializer' => (
 400         reader    => { 'initializer'     => \&Class::MOP::Attribute::initializer     },
 401         predicate => { 'has_initializer' => \&Class::MOP::Attribute::has_initializer },
 402     ))
 403 );
 404
 405 Class::MOP::Attribute->meta->add_attribute(
 406     Class::MOP::Attribute->new('writer' => (
 407         reader    => { 'writer'     => \&Class::MOP::Attribute::writer     },
 408         predicate => { 'has_writer' => \&Class::MOP::Attribute::has_writer },
 409     ))
 410 );
 411
 412 Class::MOP::Attribute->meta->add_attribute(
 413     Class::MOP::Attribute->new('predicate' => (
 414         reader    => { 'predicate'     => \&Class::MOP::Attribute::predicate     },
 415         predicate => { 'has_predicate' => \&Class::MOP::Attribute::has_predicate },
 416     ))
 417 );
 418
 419 Class::MOP::Attribute->meta->add_attribute(
 420     Class::MOP::Attribute->new('clearer' => (
 421         reader    => { 'clearer'     => \&Class::MOP::Attribute::clearer     },
 422         predicate => { 'has_clearer' => \&Class::MOP::Attribute::has_clearer },
 423     ))
 424 );
 425
 426 Class::MOP::Attribute->meta->add_attribute(
 427     Class::MOP::Attribute->new('builder' => (
 428         reader    => { 'builder'     => \&Class::MOP::Attribute::builder     },
 429         predicate => { 'has_builder' => \&Class::MOP::Attribute::has_builder },
 430     ))
 431 );
 432
 433 Class::MOP::Attribute->meta->add_attribute(
 434     Class::MOP::Attribute->new('init_arg' => (
 435         reader    => { 'init_arg'     => \&Class::MOP::Attribute::init_arg     },
 436         predicate => { 'has_init_arg' => \&Class::MOP::Attribute::has_init_arg },
 437     ))
 438 );
 439
 440 Class::MOP::Attribute->meta->add_attribute(
 441     Class::MOP::Attribute->new('default' => (
 442         # default has a custom 'reader' method ...
 443         predicate => { 'has_default' => \&Class::MOP::Attribute::has_default },
 444     ))
 445 );
 446
 447 Class::MOP::Attribute->meta->add_attribute(
 448     Class::MOP::Attribute->new('associated_methods' => (
 449         reader   => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods },
 450         default  => sub { [] }
 451     ))
 452 );
 453
 454 # NOTE: (meta-circularity)
 455 # This should be one of the last things done
 456 # it will "tie the knot" with Class::MOP::Attribute
 457 # so that it uses the attributes meta-objects
 458 # to construct itself.
 459 Class::MOP::Attribute->meta->add_method('new' => sub {
 460     my ( $class, @args ) = @_;
 461
 462     unshift @args, "name" if @args % 2 == 1;
 463     my %options = @args;
 464
 465     my $name = $options{name};
 466
 467     (defined $name && $name)
 468         || confess "You must provide a name for the attribute";
 469     $options{init_arg} = $name
 470         if not exists $options{init_arg};
 471
 472     if(exists $options{builder}){
 473         confess("builder must be a defined scalar value which is a method name")
 474             if ref $options{builder} || !(defined $options{builder});
 475         confess("Setting both default and builder is not allowed.")
 476             if exists $options{default};
 477     } else {
 478         (Class::MOP::Attribute::is_default_a_coderef(\%options))
 479             || confess("References are not allowed as default values, you must ".
 480                        "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
 481                 if exists $options{default} && ref $options{default};
 482     }
 483
 484     # return the new object
 485     $class->meta->new_object(%options);
 486 });
 487
 488 Class::MOP::Attribute->meta->add_method('clone' => sub {
 489     my $self  = shift;
 490     $self->meta->clone_object($self, @_);
 491 });
 492
 493 ## --------------------------------------------------------
 494 ## Class::MOP::Method
 495 Class::MOP::Method->meta->add_attribute(
 496     Class::MOP::Attribute->new('body' => (
 497         reader   => { 'body' => \&Class::MOP::Method::body },
 498     ))
 499 );
 500
 501 Class::MOP::Method->meta->add_attribute(
 502     Class::MOP::Attribute->new('associated_metaclass' => (
 503         reader   => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass },
 504     ))
 505 );
 506
 507 Class::MOP::Method->meta->add_attribute(
 508     Class::MOP::Attribute->new('package_name' => (
 509         reader   => { 'package_name' => \&Class::MOP::Method::package_name },
 510     ))
 511 );
 512
 513 Class::MOP::Method->meta->add_attribute(
 514     Class::MOP::Attribute->new('name' => (
 515         reader   => { 'name' => \&Class::MOP::Method::name },
 516     ))
 517 );
 518
 519 # FIMXE prime candidate for immutablization
 520 Class::MOP::Method->meta->add_method('wrap' => sub {
 521     my ( $class, @args ) = @_;
 522
 523     unshift @args, 'body' if @args % 2 == 1;
 524
 525     my %options = @args;
 526     my $code = $options{body};
 527
 528     ('CODE' eq ref($code))
 529         || confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")";
 530
 531     ($options{package_name} && $options{name})
 532         || confess "You must supply the package_name and name parameters";
 533
 534     # return the new object
 535     $class->meta->new_object(%options);
 536 });
 537
 538 Class::MOP::Method->meta->add_method('clone' => sub {
 539     my $self  = shift;
 540     $self->meta->clone_object($self, @_);
 541 });
 542
 543 ## --------------------------------------------------------
 544 ## Class::MOP::Method::Wrapped
 545
 546 # NOTE:
 547 # the way this item is initialized, this
 548 # really does not follow the standard
 549 # practices of attributes, but we put
 550 # it here for completeness
 551 Class::MOP::Method::Wrapped->meta->add_attribute(
 552     Class::MOP::Attribute->new('modifier_table')
 553 );
 554
 555 ## --------------------------------------------------------
 556 ## Class::MOP::Method::Generated
 557
 558 Class::MOP::Method::Generated->meta->add_attribute(
 559     Class::MOP::Attribute->new('is_inline' => (
 560         reader   => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline },
 561         default  => 0,
 562     ))
 563 );
 564
 565 Class::MOP::Method::Generated->meta->add_method('new' => sub {
 566     my ($class, %options) = @_;
 567     ($options{package_name} && $options{name})
 568         || confess "You must supply the package_name and name parameters";
 569     my $self = $class->meta->new_object(%options);
 570     $self->initialize_body;
 571     $self;
 572 });
 573
 574 ## --------------------------------------------------------
 575 ## Class::MOP::Method::Accessor
 576
 577 Class::MOP::Method::Accessor->meta->add_attribute(
 578     Class::MOP::Attribute->new('attribute' => (
 579         reader   => {
 580             'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute
 581         },
 582     ))
 583 );
 584
 585 Class::MOP::Method::Accessor->meta->add_attribute(
 586     Class::MOP::Attribute->new('accessor_type' => (
 587         reader   => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type },
 588     ))
 589 );
 590
 591 Class::MOP::Method::Accessor->meta->add_method('new' => sub {
 592     my $class   = shift;
 593     my %options = @_;
 594
 595     (exists $options{attribute})
 596         || confess "You must supply an attribute to construct with";
 597
 598     (exists $options{accessor_type})
 599         || confess "You must supply an accessor_type to construct with";
 600
 601     (Scalar::Util::blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
 602         || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
 603
 604     ($options{package_name} && $options{name})
 605         || confess "You must supply the package_name and name parameters";
 606
 607     # return the new object
 608     my $self = $class->meta->new_object(%options);
 609
 610     # we don't want this creating
 611     # a cycle in the code, if not
 612     # needed
 613     Scalar::Util::weaken($self->{'attribute'});
 614
 615     $self->initialize_body;
 616
 617     $self;
 618 });
 619
 620
 621 ## --------------------------------------------------------
 622 ## Class::MOP::Method::Constructor
 623
 624 Class::MOP::Method::Constructor->meta->add_attribute(
 625     Class::MOP::Attribute->new('options' => (
 626         reader   => {
 627             'options' => \&Class::MOP::Method::Constructor::options
 628         },
 629         default  => sub { +{} }
 630     ))
 631 );
 632
 633 Class::MOP::Method::Constructor->meta->add_attribute(
 634     Class::MOP::Attribute->new('associated_metaclass' => (
 635         init_arg => "metaclass", # FIXME alias and rename
 636         reader   => {
 637             'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass
 638         },
 639     ))
 640 );
 641
 642 Class::MOP::Method::Constructor->meta->add_method('new' => sub {
 643     my $class   = shift;
 644     my %options = @_;
 645
 646     (Scalar::Util::blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
 647         || confess "You must pass a metaclass instance if you want to inline"
 648             if $options{is_inline};
 649
 650     ($options{package_name} && $options{name})
 651         || confess "You must supply the package_name and name parameters";
 652
 653     # return the new object
 654     my $self = $class->meta->new_object(%options);
 655
 656     # we don't want this creating
 657     # a cycle in the code, if not
 658     # needed
 659     Scalar::Util::weaken($self->{'associated_metaclass'});
 660
 661     $self->initialize_body;
 662
 663     $self;
 664 });
 665
 666 ## --------------------------------------------------------
 667 ## Class::MOP::Instance
 668
 669 # NOTE:
 670 # these don't yet do much of anything, but are just
 671 # included for completeness
 672
 673 Class::MOP::Instance->meta->add_attribute(
 674     Class::MOP::Attribute->new('associated_metaclass',
 675         reader   => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass },
 676     ),
 677 );
 678
 679 Class::MOP::Instance->meta->add_attribute(
 680     Class::MOP::Attribute->new('_class_name',
 681         init_arg => undef,
 682         reader   => { _class_name => \&Class::MOP::Instance::_class_name },
 683         #lazy     => 1, # not yet supported by Class::MOP but out our version does it anyway
 684         #default  => sub { $_[0]->associated_metaclass->name },
 685     ),
 686 );
 687
 688 Class::MOP::Instance->meta->add_attribute(
 689     Class::MOP::Attribute->new('attributes',
 690         reader   => { attributes => \&Class::MOP::Instance::attributes },
 691     ),
 692 );
 693
 694 Class::MOP::Instance->meta->add_attribute(
 695     Class::MOP::Attribute->new('slots',
 696         reader   => { slots => \&Class::MOP::Instance::slots },
 697     ),
 698 );
 699
 700 Class::MOP::Instance->meta->add_attribute(
 701     Class::MOP::Attribute->new('slot_hash',
 702         reader   => { slot_hash => \&Class::MOP::Instance::slot_hash },
 703     ),
 704 );
 705
 706
 707 # we need the meta instance of the meta instance to be created now, in order
 708 # for the constructor to be able to use it
 709 Class::MOP::Instance->meta->get_meta_instance;
 710
 711 Class::MOP::Instance->meta->add_method('new' => sub {
 712     my $class   = shift;
 713     my $options = $class->BUILDARGS(@_);
 714
 715     my $self = $class->meta->new_object(%$options);
 716
 717     Scalar::Util::weaken($self->{'associated_metaclass'});
 718
 719     $self;
 720 });
 721
 722 # pretend the add_method never happenned. it hasn't yet affected anything
 723 undef Class::MOP::Instance->meta->{_package_cache_flag};
 724
 725 ## --------------------------------------------------------
 726 ## Now close all the Class::MOP::* classes
 727
 728 # NOTE:
 729 # we don't need to inline the
 730 # constructors or the accessors
 731 # this only lengthens the compile
 732 # time of the MOP, and gives us
 733 # no actual benefits.
 734
 735 $_->meta->make_immutable(
 736     ( $_->can("_new") ? (
 737         inline_constructor => 1,
 738         constructor_name   => "_new",
 739     ) : (
 740         inline_constructor => 0,
 741     ) ),
 742     inline_accessors => 0,
 743 ) for qw/
 744     Class::MOP::Package
 745     Class::MOP::Module
 746     Class::MOP::Class
 747
 748     Class::MOP::Attribute
 749     Class::MOP::Method
 750     Class::MOP::Instance
 751
 752     Class::MOP::Object
 753
 754     Class::MOP::Method::Generated
 755
 756     Class::MOP::Method::Accessor
 757     Class::MOP::Method::Constructor
 758     Class::MOP::Method::Wrapped
 759 /;
 760
 761 1;
 762
 763 __END__
 764
 765 =pod
 766
 767 =head1 NAME
 768
 769 Class::MOP - A Meta Object Protocol for Perl 5
 770
 771 =head1 DESCRIPTON
 772
 773 This module is a fully functioning meta object protocol for the
 774 Perl 5 object system. It makes no attempt to change the behavior or
 775 characteristics of the Perl 5 object system, only to create a
 776 protocol for its manipulation and introspection.
 777
 778 That said, it does attempt to create the tools for building a rich
 779 set of extensions to the Perl 5 object system. Every attempt has been
 780 made for these tools to keep to the spirit of the Perl 5 object
 781 system that we all know and love.
 782
 783 This documentation is admittedly sparse on details, as time permits
 784 I will try to improve them. For now, I suggest looking at the items
 785 listed in the L<SEE ALSO> section for more information. In particular
 786 the book "The Art of the Meta Object Protocol" was very influential
 787 in the development of this system.
 788
 789 =head2 What is a Meta Object Protocol?
 790
 791 A meta object protocol is an API to an object system.
 792
 793 To be more specific, it is a set of abstractions of the components of
 794 an object system (typically things like; classes, object, methods,
 795 object attributes, etc.). These abstractions can then be used to both
 796 inspect and manipulate the object system which they describe.
 797
 798 It can be said that there are two MOPs for any object system; the
 799 implicit MOP, and the explicit MOP. The implicit MOP handles things
 800 like method dispatch or inheritance, which happen automatically as
 801 part of how the object system works. The explicit MOP typically
 802 handles the introspection/reflection features of the object system.
 803 All object systems have implicit MOPs, without one, they would not
 804 work. Explict MOPs however as less common, and depending on the
 805 language can vary from restrictive (Reflection in Java or C#) to
 806 wide open (CLOS is a perfect example).
 807
 808 =head2 Yet Another Class Builder!! Why?
 809
 810 This is B<not> a class builder so much as it is a I<class builder
 811 B<builder>>. My intent is that an end user does not use this module
 812 directly, but instead this module is used by module authors to
 813 build extensions and features onto the Perl 5 object system.
 814
 815 =head2 Who is this module for?
 816
 817 This module is specifically for anyone who has ever created or
 818 wanted to create a module for the Class:: namespace. The tools which
 819 this module will provide will hopefully make it easier to do more
 820 complex things with Perl 5 classes by removing such barriers as
 821 the need to hack the symbol tables, or understand the fine details
 822 of method dispatch.
 823
 824 =head2 What changes do I have to make to use this module?
 825
 826 This module was designed to be as unintrusive as possible. Many of
 827 its features are accessible without B<any> change to your existsing
 828 code at all. It is meant to be a compliment to your existing code and
 829 not an intrusion on your code base. Unlike many other B<Class::>
 830 modules, this module B<does not> require you subclass it, or even that
 831 you C<use> it in within your module's package.
 832
 833 The only features which requires additions to your code are the
 834 attribute handling and instance construction features, and these are
 835 both completely optional features. The only reason for this is because
 836 Perl 5's object system does not actually have these features built
 837 in. More information about this feature can be found below.
 838
 839 =head2 A Note about Performance?
 840
 841 It is a common misconception that explict MOPs are performance drains.
 842 But this is not a universal truth at all, it is an side-effect of
 843 specific implementations. For instance, using Java reflection is much
 844 slower because the JVM cannot take advantage of any compiler
 845 optimizations, and the JVM has to deal with much more runtime type
 846 information as well. Reflection in C# is marginally better as it was
 847 designed into the language and runtime (the CLR). In contrast, CLOS
 848 (the Common Lisp Object System) was built to support an explicit MOP,
 849 and so performance is tuned for it.
 850
 851 This library in particular does it's absolute best to avoid putting
 852 B<any> drain at all upon your code's performance. In fact, by itself
 853 it does nothing to affect your existing code. So you only pay for
 854 what you actually use.
 855
 856 =head2 About Metaclass compatibility
 857
 858 This module makes sure that all metaclasses created are both upwards
 859 and downwards compatible. The topic of metaclass compatibility is
 860 highly esoteric and is something only encountered when doing deep and
 861 involved metaclass hacking. There are two basic kinds of metaclass
 862 incompatibility; upwards and downwards.
 863
 864 Upwards metaclass compatibility means that the metaclass of a
 865 given class is either the same as (or a subclass of) all of the
 866 class's ancestors.
 867
 868 Downward metaclass compatibility means that the metaclasses of a
 869 given class's anscestors are all either the same as (or a subclass
 870 of) that metaclass.
 871
 872 Here is a diagram showing a set of two classes (C<A> and C<B>) and
 873 two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
 874 metaclass compatibility both upwards and downwards.
 875
 876     +---------+     +---------+
 877     | Meta::A |<----| Meta::B |      <....... (instance of  )
 878     +---------+     +---------+      <------- (inherits from)
 879          ^               ^
 880          :               :
 881     +---------+     +---------+
 882     |    A    |<----|    B    |
 883     +---------+     +---------+
 884
 885 As I said this is a highly esoteric topic and one you will only run
 886 into if you do a lot of subclassing of B<Class::MOP::Class>. If you
 887 are interested in why this is an issue see the paper
 888 I<Uniform and safe metaclass composition> linked to in the
 889 L<SEE ALSO> section of this document.
 890
 891 =head2 Using custom metaclasses
 892
 893 Always use the metaclass pragma when using a custom metaclass, this
 894 will ensure the proper initialization order and not accidentely
 895 create an incorrect type of metaclass for you. This is a very rare
 896 problem, and one which can only occur if you are doing deep metaclass
 897 programming. So in other words, don't worry about it.
 898
 899 =head1 PROTOCOLS
 900
 901 The protocol is divided into 4 main sub-protocols:
 902
 903 =over 4
 904
 905 =item The Class protocol
 906
 907 This provides a means of manipulating and introspecting a Perl 5
 908 class. It handles all of symbol table hacking for you, and provides
 909 a rich set of methods that go beyond simple package introspection.
 910
 911 See L<Class::MOP::Class> for more details.
 912
 913 =item The Attribute protocol
 914
 915 This provides a consistent represenation for an attribute of a
 916 Perl 5 class. Since there are so many ways to create and handle
 917 attributes in Perl 5 OO, this attempts to provide as much of a
 918 unified approach as possible, while giving the freedom and
 919 flexibility to subclass for specialization.
 920
 921 See L<Class::MOP::Attribute> for more details.
 922
 923 =item The Method protocol
 924
 925 This provides a means of manipulating and introspecting methods in
 926 the Perl 5 object system. As with attributes, there are many ways to
 927 approach this topic, so we try to keep it pretty basic, while still
 928 making it possible to extend the system in many ways.
 929
 930 See L<Class::MOP::Method> for more details.
 931
 932 =item The Instance protocol
 933
 934 This provides a layer of abstraction for creating object instances.
 935 Since the other layers use this protocol, it is relatively easy to
 936 change the type of your instances from the default HASH ref to other
 937 types of references. Several examples are provided in the F<examples/>
 938 directory included in this distribution.
 939
 940 See L<Class::MOP::Instance> for more details.
 941
 942 =back
 943
 944 =head1 FUNCTIONS
 945
 946 =head2 Constants
 947
 948 =over 4
 949
 950 =item I<IS_RUNNING_ON_5_10>
 951
 952 We set this constant depending on what version perl we are on, this
 953 allows us to take advantage of new 5.10 features and stay backwards
 954 compat.
 955
 956 =item I<HAVE_ISAREV>
 957
 958 Whether or not C<mro> provides C<get_isarev>, a much faster way to get all the
 959 subclasses of a certain class.
 960
 961 =back
 962
 963 =head2 Utility functions
 964
 965 =over 4
 966
 967 =item B<load_class ($class_name)>
 968
 969 This will load a given C<$class_name> and if it does not have an
 970 already initialized metaclass, then it will intialize one for it.
 971 This function can be used in place of tricks like
 972 C<eval "use $module"> or using C<require>.
 973
 974 =item B<is_class_loaded ($class_name)>
 975
 976 This will return a boolean depending on if the C<$class_name> has
 977 been loaded.
 978
 979 NOTE: This does a basic check of the symbol table to try and
 980 determine as best it can if the C<$class_name> is loaded, it
 981 is probably correct about 99% of the time.
 982
 983 =item B<check_package_cache_flag ($pkg)>
 984
 985 This will return an integer that is managed by C<Class::MOP::Class>
 986 to determine if a module's symbol table has been altered.
 987
 988 In Perl 5.10 or greater, this flag is package specific. However in
 989 versions prior to 5.10, this will use the C<PL_sub_generation> variable
 990 which is not package specific.
 991
 992 =item B<get_code_info ($code)>
 993
 994 This function returns two values, the name of the package the C<$code>
 995 is from and the name of the C<$code> itself. This is used by several
 996 elements of the MOP to detemine where a given C<$code> reference is from.
 997
 998 =item B<subname ($name, $code)>
 999
1000 B<NOTE: DO NOT USE THIS FUNCTION, IT IS FOR INTERNAL USE ONLY!>
1001
1002 If possible, we will load the L<Sub::Name> module and this will function
1003 as C<Sub::Name::subname> does, otherwise it will just return the C<$code>
1004 argument.
1005
1006 =item B<in_global_destruction>
1007
1008 If L<Devel::GlobalDestruction> is available, this returns true under global
1009 destruction.
1010
1011 Otherwise it's a constant returning false.
1012
1013 =back
1014
1015 =head2 Metaclass cache functions
1016
1017 Class::MOP holds a cache of metaclasses, the following are functions
1018 (B<not methods>) which can be used to access that cache. It is not
1019 recommended that you mess with this, bad things could happen. But if
1020 you are brave and willing to risk it, go for it.
1021
1022 =over 4
1023
1024 =item B<get_all_metaclasses>
1025
1026 This will return an hash of all the metaclass instances that have
1027 been cached by B<Class::MOP::Class> keyed by the package name.
1028
1029 =item B<get_all_metaclass_instances>
1030
1031 This will return an array of all the metaclass instances that have
1032 been cached by B<Class::MOP::Class>.
1033
1034 =item B<get_all_metaclass_names>
1035
1036 This will return an array of all the metaclass names that have
1037 been cached by B<Class::MOP::Class>.
1038
1039 =item B<get_metaclass_by_name ($name)>
1040
1041 This will return a cached B<Class::MOP::Class> instance of nothing
1042 if no metaclass exist by that C<$name>.
1043
1044 =item B<store_metaclass_by_name ($name, $meta)>
1045
1046 This will store a metaclass in the cache at the supplied C<$key>.
1047
1048 =item B<weaken_metaclass ($name)>
1049
1050 In rare cases it is desireable to store a weakened reference in
1051 the metaclass cache. This function will weaken the reference to
1052 the metaclass stored in C<$name>.
1053
1054 =item B<does_metaclass_exist ($name)>
1055
1056 This will return true of there exists a metaclass stored in the
1057 C<$name> key and return false otherwise.
1058
1059 =item B<remove_metaclass_by_name ($name)>
1060
1061 This will remove a the metaclass stored in the C<$name> key.
1062
1063 =back
1064
1065 =head1 SEE ALSO
1066
1067 =head2 Books
1068
1069 There are very few books out on Meta Object Protocols and Metaclasses
1070 because it is such an esoteric topic. The following books are really
1071 the only ones I have found. If you know of any more, B<I<please>>
1072 email me and let me know, I would love to hear about them.
1073
1074 =over 4
1075
1076 =item "The Art of the Meta Object Protocol"
1077
1078 =item "Advances in Object-Oriented Metalevel Architecture and Reflection"
1079
1080 =item "Putting MetaClasses to Work"
1081
1082 =item "Smalltalk: The Language"
1083
1084 =back
1085
1086 =head2 Papers
1087
1088 =over 4
1089
1090 =item Uniform and safe metaclass composition
1091
1092 An excellent paper by the people who brought us the original Traits paper.
1093 This paper is on how Traits can be used to do safe metaclass composition,
1094 and offers an excellent introduction section which delves into the topic of
1095 metaclass compatibility.
1096
1097 L<http://www.iam.unibe.ch/~scg/Archive/Papers/Duca05ySafeMetaclassTrait.pdf>
1098
1099 =item Safe Metaclass Programming
1100
1101 This paper seems to precede the above paper, and propose a mix-in based
1102 approach as opposed to the Traits based approach. Both papers have similar
1103 information on the metaclass compatibility problem space.
1104
1105 L<http://citeseer.ist.psu.edu/37617.html>
1106
1107 =back
1108
1109 =head2 Prior Art
1110
1111 =over 4
1112
1113 =item The Perl 6 MetaModel work in the Pugs project
1114
1115 =over 4
1116
1117 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel>
1118
1119 =item L<http://svn.openfoundry.org/pugs/perl5/Perl6-ObjectSpace>
1120
1121 =back
1122
1123 =back
1124
1125 =head2 Articles
1126
1127 =over 4
1128
1129 =item CPAN Module Review of Class::MOP
1130
1131 L<http://www.oreillynet.com/onlamp/blog/2006/06/cpan_module_review_classmop.html>
1132
1133 =back
1134
1135 =head1 SIMILAR MODULES
1136
1137 As I have said above, this module is a class-builder-builder, so it is
1138 not the same thing as modules like L<Class::Accessor> and
1139 L<Class::MethodMaker>. That being said there are very few modules on CPAN
1140 with similar goals to this module. The one I have found which is most
1141 like this module is L<Class::Meta>, although it's philosophy and the MOP it
1142 creates are very different from this modules.
1143
1144 =head1 BUGS
1145
1146 All complex software has bugs lurking in it, and this module is no
1147 exception. If you find a bug please either email me, or add the bug
1148 to cpan-RT.
1149
1150 =head1 ACKNOWLEDGEMENTS
1151
1152 =over 4
1153
1154 =item Rob Kinyon
1155
1156 Thanks to Rob for actually getting the development of this module kick-started.
1157
1158 =back
1159
1160 =head1 AUTHORS
1161
1162 Stevan Little E<lt>stevan@iinteractive.comE<gt>
1163
1164 B<with contributions from:>
1165
1166 Brandon (blblack) Black
1167
1168 Guillermo (groditi) Roditi
1169
1170 Matt (mst) Trout
1171
1172 Rob (robkinyon) Kinyon
1173
1174 Yuval (nothingmuch) Kogman
1175
1176 Scott (konobi) McWhirter
1177
1178 =head1 COPYRIGHT AND LICENSE
1179
1180 Copyright 2006-2008 by Infinity Interactive, Inc.
1181
1182 L<http://www.iinteractive.com>
1183
1184 This library is free software; you can redistribute it and/or modify
1185 it under the same terms as Perl itself.
1186
1187 =cut