File Coverage

blib/lib/Class/MOP/Method/Constructor.pm
Criterion Covered Total %
statement 44 46 95.6
branch 8 12 66.6
condition 8 13 61.5
subroutine 14 16 87.5
pod 1 1 100.0
total 75 88 85.2


line stmt bran cond sub pod time code
1             package Class::MOP::Method::Constructor;
2             our $VERSION = '2.2206';
3              
4 450     450   3440 use strict;
  450         1117  
  450         14919  
5 450     450   2514 use warnings;
  450         1128  
  450         12928  
6              
7 450     450   2554 use Scalar::Util 'blessed', 'weaken';
  450         1078  
  450         22444  
8 450     450   2965 use Try::Tiny;
  450         1109  
  450         25051  
9              
10 450     450   3369 use parent 'Class::MOP::Method::Inlined';
  450         1241  
  450         2962  
11              
12             sub new {
13 11474     11474 1 25409 my $class = shift;
14 11474         49383 my %options = @_;
15              
16             (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
17             || $class->_throw_exception( MustSupplyAMetaclass => params => \%options,
18             class => $class
19             )
20 11474 100 66     95324 if $options{is_inline};
      66        
21              
22             ($options{package_name} && $options{name})
23 11473 100 66     49921 || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
24             class => $class
25             );
26              
27 11472         32923 my $self = $class->_new(\%options);
28              
29             # we don't want this creating
30             # a cycle in the code, if not
31             # needed
32 11472         79613 weaken($self->{'associated_metaclass'});
33              
34 11472         32217 $self->_initialize_body;
35              
36 11472         48239 return $self;
37             }
38              
39             sub _new {
40 11472     11472   19458 my $class = shift;
41              
42 11472 50       26783 return Class::MOP::Class->initialize($class)->new_object(@_)
43             if $class ne __PACKAGE__;
44              
45 11472 50       28615 my $params = @_ == 1 ? $_[0] : {@_};
46              
47             return bless {
48             # inherited from Class::MOP::Method
49             body => $params->{body},
50             # associated_metaclass => $params->{associated_metaclass}, # overridden
51             package_name => $params->{package_name},
52             name => $params->{name},
53             original_method => $params->{original_method},
54              
55             # inherited from Class::MOP::Generated
56             is_inline => $params->{is_inline} || 0,
57             definition_context => $params->{definition_context},
58              
59             # inherited from Class::MOP::Inlined
60             _expected_method_class => $params->{_expected_method_class},
61              
62             # defined in this subclass
63             options => $params->{options} || {},
64             associated_metaclass => $params->{metaclass},
65 11472   50     103088 }, $class;
      50        
66             }
67              
68             ## accessors
69              
70 12218     12218   42785 sub options { (shift)->{'options'} }
71 34416     34416   87158 sub associated_metaclass { (shift)->{'associated_metaclass'} }
72              
73             ## method
74              
75             sub _initialize_body {
76 11472     11472   18043 my $self = shift;
77 11472         20227 my $method_name = '_generate_constructor_method';
78              
79 11472 50       39256 $method_name .= '_inline' if $self->is_inline;
80              
81 11472         35695 $self->{'body'} = $self->$method_name;
82             }
83              
84             sub _eval_environment {
85 12218     12218   23206 my $self = shift;
86 12218         26732 return $self->associated_metaclass->_eval_environment;
87             }
88              
89             sub _generate_constructor_method {
90 0     0   0 return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
91 0     0   0 }
92              
93             sub _generate_constructor_method_inline {
94 12218     12218   19993 my $self = shift;
95              
96 12218         26242 my $meta = $self->associated_metaclass;
97              
98 12218         39840 my @source = (
99             'sub {',
100             $meta->_inline_new_object,
101             '}',
102             );
103              
104 12218 50       36332 warn join("\n", @source) if $self->options->{debug};
105              
106             my $code = try {
107 12218     12218   558681 $self->_compile_code(\@source);
108             }
109             catch {
110 1     1   640 my $source = join("\n", @source);
111 1         11 $self->_throw_exception( CouldNotEvalConstructor => constructor_method => $self,
112             source => $source,
113             error => $_
114             );
115 12218         94922 };
116              
117 12217         561862 return $code;
118             }
119              
120             1;
121              
122             # ABSTRACT: Method Meta Object for constructors
123              
124             __END__
125              
126             =pod
127              
128             =encoding UTF-8
129              
130             =head1 NAME
131              
132             Class::MOP::Method::Constructor - Method Meta Object for constructors
133              
134             =head1 VERSION
135              
136             version 2.2206
137              
138             =head1 SYNOPSIS
139              
140             use Class::MOP::Method::Constructor;
141              
142             my $constructor = Class::MOP::Method::Constructor->new(
143             metaclass => $metaclass,
144             options => {
145             debug => 1, # this is all for now
146             },
147             );
148              
149             # calling the constructor ...
150             $constructor->body->execute($metaclass->name, %params);
151              
152             =head1 DESCRIPTION
153              
154             This is a subclass of L<Class::MOP::Method> which generates
155             constructor methods.
156              
157             =head1 METHODS
158              
159             =over 4
160              
161             =item B<< Class::MOP::Method::Constructor->new(%options) >>
162              
163             This creates a new constructor object. It accepts a hash reference of
164             options.
165              
166             =over 8
167              
168             =item * metaclass
169              
170             This should be a L<Class::MOP::Class> object. It is required.
171              
172             =item * name
173              
174             The method name (without a package name). This is required.
175              
176             =item * package_name
177              
178             The package name for the method. This is required.
179              
180             =item * is_inline
181              
182             This indicates whether or not the constructor should be inlined. This
183             defaults to false.
184              
185             =back
186              
187             =item B<< $metamethod->is_inline >>
188              
189             Returns a boolean indicating whether or not the constructor is
190             inlined.
191              
192             =item B<< $metamethod->associated_metaclass >>
193              
194             This returns the L<Class::MOP::Class> object for the method.
195              
196             =back
197              
198             =head1 AUTHORS
199              
200             =over 4
201              
202             =item *
203              
204             Stevan Little <stevan@cpan.org>
205              
206             =item *
207              
208             Dave Rolsky <autarch@urth.org>
209              
210             =item *
211              
212             Jesse Luehrs <doy@cpan.org>
213              
214             =item *
215              
216             Shawn M Moore <sartak@cpan.org>
217              
218             =item *
219              
220             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
221              
222             =item *
223              
224             Karen Etheridge <ether@cpan.org>
225              
226             =item *
227              
228             Florian Ragwitz <rafl@debian.org>
229              
230             =item *
231              
232             Hans Dieter Pearcey <hdp@cpan.org>
233              
234             =item *
235              
236             Chris Prather <chris@prather.org>
237              
238             =item *
239              
240             Matt S Trout <mstrout@cpan.org>
241              
242             =back
243              
244             =head1 COPYRIGHT AND LICENSE
245              
246             This software is copyright (c) 2006 by Infinity Interactive, Inc.
247              
248             This is free software; you can redistribute it and/or modify it under
249             the same terms as the Perl 5 programming language system itself.
250              
251             =cut