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