| 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 |
|||||||||||||
| 23 | methods. The implementation is entirely different than | |||||||||||||
| 24 | L |
|||||||||||||
| 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 LE |
|||||||||||||
| 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<< LE |
|||||||||||||
| 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 |
|||||||||||||
| 166 | C |
|||||||||||||
| 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 |
|||||||||||||
| 184 | L |
|||||||||||||
| 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 |
|||||||||||||
| 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 |
|||||||||||||
| 207 | content tag (customized by C |
|||||||||||||
| 208 | (if C |
|||||||||||||
| 209 | C |
|||||||||||||
| 210 | and C tags. | |||||||||||||
| 211 | ||||||||||||||
| 212 | The options listed above customize parts of the default header, but | |||||||||||||
| 213 | setting C |
|||||||||||||
| 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<< |
|||||||||||||
| 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 |
|||||||||||||
| 319 | ||||||||||||||
| 320 | $new->accept_targets_as_text( 'foo' ); | |||||||||||||
| 321 | ||||||||||||||
| 322 | Then override the C |
|||||||||||||
| 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 |
|||||||||||||
| 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 tags |
|||||||||||||
| 345 | before and after C |
|||||||||||||
| 346 | together with C |
|||||||||||||
| 347 | ||||||||||||||
| 348 | Note that the code might be broken into multiple segments if there are | |||||||||||||
| 349 | nested formatting codes inside a C<< CE |
|||||||||||||
| 350 | calls to C |
|||||||||||||
| 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 |
|||||||||||||
| 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'} = '
|
|||||||||
| 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'} = '
|
|||||||||
| 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{ |
|||||||||||
| 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{ |
|||||||||||
| 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 | |
|||||||||||||
| 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) . ' | |||||||||
| 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 |
|||||||||||
| 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 |
|||||||||||||
| 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 |
|||||||||||||
| 861 | initialize the converter. Internally it sets the C |
|||||||||||||
| 862 | true and sets C |
|||||||||||||
| 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__ |