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 = ( meta => $self, error => $@, @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         %args,
 482         depth => ( ($args{depth} || 1) + ( $level + 1 ) ),
 483     );
 484 }
 485
 486 sub create_error_croak {
 487     my ( $self, @args ) = @_;
 488     $self->_create_error_carpmess( @args );
 489 }
 490
 491 sub create_error_confess {
 492     my ( $self, @args ) = @_;
 493     $self->_create_error_carpmess( @args, longmess => 1 );
 494 }
 495
 496 sub _create_error_carpmess {
 497     my ( $self, %args ) = @_;
 498
 499     my $carp_level = $level + 1 + ( $args{depth} || 1 );
 500
 501     local $Carp::CarpLevel = $carp_level; # $Carp::CarpLevel + $carp_level ?
 502     local $Carp::MaxArgNums = 20;         # default is 8, usually we use named args which gets messier though
 503
 504     my @args = exists $args{message} ? $args{message} : ();
 505
 506     if ( $args{longmess} ) {
 507         return Carp::longmess(@args);
 508     } else {
 509         return Carp::shortmess(@args);
 510     }
 511 }
 512
 513 1;
 514
 515 __END__
 516
 517 =pod
 518
 519 =head1 NAME
 520
 521 Moose::Meta::Class - The Moose metaclass
 522
 523 =head1 DESCRIPTION
 524
 525 This is a subclass of L<Class::MOP::Class> with Moose specific
 526 extensions.
 527
 528 For the most part, the only time you will ever encounter an
 529 instance of this class is if you are doing some serious deep
 530 introspection. To really understand this class, you need to refer
 531 to the L<Class::MOP::Class> documentation.
 532
 533 =head1 METHODS
 534
 535 =over 4
 536
 537 =item B<initialize>
 538
 539 =item B<create>
 540
 541 Overrides original to accept a list of roles to apply to
 542 the created class.
 543
 544    my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
 545
 546 =item B<create_anon_class>
 547
 548 Overrides original to support roles and caching.
 549
 550    my $metaclass = Moose::Meta::Class->create_anon_class(
 551        superclasses => ['Foo'],
 552        roles        => [qw/Some Roles Go Here/],
 553        cache        => 1,
 554    );
 555
 556 =item B<make_immutable>
 557
 558 Override original to add default options for inlining destructor
 559 and altering the Constructor metaclass.
 560
 561 =item B<create_immutable_transformer>
 562
 563 Override original to lock C<add_role> and memoize C<calculate_all_roles>
 564
 565 =item B<new_object>
 566
 567 We override this method to support the C<trigger> attribute option.
 568
 569 =item B<construct_instance>
 570
 571 This provides some Moose specific extensions to this method, you
 572 almost never call this method directly unless you really know what
 573 you are doing.
 574
 575 This method makes sure to handle the moose weak-ref, type-constraint
 576 and type coercion features.
 577
 578 =item B<get_method_map>
 579
 580 This accommodates Moose::Meta::Role::Method instances, which are
 581 aliased, instead of added, but still need to be counted as valid
 582 methods.
 583
 584 =item B<add_override_method_modifier ($name, $method)>
 585
 586 This will create an C<override> method modifier for you, and install
 587 it in the package.
 588
 589 =item B<add_augment_method_modifier ($name, $method)>
 590
 591 This will create an C<augment> method modifier for you, and install
 592 it in the package.
 593
 594 =item B<calculate_all_roles>
 595
 596 =item B<roles>
 597
 598 This will return an array of C<Moose::Meta::Role> instances which are
 599 attached to this class.
 600
 601 =item B<add_role ($role)>
 602
 603 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 604 to the list of associated roles.
 605
 606 =item B<does_role ($role_name)>
 607
 608 This will test if this class C<does> a given C<$role_name>. It will
 609 not only check it's local roles, but ask them as well in order to
 610 cascade down the role hierarchy.
 611
 612 =item B<excludes_role ($role_name)>
 613
 614 This will test if this class C<excludes> a given C<$role_name>. It will
 615 not only check it's local roles, but ask them as well in order to
 616 cascade down the role hierarchy.
 617
 618 =item B<add_attribute ($attr_name, %params|$params)>
 619
 620 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 621 support for taking the C<$params> as a HASH ref.
 622
 623 =item B<throw_error $message, %extra>
 624
 625 Throws the error created by C<create_error> using C<raise_error>
 626
 627 =item B<create_error $message, %extra>
 628
 629 Creates an error message or object.
 630
 631 The default behavior is C<create_error_confess>.
 632
 633 If C<error_class> is set uses C<create_error_object>. Otherwise uses
 634 C<error_builder> (a code reference or variant name), and calls the appropriate
 635 C<create_error_$builder> method.
 636
 637 =item B<error_builder $builder_name>
 638
 639 Get or set the error builder. Defaults to C<confess>.
 640
 641 =item B<error_class $class_name>
 642
 643 Get or set the error class. Has no default.
 644
 645 =item B<create_error_confess %args>
 646
 647 Creates an error using L<Carp/longmess>
 648
 649 =item B<create_error_croak %args>
 650
 651 Creates an error using L<Carp/shortmess>
 652
 653 =item B<create_error_object %args>
 654
 655 Calls C<new> on the C<class> parameter in C<%args>. Usable with C<error_class>
 656 to support custom error objects for your meta class.
 657
 658 =item B<raise_error $error>
 659
 660 Dies with an error object or string.
 661
 662 =back
 663
 664 =head1 BUGS
 665
 666 All complex software has bugs lurking in it, and this module is no
 667 exception. If you find a bug please either email me, or add the bug
 668 to cpan-RT.
 669
 670 =head1 AUTHOR
 671
 672 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 673
 674 =head1 COPYRIGHT AND LICENSE
 675
 676 Copyright 2006-2008 by Infinity Interactive, Inc.
 677
 678 L<http://www.iinteractive.com>
 679
 680 This library is free software; you can redistribute it and/or modify
 681 it under the same terms as Perl itself.
 682
 683 =cut
 684