line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
{ |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
XML::Filter::XML_Directory_Pruner - SAX2 filter for restricting the output of the XML::Directory::SAX |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 SYNOPSIS |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
use XML::SAX::Writer; |
10
|
|
|
|
|
|
|
use XML::Directory::SAX; |
11
|
|
|
|
|
|
|
use XML::Filter::XML_Directory_Pruner; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
my $output = ""; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $writer = XML::SAX::Writer->new(Output=>\$output); |
16
|
|
|
|
|
|
|
my $pruner = XML::Filter::XML_Directory_Pruner->new(Handler=>$writer); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
$pruner->exclude(matching=>["(.*)\\.ph\$"]); |
19
|
|
|
|
|
|
|
$pruner->include(ending=>[".pm"]); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
my $directory = XML::Directory::SAX->new(Handler => $pruner, |
22
|
|
|
|
|
|
|
detail => 2, |
23
|
|
|
|
|
|
|
depth => 1); |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
$directory->parse_dir($INC[0]); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head1 DESCRIPTION |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
XML::Filter::XML_Directory_Pruner is a SAX2 filter for restricting the output of the XML::Directory::SAX handler. |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
=cut |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
package XML::Filter::XML_Directory_Pruner; |
34
|
1
|
|
|
1
|
|
39781
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
35
|
|
|
|
|
|
|
|
36
|
1
|
|
|
1
|
|
6
|
use Exporter; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
34
|
|
37
|
1
|
|
|
1
|
|
5
|
use XML::SAX::Base; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
20
|
|
38
|
1
|
|
|
1
|
|
898
|
use MIME::Types; |
|
1
|
|
|
|
|
5126
|
|
|
1
|
|
|
|
|
2761
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
$XML::Filter::XML_Directory_Pruner::VERSION = '1.3'; |
41
|
|
|
|
|
|
|
@XML::Filter::XML_Directory_Pruner::ISA = qw (Exporter XML::SAX::Base); |
42
|
|
|
|
|
|
|
@XML::Filter::XML_Directory_Pruner::EXPORT = qw (); |
43
|
|
|
|
|
|
|
@XML::Filter::XML_Directory_Pruner::EXPORT_OK = qw (); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my %__typeof = (); |
46
|
|
|
|
|
|
|
my $__mtypes = undef; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
=head1 PACKAGE METHODS |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=head2 __PACKAGE__->mtype($file) |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Return the media type, as defined by the I package, associated with I<$file>. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=cut |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub mtype { |
57
|
0
|
|
|
0
|
1
|
0
|
my $pkg = shift; |
58
|
0
|
|
|
|
|
0
|
my $fname = shift; |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# |
61
|
|
|
|
|
|
|
|
62
|
0
|
|
|
|
|
0
|
$fname =~ /^(.*)\.([^\.]+)$/; |
63
|
0
|
0
|
|
|
|
0
|
if (! $2) { return undef; } |
|
0
|
|
|
|
|
0
|
|
64
|
|
|
|
|
|
|
|
65
|
0
|
0
|
|
|
|
0
|
if (exists($__typeof{$2})) { |
66
|
0
|
|
|
|
|
0
|
return $__typeof{$2}; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
0
|
|
0
|
|
|
0
|
$__mtypes ||= MIME::Types->new() |
|
|
|
0
|
|
|
|
|
70
|
|
|
|
|
|
|
|| return undef; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# |
74
|
|
|
|
|
|
|
|
75
|
0
|
|
|
|
|
0
|
my $mime = $__mtypes->mimeTypeOf($2); |
76
|
|
|
|
|
|
|
|
77
|
0
|
0
|
|
|
|
0
|
if (! $mime) { |
78
|
0
|
|
|
|
|
0
|
$__typeof{$2} = undef; |
79
|
0
|
|
|
|
|
0
|
return $__typeof{$2}; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# |
83
|
|
|
|
|
|
|
|
84
|
0
|
|
|
|
|
0
|
$__typeof{$2} = $mime->mediaType(); |
85
|
0
|
|
|
|
|
0
|
return $__typeof{$2}; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=head1 OBJECT METHODS |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head2 $pkg = __PACKAGE__->new() |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Inherits from I |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 $pkg->include(%args) |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Include *only* that files that match either the starting or ending pattern. |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
Valid arguments are |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=over |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=item * |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
B |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
Array ref. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=item * |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
B |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
Array ref. One or more regular expressions. |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
I |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
In earlier releases, only a string was expected. Newer releases are backward compatible. |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=item * |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
B |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Array ref. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item * |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
B |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
Array ref. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=back |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=cut |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub include { |
135
|
1
|
|
|
1
|
1
|
13
|
my $self = shift; |
136
|
1
|
|
|
|
|
7
|
my $args = { @_ }; |
137
|
|
|
|
|
|
|
|
138
|
1
|
50
|
|
|
|
9
|
if (ref($args->{'include'}) eq "ARRAY") { |
139
|
0
|
|
|
|
|
0
|
push (@{$self->{__PACKAGE__.'__include'}},@{$args->{'include'}}); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
1
|
50
|
|
|
|
9
|
if ($args->{'matching'}) { |
143
|
0
|
0
|
|
|
|
0
|
$self->{__PACKAGE__.'__include_matching'} = (ref($args->{'matching'} eq "ARRAY")) ? |
144
|
|
|
|
|
|
|
$args->{'matching'} : [$args->{'matching'}]; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
1
|
50
|
|
|
|
9
|
if (ref($args->{'starting'}) eq "ARRAY") { |
148
|
0
|
|
|
|
|
0
|
push (@{$self->{__PACKAGE__.'__include_starting'}},@{$args->{'starting'}}); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
1
|
50
|
|
|
|
24
|
if (ref($args->{'ending'}) eq "ARRAY") { |
152
|
1
|
|
|
|
|
4
|
push (@{$self->{__PACKAGE__.'__include_ending'}},@{$args->{'ending'}}); |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
10
|
|
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
1
|
50
|
|
|
|
8
|
if ($args->{'directories'}) { |
156
|
0
|
|
|
|
|
0
|
$self->{__PACKAGE__.'__include_subdirs'} = 1; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
1
|
|
|
|
|
4
|
return 1; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=head2 $pkg->exclude(%args) |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Exclude files with a particular name or pattern from being included in the directory listing. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
Valid arguments are |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=over |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=item * |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
B |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
Array ref. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=item * |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
B |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
Array ref. One or more regular expressions. |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
I |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
In earlier releases, only a string was expected. Newer releases are backward compatible. |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=item * |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
B |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
Array ref. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=item * |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
B |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
Array ref. |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=item * |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
B |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
Boolean. Default is false. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
B |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
Boolean. Default is false. |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
=back |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=cut |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub exclude { |
213
|
1
|
|
|
1
|
1
|
7190
|
my $self = shift; |
214
|
1
|
|
|
|
|
13
|
my $args = { @_ }; |
215
|
|
|
|
|
|
|
|
216
|
1
|
50
|
|
|
|
11
|
if (ref($args->{'exclude'}) eq "ARRAY") { |
217
|
0
|
|
|
|
|
0
|
push (@{$self->{__PACKAGE__.'__exclude'}},@{$args->{'exclude'}}); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
1
|
50
|
|
|
|
14
|
if ($args->{'matching'}) { |
221
|
1
|
50
|
|
|
|
16
|
$self->{__PACKAGE__.'__exclude_matching'} = (ref($args->{'matching'}) eq "ARRAY") ? |
222
|
|
|
|
|
|
|
$args->{'matching'} : [ $args->{'matching'}]; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
1
|
50
|
|
|
|
16
|
if (ref($args->{'starting'}) eq "ARRAY") { |
226
|
0
|
|
|
|
|
0
|
push (@{$self->{__PACKAGE__.'__exclude_starting'}},@{$args->{'starting'}}); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
1
|
50
|
|
|
|
10
|
if (ref($args->{'ending'}) eq "ARRAY") { |
230
|
0
|
|
|
|
|
0
|
push (@{$self->{__PACKAGE__.'__exclude_ending'}},@{$args->{'ending'}}); |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
1
|
|
|
|
|
7
|
$self->{__PACKAGE__.'__exclude_subdirs'} = $args->{'directories'}; |
234
|
1
|
|
|
|
|
10
|
$self->{__PACKAGE__.'__exclude_files'} = $args->{'files'}; |
235
|
1
|
|
|
|
|
9
|
return 1; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head2 $pkg->ima($what) |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
=cut |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub ima { |
243
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
244
|
0
|
|
|
|
|
0
|
my $what = shift; |
245
|
|
|
|
|
|
|
|
246
|
0
|
0
|
|
|
|
0
|
if ($what) { |
247
|
0
|
|
|
|
|
0
|
$self->{__PACKAGE__.'__ima'} = $what; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
0
|
|
|
|
|
0
|
return $self->{__PACKAGE__.'__ima'}; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
=head2 $pkg->current_level() |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
Read-only. |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=cut |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
sub current_level { |
260
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
261
|
0
|
|
|
|
|
0
|
return $self->{__PACKAGE__.'__level'}; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
=head2 $pkg->skip_level() |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
=cut |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
sub skip_level { |
269
|
0
|
|
|
0
|
1
|
0
|
return $_[0]->{__PACKAGE__.'__skip'}; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
=head2 $pkg->debug($int) |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
Read/write debugging flags. |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
By default, the package watches and performs actions if the debug level is greater than or equal to : |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
=over |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
=item * |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
I<1> |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
Nothing. |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
=item * |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
I<2> |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
Prints to STDERR the type, name and level of the current element. |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=item * |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
I<3> |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Prints to STDERR the results of checks in $pkg->_compare() |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=back |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=cut |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
sub debug { |
303
|
21
|
|
|
21
|
1
|
25
|
my $self = shift; |
304
|
21
|
|
|
|
|
26
|
my $debug = shift; |
305
|
|
|
|
|
|
|
|
306
|
21
|
50
|
|
|
|
50
|
if (defined($debug)) { |
307
|
0
|
0
|
|
|
|
0
|
$self->{__PACKAGE__.'__debug'} = ($debug) ? (int($debug)) ? $debug : 1 : 0; |
|
|
0
|
|
|
|
|
|
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
21
|
|
|
|
|
73
|
return $self->{__PACKAGE__.'__debug'}; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head1 PRIVATE METHODS |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=head2 $pkg->start_element($data) |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=cut |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub start_element { |
320
|
19
|
|
|
19
|
1
|
49287
|
my $self = shift; |
321
|
19
|
|
|
|
|
30
|
my $data = shift; |
322
|
|
|
|
|
|
|
|
323
|
19
|
|
|
|
|
65
|
$self->on_enter_start_element($data); |
324
|
19
|
|
|
|
|
1145
|
$self->compare($data); |
325
|
|
|
|
|
|
|
|
326
|
19
|
100
|
|
|
|
48
|
unless ($self->{__PACKAGE__.'__skip'}) { |
327
|
9
|
|
|
|
|
15
|
$self->{__PACKAGE__.'__last'} = $data->{'Name'}; |
328
|
9
|
|
|
|
|
56
|
$self->SUPER::start_element($data); |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
|
331
|
19
|
|
|
|
|
297
|
return 1; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
sub on_enter_start_element { |
335
|
19
|
|
|
19
|
0
|
23
|
my $self = shift; |
336
|
19
|
|
|
|
|
23
|
my $data = shift; |
337
|
|
|
|
|
|
|
|
338
|
19
|
|
|
|
|
35
|
$self->{__PACKAGE__.'__level'} ++; |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# if ($data->{Name} =~ /^(directory|file)$/) { |
341
|
|
|
|
|
|
|
# $self->{__PACKAGE__.'__'.$1} ++; |
342
|
|
|
|
|
|
|
# map { print " "; } (0..$self->{__PACKAGE__.'__'.$1}); |
343
|
|
|
|
|
|
|
# print $self->{__PACKAGE__.'__'.$1} ." [$1] $data->{Attributes}->{'{}name'}->{Value} ".__PACKAGE__."\n"; |
344
|
|
|
|
|
|
|
# } |
345
|
|
|
|
|
|
|
|
346
|
19
|
50
|
|
|
|
38
|
if ($self->debug() >= 2) { |
347
|
0
|
|
|
|
|
0
|
map { print STDERR " "; } (0..$self->current_level); |
|
0
|
|
|
|
|
0
|
|
348
|
0
|
|
|
|
|
0
|
print STDERR "[".$self->current_level."] $data->{Name} : "; |
349
|
|
|
|
|
|
|
# Because sometimes auto-vivification |
350
|
|
|
|
|
|
|
# is not what you want. |
351
|
0
|
0
|
|
|
|
0
|
if (exists($data->{Attributes}->{'{}name'})) { |
352
|
0
|
|
|
|
|
0
|
print STDERR $data->{Attributes}->{'{}name'}->{Value}; |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
0
|
|
|
|
|
0
|
print STDERR "\n"; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
19
|
|
|
|
|
30
|
return 1; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
=head2 $pkg->end_element($data) |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=cut |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub end_element { |
366
|
19
|
|
|
19
|
1
|
525
|
my $self = shift; |
367
|
19
|
|
|
|
|
22
|
my $data = shift; |
368
|
|
|
|
|
|
|
|
369
|
19
|
100
|
|
|
|
52
|
unless ($self->{__PACKAGE__.'__skip'}) { |
370
|
9
|
|
|
|
|
79
|
$self->SUPER::end_element($data); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
19
|
|
|
|
|
148
|
$self->on_exit_end_element($data); |
374
|
19
|
|
|
|
|
768
|
return 1; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=head2 $pkg->_on_exit_end_element() |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
=cut |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
sub on_exit_end_element { |
382
|
19
|
|
|
19
|
0
|
21
|
my $self = shift; |
383
|
19
|
|
|
|
|
22
|
my $data = shift; |
384
|
|
|
|
|
|
|
|
385
|
19
|
100
|
|
|
|
48
|
if ($self->{__PACKAGE__.'__skip'} == $self->{__PACKAGE__.'__level'}) { |
386
|
2
|
|
|
|
|
4
|
$self->{__PACKAGE__.'__skip'} = 0; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
19
|
100
|
|
|
|
62
|
if ($data->{Name} =~ /^(directory|file)$/) { |
390
|
4
|
|
|
|
|
14
|
$self->{__PACKAGE__.'__'.$1} --; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
19
|
|
|
|
|
29
|
$self->{__PACKAGE__.'__level'} --; |
394
|
19
|
|
|
|
|
26
|
return 1; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=head2 $pkg->characters($data) |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=cut |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub characters { |
402
|
10
|
|
|
10
|
1
|
166
|
my $self = shift; |
403
|
10
|
|
|
|
|
10
|
my $data = shift; |
404
|
|
|
|
|
|
|
|
405
|
10
|
100
|
|
|
|
26
|
unless ($self->{__PACKAGE__.'__skip'}) { |
406
|
4
|
|
|
|
|
26
|
$self->SUPER::characters($data); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
10
|
|
|
|
|
161
|
return 1; |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=head2 $pkg->compare(\%data) |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=cut |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
sub compare { |
417
|
19
|
|
|
19
|
1
|
26
|
my $self = shift; |
418
|
19
|
|
|
|
|
18
|
my $data = shift; |
419
|
|
|
|
|
|
|
|
420
|
19
|
100
|
|
|
|
113
|
if ($data->{'Name'} =~ /^(file|directory)$/) { |
421
|
|
|
|
|
|
|
# map { print " "; } (0..$self->{__PACKAGE__.'__'.$1}); |
422
|
|
|
|
|
|
|
# print $self->{__PACKAGE__.'__'.$1} ." <$1> $data->{Attributes}->{'{}name'}->{Value} ($self->{__PACKAGE__.'__skip'})\n"; |
423
|
|
|
|
|
|
|
|
424
|
4
|
100
|
|
|
|
13
|
if (! $self->{__PACKAGE__.'__skip'}) { |
425
|
3
|
|
|
|
|
19
|
$self->{__PACKAGE__.'__ima'} = $1; |
426
|
3
|
|
|
|
|
14
|
$self->_compare($data->{Attributes}->{'{}name'}->{Value}); |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
19
|
|
|
|
|
27
|
return 1; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
=head2 $pkg->_compare($data) |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
=cut |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
sub _compare { |
438
|
3
|
|
|
3
|
|
4
|
my $self = shift; |
439
|
3
|
|
|
|
|
5
|
my $data = shift; |
440
|
|
|
|
|
|
|
|
441
|
3
|
|
|
|
|
4
|
my $ok = 1; |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
# Note the check on __level. We have to do |
444
|
|
|
|
|
|
|
# this, so that filtering the output for |
445
|
|
|
|
|
|
|
# /foo/bar won't fail with : |
446
|
|
|
|
|
|
|
# |
447
|
|
|
|
|
|
|
# 101 ->./dir-machine |
448
|
|
|
|
|
|
|
# 1 dirtree |
449
|
|
|
|
|
|
|
# 2 head |
450
|
|
|
|
|
|
|
# 3 path |
451
|
|
|
|
|
|
|
# 3 details |
452
|
|
|
|
|
|
|
# 3 depth |
453
|
|
|
|
|
|
|
# Comparing 'bar' (directory)...failed directory test...'0' (2) |
454
|
|
|
|
|
|
|
|
455
|
3
|
100
|
|
|
|
22
|
if ($self->{__PACKAGE__.'__level'} == 2) { return 1; } |
|
1
|
|
|
|
|
10
|
|
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# |
458
|
|
|
|
|
|
|
|
459
|
2
|
100
|
|
|
|
8
|
if ($self->{__PACKAGE__.'__ima'} eq "directory") { |
460
|
1
|
50
|
33
|
|
|
36
|
if (($ok) && ($self->{__PACKAGE__.'__exclude_subdirs'})) { |
461
|
0
|
0
|
|
|
|
0
|
print STDERR "10 - EXCLUDING $data BECAUSE I AM A DIRECTORY\n" |
462
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
463
|
0
|
|
|
|
|
0
|
$ok = 0; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
2
|
50
|
66
|
|
|
29
|
if (($ok) && ($self->{__PACKAGE__.'__ima'} eq "file" && $self->{__PACKAGE__.'__exclude_files'})) { |
|
|
|
33
|
|
|
|
|
468
|
0
|
0
|
|
|
|
0
|
print STDERR "20 - EXCLUDING $data BECAUSE I AM A FILE\n" |
469
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
470
|
0
|
|
|
|
|
0
|
$ok = 0; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# |
474
|
|
|
|
|
|
|
|
475
|
2
|
50
|
33
|
|
|
16
|
if (($ok) && ($self->{__PACKAGE__.'__include_matching'} eq "ARRAY")) { |
476
|
0
|
|
|
|
|
0
|
foreach my $pattern (@{$self->{__PACKAGE__.'__include_matching'}}) { |
|
0
|
|
|
|
|
0
|
|
477
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /$pattern/) ? 1 : 0; |
478
|
|
|
|
|
|
|
|
479
|
0
|
0
|
|
|
|
0
|
if ($ok) { |
480
|
0
|
0
|
|
|
|
0
|
print STDERR "20 - INCLUDING $data BECAUSE IT MATCHES PATTERN '$pattern'\n" |
481
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
482
|
0
|
|
|
|
|
0
|
last; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
2
|
50
|
33
|
|
|
16
|
if (($ok) && (ref($self->{__PACKAGE__.'__include'}) eq "ARRAY")) { |
488
|
0
|
|
|
|
|
0
|
foreach my $match (@{$self->{__PACKAGE__.'__include'}}) { |
|
0
|
|
|
|
|
0
|
|
489
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /^($match)$/) ? 0 : 1; |
490
|
|
|
|
|
|
|
|
491
|
0
|
0
|
|
|
|
0
|
if ($ok) { |
492
|
0
|
0
|
|
|
|
0
|
print STDERR "30 - INCLUDING $data BECAUSE IT MATCHES '$match'\n" |
493
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
494
|
0
|
|
|
|
|
0
|
last; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
|
499
|
2
|
50
|
33
|
|
|
14
|
if (($ok) && (ref($self->{__PACKAGE__.'__include_starting'}) eq "ARRAY")) { |
500
|
0
|
|
|
|
|
0
|
foreach my $match (@{$self->{__PACKAGE__.'__include_starting'}}) { |
|
0
|
|
|
|
|
0
|
|
501
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /^($match)(.*)$/) ? 1 : 0; |
502
|
|
|
|
|
|
|
|
503
|
0
|
0
|
|
|
|
0
|
if ($ok) { |
504
|
0
|
0
|
|
|
|
0
|
print STDERR "40 - INCLUDING $data BECAUSE IT STARTS WITH '$match'\n" |
505
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
506
|
0
|
|
|
|
|
0
|
last; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
2
|
50
|
33
|
|
|
32
|
if (($ok) && (ref($self->{__PACKAGE__.'__include_ending'}) eq "ARRAY")) { |
512
|
2
|
|
|
|
|
3
|
foreach my $match (@{$self->{__PACKAGE__.'__include_ending'}}) { |
|
2
|
|
|
|
|
7
|
|
513
|
2
|
50
|
|
|
|
69
|
$ok = ($data =~ /^(.*)($match)$/) ? 1 : 0; |
514
|
|
|
|
|
|
|
|
515
|
2
|
50
|
|
|
|
16
|
if ($ok) { |
516
|
0
|
0
|
|
|
|
0
|
print STDERR "50 - INCLUDING $data BECAUSE IT ENDS WITH '$match'\n" |
517
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
518
|
0
|
|
|
|
|
0
|
last; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# |
524
|
|
|
|
|
|
|
|
525
|
2
|
50
|
33
|
|
|
7
|
if (($ok) &&(ref($self->{__PACKAGE__.'__exclude_matching'}) eq "ARRAY")) { |
526
|
|
|
|
|
|
|
|
527
|
0
|
|
|
|
|
0
|
foreach my $pattern (@{$self->{__PACKAGE__.'__exclude_matching'}}) { |
|
0
|
|
|
|
|
0
|
|
528
|
|
|
|
|
|
|
|
529
|
0
|
0
|
|
|
|
0
|
print STDERR "25 - COMPARING '$data' w/ '$pattern'\n" |
530
|
|
|
|
|
|
|
if ($self->debug() >= 4); |
531
|
|
|
|
|
|
|
|
532
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /$pattern/) ? 0 : 1; |
533
|
|
|
|
|
|
|
|
534
|
0
|
0
|
|
|
|
0
|
if (! $ok) { |
535
|
0
|
0
|
|
|
|
0
|
print STDERR "30 - EXCLUDING $data BECAUSE IT MATCHES PATTERN '$pattern'\n" |
536
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
537
|
|
|
|
|
|
|
|
538
|
0
|
|
|
|
|
0
|
last; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
|
543
|
2
|
50
|
33
|
|
|
7
|
if (($ok) && (ref($self->{__PACKAGE__.'__exclude'}) eq "ARRAY")) { |
544
|
0
|
|
|
|
|
0
|
foreach my $match (@{$self->{__PACKAGE__.'__exclude'}}) { |
|
0
|
|
|
|
|
0
|
|
545
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /^($match)$/) ? 0 : 1; |
546
|
|
|
|
|
|
|
|
547
|
0
|
0
|
|
|
|
0
|
if (! $ok) { |
548
|
0
|
0
|
|
|
|
0
|
print STDERR "40 - EXCLUDING $data BECAUSE IT MATCHES '$match'\n" |
549
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
550
|
0
|
|
|
|
|
0
|
last; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
2
|
50
|
33
|
|
|
5
|
if (($ok) && (ref($self->{__PACKAGE__.'__exclude_starting'}) eq "ARRAY")) { |
556
|
0
|
|
|
|
|
0
|
foreach my $match (@{$self->{__PACKAGE__.'__exclude_starting'}}) { |
|
0
|
|
|
|
|
0
|
|
557
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /^($match)(.*)$/) ? 0 : 1; |
558
|
|
|
|
|
|
|
|
559
|
0
|
0
|
|
|
|
0
|
if (! $ok) { |
560
|
0
|
0
|
|
|
|
0
|
print STDERR "50 - EXCLUDING $data BECAUSE IT STARTS WITH '$match'\n" |
561
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
562
|
0
|
|
|
|
|
0
|
last; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
2
|
50
|
33
|
|
|
7
|
if (($ok) && (ref($self->{__PACKAGE__.'__exclude_ending'}) eq "ARRAY")) { |
568
|
0
|
|
|
|
|
0
|
foreach my $match (@{$self->{__PACKAGE__.'__exclude_ending'}}) { |
|
0
|
|
|
|
|
0
|
|
569
|
0
|
0
|
|
|
|
0
|
$ok = ($data =~ /^(.*)($match)$/) ? 0 : 1; |
570
|
|
|
|
|
|
|
|
571
|
0
|
0
|
|
|
|
0
|
if (! $ok) { |
572
|
0
|
0
|
|
|
|
0
|
print STDERR "60 - EXCLUDING $data BECAUSE IT ENDS WITH '$match'\n" |
573
|
|
|
|
|
|
|
if ($self->debug() >= 3); |
574
|
0
|
|
|
|
|
0
|
last; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
# |
580
|
|
|
|
|
|
|
|
581
|
2
|
50
|
|
|
|
5
|
if (! $ok) { |
582
|
2
|
50
|
|
|
|
5
|
print STDERR "SKIPPING '$data' at $self->{__PACKAGE__.'__level'}\n" |
583
|
|
|
|
|
|
|
if ($self->debug() >= 2); |
584
|
|
|
|
|
|
|
|
585
|
2
|
|
|
|
|
8
|
$self->{__PACKAGE__.'__skip'} = $self->{__PACKAGE__.'__level'}; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
2
|
|
|
|
|
3
|
return 1; |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=head1 VERSION |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
1.3 |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=head1 DATE |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
July 20, 2002 |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=head1 AUTHOR |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
Aaron Straup Cope |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=head1 TO DO |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=over |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
=item * |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
Allow for inclusion/exclusion based on MIME and/or media type |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=back |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
=head1 SEE ALSO |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
L |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
L |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
L |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=head1 LICENSE |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
Copyright (c) 2002, Aaron Straup Cope. All Rights Reserved. |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
This is free software, you may use it and distribute it under the same terms as Perl itself. |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
=cut |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
return 1; |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
} |