line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package XML::Parser::GlobEvents; |
2
|
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
|
199017
|
use 5.006; |
|
6
|
|
|
|
|
24
|
|
|
6
|
|
|
|
|
228
|
|
4
|
6
|
|
|
6
|
|
33
|
use strict; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
197
|
|
5
|
6
|
|
|
6
|
|
130
|
use warnings; |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
675
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
require Exporter; |
8
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
9
|
|
|
|
|
|
|
our @EXPORT_OK = qw(parse parse_xml); |
10
|
|
|
|
|
|
|
our $VERSION = '0.400'; |
11
|
|
|
|
|
|
|
|
12
|
6
|
|
|
6
|
|
10799
|
use XML::Parser::Expat; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
use Carp; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub parse { |
16
|
|
|
|
|
|
|
my $file = shift; |
17
|
|
|
|
|
|
|
my(%handler, @handler); |
18
|
|
|
|
|
|
|
while(@_) { |
19
|
|
|
|
|
|
|
if(ref $_[1] eq 'CODE') { |
20
|
|
|
|
|
|
|
my($pattern, $code) = splice @_, 0, 2; |
21
|
|
|
|
|
|
|
unshift @_, $pattern => { End => $code }; |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
my($pattern, $hash) = splice @_, 0, 2; |
24
|
|
|
|
|
|
|
if(ref $hash ne 'HASH') { |
25
|
|
|
|
|
|
|
require Carp; |
26
|
|
|
|
|
|
|
Carp::croak("Invalid parameter for $pattern: '$hash', expected hashref"); |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
foreach my $key (qw(Start End)) { |
29
|
|
|
|
|
|
|
if(my $code = $hash->{$key}) { |
30
|
|
|
|
|
|
|
unless(ref $code eq 'CODE') { |
31
|
|
|
|
|
|
|
require Carp; |
32
|
|
|
|
|
|
|
Carp::croak("Invalid $key handler for $pattern"); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
my %order; |
37
|
|
|
|
|
|
|
for($pattern) { |
38
|
|
|
|
|
|
|
s{///+}{//}g; |
39
|
|
|
|
|
|
|
s{^//}{}; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
my $regex = $pattern; |
42
|
|
|
|
|
|
|
for($regex) { |
43
|
|
|
|
|
|
|
$order{depth} = () = m{[^/]+}g; |
44
|
|
|
|
|
|
|
s/([.])/\\$1/g; |
45
|
|
|
|
|
|
|
$order{star} = s{\*}{[^/]+}g; |
46
|
|
|
|
|
|
|
$order{desc} = s{//}{(?=/).*/}g; |
47
|
|
|
|
|
|
|
s{\Q(?=/).*/[^/]+}{/.+}g; |
48
|
|
|
|
|
|
|
$order{abs} = s{^/}{^/} or s{^}{(?:/|^)}, $order{desc}++; |
49
|
|
|
|
|
|
|
s/$/\$/; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
$hash->{pattern} = $pattern; |
52
|
|
|
|
|
|
|
$hash->{regex} = qr/$regex/; |
53
|
|
|
|
|
|
|
$hash->{order} = \%order; |
54
|
|
|
|
|
|
|
@{$handler{$pattern}}{keys %$hash} = values %$hash; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
@handler = sort { $b->{order}{depth} <=> $a->{order}{depth} || |
57
|
|
|
|
|
|
|
$a->{order}{star} <=> $b->{order}{star} || |
58
|
|
|
|
|
|
|
$a->{order}{desc} <=> $b->{order}{desc} |
59
|
|
|
|
|
|
|
} values %handler; |
60
|
|
|
|
|
|
|
# use Data::Dumper; print Dumper \@handler; |
61
|
|
|
|
|
|
|
use IO::File; |
62
|
|
|
|
|
|
|
my $fh = ref $file eq 'SCALAR' ? $$file : |
63
|
|
|
|
|
|
|
ref $file ? $file : IO::File->new($file, 'r') |
64
|
|
|
|
|
|
|
or croak "Cannot read file '$file': $!"; |
65
|
|
|
|
|
|
|
my $parser = XML::Parser::Expat->new; |
66
|
|
|
|
|
|
|
my @stack; |
67
|
|
|
|
|
|
|
my $node = {}; |
68
|
|
|
|
|
|
|
my $current = { -path => '/', -name => '', -node => $node }; |
69
|
|
|
|
|
|
|
$parser->setHandlers( |
70
|
|
|
|
|
|
|
Start => sub { |
71
|
|
|
|
|
|
|
my($self, $name, %attr) = @_; |
72
|
|
|
|
|
|
|
push @stack, my $parent = $current; |
73
|
|
|
|
|
|
|
(my $path = join '/', $parent->{-path}, $name ) =~ s(^//)(/); |
74
|
|
|
|
|
|
|
# print STDERR "Entering $path\n"; |
75
|
|
|
|
|
|
|
my $parentnode = $node; |
76
|
|
|
|
|
|
|
$node = { -path => $path, -name => $name, -attr => \%attr }; |
77
|
|
|
|
|
|
|
$node->{-position} = ++$parent->{-childcount}{$name}; |
78
|
|
|
|
|
|
|
$current = { -path => $path, -name => $name, -node => $node }; |
79
|
|
|
|
|
|
|
if($parent->{-store}) { |
80
|
|
|
|
|
|
|
$current->{-store} = 1; |
81
|
|
|
|
|
|
|
push @{$parentnode->{-contents}}, $node; |
82
|
|
|
|
|
|
|
push @{$parentnode->{"$name\[]"}}, $node; |
83
|
|
|
|
|
|
|
$parentnode->{$name} = $node; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
my $store; |
86
|
|
|
|
|
|
|
foreach (grep { $path =~ $_->{regex} } @handler) { |
87
|
|
|
|
|
|
|
# print STDERR "Match handler rule $_->{pattern}\n"; |
88
|
|
|
|
|
|
|
if($_->{Start}) { |
89
|
|
|
|
|
|
|
# print STDERR "Firing Start rule $_->{pattern}\n"; |
90
|
|
|
|
|
|
|
$_->{Start}->($node, \@stack); |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
if(defined $_->{Store}) { |
93
|
|
|
|
|
|
|
$store = $_->{Store} unless defined $store; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
if($_->{End}) { |
96
|
|
|
|
|
|
|
push @{$current->{End}}, $_; |
97
|
|
|
|
|
|
|
$current->{-node} = $node; |
98
|
|
|
|
|
|
|
$store = 1 unless defined $store; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
if(defined $_->{Whitespace}) { |
101
|
|
|
|
|
|
|
$current->{Whitespace} = $_->{Whitespace}; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
$current->{-store} = $store if defined $store; |
105
|
|
|
|
|
|
|
$node->{-text} = '' if $current->{-store}; |
106
|
|
|
|
|
|
|
}, |
107
|
|
|
|
|
|
|
End => sub { |
108
|
|
|
|
|
|
|
my($self, $name) = @_; |
109
|
|
|
|
|
|
|
my $path = $current->{-path}; |
110
|
|
|
|
|
|
|
# print STDERR "Exiting $path\n"; |
111
|
|
|
|
|
|
|
if($current->{-store}) { |
112
|
|
|
|
|
|
|
my $ws = $current->{Whitespace}; |
113
|
|
|
|
|
|
|
$ws = 'normalize' unless defined $ws; |
114
|
|
|
|
|
|
|
if($ws =~ /normalize|trim/i) { |
115
|
|
|
|
|
|
|
for($node->{-text}) { |
116
|
|
|
|
|
|
|
s/^\s+//; |
117
|
|
|
|
|
|
|
s/\s+$//; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
if($ws =~ /normalize|collapse/i) { |
121
|
|
|
|
|
|
|
for($node->{-text}) { |
122
|
|
|
|
|
|
|
tr/ \t\n\r\f/ /s; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
$node->{-contents} ||= []; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
if($current->{End}) { |
128
|
|
|
|
|
|
|
foreach (@{$current->{End}}) { |
129
|
|
|
|
|
|
|
# print STDERR "Firing End rule $_->{pattern}\n"; |
130
|
|
|
|
|
|
|
$_->{End}->($node, \@stack); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
$current = pop @stack; |
134
|
|
|
|
|
|
|
$node = $current->{-node}; |
135
|
|
|
|
|
|
|
}, |
136
|
|
|
|
|
|
|
Char => sub { |
137
|
|
|
|
|
|
|
my($self, $text) = @_; |
138
|
|
|
|
|
|
|
if($current->{-store}) { |
139
|
|
|
|
|
|
|
$node->{-text} .= $text; |
140
|
|
|
|
|
|
|
if(!$node->{-contents} or ref $node->{-contents}[-1]) { |
141
|
|
|
|
|
|
|
push @{$node->{-contents}}, $text; |
142
|
|
|
|
|
|
|
} else { |
143
|
|
|
|
|
|
|
$node->{-contents}[-1] .= $text; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
}, |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
my $error; |
149
|
|
|
|
|
|
|
eval { |
150
|
|
|
|
|
|
|
$parser->parse($fh); |
151
|
|
|
|
|
|
|
1; |
152
|
|
|
|
|
|
|
} or $error = $@; |
153
|
|
|
|
|
|
|
$parser->release; |
154
|
|
|
|
|
|
|
close($fh); |
155
|
|
|
|
|
|
|
die $error if $error; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
*parse_xml = \&parse; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
1; |