File Coverage

blib/lib/Moose/Object.pm
Criterion Covered Total %
statement 77 84 91.6
branch 20 24 83.3
condition 13 15 86.6
subroutine 20 22 90.9
pod 5 7 71.4
total 135 152 88.8


line stmt bran cond sub pod time code
1             package Moose::Object;
2             our $VERSION = '2.2205';
3              
4 379     379   5477 use strict;
  379         1018  
  379         12225  
5 379     379   2164 use warnings;
  379         1058  
  379         9596  
6              
7 379     379   2160 use Carp ();
  379         873  
  379         6514  
8 379     379   2896 use Devel::GlobalDestruction ();
  379         2797  
  379         6621  
9 379     379   2910 use MRO::Compat ();
  379         2612  
  379         7560  
10 379     379   2552 use Scalar::Util ();
  379         1064  
  379         7509  
11 379     379   3025 use Try::Tiny ();
  379         3076  
  379         7384  
12              
13 379     379   2701 use Moose::Util ();
  379         1108  
  379         15384  
14              
15 379     379   273884 use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
  379         5584  
  379         2530  
16 379     379   38514 use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
  379         971  
  379         1624  
17              
18             sub new {
19 3438     3438 1 935049 my $class = shift;
20 3438   66     17065 my $real_class = Scalar::Util::blessed($class) || $class;
21              
22 3438         10833 my $params = $real_class->BUILDARGS(@_);
23              
24 3435         13504 return Class::MOP::Class->initialize($real_class)->new_object($params);
25             }
26              
27             sub BUILDARGS {
28 3428     3428 1 5732 my $class = shift;
29 3428 100       11964 if ( scalar @_ == 1 ) {
    50          
30 14 100 100     152 unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
31 3         19 Moose::Util::throw_exception( "SingleParamsToNewMustBeHashRef" );
32             }
33 11         35 return { %{ $_[0] } };
  11         56  
34             }
35             elsif ( @_ % 2 ) {
36 0         0 Carp::carp(
37             "The new() method for $class expects a hash reference or a key/value list."
38             . " You passed an odd number of arguments" );
39 0         0 return { @_, undef };
40             }
41             else {
42 3414         10003 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 2451 100   2451 0 10990 return unless $_[0]->can('BUILD');
51 30         74 my ($self, $params) = @_;
52 30 100       93 return if $params->{__no_BUILD__};
53 28         100 foreach my $method (reverse Class::MOP::class_of($self)->find_all_methods_by_name('BUILD')) {
54 28         214 $method->{code}->execute($self, $params);
55             }
56             }
57              
58             sub DEMOLISHALL {
59 3419     3419 0 23911 my $self = shift;
60 3419         7664 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 3419 100       18418 return unless $self->can('DEMOLISH');
66              
67 56         100 my @isa;
68 56 100       166 if ( my $meta = Class::MOP::class_of($self ) ) {
69 55         178 @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 1         3 my $class_name = ref $self;
76 1         3 @isa = @{ mro::get_linear_isa($class_name) }
  1         5  
77             }
78              
79 56         184 foreach my $class (@isa) {
80 379     379   3562 no strict 'refs';
  379         1180  
  379         98173  
81 119         1526 my $demolish = *{"${class}::DEMOLISH"}{CODE};
  119         427  
82 119 100       456 $self->$demolish($in_global_destruction)
83             if defined $demolish;
84             }
85             }
86              
87             sub DESTROY {
88 3419     3419   443673 my $self = shift;
89              
90 3419         11749 local $?;
91              
92             # < doy> if the destructor is being called because an exception is thrown, then $@ will be set
93             # < doy> but if DEMOLISH does an eval which succeeds, that will clear $@
94             # < doy> which is broken
95             # < doy> try::tiny implicitly localizes $@ in the try block, which fixes that
96             Try::Tiny::try {
97 3419     3419   225121 $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction);
98             }
99             Try::Tiny::catch {
100 0     0   0 die $_;
101 3419         22002 };
102              
103 3419         74134 return;
104             }
105              
106             # support for UNIVERSAL::DOES ...
107             BEGIN {
108 379 50   379   4515 my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa";
109 379   100 57 1 103551 eval 'sub DOES {
  57         3454  
  57         645  
110             my ( $self, $class_or_role_name ) = @_;
111             return $self->'.$does.'($class_or_role_name)
112             || $self->does($class_or_role_name);
113             }';
114             }
115              
116             # new does() methods will be created
117             # as appropriate see Moose::Meta::Role
118             sub does {
119 540     540 1 32066 my ($self, $role_name) = @_;
120 540   66     2863 my $class = Scalar::Util::blessed($self) || $self;
121 540         2471 my $meta = Class::MOP::Class->initialize($class);
122 540 100       2261 (defined $role_name)
123             || Moose::Util::throw_exception( DoesRequiresRoleName => class_name => $meta->name );
124 537 100 100     4157 return 1 if $meta->can('does_role') && $meta->does_role($role_name);
125 325         1744 return 0;
126             }
127              
128             sub dump {
129 0     0 1   my $self = shift;
130 0           require Data::Dumper;
131 0 0         local $Data::Dumper::Maxdepth = shift if @_;
132 0           Data::Dumper::Dumper $self;
133             }
134              
135             1;
136              
137             # ABSTRACT: The base object for Moose
138              
139             __END__
140              
141             =pod
142              
143             =encoding UTF-8
144              
145             =head1 NAME
146              
147             Moose::Object - The base object for Moose
148              
149             =head1 VERSION
150              
151             version 2.2205
152              
153             =head1 DESCRIPTION
154              
155             This class is the default base class for all Moose-using classes. When
156             you C<use Moose> in this class, your class will inherit from this
157             class.
158              
159             It provides a default constructor and destructor, which run all of the
160             C<BUILD> and C<DEMOLISH> methods in the inheritance hierarchy,
161             respectively.
162              
163             You don't actually I<need> to inherit from this in order to use Moose,
164             but it makes it easier to take advantage of all of Moose's features.
165              
166             =head1 METHODS
167              
168             =head2 Moose::Object->new(%params|$params)
169              
170             This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new
171             instance of the appropriate class. Once the instance is created, it
172             calls C<< $instance->BUILD($params) >> for each C<BUILD> method in the
173             inheritance hierarchy.
174              
175             =head2 Moose::Object->BUILDARGS(%params|$params)
176              
177             The default implementation of this method accepts a hash or hash
178             reference of named parameters. If it receives a single argument that
179             I<isn't> a hash reference it throws an error.
180              
181             You can override this method in your class to handle other types of
182             options passed to the constructor.
183              
184             This method should always return a hash reference of named options.
185              
186             =head2 $object->does($role_name)
187              
188             This returns true if the object does the given role.
189              
190             =head2 $object->DOES($class_or_role_name)
191              
192             This is a Moose role-aware implementation of L<UNIVERSAL/DOES>.
193              
194             This is effectively the same as writing:
195              
196             $object->does($name) || $object->isa($name)
197              
198             This method will work with Perl 5.8, which did not implement
199             C<UNIVERSAL::DOES>.
200              
201             =head2 $object->dump($maxdepth)
202              
203             =for stopwords ing
204              
205             This is a handy utility for L<Data::Dumper>ing an object. By default,
206             there is no maximum depth.
207              
208             =head2 $object->DESTROY
209              
210             A default destructor is provided, which calls
211             C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
212             method in the inheritance hierarchy.
213              
214             =head1 BUGS
215              
216             See L<Moose/BUGS> for details on reporting bugs.
217              
218             =head1 AUTHORS
219              
220             =over 4
221              
222             =item *
223              
224             Stevan Little <stevan@cpan.org>
225              
226             =item *
227              
228             Dave Rolsky <autarch@urth.org>
229              
230             =item *
231              
232             Jesse Luehrs <doy@cpan.org>
233              
234             =item *
235              
236             Shawn M Moore <sartak@cpan.org>
237              
238             =item *
239              
240             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
241              
242             =item *
243              
244             Karen Etheridge <ether@cpan.org>
245              
246             =item *
247              
248             Florian Ragwitz <rafl@debian.org>
249              
250             =item *
251              
252             Hans Dieter Pearcey <hdp@cpan.org>
253              
254             =item *
255              
256             Chris Prather <chris@prather.org>
257              
258             =item *
259              
260             Matt S Trout <mstrout@cpan.org>
261              
262             =back
263              
264             =head1 COPYRIGHT AND LICENSE
265              
266             This software is copyright (c) 2006 by Infinity Interactive, Inc.
267              
268             This is free software; you can redistribute it and/or modify it under
269             the same terms as the Perl 5 programming language system itself.
270              
271             =cut