← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:10 2023

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