line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::RecordStream::Operation::fromxml; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $VERSION = "4.0.23"; |
4
|
|
|
|
|
|
|
|
5
|
2
|
|
|
2
|
|
562
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
47
|
|
6
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
45
|
|
7
|
|
|
|
|
|
|
|
8
|
2
|
|
|
2
|
|
7
|
use base qw(App::RecordStream::Operation); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
110
|
|
9
|
|
|
|
|
|
|
|
10
|
2
|
|
|
2
|
|
10
|
use App::RecordStream::Record; |
|
2
|
|
|
|
|
10
|
|
|
2
|
|
|
|
|
40
|
|
11
|
|
|
|
|
|
|
|
12
|
2
|
|
|
2
|
|
9
|
use App::RecordStream::OptionalRequire 'HTTP::Request'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
12
|
|
13
|
2
|
|
|
2
|
|
10
|
use App::RecordStream::OptionalRequire 'LWP::UserAgent'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
9
|
|
14
|
2
|
|
|
2
|
|
11
|
use App::RecordStream::OptionalRequire 'List::MoreUtils', qw(uniq); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
9
|
|
15
|
2
|
|
|
2
|
|
10
|
use App::RecordStream::OptionalRequire 'XML::Twig'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
8
|
|
16
|
2
|
|
|
2
|
|
9
|
BEGIN { App::RecordStream::OptionalRequire::require_done() } |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub init { |
19
|
|
|
|
|
|
|
my $this = shift; |
20
|
|
|
|
|
|
|
my $args = shift; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my @elements; |
23
|
|
|
|
|
|
|
my $nested = 0; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my $spec = { |
26
|
|
|
|
|
|
|
'element=s' => sub { push @elements, split(/,/, $_[1]) }, |
27
|
|
|
|
|
|
|
'nested' => \$nested, |
28
|
|
|
|
|
|
|
}; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
$this->parse_options($args, $spec); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
$this->{'ELEMENTS'} = [ uniq @elements ]; |
33
|
|
|
|
|
|
|
$this->{'NESTED'} = $nested; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my $has_files = scalar @$args; |
36
|
|
|
|
|
|
|
$this->{'HAS_URIS'} = $has_files; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
$this->{'EXTRA_ARGS'} = $args; |
39
|
|
|
|
|
|
|
$this->{'OPEN_TAGS'} = 0; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub wants_input { |
43
|
|
|
|
|
|
|
return 0; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub stream_done { |
47
|
|
|
|
|
|
|
my $this = shift; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my $elements = $this->{'ELEMENTS'}; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
my $elem_prefix = '/*/'; |
52
|
|
|
|
|
|
|
my $attr_prefix = '/'; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
if ( $this->{'NESTED'} ) { |
55
|
|
|
|
|
|
|
$elem_prefix .= '/'; |
56
|
|
|
|
|
|
|
$attr_prefix .= '/'; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
my %start_tag_handlers; |
60
|
|
|
|
|
|
|
my %twig_roots; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
for my $element ( @$elements ) { |
63
|
|
|
|
|
|
|
my $elem_expr = $elem_prefix . $element; |
64
|
|
|
|
|
|
|
my $attr_expr = $attr_prefix . '[@' . $element . ']'; |
65
|
|
|
|
|
|
|
my $default_hash = {}; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
if ( @$elements > 1 ) { |
68
|
|
|
|
|
|
|
$default_hash->{'element'} = $element; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
$start_tag_handlers{$elem_expr} = sub { $this->{'OPEN_TAGS'}++ }; |
72
|
|
|
|
|
|
|
$twig_roots{$elem_expr} = sub { $this->handle_element($default_hash, @_) }; |
73
|
|
|
|
|
|
|
$twig_roots{$attr_expr} = sub { $this->handle_attribute($element, $default_hash, @_) }; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
my $twig = XML::Twig->new( |
77
|
|
|
|
|
|
|
start_tag_handlers => \%start_tag_handlers, |
78
|
|
|
|
|
|
|
twig_roots => \%twig_roots); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
while ( my $xml = $this->get_xml_string() ) { |
81
|
|
|
|
|
|
|
$twig->parse($xml); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub handle_element { |
86
|
|
|
|
|
|
|
my ($this, $default_hash, $twig, $elem) = @_; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
$this->{'OPEN_TAGS'}--; # force evaluation of outer elements before inner |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
if ( $this->{'OPEN_TAGS'} == 0 ) { |
91
|
|
|
|
|
|
|
my $s = $elem->simplify('forcearray' => 1, |
92
|
|
|
|
|
|
|
'keyattr' => [] ); |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
$this->push_value($s, $default_hash); |
95
|
|
|
|
|
|
|
$twig->purge; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
return 0; # don't trigger attr handler |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub handle_attribute { |
102
|
|
|
|
|
|
|
my ($this, $name, $default_hash, $twig, $elem) = @_; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
if ( $this->{'OPEN_TAGS'} == 0 ) { |
105
|
|
|
|
|
|
|
$this->push_value($elem->att($name), $default_hash); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub push_value { |
110
|
|
|
|
|
|
|
my $this = shift; |
111
|
|
|
|
|
|
|
my $value = shift; |
112
|
|
|
|
|
|
|
my $default_hash = shift; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
if ( UNIVERSAL::isa($value, 'HASH') ) { |
115
|
|
|
|
|
|
|
my $record = App::RecordStream::Record->new($value); |
116
|
|
|
|
|
|
|
foreach my $key ( keys %$default_hash ) { |
117
|
|
|
|
|
|
|
$record->{$key} = $default_hash->{$key}; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
$this->push_record($record); |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa($value, 'ARRAY') ) { |
123
|
|
|
|
|
|
|
foreach my $item (@$value) { |
124
|
|
|
|
|
|
|
$this->push_value($item, $default_hash); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
else { |
128
|
|
|
|
|
|
|
my $record = App::RecordStream::Record->new(%$default_hash); |
129
|
|
|
|
|
|
|
$record->{'value'} = $value; |
130
|
|
|
|
|
|
|
$this->push_record($record); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub get_xml_string { |
135
|
|
|
|
|
|
|
my $this = shift; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
my $uris = $this->{'EXTRA_ARGS'}; |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
my $contents; |
140
|
|
|
|
|
|
|
if ( $this->{'HAS_URIS'} ) { |
141
|
|
|
|
|
|
|
return undef unless ( @$uris ); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
my $uri = shift @$uris; |
144
|
|
|
|
|
|
|
$this->update_current_filename($uri); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
my $ua = $this->make_user_agent(); |
147
|
|
|
|
|
|
|
my $response = $ua->request($this->get_request($uri)); |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
if ( ! $response->is_success() ) { |
150
|
|
|
|
|
|
|
warn "GET uri: '$uri' failed, skipping!\n"; |
151
|
|
|
|
|
|
|
return $this->get_xml_string(); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
$contents = $response->content(); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
else { |
157
|
|
|
|
|
|
|
local $/; |
158
|
|
|
|
|
|
|
$contents = ; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
return $contents; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub get_request { |
165
|
|
|
|
|
|
|
my $this = shift; |
166
|
|
|
|
|
|
|
my $uri = shift; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
my $request = HTTP::Request->new(); |
169
|
|
|
|
|
|
|
$request->method('GET'); |
170
|
|
|
|
|
|
|
$request->uri($uri); |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
return $request; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub make_user_agent { |
176
|
|
|
|
|
|
|
return LWP::UserAgent->new(); |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub usage { |
180
|
|
|
|
|
|
|
my $this = shift; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
my $options = [ |
183
|
|
|
|
|
|
|
[ 'element ', 'May be comma separated, may be specified multiple times. Sets the elements/attributes to print records for'], |
184
|
|
|
|
|
|
|
[ 'nested', 'search for elements at all levels of the xml document'], |
185
|
|
|
|
|
|
|
]; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
my $args_string = $this->options_string($options); |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
return <
|
190
|
|
|
|
|
|
|
Usage: recs-fromxml [] |
191
|
|
|
|
|
|
|
__FORMAT_TEXT__ |
192
|
|
|
|
|
|
|
Reads either from STDIN or from the specified URIs. Parses the xml |
193
|
|
|
|
|
|
|
documents, and creates records for the specified elements. |
194
|
|
|
|
|
|
|
If multiple element types are specified, will add a {'element' => element name} field to the output record. |
195
|
|
|
|
|
|
|
__FORMAT_TEXT__ |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
$args_string |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
Examples: |
200
|
|
|
|
|
|
|
Create records for the bar element at the top level of myXMLDoc |
201
|
|
|
|
|
|
|
recs-fromxml --element bar file:myXMLDoc |
202
|
|
|
|
|
|
|
Create records for all foo and bar elements from the URL |
203
|
|
|
|
|
|
|
recs-fromxml --element foo,bar --nested http://google.com |
204
|
|
|
|
|
|
|
USAGE |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
1; |