← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:10 2016

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