File Coverage

blib/lib/Pod/Simple/XHTML.pm
Criterion Covered Total %
statement 316 320 98.7
branch 97 118 82.2
condition 37 52 71.1
subroutine 69 70 98.5
pod 9 65 13.8
total 528 625 84.4


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

';

430             }
431              
432             sub start_Verbatim {
433 26     26 0 66 $_[0]{'scratch'} = '
'; 
434 26         45 push(@{$_[0]{'in_code'}}, 'Verbatim');
  26         98  
435 26         99 $_[0]->start_code($_[0]{'in_code'}[-1]);
436             }
437              
438 63     63 0 129 sub start_head1 { $_[0]{'in_head'} = 1; $_[0]{htext} = $_[0]{hhtml} = ''; }
  63         220  
439 15     15 0 31 sub start_head2 { $_[0]{'in_head'} = 2; $_[0]{htext} = $_[0]{hhtml} = ''; }
  15         59  
440 8     8 0 43 sub start_head3 { $_[0]{'in_head'} = 3; $_[0]{htext} = $_[0]{hhtml} = ''; }
  8         23  
441 9     9 0 16 sub start_head4 { $_[0]{'in_head'} = 4; $_[0]{htext} = $_[0]{hhtml} = ''; }
  9         24  
442 2     2 0 7 sub start_head5 { $_[0]{'in_head'} = 5; $_[0]{htext} = $_[0]{hhtml} = ''; }
  2         7  
443 2     2 0 35 sub start_head6 { $_[0]{'in_head'} = 6; $_[0]{htext} = $_[0]{hhtml} = ''; }
  2         10  
