line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Pod::Simple::Select;
|
2
|
1
|
|
|
1
|
|
14636
|
use strict;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
25
|
|
3
|
1
|
|
|
1
|
|
4
|
use warnings;
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
38
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Pod::Simple::Select - Select parts in a file using pod directives
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 VERSION
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
Version 0.002
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=cut
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERSION = '0.002';
|
16
|
|
|
|
|
|
|
|
17
|
1
|
|
|
1
|
|
5
|
use base qw(Pod::Simple);
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
705
|
|
18
|
1
|
|
|
1
|
|
27293
|
use Fcntl 'O_RDONLY';
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
74
|
|
19
|
1
|
|
|
1
|
|
994
|
use Tie::File;
|
|
1
|
|
|
|
|
18324
|
|
|
1
|
|
|
|
|
34
|
|
20
|
|
|
|
|
|
|
|
21
|
1
|
|
|
1
|
|
9
|
use Carp qw/confess/;
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
43
|
|
22
|
1
|
|
|
1
|
|
536
|
use Log::Any;
|
|
1
|
|
|
|
|
6098
|
|
|
1
|
|
|
|
|
5
|
|
23
|
1
|
|
|
1
|
|
570
|
use Data::Dumper;
|
|
1
|
|
|
|
|
5104
|
|
|
1
|
|
|
|
|
281
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my $end_line;
|
26
|
|
|
|
|
|
|
my $key;
|
27
|
|
|
|
|
|
|
my $h_value;
|
28
|
|
|
|
|
|
|
#my $token_match;
|
29
|
|
|
|
|
|
|
my $token;
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
#my $last_end;
|
32
|
|
|
|
|
|
|
=for comment
|
33
|
|
|
|
|
|
|
my $conf = q(
|
34
|
|
|
|
|
|
|
log4perl.rootLogger=ERROR, LOGFILE1, Screen
|
35
|
|
|
|
|
|
|
#log4perl.rootLogger=DEBUG, LOGFILE1, Screen
|
36
|
|
|
|
|
|
|
#log4perl.logger.Pod.Simple.Select=DEBUG, LOGFILE1, Screen
|
37
|
|
|
|
|
|
|
#log4perl.logger.Pod.Simple.Select.Token=DEBUG, LOGFILE1, Screen
|
38
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1=Log::Log4perl::Appender::File
|
39
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1.filename=./debug.log
|
40
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1.mode=clobber
|
41
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1.layout=PatternLayout
|
42
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1.Threshold=DEBUG
|
43
|
|
|
|
|
|
|
log4perl.appender.LOGFILE1.layout.ConversionPattern= %c{1}-%M{1} %m%n
|
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
log4perl.appender.Screen=Log::Dispatch::Screen
|
46
|
|
|
|
|
|
|
log4perl.appender.Screen.stderr=0
|
47
|
|
|
|
|
|
|
log4perl.appender.Screen.Threshold=DEBUG
|
48
|
|
|
|
|
|
|
log4perl.appender.Screen.mode=append
|
49
|
|
|
|
|
|
|
log4perl.appender.Screen.layout=Log::Log4perl::Layout::PatternLayout
|
50
|
|
|
|
|
|
|
log4perl.appender.Screen.layout.ConversionPattern=%c{1}-%M{1} %m%n
|
51
|
|
|
|
|
|
|
);
|
52
|
|
|
|
|
|
|
Log::Log4perl->init( \$conf );
|
53
|
|
|
|
|
|
|
=cut
|
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head1 SYNOPSIS
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
use Pod::Simple::Select;
|
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
my $p = Pod::Simple::Select->new;
|
60
|
|
|
|
|
|
|
$p->output_file("out");
|
61
|
|
|
|
|
|
|
$p->select(["head1" =>["Top1"=>["head2"=>["Top12"]]], "head2" =>["Function doit"], "head3"=>["Top3"]]);
|
62
|
|
|
|
|
|
|
$p->parse_file(ex.pod);
|
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
Given that the ex.pod file is
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=head1 NotFound
|
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
Bla
|
69
|
|
|
|
|
|
|
Bla
|
70
|
|
|
|
|
|
|
Bla
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=head1 NotFound
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Bla
|
75
|
|
|
|
|
|
|
Bla
|
76
|
|
|
|
|
|
|
Bla
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=head1 Top1
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Bla under top1
|
81
|
|
|
|
|
|
|
Bla2 under top1
|
82
|
|
|
|
|
|
|
Bla3 under top1
|
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
=head2 Top12
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
Bla under top12
|
87
|
|
|
|
|
|
|
Bla2 under top12
|
88
|
|
|
|
|
|
|
Bla3 under top12
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=cut
|
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
code
|
93
|
|
|
|
|
|
|
code
|
94
|
|
|
|
|
|
|
code
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=head2 Function C
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
Bla under Function Doit
|
99
|
|
|
|
|
|
|
Bla2 under Function Doit
|
100
|
|
|
|
|
|
|
Bla3 under Function Doit
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=head2 Top12
|
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Bla under top12_2
|
105
|
|
|
|
|
|
|
Bla2 under top12_2
|
106
|
|
|
|
|
|
|
Bla3 under top12_2
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=head1 NotFound
|
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
Bla
|
111
|
|
|
|
|
|
|
Bla
|
112
|
|
|
|
|
|
|
Bla
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head3 Top3
|
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
Bla under top3
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=head1 NotFound
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
Bla
|
121
|
|
|
|
|
|
|
Bla
|
122
|
|
|
|
|
|
|
Bla
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
The out file will be
|
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
=head2 Top12
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
Bla under top12
|
129
|
|
|
|
|
|
|
Bla2 under top12
|
130
|
|
|
|
|
|
|
Bla3 under top12
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=head2 Function C
|
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Bla under Function Doit
|
135
|
|
|
|
|
|
|
Bla2 under Function Doit
|
136
|
|
|
|
|
|
|
Bla3 under Function Doit
|
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=head3 Top3
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Bla under top3
|
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=head1 DESCRIPTION
|
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
This module will extract specified sections of
|
146
|
|
|
|
|
|
|
pod documentation from a file. This ability is provided by the
|
147
|
|
|
|
|
|
|
B |
148
|
|
|
|
|
|
|
POD sections to select for processing/printing.
|
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
=head1 SECTION SPECIFICATIONS
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
The argument to C |
153
|
|
|
|
|
|
|
An array reference containing array refereces will restrict the text processed to only the
|
154
|
|
|
|
|
|
|
desired set of sections, or subsections following a section.
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
Pod directive is head1, head2 and so on.
|
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
The formal syntax of a section specification is:
|
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=over 4
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=item * Ordered parsing
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
["Pod directive" =>["Text following the directive"=>["Pod directive 2"=>["Text2"]], "Text3], "Pod directive 3" => [Text4], ...]
|
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
A list of token will be made using these array references and that list will be used for the parsing.
|
167
|
|
|
|
|
|
|
A key (:text after a pod directive) not found in the file will stop the parser from searching further down.
|
168
|
|
|
|
|
|
|
If an array references are enclosed within each other, the parsing will search for a sequence in the same order.
|
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=item * Unordered parsing
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
{"Pod directive" =>["Text following the directive", "Text2", "Text3], "Another pod directive => [Text4], ...}
|
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
A list of token is constructed during the parsing, and all the Pod directive and key are on the same level.
|
175
|
|
|
|
|
|
|
The order in the hash has no meaning. A pod directive or a key given in the hash and not found in the file won't stop the parsing.
|
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=back
|
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=cut
|
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub new {
|
182
|
1
|
|
|
1
|
1
|
16
|
my $self = shift;
|
183
|
1
|
|
|
|
|
12
|
my $new = $self->SUPER::new(@_);
|
184
|
|
|
|
|
|
|
#$new->{log} = Log::Log4perl->get_logger(__PACKAGE__);
|
185
|
1
|
|
|
|
|
35
|
$new->{log} = Log::Any->get_logger;
|
186
|
|
|
|
|
|
|
#$new->cut_handler( \&cut_seen );
|
187
|
1
|
|
|
|
|
1874
|
$new->{output_as_hash} = 0;
|
188
|
1
|
|
|
|
|
5
|
return $new;
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
}
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=head1 B |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
$parser->select(["head1"=>["select()", "output_hash"]]);
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
$parser->select({head1 =>["select()", "output_hash"]});
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
The first call will search for the pod section in that order.
|
199
|
|
|
|
|
|
|
The second call will catch the two section in any order.
|
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
$parser->select(["head1" => ["select()", ["head1"=>["output_hash()"]]]]);
|
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
This will search for a C<<=head1 B >> pod secttion following a C<< =head1 B |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=cut
|
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub select {
|
208
|
1
|
|
|
1
|
0
|
483
|
my ( $self, $ar_r ) = @_;
|
209
|
1
|
50
|
|
|
|
5
|
if ( ref $ar_r eq "ARRAY" ) {
|
|
|
0
|
|
|
|
|
|
210
|
1
|
|
|
|
|
6
|
$self->make_tree( undef, undef, $ar_r );
|
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
#add a last token as a sentinelle so that the
|
213
|
|
|
|
|
|
|
#whole file is parse and the last line of
|
214
|
|
|
|
|
|
|
#the last token to fetch is found correctly
|
215
|
1
|
|
|
|
|
8
|
Pod::Simple::Select::Token->new( $self->{doc}, "Document_end" );
|
216
|
1
|
|
|
|
|
6
|
my $next = $self->{doc}->child_at(0);
|
217
|
1
|
50
|
|
|
|
7
|
$self->link_tree( $self->{doc}, $next ) if ($next);
|
218
|
1
|
|
|
|
|
9
|
$self->cut_handler( \&cut_seen );
|
219
|
|
|
|
|
|
|
}
|
220
|
|
|
|
|
|
|
elsif ( ref $ar_r eq "HASH" ) {
|
221
|
|
|
|
|
|
|
|
222
|
0
|
|
|
|
|
0
|
my @pods;
|
223
|
|
|
|
|
|
|
my @keys_r;
|
224
|
0
|
|
|
|
|
0
|
for my $key ( keys %$ar_r ) {
|
225
|
0
|
|
|
|
|
0
|
push @pods, $key;
|
226
|
0
|
|
|
|
|
0
|
my $k_r = $ar_r->{$key};
|
227
|
0
|
|
|
|
|
0
|
my @k_p;
|
228
|
0
|
|
|
|
|
0
|
for my $key (@$k_r) {
|
229
|
0
|
|
|
|
|
0
|
push @k_p, qr/\b$key\b/i;
|
230
|
|
|
|
|
|
|
}
|
231
|
0
|
|
|
|
|
0
|
push @keys_r, \@k_p;
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
}
|
234
|
0
|
|
|
|
|
0
|
$self->{doc} = Pod::Simple::Select::Token->new( undef, "doc" );
|
235
|
0
|
|
|
|
|
0
|
$self->{doc}->set_pod_pattern( \@pods );
|
236
|
0
|
|
|
|
|
0
|
$self->{doc}->{key_pat} = \@keys_r;
|
237
|
0
|
|
|
|
|
0
|
$self->cut_handler( \&cut_seen_uo );
|
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
{
|
240
|
1
|
|
|
1
|
|
9
|
no warnings "redefine";
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1613
|
|
|
0
|
|
|
|
|
0
|
|
241
|
|
|
|
|
|
|
|
242
|
0
|
|
|
|
|
0
|
*_handle_element_start = \&_handle_element_start_uo;
|
243
|
0
|
|
|
|
|
0
|
*_handle_text = \&_handle_text_uo;
|
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
}
|
246
|
|
|
|
|
|
|
}
|
247
|
|
|
|
|
|
|
}
|
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
#A recursive method for creating a list of token using the array ref given in select
|
250
|
|
|
|
|
|
|
#param: $token the parent token,
|
251
|
|
|
|
|
|
|
# $pod_dir the directive given in array ref for the token
|
252
|
|
|
|
|
|
|
# $ar_r the array ref from select
|
253
|
|
|
|
|
|
|
#Use the parent child relation
|
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub make_tree {
|
256
|
1
|
|
|
1
|
0
|
4
|
my ( $self, $token, $pod_dir, $ar_r ) = @_;
|
257
|
1
|
|
|
|
|
1
|
my $child_token;
|
258
|
1
|
50
|
|
|
|
4
|
if ( !defined $token ) {
|
259
|
1
|
|
|
|
|
8
|
$token = Pod::Simple::Select::Token->new( undef, "doc" );
|
260
|
1
|
|
|
|
|
3
|
$self->{doc} = $token;
|
261
|
|
|
|
|
|
|
}
|
262
|
1
|
|
|
|
|
2
|
my $pod_sel;
|
263
|
1
|
|
|
|
|
2
|
for my $val ( @{$ar_r} ) {
|
|
1
|
|
|
|
|
3
|
|
264
|
2
|
100
|
|
|
|
7
|
if ( ref $val eq "ARRAY" ) {
|
265
|
1
|
|
|
|
|
3
|
for my $key (@$val) {
|
266
|
2
|
50
|
|
|
|
14
|
if ( ref $key eq "ARRAY" ) {
|
267
|
0
|
|
|
|
|
0
|
$self->make_tree( $child_token, $pod_sel, $key );
|
268
|
|
|
|
|
|
|
}
|
269
|
|
|
|
|
|
|
else {
|
270
|
|
|
|
|
|
|
#print "make_tree 3 ", $key, "\n";
|
271
|
2
|
|
|
|
|
7
|
$child_token =
|
272
|
|
|
|
|
|
|
Pod::Simple::Select::Token->new( $token, $pod_sel );
|
273
|
2
|
|
|
|
|
8
|
$child_token->set_key($key);
|
274
|
|
|
|
|
|
|
#print $child_token->get_level, "\n";
|
275
|
|
|
|
|
|
|
}
|
276
|
|
|
|
|
|
|
} #for
|
277
|
|
|
|
|
|
|
} #if
|
278
|
|
|
|
|
|
|
else {
|
279
|
1
|
|
|
|
|
2
|
$pod_sel = $val;
|
280
|
|
|
|
|
|
|
}
|
281
|
|
|
|
|
|
|
} #for
|
282
|
|
|
|
|
|
|
}
|
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
#A recursive method for creating a list of token using the array ref given in select
|
285
|
|
|
|
|
|
|
#param: $parent the parent token,
|
286
|
|
|
|
|
|
|
# $first_child
|
287
|
|
|
|
|
|
|
#Create the next and previous relations.
|
288
|
|
|
|
|
|
|
#a parent's next is the first child
|
289
|
|
|
|
|
|
|
#a child's next is it's brother (or sister ... it's parent's next child)
|
290
|
|
|
|
|
|
|
#The last child is the parent's brother :
|
291
|
|
|
|
|
|
|
#that is: the next token of a leaf child is its neigbhour or the the parent neighbour
|
292
|
|
|
|
|
|
|
#In ->select the last token received a sentinelle token with pod dir "end_document"
|
293
|
|
|
|
|
|
|
#so that the parsing can terminate with undefined token
|
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
sub link_tree {
|
296
|
4
|
|
|
4
|
0
|
8
|
my ( $self, $parent, $first_child ) = @_;
|
297
|
4
|
100
|
|
|
|
10
|
return unless $first_child;
|
298
|
|
|
|
|
|
|
$self->{log}->debug(
|
299
|
3
|
|
|
|
|
8
|
"link_tree previous: ", $parent->get_key,
|
300
|
|
|
|
|
|
|
" next: ", $first_child->get_key
|
301
|
|
|
|
|
|
|
);
|
302
|
3
|
|
|
|
|
14
|
$parent->next($first_child);
|
303
|
3
|
|
|
|
|
7
|
$first_child->previous($parent);
|
304
|
3
|
|
|
|
|
4
|
my $next;
|
305
|
3
|
|
|
|
|
8
|
for my $t ( $parent->children ) {
|
306
|
3
|
50
|
|
|
|
6
|
if ( $t->children_count ) {
|
307
|
0
|
|
|
|
|
0
|
$self->{log}->debug( $t->get_key, " has ", $t->children_count,
|
308
|
|
|
|
|
|
|
" children" );
|
309
|
0
|
|
|
|
|
0
|
$next = $t->child_at(0);
|
310
|
|
|
|
|
|
|
}
|
311
|
|
|
|
|
|
|
else {
|
312
|
3
|
|
|
|
|
7
|
$next = $parent->child_at( $t->next_index );
|
313
|
|
|
|
|
|
|
}
|
314
|
3
|
|
|
|
|
9
|
$self->link_tree( $t, $next );
|
315
|
|
|
|
|
|
|
}
|
316
|
|
|
|
|
|
|
}
|
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
#For debugging: print the tree of token
|
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
sub print_tree {
|
321
|
0
|
|
|
0
|
0
|
0
|
my $self = shift;
|
322
|
0
|
|
|
|
|
0
|
my $token = $self->{doc};
|
323
|
0
|
|
|
|
|
0
|
my $last;
|
324
|
0
|
|
|
|
|
0
|
print "print_tree\n";
|
325
|
0
|
0
|
|
|
|
0
|
if ( ref $token->{pod_pat} eq "Regexp" ) {
|
326
|
0
|
|
|
|
|
0
|
print $token->{pod_pat};
|
327
|
0
|
|
|
|
|
0
|
return;
|
328
|
|
|
|
|
|
|
}
|
329
|
0
|
|
|
|
|
0
|
while ($token) {
|
330
|
0
|
|
|
|
|
0
|
my $pat = $token->get_key_pattern;
|
331
|
0
|
|
|
|
|
0
|
print "\t" x $token->get_level, " ";
|
332
|
0
|
0
|
|
|
|
0
|
print "", ( defined $token->get_pod_pattern ? @{ $token->get_pod_pattern } : ""), " ";
|
|
0
|
|
|
|
|
0
|
|
333
|
0
|
0
|
0
|
|
|
0
|
print "", ( defined $pat && defined $pat->[0] ? $pat->[0]->[0] : " key pat undef" ), "\n";
|
334
|
0
|
|
|
|
|
0
|
$last = $token;
|
335
|
0
|
|
|
|
|
0
|
$token = $token->next;
|
336
|
|
|
|
|
|
|
}
|
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
}
|
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
=head1 B
|
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
$parser->ouptut_hash
|
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
Calling this method before calling C<$p->parse_file($filename)> will have parse_file return a the parsing in hash.
|
345
|
|
|
|
|
|
|
The keys are the text after the pod directives (followed by a counter if the same text is met more than once.
|
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
=cut
|
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub output_hash {
|
350
|
1
|
|
|
1
|
0
|
30
|
my $self = shift;
|
351
|
1
|
|
|
|
|
2
|
my $out;
|
352
|
|
|
|
|
|
|
open( $out, ">", \$h_value )
|
353
|
1
|
50
|
|
1
|
|
6
|
or confess($self->{log}->error("Can't set a scalar ref as a file handle $!"));
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
37
|
|
354
|
1
|
|
|
|
|
686
|
$self->SUPER::output_fh($out);
|
355
|
1
|
|
|
|
|
15
|
$self->{output_as_hash} = 1;
|
356
|
|
|
|
|
|
|
}
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=head1 B
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
$parser->output_file("selected_pod.txt");
|
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
Will write the file with the pod sections selected in the parsing.
|
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=cut
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
sub output_file {
|
367
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $file ) = @_;
|
368
|
0
|
|
|
|
|
0
|
my $fh;
|
369
|
0
|
0
|
|
|
|
0
|
if ($file) {
|
370
|
|
|
|
|
|
|
open $fh, ">", $file
|
371
|
0
|
0
|
|
|
|
0
|
or confess($self->{log}->error("Can't open $file for writing $!"));
|
372
|
|
|
|
|
|
|
}
|
373
|
|
|
|
|
|
|
else {
|
374
|
0
|
|
|
|
|
0
|
$fh = *STDOUT{IO};
|
375
|
|
|
|
|
|
|
}
|
376
|
0
|
|
|
|
|
0
|
$self->SUPER::output_fh($fh);
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
}
|
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=head1 B
|
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
$parser->parse_file("Select.pm");
|
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
This method run the parsing. It as to be called after C<$p->select(...)> and C>$p->output_file(...)> or C<$p->output_hash()>.
|
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
=cut
|
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub parse_file {
|
389
|
1
|
|
|
1
|
1
|
10
|
my ( $self, $file ) = @_;
|
390
|
1
|
|
|
|
|
9
|
tie my @array, 'Tie::File', $file, mode => O_RDONLY;
|
391
|
|
|
|
|
|
|
confess($self->{log}->error(
|
392
|
1
|
50
|
|
|
|
209
|
"$file is seen as one line long by Tie::File\nPlease set the line ending according to your OS"
|
393
|
|
|
|
|
|
|
)) if ( scalar(@array) == 1 );
|
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
#$token_match = $self->{doc};
|
396
|
1
|
|
|
|
|
11461
|
$token = $self->{doc}->next;
|
397
|
|
|
|
|
|
|
# $self->{doc}->_print_patt;
|
398
|
|
|
|
|
|
|
|
399
|
1
|
|
|
|
|
16
|
$self->SUPER::parse_file($file);
|
400
|
|
|
|
|
|
|
|
401
|
1
|
50
|
|
|
|
156
|
if ($token->get_key eq "doc_Document_end_") { #ordered parsing, last token is the sentinel
|
402
|
1
|
50
|
|
|
|
5
|
$token->previous->line_end( @array + 0) unless $token->previous->line_end;
|
403
|
|
|
|
|
|
|
}
|
404
|
|
|
|
|
|
|
else { #unordered parsing: last token is the current token
|
405
|
0
|
0
|
|
|
|
0
|
$token->line_end( @array + 0) unless $token->line_end;
|
406
|
|
|
|
|
|
|
}
|
407
|
1
|
|
|
|
|
4
|
my $out = $self->{'output_fh'};
|
408
|
1
|
|
|
|
|
4
|
my %data;
|
409
|
1
|
|
|
|
|
6
|
$token = $self->{doc}->next;
|
410
|
1
|
|
|
|
|
3
|
my $key_count;
|
411
|
1
|
|
|
|
|
6
|
while ($token) {
|
412
|
3
|
50
|
|
|
|
11
|
$token = $token->next if ( $token->children_count );
|
413
|
3
|
|
|
|
|
11
|
my $key = $token->get_key;
|
414
|
3
|
|
|
|
|
23
|
$key =~s/^.*_//; #keep only the last part of the key
|
415
|
|
|
|
|
|
|
#array starts at 0 and line numbers starts at 1 ...
|
416
|
3
|
|
|
|
|
12
|
my $first = $token->line_start() - 1;
|
417
|
3
|
|
|
|
|
12
|
my $last = $token->line_end() - 1;
|
418
|
3
|
|
|
|
|
11
|
$self->{log}->debug( "key : ", $key, " ", $token->line_start(),
|
419
|
|
|
|
|
|
|
" - ", $token->line_end() );
|
420
|
3
|
|
|
|
|
23
|
for my $i ( $first .. $last ) {
|
421
|
9
|
|
|
|
|
949
|
print $out $array[$i], "\n";
|
422
|
|
|
|
|
|
|
}
|
423
|
3
|
50
|
|
|
|
440
|
if ( $self->{output_as_hash} ) {
|
424
|
3
|
|
|
|
|
13
|
while ( exists $data{$key} ) {
|
425
|
0
|
|
|
|
|
0
|
$key_count++;
|
426
|
0
|
|
|
|
|
0
|
$key .= " $key_count";
|
427
|
|
|
|
|
|
|
}
|
428
|
3
|
|
|
|
|
11
|
$data{$key} = $h_value;
|
429
|
3
|
|
|
|
|
9
|
$h_value = undef;
|
430
|
3
|
|
|
|
|
11
|
close $out;
|
431
|
|
|
|
|
|
|
open $out, ">", \$h_value
|
432
|
3
|
50
|
|
|
|
30
|
or confess($self->{log}->error("Can't open string for writing $!"));
|
433
|
|
|
|
|
|
|
}
|
434
|
3
|
|
|
|
|
12
|
$token = $token->next;
|
435
|
|
|
|
|
|
|
}
|
436
|
1
|
|
|
|
|
4
|
close $out;
|
437
|
1
|
|
|
|
|
15
|
untie @array;
|
438
|
1
|
50
|
|
|
|
92
|
return %data if ( $self->{output_as_hash} );
|
439
|
|
|
|
|
|
|
}
|
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
#
|
442
|
|
|
|
|
|
|
#A handler to get the =cut positions in the file
|
443
|
|
|
|
|
|
|
#
|
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
sub cut_seen {
|
446
|
9
|
|
|
9
|
0
|
12264
|
my ( $line, $line_number, $self ) = @_;
|
447
|
|
|
|
|
|
|
#my $mytoken = ( $token ? $token->previous : $token_match );
|
448
|
9
|
|
|
|
|
25
|
my $mytoken = $token->previous;
|
449
|
|
|
|
|
|
|
$self->{log}->debug(
|
450
|
9
|
|
|
|
|
27
|
$line_number, " token: ",
|
451
|
|
|
|
|
|
|
$mytoken->get_key, " line_end: ", $mytoken->line_end,
|
452
|
|
|
|
|
|
|
" replaced by ",
|
453
|
|
|
|
|
|
|
$line_number - 1
|
454
|
|
|
|
|
|
|
);
|
455
|
9
|
100
|
|
|
|
42
|
$mytoken->line_end( $line_number - 1 ) unless ( $mytoken->line_end );
|
456
|
|
|
|
|
|
|
}
|
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
#
|
459
|
|
|
|
|
|
|
#The same handle for select args given in a hash ref (uo is for unordered)
|
460
|
|
|
|
|
|
|
#
|
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub cut_seen_uo {
|
463
|
0
|
|
|
0
|
0
|
0
|
my ( $line, $line_number, $self ) = @_;
|
464
|
|
|
|
|
|
|
$self->{log}->debug(
|
465
|
0
|
0
|
|
|
|
0
|
$line_number,
|
466
|
|
|
|
|
|
|
" token: ",
|
467
|
|
|
|
|
|
|
( $token
|
468
|
|
|
|
|
|
|
? $token->get_key . " line_end: " . $token->line_end
|
469
|
|
|
|
|
|
|
: " undef"
|
470
|
|
|
|
|
|
|
)
|
471
|
|
|
|
|
|
|
);
|
472
|
0
|
0
|
|
|
|
0
|
$token->line_end( $line_number - 1 ) unless ($token->line_end);
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
}
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub _handle_element_start {
|
477
|
66
|
|
|
66
|
|
24782
|
my ( $self, $e_name, $attr_hr ) = @_;
|
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
#return unless $token;
|
480
|
|
|
|
|
|
|
return
|
481
|
66
|
100
|
|
|
|
172
|
unless defined $attr_hr->{"start_line"};
|
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
#do nothing with C<>, L<> element
|
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
$self->{log}->debug(
|
486
|
|
|
|
|
|
|
"e_name: ",
|
487
|
|
|
|
|
|
|
$e_name,
|
488
|
|
|
|
|
|
|
" line: ",
|
489
|
51
|
100
|
|
|
|
165
|
$attr_hr->{"start_line"},
|
|
|
50
|
|
|
|
|
|
490
|
|
|
|
|
|
|
" token: ",
|
491
|
|
|
|
|
|
|
( $token
|
492
|
|
|
|
|
|
|
? $token->get_key
|
493
|
|
|
|
|
|
|
. " key_needed: "
|
494
|
|
|
|
|
|
|
. ( $token->key_needed() ? " true" : " false" )
|
495
|
|
|
|
|
|
|
: " undef"
|
496
|
|
|
|
|
|
|
)
|
497
|
|
|
|
|
|
|
);
|
498
|
|
|
|
|
|
|
|
499
|
51
|
100
|
|
|
|
214
|
if ( $token->is_pod_matching($e_name) ) {
|
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
$self->{log}->debug(
|
502
|
2
|
|
|
|
|
6
|
"current token: ", $token->get_key,
|
503
|
|
|
|
|
|
|
" previous: ", $token->previous->get_key
|
504
|
|
|
|
|
|
|
);
|
505
|
2
|
|
|
|
|
11
|
$token->line_start( $attr_hr->{"start_line"} );
|
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
#Do not change a value set by _cut_seen, change only the 0 default value
|
508
|
2
|
50
|
|
|
|
5
|
$token->previous->line_end( $attr_hr->{"start_line"} - 1 )
|
509
|
|
|
|
|
|
|
if ( $token->previous->line_end() == 0 );
|
510
|
|
|
|
|
|
|
}
|
511
|
|
|
|
|
|
|
|
512
|
51
|
|
|
|
|
107
|
my $tp = $token->previous;
|
513
|
|
|
|
|
|
|
|
514
|
51
|
100
|
100
|
|
|
94
|
if ( $token->key_needed() && $key ) {
|
515
|
2
|
|
|
|
|
5
|
$self->{log}->debug( "testing : ", $token->get_key, " / ", $key );
|
516
|
2
|
50
|
|
|
|
8
|
if ( $token->is_key_matching($key) ) {
|
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
#$last_end = $attr_hr->{"start_line"} - 1;
|
519
|
|
|
|
|
|
|
#Set the end of the previous token if it's not elready done
|
520
|
2
|
50
|
|
|
|
20
|
$tp->line_end( $token->line_start - 1 ) unless ( $tp->line_end );
|
521
|
|
|
|
|
|
|
#$token_match = $token;
|
522
|
2
|
|
|
|
|
7
|
$self->{log}->debug("moving to the next token");
|
523
|
2
|
|
|
|
|
8
|
$token = $token->next;
|
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
}
|
526
|
|
|
|
|
|
|
else {
|
527
|
0
|
|
|
|
|
0
|
$self->{log}->debug( $token->get_key, " no match with $key" );
|
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
#stop fetching text for the key since a match has be done
|
530
|
0
|
|
|
|
|
0
|
$token->key_needed(0);
|
531
|
|
|
|
|
|
|
}
|
532
|
2
|
|
|
|
|
5
|
$key = undef;
|
533
|
|
|
|
|
|
|
} #if
|
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
else {
|
536
|
|
|
|
|
|
|
#key not needed or $key undef
|
537
|
49
|
100
|
|
|
|
165
|
if ( $e_name =~ /^head/i ) {
|
538
|
|
|
|
|
|
|
$self->{log}
|
539
|
14
|
|
|
|
|
43
|
->debug( "token->key_needed is false or key undef. tp current line end : ", $tp->line_end );
|
540
|
|
|
|
|
|
|
#close the last token fetched if it's still 0
|
541
|
14
|
50
|
|
|
|
52
|
$tp->line_end( $attr_hr->{"start_line"} - 1 )
|
542
|
|
|
|
|
|
|
unless ( $tp->line_end );
|
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
}
|
545
|
|
|
|
|
|
|
}
|
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
}
|
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
#uo parsing: the compiled regex for the pod directives and the keys
|
550
|
|
|
|
|
|
|
#are in the root token for the whole parsing.
|
551
|
|
|
|
|
|
|
#The children token are created during the parsing when a key (from the file) matched with a key pattern
|
552
|
|
|
|
|
|
|
#The starting line and ending line are
|
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
sub _handle_element_start_uo {
|
555
|
0
|
|
|
0
|
|
0
|
my ( $self, $e_name, $attr_hr ) = @_;
|
556
|
|
|
|
|
|
|
return
|
557
|
0
|
0
|
|
|
|
0
|
unless defined $attr_hr->{"start_line"};
|
558
|
0
|
0
|
|
|
|
0
|
$token = $self->{doc} unless ($token);
|
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
$self->{log}->debug(
|
561
|
|
|
|
|
|
|
"e_name: ",
|
562
|
|
|
|
|
|
|
$e_name,
|
563
|
|
|
|
|
|
|
" line: ",
|
564
|
|
|
|
|
|
|
$attr_hr->{"start_line"},
|
565
|
|
|
|
|
|
|
" token: ",
|
566
|
|
|
|
|
|
|
( defined $token ) ? $token->get_key : " token undef",
|
567
|
|
|
|
|
|
|
" key_needed: ",
|
568
|
0
|
0
|
|
|
|
0
|
( $self->{doc}->key_needed() ? " true" : " false" )
|
|
|
0
|
|
|
|
|
|
569
|
|
|
|
|
|
|
);
|
570
|
|
|
|
|
|
|
|
571
|
0
|
0
|
|
|
|
0
|
if ( $self->{doc}->is_pod_matching($e_name) ) {
|
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
#put the line of the matching pod directive in the root token
|
574
|
|
|
|
|
|
|
#the matching pod directive can be retrieve with $self->{doc}->get_pod
|
575
|
0
|
|
|
|
|
0
|
$self->{doc}->line_start( $attr_hr->{"start_line"} );
|
576
|
0
|
0
|
|
|
|
0
|
if ( $token->previous ) {
|
577
|
0
|
0
|
|
|
|
0
|
$token->previous->line_end( $attr_hr->{"start_line"} - 1 )
|
578
|
|
|
|
|
|
|
if ( $token->previous->line_end() == 0 );
|
579
|
|
|
|
|
|
|
}
|
580
|
|
|
|
|
|
|
else {
|
581
|
0
|
|
|
|
|
0
|
$self->{log}->debug("tp undef");
|
582
|
|
|
|
|
|
|
}
|
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
}
|
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
$self->{log}->debug(
|
587
|
|
|
|
|
|
|
" self->{doc}->key_needed: ",
|
588
|
0
|
0
|
|
|
|
0
|
( $self->{doc}->key_needed() ? " true" : " false" ),
|
|
|
0
|
|
|
|
|
|
589
|
|
|
|
|
|
|
" key is ", ( defined $key ? $key : " undef" )
|
590
|
|
|
|
|
|
|
);
|
591
|
|
|
|
|
|
|
|
592
|
0
|
0
|
0
|
|
|
0
|
if ( $self->{doc}->key_needed() && $key ) {
|
593
|
|
|
|
|
|
|
|
594
|
0
|
|
|
|
|
0
|
$self->{log}->debug( "testing : ", $key );
|
595
|
|
|
|
|
|
|
|
596
|
0
|
0
|
|
|
|
0
|
if ( $self->{doc}->is_key_matching($key) ) {
|
597
|
0
|
|
|
|
|
0
|
$self->{log}->debug("Found match");
|
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
#$last_end = $attr_hr->{"start_line"} - 1;
|
600
|
0
|
0
|
|
|
|
0
|
if ( $token->previous ) {
|
601
|
0
|
0
|
|
|
|
0
|
$token->previous->line_end( $attr_hr->{"start_line"} - 1 )
|
602
|
|
|
|
|
|
|
unless ( $token->previous->line_end );
|
603
|
|
|
|
|
|
|
}
|
604
|
|
|
|
|
|
|
else {
|
605
|
0
|
|
|
|
|
0
|
$self->{log}->debug("tp undef");
|
606
|
|
|
|
|
|
|
}
|
607
|
0
|
|
|
|
|
0
|
$self->{log}->debug("next token - new token");
|
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
my $new_token =
|
610
|
|
|
|
|
|
|
Pod::Simple::Select::Token->new( $self->{doc},
|
611
|
0
|
|
|
|
|
0
|
$self->{doc}->get_pod );
|
612
|
|
|
|
|
|
|
|
613
|
0
|
|
|
|
|
0
|
$new_token->set_key($key);
|
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
#retrieve back the line_start stored when the pod
|
616
|
|
|
|
|
|
|
#dir of the current key was matching
|
617
|
0
|
|
|
|
|
0
|
$new_token->line_start( $self->{doc}->line_start );
|
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
#set the line end the soon to become previous token
|
620
|
|
|
|
|
|
|
#unless the line_end already exists
|
621
|
0
|
0
|
|
|
|
0
|
$token->line_end( $self->{doc}->line_start - 1 )
|
622
|
|
|
|
|
|
|
unless ( $token->line_end );
|
623
|
0
|
|
|
|
|
0
|
$new_token->previous($token);
|
624
|
0
|
|
|
|
|
0
|
$token = $token->next($new_token);
|
625
|
|
|
|
|
|
|
} #if
|
626
|
|
|
|
|
|
|
else {
|
627
|
|
|
|
|
|
|
$self->{log}->debug(
|
628
|
|
|
|
|
|
|
"no match ! pod_index: ",
|
629
|
|
|
|
|
|
|
$self->{doc}->{pod_index},
|
630
|
|
|
|
|
|
|
" keys ",
|
631
|
|
|
|
|
|
|
join(
|
632
|
|
|
|
|
|
|
" ",
|
633
|
0
|
|
|
|
|
0
|
@{ $self->{doc}->{key_pat}->[ $self->{doc}->{pod_index} ]
|
|
0
|
|
|
|
|
0
|
|
634
|
|
|
|
|
|
|
}
|
635
|
|
|
|
|
|
|
)
|
636
|
|
|
|
|
|
|
);
|
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
#set the line end of the current token before the start of
|
639
|
|
|
|
|
|
|
#this section having a non matching key
|
640
|
|
|
|
|
|
|
#tester =head1 found =head3 Non matching pod
|
641
|
0
|
0
|
|
|
|
0
|
$token->line_end( $self->{doc}->line_start - 1 )
|
642
|
|
|
|
|
|
|
unless ( $token->line_end );
|
643
|
|
|
|
|
|
|
}
|
644
|
0
|
|
|
|
|
0
|
$key = undef;
|
645
|
|
|
|
|
|
|
}
|
646
|
|
|
|
|
|
|
else {
|
647
|
|
|
|
|
|
|
#key not needed or $key undef
|
648
|
0
|
0
|
|
|
|
0
|
if ( $e_name =~ /^head/i ) {
|
649
|
0
|
|
|
|
|
0
|
my $last_end = $attr_hr->{"start_line"} - 1;
|
650
|
0
|
0
|
|
|
|
0
|
if ( $token->previous ) {
|
651
|
0
|
|
|
|
|
0
|
$self->{log}->debug( "tp current line end : ",
|
652
|
|
|
|
|
|
|
$token->previous->line_end );
|
653
|
|
|
|
|
|
|
|
654
|
0
|
0
|
|
|
|
0
|
$token->previous->line_end($last_end)
|
655
|
|
|
|
|
|
|
unless ( $token->previous->line_end );
|
656
|
|
|
|
|
|
|
}
|
657
|
|
|
|
|
|
|
else {
|
658
|
0
|
|
|
|
|
0
|
$self->{log}->debug("tp undef");
|
659
|
|
|
|
|
|
|
}
|
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
}
|
662
|
|
|
|
|
|
|
}
|
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
}
|
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
sub _handle_text {
|
668
|
66
|
|
|
66
|
|
648
|
my ( $self, $text ) = @_;
|
669
|
66
|
50
|
|
|
|
138
|
return unless $token;
|
670
|
66
|
100
|
|
|
|
120
|
if ( $token->key_needed() ) {
|
671
|
2
|
|
|
|
|
4
|
$key .= $text;
|
672
|
|
|
|
|
|
|
}
|
673
|
66
|
|
|
|
|
159
|
$self->{log}->debug($text);
|
674
|
|
|
|
|
|
|
}
|
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
sub _handle_text_uo {
|
677
|
0
|
|
|
0
|
|
0
|
my ( $self, $text ) = @_;
|
678
|
0
|
0
|
|
|
|
0
|
if ( $self->{doc}->key_needed() ) {
|
679
|
0
|
|
|
|
|
0
|
$key .= $text;
|
680
|
|
|
|
|
|
|
}
|
681
|
0
|
|
|
|
|
0
|
$self->{log}->debug($text);
|
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
}
|
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
#
|
687
|
|
|
|
|
|
|
#Pod::Simple::Select::Token is used in both ordred unordered parsing
|
688
|
|
|
|
|
|
|
#It's not used outsite this module so it is not included in separate file
|
689
|
|
|
|
|
|
|
#
|
690
|
|
|
|
|
|
|
#Ordered parsing : a list of token ordred by next-previous links and parent-child links
|
691
|
|
|
|
|
|
|
#parent - child links are made by the args given in select
|
692
|
|
|
|
|
|
|
#next-previous is a deep first search in the tree made in $parser->make_tree
|
693
|
|
|
|
|
|
|
#{key_pat} holds an array ref of one array ref that hold the compiled regex of a key
|
694
|
|
|
|
|
|
|
#{pod_pat} holds an array ref of one array ref that hold .... of the pod directive
|
695
|
|
|
|
|
|
|
#{pod_index} is 0 in every token
|
696
|
|
|
|
|
|
|
#{pod} is the pod directive received in the token contructor
|
697
|
|
|
|
|
|
|
#
|
698
|
|
|
|
|
|
|
#Unordered parsing: a list of token is made in _handle_element_start_uo when a pod directive
|
699
|
|
|
|
|
|
|
#and key match with the keys and pod patterns stored in the root token (stored in $parser->{doc}
|
700
|
|
|
|
|
|
|
#all the token are children of the root, next-previous is a link between all these children token
|
701
|
|
|
|
|
|
|
#In the root token
|
702
|
|
|
|
|
|
|
#{pod_pat} holds an array ref of arrays ref, each having a compiled pod directives
|
703
|
|
|
|
|
|
|
#{key_pat} holds an array ref of arrays ref, each having a compiled regex for a key
|
704
|
|
|
|
|
|
|
#when a pod directive from the file matched, the index in the @{$self->{pod_array}}
|
705
|
|
|
|
|
|
|
#is stored in {pod_index}. So the corresponding array of compiled keys regex can be used
|
706
|
|
|
|
|
|
|
#in @{$self->{key_pat}} to test a match with a key.
|
707
|
|
|
|
|
|
|
#The pod directive that matched is remembered in $parser->{doc}->{pod}
|
708
|
|
|
|
|
|
|
#
|
709
|
|
|
|
|
|
|
package Pod::Simple::Select::Token;
|
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
#use Carp qw/confess/;
|
712
|
1
|
|
|
1
|
|
8
|
use Data::Dumper;
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
1003
|
|
713
|
|
|
|
|
|
|
my $current_child = 0;
|
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
sub new {
|
716
|
4
|
|
|
4
|
|
11
|
my ( $class, $parent, $pod_dir ) = @_;
|
717
|
4
|
|
|
|
|
12
|
my $self->{parent} = $parent;
|
718
|
4
|
|
|
|
|
9
|
bless $self, $class;
|
719
|
|
|
|
|
|
|
|
720
|
4
|
100
|
|
|
|
11
|
if ($parent) {
|
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
#index position of this token in the parent token
|
723
|
3
|
|
|
|
|
13
|
$self->{index} = $parent->add_child($self);
|
724
|
3
|
|
|
|
|
9
|
$self->{level} = $parent->{level} + 1;
|
725
|
3
|
|
|
|
|
11
|
$self->{key} = $parent->get_key . "_" . $pod_dir . "_";
|
726
|
3
|
|
|
|
|
7
|
$self->{key_needed} = 0;
|
727
|
|
|
|
|
|
|
}
|
728
|
|
|
|
|
|
|
else {
|
729
|
1
|
|
|
|
|
6
|
$self->{level} = 0;
|
730
|
1
|
|
|
|
|
2
|
$self->{key_pat} = [];
|
731
|
1
|
|
|
|
|
3
|
$self->{key} = $pod_dir;
|
732
|
|
|
|
|
|
|
}
|
733
|
4
|
|
|
|
|
10
|
$self->{pod_index} = 0;
|
734
|
4
|
|
|
|
|
11
|
$self->{line_pos} = [ 0, 0 ];
|
735
|
4
|
|
|
|
|
15
|
$self->set_pod_pattern($pod_dir);
|
736
|
4
|
|
|
|
|
9
|
$self->{children} = [];
|
737
|
|
|
|
|
|
|
#$self->{log} = Log::Log4perl::get_logger(__PACKAGE__);
|
738
|
4
|
|
|
|
|
19
|
$self->{log} = Log::Any->get_logger;
|
739
|
4
|
|
|
|
|
301
|
return $self;
|
740
|
|
|
|
|
|
|
}
|
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
sub set_key {
|
743
|
2
|
|
|
2
|
|
5
|
my ( $self, $key ) = @_;
|
744
|
2
|
|
|
|
|
12
|
$self->{log}->debug( " key: ", $key );
|
745
|
2
|
|
|
|
|
10
|
$self->{key} .= $key;
|
746
|
2
|
|
|
|
|
4
|
push @{ $self->{key_pat} }, [qr/\b$key\b/i];
|
|
2
|
|
|
|
|
36
|
|
747
|
|
|
|
|
|
|
}
|
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
sub get_key {
|
750
|
88
|
|
|
88
|
|
280
|
return shift->{key};
|
751
|
|
|
|
|
|
|
}
|
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
sub get_key_pattern {
|
754
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
755
|
|
|
|
|
|
|
|
756
|
0
|
|
|
|
|
0
|
return $self->{key_pat};
|
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
}
|
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
sub get_pod_pattern {
|
761
|
0
|
|
|
0
|
|
0
|
return shift->{pod_pat};
|
762
|
|
|
|
|
|
|
}
|
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
sub set_pod_pattern {
|
765
|
4
|
|
|
4
|
|
9
|
my ( $self, $pod_dir ) = @_;
|
766
|
4
|
50
|
|
|
|
13
|
if ( ref $pod_dir eq "ARRAY" ) {
|
767
|
0
|
|
|
|
|
0
|
my @pat;
|
768
|
0
|
|
|
|
|
0
|
for my $pod (@$pod_dir) {
|
769
|
0
|
|
|
|
|
0
|
push @pat, qr/\b$pod\b/i;
|
770
|
|
|
|
|
|
|
}
|
771
|
0
|
|
|
|
|
0
|
$self->{pod_pat} = \@pat;
|
772
|
|
|
|
|
|
|
}
|
773
|
|
|
|
|
|
|
else {
|
774
|
4
|
|
|
|
|
51
|
$self->{pod_pat} = [qr/\b$pod_dir\b/i];
|
775
|
4
|
|
|
|
|
15
|
$self->{pod} = $pod_dir
|
776
|
|
|
|
|
|
|
; #ordered args: holds the head1 etc given in the select call
|
777
|
|
|
|
|
|
|
#unordered args : holds the pod_directive last match
|
778
|
|
|
|
|
|
|
}
|
779
|
|
|
|
|
|
|
}
|
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
sub add_child {
|
782
|
3
|
|
|
3
|
|
6
|
my ( $self, $child ) = @_;
|
783
|
|
|
|
|
|
|
$self->{first_child} = $child
|
784
|
3
|
100
|
|
|
|
6
|
unless ( scalar @{ $self->{children} } );
|
|
3
|
|
|
|
|
12
|
|
785
|
3
|
|
|
|
|
6
|
push @{ $self->{children} }, $child;
|
|
3
|
|
|
|
|
6
|
|
786
|
3
|
|
|
|
|
7
|
return @{ $self->{children} } - 1;
|
|
3
|
|
|
|
|
10
|
|
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
#next est le premier ne s'il y a des descendants
|
789
|
|
|
|
|
|
|
#sinon c est le voisin de meme niveau
|
790
|
|
|
|
|
|
|
}
|
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
sub previous {
|
793
|
70
|
|
|
70
|
|
115
|
my ( $self, $v ) = @_;
|
794
|
70
|
100
|
|
|
|
149
|
if ($v) {
|
795
|
3
|
|
|
|
|
7
|
$self->{previous} = $v;
|
796
|
|
|
|
|
|
|
}
|
797
|
70
|
50
|
|
|
|
197
|
return $self->{previous} if ( $self->{previous} );
|
798
|
|
|
|
|
|
|
}
|
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
sub next {
|
801
|
10
|
|
|
10
|
|
25
|
my ( $self, $v ) = @_;
|
802
|
10
|
100
|
|
|
|
24
|
if ($v) {
|
803
|
3
|
|
|
|
|
12
|
$self->{next} = $v;
|
804
|
|
|
|
|
|
|
}
|
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=for comment
|
807
|
|
|
|
|
|
|
if ($self->{first_child} && ! $seen{ $self->{key} }) {
|
808
|
|
|
|
|
|
|
$seen{ $self->{key}}= 1;
|
809
|
|
|
|
|
|
|
return $self->{first_child};
|
810
|
|
|
|
|
|
|
}
|
811
|
|
|
|
|
|
|
return $self->{parent}->child_at($self->{index}+1) if ( $self->{parent});
|
812
|
|
|
|
|
|
|
# return $self->{parent}->next if ($self->{parent});
|
813
|
|
|
|
|
|
|
=cut
|
814
|
|
|
|
|
|
|
|
815
|
10
|
100
|
|
|
|
44
|
return $self->{next} if ( $self->{next} );
|
816
|
|
|
|
|
|
|
}
|
817
|
|
|
|
|
|
|
#
|
818
|
|
|
|
|
|
|
#Return the token at pos $index if $index is in the range of 0 -> last_child (: children_count -1)
|
819
|
|
|
|
|
|
|
#Else if there is a parent, return the next sibling
|
820
|
|
|
|
|
|
|
#(the token next to the current token in the parent children list
|
821
|
|
|
|
|
|
|
#
|
822
|
|
|
|
|
|
|
sub child_at {
|
823
|
4
|
|
|
4
|
|
7
|
my ( $self, $index ) = @_;
|
824
|
4
|
50
|
|
|
|
9
|
confess($self->{log}->error("called on an empty list"))
|
825
|
|
|
|
|
|
|
unless $self->children_count;
|
826
|
|
|
|
|
|
|
$self->{log}
|
827
|
4
|
|
|
|
|
7
|
->debug( "searching ", $index, " in 0-", @{ $self->{children} } - 1,
|
|
4
|
|
|
|
|
13
|
|
828
|
|
|
|
|
|
|
" indexes" );
|
829
|
4
|
100
|
|
|
|
13
|
if ( $index < @{ $self->{children} } ) {
|
|
4
|
|
|
|
|
14
|
|
830
|
3
|
|
|
|
|
8
|
return $self->{children}->[$index];
|
831
|
|
|
|
|
|
|
}
|
832
|
|
|
|
|
|
|
else {
|
833
|
|
|
|
|
|
|
return $self->{parent}->child_at( $self->{index} + 1 )
|
834
|
1
|
50
|
|
|
|
3
|
if ( $self->{parent} );
|
835
|
|
|
|
|
|
|
}
|
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
}
|
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
sub children {
|
840
|
3
|
|
|
3
|
|
4
|
return @{ shift->{children} };
|
|
3
|
|
|
|
|
8
|
|
841
|
|
|
|
|
|
|
}
|
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
sub line_start {
|
844
|
8
|
|
|
8
|
|
22
|
my ( $self, $pos ) = @_;
|
845
|
8
|
100
|
|
|
|
47
|
if ($pos) {
|
846
|
2
|
|
|
|
|
5
|
$self->{line_pos}->[0] = $pos;
|
847
|
|
|
|
|
|
|
$self->{log}
|
848
|
2
|
|
|
|
|
5
|
->debug( "line_start: ", $self->get_key, " set at ", $pos );
|
849
|
|
|
|
|
|
|
}
|
850
|
8
|
|
|
|
|
32
|
return $self->{line_pos}->[0];
|
851
|
|
|
|
|
|
|
}
|
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub line_end {
|
854
|
60
|
|
|
60
|
|
100
|
my ( $self, $pos ) = @_;
|
855
|
60
|
100
|
|
|
|
131
|
if ($pos) {
|
856
|
3
|
|
|
|
|
6
|
$self->{line_pos}->[1] = $pos;
|
857
|
3
|
|
|
|
|
6
|
$self->{log}->debug( $self->get_key, " set at ", $pos );
|
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
}
|
860
|
60
|
|
|
|
|
218
|
return $self->{line_pos}->[1];
|
861
|
|
|
|
|
|
|
}
|
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
sub next_index {
|
864
|
3
|
|
|
3
|
|
7
|
return shift->{index} + 1;
|
865
|
|
|
|
|
|
|
}
|
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
sub children_count {
|
868
|
10
|
|
|
10
|
|
18
|
my $self = shift;
|
869
|
10
|
|
|
|
|
16
|
my $res = @{ $self->{children} };
|
|
10
|
|
|
|
|
21
|
|
870
|
10
|
|
|
|
|
28
|
return $res;
|
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
}
|
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
sub get_level {
|
875
|
0
|
|
|
0
|
|
0
|
return shift->{level};
|
876
|
|
|
|
|
|
|
}
|
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
sub is_pod_matching {
|
879
|
51
|
|
|
51
|
|
92
|
my ( $self, $el ) = @_;
|
880
|
51
|
50
|
|
|
|
108
|
confess($self->{log}->error("can't treat undef")) unless ($el);
|
881
|
|
|
|
|
|
|
|
882
|
51
|
50
|
|
|
|
123
|
if ( $self->{pod_pat} ) {
|
883
|
51
|
|
|
|
|
77
|
my $i = 0;
|
884
|
51
|
|
|
|
|
70
|
for my $p ( @{ $self->{pod_pat} } ) {
|
|
51
|
|
|
|
|
102
|
|
885
|
51
|
|
|
|
|
68
|
$i++;
|
886
|
51
|
100
|
|
|
|
278
|
if ( $el =~ /\b$p\b/ ) {
|
887
|
2
|
|
|
|
|
5
|
$self->{key_needed} = 1;
|
888
|
2
|
|
|
|
|
5
|
$self->{pod_index} = $i - 1;
|
889
|
2
|
|
|
|
|
3
|
$self->{pod} = $el;
|
890
|
|
|
|
|
|
|
$self->{log}->debug( "Found pod match for ",
|
891
|
|
|
|
|
|
|
$self->get_key, " and ", $el, " with index ",
|
892
|
2
|
|
|
|
|
5
|
$self->{pod_index} );
|
893
|
2
|
|
|
|
|
9
|
return 1;
|
894
|
|
|
|
|
|
|
}
|
895
|
|
|
|
|
|
|
}
|
896
|
|
|
|
|
|
|
}
|
897
|
49
|
|
|
|
|
119
|
return 0;
|
898
|
|
|
|
|
|
|
}
|
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
sub is_key_matching {
|
901
|
2
|
|
|
2
|
|
6
|
my ( $self, $el ) = @_;
|
902
|
2
|
50
|
|
|
|
5
|
confess($self->{log}->error("can't treat undef")) unless ($el);
|
903
|
2
|
|
|
|
|
5
|
my $key_r = $self->{key_pat}->[ $self->{pod_index} ];
|
904
|
2
|
|
|
|
|
6
|
$self->{log}->debug("is_key_matching index:", $self->{pod_index});
|
905
|
2
|
|
|
|
|
6
|
$self->{key_needed} = 0;
|
906
|
2
|
|
|
|
|
10
|
$self->{log}->debug("key_needed set to 0");
|
907
|
2
|
|
|
|
|
7
|
for my $p (@$key_r) {
|
908
|
2
|
|
|
|
|
10
|
$self->{log}->debug("searching $el pattern: $p");
|
909
|
2
|
50
|
|
|
|
27
|
if ( $el =~ /\b$p\b/ ) {
|
910
|
2
|
50
|
|
|
|
8
|
$self->set_key($el) unless $self->{key};
|
911
|
2
|
|
|
|
|
5
|
$self->{log}->debug( "Found key match for ",
|
912
|
|
|
|
|
|
|
$self->get_key, " and ", $el );
|
913
|
|
|
|
|
|
|
#$self->{key_needed} = 0;
|
914
|
2
|
|
|
|
|
11
|
return 1;
|
915
|
|
|
|
|
|
|
}
|
916
|
|
|
|
|
|
|
}
|
917
|
0
|
|
|
|
|
0
|
return 0;
|
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
}
|
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
sub get_pod {
|
922
|
0
|
|
|
0
|
|
0
|
return shift->{pod};
|
923
|
|
|
|
|
|
|
}
|
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
sub key_needed {
|
926
|
168
|
|
|
168
|
|
264
|
my ( $self, $v ) = @_;
|
927
|
168
|
50
|
|
|
|
329
|
$self->{key_needed} = $v if ( defined $v );
|
928
|
168
|
|
|
|
|
519
|
return $self->{key_needed};
|
929
|
|
|
|
|
|
|
}
|
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
sub _print_patt {
|
932
|
0
|
|
|
0
|
|
|
my $self = shift;
|
933
|
0
|
|
|
|
|
|
print "print_patt ", Dumper( $self->{pod_pat} ), "\n";
|
934
|
0
|
0
|
|
|
|
|
if ( ref $self->{key_pat} ) {
|
935
|
0
|
|
|
|
|
|
for my $k ( @{ $self->{key_pat} } ) {
|
|
0
|
|
|
|
|
|
|
936
|
0
|
|
|
|
|
|
print "key_pat ", Dumper(@$k), "\n";
|
937
|
|
|
|
|
|
|
}
|
938
|
|
|
|
|
|
|
}
|
939
|
|
|
|
|
|
|
else {
|
940
|
0
|
|
|
|
|
|
print "key_pat ", $self->{key_pat}, "\n";
|
941
|
|
|
|
|
|
|
}
|
942
|
|
|
|
|
|
|
}
|
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
1;
|
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
=head1 BUGS
|
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
See support below.
|
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
=head1 SUPPORT
|
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
Any questions or problems can be posted to me (rappazf) on my gmail account.
|
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
=head1 AUTHOR
|
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
FranEois Rappaz
|
957
|
|
|
|
|
|
|
CPAN ID: RAPPAZF
|
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
=head1 COPYRIGHT
|
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
FranEois Rappaz 2017
|
962
|
|
|
|
|
|
|
This program is free software; you can redistribute
|
963
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself.
|
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
The full text of the license can be found in the
|
966
|
|
|
|
|
|
|
LICENSE file included with this module.
|
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
=head1 SEE ALSO
|
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
L
|
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
L
|
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
=cut
|
976
|
|
|
|
|
|
|
|