lib/Moose/Object.pm

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