root/Encode-DoubleEncodedUTF8/trunk/inc/Spiffy.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

Line 
1 #line 1
2 package Spiffy;
3 use strict;
4 use 5.006001;
5 use warnings;
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 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 sub new {
34     my $class = shift;
35     $class = ref($class) || $class;
36     my $self = bless {}, $class;
37     while (@_) {
38         my $method = shift;
39         $self->$method(shift);
40     }
41     return $self;   
42 }
43
44 my $filtered_files = {};
45 my $filter_dump = 0;
46 my $filter_save = 0;
47 our $filter_result = '';
48 sub import {
49     no strict 'refs';
50     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     # difficult debugging. Consider using something truly local.
56     my ($args, @export_list) = do {
57         local *boolean_arguments = sub {
58             qw(
59                 -base -Base -mixin -selfless
60                 -XXX -dumper -yaml
61                 -filter_dump -filter_save
62             )
63         };
64         local *paired_arguments = sub { qw(-package) };
65         $self_package->parse_arguments(@_);
66     };
67     return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
68       if $args->{-mixin};
69
70     $filter_dump = 1 if $args->{-filter_dump};
71     $filter_save = 1 if $args->{-filter_save};
72     $dump = 'yaml' if $args->{-yaml};
73     $dump = 'dumper' if $args->{-dumper};
74
75     local @EXPORT_BASE = @EXPORT_BASE;
76
77     if ($args->{-XXX}) {
78         push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
79           unless grep /^XXX$/, @EXPORT_BASE;
80     }
81
82     spiffy_filter()
83       if ($args->{-selfless} or $args->{-Base}) and
84          not $filtered_files->{(caller($stack_frame))[1]}++;
85
86     my $caller_package = $args->{-package} || caller($stack_frame);
87     push @{"$caller_package\::ISA"}, $self_package
88       if $args->{-Base} or $args->{-base};
89
90     for my $class (@{all_my_bases($self_package)}) {
91         next unless $class->isa('Spiffy');
92         my @export = grep {
93             not defined &{"$caller_package\::$_"};
94         } ( @{"$class\::EXPORT"},
95             ($args->{-Base} or $args->{-base})
96               ? @{"$class\::EXPORT_BASE"} : (),
97           );
98         my @export_ok = grep {
99             not defined &{"$caller_package\::$_"};
100         } @{"$class\::EXPORT_OK"};
101
102         # Avoid calling the expensive Exporter::export
103         # if there is nothing to do (optimization)
104         my %exportable = map { ($_, 1) } @export, @export_ok;
105         next unless keys %exportable;
106
107         my @export_save = @{"$class\::EXPORT"};
108         my @export_ok_save = @{"$class\::EXPORT_OK"};
109         @{"$class\::EXPORT"} = @export;
110         @{"$class\::EXPORT_OK"} = @export_ok;
111         my @list = grep {
112             (my $v = $_) =~ s/^[\!\:]//;
113             $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
114         } @export_list;
115         Exporter::export($class, $caller_package, @list);
116         @{"$class\::EXPORT"} = @export_save;
117         @{"$class\::EXPORT_OK"} = @export_ok_save;
118     }
119 }
120
121 sub spiffy_filter {
122     require Filter::Util::Call;
123     my $done = 0;
124     Filter::Util::Call::filter_add(
125         sub {
126             return 0 if $done;
127             my ($data, $end) = ('', '');
128             while (my $status = Filter::Util::Call::filter_read()) {
129                 return $status if $status < 0;
130                 if (/^__(?:END|DATA)__\r?$/) {
131                     $end = $_;
132                     last;
133                 }
134                 $data .= $_;
135                 $_ = '';
136             }
137             $_ = $data;
138             my @my_subs;
139             s[^(sub\s+\w+\s+\{)(.*\n)]
140              [${1}my \$self = shift;$2]gm;
141             s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
142              [${1}${2}]gm;
143             s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
144              [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
145             my $preclare = '';
146             if (@my_subs) {
147                 $preclare = join ',', map "\$$_", @my_subs;
148                 $preclare = "my($preclare);";
149             }
150             $_ = "use strict;use warnings;$preclare${_};1;\n$end";
151             if ($filter_dump) { print; exit }
152             if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
153             $done = 1;
154         }
155     );
156 }
157
158 sub base {
159     push @_, -base;
160     goto &import;
161 }
162
163 sub all_my_bases {
164     my $class = shift;
165
166     return $bases_map->{$class}
167       if defined $bases_map->{$class};
168
169     my @bases = ($class);
170     no strict 'refs';
171     for my $base_class (@{"${class}::ISA"}) {
172         push @bases, @{all_my_bases($base_class)};
173     }
174     my $used = {};
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 sub field {
203     my $package = caller;
204     my ($args, @values) = do {
205         no warnings;
206         local *boolean_arguments = sub { (qw(-weak)) };
207         local *paired_arguments = sub { (qw(-package -init)) };
208         Spiffy->parse_arguments(@_);
209     };
210     my ($field, $default) = @values;
211     $package = $args->{-package} if defined $args->{-package};
212     die "Cannot have a default for a weakened field ($field)"
213         if defined $default && $args->{-weak};
214     return if defined &{"${package}::$field"};
215     require Scalar::Util if $args->{-weak};
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
223     my $code = $code{sub_start};
224     if ($args->{-init}) {
225         my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
226         $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
227     }
228     $code .= sprintf $code{set_default}, $field, $default_string, $field
229       if defined $default;
230     $code .= sprintf $code{return_if_get}, $field;
231     $code .= sprintf $code{set}, $field;
232     $code .= sprintf $code{weaken}, $field, $field
233       if $args->{-weak};
234     $code .= sprintf $code{sub_end}, $field;
235
236     my $sub = eval $code;
237     die $@ if $@;
238     no strict 'refs';
239     *{"${package}::$field"} = $sub;
240     return $code if defined wantarray;
241 }
242
243 sub default_as_code {
244     require Data::Dumper;
245     local $Data::Dumper::Sortkeys = 1;
246     my $code = Data::Dumper::Dumper(shift);
247     $code =~ s/^\$VAR1 = //;
248     $code =~ s/;$//;
249     return $code;
250 }
251
252 sub const {
253     my $package = caller;
254     my ($args, @values) = do {
255         no warnings;
256         local *paired_arguments = sub { (qw(-package)) };
257         Spiffy->parse_arguments(@_);
258     };
259     my ($field, $default) = @values;
260     $package = $args->{-package} if defined $args->{-package};
261     no strict 'refs';
262     return if defined &{"${package}::$field"};
263     *{"${package}::$field"} = sub { $default }
264 }
265
266 sub stub {
267     my $package = caller;
268     my ($args, @values) = do {
269         no warnings;
270         local *paired_arguments = sub { (qw(-package)) };
271         Spiffy->parse_arguments(@_);
272     };
273     my ($field, $default) = @values;
274     $package = $args->{-package} if defined $args->{-package};
275     no strict 'refs';
276     return if defined &{"${package}::$field"};
277     *{"${package}::$field"} =
278     sub {
279         require Carp;
280         Carp::confess
281           "Method $field in package $package must be subclassed";
282     }
283 }
284
285 sub parse_arguments {
286     my $class = shift;
287     my ($args, @values) = ({}, ());
288     my %booleans = map { ($_, 1) } $class->boolean_arguments;
289     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             ? shift
295             : 1;
296         }
297         elsif (defined $elem and defined $pairs{$elem} and @_) {
298             $args->{$elem} = shift;
299         }
300         else {
301             push @values, $elem;
302         }
303     }
304     return wantarray ? ($args, @values) : $args;       
305 }
306
307 sub boolean_arguments { () }
308 sub paired_arguments { () }
309
310 # get a unique id for any node
311 sub id {
312     if (not ref $_[0]) {
313         return 'undef' if not defined $_[0];
314         \$_[0] =~ /\((\w+)\)$/o or die;
315         return "$1-S";
316     }
317     require overload;
318     overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
319     return $1;
320 }
321
322 #===============================================================================
323 # It's super, man.
324 #===============================================================================
325 package DB;
326 {
327     no warnings 'redefine';
328     sub super_args {
329         my @dummy = caller(@_ ? $_[0] : 2);
330         return @DB::args;
331     }
332 }
333
334 package Spiffy;
335 sub super {
336     my $method;
337     my $frame = 1;
338     while ($method = (caller($frame++))[3]) {
339         $method =~ s/.*::// and last;
340     }
341     my @args = DB::super_args($frame);
342     @_ = @_ ? ($args[0], @_) : @args;
343     my $class = ref $_[0] ? ref $_[0] : $_[0];
344     my $caller_class = caller;
345     my $seen = 0;
346     my @super_classes = reverse grep {
347         ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
348     } reverse @{all_my_bases($class)};
349     for my $super_class (@super_classes) {
350         no strict 'refs';
351         next if $super_class eq $class;
352         if (defined &{"${super_class}::$method"}) {
353             ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
354               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 my $real_base_import;
367 my $real_mixin_import;
368
369 BEGIN {
370     require base unless defined $INC{'base.pm'};
371     $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
372     $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 # END
386 # }
387
388 sub spiffy_base_import {
389     my @base_classes = @_;
390     shift @base_classes;
391     no strict 'refs';
392     goto &$real_base_import
393       unless grep {
394           eval "require $_" unless %{"$_\::"};
395           $_->isa('Spiffy');
396       } @base_classes;
397     my $inheritor = caller(0);
398     for my $base_class (@base_classes) {
399         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           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     }
407 }
408
409 sub mixin {
410     my $self = shift;
411     my $target_class = ref($self);
412     spiffy_mixin_import($target_class, @_)
413 }
414
415 sub spiffy_mixin_import {
416     my $target_class = shift;
417     $target_class = caller(0)
418       if $target_class eq 'mixin';
419     my $mixin_class = shift
420       or die "Nothing to mixin";
421     eval "require $mixin_class";
422     my @roles = @_;
423     my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
424     my %methods = spiffy_mixin_methods($mixin_class, @roles);
425     no strict 'refs';
426     no warnings;
427     @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
428     @{"$target_class\::ISA"} = ($pseudo_class);
429     for (keys %methods) {
430         *{"$pseudo_class\::$_"} = $methods{$_};
431     }
432 }
433
434 sub spiffy_mixin_methods {
435     my $mixin_class = shift;
436     no strict 'refs';
437     my %methods = spiffy_all_methods($mixin_class);
438     map {
439         $methods{$_}
440           ? ($_, \ &{"$methods{$_}\::$_"})
441           : ($_, \ &{"$mixin_class\::$_"})
442     } @_
443       ? (get_roles($mixin_class, @_))
444       : (keys %methods);
445 }
446
447 sub get_roles {
448     my $mixin_class = shift;
449     my @roles = @_;
450     while (grep /^!*:/, @roles) {
451         @roles = map {
452             s/!!//g;
453             /^!:(.*)/ ? do {
454                 my $m = "_role_$1";
455                 map("!$_", $mixin_class->$m);
456             } :
457             /^:(.*)/ ? do {
458                 my $m = "_role_$1";
459                 ($mixin_class->$m);
460             } :
461             ($_)
462         } @roles;
463     }
464     if (@roles and $roles[0] =~ /^!/) {
465         my %methods = spiffy_all_methods($mixin_class);
466         unshift @roles, keys(%methods);
467     }
468     my %roles;
469     for (@roles) {
470         s/!!//g;
471         delete $roles{$1}, next
472           if /^!(.*)/;
473         $roles{$_} = 1;
474     }
475     keys %roles;
476 }
477
478 sub spiffy_all_methods {
479     no strict 'refs';
480     my $class = shift;
481     return if $class eq 'Spiffy';
482     my %methods = map {
483         ($_, $class)
484     } grep {
485         defined &{"$class\::$_"} and not /^_/
486     } keys %{"$class\::"};
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 #===============================================================================
496 # Debugging support
497 #===============================================================================
498 sub spiffy_dump {
499     no warnings;
500     if ($dump eq 'dumper') {
501         require Data::Dumper;
502         $Data::Dumper::Sortkeys = 1;
503         $Data::Dumper::Indent = 1;
504         return Data::Dumper::Dumper(@_);
505     }
506     require YAML;
507     $YAML::UseVersion = 0;
508     return YAML::Dump(@_) . "...\n";
509 }
510
511 sub at_line_number {
512     my ($file_path, $line_number) = (caller(1))[1,2];
513     "  at $file_path line $line_number\n";
514 }
515
516 sub WWW {
517     warn spiffy_dump(@_) . at_line_number;
518     return wantarray ? @_ : $_[0];
519 }
520
521 sub XXX {
522     die spiffy_dump(@_) . at_line_number;
523 }
524
525 sub YYY {
526     print spiffy_dump(@_) . at_line_number;
527     return wantarray ? @_ : $_[0];
528 }
529
530 sub ZZZ {
531     require Carp;
532     Carp::confess spiffy_dump(@_);
533 }
534
535 1;
536
537 __END__
538
539 #line 1066
Note: See TracBrowser for help on using the browser.