← Index
NYTProf Performance Profile   « line view »
For webmerge/scripts/webmerge.pl
  Run on Mon Oct 7 02:42:42 2013
Reported on Mon Oct 7 03:03:26 2013

Filename/usr/lib64/perl5/5.16.0/Pod/Simple.pm
StatementsExecuted 87 statements in 44.8ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11113.6ms14.6msPod::Simple::::BEGIN@8Pod::Simple::BEGIN@8
1112.94ms55.6msPod::Simple::::BEGIN@9Pod::Simple::BEGIN@9
1111.04ms1.11msPod::Simple::::_accessorizePod::Simple::_accessorize
111982µs1.00msPod::Simple::::BEGIN@7Pod::Simple::BEGIN@7
111102µs108µsPod::Simple::::BEGIN@32Pod::Simple::BEGIN@32
11181µs181µsPod::Simple::::BEGIN@4Pod::Simple::BEGIN@4
251170µs70µsPod::Simple::::CORE:matchPod::Simple::CORE:match (opcode)
11169µs155µsPod::Simple::::BEGIN@1438Pod::Simple::BEGIN@1438
11165µs646µsPod::Simple::::BEGIN@13Pod::Simple::BEGIN@13
11162µs158µsPod::Simple::::BEGIN@1434Pod::Simple::BEGIN@1434
11133µs33µsPod::Simple::::BEGIN@116Pod::Simple::BEGIN@116
11126µs26µsPod::Simple::::BEGIN@6Pod::Simple::BEGIN@6
11126µs26µsPod::Simple::::BEGIN@10Pod::Simple::BEGIN@10
11122µs22µsPod::Simple::::BEGIN@5Pod::Simple::BEGIN@5
1116µs6µsPod::Simple::::__ANON__Pod::Simple::__ANON__ (xsub)
0000s0sPod::Simple::::__ANON__[:1066]Pod::Simple::__ANON__[:1066]
0000s0sPod::Simple::::__ANON__[:1444]Pod::Simple::__ANON__[:1444]
0000s0sPod::Simple::::_accept_directivesPod::Simple::_accept_directives
0000s0sPod::Simple::::_accept_targetsPod::Simple::_accept_targets
0000s0sPod::Simple::::_change_S_to_nbspPod::Simple::_change_S_to_nbsp
0000s0sPod::Simple::::_complain_errataPod::Simple::_complain_errata
0000s0sPod::Simple::::_complain_warnPod::Simple::_complain_warn
0000s0sPod::Simple::::_duoPod::Simple::_duo
0000s0sPod::Simple::::_get_initial_item_typePod::Simple::_get_initial_item_type
0000s0sPod::Simple::::_get_item_typePod::Simple::_get_item_type
0000s0sPod::Simple::::_handle_element_endPod::Simple::_handle_element_end
0000s0sPod::Simple::::_handle_element_startPod::Simple::_handle_element_start
0000s0sPod::Simple::::_handle_textPod::Simple::_handle_text
0000s0sPod::Simple::::_init_fh_sourcePod::Simple::_init_fh_source
0000s0sPod::Simple::::_make_treeletPod::Simple::_make_treelet
0000s0sPod::Simple::::_outPod::Simple::_out
0000s0sPod::Simple::::_ponder_extendPod::Simple::_ponder_extend
0000s0sPod::Simple::::_remap_sequencesPod::Simple::_remap_sequences
0000s0sPod::Simple::::_treat_EsPod::Simple::_treat_Es
0000s0sPod::Simple::::_treat_LsPod::Simple::_treat_Ls
0000s0sPod::Simple::::_treat_SsPod::Simple::_treat_Ss
0000s0sPod::Simple::::_treat_ZsPod::Simple::_treat_Zs
0000s0sPod::Simple::::_wrap_upPod::Simple::_wrap_up
0000s0sPod::Simple::::abandon_output_fhPod::Simple::abandon_output_fh
0000s0sPod::Simple::::abandon_output_stringPod::Simple::abandon_output_string
0000s0sPod::Simple::::accept_codePod::Simple::accept_code
0000s0sPod::Simple::::accept_codesPod::Simple::accept_codes
0000s0sPod::Simple::::accept_directive_as_dataPod::Simple::accept_directive_as_data
0000s0sPod::Simple::::accept_directive_as_processedPod::Simple::accept_directive_as_processed
0000s0sPod::Simple::::accept_directive_as_verbatimPod::Simple::accept_directive_as_verbatim
0000s0sPod::Simple::::accept_targetPod::Simple::accept_target
0000s0sPod::Simple::::accept_target_as_textPod::Simple::accept_target_as_text
0000s0sPod::Simple::::accept_targetsPod::Simple::accept_targets
0000s0sPod::Simple::::accept_targets_as_textPod::Simple::accept_targets_as_text
0000s0sPod::Simple::::any_errata_seenPod::Simple::any_errata_seen
0000s0sPod::Simple::::filterPod::Simple::filter
0000s0sPod::Simple::::newPod::Simple::new
0000s0sPod::Simple::::output_stringPod::Simple::output_string
0000s0sPod::Simple::::parse_filePod::Simple::parse_file
0000s0sPod::Simple::::parse_from_filePod::Simple::parse_from_file
0000s0sPod::Simple::::parse_string_documentPod::Simple::parse_string_document
0000s0sPod::Simple::::screamPod::Simple::scream
0000s0sPod::Simple::::unaccept_codePod::Simple::unaccept_code
0000s0sPod::Simple::::unaccept_codesPod::Simple::unaccept_codes
0000s0sPod::Simple::::unaccept_directivePod::Simple::unaccept_directive
0000s0sPod::Simple::::unaccept_directivesPod::Simple::unaccept_directives
0000s0sPod::Simple::::unaccept_targetPod::Simple::unaccept_target
0000s0sPod::Simple::::unaccept_targetsPod::Simple::unaccept_targets
0000s0sPod::Simple::::version_reportPod::Simple::version_report
0000s0sPod::Simple::::whinePod::Simple::whine
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1
2142µsrequire 5;
3package Pod::Simple;
42150µs2281µs
# spent 181µs (81+100) within Pod::Simple::BEGIN@4 which was called: # once (81µs+100µs) by Pod::Text::BEGIN@34 at line 4
use strict;
# spent 181µs making 1 call to Pod::Simple::BEGIN@4 # spent 100µs making 1 call to strict::import
52247µs122µs
# spent 22µs within Pod::Simple::BEGIN@5 which was called: # once (22µs+0s) by Pod::Text::BEGIN@34 at line 5
use Carp ();
# spent 22µs making 1 call to Pod::Simple::BEGIN@5
61132µs126µs
# spent 26µs within Pod::Simple::BEGIN@6 which was called: # once (26µs+0s) by Pod::Text::BEGIN@34 at line 6
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
# spent 26µs making 1 call to Pod::Simple::BEGIN@6
721.14ms21.02ms
# spent 1.00ms (982µs+18µs) within Pod::Simple::BEGIN@7 which was called: # once (982µs+18µs) by Pod::Text::BEGIN@34 at line 7
use integer;
# spent 1.00ms making 1 call to Pod::Simple::BEGIN@7 # spent 18µs making 1 call to integer::import
831.14ms214.7ms
# spent 14.6ms (13.6+991µs) within Pod::Simple::BEGIN@8 which was called: # once (13.6ms+991µs) by Pod::Text::BEGIN@34 at line 8
use Pod::Escapes 1.04 ();
# spent 14.6ms making 1 call to Pod::Simple::BEGIN@8 # spent 85µs making 1 call to UNIVERSAL::VERSION
92955µs155.6ms
# spent 55.6ms (2.94+52.6) within Pod::Simple::BEGIN@9 which was called: # once (2.94ms+52.6ms) by Pod::Text::BEGIN@34 at line 9
use Pod::Simple::LinkSection ();
# spent 55.6ms making 1 call to Pod::Simple::BEGIN@9
102235µs126µs
# spent 26µs within Pod::Simple::BEGIN@10 which was called: # once (26µs+0s) by Pod::Text::BEGIN@34 at line 10
use Pod::Simple::BlackBox ();
# spent 26µs making 1 call to Pod::Simple::BEGIN@10
11#use utf8;
12
13140µs1580µs
# spent 646µs (65+581) within Pod::Simple::BEGIN@13 which was called: # once (65µs+581µs) by Pod::Text::BEGIN@34 at line 18
use vars qw(
# spent 580µs making 1 call to vars::import
14 $VERSION @ISA
15 @Known_formatting_codes @Known_directives
16 %Known_formatting_codes %Known_directives
17 $NL
1811.41ms1646µs);
# spent 646µs making 1 call to Pod::Simple::BEGIN@13
19
20137µs@ISA = ('Pod::Simple::BlackBox');
2114µs$VERSION = '3.20';
22
23113µs@Known_formatting_codes = qw(I B C L E F S X Z);
24141µs%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
2518µs@Known_directives = qw(head1 head2 head3 head4 item over back);
26132µs%Known_directives = map(($_=>'Plain'), @Known_directives);
2717µs$NL = $/ unless defined $NL;
28
29#-----------------------------------------------------------------------------
30# Set up some constants:
31
32
# spent 108µs (102+7) within Pod::Simple::BEGIN@32 which was called: # once (102µs+7µs) by Pod::Text::BEGIN@34 at line 45
BEGIN {
3318µs if(defined &ASCII) { }
34 elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
35 else { *ASCII = sub () {''} }
36
3713µs unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
38 DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
39160µs16µs unless(MANY_LINES() >= 1) {
# spent 6µs making 1 call to Pod::Simple::__ANON__
40 die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
41 }
42131µs if(defined &UNICODE) { }
43 elsif($] >= 5.008) { *UNICODE = sub() {1} }
44 else { *UNICODE = sub() {''} }
451794µs1108µs}
# spent 108µs making 1 call to Pod::Simple::BEGIN@32
46if(DEBUG > 2) {
47 print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
48 print "# We are under a Unicode-safe Perl.\n";
49}
50
51# Design note:
52# This is a parser for Pod. It is not a parser for the set of Pod-like
53# languages which happens to contain Pod -- it is just for Pod, plus possibly
54# some extensions.
55
56# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
57#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
58#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
59
60__PACKAGE__->_accessorize(
61125µs11.11ms 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters
# spent 1.11ms making 1 call to Pod::Simple::_accessorize
62 'source_filename', # Filename of the source, for use in warnings
63 'source_dead', # Whether to consider this parser's source dead
64
65 'output_fh', # The filehandle we're writing to, if applicable.
66 # Used only in some derived classes.
67
68 'hide_line_numbers', # For some dumping subclasses: whether to pointedly
69 # suppress the start_line attribute
70
71 'line_count', # the current line number
72 'pod_para_count', # count of pod paragraphs seen so far
73
74 'no_whining', # whether to suppress whining
75 'no_errata_section', # whether to suppress the errata section
76 'complain_stderr', # whether to complain to stderr
77
78 'doc_has_started', # whether we've fired the open-Document event yet
79
80 'bare_output', # For some subclasses: whether to prepend
81 # header-code and postpend footer-code
82
83 'nix_X_codes', # whether to ignore X<...> codes
84 'merge_text', # whether to avoid breaking a single piece of
85 # text up into several events
86
87 'preserve_whitespace', # whether to try to keep whitespace as-is
88 'strip_verbatim_indent', # What indent to strip from verbatim
89
90 'content_seen', # whether we've seen any real Pod content
91 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not)
92
93 'codes_in_verbatim', # for PseudoPod extensions
94
95 'code_handler', # coderef to call when a code (non-pod) line is seen
96 'cut_handler', # ... when a =cut line is seen
97 'pod_handler', # ... when a =pod line is seen
98 'whiteline_handler', # ... when a line with only whitespace is seen
99 #Called like:
100 # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
101 # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
102 # $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler;
103 # $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler;
104 'parse_empty_lists', # whether to acknowledge empty =over/=back blocks
105
106);
107
108#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
109
110sub any_errata_seen { # good for using as an exit() value...
111 return shift->{'errors_seen'} || 0;
112}
113
114#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
115# Pull in some functions that, for some reason, I expect to see here too:
116
# spent 33µs within Pod::Simple::BEGIN@116 which was called: # once (33µs+0s) by Pod::Text::BEGIN@34 at line 119
BEGIN {
11718µs *pretty = \&Pod::Simple::BlackBox::pretty;
118128µs *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
119134.0ms133µs}
# spent 33µs making 1 call to Pod::Simple::BEGIN@116
120
121#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
122
123sub version_report {
124 my $class = ref($_[0]) || $_[0];
125 if($class eq __PACKAGE__) {
126 return "$class $VERSION";
127 } else {
128 my $v = $class->VERSION;
129 return "$class $v (" . __PACKAGE__ . " $VERSION)";
130 }
131}
132
133#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
134
135#sub curr_open { # read-only list accessor
136# return @{ $_[0]{'curr_open'} || return() };
137#}
138#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
139
140
141sub output_string {
142 # Works by faking out output_fh. Simplifies our code.
143 #
144 my $this = shift;
145 return $this->{'output_string'} unless @_; # GET.
146
147 require Pod::Simple::TiedOutFH;
148 my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
149 $$x = '' unless defined $$x;
150 DEBUG > 4 and print "# Output string set to $x ($$x)\n";
151 $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
152 return
153 $this->{'output_string'} = $_[0];
154 #${ ${ $this->{'output_fh'} } };
155}
156
157sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
158sub abandon_output_fh { $_[0]->output_fh(undef) }
159# These don't delete the string or close the FH -- they just delete our
160# references to it/them.
161# TODO: document these
162
163#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
164
165sub new {
166 # takes no parameters
167 my $class = ref($_[0]) || $_[0];
168 #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
169 # . __PACKAGE__ );
170 return bless {
171 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
172 'accept_directives' => { %Known_directives },
173 'accept_targets' => {},
174 }, $class;
175}
176
- -
179# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
180
181#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
182
183sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
184 my($self, $element_name, $attr_hash_r) = @_;
185 return;
186}
187
188sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
189 my($self, $element_name) = @_;
190 return;
191}
192
193sub _handle_text { # OVERRIDE IN DERIVED CLASS
194 my($self, $text) = @_;
195 return;
196}
197
198#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
199#
200# And now directives (not targets)
201
202sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
203sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
204sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
205
206sub _accept_directives {
207 my($this, $type) = splice @_,0,2;
208 foreach my $d (@_) {
209 next unless defined $d and length $d;
210 Carp::croak "\"$d\" isn't a valid directive name"
211 unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
212 Carp::croak "\"$d\" is already a reserved Pod directive name"
213 if exists $Known_directives{$d};
214 $this->{'accept_directives'}{$d} = $type;
215 DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
216 }
217 DEBUG > 6 and print "$this\'s accept_directives : ",
218 pretty($this->{'accept_directives'}), "\n";
219
220 return sort keys %{ $this->{'accept_directives'} } if wantarray;
221 return;
222}
223
224#--------------------------------------------------------------------------
225# TODO: document these:
226
227sub unaccept_directive { shift->unaccept_directives(@_) };
228
229sub unaccept_directives {
230 my $this = shift;
231 foreach my $d (@_) {
232 next unless defined $d and length $d;
233 Carp::croak "\"$d\" isn't a valid directive name"
234 unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
235 Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
236 if exists $Known_directives{$d};
237 delete $this->{'accept_directives'}{$d};
238 DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
239 }
240 return sort keys %{ $this->{'accept_directives'} } if wantarray;
241 return
242}
243
244#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
245#
246# And now targets (not directives)
247
248sub accept_target { shift->accept_targets(@_) } # alias
249sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
250
251
252sub accept_targets { shift->_accept_targets('1', @_) }
253
254sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
255 # forces them to be processed, even when there's no ":".
256
257sub _accept_targets {
258 my($this, $type) = splice @_,0,2;
259 foreach my $t (@_) {
260 next unless defined $t and length $t;
261 # TODO: enforce some limitations on what a target name can be?
262 $this->{'accept_targets'}{$t} = $type;
263 DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
264 }
265 return sort keys %{ $this->{'accept_targets'} } if wantarray;
266 return;
267}
268
269#--------------------------------------------------------------------------
270sub unaccept_target { shift->unaccept_targets(@_) }
271
272sub unaccept_targets {
273 my $this = shift;
274 foreach my $t (@_) {
275 next unless defined $t and length $t;
276 # TODO: enforce some limitations on what a target name can be?
277 delete $this->{'accept_targets'}{$t};
278 DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
279 }
280 return sort keys %{ $this->{'accept_targets'} } if wantarray;
281 return;
282}
283
284#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
285#
286# And now codes (not targets or directives)
287
288sub accept_code { shift->accept_codes(@_) } # alias
289
290sub accept_codes { # Add some codes
291 my $this = shift;
292
293 foreach my $new_code (@_) {
294 next unless defined $new_code and length $new_code;
295 if(ASCII) {
296 # A good-enough check that it's good as an XML Name symbol:
297 Carp::croak "\"$new_code\" isn't a valid element name"
298 if $new_code =~
299 m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
300 # Characters under 0x80 that aren't legal in an XML Name.
301 or $new_code =~ m/^[-\.0-9]/s
302 or $new_code =~ m/:[-\.0-9]/s;
303 # The legal under-0x80 Name characters that
304 # an XML Name still can't start with.
305 }
306
307 $this->{'accept_codes'}{$new_code} = $new_code;
308
309 # Yes, map to itself -- just so that when we
310 # see "=extend W [whatever] thatelementname", we say that W maps
311 # to whatever $this->{accept_codes}{thatelementname} is,
312 # i.e., "thatelementname". Then when we go re-mapping,
313 # a "W" in the treelet turns into "thatelementname". We only
314 # remap once.
315 # If we say we accept "W", then a "W" in the treelet simply turns
316 # into "W".
317 }
318
319 return;
320}
321
322#--------------------------------------------------------------------------
323sub unaccept_code { shift->unaccept_codes(@_) }
324
325sub unaccept_codes { # remove some codes
326 my $this = shift;
327
328 foreach my $new_code (@_) {
329 next unless defined $new_code and length $new_code;
330 if(ASCII) {
331 # A good-enough check that it's good as an XML Name symbol:
332 Carp::croak "\"$new_code\" isn't a valid element name"
333 if $new_code =~
334 m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
335 # Characters under 0x80 that aren't legal in an XML Name.
336 or $new_code =~ m/^[-\.0-9]/s
337 or $new_code =~ m/:[-\.0-9]/s;
338 # The legal under-0x80 Name characters that
339 # an XML Name still can't start with.
340 }
341
342 Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
343 if grep $new_code eq $_, @Known_formatting_codes;
344
345 delete $this->{'accept_codes'}{$new_code};
346
347 DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
348 }
349
350 return;
351}
352
353
354#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
355#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
356
357sub parse_string_document {
358 my $self = shift;
359 my @lines;
360 foreach my $line_group (@_) {
361 next unless defined $line_group and length $line_group;
362 pos($line_group) = 0;
363 while($line_group =~
364 m/([^\n\r]*)(\r?\n?)/g # supports \r, \n ,\r\n
365 #m/([^\n\r]*)((?:\r?\n)?)/g
366 ) {
367 #print(">> $1\n"),
368 $self->parse_lines($1)
369 if length($1) or length($2)
370 or pos($line_group) != length($line_group);
371 # I.e., unless it's a zero-length "empty line" at the very
372 # end of "foo\nbar\n" (i.e., between the \n and the EOS).
373 }
374 }
375 $self->parse_lines(undef); # to signal EOF
376 return $self;
377}
378
379sub _init_fh_source {
380 my($self, $source) = @_;
381
382 #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
383 #$self->_apply_binmode($source, ':raw');
384 #binmode($source, ":raw");
385
386 return;
387}
388
389#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
390#
391
392sub parse_file {
393 my($self, $source) = (@_);
394
395 if(!defined $source) {
396 Carp::croak("Can't use empty-string as a source for parse_file");
397 } elsif(ref(\$source) eq 'GLOB') {
398 $self->{'source_filename'} = '' . ($source);
399 } elsif(ref $source) {
400 $self->{'source_filename'} = '' . ($source);
401 } elsif(!length $source) {
402 Carp::croak("Can't use empty-string as a source for parse_file");
403 } else {
404 {
405 local *PODSOURCE;
406 open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
407 $self->{'source_filename'} = $source;
408 $source = *PODSOURCE{IO};
409 }
410 $self->_init_fh_source($source);
411 }
412 # By here, $source is a FH.
413
414 $self->{'source_fh'} = $source;
415
416 my($i, @lines);
417 until( $self->{'source_dead'} ) {
418 splice @lines;
419
420 for($i = MANY_LINES; $i--;) { # read those many lines at a time
421 local $/ = $NL;
422 push @lines, scalar(<$source>); # readline
423 last unless defined $lines[-1];
424 # but pass thru the undef, which will set source_dead to true
425 }
426
427 my $at_eof = ! $lines[-1]; # keep track of the undef
428 pop @lines if $at_eof; # silence warnings
429
430 # be eol agnostic
431 s/\r\n?/\n/g for @lines;
432
433 # make sure there are only one line elements for parse_lines
434 @lines = split(/(?<=\n)/, join('', @lines));
435
436 # push the undef back after popping it to set source_dead to true
437 push @lines, undef if $at_eof;
438
439 $self->parse_lines(@lines);
440 }
441 delete($self->{'source_fh'}); # so it can be GC'd
442 return $self;
443}
444
445#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
446
447sub parse_from_file {
448 # An emulation of Pod::Parser's interface, for the sake of Perldoc.
449 # Basically just a wrapper around parse_file.
450
451 my($self, $source, $to) = @_;
452 $self = $self->new unless ref($self); # so we tolerate being a class method
453
454 if(!defined $source) { $source = *STDIN{IO}
455 } elsif(ref(\$source) eq 'GLOB') { # stet
456 } elsif(ref($source) ) { # stet
457 } elsif(!length $source
458 or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
459 ) {
460 $source = *STDIN{IO};
461 }
462
463 if(!defined $to) { $self->output_fh( *STDOUT{IO} );
464 } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
465 } elsif(ref($to)) { $self->output_fh( $to );
466 } elsif(!length $to
467 or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
468 ) {
469 $self->output_fh( *STDOUT{IO} );
470 } else {
471 require Symbol;
472 my $out_fh = Symbol::gensym();
473 DEBUG and print "Write-opening to $to\n";
474 open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!";
475 binmode($out_fh)
476 if $self->can('write_with_binmode') and $self->write_with_binmode;
477 $self->output_fh($out_fh);
478 }
479
480 return $self->parse_file($source);
481}
482
483#-----------------------------------------------------------------------------
484
485sub whine {
486 #my($self,$line,$complaint) = @_;
487 my $self = shift(@_);
488 ++$self->{'errors_seen'};
489 if($self->{'no_whining'}) {
490 DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
491 return;
492 }
493 return $self->_complain_warn(@_) if $self->{'complain_stderr'};
494 return $self->_complain_errata(@_);
495}
496
497sub scream { # like whine, but not suppressible
498 #my($self,$line,$complaint) = @_;
499 my $self = shift(@_);
500 ++$self->{'errors_seen'};
501 return $self->_complain_warn(@_) if $self->{'complain_stderr'};
502 return $self->_complain_errata(@_);
503}
504
505sub _complain_warn {
506 my($self,$line,$complaint) = @_;
507 return printf STDERR "%s around line %s: %s\n",
508 $self->{'source_filename'} || 'Pod input', $line, $complaint;
509}
510
511sub _complain_errata {
512 my($self,$line,$complaint) = @_;
513 if( $self->{'no_errata_section'} ) {
514 DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
515 } else {
516 DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
517 push @{$self->{'errata'}{$line}}, $complaint
518 # for a report to be generated later!
519 }
520 return 1;
521}
522
523#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
524
525sub _get_initial_item_type {
526 # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
527 my($self, $para) = @_;
528 return $para->[1]{'~type'} if $para->[1]{'~type'};
529
530 return $para->[1]{'~type'} = 'text'
531 if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
532 # Else fall thru to the general case:
533 return $self->_get_item_type($para);
534}
535
- -
538sub _get_item_type { # mutates the item!!
539 my($self, $para) = @_;
540 return $para->[1]{'~type'} if $para->[1]{'~type'};
541
542
543 # Otherwise we haven't yet been to this node. Maybe alter it...
544
545 my $content = join "\n", @{$para}[2 .. $#$para];
546
547 if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
548 # Like: "=item *", "=item * ", "=item"
549 splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
550 $para->[1]{'~orig_content'} = $content;
551 return $para->[1]{'~type'} = 'bullet';
552
553 } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance
554
555 # Like: "=item * Foo bar baz";
556 $para->[1]{'~orig_content'} = $content;
557 $para->[1]{'~_freaky_para_hack'} = $1;
558 DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
559 splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
560 return $para->[1]{'~type'} = 'bullet';
561
562 } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
563 # Like: "=item 1.", "=item 123412"
564
565 $para->[1]{'~orig_content'} = $content;
566 $para->[1]{'number'} = $1; # Yes, stores the number there!
567
568 splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
569 return $para->[1]{'~type'} = 'number';
570
571 } else {
572 # It's anything else.
573 return $para->[1]{'~type'} = 'text';
574
575 }
576}
577
578#-----------------------------------------------------------------------------
579
580sub _make_treelet {
581 my $self = shift; # and ($para, $start_line)
582 my $treelet;
583 if(!@_) {
584 return [''];
585 } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
586 # Hack so we can pass in fake-o pre-cooked paragraphs:
587 # just have the first line be a reference to a ['~Top', {}, ...]
588 # We use this feechure in gen_errata and stuff.
589
590 DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
591 $treelet = $_[0][0];
592 splice @$treelet, 0, 2; # lop the top off
593 return $treelet;
594 } else {
595 $treelet = $self->_treelet_from_formatting_codes(@_);
596 }
597
598 if( $self->_remap_sequences($treelet) ) {
599 $self->_treat_Zs($treelet); # Might as well nix these first
600 $self->_treat_Ls($treelet); # L has to precede E and S
601 $self->_treat_Es($treelet);
602 $self->_treat_Ss($treelet); # S has to come after E
603
604 $self->_wrap_up($treelet); # Nix X's and merge texties
605
606 } else {
607 DEBUG and print "Formatless treelet gets fast-tracked.\n";
608 # Very common case!
609 }
610
611 splice @$treelet, 0, 2; # lop the top off
612
613 return $treelet;
614}
615
616#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
617
618sub _wrap_up {
619 my($self, @stack) = @_;
620 my $nixx = $self->{'nix_X_codes'};
621 my $merge = $self->{'merge_text' };
622 return unless $nixx or $merge;
623
624 DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
625 $merge ? (" Merge mode on\n") : (),
626 $nixx ? (" Nix-X mode on\n") : (),
627 ;
628
629
630 my($i, $treelet);
631 while($treelet = shift @stack) {
632 DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
633 for($i = 2; $i < @$treelet; ++$i) { # iterate over children
634 DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
635 if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
636 DEBUG > 3 and print " Nixing X node at $i\n";
637 splice(@$treelet, $i, 1); # just nix this node (and its descendants)
638 # no need to back-update the counter just yet
639 redo;
640
641 } elsif($merge and $i != 2 and # non-initial
642 !ref $treelet->[$i] and !ref $treelet->[$i - 1]
643 ) {
644 DEBUG > 3 and print " Merging ", $i-1,
645 ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
646 $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
647 DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n";
648 --$i;
649 next;
650 # since we just pulled the possibly last node out from under
651 # ourselves, we can't just redo()
652
653 } elsif( ref $treelet->[$i] ) {
654 DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
655 push @stack, $treelet->[$i];
656
657 if($treelet->[$i][0] eq 'L') {
658 my $thing;
659 foreach my $attrname ('section', 'to') {
660 if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
661 unshift @stack, $thing;
662 DEBUG > 4 and print " +Enqueuing ",
663 pretty( $treelet->[$i][1]{$attrname} ),
664 " as an attribute value to tweak.\n";
665 }
666 }
667 }
668 }
669 }
670 }
671 DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
672
673 return;
674}
675
676#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
677
678sub _remap_sequences {
679 my($self,@stack) = @_;
680
681 if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
682 # VERY common case: abort it.
683 DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
684 return 0;
685 }
686
687 my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
688
689 my $start_line = $stack[0][1]{'start_line'};
690 DEBUG > 2 and printf
691 "\nAbout to start _remap_sequences on treelet from line %s.\n",
692 $start_line || '[?]'
693 ;
694 DEBUG > 3 and print " Map: ",
695 join('; ', map "$_=" . (
696 ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
697 ),
698 sort keys %$map ),
699 ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
700 ? " (all normal)\n" : "\n"
701 ;
702
703 # A recursive algorithm implemented iteratively! Whee!
704
705 my($is, $was, $i, $treelet); # scratch
706 while($treelet = shift @stack) {
707 DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
708 for($i = 2; $i < @$treelet; ++$i) { # iterate over children
709 next unless ref $treelet->[$i]; # text nodes are uninteresting
710
711 DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n";
712
713 $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
714 if( DEBUG > 3 ) {
715 if(!defined $is) {
716 print " Code $was<> is UNKNOWN!\n";
717 } elsif($is eq $was) {
718 DEBUG > 4 and print " Code $was<> stays the same.\n";
719 } else {
720 print " Code $was<> maps to ",
721 ref($is)
722 ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
723 : "tag $is<...>.\n";
724 }
725 }
726
727 if(!defined $is) {
728 $self->whine($start_line, "Deleting unknown formatting code $was<>");
729 $is = $treelet->[$i][0] = '1'; # But saving the children!
730 # I could also insert a leading "$was<" and tailing ">" as
731 # children of this node, but something about that seems icky.
732 }
733 if(ref $is) {
734 my @dynasty = @$is;
735 DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n";
736 $treelet->[$i][0] = pop @dynasty;
737 my $nugget;
738 while(@dynasty) {
739 DEBUG > 4 and printf
740 " Grafting a new %s node between %s and %s\n",
741 $dynasty[-1], $treelet->[0], $treelet->[$i][0],
742 ;
743
744 #$nugget = ;
745 splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
746 # relace node with a new parent
747 }
748 } elsif($is eq '0') {
749 splice(@$treelet, $i, 1); # just nix this node (and its descendants)
750 --$i; # back-update the counter
751 } elsif($is eq '1') {
752 splice(@$treelet, $i, 1 # replace this node with its children!
753 => splice @{ $treelet->[$i] },2
754 # (not catching its first two (non-child) items)
755 );
756 --$i; # back up for new stuff
757 } else {
758 # otherwise it's unremarkable
759 unshift @stack, $treelet->[$i]; # just recurse
760 }
761 }
762 }
763
764 DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
765
766 if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
767 DEBUG and print "Noting that the treelet is now formatless.\n";
768 return 0;
769 }
770 return 1;
771}
772
773# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
774
775sub _ponder_extend {
776
777 # "Go to an extreme, move back to a more comfortable place"
778 # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
779
780 my($self, $para) = @_;
781 my $content = join ' ', splice @$para, 2;
782 $content =~ s/^\s+//s;
783 $content =~ s/\s+$//s;
784
785 DEBUG > 2 and print "Ogling extensor: =extend $content\n";
786
787 if($content =~
788 m/^
789 (\S+) # 1 : new item
790 \s+
791 (\S+) # 2 : fallback(s)
792 (?:\s+(\S+))? # 3 : element name(s)
793 \s*
794 $
795 /xs
796 ) {
797 my $new_letter = $1;
798 my $fallbacks_one = $2;
799 my $elements_one;
800 $elements_one = defined($3) ? $3 : $1;
801
802 DEBUG > 2 and print "Extensor has good syntax.\n";
803
804 unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
805 DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
806 $self->whine(
807 $para->[1]{'start_line'},
808 "You can extend only formatting codes A-Z, not like \"$new_letter\""
809 );
810 return;
811 }
812
813 if(grep $new_letter eq $_, @Known_formatting_codes) {
814 DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
815 $self->whine(
816 $para->[1]{'start_line'},
817 "You can't extend an established code like \"$new_letter\""
818 );
819
820 #TODO: or allow if last bit is same?
821
822 return;
823 }
824
825 unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc.
826 or $fallbacks_one eq '0' or $fallbacks_one eq '1'
827 ) {
828 $self->whine(
829 $para->[1]{'start_line'},
830 "Format for second =extend parameter must be like"
831 . " M or 1 or 0 or M,N or M,N,O but you have it like "
832 . $fallbacks_one
833 );
834 return;
835 }
836
837 unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
838 $self->whine(
839 $para->[1]{'start_line'},
840 "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
841 . $elements_one
842 );
843 return;
844 }
845
846 my @fallbacks = split ',', $fallbacks_one, -1;
847 my @elements = split ',', $elements_one, -1;
848
849 foreach my $f (@fallbacks) {
850 next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
851 DEBUG > 2 and print " Can't fall back on unknown code $f\n";
852 $self->whine(
853 $para->[1]{'start_line'},
854 "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
855 );
856 return;
857 }
858
859 DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
860 @fallbacks, @elements;
861
862 my $canonical_form;
863 foreach my $e (@elements) {
864 if(exists $self->{'accept_codes'}{$e}) {
865 DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
866 $canonical_form = $e;
867 last; # first acceptable elementname wins!
868 } else {
869 DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
870 }
871 }
872
873
874 if( defined $canonical_form ) {
875 # We found a good N => elementname mapping
876 $self->{'accept_codes'}{$new_letter} = $canonical_form;
877 DEBUG > 2 and print
878 "Extensor maps $new_letter => known element $canonical_form.\n";
879 } else {
880 # We have to use the fallback(s), which might be '0', or '1'.
881 $self->{'accept_codes'}{$new_letter}
882 = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
883 DEBUG > 2 and print
884 "Extensor maps $new_letter => fallbacks @fallbacks.\n";
885 }
886
887 } else {
888 DEBUG > 2 and print "Extensor has bad syntax.\n";
889 $self->whine(
890 $para->[1]{'start_line'},
891 "Unknown =extend syntax: $content"
892 )
893 }
894 return;
895}
896
897
898#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
899
900sub _treat_Zs { # Nix Z<...>'s
901 my($self,@stack) = @_;
902
903 my($i, $treelet);
904 my $start_line = $stack[0][1]{'start_line'};
905
906 # A recursive algorithm implemented iteratively! Whee!
907
908 while($treelet = shift @stack) {
909 for($i = 2; $i < @$treelet; ++$i) { # iterate over children
910 next unless ref $treelet->[$i]; # text nodes are uninteresting
911 unless($treelet->[$i][0] eq 'Z') {
912 unshift @stack, $treelet->[$i]; # recurse
913 next;
914 }
915
916 DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
917
918 # bitch UNLESS it's empty
919 unless( @{$treelet->[$i]} == 2
920 or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
921 ) {
922 $self->whine( $start_line, "A non-empty Z<>" );
923 } # but kill it anyway
924
925 splice(@$treelet, $i, 1); # thereby just nix this node.
926 --$i;
927
928 }
929 }
930
931 return;
932}
933
934# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
935
936# Quoting perlpodspec:
937
938# In parsing an L<...> code, Pod parsers must distinguish at least four
939# attributes:
940
941############# Not used. Expressed via the element children plus
942############# the value of the "content-implicit" flag.
943# First:
944# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
945# Functions|perlfunc>", the link-text is "Perl Functions". In
946# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
947# that link text may contain formatting.)
948#
949
950############# The element children
951# Second:
952# The possibly inferred link-text -- i.e., if there was no real link text,
953# then this is the text that we'll infer in its place. (E.g., for
954# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
955#
956
957############# The "to" attribute (which might be text, or a treelet)
958# Third:
959# The name or URL, or undef if none. (E.g., in "L<Perl
960# Functions|perlfunc>", the name -- also sometimes called the page -- is
961# "perlfunc". In "L</CAVEATS>", the name is undef.)
962#
963
964############# The "section" attribute (which might be next, or a treelet)
965# Fourth:
966# The section (AKA "item" in older perlpods), or undef if none. E.g., in
967# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
968# is not the same as a manpage section like the "5" in "man 5 crontab".
969# "Section Foo" in the Pod sense means the part of the text that's
970# introduced by the heading or item whose text is "Foo".)
971#
972# Pod parsers may also note additional attributes including:
973#
974
975############# The "type" attribute.
976# Fifth:
977# A flag for whether item 3 (if present) is a URL (like
978# "http://lists.perl.org" is), in which case there should be no section
979# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
980# possibly a man page name (like "crontab(5)" is).
981#
982
983############# The "raw" attribute that is already there.
984# Sixth:
985# The raw original L<...> content, before text is split on "|", "/", etc,
986# and before E<...> codes are expanded.
987
988
989# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
990# occur -- no other formatting codes. That is, authors should not use
991# "L<B<Foo::Bar>>".
992#
993# Note, however, that formatting codes and Z<>'s can occur in any and all
994# parts of an L<...> (i.e., in name, section, text, and url).
995
996sub _treat_Ls { # Process our dear dear friends, the L<...> sequences
997
998 # L<name>
999 # L<name/"sec"> or L<name/sec>
1000 # L</"sec"> or L</sec> or L<"sec">
1001 # L<text|name>
1002 # L<text|name/"sec"> or L<text|name/sec>
1003 # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
1004 # L<scheme:...>
1005 # L<text|scheme:...>
1006
1007 my($self,@stack) = @_;
1008
1009 my($i, $treelet);
1010 my $start_line = $stack[0][1]{'start_line'};
1011
1012 # A recursive algorithm implemented iteratively! Whee!
1013
1014 while($treelet = shift @stack) {
1015 for(my $i = 2; $i < @$treelet; ++$i) {
1016 # iterate over children of current tree node
1017 next unless ref $treelet->[$i]; # text nodes are uninteresting
1018 unless($treelet->[$i][0] eq 'L') {
1019 unshift @stack, $treelet->[$i]; # recurse
1020 next;
1021 }
1022
1023
1024 # By here, $treelet->[$i] is definitely an L node
1025 my $ell = $treelet->[$i];
1026 DEBUG > 1 and print "Ogling L node $ell\n";
1027
1028 # bitch if it's empty
1029 if( @{$ell} == 2
1030 or (@{$ell} == 3 and $ell->[2] eq '')
1031 ) {
1032 $self->whine( $start_line, "An empty L<>" );
1033 $treelet->[$i] = 'L<>'; # just make it a text node
1034 next; # and move on
1035 }
1036
1037 # Catch URLs:
1038
1039 # there are a number of possible cases:
1040 # 1) text node containing url: http://foo.com
1041 # -> [ 'http://foo.com' ]
1042 # 2) text node containing url and text: foo|http://foo.com
1043 # -> [ 'foo|http://foo.com' ]
1044 # 3) text node containing url start: mailto:xE<at>foo.com
1045 # -> [ 'mailto:x', [ E ... ], 'foo.com' ]
1046 # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
1047 # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
1048 # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
1049 # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
1050 # ... etc.
1051
1052 # anything before the url is part of the text.
1053 # anything after it is part of the url.
1054 # the url text node itself may contain parts of both.
1055
1056 if (my ($url_index, $text_part, $url_part) =
1057 # grep is no good here; we want to bail out immediately so that we can
1058 # use $1, $2, etc. without having to do the match twice.
1059 sub {
1060 for (2..$#$ell) {
1061 next if ref $ell->[$_];
1062 next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
1063 return ($_, $1, $2);
1064 }
1065 return;
1066 }->()
1067 ) {
1068 $ell->[1]{'type'} = 'url';
1069
1070 my @text = @{$ell}[2..$url_index-1];
1071 push @text, $text_part if defined $text_part;
1072
1073 my @url = @{$ell}[$url_index+1..$#$ell];
1074 unshift @url, $url_part;
1075
1076 unless (@text) {
1077 $ell->[1]{'content-implicit'} = 'yes';
1078 @text = @url;
1079 }
1080
1081 $ell->[1]{to} = Pod::Simple::LinkSection->new(
1082 @url == 1
1083 ? $url[0]
1084 : [ '', {}, @url ],
1085 );
1086
1087 splice @$ell, 2, $#$ell, @text;
1088
1089 next;
1090 }
1091
1092 # Catch some very simple and/or common cases
1093 if(@{$ell} == 3 and ! ref $ell->[2]) {
1094 my $it = $ell->[2];
1095 if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
1096 # Hopefully neither too broad nor too restrictive a RE
1097 DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
1098 $ell->[1]{'type'} = 'man';
1099 # This's the only place where man links can get made.
1100 $ell->[1]{'content-implicit'} = 'yes';
1101 $ell->[1]{'to' } =
1102 Pod::Simple::LinkSection->new( $it ); # treelet!
1103
1104 next;
1105 }
1106 if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
1107 # Extremely forgiving idea of what constitutes a bare
1108 # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
1109 DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
1110 $ell->[1]{'type'} = 'pod';
1111 $ell->[1]{'content-implicit'} = 'yes';
1112 $ell->[1]{'to' } =
1113 Pod::Simple::LinkSection->new( $it ); # treelet!
1114 next;
1115 }
1116 # else fall thru...
1117 }
1118
1119
1120
1121 # ...Uhoh, here's the real L<...> parsing stuff...
1122 # "With the ill behavior, with the ill behavior, with the ill behavior..."
1123
1124 DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
1125
1126
1127 my $link_text; # set to an arrayref if found
1128 my @ell_content = @$ell;
1129 splice @ell_content,0,2; # Knock off the 'L' and {} bits
1130
1131 DEBUG > 3 and print " Ell content to start: ",
1132 pretty(@ell_content), "\n";
1133
1134
1135 # Look for the "|" -- only in CHILDREN (not all underlings!)
1136 # Like L<I like the strictness|strict>
1137 DEBUG > 3 and
1138 print " Peering at L content for a '|' ...\n";
1139 for(my $j = 0; $j < @ell_content; ++$j) {
1140 next if ref $ell_content[$j];
1141 DEBUG > 3 and
1142 print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
1143
1144 if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
1145 my @link_text = ($1); # might be 0-length
1146 $ell_content[$j] = $2; # might be 0-length
1147
1148 DEBUG > 3 and
1149 print " FOUND a '|' in it. Splitting into [$1] + [$2]\n";
1150
1151 unshift @link_text, splice @ell_content, 0, $j;
1152 # leaving only things at J and after
1153 @ell_content = grep ref($_)||length($_), @ell_content ;
1154 $link_text = [grep ref($_)||length($_), @link_text ];
1155 DEBUG > 3 and printf
1156 " So link text is %s\n and remaining ell content is %s\n",
1157 pretty($link_text), pretty(@ell_content);
1158 last;
1159 }
1160 }
1161
1162
1163 # Now look for the "/" -- only in CHILDREN (not all underlings!)
1164 # And afterward, anything left in @ell_content will be the raw name
1165 # Like L<Foo::Bar/Object Methods>
1166 my $section_name; # set to arrayref if found
1167 DEBUG > 3 and print " Peering at L-content for a '/' ...\n";
1168 for(my $j = 0; $j < @ell_content; ++$j) {
1169 next if ref $ell_content[$j];
1170 DEBUG > 3 and
1171 print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
1172
1173 if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
1174 my @section_name = ($2); # might be 0-length
1175 $ell_content[$j] = $1; # might be 0-length
1176
1177 DEBUG > 3 and
1178 print " FOUND a '/' in it.",
1179 " Splitting to page [...$1] + section [$2...]\n";
1180
1181 push @section_name, splice @ell_content, 1+$j;
1182 # leaving only things before and including J
1183
1184 @ell_content = grep ref($_)||length($_), @ell_content ;
1185 @section_name = grep ref($_)||length($_), @section_name ;
1186
1187 # Turn L<.../"foo"> into L<.../foo>
1188 if(@section_name
1189 and !ref($section_name[0]) and !ref($section_name[-1])
1190 and $section_name[ 0] =~ m/^\"/s
1191 and $section_name[-1] =~ m/\"$/s
1192 and !( # catch weird degenerate case of L<"> !
1193 @section_name == 1 and $section_name[0] eq '"'
1194 )
1195 ) {
1196 $section_name[ 0] =~ s/^\"//s;
1197 $section_name[-1] =~ s/\"$//s;
1198 DEBUG > 3 and
1199 print " Quotes removed: ", pretty(@section_name), "\n";
1200 } else {
1201 DEBUG > 3 and
1202 print " No need to remove quotes in ", pretty(@section_name), "\n";
1203 }
1204
1205 $section_name = \@section_name;
1206 last;
1207 }
1208 }
1209
1210 # Turn L<"Foo Bar"> into L</Foo Bar>
1211 if(!$section_name and @ell_content
1212 and !ref($ell_content[0]) and !ref($ell_content[-1])
1213 and $ell_content[ 0] =~ m/^\"/s
1214 and $ell_content[-1] =~ m/\"$/s
1215 and !( # catch weird degenerate case of L<"> !
1216 @ell_content == 1 and $ell_content[0] eq '"'
1217 )
1218 ) {
1219 $section_name = [splice @ell_content];
1220 $section_name->[ 0] =~ s/^\"//s;
1221 $section_name->[-1] =~ s/\"$//s;
1222 }
1223
1224 # Turn L<Foo Bar> into L</Foo Bar>.
1225 if(!$section_name and !$link_text and @ell_content
1226 and grep !ref($_) && m/ /s, @ell_content
1227 ) {
1228 $section_name = [splice @ell_content];
1229 # That's support for the now-deprecated syntax.
1230 # (Maybe generate a warning eventually?)
1231 # Note that it deliberately won't work on L<...|Foo Bar>
1232 }
1233
1234
1235 # Now make up the link_text
1236 # L<Foo> -> L<Foo|Foo>
1237 # L</Bar> -> L<"Bar"|Bar>
1238 # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
1239 unless($link_text) {
1240 $ell->[1]{'content-implicit'} = 'yes';
1241 $link_text = [];
1242 push @$link_text, '"', @$section_name, '"' if $section_name;
1243
1244 if(@ell_content) {
1245 $link_text->[-1] .= ' in ' if $section_name;
1246 push @$link_text, @ell_content;
1247 }
1248 }
1249
1250
1251 # And the E resolver will have to deal with all our treeletty things:
1252
1253 if(@ell_content == 1 and !ref($ell_content[0])
1254 and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
1255 ) {
1256 $ell->[1]{'type'} = 'man';
1257 DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
1258 } else {
1259 $ell->[1]{'type'} = 'pod';
1260 DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
1261 }
1262
1263 if( defined $section_name ) {
1264 $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
1265 ['', {}, @$section_name]
1266 );
1267 DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
1268 }
1269
1270 if( @ell_content ) {
1271 $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
1272 ['', {}, @ell_content]
1273 );
1274 DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
1275 }
1276
1277 # And update children to be the link-text:
1278 @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
1279
1280 DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
1281
1282 unshift @stack, $treelet->[$i]; # might as well recurse
1283 }
1284 }
1285
1286 return;
1287}
1288
1289# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1290
1291sub _treat_Es {
1292 my($self,@stack) = @_;
1293
1294 my($i, $treelet, $content, $replacer, $charnum);
1295 my $start_line = $stack[0][1]{'start_line'};
1296
1297 # A recursive algorithm implemented iteratively! Whee!
1298
1299
1300 # Has frightening side effects on L nodes' attributes.
1301
1302 #my @ells_to_tweak;
1303
1304 while($treelet = shift @stack) {
1305 for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
1306 next unless ref $treelet->[$i]; # text nodes are uninteresting
1307 if($treelet->[$i][0] eq 'L') {
1308 # SPECIAL STUFF for semi-processed L<>'s
1309
1310 my $thing;
1311 foreach my $attrname ('section', 'to') {
1312 if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
1313 unshift @stack, $thing;
1314 DEBUG > 2 and print " Enqueuing ",
1315 pretty( $treelet->[$i][1]{$attrname} ),
1316 " as an attribute value to tweak.\n";
1317 }
1318 }
1319
1320 unshift @stack, $treelet->[$i]; # recurse
1321 next;
1322 } elsif($treelet->[$i][0] ne 'E') {
1323 unshift @stack, $treelet->[$i]; # recurse
1324 next;
1325 }
1326
1327 DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
1328
1329 # bitch if it's empty
1330 if( @{$treelet->[$i]} == 2
1331 or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
1332 ) {
1333 $self->whine( $start_line, "An empty E<>" );
1334 $treelet->[$i] = 'E<>'; # splice in a literal
1335 next;
1336 }
1337
1338 # bitch if content is weird
1339 unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
1340 $self->whine( $start_line, "An E<...> surrounding strange content" );
1341 $replacer = $treelet->[$i]; # scratch
1342 splice(@$treelet, $i, 1, # fake out a literal
1343 'E<',
1344 splice(@$replacer,2), # promote its content
1345 '>'
1346 );
1347 # Don't need to do --$i, as the 'E<' we just added isn't interesting.
1348 next;
1349 }
1350
1351 DEBUG > 1 and print "Ogling E<$content>\n";
1352
1353 # XXX E<>'s contents *should* be a valid char in the scope of the current
1354 # =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the
1355 # future sometime.
1356
1357 $charnum = Pod::Escapes::e2charnum($content);
1358 DEBUG > 1 and print " Considering E<$content> with char ",
1359 defined($charnum) ? $charnum : "undef", ".\n";
1360
1361 if(!defined( $charnum )) {
1362 DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
1363 $self->whine( $start_line, "Unknown E content in E<$content>" );
1364 $replacer = "E<$content>"; # better than nothing
1365 } elsif($charnum >= 255 and !UNICODE) {
1366 $replacer = ASCII ? "\xA4" : "?";
1367 DEBUG > 1 and print "This Perl version can't handle ",
1368 "E<$content> (chr $charnum), so replacing with $replacer\n";
1369 } else {
1370 $replacer = Pod::Escapes::e2char($content);
1371 DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
1372 }
1373
1374 splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
1375 }
1376 }
1377
1378 return;
1379}
1380
1381
1382# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1383
1384sub _treat_Ss {
1385 my($self,$treelet) = @_;
1386
1387 _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
1388
1389 # TODO: or a change_nbsp_to_S
1390 # Normalizing nbsp's to S is harder: for each text node, make S content
1391 # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
1392
1393
1394 return;
1395}
1396
1397
1398sub _change_S_to_nbsp { # a recursive function
1399 # Sanely assumes that the top node in the excursion won't be an S node.
1400 my($treelet, $in_s) = @_;
1401
1402 my $is_s = ('S' eq $treelet->[0]);
1403 $in_s ||= $is_s; # So in_s is on either by this being an S element,
1404 # or by an ancestor being an S element.
1405
1406 for(my $i = 2; $i < @$treelet; ++$i) {
1407 if(ref $treelet->[$i]) {
1408 if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
1409 my $to_pull_up = $treelet->[$i];
1410 splice @$to_pull_up,0,2; # ...leaving just its content
1411 splice @$treelet, $i, 1, @$to_pull_up; # Pull up content
1412 $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff
1413 }
1414 } else {
1415 $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
1416 # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
1417
1418 # Note that if you apply nbsp_for_S to text, and so turn
1419 # "foo S<bar baz> quux" into "foo bar&#160;faz quux", you
1420 # end up with something that fails to say "and don't hyphenate
1421 # any part of 'bar baz'". However, hyphenation is such a vexing
1422 # problem anyway, that most Pod renderers just don't render it
1423 # at all. But if you do want to implement hyphenation, I guess
1424 # that you'd better have nbsp_for_S off.
1425 }
1426 }
1427
1428 return $is_s;
1429}
1430
1431#-----------------------------------------------------------------------------
1432
1433
# spent 1.11ms (1.04+71µs) within Pod::Simple::_accessorize which was called: # once (1.04ms+71µs) by Pod::Text::BEGIN@34 at line 61
sub _accessorize { # A simple-minded method-maker
14342333µs2253µs
# spent 158µs (62+95) within Pod::Simple::BEGIN@1434 which was called: # once (62µs+95µs) by Pod::Text::BEGIN@34 at line 1434
no strict 'refs';
# spent 158µs making 1 call to Pod::Simple::BEGIN@1434 # spent 95µs making 1 call to strict::unimport
1435110µs foreach my $attrname (@_) {
143625362µs2570µs next if $attrname =~ m/::/; # a hack
# spent 70µs making 25 calls to Pod::Simple::CORE:match, avg 3µs/call
1437 *{caller() . '::' . $attrname} = sub {
143822.71ms2241µs
# spent 155µs (69+86) within Pod::Simple::BEGIN@1438 which was called: # once (69µs+86µs) by Pod::Text::BEGIN@34 at line 1438
use strict;
# spent 155µs making 1 call to Pod::Simple::BEGIN@1438 # spent 86µs making 1 call to strict::import
1439 $Carp::CarpLevel = 1, Carp::croak(
1440 "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
1441 ) unless (@_ == 1 or @_ == 2) and ref $_[0];
1442 (@_ == 1) ? $_[0]->{$attrname}
1443 : ($_[0]->{$attrname} = $_[1]);
144424719µs };
1445 }
1446 # Ya know, they say accessories make the ensemble!
1447131µs return;
1448}
1449
1450# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1451# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1452#=============================================================================
1453
1454sub filter {
1455 my($class, $source) = @_;
1456 my $new = $class->new;
1457 $new->output_fh(*STDOUT{IO});
1458
1459 if(ref($source || '') eq 'SCALAR') {
1460 $new->parse_string_document( $$source );
1461 } elsif(ref($source)) { # it's a file handle
1462 $new->parse_file($source);
1463 } else { # it's a filename
1464 $new->parse_file($source);
1465 }
1466
1467 return $new;
1468}
1469
1470
1471#-----------------------------------------------------------------------------
1472
1473sub _out {
1474 # For use in testing: Class->_out($source)
1475 # returns the transformation of $source
1476
1477 my $class = shift(@_);
1478
1479 my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
1480
1481 DEBUG and print "\n\n", '#' x 76,
1482 "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
1483
1484
1485 my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
1486 $parser->hide_line_numbers(1);
1487
1488 my $out = '';
1489 $parser->output_string( \$out );
1490 DEBUG and print " _out to ", \$out, "\n";
1491
1492 $mutor->($parser) if $mutor;
1493
1494 $parser->parse_string_document( $_[0] );
1495 # use Data::Dumper; print Dumper($parser), "\n";
1496 return $out;
1497}
1498
1499
1500sub _duo {
1501 # For use in testing: Class->_duo($source1, $source2)
1502 # returns the parse trees of $source1 and $source2.
1503 # Good in things like: &ok( Class->duo(... , ...) );
1504
1505 my $class = shift(@_);
1506
1507 Carp::croak "But $class->_duo is useful only in list context!"
1508 unless wantarray;
1509
1510 my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
1511
1512 Carp::croak "But $class->_duo takes two parameters, not: @_"
1513 unless @_ == 2;
1514
1515 my(@out);
1516
1517 while( @_ ) {
1518 my $parser = $class->new;
1519
1520 push @out, '';
1521 $parser->output_string( \( $out[-1] ) );
1522
1523 DEBUG and print " _duo out to ", $parser->output_string(),
1524 " = $parser->{'output_string'}\n";
1525
1526 $parser->hide_line_numbers(1);
1527 $mutor->($parser) if $mutor;
1528 $parser->parse_string_document( shift( @_ ) );
1529 # use Data::Dumper; print Dumper($parser), "\n";
1530 }
1531
1532 return @out;
1533}
1534
- -
1537#-----------------------------------------------------------------------------
1538157µs1;
1539__END__
 
# spent 70µs within Pod::Simple::CORE:match which was called 25 times, avg 3µs/call: # 25 times (70µs+0s) by Pod::Simple::_accessorize at line 1436, avg 3µs/call
sub Pod::Simple::CORE:match; # opcode
# spent 6µs within Pod::Simple::__ANON__ which was called: # once (6µs+0s) by Pod::Simple::BEGIN@32 at line 39
sub Pod::Simple::__ANON__; # xsub
Report produced by the NYTProf 5.05 Perl profiler, developed by Tim Bunce and Adam Kaplan.