line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::Visitor::Lite; |
2
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
42
|
|
3
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
33
|
|
4
|
1
|
|
|
1
|
|
4
|
no warnings 'recursion'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
30
|
|
5
|
1
|
|
|
1
|
|
4
|
use Carp qw/croak/; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
77
|
|
6
|
1
|
|
|
1
|
|
987
|
use Data::Util qw/:check/; |
|
1
|
|
|
|
|
1762
|
|
|
1
|
|
|
|
|
248
|
|
7
|
1
|
|
|
1
|
|
8
|
use Scalar::Util qw/blessed refaddr/; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
153
|
|
8
|
1
|
|
|
1
|
|
1179
|
use List::MoreUtils qw/all/; |
|
1
|
|
|
|
|
1287
|
|
|
1
|
|
|
|
|
83
|
|
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
6
|
use constant AS_HASH_KEY => 1; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1341
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $REPLACER_GENERATOR = { |
14
|
|
|
|
|
|
|
# only blessed value |
15
|
|
|
|
|
|
|
'-object' => sub { |
16
|
|
|
|
|
|
|
my ($code) = shift; |
17
|
|
|
|
|
|
|
return sub { |
18
|
|
|
|
|
|
|
my $value = shift; |
19
|
|
|
|
|
|
|
return $value unless blessed $value; |
20
|
|
|
|
|
|
|
return $code->($value); |
21
|
|
|
|
|
|
|
}; |
22
|
|
|
|
|
|
|
}, |
23
|
|
|
|
|
|
|
# only blessed value and implements provided methods |
24
|
|
|
|
|
|
|
'-implements' => sub { |
25
|
|
|
|
|
|
|
my ( $args, $code ) = @_; |
26
|
|
|
|
|
|
|
return sub { |
27
|
|
|
|
|
|
|
my $value = shift; |
28
|
|
|
|
|
|
|
return $value unless blessed $value; |
29
|
|
|
|
|
|
|
return $value unless all { $value->can($_) } @$args; |
30
|
|
|
|
|
|
|
return $code->($value); |
31
|
|
|
|
|
|
|
}; |
32
|
|
|
|
|
|
|
}, |
33
|
|
|
|
|
|
|
# only blessed value and sub-class of provided package |
34
|
|
|
|
|
|
|
'-instance' => sub { |
35
|
|
|
|
|
|
|
my ( $args, $code ) = @_; |
36
|
|
|
|
|
|
|
return sub { |
37
|
|
|
|
|
|
|
my $value = shift; |
38
|
|
|
|
|
|
|
return $value unless Data::Util::is_instance( $value, $args ); |
39
|
|
|
|
|
|
|
return $code->($value); |
40
|
|
|
|
|
|
|
}; |
41
|
|
|
|
|
|
|
}, |
42
|
|
|
|
|
|
|
# only hash key |
43
|
|
|
|
|
|
|
'-hashkey' => sub { |
44
|
|
|
|
|
|
|
my ($code) = @_; |
45
|
|
|
|
|
|
|
return sub { |
46
|
|
|
|
|
|
|
my ( $value, $as_hash_key ) = @_; |
47
|
|
|
|
|
|
|
return $value unless $as_hash_key; |
48
|
|
|
|
|
|
|
return $code->($value); |
49
|
|
|
|
|
|
|
}; |
50
|
|
|
|
|
|
|
}, |
51
|
|
|
|
|
|
|
# only all string with hash keys |
52
|
|
|
|
|
|
|
'-string' => sub { |
53
|
|
|
|
|
|
|
my ($code) = @_; |
54
|
|
|
|
|
|
|
return sub { |
55
|
|
|
|
|
|
|
my ( $value, $as_hash_key ) = @_; |
56
|
|
|
|
|
|
|
return $value unless Data::Util::is_string($value); |
57
|
|
|
|
|
|
|
return $code->($value); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
}, |
60
|
|
|
|
|
|
|
# list up other types |
61
|
|
|
|
|
|
|
&__other_types, |
62
|
|
|
|
|
|
|
}; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
sub __other_types { |
65
|
1
|
|
|
1
|
|
4
|
my @types = qw/ |
66
|
|
|
|
|
|
|
scalar_ref |
67
|
|
|
|
|
|
|
array_ref |
68
|
|
|
|
|
|
|
hash_ref |
69
|
|
|
|
|
|
|
code_ref |
70
|
|
|
|
|
|
|
glob_ref |
71
|
|
|
|
|
|
|
regex_ref |
72
|
|
|
|
|
|
|
invocant |
73
|
|
|
|
|
|
|
value |
74
|
|
|
|
|
|
|
number |
75
|
|
|
|
|
|
|
integer |
76
|
|
|
|
|
|
|
/; |
77
|
1
|
|
|
|
|
3
|
return map{__create_by_type($_)} @types; |
|
10
|
|
|
|
|
20
|
|
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub __create_by_type { |
81
|
10
|
|
|
10
|
|
14
|
my $type = shift; |
82
|
|
|
|
|
|
|
return ( |
83
|
|
|
|
|
|
|
"-$type" => sub { |
84
|
0
|
|
|
0
|
|
|
my ($code) = @_; |
85
|
0
|
|
|
|
|
|
my $checker = Data::Util->can("is_$type"); |
86
|
|
|
|
|
|
|
return sub { |
87
|
0
|
|
|
|
|
|
my ( $value, $as_hash_key ) = @_; |
88
|
0
|
0
|
|
|
|
|
return $value if $as_hash_key; |
89
|
0
|
0
|
|
|
|
|
return $value unless $checker->($value); |
90
|
0
|
|
|
|
|
|
return $code->($value); |
91
|
|
|
|
|
|
|
} |
92
|
0
|
|
|
|
|
|
} |
93
|
10
|
|
|
|
|
1322
|
); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub new { |
97
|
0
|
|
|
0
|
0
|
|
my ( $class, @replacers ) = @_; |
98
|
0
|
|
|
|
|
|
return bless { replacer => __compose_replacers(@replacers) }, $class; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub __compose_replacers { |
102
|
0
|
|
|
0
|
|
|
my (@replacers) = @_; |
103
|
0
|
|
|
|
|
|
my @codes = map { __compose_replacer($_) } @replacers; |
|
0
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
return sub { |
105
|
0
|
|
|
0
|
|
|
my ( $value, $as_hash_key ) = @_; |
106
|
0
|
|
|
|
|
|
for my $code (@codes) { |
107
|
0
|
|
|
|
|
|
$value = $code->( $value, $as_hash_key ); |
108
|
|
|
|
|
|
|
} |
109
|
0
|
|
|
|
|
|
return $value; |
110
|
0
|
|
|
|
|
|
}; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub __compose_replacer { |
114
|
0
|
|
|
0
|
|
|
my ($replacer) = @_; |
115
|
0
|
|
|
0
|
|
|
return sub { $_[0] } |
116
|
0
|
0
|
|
|
|
|
unless defined $replacer; |
117
|
0
|
0
|
|
|
|
|
return $replacer |
118
|
|
|
|
|
|
|
unless ref $replacer; |
119
|
0
|
0
|
|
|
|
|
return $replacer |
120
|
|
|
|
|
|
|
if ref $replacer eq 'CODE'; |
121
|
|
|
|
|
|
|
|
122
|
0
|
0
|
|
|
|
|
croak('replacer should not be hash ref') |
123
|
|
|
|
|
|
|
if ref $replacer eq 'HASH'; |
124
|
|
|
|
|
|
|
|
125
|
0
|
|
|
|
|
|
my ( $type, $args, $code ) = @$replacer; |
126
|
|
|
|
|
|
|
my $generator = $REPLACER_GENERATOR->{$type} || sub { |
127
|
0
|
|
|
0
|
|
|
croak('undefined replacer type'); |
128
|
0
|
|
0
|
|
|
|
}; |
129
|
|
|
|
|
|
|
|
130
|
0
|
|
|
|
|
|
return $generator->( $args, $code ); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub visit { |
134
|
0
|
|
|
0
|
0
|
|
my ( $self, $target ) = @_; |
135
|
0
|
|
|
|
|
|
$self->{seen} = {}; |
136
|
0
|
|
|
|
|
|
return $self->_visit($target); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub _visit { |
140
|
0
|
|
|
0
|
|
|
my ( $self, $target ) = @_; |
141
|
0
|
0
|
|
|
|
|
goto \&_replace unless ref $target; |
142
|
0
|
0
|
|
|
|
|
goto \&_visit_array if ref $target eq 'ARRAY'; |
143
|
0
|
0
|
|
|
|
|
goto \&_visit_hash if ref $target eq 'HASH'; |
144
|
0
|
|
|
|
|
|
goto \&_replace; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub _replace { |
148
|
0
|
|
|
0
|
|
|
my ( $self, $value, $as_hash_key ) = @_; |
149
|
0
|
|
|
|
|
|
return $self->{replacer}->( $value, $as_hash_key ); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub _visit_array { |
153
|
0
|
|
|
0
|
|
|
my ( $self, $target ) = @_; |
154
|
0
|
|
|
|
|
|
my $addr = refaddr $target; |
155
|
0
|
0
|
|
|
|
|
return $self->{seen}{$addr} |
156
|
|
|
|
|
|
|
if defined $self->{seen}{$addr}; |
157
|
0
|
|
|
|
|
|
my $new_array = $self->{seen}{$addr} = []; |
158
|
0
|
|
|
|
|
|
@$new_array = map { $self->_visit($_) } @$target; |
|
0
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
|
return $new_array; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub _visit_hash { |
163
|
0
|
|
|
0
|
|
|
my ( $self, $target ) = @_; |
164
|
0
|
|
|
|
|
|
my $addr = refaddr $target; |
165
|
0
|
0
|
|
|
|
|
return $self->{seen}{$addr} if defined $self->{seen}{$addr}; |
166
|
0
|
|
|
|
|
|
my $new_hash = $self->{seen}{$addr} = {}; |
167
|
0
|
|
|
|
|
|
%$new_hash = map { |
168
|
0
|
|
|
|
|
|
$self->_replace( $_, AS_HASH_KEY ) => $self->_visit( $target->{$_} ) |
169
|
|
|
|
|
|
|
} keys %$target; |
170
|
0
|
|
|
|
|
|
return $new_hash; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
1; |
174
|
|
|
|
|
|
|
__END__ |