%PDF- %PDF-
Direktori : C:/xampp/perl/vendor/lib/MooseX/NonMoose/Meta/Role/ |
Current File : C:/xampp/perl/vendor/lib/MooseX/NonMoose/Meta/Role/Class.pm |
package MooseX::NonMoose::Meta::Role::Class; BEGIN { $MooseX::NonMoose::Meta::Role::Class::AUTHORITY = 'cpan:DOY'; } { $MooseX::NonMoose::Meta::Role::Class::VERSION = '0.26'; } use Moose::Role; # ABSTRACT: metaclass trait for L<MooseX::NonMoose> use List::MoreUtils qw(any); use Module::Runtime qw(use_package_optimistically); use Try::Tiny; has has_nonmoose_constructor => ( is => 'rw', isa => 'Bool', default => 0, ); has has_nonmoose_destructor => ( is => 'rw', isa => 'Bool', default => 0, ); # overrides the constructor_name attr that already exists has constructor_name => ( is => 'rw', isa => 'Str', lazy => 1, default => sub { shift->throw_error("No constructor name has been set") }, ); # XXX ugh, really need to fix this in moose around reinitialize => sub { my $orig = shift; my $class = shift; my ($pkg) = @_; my $meta = blessed($pkg) ? $pkg : Moose::Util::find_meta($pkg); $class->$orig( @_, (map { $_->init_arg => $_->get_value($meta) } grep { $_->has_value($meta) } map { $meta->meta->find_attribute_by_name($_) } qw(has_nonmoose_constructor has_nonmoose_destructor constructor_name)), ); }; sub _determine_constructor_options { my $self = shift; my @options = @_; # if we're using just the metaclass trait, but not the constructor trait, # then suppress the warning about not inlining a constructor my $cc_meta = Moose::Util::find_meta($self->constructor_class); return (@options, inline_constructor => 0) unless $cc_meta->can('does_role') && $cc_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor'); # do nothing if we explicitly ask for the constructor to not be inlined my %options = @options; return @options if !$options{inline_constructor}; my $constructor_name = $self->constructor_name; my $local_constructor = $self->get_method($constructor_name); if (!defined($local_constructor)) { warn "Not inlining a constructor for " . $self->name . " since " . "its parent " . ($self->superclasses)[0] . " doesn't contain a " . "constructor named '$constructor_name'. " . "If you are certain you don't need to inline your" . " constructor, specify inline_constructor => 0 in your" . " call to " . $self->name . "->meta->make_immutable\n"; return @options; } # do nothing if extends was called, but we then added a method modifier to # the constructor (this will warn, but that's okay) # XXX: this is a fairly big hack, but it should cover most of the cases # that actually show up in practice... it would be nice to do this properly # though return @options if $local_constructor->isa('Class::MOP::Method::Wrapped'); # otherwise, explicitly ask for the constructor to be replaced (to suppress # the warning message), since this is the expected usage, and shouldn't # cause a warning return (replace_constructor => 1, @options); } sub _determine_destructor_options { my $self = shift; my @options = @_; return (@options, inline_destructor => 0); } around _immutable_options => sub { my $orig = shift; my $self = shift; my @options = $self->$orig(@_); # do nothing if extends was never called return @options if !$self->has_nonmoose_constructor && !$self->has_nonmoose_destructor; @options = $self->_determine_constructor_options(@options); @options = $self->_determine_destructor_options(@options); return @options; }; sub _check_superclass_constructor { my $self = shift; # if the current class defined a custom new method (since subs happen at # BEGIN time), don't try to override it return if $self->has_method($self->constructor_name); # we need to get the non-moose constructor from the superclass # of the class where this method actually exists, regardless of what class # we're calling it on my $super_new = $self->find_next_method_by_name($self->constructor_name); # if we're trying to extend a (non-immutable) moose class, just do nothing return if $super_new->package_name eq 'Moose::Object'; if ($super_new->associated_metaclass->can('constructor_class')) { my $constructor_class_meta = Class::MOP::Class->initialize( $super_new->associated_metaclass->constructor_class ); # if the constructor we're inheriting is already one of ours, there's # no reason to install a new one return if $constructor_class_meta->can('does_role') && $constructor_class_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor'); # if the constructor we're inheriting is an inlined version of the # default moose constructor, don't do anything either return if any { $_->isa($constructor_class_meta->name) } $super_new->associated_metaclass->_inlined_methods; } $self->add_method($self->constructor_name => sub { my $class = shift; my $params = $class->BUILDARGS(@_); my @foreign_params = $class->can('FOREIGNBUILDARGS') ? $class->FOREIGNBUILDARGS(@_) : @_; my $instance = $super_new->execute($class, @foreign_params); if (!blessed($instance)) { confess "The constructor for " . $super_new->associated_metaclass->name . " did not return a blessed instance"; } elsif (!$instance->isa($class)) { if (!$class->isa(blessed($instance))) { confess "The constructor for " . $super_new->associated_metaclass->name . " returned an object whose class is not a parent of " . $class; } else { bless $instance, $class; } } return Class::MOP::Class->initialize($class)->new_object( __INSTANCE__ => $instance, %$params, ); }); $self->has_nonmoose_constructor(1); } sub _check_superclass_destructor { my $self = shift; # if the current class defined a custom DESTROY method (since subs happen # at BEGIN time), don't try to override it return if $self->has_method('DESTROY'); # we need to get the non-moose destructor from the superclass # of the class where this method actually exists, regardless of what class # we're calling it on my $super_DESTROY = $self->find_next_method_by_name('DESTROY'); # if we're trying to extend a (non-immutable) moose class, just do nothing return if $super_DESTROY->package_name eq 'Moose::Object'; if ($super_DESTROY->associated_metaclass->can('destructor_class') && $super_DESTROY->associated_metaclass->destructor_class) { my $destructor_class_meta = Class::MOP::Class->initialize( $super_DESTROY->associated_metaclass->destructor_class ); # if the destructor we're inheriting is an inlined version of the # default moose destructor, don't do anything return if any { $_->isa($destructor_class_meta->name) } $super_DESTROY->associated_metaclass->_inlined_methods; } $self->add_method(DESTROY => sub { my $self = shift; local $?; Try::Tiny::try { $super_DESTROY->execute($self); $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction); } Try::Tiny::catch { # Without this, Perl will warn "\t(in cleanup)$@" because of some # bizarre fucked-up logic deep in the internals. no warnings 'misc'; die $_; }; return; }); $self->has_nonmoose_destructor(1); } around superclasses => sub { my $orig = shift; my $self = shift; return $self->$orig unless @_; # XXX lots of duplication between here and MMC::superclasses my ($constructor_name, $constructor_class); for my $super (@{ Data::OptList::mkopt(\@_) }) { my ($name, $opts) = @{ $super }; my $cur_constructor_name = delete $opts->{'-constructor_name'}; if (defined($constructor_name) && defined($cur_constructor_name)) { $self->throw_error( "You have already specified " . "${constructor_class}::${constructor_name} as the parent " . "constructor; ${name}::${cur_constructor_name} cannot also be " . "the constructor" ); } if ($opts && exists($opts->{-version})) { use_package_optimistically($name, $opts->{-version}); } else { use_package_optimistically($name); } if (defined($cur_constructor_name)) { my $meta = Moose::Util::find_meta($name); $self->throw_error( "You specified '$cur_constructor_name' as the constructor for " . "$name, but $name has no method by that name" ) unless $meta ? $meta->find_method_by_name($cur_constructor_name) : $name->can($cur_constructor_name); } if (!defined($constructor_name)) { $constructor_name = $cur_constructor_name; $constructor_class = $name; } delete $opts->{'-constructor_name'}; } $self->constructor_name( defined($constructor_name) ? $constructor_name : 'new' ); my @superclasses = @_; push @superclasses, 'Moose::Object' unless grep { !ref($_) && $_->isa('Moose::Object') } @superclasses; my @ret = $self->$orig(@superclasses); $self->_check_superclass_constructor; $self->_check_superclass_destructor; return @ret; }; sub _generate_fallback_constructor { my $self = shift; my ($class_var) = @_; my $new = $self->constructor_name; my $super_new_class = $self->_find_next_nonmoose_constructor_package; my $arglist = $self->find_method_by_name('FOREIGNBUILDARGS') ? "${class_var}->FOREIGNBUILDARGS(\@_)" : '@_'; my $instance = "${class_var}->${super_new_class}::$new($arglist)"; # XXX: the "my $__DUMMY = " part is because "return do" triggers a weird # bug in pre-5.12 perls (it ends up returning undef) return '(my $__DUMMY = do { ' . 'if (ref($_[0]) eq \'HASH\') { ' . '$_[0]->{__INSTANCE__} = ' . $instance . ' ' . 'unless exists $_[0]->{__INSTANCE__}; ' . '} ' . 'else { ' . 'unshift @_, __INSTANCE__ => ' . $instance . '; ' . '} ' . $class_var . '->Moose::Object::new(@_); ' . '})'; } sub _inline_generate_instance { my $self = shift; my ($var, $class_var) = @_; my $new = $self->constructor_name; my $super_new_class = $self->_find_next_nonmoose_constructor_package; my $arglist = $self->find_method_by_name('FOREIGNBUILDARGS') ? "${class_var}->FOREIGNBUILDARGS(\@_)" : '@_'; my $instance = "${class_var}->${super_new_class}::$new($arglist)"; return ( 'my ' . $var . ' = ' . $instance . ';', 'if (!Scalar::Util::blessed(' . $var . ')) {', $self->_inline_throw_error( '"The constructor for ' . $super_new_class . ' did not return a blessed instance"', ) . ';', '}', 'elsif (!' . $var . '->isa(' . $class_var . ')) {', 'if (!' . $class_var . '->isa(Scalar::Util::blessed(' . $var . '))) {', $self->_inline_throw_error( '"The constructor for ' . $super_new_class . ' returned an object whose class is not a parent of ' . $class_var . '"', ) . ';', '}', 'else {', $self->_inline_rebless_instance($var, $class_var) . ';', '}', '}', ); } sub _find_next_nonmoose_constructor_package { my $self = shift; my $new = $self->constructor_name; for my $method (map { $_->{code} } $self->find_all_methods_by_name($new)) { next if $method->associated_metaclass->meta->can('does_role') && $method->associated_metaclass->meta->does_role('MooseX::NonMoose::Meta::Role::Class'); return $method->package_name; } # this should never happen (it should find Moose::Object at least) $self->throw_error("Couldn't find a non-Moose constructor for " . $self->name); } no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::NonMoose::Meta::Role::Class - metaclass trait for L<MooseX::NonMoose> =head1 VERSION version 0.26 =head1 SYNOPSIS package Foo; use Moose -traits => 'MooseX::NonMoose::Meta::Role::Class'; # or package My::Moose; use Moose (); use Moose::Exporter; Moose::Exporter->setup_import_methods; sub init_meta { shift; my %options = @_; Moose->init_meta(%options); Moose::Util::MetaRole::apply_metaclass_roles( for_class => $options{for_class}, metaclass_roles => ['MooseX::NonMoose::Meta::Role::Class'], ); return Moose::Util::find_meta($options{for_class}); } =head1 DESCRIPTION This trait implements everything involved with extending non-Moose classes, other than doing the actual inlining at C<make_immutable> time. See L<MooseX::NonMoose> for more details. =head1 AUTHOR Jesse Luehrs <doy@tozt.net> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Jesse Luehrs. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut