File Coverage

inc/Spiffy.pm
Criterion Covered Total %
statement 254 440 57.7
branch 82 204 40.2
condition 34 62 54.8
subroutine 38 61 62.3
pod 0 27 0.0
total 408 794 51.3


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