File Coverage

inc/Spiffy.pm
Criterion Covered Total %
statement 264 435 60.6
branch 96 202 47.5
condition 35 62 56.4
subroutine 37 60 61.6
pod 0 27 0.0
total 432 786 54.9


line stmt bran cond sub pod time code
1 5     5   53 #line 1
  5     5   9  
  5         123  
  5         19  
  5         7  
  5         193  
2             use strict; use warnings;
3             package Spiffy;
4             our $VERSION = '0.46';
5 5     5   21  
  5         6  
  5         1627  
6             use Carp;
7             require Exporter;
8             our @EXPORT = ();
9             our @EXPORT_BASE = qw(field const stub super);
10             our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
11             our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
12              
13             my $stack_frame = 0;
14             my $dump = 'yaml';
15             my $bases_map = {};
16              
17             sub WWW; sub XXX; sub YYY; sub ZZZ;
18              
19             # This line is here to convince "autouse" into believing we are autousable.
20 59 50 33 59 0 395 sub can {
21             ($_[1] eq 'import' and caller()->isa('autouse'))
22             ? \&Exporter::import # pacify autouse's equality test
23             : $_[0]->SUPER::can($_[1]) # normal case
24             }
25              
26             # TODO
27             #
28             # Exported functions like field and super should be hidden so as not to
29             # be confused with methods that can be inherited.
30             #
31              
32 33     33 0 55 sub new {
33 33   33     97 my $class = shift;
34 33         54 $class = ref($class) || $class;
35 33         74 my $self = bless {}, $class;
36 0         0 while (@_) {
37 0         0 my $method = shift;
38             $self->$method(shift);
39 33         66 }
40             return $self;
41             }
42              
43             my $filtered_files = {};
44             my $filter_dump = 0;
45             my $filter_save = 0;
46             our $filter_result = '';
47 5     5   30 sub import {
  5         6  
  5         131  
48 5     5   19 no strict 'refs';
  5         8  
  5         8896  
49 19     19   43 no warnings;
50             my $self_package = shift;
51              
52             # XXX Using parse_arguments here might cause confusion, because the
53             # subclass's boolean_arguments and paired_arguments can conflict, causing
54 19         29 # difficult debugging. Consider using something truly local.
55             my ($args, @export_list) = do {
56 19     19   68 local *boolean_arguments = sub {
57             qw(
58             -base -Base -mixin -selfless
59             -XXX -dumper -yaml
60             -filter_dump -filter_save
61 19         145 )
62 19     19   82 };
  19         28  
63 19         77 local *paired_arguments = sub { qw(-package) };
64             $self_package->parse_arguments(@_);
65             };
66 19 50       60 return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
67             if $args->{-mixin};
68 19 50       45  
69 19 50       49 $filter_dump = 1 if $args->{-filter_dump};
70 19 50       43 $filter_save = 1 if $args->{-filter_save};
71 19 50       54 $dump = 'yaml' if $args->{-yaml};
72             $dump = 'dumper' if $args->{-dumper};
73 19         74  
74             local @EXPORT_BASE = @EXPORT_BASE;
75 19 50       59  
76 0 0       0 if ($args->{-XXX}) {
  0         0  
77             push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
78             unless grep /^XXX$/, @EXPORT_BASE;
79             }
80              
81             spiffy_filter()
82 19 100 66     150 if ($args->{-selfless} or $args->{-Base}) and
      66        
83             not $filtered_files->{(caller($stack_frame))[1]}++;
84 19   33     1424  
85 7         123 my $caller_package = $args->{-package} || caller($stack_frame);
86 19 100 66     2912 push @{"$caller_package\::ISA"}, $self_package
87             if $args->{-Base} or $args->{-base};
88 19         1829  
  19         49  
89 24 50       133 for my $class (@{all_my_bases($self_package)}) {
90             next unless $class->isa('Spiffy');
91 278         284 my @export = grep {
  278         889  
92 24         135 not defined &{"$caller_package\::$_"};
93             } ( @{"$class\::EXPORT"},
94 24 100 66     44 ($args->{-Base} or $args->{-base})
  7         23  
95             ? @{"$class\::EXPORT_BASE"} : (),
96             );
97 171         186 my @export_ok = grep {
  171         443  
98 24         78 not defined &{"$caller_package\::$_"};
  24         74  
99             } @{"$class\::EXPORT_OK"};
100              
101             # Avoid calling the expensive Exporter::export
102 24         41 # if there is nothing to do (optimization)
  401         533  
103 24 50       78 my %exportable = map { ($_, 1) } @export, @export_ok;
104             next unless keys %exportable;
105 24         34  
  24         75  
106 24         30 my @export_save = @{"$class\::EXPORT"};
  24         64  
107 24         32 my @export_ok_save = @{"$class\::EXPORT_OK"};
  24         109  
108 24         36 @{"$class\::EXPORT"} = @export;
  24         64  
109             @{"$class\::EXPORT_OK"} = @export_ok;
110 24         66 my @list = grep {
  7         34  
111 7 50       28 (my $v = $_) =~ s/^[\!\:]//;
  0         0  
112             $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
113 24         2351 } @export_list;
114 24         65 Exporter::export($class, $caller_package, @list);
  24         78  
115 24         37 @{"$class\::EXPORT"} = @export_save;
  24         2198  
116             @{"$class\::EXPORT_OK"} = @export_ok_save;
117             }
118             }
119              
120 7     7 0 3281 sub spiffy_filter {
121 7         4540 require Filter::Util::Call;
122             my $done = 0;
123             Filter::Util::Call::filter_add(
124 14 100   14   429 sub {
125 7         18 return 0 if $done;
126 7         71 my ($data, $end) = ('', '');
127 4121 50       5808 while (my $status = Filter::Util::Call::filter_read()) {
128 4121 50       6554 return $status if $status < 0;
129 0         0 if (/^__(?:END|DATA)__\r?$/) {
130 0         0 $end = $_;
131             last;
132 4121         4764 }
133 4121         8668 $data .= $_;
134             $_ = '';
135 7         139 }
136 7         21 $_ = $data;
137 7         640 my @my_subs;
138 7         528 s[^(sub\s+\w+\s+\{)(.*\n)]
139 7         190 [${1}my \$self = shift;$2]gm;
  0         0  
  0         0  
140 7         18 s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
141 7 50       36 [${1}${2}]gm;
142 0         0 s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
143 0         0 [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
144             my $preclare = '';
145 7         188 if (@my_subs) {
146 7 50       26 $preclare = join ',', map "\$$_", @my_subs;
  0         0  
  0         0  
147 7 50       20 $preclare = "my($preclare);";
  0         0  
  0         0  
148 7         417 }
149             $_ = "use strict;use warnings;$preclare${_};1;\n$end";
150 7         1738 if ($filter_dump) { print; exit }
151             if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
152             $done = 1;
153             }
154 0     0 0 0 );
155 0         0 }
156              
157             sub base {
158             push @_, -base;
159 24     24 0 38 goto &import;
160             }
161              
162 24 100       84 sub all_my_bases {
163             my $class = shift;
164 10         21  
165 5     5   40 return $bases_map->{$class}
  5         21  
  5         1140  
166 10         14 if defined $bases_map->{$class};
  10         45  
167 5         54  
  5         26  
168             my @bases = ($class);
169 10         18 no strict 'refs';
170 10         19 for my $base_class (@{"${class}::ISA"}) {
  15         69  
171             push @bases, @{all_my_bases($base_class)};
172             }
173             my $used = {};
174             $bases_map->{$class} = [grep {not $used->{$_}++} @bases];
175             }
176              
177             my %code = (
178             sub_start =>
179             "sub {\n",
180             set_default =>
181             " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
182             init =>
183             " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
184             " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
185             weak_init =>
186             " return do {\n" .
187             " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
188             " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
189             " \$_[0]->{%s};\n" .
190             " } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
191             return_if_get =>
192             " return \$_[0]->{%s} unless \$#_ > 0;\n",
193             set =>
194             " \$_[0]->{%s} = \$_[1];\n",
195             weaken =>
196             " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
197             sub_end =>
198 87     87 0 205 " return \$_[0]->{%s};\n}\n",
199 87         101 );
200 5     5   78  
  5         12  
  5         1903  
201 87     87   425 sub field {
  87         142  
202 87     87   337 my $package = caller;
  87         149  
203 87         300 my ($args, @values) = do {
204             no warnings;
205 87         185 local *boolean_arguments = sub { (qw(-weak)) };
206 87 50       170 local *paired_arguments = sub { (qw(-package -init)) };
207             Spiffy->parse_arguments(@_);
208 87 50 66     194 };
209 87 50       97 my ($field, $default) = @values;
  87         542  
210 87 50       155 $package = $args->{-package} if defined $args->{-package};
211 87 100 100     347 die "Cannot have a default for a weakened field ($field)"
    100 66        
212             if defined $default && $args->{-weak};
213             return if defined &{"${package}::$field"};
214             require Scalar::Util if $args->{-weak};
215             my $default_string =
216             ( ref($default) eq 'ARRAY' and not @$default )
217             ? '[]'
218 87         144 : (ref($default) eq 'HASH' and not keys %$default )
219 87 100       164 ? '{}'
220 20 50       59 : default_as_code($default);
221 20         95  
222 20         105 my $code = $code{sub_start};
223             if ($args->{-init}) {
224 87 100       298 my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
225             my @count = ($fragment =~ /(%s)/g);
226 87         274 $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2);
227 87         150 }
228             $code .= sprintf $code{set_default}, $field, $default_string, $field
229 87 50       142 if defined $default;
230 87         195 $code .= sprintf $code{return_if_get}, $field;
231             $code .= sprintf $code{set}, $field;
232 87 100 100 37   9659 $code .= sprintf $code{weaken}, $field, $field
  37 100 66     369  
  2 100 100     5  
  2 100 33     9  
  3 100       17  
  1 50       3  
  1 50       2  
  10 0       35  
  9 100       38  
  2 100       30  
  2 100       8  
  0 100       0  
  0 100       0  
  4 100       18  
  4 100       24  
  1 50       9  
  1 100       2  
  1 100       6  
  0 100       0  
  0 0       0  
  0 100       0  
  7 50       35  
  3 0       11  
  2 100       5  
  3 100       21  
  3 50       14  
  2 50       21  
  3 50       27  
  1 50       5  
  0         0  
  4         15  
  5         30  
  1         2  
  1         4  
  20         181  
  2         3  
  2         4  
  8         29  
  8         43  
  0         0  
  0         0  
  3         21  
  1         2  
  1         5  
  2         9  
  2         11  
  2         6  
  4         27  
  1         4  
  1         2  
  0         0  
  4         16  
  4         17  
  0         0  
  1         9  
  1         2  
  1         17  
  0         0  
  0         0  
  2         6  
  9         26  
  9         36  
  1         5  
  1         6  
  1         5  
  1         6  
  1         7  
  0         0  
  0         0  
  1         6  
  0         0  
  0         0  
233 87 50       233 if $args->{-weak};
234 5     5   33 $code .= sprintf $code{sub_end}, $field;
  5         6  
  5         1247  
235 87         107  
  87         427  
236 87 50       316 my $sub = eval $code;
237             die $@ if $@;
238             no strict 'refs';
239             *{"${package}::$field"} = $sub;
240 100     72 0 3507 return $code if defined wantarray;
241 100         31362 }
242 100         473  
243 72         3312 sub default_as_code {
244 72         258 require Data::Dumper;
245 72         148 local $Data::Dumper::Sortkeys = 1;
246             my $code = Data::Dumper::Dumper(shift);
247             $code =~ s/^\$VAR1 = //;
248             $code =~ s/;$//;
249 0     0 0 0 return $code;
250 0         0 }
251 5     5   31  
  5         9  
  5         543  
252 0     0   0 sub const {
  0         0  
253 0         0 my $package = caller;
254             my ($args, @values) = do {
255 0         0 no warnings;
256 0 50       0 local *paired_arguments = sub { (qw(-package)) };
257 5     5   30 Spiffy->parse_arguments(@_);
  5         8  
  5         600  
258 0 0       0 };
  0         0  
259 0     0   0 my ($field, $default) = @values;
  0         0  
260 0         0 $package = $args->{-package} if defined $args->{-package};
261             no strict 'refs';
262             return if defined &{"${package}::$field"};
263 0     0 0 0 *{"${package}::$field"} = sub { $default }
264 0         0 }
265 5     5   31  
  5         9  
  5         557  
266 0     0   0 sub stub {
  0         0  
267 0         0 my $package = caller;
268             my ($args, @values) = do {
269 0         0 no warnings;
270 0 0       0 local *paired_arguments = sub { (qw(-package)) };
271 5     5   28 Spiffy->parse_arguments(@_);
  5         22  
  5         2313  
272 0 0       0 };
  0         0  
273 0         0 my ($field, $default) = @values;
274             $package = $args->{-package} if defined $args->{-package};
275 0     0   0 no strict 'refs';
276 0         0 return if defined &{"${package}::$field"};
277             *{"${package}::$field"} =
278             sub {
279 0         0 require Carp;
280             Carp::confess
281             "Method $field in package $package must be subclassed";
282 106     106 0 203 }
283 106         188 }
284 106         207  
  258         614  
285 106         231 sub parse_arguments {
  193         328  
286 106         246 my $class = shift;
287 161         215 my ($args, @values) = ({}, ());
288 161 100 66     838 my %booleans = map { ($_, 1) } $class->boolean_arguments;
    100 66        
      66        
289 7 50 33     35 my %pairs = map { ($_, 1) } $class->paired_arguments;
290             while (@_) {
291             my $elem = shift;
292             if (defined $elem and defined $booleans{$elem}) {
293             $args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
294 20         53 ? shift
295             : 1;
296             }
297 134         295 elsif (defined $elem and defined $pairs{$elem} and @_) {
298             $args->{$elem} = shift;
299             }
300 106 50       789 else {
301             push @values, $elem;
302             }
303 0     0 0 0 }
304 0     0 0 0 return wantarray ? ($args, @values) : $args;
305             }
306              
307             sub boolean_arguments { () }
308 0 0   0 0 0 sub paired_arguments { () }
309 0 0       0  
310 0 0       0 # get a unique id for any node
311 0         0 sub id {
312             if (not ref $_[0]) {
313 0         0 return 'undef' if not defined $_[0];
314 0 0       0 \$_[0] =~ /\((\w+)\)$/o or die;
315 0         0 return "$1-S";
316             }
317             require overload;
318             overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
319             return $1;
320             }
321              
322             #===============================================================================
323 5     5   33 # It's super, man.
  5         6  
  5         1136  
324             #===============================================================================
325 0 0   0 0 0 package DB;
326 0         0 {
327             no warnings 'redefine';
328             sub super_args {
329             my @dummy = caller(@_ ? $_[0] : 2);
330             return @DB::args;
331             }
332 0     0 0 0 }
333 0         0  
334 0         0 package Spiffy;
335 0 0       0 sub super {
336             my $method;
337 0         0 my $frame = 1;
338 0 0       0 while ($method = (caller($frame++))[3]) {
339 0 0       0 $method =~ s/.*::// and last;
340 0         0 }
341 0         0 my @args = DB::super_args($frame);
342             @_ = @_ ? ($args[0], @_) : @args;
343 0 0 0     0 my $class = ref $_[0] ? ref $_[0] : $_[0];
344 0         0 my $caller_class = caller;
  0         0  
345 0         0 my $seen = 0;
346 5     5   31 my @super_classes = reverse grep {
  5         7  
  5         788  
347 0 0       0 ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
348 0 0       0 } reverse @{all_my_bases($class)};
  0         0  
349 0 0       0 for my $super_class (@super_classes) {
  0         0  
  0         0  
350             no strict 'refs';
351 0         0 next if $super_class eq $class;
  0         0  
352             if (defined &{"${super_class}::$method"}) {
353             ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
354 0         0 if $method eq 'AUTOLOAD';
355             return &{"${super_class}::$method"};
356             }
357             }
358             return;
359             }
360              
361             #===============================================================================
362             # This code deserves a spanking, because it is being very naughty.
363             # It is exchanging base.pm's import() for its own, so that people
364             # can use base.pm with Spiffy modules, without being the wiser.
365             #===============================================================================
366 5 50   5   27 my $real_base_import;
367 5   50     130 my $real_mixin_import;
368 5         11  
369 5         28 BEGIN {
370 5     5   29 require base unless defined $INC{'base.pm'};
  5         7  
  5         382  
371 5         36 $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
372 5         254 $real_base_import = \&base::import;
373             $real_mixin_import = \&mixin::import;
374             no warnings;
375             *base::import = \&spiffy_base_import;
376             *mixin::import = \&spiffy_mixin_import;
377             }
378              
379             # my $i = 0;
380             # while (my $caller = caller($i++)) {
381             # next unless $caller eq 'base' or $caller eq 'mixin';
382             # croak <<END;
383             # Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
384             # Spiffy module. See the documentation of Spiffy.pm for details.
385 95     95 0 2341873 # END
386 95         189 # }
387 5     5   29  
  5         9  
  5         1280  
388             sub spiffy_base_import {
389             my @base_classes = @_;
390 95 100       203 shift @base_classes;
  95 50       117  
  95         679  
391 95         21516 no strict 'refs';
392             goto &$real_base_import
393 0           unless grep {
394 0           eval "require $_" unless %{"$_\::"};
395 0 0         $_->isa('Spiffy');
396 0 0         } @base_classes;
397             my $inheritor = caller(0);
398             for my $base_class (@base_classes) {
399 0           next if $inheritor->isa($base_class);
400 0           croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
401 0           "See the documentation of Spiffy.pm for details\n "
402             unless $base_class->isa('Spiffy');
403             $stack_frame = 1; # tell import to use different caller
404             import($base_class, '-base');
405             $stack_frame = 0;
406 0     0 0   }
407 0           }
408 0            
409             sub mixin {
410             my $self = shift;
411             my $target_class = ref($self);
412 0     0 0   spiffy_mixin_import($target_class, @_)
413 0 0         }
414              
415 0 0         sub spiffy_mixin_import {
416             my $target_class = shift;
417 0           $target_class = caller(0)
418 0           if $target_class eq 'mixin';
419 0           my $mixin_class = shift
420 0           or die "Nothing to mixin";
421 5     5   32 eval "require $mixin_class";
  5         7  
  5         122  
422 5     5   21 my @roles = @_;
  5         9  
  5         633  
423 0           my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
  0            
  0            
424 0           my %methods = spiffy_mixin_methods($mixin_class, @roles);
  0            
425 0           no strict 'refs';
426 0           no warnings;
  0            
427             @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
428             @{"$target_class\::ISA"} = ($pseudo_class);
429             for (keys %methods) {
430             *{"$pseudo_class\::$_"} = $methods{$_};
431 0     0 0   }
432 5     5   44 }
  5         13  
  5         2936  
433 0            
434             sub spiffy_mixin_methods {
435 0 0         my $mixin_class = shift;
436 0           no strict 'refs';
437 0 0         my %methods = spiffy_all_methods($mixin_class);
  0            
438             map {
439             $methods{$_}
440             ? ($_, \ &{"$methods{$_}\::$_"})
441             : ($_, \ &{"$mixin_class\::$_"})
442             } @_
443             ? (get_roles($mixin_class, @_))
444 0     0 0   : (keys %methods);
445 0           }
446 0            
447             sub get_roles {
448 0           my $mixin_class = shift;
  0            
449             my @roles = @_;
450 0           while (grep /^!*:/, @roles) {
451 0           @roles = map {
452             s/!!//g;
453 0 0         /^!:(.*)/ ? do {
    0          
454 0           my $m = "_role_$1";
455 0           map("!$_", $mixin_class->$m);
456             } :
457             /^:(.*)/ ? do {
458             my $m = "_role_$1";
459             ($mixin_class->$m);
460 0 0 0       } :
461 0           ($_)
462 0           } @roles;
463             }
464 0           if (@roles and $roles[0] =~ /^!/) {
465 0           my %methods = spiffy_all_methods($mixin_class);
466 0           unshift @roles, keys(%methods);
467 0 0         }
468             my %roles;
469 0           for (@roles) {
470             s/!!//g;
471 0           delete $roles{$1}, next
472             if /^!(.*)/;
473             $roles{$_} = 1;
474             }
475 5     5   33 keys %roles;
  5         98  
  5         868  
476 0     0 0   }
477 0 0          
478             sub spiffy_all_methods {
479 0           no strict 'refs';
480             my $class = shift;
481 0 0         return if $class eq 'Spiffy';
  0            
482 0           my %methods = map {
  0            
483 0           ($_, $class)
484 0           } grep {
485 0 0         defined &{"$class\::$_"} and not /^_/
  0            
486 0           } keys %{"$class\::"};
  0            
487             my %super_methods;
488             %super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
489             if @{"$class\::ISA"};
490             %{{%super_methods, %methods}};
491             }
492              
493              
494             # END of naughty code.
495 5     5   32 #===============================================================================
  5         7  
  5         1751  
496 0 0   0 0   # Debugging support
497 0           #===============================================================================
498 0           sub spiffy_dump {
499 0           no warnings;
500 0           if ($dump eq 'dumper') {
501             require Data::Dumper;
502 0           $Data::Dumper::Sortkeys = 1;
503 0           $Data::Dumper::Indent = 1;
504 0           return Data::Dumper::Dumper(@_);
505             }
506             require YAML;
507             $YAML::UseVersion = 0;
508 0     0 0   return YAML::Dump(@_) . "...\n";
509 0           }
510              
511             sub at_line_number {
512             my ($file_path, $line_number) = (caller(1))[1,2];
513 0     0 0   " at $file_path line $line_number\n";
514 0 0         }
515              
516             sub WWW {
517             warn spiffy_dump(@_) . at_line_number;
518 0     0 0   return wantarray ? @_ : $_[0];
519             }
520              
521             sub XXX {
522 0     0 0   die spiffy_dump(@_) . at_line_number;
523 0 0         }
524              
525             sub YYY {
526             print spiffy_dump(@_) . at_line_number;
527 0     0 0   return wantarray ? @_ : $_[0];
528 0           }
529              
530             sub ZZZ {
531             require Carp;
532             Carp::confess spiffy_dump(@_);
533             }
534              
535             1;