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 Scalar::Util 'weaken', 'blessed';
  11
  12 our $VERSION   = '0.50';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::Method::Overriden;
  16 use Moose::Meta::Method::Augmented;
  17
  18 use base 'Class::MOP::Class';
  19
  20 __PACKAGE__->meta->add_attribute('roles' => (
  21     reader  => 'roles',
  22     default => sub { [] }
  23 ));
  24
  25 __PACKAGE__->meta->add_attribute('error_builder' => (
  26     reader  => 'error_builder',
  27     default => 'confess',
  28 ));
  29
  30 __PACKAGE__->meta->add_attribute('error_class' => (
  31     reader  => 'error_class',
  32 ));
  33
  34
  35 sub initialize {
  36     my $class = shift;
  37     my $pkg   = shift;
  38     return Class::MOP::get_metaclass_by_name($pkg)
  39         || $class->SUPER::initialize($pkg,
  40                 'attribute_metaclass' => 'Moose::Meta::Attribute',
  41                 'method_metaclass'    => 'Moose::Meta::Method',
  42                 'instance_metaclass'  => 'Moose::Meta::Instance',
  43                 @_
  44             );
  45 }
  46
  47 sub create {
  48     my ($self, $package_name, %options) = @_;
  49
  50     (ref $options{roles} eq 'ARRAY')
  51         || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
  52             if exists $options{roles};
  53
  54     my $class = $self->SUPER::create($package_name, %options);
  55
  56     if (exists $options{roles}) {
  57         Moose::Util::apply_all_roles($class, @{$options{roles}});
  58     }
  59
  60     return $class;
  61 }
  62
  63 my %ANON_CLASSES;
  64
  65 sub create_anon_class {
  66     my ($self, %options) = @_;
  67
  68     my $cache_ok = delete $options{cache};
  69
  70     # something like Super::Class|Super::Class::2=Role|Role::1
  71     my $cache_key = join '=' => (
  72         join('|', sort @{$options{superclasses} || []}),
  73         join('|', sort @{$options{roles}        || []}),
  74     );
  75
  76     if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
  77         return $ANON_CLASSES{$cache_key};
  78     }
  79
  80     my $new_class = $self->SUPER::create_anon_class(%options);
  81
  82     $ANON_CLASSES{$cache_key} = $new_class
  83         if $cache_ok;
  84
  85     return $new_class;
  86 }
  87
  88 sub add_role {
  89     my ($self, $role) = @_;
  90     (blessed($role) && $role->isa('Moose::Meta::Role'))
  91         || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role);
  92     push @{$self->roles} => $role;
  93 }
  94
  95 sub calculate_all_roles {
  96     my $self = shift;
  97     my %seen;
  98     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
  99 }
 100
 101 sub does_role {
 102     my ($self, $role_name) = @_;
 103     (defined $role_name)
 104         || $self->throw_error("You must supply a role name to look for");
 105     foreach my $class ($self->class_precedence_list) {
 106         next unless $class->can('meta') && $class->meta->can('roles');
 107         foreach my $role (@{$class->meta->roles}) {
 108             return 1 if $role->does_role($role_name);
 109         }
 110     }
 111     return 0;
 112 }
 113
 114 sub excludes_role {
 115     my ($self, $role_name) = @_;
 116     (defined $role_name)
 117         || $self->throw_error("You must supply a role name to look for");
 118     foreach my $class ($self->class_precedence_list) {
 119         next unless $class->can('meta');
 120         # NOTE:
 121         # in the pretty rare instance when a Moose metaclass
 122         # is itself extended with a role, this check needs to
 123         # be done since some items in the class_precedence_list
 124         # might in fact be Class::MOP based still.
 125         next unless $class->meta->can('roles');
 126         foreach my $role (@{$class->meta->roles}) {
 127             return 1 if $role->excludes_role($role_name);
 128         }
 129     }
 130     return 0;
 131 }
 132
 133 sub new_object {
 134     my ($class, %params) = @_;
 135     my $self = $class->SUPER::new_object(%params);
 136     foreach my $attr ($class->compute_all_applicable_attributes()) {
 137         # if we have a trigger, then ...
 138         if ($attr->can('has_trigger') && $attr->has_trigger) {
 139             # make sure we have an init-arg ...
 140             if (defined(my $init_arg = $attr->init_arg)) {
 141                 # now make sure an init-arg was passes ...
 142                 if (exists $params{$init_arg}) {
 143                     # and if get here, fire the trigger
 144                     $attr->trigger->(
 145                         $self,
 146                         # check if there is a coercion
 147                         ($attr->should_coerce
 148                             # and if so, we need to grab the
 149                             # value that is actually been stored
 150                             ? $attr->get_read_method_ref->($self)
 151                             # otherwise, just get the value from
 152                             # the constructor params
 153                             : $params{$init_arg}),
 154                         $attr
 155                     );
 156                 }
 157             }
 158         }
 159     }
 160     return $self;
 161 }
 162
 163 sub construct_instance {
 164     my ($class, %params) = @_;
 165     my $meta_instance = $class->get_meta_instance;
 166     # FIXME:
 167     # the code below is almost certainly incorrect
 168     # but this is foreign inheritence, so we might
 169     # have to kludge it in the end.
 170     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
 171     foreach my $attr ($class->compute_all_applicable_attributes()) {
 172         $attr->initialize_instance_slot($meta_instance, $instance, \%params);
 173     }
 174     return $instance;
 175 }
 176
 177 # FIXME:
 178 # This is ugly
 179 sub get_method_map {
 180     my $self = shift;
 181
 182     if (defined $self->{'$!_package_cache_flag'} &&
 183                 $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->meta->name)) {
 184         return $self->{'%!methods'};
 185     }
 186
 187     my $map  = $self->{'%!methods'};
 188
 189     my $class_name       = $self->name;
 190     my $method_metaclass = $self->method_metaclass;
 191
 192     my %all_code = $self->get_all_package_symbols('CODE');
 193
 194     foreach my $symbol (keys %all_code) {
 195         my $code = $all_code{$symbol};
 196
 197         next if exists  $map->{$symbol} &&
 198                 defined $map->{$symbol} &&
 199                         $map->{$symbol}->body == $code;
 200
 201         my ($pkg, $name) = Class::MOP::get_code_info($code);
 202
 203         if ($pkg->can('meta')
 204             # NOTE:
 205             # we don't know what ->meta we are calling
 206             # here, so we need to be careful cause it
 207             # just might blow up at us, or just complain
 208             # loudly (in the case of Curses.pm) so we
 209             # just be a little overly cautious here.
 210             # - SL
 211             && eval { no warnings; blessed($pkg->meta) }
 212             && $pkg->meta->isa('Moose::Meta::Role')) {
 213             #my $role = $pkg->meta->name;
 214             #next unless $self->does_role($role);
 215         }
 216         else {
 217
 218             # NOTE:
 219             # in 5.10 constant.pm the constants show up
 220             # as being in the right package, but in pre-5.10
 221             # they show up as constant::__ANON__ so we
 222             # make an exception here to be sure that things
 223             # work as expected in both.
 224             # - SL
 225             unless ($pkg eq 'constant' && $name eq '__ANON__') {
 226                 next if ($pkg  || '') ne $class_name ||
 227                         (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
 228             }
 229
 230         }
 231
 232         $map->{$symbol} = $method_metaclass->wrap(
 233             $code,
 234             package_name => $class_name,
 235             name         => $symbol
 236         );
 237     }
 238
 239     return $map;
 240 }
 241
 242 ### ---------------------------------------------
 243
 244 sub add_attribute {
 245     my $self = shift;
 246     $self->SUPER::add_attribute(
 247         (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
 248             ? $_[0]
 249             : $self->_process_attribute(@_))
 250     );
 251 }
 252
 253 sub add_override_method_modifier {
 254     my ($self, $name, $method, $_super_package) = @_;
 255
 256     (!$self->has_method($name))
 257         || $self->throw_error("Cannot add an override method if a local method is already present");
 258
 259     $self->add_method($name => Moose::Meta::Method::Overriden->new(
 260         method  => $method,
 261         class   => $self,
 262         package => $_super_package, # need this for roles
 263         name    => $name,
 264     ));
 265 }
 266
 267 sub add_augment_method_modifier {
 268     my ($self, $name, $method) = @_;
 269     (!$self->has_method($name))
 270         || $self->throw_error("Cannot add an augment method if a local method is already present");
 271
 272     $self->add_method($name => Moose::Meta::Method::Augmented->new(
 273         method  => $method,
 274         class   => $self,
 275         name    => $name,
 276     ));
 277 }
 278
 279 ## Private Utility methods ...
 280
 281 sub _find_next_method_by_name_which_is_not_overridden {
 282     my ($self, $name) = @_;
 283     foreach my $method ($self->find_all_methods_by_name($name)) {
 284         return $method->{code}
 285             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 286     }
 287     return undef;
 288 }
 289
 290 sub _fix_metaclass_incompatability {
 291     my ($self, @superclasses) = @_;
 292     foreach my $super (@superclasses) {
 293         # don't bother if it does not have a meta.
 294         next unless $super->can('meta');
 295         # get the name, make sure we take
 296         # immutable classes into account
 297         my $super_meta_name = ($super->meta->is_immutable
 298                                 ? $super->meta->get_mutable_metaclass_name
 299                                 : blessed($super->meta));
 300         # if it's meta is a vanilla Moose,
 301         # then we can safely ignore it.
 302         next if $super_meta_name eq 'Moose::Meta::Class';
 303         # but if we have anything else,
 304         # we need to check it out ...
 305         unless (# see if of our metaclass is incompatible
 306                 ($self->isa($super_meta_name) &&
 307                  # and see if our instance metaclass is incompatible
 308                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 309                 # ... and if we are just a vanilla Moose
 310                 $self->isa('Moose::Meta::Class')) {
 311             # re-initialize the meta ...
 312             my $super_meta = $super->meta;
 313             # NOTE:
 314             # We might want to consider actually
 315             # transfering any attributes from the
 316             # original meta into this one, but in
 317             # general you should not have any there
 318             # at this point anyway, so it's very
 319             # much an obscure edge case anyway
 320             $self = $super_meta->reinitialize($self->name => (
 321                 'attribute_metaclass' => $super_meta->attribute_metaclass,
 322                 'method_metaclass'    => $super_meta->method_metaclass,
 323                 'instance_metaclass'  => $super_meta->instance_metaclass,
 324             ));
 325         }
 326     }
 327     return $self;
 328 }
 329
 330 # NOTE:
 331 # this was crap anyway, see
 332 # Moose::Util::apply_all_roles
 333 # instead
 334 sub _apply_all_roles {
 335     Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
 336 }
 337
 338 sub _process_attribute {
 339     my ( $self, $name, @args ) = @_;
 340
 341     @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
 342
 343     if ($name =~ /^\+(.*)/) {
 344         return $self->_process_inherited_attribute($1, @args);
 345     }
 346     else {
 347         return $self->_process_new_attribute($name, @args);
 348     }
 349 }
 350
 351 sub _process_new_attribute {
 352     my ( $self, $name, @args ) = @_;
 353
 354     $self->attribute_metaclass->interpolate_class_and_new($name, @args);
 355 }
 356
 357 sub _process_inherited_attribute {
 358     my ($self, $attr_name, %options) = @_;
 359     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 360     (defined $inherited_attr)
 361         || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
 362     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 363         return $inherited_attr->clone_and_inherit_options(%options);
 364     }
 365     else {
 366         # NOTE:
 367         # kind of a kludge to handle Class::MOP::Attributes
 368         return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
 369     }
 370 }
 371
 372 ## -------------------------------------------------
 373
 374 use Moose::Meta::Method::Constructor;
 375 use Moose::Meta::Method::Destructor;
 376
 377 # This could be done by using SUPER and altering ->options
 378 # I am keeping it this way to make it more explicit.
 379 sub create_immutable_transformer {
 380     my $self = shift;
 381     my $class = Class::MOP::Immutable->new($self, {
 382         read_only   => [qw/
 383             superclasses
 384             roles
 385             error_class
 386             error_builder
 387         /],
 388         cannot_call => [qw/
 389             add_method
 390             alias_method
 391             remove_method
 392             add_attribute
 393             remove_attribute
 394             remove_package_symbol
 395             add_role
 396         /],
 397         memoize     => {
 398             class_precedence_list             => 'ARRAY',
 399             compute_all_applicable_attributes => 'ARRAY',
 400             get_meta_instance                 => 'SCALAR',
 401             get_method_map                    => 'SCALAR',
 402             # maybe ....
 403             calculate_all_roles               => 'ARRAY',
 404         },
 405         # NOTE:
 406         # this is ugly, but so are typeglobs,
 407         # so whattayahgonnadoboutit
 408         # - SL
 409         wrapped => {
 410             add_package_symbol => sub {
 411                 my $original = shift;
 412                 $self->throw_error("Cannot add package symbols to an immutable metaclass")
 413                     unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 414                 goto $original->body;
 415             },
 416         },
 417     });
 418     return $class;
 419 }
 420
 421 sub make_immutable {
 422     my $self = shift;
 423     $self->SUPER::make_immutable
 424       (
 425        constructor_class => 'Moose::Meta::Method::Constructor',
 426        destructor_class  => 'Moose::Meta::Method::Destructor',
 427        inline_destructor => 1,
 428        # NOTE:
 429        # no need to do this,
 430        # Moose always does it
 431        inline_accessors  => 0,
 432        @_,
 433       );
 434 }
 435
 436 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
 437
 438 our $level;
 439
 440 sub throw_error {
 441     my ( $self, @args ) = @_;
 442     local $level = 1;
 443     $self->raise_error($self->create_error(@args));
 444 }
 445
 446 sub raise_error {
 447     my ( $self, @args ) = @_;
 448     die @args;
 449 }
 450
 451 sub create_error {
 452     my ( $self, @args ) = @_;
 453
 454     if ( @args % 2 == 1 ) {
 455         unshift @args, "message";
 456     }
 457
 458     my %args = @args;
 459
 460     local $level = $level + 1;
 461
 462     if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
 463         return $self->create_error_object( %args, class => $class );
 464     } else {
 465         my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
 466
 467         my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
 468             ? $builder
 469             : ( $self->can("create_error_$builder") || "create_error_confess" ));
 470
 471         return $self->$builder_method(%args);
 472     }
 473 }
 474
 475 sub create_error_object {
 476     my ( $self, %args ) = @_;
 477
 478     my $class = delete $args{class};
 479
 480     $class->new(
 481         metaclass => $self,
 482         %args,
 483         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
 484     );
 485 }
 486
 487 sub create_error_croak {
 488     my ( $self, @args ) = @_;
 489     $self->_create_error_carpmess( @args );
 490 }
 491
 492 sub create_error_confess {
 493     my ( $self, @args ) = @_;
 494     $self->_create_error_carpmess( @args, longmess => 1 );
 495 }
 496
 497 sub _create_error_carpmess {
 498     my ( $self, %args ) = @_;
 499
 500     my $carp_level = $level + 1 + ( $args{depth} || 1 );
 501
 502     local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
 503     local $Carp::MaxArgNums = 20;         # default is 8, usually we use named args which gets messier though
 504
 505     my @args = exists $args{message} ? $args{message} : ();
 506
 507     if ( $args{longmess} ) {
 508         return Carp::longmess(@args);
 509     } else {
 510         return Carp::shortmess(@args);
 511     }
 512 }
 513
 514 1;
 515
 516 __END__
 517
 518 =pod
 519
 520 =head1 NAME
 521
 522 Moose::Meta::Class - The Moose metaclass
 523
 524 =head1 DESCRIPTION
 525
 526 This is a subclass of L<Class::MOP::Class> with Moose specific
 527 extensions.
 528
 529 For the most part, the only time you will ever encounter an
 530 instance of this class is if you are doing some serious deep
 531 introspection. To really understand this class, you need to refer
 532 to the L<Class::MOP::Class> documentation.
 533
 534 =head1 METHODS
 535
 536 =over 4
 537
 538 =item B<initialize>
 539
 540 =item B<create>
 541
 542 Overrides original to accept a list of roles to apply to
 543 the created class.
 544
 545    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 546
 547 =item B<create_anon_class>
 548
 549 Overrides original to support roles and caching.
 550
 551    my $metaclass = Moose::Meta::Class->create_anon_class(
 552        superclasses => ['Foo'],
 553        roles        => [qw/Some Roles Go Here/],
 554        cache        => 1,
 555    );
 556
 557 =item B<make_immutable>
 558
 559 Override original to add default options for inlining destructor
 560 and altering the Constructor metaclass.
 561
 562 =item B<create_immutable_transformer>
 563
 564 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 565
 566 =item B<new_object>
 567
 568 We override this method to support the C<trigger> attribute option.
 569
 570 =item B<construct_instance>
 571
 572 This provides some Moose specific extensions to this method, you
 573 almost never call this method directly unless you really know what
 574 you are doing.
 575
 576 This method makes sure to handle the moose weak-ref, type-constraint
 577 and type coercion features.
 578
 579 =item B<get_method_map>
 580
 581 This accommodates Moose::Meta::Role::Method instances, which are
 582 aliased, instead of added, but still need to be counted as valid
 583 methods.
 584
 585 =item B<add_override_method_modifier ($name, $method)>
 586
 587 This will create an C<override> method modifier for you, and install
 588 it in the package.
 589
 590 =item B<add_augment_method_modifier ($name, $method)>
 591
 592 This will create an C<augment> method modifier for you, and install
 593 it in the package.
 594
 595 =item B<calculate_all_roles>
 596
 597 =item B<roles>
 598
 599 This will return an array of C<Moose::Meta::Role> instances which are
 600 attached to this class.
 601
 602 =item B<add_role ($role)>
 603
 604 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 605 to the list of associated roles.
 606
 607 =item B<does_role ($role_name)>
 608
 609 This will test if this class C<does> a given C<$role_name>. It will
 610 not only check it's local roles, but ask them as well in order to
 611 cascade down the role hierarchy.
 612
 613 =item B<excludes_role ($role_name)>
 614
 615 This will test if this class C<excludes> a given C<$role_name>. It will
 616 not only check it's local roles, but ask them as well in order to
 617 cascade down the role hierarchy.
 618
 619 =item B<add_attribute ($attr_name, %params|$params)>
 620
 621 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 622 support for taking the C<$params> as a HASH ref.
 623
 624 =item B<throw_error $message, %extra>
 625
 626 Throws the error created by C<create_error> using C<raise_error>
 627
 628 =item B<create_error $message, %extra>
 629
 630 Creates an error message or object.
 631
 632 The default behavior is C<create_error_confess>.
 633
 634 If C<error_class> is set uses C<create_error_object>. Otherwise uses
 635 C<error_builder> (a code reference or variant name), and calls the appropriate
 636 C<create_error_$builder> method.
 637
 638 =item B<error_builder $builder_name>
 639
 640 Get or set the error builder. Defaults to C<confess>.
 641
 642 =item B<error_class $class_name>
 643
 644 Get or set the error class. Has no default.
 645
 646 =item B<create_error_confess %args>
 647
 648 Creates an error using L<Carp/longmess>
 649
 650 =item B<create_error_croak %args>
 651
 652 Creates an error using L<Carp/shortmess>
 653
 654 =item B<create_error_object %args>
 655
 656 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
 657 to support custom error objects for your meta class.
 658
 659 =item B<raise_error $error>
 660
 661 Dies with an error object or string.
 662
 663 =back
 664
 665 =head1 BUGS
 666
 667 All complex software has bugs lurking in it, and this module is no
 668 exception. If you find a bug please either email me, or add the bug
 669 to cpan-RT.
 670
 671 =head1 AUTHOR
 672
 673 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 674
 675 =head1 COPYRIGHT AND LICENSE
 676
 677 Copyright 2006-2008 by Infinity Interactive, Inc.
 678
 679 L<http://www.iinteractive.com>
 680
 681 This library is free software; you can redistribute it and/or modify
 682 it under the same terms as Perl itself.
 683
 684 =cut
 685