444              
445             sub start_item_number {
446 8 100 66 8 0 31 $_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
  3         18  
447 8         18 $_[0]{'scratch'} .= '
  • ';

  • 448 8         14 push @{$_[0]{'in_li'}}, 1;
      8         35  
    449             }
    450              
    451             sub start_item_bullet {
    452 12 100 66 12 0 49 $_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
      5         26  
    453 12         27 $_[0]{'scratch'} .= '
  • ';

  • 454 12         21 push @{$_[0]{'in_li'}}, 1;
      12         39  
    455             }
    456              
    457             sub start_item_text {
    458 17     17 0 45 $_[0]{'in_item_text'} = 1; $_[0]{itext} = '';
      17         52  
    459             # see end_item_text
    460             }
    461              
    462 7     7 0 18 sub start_over_bullet { $_[0]{'scratch'} = '
      '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
      7         15  
      7         24  
      7         26  
    463 1     1 0 4 sub start_over_block { $_[0]{'scratch'} = '
    '; $_[0]->emit }
      1         4  
    464 5     5 0 13 sub start_over_number { $_[0]{'scratch'} = '
      '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
      5         9  
      5         16  
      5         18  
    465             sub start_over_text {
    466 11     11 0 32 $_[0]{'scratch'} = '
    ';
    467 11         29 $_[0]{'dl_level'}++;
    468 11   100     75 $_[0]{'in_dd'} ||= [];
    469 11         33 $_[0]->emit
    470             }
    471              
    472 1     1 0 4 sub end_over_block { $_[0]{'scratch'} .= ''; $_[0]->emit }
      1         3  
    473              
    474             sub end_over_number {
    475 5 50   5 0 10 $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
      5         45  
    476 5         15 $_[0]{'scratch'} .= '';
    477 5         7 pop @{$_[0]{'in_li'}};
      5         12  
    478 5         16 $_[0]->emit;
    479             }
    480              
    481             sub end_over_bullet {
    482 7 50   7 0 14 $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
      7         47  
    483 7         16 $_[0]{'scratch'} .= '';
    484 7         14 pop @{$_[0]{'in_li'}};
      7         38  
    485 7         24 $_[0]->emit;
    486             }
    487              
    488             sub end_over_text {
    489 11 50   11 0 49 if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
    490 11         33 $_[0]{'scratch'} = "\n";
    491 11         30 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
    492             }
    493 11         27 $_[0]{'scratch'} .= '';
    494 11         22 $_[0]{'dl_level'}--;
    495 11         32 $_[0]->emit;
    496             }
    497              
    498             # . . . . . Now the actual formatters:
    499              
    500 88     88 0 216 sub end_Para { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      88         282  
    501             sub end_Verbatim {
    502 26     26 0 58 $_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
      26         113  
    503 26         68 $_[0]{'scratch'} .= '';
    504 26         73 $_[0]->emit;
    505             }
    506              
    507             sub _end_head {
    508 99     99   188 my $h = delete $_[0]{in_head};
    509              
    510 99         278 my $add = $_[0]->html_h_level;
    511 99 100       196 $add = 1 unless defined $add;
    512 99         175 $h += $add - 1;
    513              
    514 99         264 my $id = $_[0]->idify(delete $_[0]{htext});
    515 99         286 my $text = $_[0]{scratch};
    516 99         263 my $head = qq{$text};
    517 99 100 100     1924 $_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
    518             # backlinks enabled && =head1
    519             ? qq{$head}
    520             : $head;
    521 99         306 $_[0]->emit;
    522 99         139 push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'hhtml'}];
      99         508  
    523             }
    524              
    525 63     63 0 171 sub end_head1 { shift->_end_head(@_); }
    526 15     15 0 71 sub end_head2 { shift->_end_head(@_); }
    527 8     8 0 20 sub end_head3 { shift->_end_head(@_); }
    528 9     9 0 21 sub end_head4 { shift->_end_head(@_); }
    529 2     2 0 7 sub end_head5 { shift->_end_head(@_); }
    530 2     2 0 8 sub end_head6 { shift->_end_head(@_); }
    531              
    532 12     12 0 31 sub end_item_bullet { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      12         36  
    533 8     8 0 21 sub end_item_number { $_[0]{'scratch'} .= '

    '; $_[0]->emit }
      8         24  
    534              
    535             sub end_item_text {
    536             # idify and anchor =item content if wanted
    537             my $dt_id = $_[0]{'anchor_items'}
    538 17 100   17 0 68 ? ' id="'. $_[0]->encode_entities($_[0]->idify($_[0]{'itext'})) .'"'
    539             : '';
    540              
    541             # reset scratch
    542 17         156 my $text = $_[0]{scratch};
    543 17         40 $_[0]{'scratch'} = '';
    544              
    545 17 100       58 if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
    546 6         13 $_[0]{'scratch'} = "\n";
    547 6         34 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
    548             }
    549              
    550 17         46 $_[0]{'scratch'} .= qq{$text\n
    };
    551 17         44 $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
    552 17         67 $_[0]->emit;
    553             }
    554              
    555             # This handles =begin and =for blocks of all kinds.
    556             sub start_for {
    557 6     6 0 16 my ($self, $flags) = @_;
    558              
    559 6         29 push @{ $self->{__region_targets} }, $flags->{target_matching};
      6         20  
    560 6         14 $self->{started_for} = 1;
    561 6         10 $self->{in_for} = 1;
    562              
    563 6 100       16 unless ($self->__in_literal_xhtml_region) {
    564 4         8 $self->{scratch} .= '
    565 4 50       12 $self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
    566 4         13 $self->{scratch} .= ">\n\n";
    567             }
    568             }
    569              
    570             sub end_for {
    571 6     6 0 13 my ($self) = @_;
    572 6         13 delete $self->{started_for};
    573 6         12 delete $self->{in_for};
    574              
    575 6 100       16 if ($self->__in_literal_xhtml_region) {
    576             # Remove trailine newlines.
    577 2         22 $self->{'scratch'} =~ s/\s+\z//s;
    578             } else {
    579 4         8 $self->{'scratch'} .= '';
    580             }
    581              
    582 6         11 pop @{ $self->{__region_targets} };
      6         13  
    583 6         18 $self->emit;
    584             }
    585              
    586             sub start_Document {
    587 134     134 0 339 my ($self) = @_;
    588 134 100       443 if (defined $self->html_header) {
    589 114         348 $self->{'scratch'} .= $self->html_header;
    590 114 100       291 $self->emit unless $self->html_header eq "";
    591             } else {
    592 20         37 my ($doctype, $title, $metatags, $bodyid);
    593 20   50     68 $doctype = $self->html_doctype || '';
    594 20   50     63 $title = $self->force_title || $self->title || $self->default_title || '';
    595 20   50     71 $metatags = $self->html_header_tags || '';
    596 20 100       75 if (my $css = $self->html_css) {
    597 3 100       17 if ($css !~ /
    598             # this is required to be compatible with Pod::Simple::BatchHTML
    599 2         7 $metatags .= ' 600             . $self->encode_entities($css) . '" type="text/css" />';
    601             } else {
    602 1         3 $metatags .= $css;
    603             }
    604             }
    605 20 50       126 if ($self->html_javascript) {
    606 0         0 $metatags .= qq{\n';
    608             }
    609 20 100       65 $bodyid = $self->backlink ? ' id="_podtop_"' : '';
    610 20         88 $self->{'scratch'} .= <<"HTML";
    611             $doctype
    612            
    613            
    614             $title
    615             $metatags
    616            
    617            
    618             HTML
    619 20         55 $self->emit;
    620             }
    621             }
    622              
    623             sub build_index {
    624 30     30 0 57 my ($self, $to_index) = @_;
    625              
    626 30         37 my @out;
    627 30         40 my $level = 0;
    628 30         37 my $indent = -1;
    629 30         48 my $space = '';
    630 30         40 my $id = ' id="index"';
    631              
    632 30         39 for my $h (@{ $to_index }, [0]) {
      30         71  
    633 96         139 my $target_level = $h->[0];
    634             # Get to target_level by opening or closing ULs
    635 96 100       167 if ($level == $target_level) {
        100          
    636 9         18 $out[-1] .= '';
    637             } elsif ($level > $target_level) {
    638 36 50       199 $out[-1] .= '' if $out[-1] =~ /^\s+
  • /;
  • 639 36         102 while ($level > $target_level) {
    640 65         69 --$level;
    641 65 100 66     216 push @out, (' ' x --$indent) . '' if @out && $out[-1] =~ m{^\s+<\/ul};
    642 65         190 push @out, (' ' x --$indent) . '';
    643             }
    644 36 100       92 push @out, (' ' x --$indent) . '' if $level;
    645             } else {
    646 51         92 while ($level < $target_level) {
    647 65         67 ++$level;
    648 65 100 100     191 push @out, (' ' x ++$indent) . '
  • ' if @out && $out[-1]=~ /^\s*
  • 649 65         169 push @out, (' ' x ++$indent) . "";
    650 65         99 $id = '';
    651             }
    652 51         69 ++$indent;
    653             }
    654              
    655 96 100       160 next unless $level;
    656 66         109 $space = ' ' x $indent;
    657 66         125 my $fragment = $self->encode_entities($self->encode_url($h->[1]));
    658 66         1020 push @out, sprintf '%s
  • %s',
  • 659             $space, $fragment, $h->[2];
    660             }
    661              
    662 30         138 return join "\n", @out;
    663             }
    664              
    665             sub end_Document {
    666 134     134 0 293 my ($self) = @_;
    667 134         265 my $to_index = $self->{'to_index'};
    668 134 100 100     416 if ($self->index && @{ $to_index } ) {
      34         90  
    669 30         78 my $index = $self->build_index($to_index);
    670              
    671             # Splice the index in between the HTML headers and the first element.
    672 30 50       79 my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
        100          
    673 30         51 splice @{ $self->{'output'} }, $offset, 0, $index;
      30         87  
    674             }
    675              
    676 134 100       378 if (defined $self->html_footer) {
    677 114         260 $self->{'scratch'} .= $self->html_footer;
    678 114 100       241 $self->emit unless $self->html_footer eq "";
    679             } else {
    680 20         47 $self->{'scratch'} .= "\n";
    681 20         73 $self->emit;
    682             }
    683              
    684 134 100       311 if ($self->index) {
    685 34         53 print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
      34         61  
      34         200  
    686 34         54 @{$self->{'output'}} = ();
      34         142  
    687             }
    688              
    689             }
    690              
    691             # Handling code tags
    692 7     7 0 20 sub start_B { $_[0]{'scratch'} .= '' }
    693 7     7 0 22 sub end_B { $_[0]{'scratch'} .= '' }
    694              
    695 10     10 0 32 sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); }
      10         34  
      10         37  
    696 10     10 0 18 sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); }
      10         37  
    697              
    698 1     1 0 2 sub start_F { $_[0]{'scratch'} .= '' }
    699 1     1 0 2 sub end_F { $_[0]{'scratch'} .= '' }
    700              
    701 1     1 0 4 sub start_I { $_[0]{'scratch'} .= '' }
    702 1     1 0 4 sub end_I { $_[0]{'scratch'} .= '' }
    703              
    704 1     1 0 4 sub start_U { $_[0]{'scratch'} .= '' }
    705 1     1 0 4 sub end_U { $_[0]{'scratch'} .= '' }
    706              
    707             sub start_L {
    708 33     33 0 74 my ($self, $flags) = @_;
    709 33         63 my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
      33         108  
    710 33 50       174 my $url = $self->encode_entities(
        100          
        100          
    711             $type eq 'url' ? $to
    712             : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
    713             : $type eq 'man' ? $self->resolve_man_page_link($to, $section)
    714             : undef
    715             );
    716              
    717             # If it's an unknown type, use an attribute-less like HTML.pm.
    718 33 50       772 $self->{'scratch'} .= '' : '>');
    719             }
    720              
    721 33     33 0 99 sub end_L { $_[0]{'scratch'} .= '' }
    722              
    723 1     1 0 5 sub start_S { $_[0]{'scratch'} .= '' }
    724 1     1 0 5 sub end_S { $_[0]{'scratch'} .= '' }
    725              
    726             sub emit {
    727 346     346 0 696 my($self) = @_;
    728 346 100       908 if ($self->index) {
    729 120         151 push @{ $self->{'output'} }, $self->{'scratch'};
      120         304  
    730             } else {
    731 226         351 print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
      226         1249  
    732             }
    733 346         705 $self->{'scratch'} = '';
    734 346         969 return;
    735             }
    736              
    737             =head2 resolve_pod_page_link
    738              
    739             my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
    740             my $url = $pod->resolve_pod_page_link('perlpodspec');
    741             my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
    742              
    743             Resolves a POD link target (typically a module or POD file name) and section
    744             name to a URL. The resulting link will be returned for the above examples as:
    745              
    746             https://metacpan.org/pod/Net::Ping#INSTALL
    747             https://metacpan.org/pod/perlpodspec
    748             #SYNOPSIS
    749              
    750             Note that when there is only a section argument the URL will simply be a link
    751             to a section in the current document.
    752              
    753             =cut
    754              
    755             sub resolve_pod_page_link {
    756 23     23 1 109 my ($self, $to, $section) = @_;
    757 23 50 66     114 return undef unless defined $to || defined $section;
    758 23 100       68 if (defined $section) {
    759 15         60 my $id = $self->idify($section, 1);
    760 15         80 $section = '#' . $self->encode_url($id);
    761 15 100       73 return $section unless defined $to;
    762             } else {
    763 8         26 $section = ''
    764             }
    765              
    766 13   50     48 return ($self->perldoc_url_prefix || '')
          50        
    767             . $to . $section
    768             . ($self->perldoc_url_postfix || '');
    769             }
    770              
    771             =head2 resolve_man_page_link
    772              
    773             my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
    774             my $url = $pod->resolve_man_page_link('crontab');
    775              
    776             Resolves a man page link target and numeric section to a URL. The resulting
    777             link will be returned for the above examples as:
    778              
    779             https://man7.org/linux/man-pages/man5/crontab.5.html
    780             https://man7.org/linux/man-pages/man1/crontab.1.html
    781              
    782             Note that the first argument is required. The section number will be parsed
    783             from it, and if it's missing will default to 1. The second argument is
    784             currently ignored. Subclass to link to a different man page HTTP server.
    785              
    786             =cut
    787              
    788             sub resolve_man_page_link {
    789 6     6 1 17 my ($self, $to, $section) = @_;
    790 6 50       18 return undef unless defined $to;
    791              
    792 6         31 my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
    793 6 50       17 return undef unless $page;
    794              
    795 6   50     18 return ($self->man_url_prefix || '')
          100        
          100        
          50        
    796             . ($part || 1) . "/" . $self->encode_entities($page)
    797             . "." . ($part || 1) . ($self->man_url_postfix || '');
    798              
    799             }
    800              
    801             =head2 idify
    802              
    803             my $id = $pod->idify($text);
    804             my $hash = $pod->idify($text, 1);
    805              
    806             This method turns an arbitrary string into a valid XHTML ID attribute value.
    807             The rules enforced, following
    808             L, are:
    809              
    810             =over
    811              
    812             =item *
    813              
    814             The id must start with a letter (a-z or A-Z)
    815              
    816             =item *
    817              
    818             All subsequent characters can be letters, numbers (0-9), hyphens (-),
    819             underscores (_), colons (:), and periods (.).
    820              
    821             =item *
    822              
    823             The final character can't be a hyphen, colon, or period. URLs ending with these
    824             characters, while allowed by XHTML, can be awkward to extract from plain text.
    825              
    826             =item *
    827              
    828             Each id must be unique within the document.
    829              
    830             =back
    831              
    832             In addition, the returned value will be unique within the context of the
    833             Pod::Simple::XHTML object unless a second argument is passed a true value. ID
    834             attributes should always be unique within a single XHTML document, but pass
    835             the true value if you are creating not an ID but a URL hash to point to
    836             an ID (i.e., if you need to put the "#foo" in C<< foo >>.
    837              
    838             =cut
    839              
    840             sub idify {
    841 120     120 1 2913 my ($self, $t, $not_unique) = @_;
    842 120         217 for ($t) {
    843 120         259 s/[<>&'"]//g; # Strip HTML special characters
    844 120         308 s/^\s+//; s/\s+$//; # Strip white space.
      120         264  
    845 120         281 s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
    846 120         200 s/^[^a-zA-Z]+//; # First char must be a letter.
    847 120         271 s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
    848 120         274 s/[-:.]+$//; # Strip trailing punctuation.
    849             }
    850 120 100       297 return $t if $not_unique;
    851 103         146 my $i = '';
    852 103         418 $i++ while $self->{ids}{"$t$i"}++;
    853 103         304 return "$t$i";
    854             }
    855              
    856             =head2 batch_mode_page_object_init
    857              
    858             $pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
    859              
    860             Called by L so that the class has a chance to
    861             initialize the converter. Internally it sets the C property to
    862             true and sets C, but Pod::Simple::XHTML does not
    863             currently use those features. Subclasses might, though.
    864              
    865             =cut
    866              
    867             sub batch_mode_page_object_init {
    868 1     1 1 3 my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
    869 1         4 $self->batch_mode(1);
    870 1         3 $self->batch_mode_current_level($depth);
    871 1         3 return $self;
    872             }
    873              
    874       0 0   sub html_header_after_title {
    875             }
    876              
    877              
    878             1;
    879              
    880             __END__