lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP;
   8
   9 use Carp ();
  10 use List::Util qw( first );
  11 use List::MoreUtils qw( any all );
  12 use Scalar::Util 'weaken', 'blessed';
  13
  14 our $VERSION   = '0.57';
  15 $VERSION = eval $VERSION;
  16 our $AUTHORITY = 'cpan:STEVAN';
  17
  18 use Moose::Meta::Method::Overriden;
  19 use Moose::Meta::Method::Augmented;
  20
  21 use base 'Class::MOP::Class';
  22
  23 __PACKAGE__->meta->add_attribute('roles' => (
  24     reader  => 'roles',
  25     default => sub { [] }
  26 ));
  27
  28 __PACKAGE__->meta->add_attribute('constructor_class' => (
  29     accessor => 'constructor_class',
  30     default  => sub { 'Moose::Meta::Method::Constructor' }
  31 ));
  32
  33 __PACKAGE__->meta->add_attribute('destructor_class' => (
  34     accessor => 'destructor_class',
  35     default  => sub { 'Moose::Meta::Method::Destructor' }
  36 ));
  37
  38 __PACKAGE__->meta->add_attribute('error_builder' => (
  39     reader  => 'error_builder',
  40     default => 'confess',
  41 ));
  42
  43 __PACKAGE__->meta->add_attribute('error_class' => (
  44     reader  => 'error_class',
  45 ));
  46
  47
  48 sub initialize {
  49     my $class = shift;
  50     my $pkg   = shift;
  51     return Class::MOP::get_metaclass_by_name($pkg)
  52         || $class->SUPER::initialize($pkg,
  53                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  54                 'method_metaclass'    => 'Moose::Meta::Method',
  55                 'instance_metaclass'  => 'Moose::Meta::Instance',
  56                 @_
  57             );
  58 }
  59
  60 sub create {
  61     my ($self, $package_name, %options) = @_;
  62
  63     (ref $options{roles} eq 'ARRAY')
  64         || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  65             if exists $options{roles};
  66
  67     my $class = $self->SUPER::create($package_name, %options);
  68
  69     if (exists $options{roles}) {
  70         Moose::Util::apply_all_roles($class, @{$options{roles}});
  71     }
  72
  73     return $class;
  74 }
  75
  76 sub check_metaclass_compatibility {
  77     my $self = shift;
  78
  79     if ( my @supers = $self->superclasses ) {
  80         $self->_fix_metaclass_incompatibility(@supers);
  81     }
  82
  83     $self->SUPER::check_metaclass_compatibility(@_);
  84 }
  85
  86 my %ANON_CLASSES;
  87
  88 sub create_anon_class {
  89     my ($self, %options) = @_;
  90
  91     my $cache_ok = delete $options{cache};
  92
  93     # something like Super::Class|Super::Class::2=Role|Role::1
  94     my $cache_key = join '=' => (
  95         join('|', sort @{$options{superclasses} || []}),
  96         join('|', sort @{$options{roles}        || []}),
  97     );
  98
  99     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
 100         return $ANON_CLASSES{$cache_key};
 101     }
 102
 103     my $new_class = $self->SUPER::create_anon_class(%options);
 104
 105     $ANON_CLASSES{$cache_key} = $new_class
 106         if $cache_ok;
 107
 108     return $new_class;
 109 }
 110
 111 sub add_role {
 112     my ($self, $role) = @_;
 113     (blessed($role) && $role->isa('Moose::Meta::Role'))
 114         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
 115     push @{$self->roles} => $role;
 116 }
 117
 118 sub calculate_all_roles {
 119     my $self = shift;
 120     my %seen;
 121     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
 122 }
 123
 124 sub does_role {
 125     my ($self, $role_name) = @_;
 126     (defined $role_name)
 127         || $self->throw_error("You must supply a role name to look for");
 128     foreach my $class ($self->class_precedence_list) {
 129         next unless $class->can('meta') && $class->meta->can('roles');
 130         foreach my $role (@{$class->meta->roles}) {
 131             return 1 if $role->does_role($role_name);
 132         }
 133     }
 134     return 0;
 135 }
 136
 137 sub excludes_role {
 138     my ($self, $role_name) = @_;
 139     (defined $role_name)
 140         || $self->throw_error("You must supply a role name to look for");
 141     foreach my $class ($self->class_precedence_list) {
 142         next unless $class->can('meta');
 143         # NOTE:
 144         # in the pretty rare instance when a Moose metaclass
 145         # is itself extended with a role, this check needs to
 146         # be done since some items in the class_precedence_list
 147         # might in fact be Class::MOP based still.
 148         next unless $class->meta->can('roles');
 149         foreach my $role (@{$class->meta->roles}) {
 150             return 1 if $role->excludes_role($role_name);
 151         }
 152     }
 153     return 0;
 154 }
 155
 156 sub new_object {
 157     my $class = shift;
 158     my $params = @_ == 1 ? $_[0] : {@_};
 159     my $self = $class->SUPER::new_object($params);
 160     foreach my $attr ($class->compute_all_applicable_attributes()) {
 161         # if we have a trigger, then ...
 162         if ($attr->can('has_trigger') && $attr->has_trigger) {
 163             # make sure we have an init-arg ...
 164             if (defined(my $init_arg = $attr->init_arg)) {
 165                 # now make sure an init-arg was passes ...
 166                 if (exists $params->{$init_arg}) {
 167                     # and if get here, fire the trigger
 168                     $attr->trigger->(
 169                         $self,
 170                         # check if there is a coercion
 171                         ($attr->should_coerce
 172                             # and if so, we need to grab the
 173                             # value that is actually been stored
 174                             ? $attr->get_read_method_ref->($self)
 175                             # otherwise, just get the value from
 176                             # the constructor params
 177                             : $params->{$init_arg}),
 178                         $attr
 179                     );
 180                 }
 181             }
 182         }
 183     }
 184     return $self;
 185 }
 186
 187 sub construct_instance {
 188     my $class = shift;
 189     my $params = @_ == 1 ? $_[0] : {@_};
 190     my $meta_instance = $class->get_meta_instance;
 191     # FIXME:
 192     # the code below is almost certainly incorrect
 193     # but this is foreign inheritence, so we might
 194     # have to kludge it in the end.
 195     my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance();
 196     foreach my $attr ($class->compute_all_applicable_attributes()) {
 197         $attr->initialize_instance_slot($meta_instance, $instance, $params);
 198     }
 199     return $instance;
 200 }
 201
 202 # FIXME:
 203 # This is ugly
 204 sub get_method_map {
 205     my $self = shift;
 206
 207     my $current = Class::MOP::check_package_cache_flag($self->name);
 208
 209     if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
 210         return $self->{'methods'};
 211     }
 212
 213     $self->{_package_cache_flag} = $current;
 214
 215     my $map  = $self->{'methods'};
 216
 217     my $class_name       = $self->name;
 218     my $method_metaclass = $self->method_metaclass;
 219
 220     my %all_code = $self->get_all_package_symbols('CODE');
 221
 222     foreach my $symbol (keys %all_code) {
 223         my $code = $all_code{$symbol};
 224
 225         next if exists  $map->{$symbol} &&
 226                 defined $map->{$symbol} &&
 227                         $map->{$symbol}->body == $code;
 228
 229         my ($pkg, $name) = Class::MOP::get_code_info($code);
 230
 231         if ($pkg->can('meta')
 232             # NOTE:
 233             # we don't know what ->meta we are calling
 234             # here, so we need to be careful cause it
 235             # just might blow up at us, or just complain
 236             # loudly (in the case of Curses.pm) so we
 237             # just be a little overly cautious here.
 238             # - SL
 239             && eval { no warnings; blessed($pkg->meta) }
 240             && $pkg->meta->isa('Moose::Meta::Role')) {
 241             #my $role = $pkg->meta->name;
 242             #next unless $self->does_role($role);
 243         }
 244         else {
 245
 246             # NOTE:
 247             # in 5.10 constant.pm the constants show up
 248             # as being in the right package, but in pre-5.10
 249             # they show up as constant::__ANON__ so we
 250             # make an exception here to be sure that things
 251             # work as expected in both.
 252             # - SL
 253             unless ($pkg eq 'constant' && $name eq '__ANON__') {
 254                 next if ($pkg  || '') ne $class_name ||
 255                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
 256             }
 257
 258         }
 259
 260         $map->{$symbol} = $method_metaclass->wrap(
 261             $code,
 262             package_name => $class_name,
 263             name         => $symbol
 264         );
 265     }
 266
 267     return $map;
 268 }
 269
 270 ### ---------------------------------------------
 271
 272 sub add_attribute {
 273     my $self = shift;
 274     $self->SUPER::add_attribute(
 275         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 276             ? $_[0]
 277             : $self->_process_attribute(@_))
 278     );
 279 }
 280
 281 sub add_override_method_modifier {
 282     my ($self, $name, $method, $_super_package) = @_;
 283
 284     (!$self->has_method($name))
 285         || $self->throw_error("Cannot add an override method if a local method is already present");
 286
 287     $self->add_method($name => Moose::Meta::Method::Overriden->new(
 288         method  => $method,
 289         class   => $self,
 290         package => $_super_package, # need this for roles
 291         name    => $name,
 292     ));
 293 }
 294
 295 sub add_augment_method_modifier {
 296     my ($self, $name, $method) = @_;
 297     (!$self->has_method($name))
 298         || $self->throw_error("Cannot add an augment method if a local method is already present");
 299
 300     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 301         method  => $method,
 302         class   => $self,
 303         name    => $name,
 304     ));
 305 }
 306
 307 ## Private Utility methods ...
 308
 309 sub _find_next_method_by_name_which_is_not_overridden {
 310     my ($self, $name) = @_;
 311     foreach my $method ($self->find_all_methods_by_name($name)) {
 312         return $method->{code}
 313             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 314     }
 315     return undef;
 316 }
 317
 318 sub _fix_metaclass_incompatibility {
 319     my ($self, @superclasses) = @_;
 320
 321     foreach my $super (@superclasses) {
 322         next if $self->_superclass_meta_is_compatible($super);
 323
 324         unless ( $self->is_pristine ) {
 325             $self->throw_error(
 326                       "Cannot attempt to reinitialize metaclass for "
 327                     . $self->name
 328                     . ", it isn't pristine" );
 329         }
 330
 331         $self->_reconcile_with_superclass_meta($super);
 332     }
 333 }
 334
 335 sub _superclass_meta_is_compatible {
 336     my ($self, $super) = @_;
 337
 338     my $super_meta = Class::MOP::Class->initialize($super)
 339         or return 1;
 340
 341     next unless $super_meta->isa("Class::MOP::Class");
 342
 343     my $super_meta_name
 344         = $super_meta->is_immutable
 345         ? $super_meta->get_mutable_metaclass_name
 346         : ref($super_meta);
 347
 348     return 1
 349         if $self->isa($super_meta_name)
 350             and
 351            $self->instance_metaclass->isa( $super_meta->instance_metaclass );
 352 }
 353
 354 # I don't want to have to type this >1 time
 355 my @MetaClassTypes =
 356     qw( attribute_metaclass method_metaclass instance_metaclass constructor_class destructor_class );
 357
 358 sub _reconcile_with_superclass_meta {
 359     my ($self, $super) = @_;
 360
 361     my $super_meta = $super->meta;
 362
 363     my $super_meta_name
 364         = $super_meta->is_immutable
 365         ? $super_meta->get_mutable_metaclass_name
 366         : ref($super_meta);
 367
 368     my $self_metaclass = ref $self;
 369
 370     # If neither of these is true we have a more serious
 371     # incompatibility that we just cannot fix (yet?).
 372     if ( $super_meta_name->isa( ref $self )
 373         && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) {
 374         $self->_reinitialize_with($super_meta);
 375     }
 376     elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) {
 377         $self->_reconcile_role_differences($super_meta);
 378     }
 379 }
 380
 381 sub _reinitialize_with {
 382     my ( $self, $new_meta ) = @_;
 383
 384     my $new_self = $new_meta->reinitialize(
 385         $self->name,
 386         attribute_metaclass => $new_meta->attribute_metaclass,
 387         method_metaclass    => $new_meta->method_metaclass,
 388         instance_metaclass  => $new_meta->instance_metaclass,
 389     );
 390
 391     $new_self->$_( $new_meta->$_ ) for qw( constructor_class destructor_class );
 392
 393     %$self = %$new_self;
 394
 395     bless $self, ref $new_self;
 396
 397     # We need to replace the cached metaclass instance or else when it
 398     # goes out of scope Class::MOP::Class destroy's the namespace for
 399     # the metaclass's class, causing much havoc.
 400     Class::MOP::store_metaclass_by_name( $self->name, $self );
 401     Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class;
 402 }
 403
 404 # In the more complex case, we share a common ancestor with our
 405 # superclass's metaclass, but each metaclass (ours and the parent's)
 406 # has a different set of roles applied. We reconcile this by first
 407 # reinitializing into the parent class, and _then_ applying our own
 408 # roles.
 409 sub _all_metaclasses_differ_by_roles_only {
 410     my ($self, $super_meta) = @_;
 411
 412     for my $pair (
 413         [ ref $self, ref $super_meta ],
 414         map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes
 415         ) {
 416
 417         next if $pair->[0] eq $pair->[1];
 418
 419         my $self_meta_meta  = Class::MOP::Class->initialize( $pair->[0] );
 420         my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] );
 421
 422         my $common_ancestor
 423             = _find_common_ancestor( $self_meta_meta, $super_meta_meta );
 424
 425         return unless $common_ancestor;
 426
 427         return
 428             unless _is_role_only_subclass_of(
 429             $self_meta_meta,
 430             $common_ancestor,
 431             )
 432             && _is_role_only_subclass_of(
 433             $super_meta_meta,
 434             $common_ancestor,
 435             );
 436     }
 437
 438     return 1;
 439 }
 440
 441 # This, and some other functions, could be called as methods, but
 442 # they're not for two reasons. One, we just end up ignoring the first
 443 # argument, because we can't call these directly on one of the real
 444 # arguments, because one of them could be a Class::MOP::Class object
 445 # and not a Moose::Meta::Class. Second, only a completely insane
 446 # person would attempt to subclass this stuff!
 447 sub _find_common_ancestor {
 448     my ($meta1, $meta2) = @_;
 449
 450     # FIXME? This doesn't account for multiple inheritance (not sure
 451     # if it needs to though). For example, is somewhere in $meta1's
 452     # history it inherits from both ClassA and ClassB, and $meta
 453     # inherits from ClassB & ClassA, does it matter? And what crazy
 454     # fool would do that anyway?
 455
 456     my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa;
 457
 458     return first { $meta1_parents{$_} } $meta2->linearized_isa;
 459 }
 460
 461 sub _is_role_only_subclass_of {
 462     my ($meta, $ancestor) = @_;
 463
 464     return 1 if $meta->name eq $ancestor;
 465
 466     my @roles = _all_roles_until( $meta, $ancestor );
 467
 468     my %role_packages = map { $_->name => 1 } @roles;
 469
 470     my $ancestor_meta = Class::MOP::Class->initialize($ancestor);
 471
 472     my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa;
 473
 474     for my $method ( $meta->get_all_methods() ) {
 475         next if $method->name eq 'meta';
 476         next if $method->can('associated_attribute');
 477
 478         next
 479             if $role_packages{ $method->original_package_name }
 480                 || $shared_ancestors{ $method->original_package_name };
 481
 482         return 0;
 483     }
 484
 485     # FIXME - this really isn't right. Just because an attribute is
 486     # defined in a role doesn't mean it isn't _also_ defined in the
 487     # subclass.
 488     for my $attr ( $meta->get_all_attributes ) {
 489         next if $shared_ancestors{ $attr->associated_class->name };
 490
 491         next if any { $_->has_attribute( $attr->name ) } @roles;
 492
 493         return 0;
 494     }
 495
 496     return 1;
 497 }
 498
 499 sub _all_roles {
 500     my $meta = shift;
 501
 502     return _all_roles_until($meta);
 503 }
 504
 505 sub _all_roles_until {
 506     my ($meta, $stop_at_class) = @_;
 507
 508     return unless $meta->can('calculate_all_roles');
 509
 510     my @roles = $meta->calculate_all_roles;
 511
 512     for my $class ( $meta->linearized_isa ) {
 513         last if $stop_at_class && $stop_at_class eq $class;
 514
 515         my $meta = Class::MOP::Class->initialize($class);
 516         last unless $meta->can('calculate_all_roles');
 517
 518         push @roles, $meta->calculate_all_roles;
 519     }
 520
 521     return @roles;
 522 }
 523
 524 sub _reconcile_role_differences {
 525     my ($self, $super_meta) = @_;
 526
 527     my $self_meta = $self->meta;
 528
 529     my %roles;
 530
 531     if ( my @roles = map { $_->name } _all_roles($self_meta) ) {
 532         $roles{metaclass_roles} = \@roles;
 533     }
 534
 535     for my $thing (@MetaClassTypes) {
 536         my $name = $self->$thing();
 537
 538         my $thing_meta = Class::MOP::Class->initialize($name);
 539
 540         my @roles = map { $_->name } _all_roles($thing_meta)
 541             or next;
 542
 543         $roles{ $thing . '_roles' } = \@roles;
 544     }
 545
 546     $self->_reinitialize_with($super_meta);
 547
 548     Moose::Util::MetaRole::apply_metaclass_roles(
 549         for_class => $self->name,
 550         %roles,
 551     );
 552
 553     return $self;
 554 }
 555
 556 # NOTE:
 557 # this was crap anyway, see
 558 # Moose::Util::apply_all_roles
 559 # instead
 560 sub _apply_all_roles {
 561     Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 562 }
 563
 564 sub _process_attribute {
 565     my ( $self, $name, @args ) = @_;
 566
 567     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 568
 569     if ($name =~ /^\+(.*)/) {
 570         return $self->_process_inherited_attribute($1, @args);
 571     }
 572     else {
 573         return $self->_process_new_attribute($name, @args);
 574     }
 575 }
 576
 577 sub _process_new_attribute {
 578     my ( $self, $name, @args ) = @_;
 579
 580     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 581 }
 582
 583 sub _process_inherited_attribute {
 584     my ($self, $attr_name, %options) = @_;
 585     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 586     (defined $inherited_attr)
 587         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
 588     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 589         return $inherited_attr->clone_and_inherit_options(%options);
 590     }
 591     else {
 592         # NOTE:
 593         # kind of a kludge to handle Class::MOP::Attributes
 594         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 595     }
 596 }
 597
 598 ## -------------------------------------------------
 599
 600 use Moose::Meta::Method::Constructor;
 601 use Moose::Meta::Method::Destructor;
 602
 603 # This could be done by using SUPER and altering ->options
 604 # I am keeping it this way to make it more explicit.
 605 sub create_immutable_transformer {
 606     my $self = shift;
 607     my $class = Class::MOP::Immutable->new($self, {
 608        read_only   => [qw/superclasses/],
 609        cannot_call => [qw/
 610            add_method
 611            alias_method
 612            remove_method
 613            add_attribute
 614            remove_attribute
 615            remove_package_symbol
 616            add_role
 617        /],
 618        memoize     => {
 619            class_precedence_list             => 'ARRAY',
 620            linearized_isa                    => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need?
 621            get_all_methods                   => 'ARRAY',
 622            #get_all_attributes               => 'ARRAY', # it's an alias, no need, but maybe in the future
 623            compute_all_applicable_attributes => 'ARRAY',
 624            get_meta_instance                 => 'SCALAR',
 625            get_method_map                    => 'SCALAR',
 626            calculate_all_roles               => 'ARRAY',
 627        },
 628        # NOTE:
 629        # this is ugly, but so are typeglobs,
 630        # so whattayahgonnadoboutit
 631        # - SL
 632        wrapped => {
 633            add_package_symbol => sub {
 634                my $original = shift;
 635                $self->throw_error("Cannot add package symbols to an immutable metaclass")
 636                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 637                goto $original->body;
 638            },
 639        },
 640     });
 641     return $class;
 642 }
 643
 644 sub make_immutable {
 645     my $self = shift;
 646     $self->SUPER::make_immutable
 647       (
 648        constructor_class => $self->constructor_class,
 649        destructor_class  => $self->destructor_class,
 650        inline_destructor => 1,
 651        # NOTE:
 652        # no need to do this,
 653        # Moose always does it
 654        inline_accessors  => 0,
 655        @_,
 656       );
 657 }
 658
 659 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
 660
 661 our $level;
 662
 663 sub throw_error {
 664     my ( $self, @args ) = @_;
 665     local $level = 1;
 666     $self->raise_error($self->create_error(@args));
 667 }
 668
 669 sub raise_error {
 670     my ( $self, @args ) = @_;
 671     die @args;
 672 }
 673
 674 sub create_error {
 675     my ( $self, @args ) = @_;
 676
 677     if ( @args % 2 == 1 ) {
 678         unshift @args, "message";
 679     }
 680
 681     my %args = ( meta => $self, error => $@, @args );
 682
 683     local $level = $level + 1;
 684
 685     if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
 686         return $self->create_error_object( %args, class => $class );
 687     } else {
 688         my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
 689
 690         my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
 691             ? $builder
 692             : ( $self->can("create_error_$builder") || "create_error_confess" ));
 693
 694         return $self->$builder_method(%args);
 695     }
 696 }
 697
 698 sub create_error_object {
 699     my ( $self, %args ) = @_;
 700
 701     my $class = delete $args{class};
 702
 703     $class->new(
 704         %args,
 705         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
 706     );
 707 }
 708
 709 sub create_error_croak {
 710     my ( $self, @args ) = @_;
 711     $self->_create_error_carpmess( @args );
 712 }
 713
 714 sub create_error_confess {
 715     my ( $self, @args ) = @_;
 716     $self->_create_error_carpmess( @args, longmess => 1 );
 717 }
 718
 719 sub _create_error_carpmess {
 720     my ( $self, %args ) = @_;
 721
 722     my $carp_level = $level + 1 + ( $args{depth} || 1 );
 723
 724     local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
 725     local $Carp::MaxArgNums = 20;         # default is 8, usually we use named args which gets messier though
 726
 727     my @args = exists $args{message} ? $args{message} : ();
 728
 729     if ( $args{longmess} ) {
 730         return Carp::longmess(@args);
 731     } else {
 732         return Carp::shortmess(@args);
 733     }
 734 }
 735
 736 1;
 737
 738 __END__
 739
 740 =pod
 741
 742 =head1 NAME
 743
 744 Moose::Meta::Class - The Moose metaclass
 745
 746 =head1 DESCRIPTION
 747
 748 This is a subclass of L<Class::MOP::Class> with Moose specific
 749 extensions.
 750
 751 For the most part, the only time you will ever encounter an
 752 instance of this class is if you are doing some serious deep
 753 introspection. To really understand this class, you need to refer
 754 to the L<Class::MOP::Class> documentation.
 755
 756 =head1 METHODS
 757
 758 =over 4
 759
 760 =item B<initialize>
 761
 762 =item B<create>
 763
 764 Overrides original to accept a list of roles to apply to
 765 the created class.
 766
 767    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 768
 769 =item B<create_anon_class>
 770
 771 Overrides original to support roles and caching.
 772
 773    my $metaclass = Moose::Meta::Class->create_anon_class(
 774        superclasses => ['Foo'],
 775        roles        => [qw/Some Roles Go Here/],
 776        cache        => 1,
 777    );
 778
 779 =item B<make_immutable>
 780
 781 Override original to add default options for inlining destructor
 782 and altering the Constructor metaclass.
 783
 784 =item B<create_immutable_transformer>
 785
 786 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 787
 788 =item B<new_object>
 789
 790 We override this method to support the C<trigger> attribute option.
 791
 792 =item B<construct_instance>
 793
 794 This provides some Moose specific extensions to this method, you
 795 almost never call this method directly unless you really know what
 796 you are doing.
 797
 798 This method makes sure to handle the moose weak-ref, type-constraint
 799 and type coercion features.
 800
 801 =item B<get_method_map>
 802
 803 This accommodates Moose::Meta::Role::Method instances, which are
 804 aliased, instead of added, but still need to be counted as valid
 805 methods.
 806
 807 =item B<add_override_method_modifier ($name, $method)>
 808
 809 This will create an C<override> method modifier for you, and install
 810 it in the package.
 811
 812 =item B<add_augment_method_modifier ($name, $method)>
 813
 814 This will create an C<augment> method modifier for you, and install
 815 it in the package.
 816
 817 =item B<calculate_all_roles>
 818
 819 =item B<roles>
 820
 821 This will return an array of C<Moose::Meta::Role> instances which are
 822 attached to this class.
 823
 824 =item B<add_role ($role)>
 825
 826 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 827 to the list of associated roles.
 828
 829 =item B<does_role ($role_name)>
 830
 831 This will test if this class C<does> a given C<$role_name>. It will
 832 not only check it's local roles, but ask them as well in order to
 833 cascade down the role hierarchy.
 834
 835 =item B<excludes_role ($role_name)>
 836
 837 This will test if this class C<excludes> a given C<$role_name>. It will
 838 not only check it's local roles, but ask them as well in order to
 839 cascade down the role hierarchy.
 840
 841 =item B<add_attribute ($attr_name, %params|$params)>
 842
 843 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 844 support for taking the C<$params> as a HASH ref.
 845
 846 =item B<constructor_class ($class_name)>
 847
 848 =item B<destructor_class ($class_name)>
 849
 850 These are the names of classes used when making a class
 851 immutable. These default to L<Moose::Meta::Method::Constructor> and
 852 L<Moose::Meta::Method::Destructor> respectively. These accessors are
 853 read-write, so you can use them to change the class name.
 854
 855 =item B<check_metaclass_compatibility>
 856
 857 Moose overrides this method from C<Class::MOP::Class> and attempts to
 858 fix some incompatibilities before doing the check.
 859
 860 =item B<throw_error $message, %extra>
 861
 862 Throws the error created by C<create_error> using C<raise_error>
 863
 864 =item B<create_error $message, %extra>
 865
 866 Creates an error message or object.
 867
 868 The default behavior is C<create_error_confess>.
 869
 870 If C<error_class> is set uses C<create_error_object>. Otherwise uses
 871 C<error_builder> (a code reference or variant name), and calls the appropriate
 872 C<create_error_$builder> method.
 873
 874 =item B<error_builder $builder_name>
 875
 876 Get or set the error builder. Defaults to C<confess>.
 877
 878 =item B<error_class $class_name>
 879
 880 Get or set the error class. Has no default.
 881
 882 =item B<create_error_confess %args>
 883
 884 Creates an error using L<Carp/longmess>
 885
 886 =item B<create_error_croak %args>
 887
 888 Creates an error using L<Carp/shortmess>
 889
 890 =item B<create_error_object %args>
 891
 892 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
 893 to support custom error objects for your meta class.
 894
 895 =item B<raise_error $error>
 896
 897 Dies with an error object or string.
 898
 899 =back
 900
 901 =head1 BUGS
 902
 903 All complex software has bugs lurking in it, and this module is no
 904 exception. If you find a bug please either email me, or add the bug
 905 to cpan-RT.
 906
 907 =head1 AUTHOR
 908
 909 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 910
 911 =head1 COPYRIGHT AND LICENSE
 912
 913 Copyright 2006-2008 by Infinity Interactive, Inc.
 914
 915 L<http://www.iinteractive.com>
 916
 917 This library is free software; you can redistribute it and/or modify
 918 it under the same terms as Perl itself.
 919
 920 =cut
 921