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