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