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