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