lib/Moose/Object.pm

   1
   2 package Moose::Object;
   3
   4 use strict;
   5 use warnings;
   6
   7 use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
   8 use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
   9
  10 our $VERSION   = '0.72_01';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 sub new {
  15     my $class = shift;
  16     my $params = $class->BUILDARGS(@_);
  17     my $self = $class->meta->new_object($params);
  18     $self->BUILDALL($params);
  19     return $self;
  20 }
  21
  22 sub BUILDARGS {
  23     my $class = shift;
  24     if ( scalar @_ == 1 ) {
  25         unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
  26             $class->meta->throw_error(
  27                 "Single parameters to new() must be a HASH ref",
  28                 data => $_[0] );
  29         }
  30         return { %{ $_[0] } };
  31     }
  32     else {
  33         return {@_};
  34     }
  35 }
  36
  37 sub BUILDALL {
  38     # NOTE: we ask Perl if we even
  39     # need to do this first, to avoid
  40     # extra meta level calls
  41     return unless $_[0]->can('BUILD');
  42     my ($self, $params) = @_;
  43     foreach my $method (reverse $self->meta->find_all_methods_by_name('BUILD')) {
  44         $method->{code}->execute($self, $params);
  45     }
  46 }
  47
  48 sub DEMOLISHALL {
  49     my $self = shift;
  50     # NOTE: we ask Perl if we even
  51     # need to do this first, to avoid
  52     # extra meta level calls
  53     return unless $self->can('DEMOLISH');
  54     foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
  55         $method->{code}->execute($self);
  56     }
  57 }
  58
  59 sub DESTROY {
  60     # if we have an exception here ...
  61     if ($@) {
  62         # localize the $@ ...
  63         local $@;
  64         # run DEMOLISHALL ourselves, ...
  65         $_[0]->DEMOLISHALL;
  66         # and return ...
  67         return;
  68     }
  69     # otherwise it is normal destruction
  70     $_[0]->DEMOLISHALL;
  71 }
  72
  73 # support for UNIVERSAL::DOES ...
  74 BEGIN {
  75     my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa";
  76     eval 'sub DOES {
  77         my ( $self, $class_or_role_name ) = @_;
  78         return $self->'.$does.'($class_or_role_name)
  79             || $self->does($class_or_role_name);
  80     }';
  81 }
  82
  83 # new does() methods will be created
  84 # as appropiate see Moose::Meta::Role
  85 sub does {
  86     my ($self, $role_name) = @_;
  87     my $meta = $self->meta;
  88     (defined $role_name)
  89         || $meta->throw_error("You much supply a role name to does()");
  90     foreach my $class ($meta->class_precedence_list) {
  91         my $m = $meta->initialize($class);
  92         return 1
  93             if $m->can('does_role') && $m->does_role($role_name);
  94     }
  95     return 0;
  96 }
  97
  98 sub dump {
  99     my $self = shift;
 100     require Data::Dumper;
 101     local $Data::Dumper::Maxdepth = shift if @_;
 102     Data::Dumper::Dumper $self;
 103 }
 104
 105 1;
 106
 107 __END__
 108
 109 =pod
 110
 111 =head1 NAME
 112
 113 Moose::Object - The base object for Moose
 114
 115 =head1 DESCRIPTION
 116
 117 This class is the default base class for all Moose-using classes. When
 118 you C<use Moose> in this class, your class will inherit from this
 119 class.
 120
 121 It provides a default constructor and destructor, which run the
 122 C<BUILDALL> and C<DEMOLISHALL> methods respectively.
 123
 124 You don't actually I<need> to inherit from this in order to use Moose,
 125 but it makes it easier to take advantage of all of Moose's features.
 126
 127 =head1 METHODS
 128
 129 =over 4
 130
 131 =item B<< Moose::Object->new(%params) >>
 132
 133 This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new
 134 instance of the appropriate class. Once the instance is created, it
 135 calls C<< $instance->BUILDALL($params) >>.
 136
 137 =item B<< Moose::Object->BUILDARGS(%params) >>
 138
 139 The default implementation of this method accepts a hash or hash
 140 reference of named parameters. If it receives a single argument that
 141 I<isn't> a hash reference it throws an error.
 142
 143 You can override this method in your class to handle other types of
 144 options passed to the constructor.
 145
 146 This method should always return a hash reference of named options.
 147
 148 =item B<< $object->BUILDALL($params) >>
 149
 150 This method will call every C<BUILD> method in the inheritance
 151 hierarchy, starting with the most distant parent class and ending with
 152 the object's class.
 153
 154 The C<BUILD> method will be passed the hash reference returned by
 155 C<BUILDARGS>.
 156
 157 =item B<< $object->DEMOLISHALL >>
 158
 159 This will call every C<DEMOLISH> method in the inheritance hierarchy,
 160 starting with the object's class and ending with the most distant
 161 parent.
 162
 163 =item B<< $object->does($role_name) >>
 164
 165 This returns true if the object does the given role.
 166
 167 =item B<DOES ($class_or_role_name)>
 168
 169 This is a a Moose role-aware implementation of L<UNIVERSAL/DOES>.
 170
 171 This is effectively the same as writing:
 172
 173   $object->does($name) || $object->isa($name)
 174
 175 This method will work with Perl 5.8, which did not implement
 176 C<UNIVERSAL::DOES>.
 177
 178 =item B<< $object->dump($maxdepth) >>
 179
 180 This is a handy utility for C<Data::Dumper>ing an object. By default,
 181 the maximum depth is 1, to avoid making a mess.
 182
 183 =back
 184
 185 =head1 BUGS
 186
 187 All complex software has bugs lurking in it, and this module is no
 188 exception. If you find a bug please either email me, or add the bug
 189 to cpan-RT.
 190
 191 =head1 AUTHOR
 192
 193 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 194
 195 =head1 COPYRIGHT AND LICENSE
 196
 197 Copyright 2006-2009 by Infinity Interactive, Inc.
 198
 199 L<http://www.iinteractive.com>
 200
 201 This library is free software; you can redistribute it and/or modify
 202 it under the same terms as Perl itself.
 203
 204 =cut