File Coverage

blib/lib/Mouse/Meta/Method/Constructor.pm
Criterion Covered Total %
statement 6 111 5.4
branch 1 52 1.9
condition 0 12 0.0
subroutine 2 7 28.5
pod n/a
total 9 182 4.9


line stmt bran cond sub pod time code
1             package Mouse::Meta::Method::Constructor;
2 1     1   308 use Mouse::Util qw(:meta); # enables strict and warnings
  1         1  
  1         3  
3              
4 1 50   1   4 use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
  1         1  
  1         828  
5              
6             sub _inline_slot{
7 0     0     my(undef, $self_var, $attr_name) = @_;
8 0           return sprintf '%s->{q{%s}}', $self_var, $attr_name;
9             }
10              
11             sub _generate_constructor {
12 0     0     my ($class, $metaclass, $args) = @_;
13              
14 0           my $associated_metaclass_name = $metaclass->name;
15              
16 0           my $buildall = $class->_generate_BUILDALL($metaclass);
17 0           my $buildargs = $class->_generate_BUILDARGS($metaclass);
18             my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||=
19 0   0       $class->_generate_initialize_object($metaclass);
20 0           my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall);
21             #line 1 "%s"
22             package %s;
23             sub {
24             my $class = shift;
25             return $class->Mouse::Object::new(@_)
26             if $class ne __PACKAGE__;
27             # BUILDARGS
28             %s;
29             my $instance = bless {}, $class;
30             $metaclass->$initializer($instance, $args, 0);
31             # BUILDALL
32             %s;
33             return $instance;
34             }
35             EOT
36 0           warn $source if _MOUSE_DEBUG;
37 0           my $body;
38 0           my $e = do{
39 0           local $@;
40 0           $body = eval $source;
41 0           $@;
42             };
43 0 0         die $e if $e;
44 0           return $body;
45             }
46              
47             sub _generate_initialize_object {
48 0     0     my ($method_class, $metaclass) = @_;
49 0           my @attrs = $metaclass->get_all_attributes;
50              
51 0 0         my @checks = map { $_ && $_->_compiled_type_constraint }
52 0           map { $_->type_constraint } @attrs;
  0            
53              
54 0           my @res;
55              
56             my $has_triggers;
57 0           my $strict = $metaclass->strict_constructor;
58              
59 0 0         if($strict){
60 0           push @res, 'my $used = 0;';
61             }
62              
63 0           for my $index (0 .. @attrs - 1) {
64 0           my $code = '';
65              
66 0           my $attr = $attrs[$index];
67 0           my $key = $attr->name;
68              
69 0           my $init_arg = $attr->init_arg;
70 0           my $type_constraint = $attr->type_constraint;
71 0           my $is_weak_ref = $attr->is_weak_ref;
72 0           my $need_coercion;
73              
74 0           my $instance_slot = $method_class->_inline_slot('$instance', $key);
75 0           my $attr_var = "\$attrs[$index]";
76 0           my $constraint_var;
77              
78 0 0         if(defined $type_constraint){
79 0           $constraint_var = "$attr_var\->{type_constraint}";
80 0   0       $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion);
81             }
82              
83 0           $code .= "# initialize $key\n";
84              
85 0           my $post_process = '';
86 0 0         if(defined $type_constraint){
87 0           $post_process .= "\$checks[$index]->($instance_slot)\n";
88 0           $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
89             }
90              
91             # build cde for an attribute
92 0 0         if (defined $init_arg) {
93 0           my $value = "\$args->{q{$init_arg}}";
94              
95 0           $code .= "if (exists $value) {\n";
96              
97 0 0         if($need_coercion){
98 0           $value = "$constraint_var->coerce($value)";
99             }
100              
101 0           $code .= "$instance_slot = $value;\n";
102 0           $code .= $post_process;
103              
104 0 0         if ($attr->has_trigger) {
105 0           $has_triggers++;
106 0           $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
107             }
108              
109 0 0         if ($strict){
110 0           $code .= '++$used;' . "\n";
111             }
112              
113 0           $code .= "\n} else {\n"; # $value exists
114             }
115              
116 0 0 0       if ($attr->has_default || $attr->has_builder) {
    0          
117 0 0         unless ($attr->is_lazy) {
118 0           my $default = $attr->default;
119 0           my $builder = $attr->builder;
120              
121 0           my $value;
122 0 0         if (defined($builder)) {
    0          
    0          
123 0           $value = "\$instance->$builder()";
124             }
125             elsif (ref($default) eq 'CODE') {
126 0           $value = "$attr_var\->{default}->(\$instance)";
127             }
128             elsif (defined($default)) {
129 0           $value = "$attr_var\->{default}";
130             }
131             else {
132 0           $value = 'undef';
133             }
134              
135 0 0         if($need_coercion){
136 0           $value = "$constraint_var->coerce($value)";
137             }
138              
139 0           $code .= "$instance_slot = $value;\n";
140 0           $code .= $post_process;
141             }
142             }
143             elsif ($attr->is_required) {
144 0           $code .= "\$meta->throw_error('Attribute ($key) is required')";
145 0           $code .= " unless \$is_cloning;\n";
146             }
147              
148 0 0         $code .= "}\n" if defined $init_arg;
149              
150 0 0         if($is_weak_ref){
151 0           $code .= "Scalar::Util::weaken($instance_slot) "
152             . "if ref $instance_slot and not Scalar::Util::isweak($instance_slot);\n";
153             }
154              
155 0           push @res, $code;
156             }
157              
158 0 0         if($strict){
159 0           push @res, q{if($used < keys %{$args})}
160             . q{{ $meta->_report_unknown_args(\@attrs, $args) }};
161             }
162              
163 0 0         if($metaclass->is_anon_class){
164 0           push @res, q{$instance->{__METACLASS__} = $meta;};
165             }
166              
167 0 0         if($has_triggers){
168 0           unshift @res, q{my @triggers;};
169 0           push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
170             }
171              
172 0           my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res;
173             #line 1 "%s"
174             package %s;
175             sub {
176             my($meta, $instance, $args, $is_cloning) = @_;
177             %s;
178             return $instance;
179             }
180             EOT
181 0           warn $source if _MOUSE_DEBUG;
182 0           my $body;
183 0           my $e = do {
184 0           local $@;
185 0           $body = eval $source;
186 0           $@;
187             };
188 0 0         die $e if $e;
189 0           return $body;
190             }
191              
192             sub _generate_BUILDARGS {
193 0     0     my(undef, $metaclass) = @_;
194              
195 0           my $class = $metaclass->name;
196 0 0 0       if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
197 0           return 'my $args = $class->BUILDARGS(@_)';
198             }
199              
200 0           return <<'...';
201             my $args;
202             if ( scalar @_ == 1 ) {
203             ( ref( $_[0] ) eq 'HASH' )
204             || Carp::confess "Single parameters to new() must be a HASH ref";
205             $args = +{ %{ $_[0] } };
206             }
207             else {
208             $args = +{@_};
209             }
210             ...
211             }
212              
213             sub _generate_BUILDALL {
214 0     0     my (undef, $metaclass) = @_;
215              
216 0 0         return '' unless $metaclass->name->can('BUILD');
217              
218 0           my @code;
219 0           for my $class ($metaclass->linearized_isa) {
220 0 0         if (Mouse::Util::get_code_ref($class, 'BUILD')) {
221 0           unshift @code, qq{${class}::BUILD(\$instance, \$args);};
222             }
223             }
224 0           return join "\n", @code;
225             }
226              
227             1;
228             __END__