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