line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Parse::FieldPath; |
2
|
|
|
|
|
|
|
{ |
3
|
|
|
|
|
|
|
$Parse::FieldPath::VERSION = '0.005'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
# ABSTRACT: Perl module to extract fields from objects |
7
|
|
|
|
|
|
|
|
8
|
9
|
|
|
9
|
|
334260
|
use strict; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
285
|
|
9
|
9
|
|
|
9
|
|
43
|
use warnings; |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
247
|
|
10
|
|
|
|
|
|
|
|
11
|
9
|
|
|
9
|
|
49
|
use Exporter qw/import unimport/; |
|
9
|
|
|
|
|
15
|
|
|
9
|
|
|
|
|
752
|
|
12
|
|
|
|
|
|
|
our @EXPORT_OK = qw/extract_fields/; |
13
|
|
|
|
|
|
|
|
14
|
9
|
|
|
9
|
|
44
|
use Scalar::Util qw/reftype blessed/; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
740
|
|
15
|
9
|
|
|
9
|
|
47
|
use List::Util qw/first/; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
981
|
|
16
|
9
|
|
|
9
|
|
47
|
use Carp; |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
632
|
|
17
|
|
|
|
|
|
|
|
18
|
9
|
|
|
9
|
|
9697
|
use Parse::FieldPath::Parser; |
|
9
|
|
|
|
|
42
|
|
|
9
|
|
|
|
|
341
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# Maximum number of times to allow _extract to recurse. |
21
|
9
|
|
|
9
|
|
67
|
use constant RECURSION_LIMIT => 512; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
6241
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub extract_fields { |
24
|
30
|
|
|
30
|
1
|
21100
|
my ( $obj, $field_path ) = @_; |
25
|
|
|
|
|
|
|
|
26
|
30
|
100
|
66
|
|
|
455
|
croak "extract_fields needs an object or a hashref" |
|
|
|
66
|
|
|
|
|
27
|
|
|
|
|
|
|
unless blessed($obj) || ( reftype($obj) && reftype($obj) eq 'HASH' ); |
28
|
|
|
|
|
|
|
|
29
|
29
|
|
|
|
|
99
|
my $tree = _build_tree($field_path); |
30
|
29
|
|
|
|
|
2699
|
return _extract( $obj, $tree, 0 ); |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
sub _build_tree { |
34
|
40
|
|
|
40
|
|
43512
|
my ($field_path) = @_; |
35
|
40
|
|
|
|
|
278
|
my $parser = Parse::FieldPath::Parser->new(); |
36
|
40
|
|
|
|
|
517
|
return $parser->parse($field_path); |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub _extract { |
40
|
575
|
|
|
575
|
|
826
|
my ( $source, $tree, $recurse_count ) = @_; |
41
|
|
|
|
|
|
|
|
42
|
575
|
|
|
|
|
5452
|
$recurse_count++; |
43
|
575
|
100
|
|
|
|
2142
|
die "Maximum recursion limit reached" if $recurse_count > RECURSION_LIMIT; |
44
|
|
|
|
|
|
|
|
45
|
574
|
|
|
|
|
541
|
my $is_object; |
46
|
574
|
100
|
66
|
|
|
1761
|
if ( blessed($source) ) { |
|
|
100
|
|
|
|
|
|
47
|
554
|
|
|
|
|
722
|
$is_object = 1; |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
elsif ( reftype($source) && reftype($source) eq 'HASH' ) { |
50
|
11
|
|
|
|
|
22
|
$is_object = 0; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
else { |
53
|
9
|
|
|
|
|
36
|
return $source; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
565
|
|
|
|
|
1032
|
my $all_fields = []; |
57
|
565
|
100
|
|
|
|
849
|
if ($is_object) { |
58
|
554
|
50
|
|
|
|
1387
|
$all_fields = $source->all_fields() if $source->can('all_fields'); |
59
|
|
|
|
|
|
|
|
60
|
554
|
100
|
66
|
|
|
40219
|
die "Expected $source->all_fields to return an arrayref" |
61
|
|
|
|
|
|
|
unless reftype($all_fields) |
62
|
|
|
|
|
|
|
&& reftype($all_fields) eq 'ARRAY'; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
else { |
65
|
11
|
|
|
|
|
42
|
@$all_fields = keys %$source; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
564
|
100
|
100
|
|
|
2479
|
if ( exists $tree->{'*'} || !%$tree ) { |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# We've got an object, but not a list of fields. Get everything. |
71
|
527
|
|
|
|
|
2024
|
$tree->{$_} = {} for @$all_fields; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
564
|
100
|
100
|
|
|
2134
|
$source->fields_requested( [ keys %$tree ] ) |
75
|
|
|
|
|
|
|
if $is_object && $source->can('fields_requested'); |
76
|
|
|
|
|
|
|
|
77
|
564
|
|
|
|
|
10231
|
my %fields; |
78
|
564
|
|
|
|
|
1359
|
for my $field ( keys %$tree ) { |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# Only accept fields that have been explicitly allowed |
81
|
595
|
100
|
|
661
|
|
2386
|
next unless first { $_ eq $field } @$all_fields; |
|
661
|
|
|
|
|
1584
|
|
82
|
|
|
|
|
|
|
|
83
|
587
|
|
|
|
|
1595
|
my $branch = $tree->{$field}; |
84
|
587
|
100
|
|
|
|
2623
|
my $value = $is_object ? $source->$field : $source->{$field}; |
85
|
587
|
|
100
|
|
|
30286
|
my $value_reftype = reftype($value) || ''; |
86
|
|
|
|
|
|
|
|
87
|
587
|
100
|
100
|
|
|
2150
|
if ( blessed($value) || $value_reftype eq 'HASH' ) { |
|
|
100
|
|
|
|
|
|
88
|
527
|
|
|
|
|
3562
|
$fields{$field} = _extract( $value, $branch, $recurse_count ); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
elsif ( $value_reftype eq 'ARRAY' ) { |
91
|
19
|
|
|
|
|
52
|
$fields{$field} = |
92
|
8
|
|
|
|
|
12
|
[ map { _extract( $_, $branch, $recurse_count ) } @{$value} ]; |
|
8
|
|
|
|
|
22
|
|
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
else { |
95
|
52
|
100
|
|
|
|
115
|
if (%$branch) { |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# Unblessed object, but a sub-object has been requested. |
98
|
|
|
|
|
|
|
# Setting it to undef, maybe an error should be thrown here |
99
|
|
|
|
|
|
|
# though? |
100
|
1
|
|
|
|
|
3
|
$fields{$field} = undef; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
else { |
103
|
51
|
|
|
|
|
161
|
$fields{$field} = $value; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
51
|
|
|
|
|
416
|
return \%fields; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
1; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=pod |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=head1 NAME |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
Parse::FieldPath |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=head1 ABSTRACT |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
Parses an XPath inspired field list and extracts those fields from an object |
122
|
|
|
|
|
|
|
hierarchy. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
Based on the "fields" parameter for the Google+ API: |
125
|
|
|
|
|
|
|
http://developers.google.com/+/api/ |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=head1 SYNOPSIS |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
Say you have an object, with some sub-objects, that's initialized like this: |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
my $cow = Cow->new(); |
132
|
|
|
|
|
|
|
$cow->color("black and white"); |
133
|
|
|
|
|
|
|
$cow->tail(Cow::Tail->new(floppy => 1)); |
134
|
|
|
|
|
|
|
$cow->mouth(Cow::Tounge->new( |
135
|
|
|
|
|
|
|
tounge => Cow::Tounge->new, |
136
|
|
|
|
|
|
|
teeth => Cow::Teeth->new, |
137
|
|
|
|
|
|
|
); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
And you want a hash containing some of those fields (perhaps to pass to |
140
|
|
|
|
|
|
|
JSON::XS, or something). Then you can do this: |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
use Parse::FieldPath qw/extract_fields/; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
my $cow_hash = extract_fields($cow, "color,tail/floppy"); |
145
|
|
|
|
|
|
|
# $cow_hash is now: |
146
|
|
|
|
|
|
|
# { |
147
|
|
|
|
|
|
|
# color => 'black and white', |
148
|
|
|
|
|
|
|
# tail => { |
149
|
|
|
|
|
|
|
# floppy => 1, |
150
|
|
|
|
|
|
|
# } |
151
|
|
|
|
|
|
|
# } |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=head1 FUNCTIONS |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=over 4 |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=item B<extract_fields ($object_or_hashref, $field_path)> |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
Parses the C<field_path> and returns a hashref with the fields requested from |
160
|
|
|
|
|
|
|
C<$object_or_hashref>. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
C<$object_or_hashref>, and any sub-objects, will need to define a method called |
163
|
|
|
|
|
|
|
C<all_fields()>. See L<CALLBACKS> for details. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
C<field_path> is a string describing the fields to return. Each field is |
166
|
|
|
|
|
|
|
separated by a comma, e.g. "a,b" will return fields "a" and "b". |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
To request a field from a sub-objects, use the form "subobject/field". If more |
169
|
|
|
|
|
|
|
than one field from a sub-object is required, put the field names in |
170
|
|
|
|
|
|
|
parenthesis, "subobject(field1,field2)". |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
C<field_path> can go as deep as necessary, for example, this works fine: |
173
|
|
|
|
|
|
|
"a/b/c(d/e,f)" |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=back |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=head1 CALLBACKS |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=over 4 |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item B<all_fields()> |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
A method called C<all_fields()> should be defined for any object (including |
184
|
|
|
|
|
|
|
sub-objects), that will be used with this module. It needs to return an |
185
|
|
|
|
|
|
|
arrayref containing all the valid fields. Any field requested that's not in the |
186
|
|
|
|
|
|
|
list returned by C<all_fields()> will be skipped. |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
A simple implementation would be: |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub all_fields { |
191
|
|
|
|
|
|
|
my ($self) = @_; |
192
|
|
|
|
|
|
|
return [qw/field1 field2/]; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
If the list doesn't change, a constant will work too: |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
use constant all_fields => [qw/field1 field2/]; |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
This method is required because simply allowing any method to be called would |
200
|
|
|
|
|
|
|
be dangerous (e.g. if your object had a "delete_everything()" method, or |
201
|
|
|
|
|
|
|
something). It's also necessary to know which fields constitute "everything" |
202
|
|
|
|
|
|
|
for the object. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
=item B<requested_fields($field_list)> |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
Called on an object right before the accessor methods are called. It's passed a |
207
|
|
|
|
|
|
|
list of fields that are about to be requested. This method is completely |
208
|
|
|
|
|
|
|
optional. It's intended to allow the object to fetch anything it needs to, in |
209
|
|
|
|
|
|
|
order to make the requested data available. |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
=back |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
=head1 GitHub |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
https://github.com/pboyd/Parse-FieldPath |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
=head1 AUTHOR |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
Paul Boyd <pboyd@dev3l.net> |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
This software is copyright (c) 2011 by Paul Boyd. |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
226
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=cut |