lib/Moose/Object.pm

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