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/superclasses/],
 383        cannot_call => [qw/
 384            add_method
 385            alias_method
 386            remove_method
 387            add_attribute
 388            remove_attribute
 389            remove_package_symbol
 390            add_role
 391        /],
 392        memoize     => {
 393            class_precedence_list             => 'ARRAY',
 394            compute_all_applicable_attributes => 'ARRAY',
 395            get_meta_instance                 => 'SCALAR',
 396            get_method_map                    => 'SCALAR',
 397            # maybe ....
 398            calculate_all_roles               => 'ARRAY',
 399        },
 400        # NOTE:
 401        # this is ugly, but so are typeglobs,
 402        # so whattayahgonnadoboutit
 403        # - SL
 404        wrapped => {
 405            add_package_symbol => sub {
 406                my $original = shift;
 407                $self->throw_error("Cannot add package symbols to an immutable metaclass")
 408                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
 409                goto $original->body;
 410            },
 411        },
 412     });
 413     return $class;
 414 }
 415
 416 sub make_immutable {
 417     my $self = shift;
 418     $self->SUPER::make_immutable
 419       (
 420        constructor_class => 'Moose::Meta::Method::Constructor',
 421        destructor_class  => 'Moose::Meta::Method::Destructor',
 422        inline_destructor => 1,
 423        # NOTE:
 424        # no need to do this,
 425        # Moose always does it
 426        inline_accessors  => 0,
 427        @_,
 428       );
 429 }
 430
 431 #{ package Moose::Meta::Class::ErrorRoutines; %Carp::Internal?
 432
 433 our $level;
 434
 435 sub throw_error {
 436     my ( $self, @args ) = @_;
 437     local $level = 1;
 438     $self->raise_error($self->create_error(@args));
 439 }
 440
 441 sub raise_error {
 442     my ( $self, @args ) = @_;
 443     die @args;
 444 }
 445
 446 sub create_error {
 447     my ( $self, @args ) = @_;
 448
 449     if ( @args % 2 == 1 ) {
 450         unshift @args, "message";
 451     }
 452
 453     my %args = @args;
 454
 455     local $level = $level + 1;
 456
 457     if ( my $class = $args{class} || ( ref $self && $self->error_class ) ) {
 458         return $self->create_error_object( %args, class => $class );
 459     } else {
 460         my $builder = $args{builder} || ( ref($self) ? $self->error_builder : "confess" );
 461
 462         my $builder_method = ( ( ref($builder) && ref($builder) eq 'CODE' )
 463             ? $builder
 464             : ( $self->can("create_error_$builder") || "create_error_confess" ));
 465
 466         return $self->$builder_method(%args);
 467     }
 468 }
 469
 470 sub create_error_object {
 471     my ( $self, %args ) = @_;
 472
 473     my $class = delete $args{class};
 474
 475     $class->new(
 476         metaclass => $self,
 477         %args,
 478         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
 479     );
 480 }
 481
 482 sub create_error_croak {
 483     my ( $self, @args ) = @_;
 484     $self->_create_error_carpmess( @args );
 485 }
 486
 487 sub create_error_confess {
 488     my ( $self, @args ) = @_;
 489     $self->_create_error_carpmess( @args, longmess => 1 );
 490 }
 491
 492 sub _create_error_carpmess {
 493     my ( $self, %args ) = @_;
 494
 495     my $carp_level = $level + 1 + ( $args{depth} || 1 );
 496
 497     local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
 498     local $Carp::MaxArgNums = 20;         # default is 8, usually we use named args which gets messier though
 499
 500     my @args = exists $args{message} ? $args{message} : ();
 501
 502     if ( $args{longmess} ) {
 503         return Carp::longmess(@args);
 504     } else {
 505         return Carp::shortmess(@args);
 506     }
 507 }
 508
 509 1;
 510
 511 __END__
 512
 513 =pod
 514
 515 =head1 NAME
 516
 517 Moose::Meta::Class - The Moose metaclass
 518
 519 =head1 DESCRIPTION
 520
 521 This is a subclass of L<Class::MOP::Class> with Moose specific
 522 extensions.
 523
 524 For the most part, the only time you will ever encounter an
 525 instance of this class is if you are doing some serious deep
 526 introspection. To really understand this class, you need to refer
 527 to the L<Class::MOP::Class> documentation.
 528
 529 =head1 METHODS
 530
 531 =over 4
 532
 533 =item B<initialize>
 534
 535 =item B<create>
 536
 537 Overrides original to accept a list of roles to apply to
 538 the created class.
 539
 540    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 541
 542 =item B<create_anon_class>
 543
 544 Overrides original to support roles and caching.
 545
 546    my $metaclass = Moose::Meta::Class->create_anon_class(
 547        superclasses => ['Foo'],
 548        roles        => [qw/Some Roles Go Here/],
 549        cache        => 1,
 550    );
 551
 552 =item B<make_immutable>
 553
 554 Override original to add default options for inlining destructor
 555 and altering the Constructor metaclass.
 556
 557 =item B<create_immutable_transformer>
 558
 559 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 560
 561 =item B<new_object>
 562
 563 We override this method to support the C<trigger> attribute option.
 564
 565 =item B<construct_instance>
 566
 567 This provides some Moose specific extensions to this method, you
 568 almost never call this method directly unless you really know what
 569 you are doing.
 570
 571 This method makes sure to handle the moose weak-ref, type-constraint
 572 and type coercion features.
 573
 574 =item B<get_method_map>
 575
 576 This accommodates Moose::Meta::Role::Method instances, which are
 577 aliased, instead of added, but still need to be counted as valid
 578 methods.
 579
 580 =item B<add_override_method_modifier ($name, $method)>
 581
 582 This will create an C<override> method modifier for you, and install
 583 it in the package.
 584
 585 =item B<add_augment_method_modifier ($name, $method)>
 586
 587 This will create an C<augment> method modifier for you, and install
 588 it in the package.
 589
 590 =item B<calculate_all_roles>
 591
 592 =item B<roles>
 593
 594 This will return an array of C<Moose::Meta::Role> instances which are
 595 attached to this class.
 596
 597 =item B<add_role ($role)>
 598
 599 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 600 to the list of associated roles.
 601
 602 =item B<does_role ($role_name)>
 603
 604 This will test if this class C<does> a given C<$role_name>. It will
 605 not only check it's local roles, but ask them as well in order to
 606 cascade down the role hierarchy.
 607
 608 =item B<excludes_role ($role_name)>
 609
 610 This will test if this class C<excludes> a given C<$role_name>. It will
 611 not only check it's local roles, but ask them as well in order to
 612 cascade down the role hierarchy.
 613
 614 =item B<add_attribute ($attr_name, %params|$params)>
 615
 616 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 617 support for taking the C<$params> as a HASH ref.
 618
 619 =item B<throw_error $message, %extra>
 620
 621 Throws the error created by C<create_error> using C<raise_error>
 622
 623 =item B<create_error $message, %extra>
 624
 625 Creates an error message or object.
 626
 627 The default behavior is C<create_error_confess>.
 628
 629 If C<error_class> is set uses C<create_error_object>. Otherwise uses
 630 C<error_builder> (a code reference or variant name), and calls the appropriate
 631 C<create_error_$builder> method.
 632
 633 =item B<error_builder $builder_name>
 634
 635 Get or set the error builder. Defaults to C<confess>.
 636
 637 =item B<error_class $class_name>
 638
 639 Get or set the error class. Has no default.
 640
 641 =item B<create_error_confess %args>
 642
 643 Creates an error using L<Carp/longmess>
 644
 645 =item B<create_error_croak %args>
 646
 647 Creates an error using L<Carp/shortmess>
 648
 649 =item B<create_error_object %args>
 650
 651 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
 652 to support custom error objects for your meta class.
 653
 654 =item B<raise_error $error>
 655
 656 Dies with an error object or string.
 657
 658 =back
 659
 660 =head1 BUGS
 661
 662 All complex software has bugs lurking in it, and this module is no
 663 exception. If you find a bug please either email me, or add the bug
 664 to cpan-RT.
 665
 666 =head1 AUTHOR
 667
 668 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 669
 670 =head1 COPYRIGHT AND LICENSE
 671
 672 Copyright 2006-2008 by Infinity Interactive, Inc.
 673
 674 L<http://www.iinteractive.com>
 675
 676 This library is free software; you can redistribute it and/or modify
 677 it under the same terms as Perl itself.
 678
 679 =cut
 680