lib/Moose/Object.pm

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