File Coverage

lib/Pod/Simple/XHTML.pm
Criterion Covered Total %
statement 291 296 98.3
branch 92 106 86.7
condition 34 50 68.0
subroutine 63 66 95.4
pod 9 60 15.0
total 489 578 84.6


line stmt bran cond sub pod time code
1             =pod
2              
3             =head1 NAME
4              
5             Pod::Simple::XHTML -- format Pod as validating XHTML
6              
7             =head1 SYNOPSIS
8              
9             use Pod::Simple::XHTML;
10              
11             my $parser = Pod::Simple::XHTML->new();
12              
13             ...
14              
15             $parser->parse_file('path/to/file.pod');
16              
17             =head1 DESCRIPTION
18              
19             This class is a formatter that takes Pod and renders it as XHTML
20             validating HTML.
21              
22             This is a subclass of L and inherits all its
23             methods. The implementation is entirely different than
24             L, but it largely preserves the same interface.
25              
26             =head2 Minimal code
27              
28             use Pod::Simple::XHTML;
29             my $psx = Pod::Simple::XHTML->new;
30             $psx->output_string(\my $html);
31             $psx->parse_file('path/to/Module/Name.pm');
32             open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
33             print $out $html;
34              
35             You can also control the character encoding and entities. For example, if
36             you're sure that the POD is properly encoded (using the C<=encoding> command),
37             you can prevent high-bit characters from being encoded as HTML entities and
38             declare the output character set as UTF-8 before parsing, like so:
39              
40             $psx->html_charset('UTF-8');
41             $psx->html_encode_chars(q{&<>'"});
42              
43             =cut
44              
45             package Pod::Simple::XHTML;
46 11     11   148925 use strict;
  11         39  
  11         386  
47 11     11   56 use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
  11         17  
  11         928  
48             $VERSION = '3.43';
49 11     11   3710 use Pod::Simple::Methody ();
  11         43  
  11         403  
50             @ISA = ('Pod::Simple::Methody');
51              
52             BEGIN {
53 11     11   534 $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
54             }
55              
56             my %entities = (
57             q{>} => 'gt',
58             q{<} => 'lt',
59             q{'} => '#39',
60             q{"} => 'quot',
61             q{&} => 'amp',
62             );
63              
64             sub encode_entities {
65 373     373 0 486 my $self = shift;
66 373         712 my $ents = $self->html_encode_chars;
67 373 100       1092 return HTML::Entities::encode_entities( $_[0], $ents ) if $HAS_HTML_ENTITIES;
68 8 100       12 if (defined $ents) {
69 1         4 $ents =~ s,(?
70 1         2 $ents =~ s,(?
71             } else {
72 7         44 $ents = join '', keys %entities;
73             }
74 8         13 my $str = $_[0];
75 8   66     97 $str =~ s/([$ents])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/ge;
  21         71  
76 8         20 return $str;
77             }
78              
79             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80              
81             =head1 METHODS
82              
83             Pod::Simple::XHTML offers a number of methods that modify the format of
84             the HTML output. Call these after creating the parser object, but before
85             the call to C:
86              
87             my $parser = Pod::PseudoPod::HTML->new();
88             $parser->set_optional_param("value");
89             $parser->parse_file($file);
90              
91             =head2 perldoc_url_prefix
92              
93             In turning L into http://whatever/Foo%3a%3aBar, what
94             to put before the "Foo%3a%3aBar". The default value is
95             "https://metacpan.org/pod/".
96              
97             =head2 perldoc_url_postfix
98              
99             What to put after "Foo%3a%3aBar" in the URL. This option is not set by
100             default.
101              
102             =head2 man_url_prefix
103              
104             In turning C<< L >> into http://whatever/man/1/crontab, what
105             to put before the "1/crontab". The default value is
106             "http://man.he.net/man".
107              
108             =head2 man_url_postfix
109              
110             What to put after "1/crontab" in the URL. This option is not set by default.
111              
112             =head2 title_prefix, title_postfix
113              
114             What to put before and after the title in the head. The values should
115             already be &-escaped.
116              
117             =head2 html_css
118              
119             $parser->html_css('path/to/style.css');
120              
121             The URL or relative path of a CSS file to include. This option is not
122             set by default.
123              
124             =head2 html_javascript
125              
126             The URL or relative path of a JavaScript file to pull in. This option is
127             not set by default.
128              
129             =head2 html_doctype
130              
131             A document type tag for the file. This option is not set by default.
132              
133             =head2 html_charset
134              
135             The character set to declare in the Content-Type meta tag created by default
136             for C. Note that this option will be ignored if the value of
137             C is changed. Defaults to "ISO-8859-1".
138              
139             =head2 html_header_tags
140              
141             Additional arbitrary HTML tags for the header of the document. The
142             default value is just a content type header tag:
143              
144            
145              
146             Add additional meta tags here, or blocks of inline CSS or JavaScript
147             (wrapped in the appropriate tags).
148              
149             =head3 html_encode_chars
150              
151             A string containing all characters that should be encoded as HTML entities,
152             specified using the regular expression character class syntax (what you find
153             within brackets in regular expressions). This value will be passed as the
154             second argument to the C function of L. If
155             L is not installed, then any characters other than C<&<>"'>
156             will be encoded numerically.
157              
158             =head2 html_h_level
159              
160             This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
161             example, if C is set to 2, a head1 will produce an H2, a head2
162             will produce an H3, and so on.
163              
164             =head2 default_title
165              
166             Set a default title for the page if no title can be determined from the
167             content. The value of this string should already be &-escaped.
168              
169             =head2 force_title
170              
171             Force a title for the page (don't try to determine it from the content).
172             The value of this string should already be &-escaped.
173              
174             =head2 html_header, html_footer
175              
176             Set the HTML output at the beginning and end of each file. The default
177             header includes a title, a doctype tag (if C is set), a
178             content tag (customized by C), a tag for a CSS file
179             (if C is set), and a tag for a Javascript file (if
180             C is set). The default footer simply closes the C
181             and C tags.
182              
183             The options listed above customize parts of the default header, but
184             setting C or C completely overrides the
185             built-in header or footer. These may be useful if you want to use
186             template tags instead of literal HTML headers and footers or are
187             integrating converted POD pages in a larger website.
188              
189             If you want no headers or footers output in the HTML, set these options
190             to the empty string.
191              
192             =head2 index
193              
194             Whether to add a table-of-contents at the top of each page (called an
195             index for the sake of tradition).
196              
197             =head2 anchor_items
198              
199             Whether to anchor every definition C<=item> directive. This needs to be
200             enabled if you want to be able to link to specific C<=item> directives, which
201             are output as C<<
>> elements. Disabled by default.
202              
203             =head2 backlink
204              
205             Whether to turn every =head1 directive into a link pointing to the top
206             of the page (specifically, the opening body tag).
207              
208             =cut
209              
210             __PACKAGE__->_accessorize(
211             'perldoc_url_prefix',
212             'perldoc_url_postfix',
213             'man_url_prefix',
214             'man_url_postfix',
215             'title_prefix', 'title_postfix',
216             'html_css',
217             'html_javascript',
218             'html_doctype',
219             'html_charset',
220             'html_encode_chars',
221             'html_h_level',
222             'title', # Used internally for the title extracted from the content
223             'default_title',
224             'force_title',
225             'html_header',
226             'html_footer',
227             'index',
228             'anchor_items',
229             'backlink',
230             'batch_mode', # whether we're in batch mode
231             'batch_mode_current_level',
232             # When in batch mode, how deep the current module is: 1 for "LWP",
233             # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
234             );
235              
236             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
237              
238             =head1 SUBCLASSING
239              
240             If the standard options aren't enough, you may want to subclass
241             Pod::Simple::XHMTL. These are the most likely candidates for methods
242             you'll want to override when subclassing.
243              
244             =cut
245              
246             sub new {
247 126     126 1 19286 my $self = shift;
248 126         505 my $new = $self->SUPER::new(@_);
249 126   50     669 $new->{'output_fh'} ||= *STDOUT{IO};
250 126         353 $new->perldoc_url_prefix('https://metacpan.org/pod/');
251 126         316 $new->man_url_prefix('http://man.he.net/man');
252 126         300 $new->html_charset('ISO-8859-1');
253 126         383 $new->nix_X_codes(1);
254 126         221 $new->{'scratch'} = '';
255 126         232 $new->{'to_index'} = [];
256 126         215 $new->{'output'} = [];
257 126         216 $new->{'saved'} = [];
258 126         273 $new->{'ids'} = { '_podtop_' => 1 }; # used in
259 126         209 $new->{'in_li'} = [];
260              
261 126         298 $new->{'__region_targets'} = [];
262 126         224 $new->{'__literal_targets'} = {};
263 126         324 $new->accept_targets_as_html( 'html', 'HTML' );
264              
265 126         1095 return $new;
266             }
267              
268             sub html_header_tags {
269 20     20 1 32 my $self = shift;
270 20 50       47 return $self->{html_header_tags} = shift if @_;
271             return $self->{html_header_tags}
272 20   33     84 ||= ' 273             . $self->html_charset . '" />';
274             }
275              
276             #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
277              
278             =head2 handle_text
279              
280             This method handles the body of text within any element: it's the body
281             of a paragraph, or everything between a "=begin" tag and the
282             corresponding "=end" tag, or the text within an L entity, etc. You would
283             want to override this if you are adding a custom element type that does
284             more than just display formatted text. Perhaps adding a way to generate
285             HTML tables from an extended version of POD.
286              
287             So, let's say you want to add a custom element called 'foo'. In your
288             subclass's C method, after calling C you'd call:
289              
290             $new->accept_targets_as_text( 'foo' );
291              
292             Then override the C method in the subclass to check for when
293             "$flags->{'target'}" is equal to 'foo' and set a flag that marks that
294             you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
295             C method to check for the flag, and pass $text to your
296             custom subroutine to construct the HTML output for 'foo' elements,
297             something like:
298              
299             sub handle_text {
300             my ($self, $text) = @_;
301             if ($self->{'in_foo'}) {
302             $self->{'scratch'} .= build_foo_html($text);
303             return;
304             }
305             $self->SUPER::handle_text($text);
306             }
307              
308             =head2 handle_code
309              
310             This method handles the body of text that is marked up to be code.
311             You might for instance override this to plug in a syntax highlighter.
312             The base implementation just escapes the text.
313              
314             The callback methods C and C emits the C tags
315             before and after C is invoked, so you might want to override these
316             together with C if this wrapping isn't suitable.
317              
318             Note that the code might be broken into multiple segments if there are
319             nested formatting codes inside a C<< CE...> >> sequence. In between the
320             calls to C other markup tags might have been emitted in that
321             case. The same is true for verbatim sections if the C
322             option is turned on.
323              
324             =head2 accept_targets_as_html
325              
326             This method behaves like C, but also marks the region
327             as one whose content should be emitted literally, without HTML entity escaping
328             or wrapping in a C
element.
329              
330             =cut
331              
332             sub __in_literal_xhtml_region {
333 299 100   299   304 return unless @{ $_[0]{__region_targets} };
  299         953  
334 30         49 my $target = $_[0]{__region_targets}[-1];
335 30         63 return $_[0]{__literal_targets}{ $target };
336             }
337              
338             sub accept_targets_as_html {
339 126     126 1 290 my ($self, @targets) = @_;
340 126         412 $self->accept_targets(@targets);
341 126         403 $self->{__literal_targets}{$_} = 1 for @targets;
342             }
343              
344             sub handle_text {
345             # escape special characters in HTML (<, >, &, etc)
346 278 100   278 1 538 my $text = $_[0]->__in_literal_xhtml_region
347             ? $_[1]
348             : $_[0]->encode_entities( $_[1] );
349              
350 278 100 100     4419 if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) {
  49         130  
351             # Intentionally use the raw text in $_[1], even if we're not in a
352             # literal xhtml region, since handle_code calls encode_entities.
353 39         100 $_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] );
354             } else {
355 239 100       342 if ($_[0]->{in_for}) {
356 9 100       13 my $newlines = $_[0]->__in_literal_xhtml_region ? "\n\n" : '';
357 9 100       16 if ($_[0]->{started_for}) {
358 6 50       22 if ($text =~ /\S/) {
359 6         11 delete $_[0]->{started_for};
360 6         15 $_[0]{'scratch'} .= $text . $newlines;
361             }
362             # Otherwise, append nothing until we have something to append.
363             } else {
364             # The parser sometimes preserves newlines and sometimes doesn't!
365 3         8 $text =~ s/\n\z//;
366 3         7 $_[0]{'scratch'} .= $text . $newlines;
367             }
368             } else {
369             # Just plain text.
370 230         381 $_[0]{'scratch'} .= $text;
371             }
372             }
373              
374 278 100       1290 $_[0]{htext} .= $text if $_[0]{'in_head'};
375             }
376              
377             sub start_code {
378 28     28 0 95 $_[0]{'scratch'} .= '';
379             }
380              
381             sub end_code {
382 28     28 0 52 $_[0]{'scratch'} .= '';
383             }
384              
385             sub handle_code {
386 39     39 1 111 $_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] );
387             }
388              
389             sub start_Para {
390 81     81 0 172 $_[0]{'scratch'} .= '

';

391             }
392              
393             sub start_Verbatim {
394 25     25 0 51 $_[0]{'scratch'} = '
'; 
395 25         32 push(@{$_[0]{'in_code'}}, 'Verbatim');
  25         107  
396 25         67 $_[0]->start_code($_[0]{'in_code'}[-1]);
397             }
398              
399 59     59 0 127 sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
  59         141  
400 14     14 0 26 sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
  14         37  
401 8     8 0 15 sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
  8         16  
402 9     9 0 17 sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
  9         20  
403 2     2 0 7 sub start_head5 { $_[0]{'in_head'} = 5; $_[0]{htext} = ''; }
  2         6  
404 2     2 0 5 sub start_head6 { $_[0]{'in_head'} = 6; $_[0]{htext} = ''; }
  2         6  
405              
406             sub start_item_number {
407 8 100 66 8 0 27 $_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
  3         11  
408 8         13 $_[0]{'scratch'} .= '
  • ';

  • 409 8         9 push @{$_[0]{'in_li'}}, 1;
      8         18  
    410             }
    411              
    412             sub start_item_bullet {
    413 12 100 66 12 0 46 $_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
      5         18  
    414 12         19 $_[0]{'scratch'} .= '
  • ';

  • 415 12         13 push @{$_[0]{'in_li'}}, 1;
      12         27  
    416             }
    417              
    418       13 0   sub start_item_text {
    419             # see end_item_text
    420             }
    421              
    422 7     7 0 15 sub start_over_bullet { $_[0]{'scratch'} = '
      '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
      7         10  
      7         17  
      7         27  
    423 0     0 0 0 sub start_over_block { $_[0]{'scratch'} = '
      '; $_[0]->emit }
      0         0  
    424 5     5 0 8 sub start_over_number { $_[0]{'scratch'} = '
      '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
      5         7  
      5         12  
      5         22  
    425             sub start_over_text {
    426 7     7 0 14 $_[0]{'scratch'} = '
    ';
    427 7         13 $_[0]{'dl_level'}++;
    428 7   100     23 $_[0]{'in_dd'} ||= [];
    429 7         19 $_[0]->emit
    430             }
    431              
    432 0     0 0 0 sub end_over_block { $_[0]{'scratch'} .= ''; $_[0]->emit }
      0         0  
    433              
    434             sub end_over_number {
    435 5 50   5 0 7 $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
      5         18  
    436 5         10 $_[0]{'scratch'} .= '';
    437 5         7 pop @{$_[0]{'in_li'}};
      5         8  
    438 5         23 $_[0]->emit;
    439             }
    440              
    441             sub end_over_bullet {
    442 7 50   7 0 13 $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
      7         25  
    443 7         12 $_[0]{'scratch'} .= '';
    444 7         9 pop @{$_[0]{'in_li'}};
      7         13  
    445 7         22 $_[0]->emit;
    446             }
    447              
    448             sub end_over_text {
    449 7 50   7 0 86 if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
    450 7         17 $_[0]{'scratch'} = "\n";
    451 7         14 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
    452             }
    453 7         10 $_[0]{'scratch'} .= '';
    454 7         10 $_[0]{'dl_level'}--;
    455 7         16 $_[0]->emit;
    456             }
    457              
    458             # . . . . . Now the actual formatters:
    459              
    460 81     81 0 143 sub end_Para { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      81         179  
    461             sub end_Verbatim {
    462 25     25 0 42 $_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
      25         79  
    463 25         45 $_[0]{'scratch'} .= '';
    464 25         55 $_[0]->emit;
    465             }
    466              
    467             sub _end_head {
    468 94     94   162 my $h = delete $_[0]{in_head};
    469              
    470 94         174 my $add = $_[0]->html_h_level;
    471 94 100       190 $add = 1 unless defined $add;
    472 94         124 $h += $add - 1;
    473              
    474 94         207 my $id = $_[0]->idify($_[0]{htext});
    475 94         138 my $text = $_[0]{scratch};
    476 94 100 100     192 $_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
    477             # backlinks enabled && =head1
    478             ? qq{$text}
    479             : qq{$text};
    480 94         203 $_[0]->emit;
    481 94         113 push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}];
      94         352  
    482             }
    483              
    484 59     59 0 142 sub end_head1 { shift->_end_head(@_); }
    485 14     14 0 33 sub end_head2 { shift->_end_head(@_); }
    486 8     8 0 20 sub end_head3 { shift->_end_head(@_); }
    487 9     9 0 18 sub end_head4 { shift->_end_head(@_); }
    488 2     2 0 8 sub end_head5 { shift->_end_head(@_); }
    489 2     2 0 8 sub end_head6 { shift->_end_head(@_); }
    490              
    491 12     12 0 31 sub end_item_bullet { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      12         23  
    492 8     8 0 12 sub end_item_number { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      8         15  
    493              
    494             sub end_item_text {
    495             # idify and anchor =item content if wanted
    496             my $dt_id = $_[0]{'anchor_items'}
    497 13 100   13 0 46 ? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
    498             : '';
    499              
    500             # reset scratch
    501 13         18 my $text = $_[0]{scratch};
    502 13         24 $_[0]{'scratch'} = '';
    503              
    504 13 100       36 if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
    505 6         10 $_[0]{'scratch'} = "\n";
    506 6         115 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
    507             }
    508              
    509 13         33 $_[0]{'scratch'} .= qq{$text\n
    };
    510 13         20 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
    511 13         27 $_[0]->emit;
    512             }
    513              
    514             # This handles =begin and =for blocks of all kinds.
    515             sub start_for {
    516 6     6 0 13 my ($self, $flags) = @_;
    517              
    518 6         15 push @{ $self->{__region_targets} }, $flags->{target_matching};
      6         15  
    519 6         10 $self->{started_for} = 1;
    520 6         12 $self->{in_for} = 1;
    521              
    522 6 100       14 unless ($self->__in_literal_xhtml_region) {
    523 4         4 $self->{scratch} .= '
    524 4 50       10 $self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
    525 4         7 $self->{scratch} .= ">\n\n";
    526             }
    527             }
    528              
    529             sub end_for {
    530 6     6 0 10 my ($self) = @_;
    531 6         9 delete $self->{started_for};
    532 6         9 delete $self->{in_for};
    533              
    534 6 100       12 if ($self->__in_literal_xhtml_region) {
    535             # Remove trailine newlines.
    536 2         14 $self->{'scratch'} =~ s/\s+\z//s;
    537             } else {
    538 4         5 $self->{'scratch'} .= '';
    539             }
    540              
    541 6         8 pop @{ $self->{__region_targets} };
      6         17  
    542 6         15 $self->emit;
    543             }
    544              
    545             sub start_Document {
    546 122     122 0 258 my ($self) = @_;
    547 122 100       267 if (defined $self->html_header) {
    548 102         216 $self->{'scratch'} .= $self->html_header;
    549 102 100       206 $self->emit unless $self->html_header eq "";
    550             } else {
    551 20         36 my ($doctype, $title, $metatags, $bodyid);
    552 20   50     52 $doctype = $self->html_doctype || '';
    553 20   50     52 $title = $self->force_title || $self->title || $self->default_title || '';
    554 20   50     52 $metatags = $self->html_header_tags || '';
    555 20 100       50 if (my $css = $self->html_css) {
    556 3 100       12 if ($css !~ /
    557             # this is required to be compatible with Pod::Simple::BatchHTML
    558 2         6 $metatags .= ' 559             . $self->encode_entities($css) . '" type="text/css" />';
    560             } else {
    561 1         2 $metatags .= $css;
    562             }
    563             }
    564 20 50       78 if ($self->html_javascript) {
    565 0         0 $metatags .= qq{\n';
    567             }
    568 20 100       74 $bodyid = $self->backlink ? ' id="_podtop_"' : '';
    569 20         80 $self->{'scratch'} .= <<"HTML";
    570             $doctype
    571            
    572            
    573             $title
    574             $metatags
    575            
    576            
    577             HTML
    578 20         48 $self->emit;
    579             }
    580             }
    581              
    582             sub end_Document {
    583 122     122 0 216 my ($self) = @_;
    584 122         196 my $to_index = $self->{'to_index'};
    585 122 100 66     277 if ($self->index && @{ $to_index } ) {
      26         56  
    586 26         28 my @out;
    587 26         28 my $level = 0;
    588 26         19 my $indent = -1;
    589 26         27 my $space = '';
    590 26         23 my $id = ' id="index"';
    591              
    592 26         26 for my $h (@{ $to_index }, [0]) {
      26         48  
    593 88         99 my $target_level = $h->[0];
    594             # Get to target_level by opening or closing ULs
    595 88 100       244 if ($level == $target_level) {
        100          
    596 9         15 $out[-1] .= '';
    597             } elsif ($level > $target_level) {
    598 32 50       138 $out[-1] .= '' if $out[-1] =~ /^\s+
  • /;
  • 599 32         58 while ($level > $target_level) {
    600 61         56 --$level;
    601 61 100 66     222 push @out, (' ' x --$indent) . '' if @out && $out[-1] =~ m{^\s+<\/ul};
    602 61         143 push @out, (' ' x --$indent) . '';
    603             }
    604 32 100       46 push @out, (' ' x --$indent) . '' if $level;
    605             } else {
    606 47         67 while ($level < $target_level) {
    607 61         57 ++$level;
    608 61 100 100     204 push @out, (' ' x ++$indent) . '
  • ' if @out && $out[-1]=~ /^\s*
  • 609 61         132 push @out, (' ' x ++$indent) . "";
    610 61         89 $id = '';
    611             }
    612 47         47 ++$indent;
    613             }
    614              
    615 88 100       122 next unless $level;
    616 62         74 $space = ' ' x $indent;
    617 62         210 push @out, sprintf '%s
  • %s',
  • 618             $space, $h->[1], $h->[2];
    619             }
    620             # Splice the index in between the HTML headers and the first element.
    621 26 50       63 my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
        100          
    622 26         31 splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
      26         132  
    623             }
    624              
    625 122 100       276 if (defined $self->html_footer) {
    626 102         228 $self->{'scratch'} .= $self->html_footer;
    627 102 100       196 $self->emit unless $self->html_footer eq "";
    628             } else {
    629 20         39 $self->{'scratch'} .= "\n";
    630 20         49 $self->emit;
    631             }
    632              
    633 122 100       255 if ($self->index) {
    634 26         26 print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
      26         37  
      26         120  
    635 26         38 @{$self->{'output'}} = ();
      26         66  
    636             }
    637              
    638             }
    639              
    640             # Handling code tags
    641 7     7 0 16 sub start_B { $_[0]{'scratch'} .= '' }
    642 7     7 0 17 sub end_B { $_[0]{'scratch'} .= '' }
    643              
    644 7     7 0 11 sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
      7         21  
      7         25  
    645 7     7 0 15 sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
      7         24  
    646              
    647 1     1 0 2 sub start_F { $_[0]{'scratch'} .= '' }
    648 1     1 0 3 sub end_F { $_[0]{'scratch'} .= '' }
    649              
    650 1     1 0 3 sub start_I { $_[0]{'scratch'} .= '' }
    651 1     1 0 2 sub end_I { $_[0]{'scratch'} .= '' }
    652              
    653             sub start_L {
    654 29     29 0 56 my ($self, $flags) = @_;
    655 29         37 my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
      29         69  
    656 29 50       141 my $url = $self->encode_entities(
        100          
        100          
    657             $type eq 'url' ? $to
    658             : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
    659             : $type eq 'man' ? $self->resolve_man_page_link($to, $section)
    660             : undef
    661             );
    662              
    663             # If it's an unknown type, use an attribute-less like HTML.pm.
    664 29 50       293 $self->{'scratch'} .= '' : '>');
    665             }
    666              
    667 29     29 0 57 sub end_L { $_[0]{'scratch'} .= '' }
    668              
    669 1     1 0 3 sub start_S { $_[0]{'scratch'} .= '' }
    670 1     1 0 3 sub end_S { $_[0]{'scratch'} .= '' }
    671              
    672             sub emit {
    673 319     319 0 478 my($self) = @_;
    674 319 100       672 if ($self->index) {
    675 100         107 push @{ $self->{'output'} }, $self->{'scratch'};
      100         187  
    676             } else {
    677 219         247 print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
      219         823  
    678             }
    679 319         468 $self->{'scratch'} = '';
    680 319         529 return;
    681             }
    682              
    683             =head2 resolve_pod_page_link
    684              
    685             my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
    686             my $url = $pod->resolve_pod_page_link('perlpodspec');
    687             my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
    688              
    689             Resolves a POD link target (typically a module or POD file name) and section
    690             name to a URL. The resulting link will be returned for the above examples as:
    691              
    692             https://metacpan.org/pod/Net::Ping#INSTALL
    693             https://metacpan.org/pod/perlpodspec
    694             #SYNOPSIS
    695              
    696             Note that when there is only a section argument the URL will simply be a link
    697             to a section in the current document.
    698              
    699             =cut
    700              
    701             sub resolve_pod_page_link {
    702 19     19 1 37 my ($self, $to, $section) = @_;
    703 19 50 66     63 return undef unless defined $to || defined $section;
    704 19 100       41 if (defined $section) {
    705 11         23 $section = '#' . $self->idify($self->encode_entities($section), 1);
    706 11 100       56 return $section unless defined $to;
    707             } else {
    708 8         22 $section = ''
    709             }
    710              
    711 13   50     44 return ($self->perldoc_url_prefix || '')
          50        
    712             . $self->encode_entities($to) . $section
    713             . ($self->perldoc_url_postfix || '');
    714             }
    715              
    716             =head2 resolve_man_page_link
    717              
    718             my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
    719             my $url = $pod->resolve_man_page_link('crontab');
    720              
    721             Resolves a man page link target and numeric section to a URL. The resulting
    722             link will be returned for the above examples as:
    723              
    724             http://man.he.net/man5/crontab
    725             http://man.he.net/man1/crontab
    726              
    727             Note that the first argument is required. The section number will be parsed
    728             from it, and if it's missing will default to 1. The second argument is
    729             currently ignored, as L does not currently
    730             include linkable IDs or anchor names in its pages. Subclass to link to a
    731             different man page HTTP server.
    732              
    733             =cut
    734              
    735             sub resolve_man_page_link {
    736 6     6 1 12 my ($self, $to, $section) = @_;
    737 6 50       16 return undef unless defined $to;
    738 6         27 my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
    739 6 50       16 return undef unless $page;
    740 6   50     15 return ($self->man_url_prefix || '')
          100        
          50        
    741             . ($part || 1) . "/" . $self->encode_entities($page)
    742             . ($self->man_url_postfix || '');
    743              
    744             }
    745              
    746             =head2 idify
    747              
    748             my $id = $pod->idify($text);
    749             my $hash = $pod->idify($text, 1);
    750              
    751             This method turns an arbitrary string into a valid XHTML ID attribute value.
    752             The rules enforced, following
    753             L, are:
    754              
    755             =over
    756              
    757             =item *
    758              
    759             The id must start with a letter (a-z or A-Z)
    760              
    761             =item *
    762              
    763             All subsequent characters can be letters, numbers (0-9), hyphens (-),
    764             underscores (_), colons (:), and periods (.).
    765              
    766             =item *
    767              
    768             The final character can't be a hyphen, colon, or period. URLs ending with these
    769             characters, while allowed by XHTML, can be awkward to extract from plain text.
    770              
    771             =item *
    772              
    773             Each id must be unique within the document.
    774              
    775             =back
    776              
    777             In addition, the returned value will be unique within the context of the
    778             Pod::Simple::XHTML object unless a second argument is passed a true value. ID
    779             attributes should always be unique within a single XHTML document, but pass
    780             the true value if you are creating not an ID but a URL hash to point to
    781             an ID (i.e., if you need to put the "#foo" in C<< foo >>.
    782              
    783             =cut
    784              
    785             sub idify {
    786 119     119 1 2457 my ($self, $t, $not_unique) = @_;
    787 119         182 for ($t) {
    788 119         190 s/<[^>]+>//g; # Strip HTML.
    789 119         143 s/&[^;]+;//g; # Strip entities.
    790 119         223 s/^\s+//; s/\s+$//; # Strip white space.
      119         182  
    791 119         222 s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
    792 119         152 s/^[^a-zA-Z]+//; # First char must be a letter.
    793 119         202 s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
    794 119         226 s/[-:.]+$//; # Strip trailing punctuation.
    795             }
    796 119 100       251 return $t if $not_unique;
    797 102         120 my $i = '';
    798 102         368 $i++ while $self->{ids}{"$t$i"}++;
    799 102         227 return "$t$i";
    800             }
    801              
    802             =head2 batch_mode_page_object_init
    803              
    804             $pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
    805              
    806             Called by L so that the class has a chance to
    807             initialize the converter. Internally it sets the C property to
    808             true and sets C, but Pod::Simple::XHTML does not
    809             currently use those features. Subclasses might, though.
    810              
    811             =cut
    812              
    813             sub batch_mode_page_object_init {
    814 1     1 1 4 my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
    815 1         5 $self->batch_mode(1);
    816 1         5 $self->batch_mode_current_level($depth);
    817 1         5 return $self;
    818             }
    819              
    820       0 0   sub html_header_after_title {
    821             }
    822              
    823              
    824             1;
    825              
    826             __END__