lib/Moose/Object.pm

   1
   2 package Moose::Object;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp ();
   8 use Devel::GlobalDestruction ();
   9 use MRO::Compat ();
  10 use Scalar::Util ();
  11 use Try::Tiny ();
  12
  13 use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
  14 use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
  15
  16 our $VERSION   = '1.9900';
  17 $VERSION = eval $VERSION;
  18 our $AUTHORITY = 'cpan:STEVAN';
  19
  20 sub new {
  21     my $class = shift;
  22     my $real_class = Scalar::Util::blessed($class) || $class;
  23
  24     my $params = $real_class->BUILDARGS(@_);
  25
  26     return Class::MOP::Class->initialize($real_class)->new_object($params);
  27 }
  28
  29 sub BUILDARGS {
  30     my $class = shift;
  31     if ( scalar @_ == 1 ) {
  32         unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
  33             Class::MOP::class_of($class)->throw_error(
  34                 "Single parameters to new() must be a HASH ref",
  35                 data => $_[0] );
  36         }
  37         return { %{ $_[0] } };
  38     }
  39     elsif ( @_ % 2 ) {
  40         Carp::carp(
  41             "The new() method for $class expects a hash reference or a key/value list."
  42                 . " You passed an odd number of arguments" );
  43         return { @_, undef };
  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 must supply a role name to does()");
 125     return 1 if $meta->can('does_role') && $meta->does_role($role_name);
 126     return 0;
 127 }
 128
 129 sub dump {
 130     my $self = shift;
 131     require Data::Dumper;
 132     local $Data::Dumper::Maxdepth = shift if @_;
 133     Data::Dumper::Dumper $self;
 134 }
 135
 136 1;
 137
 138 __END__
 139
 140 =pod
 141
 142 =head1 NAME
 143
 144 Moose::Object - The base object for Moose
 145
 146 =head1 DESCRIPTION
 147
 148 This class is the default base class for all Moose-using classes. When
 149 you C<use Moose> in this class, your class will inherit from this
 150 class.
 151
 152 It provides a default constructor and destructor, which run the
 153 C<BUILDALL> and C<DEMOLISHALL> methods respectively.
 154
 155 You don't actually I<need> to inherit from this in order to use Moose,
 156 but it makes it easier to take advantage of all of Moose's features.
 157
 158 =head1 METHODS
 159
 160 =over 4
 161
 162 =item B<< Moose::Object->new(%params) >>
 163
 164 This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new
 165 instance of the appropriate class. Once the instance is created, it
 166 calls C<< $instance->BUILDALL($params) >>.
 167
 168 =item B<< Moose::Object->BUILDARGS(%params) >>
 169
 170 The default implementation of this method accepts a hash or hash
 171 reference of named parameters. If it receives a single argument that
 172 I<isn't> a hash reference it throws an error.
 173
 174 You can override this method in your class to handle other types of
 175 options passed to the constructor.
 176
 177 This method should always return a hash reference of named options.
 178
 179 =item B<< $object->BUILDALL($params) >>
 180
 181 This method will call every C<BUILD> method in the inheritance
 182 hierarchy, starting with the most distant parent class and ending with
 183 the object's class.
 184
 185 The C<BUILD> method will be passed the hash reference returned by
 186 C<BUILDARGS>.
 187
 188 =item B<< $object->DEMOLISHALL >>
 189
 190 This will call every C<DEMOLISH> method in the inheritance hierarchy,
 191 starting with the object's class and ending with the most distant
 192 parent. C<DEMOLISHALL> and C<DEMOLISH> will receive a boolean
 193 indicating whether or not we are currently in global destruction.
 194
 195 =item B<< $object->does($role_name) >>
 196
 197 This returns true if the object does the given role.
 198
 199 =item B<DOES ($class_or_role_name)>
 200
 201 This is a a Moose role-aware implementation of L<UNIVERSAL/DOES>.
 202
 203 This is effectively the same as writing:
 204
 205   $object->does($name) || $object->isa($name)
 206
 207 This method will work with Perl 5.8, which did not implement
 208 C<UNIVERSAL::DOES>.
 209
 210 =item B<< $object->dump($maxdepth) >>
 211
 212 This is a handy utility for C<Data::Dumper>ing an object. By default,
 213 the maximum depth is 1, to avoid making a mess.
 214
 215 =back
 216
 217 =head1 BUGS
 218
 219 See L<Moose/BUGS> for details on reporting bugs.
 220
 221 =head1 AUTHOR
 222
 223 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 224
 225 =head1 COPYRIGHT AND LICENSE
 226
 227 Copyright 2006-2010 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