File Coverage

inc/Spiffy.pm
Criterion Covered Total %
statement 279 438 63.7
branch 105 204 51.4
condition 38 62 61.2
subroutine 37 60 61.6
pod 0 27 0.0
total 459 791 58.0


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