X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FObject.pm;h=8dc841c065553788dcad54271d7993e56dbff803;hb=75b9541431131c67521bd1ec75df80c9707bd719;hp=6df798f446dd5bfe641cfcd66f1aac3c4874ae5c;hpb=c0e30cf5d3bbad2b5622975e47c08d8d009e1e97;p=gitmo%2FMoose.git diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm index 6df798f..8dc841c 100644 --- a/lib/Moose/Object.pm +++ b/lib/Moose/Object.pm @@ -3,31 +3,117 @@ package Moose::Object; use strict; use warnings; -use metaclass; + +use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class'; +use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class'; + +use Carp 'confess'; + +our $VERSION = '0.55_01'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; sub new { - my $class = shift; - my %params = @_; - my $self = $class->meta->new_object(%params); - $self->BUILDALL(%params); - return $self; + my $class = shift; + my $params = $class->BUILDARGS(@_); + my $self = $class->meta->new_object($params); + $self->BUILDALL($params); + return $self; +} + +sub BUILDARGS { + my $class = shift; + if (scalar @_ == 1) { + if (defined $_[0]) { + (ref($_[0]) eq 'HASH') + || confess "Single parameters to new() must be a HASH ref"; + return {%{$_[0]}}; + } + else { + return {}; # FIXME this is compat behavior, but is it correct? + } + } + else { + return {@_}; + } } sub BUILDALL { - my ($self, %params) = @_; - foreach my $method ($self->meta->find_all_methods_by_name('BUILD')) { - $method->{method}->($self, %params); - } + # NOTE: we ask Perl if we even + # need to do this first, to avoid + # extra meta level calls + return unless $_[0]->can('BUILD'); + my ($self, $params) = @_; + foreach my $method (reverse $self->meta->find_all_methods_by_name('BUILD')) { + $method->{code}->body->($self, $params); + } } sub DEMOLISHALL { - my $self = shift; - foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) { - $method->{method}->($self); - } + my $self = shift; + foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) { + $method->{code}->body->($self); + } } -sub DESTROY { goto &DEMOLISHALL } +sub DESTROY { + # NOTE: we ask Perl if we even + # need to do this first, to avoid + # extra meta level calls + return unless $_[0]->can('DEMOLISH'); + # if we have an exception here ... + if ($@) { + # localize the $@ ... + local $@; + # run DEMOLISHALL ourselves, ... + $_[0]->DEMOLISHALL; + # and return ... + return; + } + # otherwise it is normal destruction + $_[0]->DEMOLISHALL; +} + +# support for UNIVERSAL::DOES ... +BEGIN { + my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa"; + eval 'sub DOES { + my ( $self, $class_or_role_name ) = @_; + return $self->'.$does.'($class_or_role_name) + || $self->does($class_or_role_name); + }'; +} + +# new does() methods will be created +# as approiate see Moose::Meta::Role +sub does { + my ($self, $role_name) = @_; + (defined $role_name) + || confess "You must supply a role name to does()"; + my $meta = $self->meta; + foreach my $class ($meta->class_precedence_list) { + my $m = $meta->initialize($class); + return 1 + if $m->can('does_role') && $m->does_role($role_name); + } + return 0; +} + +# RANT: +# Cmon, how many times have you written +# the following code while debugging: +# +# use Data::Dumper; +# warn Dumper \%thing; +# +# It can get seriously annoying, so why +# not just do this ... +sub dump { + my $self = shift; + require Data::Dumper; + local $Data::Dumper::Maxdepth = shift if @_; + Data::Dumper::Dumper $self; +} 1; @@ -37,24 +123,65 @@ __END__ =head1 NAME -Moose::Object - - -=head1 SYNOPSIS +Moose::Object - The base object for Moose =head1 DESCRIPTION +This serves as the base object for all Moose classes. Every +effort will be made to ensure that all classes which C +will inherit from this class. It provides a default constructor +and destructor, which run all the BUILD and DEMOLISH methods in +the class tree. + +You don't actually I to inherit from this in order to +use Moose though. It is just here to make life easier. + =head1 METHODS =over 4 =item B +This will return the metaclass associated with the given class. + =item B +This will call C, create a new instance and call C. + +=item B + +This method processes an argument list into a hash reference. It is used by +C. + =item B +This will call every C method in the inheritance hierarchy, +and pass it a hash-ref of the the C<%params> passed to C. + =item B +This will call every C method in the inheritance hierarchy. + +=item B + +This will check if the invocant's class C a given C<$role_name>. +This is similar to C for object, but it checks the roles instead. + +=item B + +A Moose Role aware implementation of L. + +C is equivalent to C or C. + +=item B + +Cmon, how many times have you written the following code while debugging: + + use Data::Dumper; + warn Dumper $obj; + +It can get seriously annoying, so why not just use this. + =back =head1 BUGS @@ -63,24 +190,17 @@ All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. -=head1 CODE COVERAGE - -I use L to test the code coverage of my tests, below is the -L report on this module's test suite. - -=head1 ACKNOWLEDGEMENTS - =head1 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut