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