File Coverage

blib/lib/MooX/Struct.pm
Criterion Covered Total %
statement 244 263 92.7
branch 83 90 92.2
condition 41 54 75.9
subroutine 53 54 98.1
pod 9 17 52.9
total 430 478 89.9


line stmt bran cond sub pod time code
1             package MooX::Struct;
2              
3 16     16   1069598 use 5.008;
  16         179  
4 16     16   98 use strict;
  16         26  
  16         489  
5 16     16   86 use warnings;
  16         115  
  16         479  
6 16     16   9860 use utf8;
  16         232  
  16         80  
7              
8             BEGIN {
9 16     16   726 $MooX::Struct::AUTHORITY = 'cpan:TOBYINK';
10 16         351 $MooX::Struct::VERSION = '0.020';
11             }
12              
13 16     16   8625 use Moo 1.000;
  16         175988  
  16         92  
14 16     16   30224 use Types::TypeTiny 1.000 qw( HashLike ArrayLike );
  16         49107  
  16         94  
15 16     16   71524 use Types::Standard 1.000 qw( HashRef ArrayRef Num Ref InstanceOf );
  16         1105083  
  16         186  
16 16     16   28401 use namespace::autoclean;
  16         219176  
  16         76  
17              
18             my $HashLike = HashLike | Ref['HASH'];
19             my $ArrayLike = ArrayLike | Ref['ARRAY'];
20              
21             use overload
22             q[""] => 'TO_STRING',
23 11     11   1626 q[bool] => sub { 1 },
24 16         138 q[@{}] => 'TO_ARRAY',
25             q[=] => 'CLONE',
26 16     16   2077 fallback => 1;
  16         45  
