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.73_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     # NOTE: we ask Perl if we even
  60     # need to do this first, to avoid
  61     # extra meta level calls
  62     return unless $self->can('DEMOLISH');
  63     foreach my $method (Class::MOP::class_of($self)->find_all_methods_by_name('DEMOLISH')) {
  64         $method->{code}->execute($self);
  65     }
  66 }
  67
  68 sub DESTROY {
  69     # if we have an exception here ...
  70     if ($@) {
  71         # localize the $@ ...
  72         local $@;
  73         # run DEMOLISHALL ourselves, ...
  74         $_[0]->DEMOLISHALL;
  75         # and return ...
  76         return;
  77     }
  78     # otherwise it is normal destruction
  79     $_[0]->DEMOLISHALL;
  80 }
  81
  82 # support for UNIVERSAL::DOES ...
  83 BEGIN {
  84     my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa";
  85     eval 'sub DOES {
  86         my ( $self, $class_or_role_name ) = @_;
  87         return $self->'.$does.'($class_or_role_name)
  88             || $self->does($class_or_role_name);
  89     }';
  90 }
  91
  92 # new does() methods will be created
  93 # as appropiate see Moose::Meta::Role
  94 sub does {
  95     my ($self, $role_name) = @_;
  96     my $meta = Class::MOP::class_of($self);
  97     (defined $role_name)
  98         || $meta->throw_error("You much supply a role name to does()");
  99     foreach my $class ($meta->class_precedence_list) {
 100         my $m = $meta->initialize($class);
 101         return 1
 102             if $m->can('does_role') && $m->does_role($role_name);
 103     }
 104     return 0;
 105 }
 106
 107 sub dump {
 108     my $self = shift;
 109     require Data::Dumper;
 110     local $Data::Dumper::Maxdepth = shift if @_;
 111     Data::Dumper::Dumper $self;
 112 }
 113
 114 1;
 115
 116 __END__
 117
 118 =pod
 119
 120 =head1 NAME
 121
 122 Moose::Object - The base object for Moose
 123
 124 =head1 DESCRIPTION
 125
 126 This class is the default base class for all Moose-using classes. When
 127 you C<use Moose> in this class, your class will inherit from this
 128 class.
 129
 130 It provides a default constructor and destructor, which run the
 131 C<BUILDALL> and C<DEMOLISHALL> methods respectively.
 132
 133 You don't actually I<need> to inherit from this in order to use Moose,
 134 but it makes it easier to take advantage of all of Moose's features.
 135
 136 =head1 METHODS
 137
 138 =over 4
 139
 140 =item B<< Moose::Object->new(%params) >>
 141
 142 This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new
 143 instance of the appropriate class. Once the instance is created, it
 144 calls C<< $instance->BUILDALL($params) >>.
 145
 146 =item B<< Moose::Object->BUILDARGS(%params) >>
 147
 148 The default implementation of this method accepts a hash or hash
 149 reference of named parameters. If it receives a single argument that
 150 I<isn't> a hash reference it throws an error.
 151
 152 You can override this method in your class to handle other types of
 153 options passed to the constructor.
 154
 155 This method should always return a hash reference of named options.
 156
 157 =item B<< $object->BUILDALL($params) >>
 158
 159 This method will call every C<BUILD> method in the inheritance
 160 hierarchy, starting with the most distant parent class and ending with
 161 the object's class.
 162
 163 The C<BUILD> method will be passed the hash reference returned by
 164 C<BUILDARGS>.
 165
 166 =item B<< $object->DEMOLISHALL >>
 167
 168 This will call every C<DEMOLISH> method in the inheritance hierarchy,
 169 starting with the object's class and ending with the most distant
 170 parent.
 171
 172 =item B<< $object->does($role_name) >>
 173
 174 This returns true if the object does the given role.
 175
 176 =item B<DOES ($class_or_role_name)>
 177
 178 This is a a Moose role-aware implementation of L<UNIVERSAL/DOES>.
 179
 180 This is effectively the same as writing:
 181
 182   $object->does($name) || $object->isa($name)
 183
 184 This method will work with Perl 5.8, which did not implement
 185 C<UNIVERSAL::DOES>.
 186
 187 =item B<< $object->dump($maxdepth) >>
 188
 189 This is a handy utility for C<Data::Dumper>ing an object. By default,
 190 the maximum depth is 1, to avoid making a mess.
 191
 192 =back
 193
 194 =head1 BUGS
 195
 196 All complex software has bugs lurking in it, and this module is no
 197 exception. If you find a bug please either email me, or add the bug
 198 to cpan-RT.
 199
 200 =head1 AUTHOR
 201
 202 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 203
 204 =head1 COPYRIGHT AND LICENSE
 205
 206 Copyright 2006-2009 by Infinity Interactive, Inc.
 207
 208 L<http://www.iinteractive.com>
 209
 210 This library is free software; you can redistribute it and/or modify
 211 it under the same terms as Perl itself.
 212
 213 =cut