← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 03:09:29 2017
Reported on Mon Nov 6 13:20:45 2017

Filename/usr/local/lib/perl5/5.24/Pod/Text.pm
StatementsExecuted 20 statements in 8.21ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11116.5ms48.6msPod::Text::::BEGIN@35Pod::Text::BEGIN@35
1117.60ms17.2msPod::Text::::BEGIN@33Pod::Text::BEGIN@33
11144µs44µsPod::Text::::BEGIN@26Pod::Text::BEGIN@26
11134µs71µsPod::Text::::BEGIN@28Pod::Text::BEGIN@28
11122µs32µsPod::Text::::BEGIN@27Pod::Text::BEGIN@27
11121µs238µsPod::Text::::BEGIN@32Pod::Text::BEGIN@32
11121µs209µsPod::Text::::BEGIN@30Pod::Text::BEGIN@30
11112µs12µsPod::Text::::BEGIN@34Pod::Text::BEGIN@34
0000s0sPod::Text::::_handle_element_endPod::Text::_handle_element_end
0000s0sPod::Text::::_handle_element_startPod::Text::_handle_element_start
0000s0sPod::Text::::_handle_textPod::Text::_handle_text
0000s0sPod::Text::::cmd_bPod::Text::cmd_b
0000s0sPod::Text::::cmd_cPod::Text::cmd_c
0000s0sPod::Text::::cmd_dataPod::Text::cmd_data
0000s0sPod::Text::::cmd_fPod::Text::cmd_f
0000s0sPod::Text::::cmd_head1Pod::Text::cmd_head1
0000s0sPod::Text::::cmd_head2Pod::Text::cmd_head2
0000s0sPod::Text::::cmd_head3Pod::Text::cmd_head3
0000s0sPod::Text::::cmd_head4Pod::Text::cmd_head4
0000s0sPod::Text::::cmd_iPod::Text::cmd_i
0000s0sPod::Text::::cmd_item_blockPod::Text::cmd_item_block
0000s0sPod::Text::::cmd_item_bulletPod::Text::cmd_item_bullet
0000s0sPod::Text::::cmd_item_numberPod::Text::cmd_item_number
0000s0sPod::Text::::cmd_item_textPod::Text::cmd_item_text
0000s0sPod::Text::::cmd_lPod::Text::cmd_l
0000s0sPod::Text::::cmd_paraPod::Text::cmd_para
0000s0sPod::Text::::cmd_verbatimPod::Text::cmd_verbatim
0000s0sPod::Text::::cmd_xPod::Text::cmd_x
0000s0sPod::Text::::end_documentPod::Text::end_document
0000s0sPod::Text::::end_over_blockPod::Text::end_over_block
0000s0sPod::Text::::end_over_bulletPod::Text::end_over_bullet
0000s0sPod::Text::::end_over_numberPod::Text::end_over_number
0000s0sPod::Text::::end_over_textPod::Text::end_over_text
0000s0sPod::Text::::handle_codePod::Text::handle_code
0000s0sPod::Text::::headingPod::Text::heading
0000s0sPod::Text::::itemPod::Text::item
0000s0sPod::Text::::item_commonPod::Text::item_common
0000s0sPod::Text::::method_for_elementPod::Text::method_for_element
0000s0sPod::Text::::newPod::Text::new
0000s0sPod::Text::::outputPod::Text::output
0000s0sPod::Text::::output_codePod::Text::output_code
0000s0sPod::Text::::over_common_endPod::Text::over_common_end
0000s0sPod::Text::::over_common_startPod::Text::over_common_start
0000s0sPod::Text::::parse_filePod::Text::parse_file
0000s0sPod::Text::::parse_from_filePod::Text::parse_from_file
0000s0sPod::Text::::parse_from_filehandlePod::Text::parse_from_filehandle
0000s0sPod::Text::::parse_linesPod::Text::parse_lines
0000s0sPod::Text::::parse_string_documentPod::Text::parse_string_document
0000s0sPod::Text::::pod2textPod::Text::pod2text
0000s0sPod::Text::::reformatPod::Text::reformat
0000s0sPod::Text::::start_documentPod::Text::start_document
0000s0sPod::Text::::start_over_blockPod::Text::start_over_block
0000s0sPod::Text::::start_over_bulletPod::Text::start_over_bullet
0000s0sPod::Text::::start_over_numberPod::Text::start_over_number
0000s0sPod::Text::::start_over_textPod::Text::start_over_text
0000s0sPod::Text::::strip_formatPod::Text::strip_format
0000s0sPod::Text::::wrapPod::Text::wrap
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# Pod::Text -- Convert POD data to formatted text.
2#
3# This module converts POD to formatted text. It replaces the old Pod::Text
4# module that came with versions of Perl prior to 5.6.0 and attempts to match
5# its output except for some specific circumstances where other decisions
6# seemed to produce better output. It uses Pod::Parser and is designed to be
7# very easy to subclass.
8#
9# Perl core hackers, please note that this module is also separately
10# maintained outside of the Perl core as part of the podlators. Please send
11# me any patches at the address above in addition to sending them to the
12# standard Perl mailing lists.
13#
14# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2014,
15# 2015 Russ Allbery <rra@cpan.org>
16#
17# This program is free software; you may redistribute it and/or modify it
18# under the same terms as Perl itself.
19
20##############################################################################
21# Modules and declarations
22##############################################################################
23
24package Pod::Text;
25
26296µs144µs
# spent 44µs within Pod::Text::BEGIN@26 which was called: # once (44µs+0s) by Pod::Usage::BEGIN@25 at line 26
use 5.006;
# spent 44µs making 1 call to Pod::Text::BEGIN@26
27276µs243µs
# spent 32µs (22+10) within Pod::Text::BEGIN@27 which was called: # once (22µs+10µs) by Pod::Usage::BEGIN@25 at line 27
use strict;
# spent 32µs making 1 call to Pod::Text::BEGIN@27 # spent 10µs making 1 call to strict::import
282107µs2107µs
# spent 71µs (34+36) within Pod::Text::BEGIN@28 which was called: # once (34µs+36µs) by Pod::Usage::BEGIN@25 at line 28
use warnings;
# spent 71µs making 1 call to Pod::Text::BEGIN@28 # spent 36µs making 1 call to warnings::import
29
30262µs2398µs
# spent 209µs (21+189) within Pod::Text::BEGIN@30 which was called: # once (21µs+189µs) by Pod::Usage::BEGIN@25 at line 30
use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
# spent 209µs making 1 call to Pod::Text::BEGIN@30 # spent 189µs making 1 call to vars::import
31
32259µs2455µs
# spent 238µs (21+217) within Pod::Text::BEGIN@32 which was called: # once (21µs+217µs) by Pod::Usage::BEGIN@25 at line 32
use Carp qw(carp croak);
# spent 238µs making 1 call to Pod::Text::BEGIN@32 # spent 217µs making 1 call to Exporter::import
332325µs217.7ms
# spent 17.2ms (7.60+9.65) within Pod::Text::BEGIN@33 which was called: # once (7.60ms+9.65ms) by Pod::Usage::BEGIN@25 at line 33
use Encode qw(encode);
# spent 17.2ms making 1 call to Pod::Text::BEGIN@33 # spent 426µs making 1 call to Exporter::import
34246µs112µs
# spent 12µs within Pod::Text::BEGIN@34 which was called: # once (12µs+0s) by Pod::Usage::BEGIN@25 at line 34
use Exporter ();
# spent 12µs making 1 call to Pod::Text::BEGIN@34
3527.40ms148.6ms
# spent 48.6ms (16.5+32.1) within Pod::Text::BEGIN@35 which was called: # once (16.5ms+32.1ms) by Pod::Usage::BEGIN@25 at line 35
use Pod::Simple ();
# spent 48.6ms making 1 call to Pod::Text::BEGIN@35
36
37121µs@ISA = qw(Pod::Simple Exporter);
38
39# We have to export pod2text for backward compatibility.
4012µs@EXPORT = qw(pod2text);
41
4212µs$VERSION = '4.07';
43
44##############################################################################
45# Initialization
46##############################################################################
47
48# This function handles code blocks. It's registered as a callback to
49# Pod::Simple and therefore doesn't work as a regular method call, but all it
50# does is call output_code with the line.
51sub handle_code {
52 my ($line, $number, $parser) = @_;
53 $parser->output_code ($line . "\n");
54}
55
56# Initialize the object and set various Pod::Simple options that we need.
57# Here, we also process any additional options passed to the constructor or
58# set up defaults if none were given. Note that all internal object keys are
59# in all-caps, reserving all lower-case object keys for Pod::Simple and user
60# arguments.
61sub new {
62 my $class = shift;
63 my $self = $class->SUPER::new;
64
65 # Tell Pod::Simple to handle S<> by automatically inserting &nbsp;.
66 $self->nbsp_for_S (1);
67
68 # Tell Pod::Simple to keep whitespace whenever possible.
69 if ($self->can ('preserve_whitespace')) {
70 $self->preserve_whitespace (1);
71 } else {
72 $self->fullstop_space_harden (1);
73 }
74
75 # The =for and =begin targets that we accept.
76 $self->accept_targets (qw/text TEXT/);
77
78 # Ensure that contiguous blocks of code are merged together. Otherwise,
79 # some of the guesswork heuristics don't work right.
80 $self->merge_text (1);
81
82 # Pod::Simple doesn't do anything useful with our arguments, but we want
83 # to put them in our object as hash keys and values. This could cause
84 # problems if we ever clash with Pod::Simple's own internal class
85 # variables.
86 my %opts = @_;
87 my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
88 %$self = (%$self, @opts);
89
90 # Send errors to stderr if requested.
91 if ($$self{opt_stderr} and not $$self{opt_errors}) {
92 $$self{opt_errors} = 'stderr';
93 }
94 delete $$self{opt_stderr};
95
96 # Validate the errors parameter and act on it.
97 if (not defined $$self{opt_errors}) {
98 $$self{opt_errors} = 'pod';
99 }
100 if ($$self{opt_errors} eq 'stderr' || $$self{opt_errors} eq 'die') {
101 $self->no_errata_section (1);
102 $self->complain_stderr (1);
103 if ($$self{opt_errors} eq 'die') {
104 $$self{complain_die} = 1;
105 }
106 } elsif ($$self{opt_errors} eq 'pod') {
107 $self->no_errata_section (0);
108 $self->complain_stderr (0);
109 } elsif ($$self{opt_errors} eq 'none') {
110 $self->no_whining (1);
111 } else {
112 croak (qq(Invalid errors setting: "$$self{errors}"));
113 }
114 delete $$self{errors};
115
116 # Initialize various things from our parameters.
117 $$self{opt_alt} = 0 unless defined $$self{opt_alt};
118 $$self{opt_indent} = 4 unless defined $$self{opt_indent};
119 $$self{opt_margin} = 0 unless defined $$self{opt_margin};
120 $$self{opt_loose} = 0 unless defined $$self{opt_loose};
121 $$self{opt_sentence} = 0 unless defined $$self{opt_sentence};
122 $$self{opt_width} = 76 unless defined $$self{opt_width};
123
124 # Figure out what quotes we'll be using for C<> text.
125 $$self{opt_quotes} ||= '"';
126 if ($$self{opt_quotes} eq 'none') {
127 $$self{LQUOTE} = $$self{RQUOTE} = '';
128 } elsif (length ($$self{opt_quotes}) == 1) {
129 $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
130 } elsif (length ($$self{opt_quotes}) % 2 == 0) {
131 my $length = length ($$self{opt_quotes}) / 2;
132 $$self{LQUOTE} = substr ($$self{opt_quotes}, 0, $length);
133 $$self{RQUOTE} = substr ($$self{opt_quotes}, $length);
134 } else {
135 croak qq(Invalid quote specification "$$self{opt_quotes}");
136 }
137
138 # If requested, do something with the non-POD text.
139 $self->code_handler (\&handle_code) if $$self{opt_code};
140
141 # Return the created object.
142 return $self;
143}
144
145##############################################################################
146# Core parsing
147##############################################################################
148
149# This is the glue that connects the code below with Pod::Simple itself. The
150# goal is to convert the event stream coming from the POD parser into method
151# calls to handlers once the complete content of a tag has been seen. Each
152# paragraph or POD command will have textual content associated with it, and
153# as soon as all of a paragraph or POD command has been seen, that content
154# will be passed in to the corresponding method for handling that type of
155# object. The exceptions are handlers for lists, which have opening tag
156# handlers and closing tag handlers that will be called right away.
157#
158# The internal hash key PENDING is used to store the contents of a tag until
159# all of it has been seen. It holds a stack of open tags, each one
160# represented by a tuple of the attributes hash for the tag and the contents
161# of the tag.
162
163# Add a block of text to the contents of the current node, formatting it
164# according to the current formatting instructions as we do.
165sub _handle_text {
166 my ($self, $text) = @_;
167 my $tag = $$self{PENDING}[-1];
168 $$tag[1] .= $text;
169}
170
171# Given an element name, get the corresponding method name.
172sub method_for_element {
173 my ($self, $element) = @_;
174 $element =~ tr/-/_/;
175 $element =~ tr/A-Z/a-z/;
176 $element =~ tr/_a-z0-9//cd;
177 return $element;
178}
179
180# Handle the start of a new element. If cmd_element is defined, assume that
181# we need to collect the entire tree for this element before passing it to the
182# element method, and create a new tree into which we'll collect blocks of
183# text and nested elements. Otherwise, if start_element is defined, call it.
184sub _handle_element_start {
185 my ($self, $element, $attrs) = @_;
186 my $method = $self->method_for_element ($element);
187
188 # If we have a command handler, we need to accumulate the contents of the
189 # tag before calling it.
190 if ($self->can ("cmd_$method")) {
191 push (@{ $$self{PENDING} }, [ $attrs, '' ]);
192 } elsif ($self->can ("start_$method")) {
193 my $method = 'start_' . $method;
194 $self->$method ($attrs, '');
195 }
196}
197
198# Handle the end of an element. If we had a cmd_ method for this element,
199# this is where we pass along the text that we've accumulated. Otherwise, if
200# we have an end_ method for the element, call that.
201sub _handle_element_end {
202 my ($self, $element) = @_;
203 my $method = $self->method_for_element ($element);
204
205 # If we have a command handler, pull off the pending text and pass it to
206 # the handler along with the saved attribute hash.
207 if ($self->can ("cmd_$method")) {
208 my $tag = pop @{ $$self{PENDING} };
209 my $method = 'cmd_' . $method;
210 my $text = $self->$method (@$tag);
211 if (defined $text) {
212 if (@{ $$self{PENDING} } > 1) {
213 $$self{PENDING}[-1][1] .= $text;
214 } else {
215 $self->output ($text);
216 }
217 }
218 } elsif ($self->can ("end_$method")) {
219 my $method = 'end_' . $method;
220 $self->$method ();
221 }
222}
223
224##############################################################################
225# Output formatting
226##############################################################################
227
228# Wrap a line, indenting by the current left margin. We can't use Text::Wrap
229# because it plays games with tabs. We can't use formline, even though we'd
230# really like to, because it screws up non-printing characters. So we have to
231# do the wrapping ourselves.
232sub wrap {
233 my $self = shift;
234 local $_ = shift;
235 my $output = '';
236 my $spaces = ' ' x $$self{MARGIN};
237 my $width = $$self{opt_width} - $$self{MARGIN};
238 while (length > $width) {
239 if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
240 $output .= $spaces . $1 . "\n";
241 } else {
242 last;
243 }
244 }
245 $output .= $spaces . $_;
246 $output =~ s/\s+$/\n\n/;
247 return $output;
248}
249
250# Reformat a paragraph of text for the current margin. Takes the text to
251# reformat and returns the formatted text.
252sub reformat {
253 my $self = shift;
254 local $_ = shift;
255
256 # If we're trying to preserve two spaces after sentences, do some munging
257 # to support that. Otherwise, smash all repeated whitespace.
258 if ($$self{opt_sentence}) {
259 s/ +$//mg;
260 s/\.\n/. \n/g;
261 s/\n/ /g;
262 s/ +/ /g;
263 } else {
264 s/\s+/ /g;
265 }
266 return $self->wrap ($_);
267}
268
269# Output text to the output device. Replace non-breaking spaces with spaces
270# and soft hyphens with nothing, and then try to fix the output encoding if
271# necessary to match the input encoding unless UTF-8 output is forced. This
272# preserves the traditional pass-through behavior of Pod::Text.
273sub output {
274 my ($self, @text) = @_;
275 my $text = join ('', @text);
276 $text =~ tr/\240\255/ /d;
277 unless ($$self{opt_utf8}) {
278 my $encoding = $$self{encoding} || '';
279 if ($encoding && $encoding ne $$self{ENCODING}) {
280 $$self{ENCODING} = $encoding;
281 eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
282 }
283 }
284 if ($$self{ENCODE}) {
285 print { $$self{output_fh} } encode ('UTF-8', $text);
286 } else {
287 print { $$self{output_fh} } $text;
288 }
289}
290
291# Output a block of code (something that isn't part of the POD text). Called
292# by preprocess_paragraph only if we were given the code option. Exists here
293# only so that it can be overridden by subclasses.
294sub output_code { $_[0]->output ($_[1]) }
295
296##############################################################################
297# Document initialization
298##############################################################################
299
300# Set up various things that have to be initialized on a per-document basis.
301sub start_document {
302 my ($self, $attrs) = @_;
303 if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
304 $$self{CONTENTLESS} = 1;
305 } else {
306 delete $$self{CONTENTLESS};
307 }
308 my $margin = $$self{opt_indent} + $$self{opt_margin};
309
310 # Initialize a few per-document variables.
311 $$self{INDENTS} = []; # Stack of indentations.
312 $$self{MARGIN} = $margin; # Default left margin.
313 $$self{PENDING} = [[]]; # Pending output.
314
315 # We have to redo encoding handling for each document.
316 $$self{ENCODING} = '';
317
318 # When UTF-8 output is set, check whether our output file handle already
319 # has a PerlIO encoding layer set. If it does not, we'll need to encode
320 # our output before printing it (handled in the output() sub). Wrap the
321 # check in an eval to handle versions of Perl without PerlIO.
322 $$self{ENCODE} = 0;
323 if ($$self{opt_utf8}) {
324 $$self{ENCODE} = 1;
325 eval {
326 my @options = (output => 1, details => 1);
327 my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1];
328 if ($flag & PerlIO::F_UTF8 ()) {
329 $$self{ENCODE} = 0;
330 $$self{ENCODING} = 'UTF-8';
331 }
332 };
333 }
334
335 return '';
336}
337
338# Handle the end of the document. The only thing we do is handle dying on POD
339# errors, since Pod::Parser currently doesn't.
340sub end_document {
341 my ($self) = @_;
342 if ($$self{complain_die} && $self->errors_seen) {
343 croak ("POD document had syntax errors");
344 }
345}
346
347##############################################################################
348# Text blocks
349##############################################################################
350
351# Intended for subclasses to override, this method returns text with any
352# non-printing formatting codes stripped out so that length() correctly
353# returns the length of the text. For basic Pod::Text, it does nothing.
354sub strip_format {
355 my ($self, $string) = @_;
356 return $string;
357}
358
359# This method is called whenever an =item command is complete (in other words,
360# we've seen its associated paragraph or know for certain that it doesn't have
361# one). It gets the paragraph associated with the item as an argument. If
362# that argument is empty, just output the item tag; if it contains a newline,
363# output the item tag followed by the newline. Otherwise, see if there's
364# enough room for us to output the item tag in the margin of the text or if we
365# have to put it on a separate line.
366sub item {
367 my ($self, $text) = @_;
368 my $tag = $$self{ITEM};
369 unless (defined $tag) {
370 carp "Item called without tag";
371 return;
372 }
373 undef $$self{ITEM};
374
375 # Calculate the indentation and margin. $fits is set to true if the tag
376 # will fit into the margin of the paragraph given our indentation level.
377 my $indent = $$self{INDENTS}[-1];
378 $indent = $$self{opt_indent} unless defined $indent;
379 my $margin = ' ' x $$self{opt_margin};
380 my $tag_length = length ($self->strip_format ($tag));
381 my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1);
382
383 # If the tag doesn't fit, or if we have no associated text, print out the
384 # tag separately. Otherwise, put the tag in the margin of the paragraph.
385 if (!$text || $text =~ /^\s+$/ || !$fits) {
386 my $realindent = $$self{MARGIN};
387 $$self{MARGIN} = $indent;
388 my $output = $self->reformat ($tag);
389 $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
390 $output =~ s/\n*$/\n/;
391
392 # If the text is just whitespace, we have an empty item paragraph;
393 # this can result from =over/=item/=back without any intermixed
394 # paragraphs. Insert some whitespace to keep the =item from merging
395 # into the next paragraph.
396 $output .= "\n" if $text && $text =~ /^\s*$/;
397
398 $self->output ($output);
399 $$self{MARGIN} = $realindent;
400 $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
401 } else {
402 my $space = ' ' x $indent;
403 $space =~ s/^$margin /$margin:/ if $$self{opt_alt};
404 $text = $self->reformat ($text);
405 $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
406 my $tagspace = ' ' x $tag_length;
407 $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
408 $self->output ($text);
409 }
410}
411
412# Handle a basic block of text. The only tricky thing here is that if there
413# is a pending item tag, we need to format this as an item paragraph.
414sub cmd_para {
415 my ($self, $attrs, $text) = @_;
416 $text =~ s/\s+$/\n/;
417 if (defined $$self{ITEM}) {
418 $self->item ($text . "\n");
419 } else {
420 $self->output ($self->reformat ($text . "\n"));
421 }
422 return '';
423}
424
425# Handle a verbatim paragraph. Just print it out, but indent it according to
426# our margin.
427sub cmd_verbatim {
428 my ($self, $attrs, $text) = @_;
429 $self->item if defined $$self{ITEM};
430 return if $text =~ /^\s*$/;
431 $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
432 $text =~ s/\s*$/\n\n/;
433 $self->output ($text);
434 return '';
435}
436
437# Handle literal text (produced by =for and similar constructs). Just output
438# it with the minimum of changes.
439sub cmd_data {
440 my ($self, $attrs, $text) = @_;
441 $text =~ s/^\n+//;
442 $text =~ s/\n{0,2}$/\n/;
443 $self->output ($text);
444 return '';
445}
446
447##############################################################################
448# Headings
449##############################################################################
450
451# The common code for handling all headers. Takes the header text, the
452# indentation, and the surrounding marker for the alt formatting method.
453sub heading {
454 my ($self, $text, $indent, $marker) = @_;
455 $self->item ("\n\n") if defined $$self{ITEM};
456 $text =~ s/\s+$//;
457 if ($$self{opt_alt}) {
458 my $closemark = reverse (split (//, $marker));
459 my $margin = ' ' x $$self{opt_margin};
460 $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
461 } else {
462 $text .= "\n" if $$self{opt_loose};
463 my $margin = ' ' x ($$self{opt_margin} + $indent);
464 $self->output ($margin . $text . "\n");
465 }
466 return '';
467}
468
469# First level heading.
470sub cmd_head1 {
471 my ($self, $attrs, $text) = @_;
472 $self->heading ($text, 0, '====');
473}
474
475# Second level heading.
476sub cmd_head2 {
477 my ($self, $attrs, $text) = @_;
478 $self->heading ($text, $$self{opt_indent} / 2, '== ');
479}
480
481# Third level heading.
482sub cmd_head3 {
483 my ($self, $attrs, $text) = @_;
484 $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= ');
485}
486
487# Fourth level heading.
488sub cmd_head4 {
489 my ($self, $attrs, $text) = @_;
490 $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- ');
491}
492
493##############################################################################
494# List handling
495##############################################################################
496
497# Handle the beginning of an =over block. Takes the type of the block as the
498# first argument, and then the attr hash. This is called by the handlers for
499# the four different types of lists (bullet, number, text, and block).
500sub over_common_start {
501 my ($self, $attrs) = @_;
502 $self->item ("\n\n") if defined $$self{ITEM};
503
504 # Find the indentation level.
505 my $indent = $$attrs{indent};
506 unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
507 $indent = $$self{opt_indent};
508 }
509
510 # Add this to our stack of indents and increase our current margin.
511 push (@{ $$self{INDENTS} }, $$self{MARGIN});
512 $$self{MARGIN} += ($indent + 0);
513 return '';
514}
515
516# End an =over block. Takes no options other than the class pointer. Output
517# any pending items and then pop one level of indentation.
518sub over_common_end {
519 my ($self) = @_;
520 $self->item ("\n\n") if defined $$self{ITEM};
521 $$self{MARGIN} = pop @{ $$self{INDENTS} };
522 return '';
523}
524
525# Dispatch the start and end calls as appropriate.
526sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
527sub start_over_number { $_[0]->over_common_start ($_[1]) }
528sub start_over_text { $_[0]->over_common_start ($_[1]) }
529sub start_over_block { $_[0]->over_common_start ($_[1]) }
530sub end_over_bullet { $_[0]->over_common_end }
531sub end_over_number { $_[0]->over_common_end }
532sub end_over_text { $_[0]->over_common_end }
533sub end_over_block { $_[0]->over_common_end }
534
535# The common handler for all item commands. Takes the type of the item, the
536# attributes, and then the text of the item.
537sub item_common {
538 my ($self, $type, $attrs, $text) = @_;
539 $self->item if defined $$self{ITEM};
540
541 # Clean up the text. We want to end up with two variables, one ($text)
542 # which contains any body text after taking out the item portion, and
543 # another ($item) which contains the actual item text. Note the use of
544 # the internal Pod::Simple attribute here; that's a potential land mine.
545 $text =~ s/\s+$//;
546 my ($item, $index);
547 if ($type eq 'bullet') {
548 $item = '*';
549 } elsif ($type eq 'number') {
550 $item = $$attrs{'~orig_content'};
551 } else {
552 $item = $text;
553 $item =~ s/\s*\n\s*/ /g;
554 $text = '';
555 }
556 $$self{ITEM} = $item;
557
558 # If body text for this item was included, go ahead and output that now.
559 if ($text) {
560 $text =~ s/\s*$/\n/;
561 $self->item ($text);
562 }
563 return '';
564}
565
566# Dispatch the item commands to the appropriate place.
567sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
568sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
569sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
570sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
571
572##############################################################################
573# Formatting codes
574##############################################################################
575
576# The simple ones.
577sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
578sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
579sub cmd_i { return '*' . $_[2] . '*' }
580sub cmd_x { return '' }
581
582# Apply a whole bunch of messy heuristics to not quote things that don't
583# benefit from being quoted. These originally come from Barrie Slaymaker and
584# largely duplicate code in Pod::Man.
585sub cmd_c {
586 my ($self, $attrs, $text) = @_;
587
588 # A regex that matches the portion of a variable reference that's the
589 # array or hash index, separated out just because we want to use it in
590 # several places in the following regex.
591 my $index = '(?: \[.*\] | \{.*\} )?';
592
593 # Check for things that we don't want to quote, and if we find any of
594 # them, return the string with just a font change and no quoting.
595 $text =~ m{
596 ^\s*
597 (?:
598 ( [\'\`\"] ) .* \1 # already quoted
599 | \` .* \' # `quoted'
600 | \$+ [\#^]? \S $index # special ($^Foo, $")
601 | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
602 | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
603 | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
604 | 0x [a-fA-F\d]+ # a hex constant
605 )
606 \s*\z
607 }xo && return $text;
608
609 # If we didn't return, go ahead and quote the text.
610 return $$self{opt_alt}
611 ? "``$text''"
612 : "$$self{LQUOTE}$text$$self{RQUOTE}";
613}
614
615# Links reduce to the text that we're given, wrapped in angle brackets if it's
616# a URL.
617sub cmd_l {
618 my ($self, $attrs, $text) = @_;
619 if ($$attrs{type} eq 'url') {
620 if (not defined($$attrs{to}) or $$attrs{to} eq $text) {
621 return "<$text>";
622 } elsif ($$self{opt_nourls}) {
623 return $text;
624 } else {
625 return "$text <$$attrs{to}>";
626 }
627 } else {
628 return $text;
629 }
630}
631
632##############################################################################
633# Backwards compatibility
634##############################################################################
635
636# The old Pod::Text module did everything in a pod2text() function. This
637# tries to provide the same interface for legacy applications.
638sub pod2text {
639 my @args;
640
641 # This is really ugly; I hate doing option parsing in the middle of a
642 # module. But the old Pod::Text module supported passing flags to its
643 # entry function, so handle -a and -<number>.
644 while ($_[0] =~ /^-/) {
645 my $flag = shift;
646 if ($flag eq '-a') { push (@args, alt => 1) }
647 elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
648 else {
649 unshift (@_, $flag);
650 last;
651 }
652 }
653
654 # Now that we know what arguments we're using, create the parser.
655 my $parser = Pod::Text->new (@args);
656
657 # If two arguments were given, the second argument is going to be a file
658 # handle. That means we want to call parse_from_filehandle(), which means
659 # we need to turn the first argument into a file handle. Magic open will
660 # handle the <&STDIN case automagically.
661 if (defined $_[1]) {
662 my @fhs = @_;
663 local *IN;
664 unless (open (IN, $fhs[0])) {
665 croak ("Can't open $fhs[0] for reading: $!\n");
666 return;
667 }
668 $fhs[0] = \*IN;
669 $parser->output_fh ($fhs[1]);
670 my $retval = $parser->parse_file ($fhs[0]);
671 my $fh = $parser->output_fh ();
672 close $fh;
673 return $retval;
674 } else {
675 $parser->output_fh (\*STDOUT);
676 return $parser->parse_file (@_);
677 }
678}
679
680# Reset the underlying Pod::Simple object between calls to parse_from_file so
681# that the same object can be reused to convert multiple pages.
682sub parse_from_file {
683 my $self = shift;
684 $self->reinit;
685
686 # Fake the old cutting option to Pod::Parser. This fiddings with internal
687 # Pod::Simple state and is quite ugly; we need a better approach.
688 if (ref ($_[0]) eq 'HASH') {
689 my $opts = shift @_;
690 if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
691 $$self{in_pod} = 1;
692 $$self{last_was_blank} = 1;
693 }
694 }
695
696 # Do the work.
697 my $retval = $self->Pod::Simple::parse_from_file (@_);
698
699 # Flush output, since Pod::Simple doesn't do this. Ideally we should also
700 # close the file descriptor if we had to open one, but we can't easily
701 # figure this out.
702 my $fh = $self->output_fh ();
703 my $oldfh = select $fh;
704 my $oldflush = $|;
705 $| = 1;
706 print $fh '';
707 $| = $oldflush;
708 select $oldfh;
709 return $retval;
710}
711
712# Pod::Simple failed to provide this backward compatibility function, so
713# implement it ourselves. File handles are one of the inputs that
714# parse_from_file supports.
715sub parse_from_filehandle {
716 my $self = shift;
717 $self->parse_from_file (@_);
718}
719
720# Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so
721# ourself unless it was already set by the caller, since our documentation has
722# always said that this should work.
723sub parse_file {
724 my ($self, $in) = @_;
725 unless (defined $$self{output_fh}) {
726 $self->output_fh (\*STDOUT);
727 }
728 return $self->SUPER::parse_file ($in);
729}
730
731# Do the same for parse_lines, just to be polite. Pod::Simple's man page
732# implies that the caller is responsible for setting this, but I don't see any
733# reason not to set a default.
734sub parse_lines {
735 my ($self, @lines) = @_;
736 unless (defined $$self{output_fh}) {
737 $self->output_fh (\*STDOUT);
738 }
739 return $self->SUPER::parse_lines (@lines);
740}
741
742# Likewise for parse_string_document.
743sub parse_string_document {
744 my ($self, $doc) = @_;
745 unless (defined $$self{output_fh}) {
746 $self->output_fh (\*STDOUT);
747 }
748 return $self->SUPER::parse_string_document ($doc);
749}
750
751##############################################################################
752# Module return value and documentation
753##############################################################################
754
755111µs1;
756__END__
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.