27              
28             METHODS: {
29 16     16   1972 no warnings;
  16         43  
  16         8099  
30 7     7 1 5352 sub OBJECT_ID { require Object::ID; goto \&Object::ID::object_id };
  7         18045  
31 24     24 1 58 sub FIELDS { qw() };
32 1     1 1 22 sub TYPE { +undef };
33 14     14 1 92 sub TO_ARRAY { [ map {; $_[0]->$_ } $_[0]->FIELDS ] };
  37         266  
34 2     2 1 7 sub TO_HASH { +{ map {; $_ => $_[0]->$_ } $_[0]->FIELDS } };
  6         55  
35 12     12 1 432 sub TO_STRING { join q[ ], @{ $_[0]->TO_ARRAY } };
  12         32  
36 2     2   571 sub CLONE { my $s = shift; ref($s)->new(%{$s->TO_HASH}, @_) };
  2         5  
  2         21  
37 7 100   7 1 25 sub CLASSNAME { ref($_[0]) or $_[0] };
38            
39             my %_cache;
40             sub TYPE_TINY {
41 7     7 1 7538 my $class = shift->CLASSNAME;
42 7   66     36 $_cache{$class} ||= (InstanceOf[$class])->plus_constructors(HashRef|ArrayRef, 'new');
43             }
44             };
45              
46             sub BUILDARGS
47             {
48 69     69 1 55314 my $class = shift;
49 69         205 my @fields = $class->FIELDS;
50            
51 69 100 100     614 if (
    100 100        
      66        
      66        
      100        
      100        
52             (@_==1 and ref $_[0] eq 'ARRAY') or # optimized usual case
53             (@_==1 and ArrayLike->check($_[0]) and not $HashLike->check($_[0]))
54             )
55             {
56 31         54 my @values = @{ $_[0] };
  31         66  
57 31 100       268 Carp::confess("too many values passed to constructor (expected @fields); stopped")
58             unless @fields >= @values;
59 16     16   125 no warnings;
  16         37  
  16         11155  
60             return +{
61             map {
62 30         138 $fields[$_] => $values[$_];
  56         698  
63             } 0 .. $#values
64             }
65             }
66              
67             elsif (@_ == 1 and ref $_[0] ne 'HASH' and $HashLike->check($_[0]))
68             {
69             # help Moo::Object!
70 1         203 @_ = +{ %{$_[0]} };
  1         28  
71             }
72              
73 38         949 my $hashref = $class->SUPER::BUILDARGS(@_);
74            
75             # my %tmp = map { $_ => 1 } keys %$hashref;
76             # delete $tmp{$_} for @fields;
77             # if (my @unknown = sort keys %tmp)
78             # {
79             # Carp::confess("unknown keys passed to constructor (@unknown); stopped");
80             # }
81            
82 37         915 return $hashref;
83             }
84              
85             sub EXTEND
86             {
87 4     4   130 my ($invocant, @args) = @_;
88 4         6 my $base = $invocant;
89 4 100       12 $base = ref $invocant if ref $invocant;
90            
91 4         95 my $processor = 'MooX::Struct::Processor'->new;
92 4         94 while (@args) {
93 5 100       22 last unless $args[0] =~ /^-(.+)$/;
94 1         7 $processor->flags->{ lc($1) } = !!shift @args;
95             }
96              
97 4         9 my $subname = undef;
98 4 50       10 $subname = ${ shift @args } if ref($args[0]) eq 'SCALAR';
  4         9  
99              
100 4         14 my $new_class = $processor->make_sub(
101             $subname,
102             [ -extends => [$base], @args ],
103             )->();
104 4 100       19 return $new_class unless ref $invocant;
105            
106 2         6 bless $invocant => $new_class;
107             }
108              
109             my $done = 0;
110             sub _data_printer
111             {
112 0     0   0 my ($self, $ddp) = @_;
113            
114 0         0 my @values;
115             my $label;
116            
117 0 0       0 if ($Data::Printer::VERSION lt '0.90') {
118 0         0 require Data::Printer::Filter;
119 0         0 require Term::ANSIColor;
120 0         0 @values = map scalar(&Data::Printer::p(\$_, return_value => 'dump')), @$self;
121 0   0     0 $label = Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow');
122             }
123             else
124             {
125 0         0 @values = map $ddp->parse(\$_), @$self;
126 0   0     0 $label = $ddp->maybe_colorize($self->TYPE||'struct', 'MooX::Struct', 'bright_yellow');
127             }
128              
129 0 0       0 if (grep /\n/, @values) {
130             return sprintf(
131             "%s[\n\t%s,\n]",
132             $label,
133 0         0 join(qq[,\n\t], map { s/\n/\n\t/gm; $_ } @values),
  0         0  
  0         0  
134             );
135             }
136            
137 0         0 sprintf('%s[ %s ]', $label, join q[, ], @values);
138             }
139              
140 0         0 BEGIN {
141             package MooX::Struct::Processor;
142            
143             {
144 16     16   138 no warnings;
  16     16   35  
  16         1949  
  16         209  
145 16         46 our $AUTHORITY = 'cpan:TOBYINK';
146 16         31 our $VERSION = '0.020';
147             }
148            
149 38     38   76 sub _uniq { my %seen; grep { not $seen{$_}++ } @_ };
  38         94  
  73         285  
150            
151 16     16   141 use Moo 1.000;
  16         349  
  16         135  
152 16     16   6247 use Exporter::Tiny qw();
  16         46  
  16         745  
153 16     16   109 use Types::TypeTiny 1.000 qw( TypeTiny CodeLike HashLike ArrayLike );
  16         429  
  16         122  
154 16     16   7959 use Types::Standard 1.000 qw( HashRef ArrayRef CodeRef Num );
  16         248  
  16         103  
155 16     16   13838 use Carp qw(confess);
  16         45  
  16         958  
156 16     16   104 use Scalar::Util qw(blessed);
  16         34  
  16         824  
157 16     16   111 use namespace::clean qw();
  16         33  
  16         412  
158 16     16   106 use B::Hooks::EndOfScope qw(on_scope_end);
  16         43  
  16         114  
159            
160             sub __install_sub__ ($) {
161 114     114   192 my $args = shift;
162 114         284 my ($pkg, $name, $code) = @$args{qw(into as code)};
163 16     16   2020 no strict 'refs';
  16         227  
  16         37035  
164 114         176 *{"$pkg\::$name"} = $code;
  114         746  
165             }
166            
167             has flags => (
168             is => 'ro',
169             isa => HashLike,
170 28         1090 default => sub { +{} },
171 16         79 );
172            
173             has class_map => (
174             is => 'ro',
175             isa => HashLike,
176 32         1739 default => sub { +{} },
177 16         328593 );
178            
179             has base => (
180             is => 'ro',
181 31         49091 default => sub { 'MooX::Struct' },
182 16         8175 );
183            
184 16         4538 has trace => (
185             is => 'lazy',
186             );
187            
188             sub _build_trace
189             {
190             $ENV{PERL_MOOX_STRUCT_TRACE}
191 27 100   27   652 or shift->flags->{trace};
192             }
193            
194 16         12713 has trace_handle => (
195             is => 'lazy',
196             );
197            
198             sub _build_trace_handle
199             {
200 1     1   53 require IO::Handle;
201 1         6 \*STDERR;
202             }
203            
204 16         12347 my $counter = 0;
205             sub create_class
206             {
207 39     39 0 94 my ($self, $opts) = @_;
208 39         66 my $klass;
209 39         96 for my $o (@$opts) {
210 73 100       193 next unless $o->[0] eq '-class';
211 4 100       14 $klass = ArrayRef->check($o->[1]) ? join('::', @{$o->[1]}) : ${$o->[1]};
  1         64  
  3         134  
212 4         14 last;
213             }
214 39 100       360 $klass = sprintf('%s::__ANON__::%04d', $self->base, ++$counter) unless defined $klass;
215 39         264 "Moo"->_set_superclasses($klass, $self->base);
216 39         6635 "Moo"->_maybe_reset_handlemoose($klass);
217 39 100       1186 if ($self->trace)
218             {
219 2         52 $self->trace_handle->printf(
220             "package %s;\nuse Moo;\n",
221             $klass,
222             );
223             }
224 39         233 return $klass;
225             }
226            
227             sub process_meta
228             {
229 20     20 0 109 my ($self, $klass, $name, $val) = @_;
230            
231 20 100 100     139 if ($name eq '-extends' or $name eq '-isa')
    100          
    100          
232             {
233             my @parents = map {
234 13         61 exists $self->class_map->{$_}
235 13 100       108 ? $self->class_map->{$_}->()
236             : $_
237             } @$val;
238 13         94 "Moo"->_set_superclasses($klass, @parents);
239 13         4525 "Moo"->_maybe_reset_handlemoose($klass);
240            
241 13 100       372 if ($self->trace)
242             {
243 1         23 $self->trace_handle->printf(
244             "extends qw(%s)\n",
245             join(q[ ] => @parents),
246             );
247             }
248            
249 13 100       190 return map { $_->can('FIELDS') ? $_->FIELDS : () } @parents;
  13         102  
250             }
251             elsif ($name eq '-with')
252             {
253 2         13 require Moo::Role;
254 2         21 "Moo::Role"->apply_roles_to_package($klass, @$val);
255 2         2829 "Moo"->_maybe_reset_handlemoose($klass);
256            
257 2 100       95 if ($self->trace)
258             {
259 1         33 $self->trace_handle->printf(
260             "with qw(%s)\n",
261             join(q[ ] => @$val),
262             );
263             }
264            
265             return
266             # map { my $role = $_; grep { not ref $_ } @{ $Moo::Role::INFO{$role}{attributes} } }
267             # @$val;
268 2         35 }
269             elsif ($name eq '-class')
270             {
271             # skip; already handled by 'create_class' method (hopefully)
272             }
273             else
274             {
275 1         231 confess("option '$name' unknown");
276             }
277            
278 4         15 return;
279             }
280            
281             sub process_method
282             {
283 79     79 0 257 my ($self, $klass, $name, $coderef) = @_;
284 79         338 __install_sub__ {
285             into => $klass,
286             as => $name,
287             code => $coderef,
288             };
289 79 100       1722 if ($self->trace)
290             {
291 6         135 $self->trace_handle->printf(
292             "sub %s { ... }\n",
293             $name,
294             );
295 6 100       103 if ($self->flags->{deparse})
296             {
297 3         16 require B::Deparse;
298 3         3809 my $code = "B::Deparse"->new(qw(-q -si8T))->coderef2text($coderef);
299 3         46 $code =~ s/^/# /mig;
300 3         73 $self->trace_handle->printf("$code\n");
301             }
302             }
303 79         657 return;
304             }
305            
306 16         1494 my $ScalarLike;
307             sub process_spec
308             {
309 55     55 0 129 my ($self, $klass, $name, $val) = @_;
310            
311             my %spec = (
312 55 100       273 is => ($self->flags->{rw} ? 'rw' : 'ro'),
    100          
    100          
313             ( ArrayLike->check($val)
314             ? @$val
315             : ( HashLike->check($val) ? %$val : () )
316             ),
317             );
318            
319 55 100       11356 if ($name =~ /^(.+)\!$/)
320             {
321 3         8 $name = $1;
322 3         7 $spec{required} = 1;
323             }
324            
325 55 100       367 if ($name =~ /^\@(.+)/)
    100          
    100          
    100          
326             {
327 2         6 $name = $1;
328 2   66     8 $spec{isa} ||= ArrayLike;
329             }
330             elsif ($name =~ /^\%(.+)/)
331             {
332 2         16 $name = $1;
333 2   66     11 $spec{isa} ||= HashLike;
334             }
335             elsif ($name =~ /^\+(.+)/)
336             {
337 15         48 $name = $1;
338 15   66     85 $spec{isa} ||= Num;
339 15 100 100 10   190 $spec{default} ||= sub { 0 } unless $spec{required};
  10         592  
340             }
341             elsif ($name =~ /^\$(.+)/)
342             {
343 19   66     98 $ScalarLike ||= (~(ArrayRef|HashRef))->create_child_type(name => 'ScalarLike');
344 19         3819 $name = $1;
345 19   66     112 $spec{isa} ||= $ScalarLike;
346             }
347            
348 55         246 return ($name, \%spec);
349             }
350            
351             sub process_attribute
352             {
353 55     55 0 138 my ($self, $klass, $name, $val) = @_;
354 55         84 my $spec;
355 55         159 ($name, $spec) = $self->process_spec($klass, $name, $val);
356            
357 55 100       1248 if ($self->trace)
358             {
359 3         680 require Data::Dumper;
360 3         6874 my %sanespec = %$spec;
361 3 100       11 if (TypeTiny->check($sanespec{isa})) {
362 2         68 $sanespec{isa} = $sanespec{isa}->display_name;
363             }
364 3         44 my $spec_str = "Data::Dumper"->new([\%sanespec])->Terse(1)->Indent(0)->Sortkeys(1)->Dump;
365 3         260 $spec_str =~ s/(^\{)|(\}$)//g;
366 3         72 $self->trace_handle->printf(
367             "has %s => (%s);\n",
368             $name,
369             $spec_str,
370             );
371 3 50 66     80 if ($self->flags->{deparse} and CodeRef->check($spec->{isa}))
372             {
373 0         0 require B::Deparse;
374 0         0 my $code = "B::Deparse"->new(qw(-q -si8T))->coderef2text($spec->{isa});
375 0         0 $code =~ s/^/# /mig;
376 0         0 $self->trace_handle->printf("$code\n");
377             }
378             }
379            
380             "Moo"
381 55         609 ->_constructor_maker_for($klass)
382             ->register_attribute_specs($name, $spec);
383            
384 55         17871 "Moo"
385             ->_accessor_maker_for($klass)
386             ->generate_method($klass, $name, $spec);
387            
388 55         22664 "Moo"
389             ->_maybe_reset_handlemoose($klass);
390            
391 55         425 return $name;
392             }
393            
394             # returns a list of "fields" resulting from the argument
395             sub process_argument
396             {
397 78     78 0 134 my $self = shift;
398 78         166 my ($klass, $name, $val) = @_;
399            
400 78 100       237 return $self->process_method(@_) if CodeLike->check($val);
401 75 100       9363 return $self->process_meta(@_) if $name =~ /^-/;
402 55         175 return $self->process_attribute(@_);
403             }
404            
405             sub make_sub
406             {
407 39     39 0 94 my ($self, $subname, $proto) = @_;
408             return sub (;$)
409             {
410 118     118   32166 1; # bizarre, but necessary if $] < 5.014
411 118 100       341 if (ref $proto) # inflate!
412             {
413 39         156 my $opts = Exporter::Tiny::mkopt($proto);
414 39         1113 my $klass = $self->create_class($opts);
415 39         67 my $seen_extends;
416             my @fields = _uniq map {
417 39 100       101 ++$seen_extends if $_->[0] eq '-extends';
  78         252  
418 78         243 $self->process_argument($klass, @$_);
419             } @$opts;
420 38 100 100     470 unshift @fields, $self->base->FIELDS
421             if !$seen_extends && $self->base->can('FIELDS');
422 38     112   295 $self->process_method($klass, FIELDS => sub { @fields });
  112         4594  
423 38 50   4   313 $self->process_method($klass, TYPE => sub { $subname }) if defined $subname;
  4         37  
424 38         132 $proto = $klass;
425             }
426 117 100       692 return $proto->new(@_) if @_;
427 92         927 return $proto;
428             }
429 39         333 }
430            
431             sub process
432             {
433 25     25 0 649 my $self = shift;
434 25         55 my $caller = shift;
435            
436 25   100     241 while (@_ and $_[0] =~ /^-(.+)$/) {
437 2         20 $self->flags->{ lc($1) } = !!shift;
438             }
439            
440 25         53 foreach my $arg (@{ Exporter::Tiny::mkopt(\@_) })
  25         125  
441             {
442 35         649 my ($subname, $details) = @$arg;
443 35 100       94 $details = [] unless defined $details;
444            
445 35         101 $self->class_map->{ $subname } = $self->make_sub($subname, $details);
446             __install_sub__ {
447             into => $caller,
448             as => $subname,
449 35         191 code => $self->class_map->{ $subname },
450             };
451             }
452            
453             on_scope_end {
454             namespace::clean->clean_subroutines(
455             $caller,
456 18     18   3451 keys %{ $self->class_map },
  18         166  
457             );
458 25 100       2461 } unless $self->flags->{ retain };
459             }
460             };
461              
462             sub import
463             {
464 19     19   2126 my $caller = caller;
465 19         38 my $class = shift;
466 19         225 "$class\::Processor"->new->process($caller, @_);
467             }
468              
469             1;
470              
471             __END__