lib/Moose/Object.pm

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