File Coverage

lib/Class/Spiffy.pm
Criterion Covered Total %
statement 315 337 93.4
branch 98 132 74.2
condition 27 38 71.0
subroutine 53 59 89.8
pod 8 26 30.7
total 501 592 84.6


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