root/trunk/plagger/lib/Plagger/Walker.pm

Revision 1588 (checked in by miyagawa, 14 years ago)
  • Added Test::Perl::Critic test and t/perlcriticrc policy file
  • Fixed 2 args open() to comfort with PBP
  • Added ## no critic to express "I know what I'm doing"
Line 
1 package Plagger::Walker;
2 use strict;
3 use Carp;
4 use Scalar::Util qw(blessed);
5 use UNIVERSAL;
6
7 sub new {
8     my $class = shift;
9     my $self  = @_ ? {@_} : {};
10     bless $self, $class;
11 }
12
13 *isa = \&UNIVERSAL::isa;
14
15 sub decode_utf8 {
16     my($self, $stuff) = @_;
17     $self = $self->new( apply_keys => 1 ) unless ref $self;
18     $self->apply(sub { utf8::decode($_[0]) unless utf8::is_utf8($_[0]) })->($stuff);
19 }
20
21 sub apply($&;@) { ## no critic
22     my $self = shift;
23     my $code = shift;
24     my $keyapp = $self->{apply_keys} ?
25         sub { $code->(shift) } : sub { shift };
26     my $curry; # recursive so can't init
27     $curry = sub {
28         my @retval;
29         for my $arg (@_){
30             my $class = ref $arg;
31             croak 'blessed reference forbidden'
32                 if  !$self->{apply_blessed} and blessed $arg;
33             my $val =
34                 !$class ?
35                     $code->($arg) :
36                 isa($arg, 'ARRAY') ?
37                     [ $curry->(@$arg) ] :
38                 isa($arg, 'HASH') ?
39                     {
40                      map { $keyapp->($_)
41                                => $curry->($arg->{$_}) } keys %$arg
42                     } :
43                 isa($arg, 'SCALAR') ?
44                     \do{ $curry->($$arg) } :
45                 isa($arg, 'REF') && $self->{apply_ref} ?
46                     \do{ $curry->($$arg) } :
47                 isa($arg, 'GLOB')  ?
48                     *{ $curry->(*$arg) } :
49                 isa($arg, 'CODE') && $self->{apply_code} ?
50                     $code->($arg) :
51                 croak "I don't know how to apply to $class" ;
52             bless $val, $class if blessed $arg;
53             push @retval, $val;
54         }
55         return wantarray ? @retval : $retval[0];
56     };
57     @_ ? $curry->(@_) : $curry;
58 }
59
60 sub serialize {
61     my($class, $stuff) = @_;
62
63     my $curry;
64     $curry = sub {
65         my @retval;
66         for my $arg (@_) {
67             my $class = ref $arg;
68             my $val =
69                 blessed $arg && $arg->can('serialize') ?
70                     $arg->serialize :
71                 !$class ?
72                     $arg :
73                 isa($arg, 'ARRAY') ?
74                     [ $curry->(@$arg) ] :
75                 isa($arg, 'HASH') ?
76                     {
77                      map { $_ => $curry->($arg->{$_}) } keys %$arg
78                     } :
79                 isa($arg, 'SCALAR') ?
80                     \do{ $curry->($$arg) } :
81                 isa($arg, 'REF') ?
82                     \do{ $curry->($$arg) } :
83                 isa($arg, 'GLOB')  ?
84                     *{ $curry->(*$arg) } :
85                 isa($arg, 'CODE') ?
86                     $arg :
87                 croak "I don't know how to apply to $class" ;
88             push @retval, $val;
89         }
90         return wantarray ? @retval : $retval[0];
91     };
92     $curry->($stuff->clone);
93 }
94
95 1;
96
Note: See TracBrowser for help on using the browser.