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

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