local-lib5/lib/perl5/Pod/Simple/XHTML.pm

   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<Pod::Simple::Methody> and inherits all its
  23 methods. The implementation is entirely different than
  24 L<Pod::Simple::HTML>, but it largely preserves the same interface.
  25
  26 =cut
  27
  28 package Pod::Simple::XHTML;
  29 use strict;
  30 use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
  31 $VERSION = '3.10';
  32 use Carp ();
  33 use Pod::Simple::Methody ();
  34 @ISA = ('Pod::Simple::Methody');
  35
  36 BEGIN {
  37   $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
  38 }
  39
  40 my %entities = (
  41   q{>} => 'gt',
  42   q{<} => 'lt',
  43   q{'} => '#39',
  44   q{"} => 'quot',
  45   q{&} => 'amp',
  46 );
  47
  48 sub encode_entities {
  49   return HTML::Entities::encode_entities( $_[0] ) if $HAS_HTML_ENTITIES;
  50   my $str = $_[0];
  51   my $ents = join '', keys %entities;
  52   $str =~ s/([$ents])/'&' . $entities{$1} . ';'/ge;
  53   return $str;
  54 }
  55
  56 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  57
  58 =head1 METHODS
  59
  60 Pod::Simple::XHTML offers a number of methods that modify the format of
  61 the HTML output. Call these after creating the parser object, but before
  62 the call to C<parse_file>:
  63
  64   my $parser = Pod::PseudoPod::HTML->new();
  65   $parser->set_optional_param("value");
  66   $parser->parse_file($file);
  67
  68 =head2 perldoc_url_prefix
  69
  70 In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
  71 to put before the "Foo%3a%3aBar". The default value is
  72 "http://search.cpan.org/perldoc?".
  73
  74 =head2 perldoc_url_postfix
  75
  76 What to put after "Foo%3a%3aBar" in the URL. This option is not set by
  77 default.
  78
  79 =head2 title_prefix, title_postfix
  80
  81 What to put before and after the title in the head. The values should
  82 already be &-escaped.
  83
  84 =head2 html_css
  85
  86   $parser->html_css('path/to/style.css');
  87
  88 The URL or relative path of a CSS file to include. This option is not
  89 set by default.
  90
  91 =head2 html_javascript
  92
  93 The URL or relative path of a JavaScript file to pull in. This option is
  94 not set by default.
  95
  96 =head2 html_doctype
  97
  98 A document type tag for the file. This option is not set by default.
  99
 100 =head2 html_header_tags
 101
 102 Additional arbitrary HTML tags for the header of the document. The
 103 default value is just a content type header tag:
 104
 105   <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
 106
 107 Add additional meta tags here, or blocks of inline CSS or JavaScript
 108 (wrapped in the appropriate tags).
 109
 110 =head2 default_title
 111
 112 Set a default title for the page if no title can be determined from the
 113 content. The value of this string should already be &-escaped.
 114
 115 =head2 force_title
 116
 117 Force a title for the page (don't try to determine it from the content).
 118 The value of this string should already be &-escaped.
 119
 120 =head2 html_header, html_footer
 121
 122 Set the HTML output at the beginning and end of each file. The default
 123 header includes a title, a doctype tag (if C<html_doctype> is set), a
 124 content tag (customized by C<html_header_tags>), a tag for a CSS file
 125 (if C<html_css> is set), and a tag for a Javascript file (if
 126 C<html_javascript> is set). The default footer simply closes the C<html>
 127 and C<body> tags.
 128
 129 The options listed above customize parts of the default header, but
 130 setting C<html_header> or C<html_footer> completely overrides the
 131 built-in header or footer. These may be useful if you want to use
 132 template tags instead of literal HTML headers and footers or are
 133 integrating converted POD pages in a larger website.
 134
 135 If you want no headers or footers output in the HTML, set these options
 136 to the empty string.
 137
 138 =head2 index
 139
 140 Whether to add a table-of-contents at the top of each page (called an
 141 index for the sake of tradition).
 142
 143
 144 =cut
 145
 146 __PACKAGE__->_accessorize(
 147  'perldoc_url_prefix',
 148  'perldoc_url_postfix',
 149  'title_prefix',  'title_postfix',
 150  'html_css',
 151  'html_javascript',
 152  'html_doctype',
 153  'html_header_tags',
 154  'title', # Used internally for the title extracted from the content
 155  'default_title',
 156  'force_title',
 157  'html_header',
 158  'html_footer',
 159  'index',
 160  'batch_mode', # whether we're in batch mode
 161  'batch_mode_current_level',
 162     # When in batch mode, how deep the current module is: 1 for "LWP",
 163     #  2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
 164 );
 165
 166 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 167
 168 =head1 SUBCLASSING
 169
 170 If the standard options aren't enough, you may want to subclass
 171 Pod::Simple::XHMTL. These are the most likely candidates for methods
 172 you'll want to override when subclassing.
 173
 174 =cut
 175
 176 sub new {
 177   my $self = shift;
 178   my $new = $self->SUPER::new(@_);
 179   $new->{'output_fh'} ||= *STDOUT{IO};
 180   $new->accept_targets( 'html', 'HTML' );
 181   $new->perldoc_url_prefix('http://search.cpan.org/perldoc?');
 182   $new->html_header_tags('<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />');
 183   $new->nix_X_codes(1);
 184   $new->codes_in_verbatim(1);
 185   $new->{'scratch'} = '';
 186   $new->{'to_index'} = [];
 187   $new->{'output'} = [];
 188   $new->{'saved'} = [];
 189   $new->{'ids'} = {};
 190   return $new;
 191 }
 192
 193 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 194
 195 =head2 handle_text
 196
 197 This method handles the body of text within any element: it's the body
 198 of a paragraph, or everything between a "=begin" tag and the
 199 corresponding "=end" tag, or the text within an L entity, etc. You would
 200 want to override this if you are adding a custom element type that does
 201 more than just display formatted text. Perhaps adding a way to generate
 202 HTML tables from an extended version of POD.
 203
 204 So, let's say you want add a custom element called 'foo'. In your
 205 subclass's C<new> method, after calling C<SUPER::new> you'd call:
 206
 207   $new->accept_targets_as_text( 'foo' );
 208
 209 Then override the C<start_for> method in the subclass to check for when
 210 "$flags->{'target'}" is equal to 'foo' and set a flag that marks that
 211 you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
 212 C<handle_text> method to check for the flag, and pass $text to your
 213 custom subroutine to construct the HTML output for 'foo' elements,
 214 something like:
 215
 216   sub handle_text {
 217       my ($self, $text) = @_;
 218       if ($self->{'in_foo'}) {
 219           $self->{'scratch'} .= build_foo_html($text);
 220       } else {
 221           $self->{'scratch'} .= $text;
 222       }
 223   }
 224
 225 =cut
 226
 227 sub handle_text {
 228     # escape special characters in HTML (<, >, &, etc)
 229     $_[0]{'scratch'} .= encode_entities( $_[1] )
 230 }
 231
 232 sub start_Para     { $_[0]{'scratch'} = '<p>' }
 233 sub start_Verbatim { $_[0]{'scratch'} = '<pre><code>' }
 234
 235 sub start_head1 {  $_[0]{'in_head'} = 1 }
 236 sub start_head2 {  $_[0]{'in_head'} = 2 }
 237 sub start_head3 {  $_[0]{'in_head'} = 3 }
 238 sub start_head4 {  $_[0]{'in_head'} = 4 }
 239
 240 sub start_item_number {
 241     $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
 242     $_[0]{'scratch'} .= '<li><p>';
 243     $_[0]{'in_li'} = 1
 244 }
 245
 246 sub start_item_bullet {
 247     $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
 248     $_[0]{'scratch'} .= '<li><p>';
 249     $_[0]{'in_li'} = 1
 250 }
 251
 252 sub start_item_text   {
 253     if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
 254         $_[0]{'scratch'} = "</dd>\n";
 255         $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
 256     }
 257     $_[0]{'scratch'} .= '<dt>';
 258 }
 259
 260 sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
 261 sub start_over_block  { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
 262 sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit }
 263 sub start_over_text   {
 264     $_[0]{'scratch'} = '<dl>';
 265     $_[0]{'dl_level'}++;
 266     $_[0]{'in_dd'} ||= [];
 267     $_[0]->emit
 268 }
 269
 270 sub end_over_block  { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
 271
 272 sub end_over_number   {
 273     $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
 274     $_[0]{'scratch'} .= '</ol>';
 275     $_[0]->emit;
 276 }
 277
 278 sub end_over_bullet   {
 279     $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
 280     $_[0]{'scratch'} .= '</ul>';
 281     $_[0]->emit;
 282 }
 283
 284 sub end_over_text   {
 285     if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
 286         $_[0]{'scratch'} = "</dd>\n";
 287         $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
 288     }
 289     $_[0]{'scratch'} .= '</dl>';
 290     $_[0]{'dl_level'}--;
 291     $_[0]->emit;
 292 }
 293
 294 # . . . . . Now the actual formatters:
 295
 296 sub end_Para     { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
 297 sub end_Verbatim {
 298     $_[0]{'scratch'}     .= '</code></pre>';
 299     $_[0]->emit;
 300 }
 301
 302 sub _end_head {
 303     my $h = delete $_[0]{in_head};
 304     my $id = $_[0]->idify($_[0]{scratch});
 305     my $text = $_[0]{scratch};
 306     $_[0]{'scratch'} = qq{<h$h id="$id">$text</h$h>};
 307     $_[0]->emit;
 308     push @{ $_[0]{'to_index'} }, [$h, $id, $text];
 309 }
 310
 311 sub end_head1       { shift->_end_head(@_); }
 312 sub end_head2       { shift->_end_head(@_); }
 313 sub end_head3       { shift->_end_head(@_); }
 314 sub end_head4       { shift->_end_head(@_); }
 315
 316 sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
 317 sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
 318
 319 sub end_item_text   {
 320     $_[0]{'scratch'} .= "</dt>\n<dd>";
 321     $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
 322     $_[0]->emit;
 323 }
 324
 325 # This handles =begin and =for blocks of all kinds.
 326 sub start_for {
 327   my ($self, $flags) = @_;
 328   $self->{'scratch'} .= '<div';
 329   $self->{'scratch'} .= ' class="'.$flags->{'target'}.'"' if ($flags->{'target'});
 330   $self->{'scratch'} .= '>';
 331   $self->emit;
 332
 333 }
 334 sub end_for {
 335   my ($self) = @_;
 336   $self->{'scratch'} .= '</div>';
 337   $self->emit;
 338 }
 339
 340 sub start_Document {
 341   my ($self) = @_;
 342   if (defined $self->html_header) {
 343     $self->{'scratch'} .= $self->html_header;
 344     $self->emit unless $self->html_header eq "";
 345   } else {
 346     my ($doctype, $title, $metatags);
 347     $doctype = $self->html_doctype || '';
 348     $title = $self->force_title || $self->title || $self->default_title || '';
 349     $metatags = $self->html_header_tags || '';
 350     if ($self->html_css) {
 351       $metatags .= "\n<link rel='stylesheet' href='" .
 352              $self->html_css . "' type='text/css'>";
 353     }
 354     if ($self->html_javascript) {
 355       $metatags .= "\n<script type='text/javascript' src='" .
 356                     $self->html_javascript . "'></script>";
 357     }
 358     $self->{'scratch'} .= <<"HTML";
 359 $doctype
 360 <html>
 361 <head>
 362 <title>$title</title>
 363 $metatags
 364 </head>
 365 <body>
 366 HTML
 367     $self->emit;
 368   }
 369 }
 370
 371 sub end_Document   {
 372   my ($self) = @_;
 373   my $to_index = $self->{'to_index'};
 374   if ($self->index && @{ $to_index } ) {
 375       my @out;
 376       my $level  = 0;
 377       my $indent = -1;
 378       my $space  = '';
 379       my $id     = ' id="index"';
 380
 381       for my $h (@{ $to_index }, [0]) {
 382           my $target_level = $h->[0];
 383           # Get to target_level by opening or closing ULs
 384           if ($level == $target_level) {
 385               $out[-1] .= '</li>';
 386           } elsif ($level > $target_level) {
 387               $out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
 388               while ($level > $target_level) {
 389                   --$level;
 390                   push @out, ('  ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
 391                   push @out, ('  ' x --$indent) . '</ul>';
 392               }
 393               push @out, ('  ' x --$indent) . '</li>' if $level;
 394           } else {
 395               while ($level < $target_level) {
 396                   ++$level;
 397                   push @out, ('  ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
 398                   push @out, ('  ' x ++$indent) . "<ul$id>";
 399                   $id = '';
 400               }
 401               ++$indent;
 402           }
 403
 404           next unless $level;
 405           $space = '  '  x $indent;
 406           push @out, sprintf '%s<li><a href="#%s">%s</a>',
 407               $space, $h->[1], $h->[2];
 408       }
 409       # Splice the index in between the HTML headers and the first element.
 410       my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
 411       splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
 412   }
 413
 414   if (defined $self->html_footer) {
 415     $self->{'scratch'} .= $self->html_footer;
 416     $self->emit unless $self->html_footer eq "";
 417   } else {
 418     $self->{'scratch'} .= "</body>\n</html>";
 419     $self->emit;
 420   }
 421
 422   if ($self->index) {
 423       print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
 424       @{$self->{'output'}} = ();
 425   }
 426
 427 }
 428
 429 # Handling code tags
 430 sub start_B { $_[0]{'scratch'} .= '<b>' }
 431 sub end_B   { $_[0]{'scratch'} .= '</b>' }
 432
 433 sub start_C { $_[0]{'scratch'} .= '<code>' }
 434 sub end_C   { $_[0]{'scratch'} .= '</code>' }
 435
 436 sub start_E {
 437   my ($self, $flags) = @_;
 438   push @{ $self->{'saved'} }, $self->{'scratch'};
 439   $self->{'scratch'} = '';
 440 }
 441 sub end_E   {
 442   my ($self, $flags) = @_;
 443   my $previous = pop @{ $self->{'saved'} };
 444   my $entity = $self->{'scratch'};
 445
 446   if ($entity =~ 'sol' or $entity =~ 'verbar') {
 447     my $char = Pod::Escapes::e2char($entity);
 448     if (defined($char)) {
 449       $self->{'scratch'} = $previous . $char;
 450       return;
 451     }
 452   }
 453
 454   if ($entity =~ /^[0-9]/) {
 455       $entity = '#' . $entity;
 456   }
 457
 458   $self->{'scratch'} = $previous . '&'. $entity . ';'
 459 }
 460
 461 sub start_F { $_[0]{'scratch'} .= '<i>' }
 462 sub end_F   { $_[0]{'scratch'} .= '</i>' }
 463
 464 sub start_I { $_[0]{'scratch'} .= '<i>' }
 465 sub end_I   { $_[0]{'scratch'} .= '</i>' }
 466
 467 sub start_L {
 468   my ($self, $flags) = @_;
 469     my $url;
 470     if ($flags->{'type'} eq 'url') {
 471       $url = $flags->{'to'};
 472     } elsif ($flags->{'type'} eq 'pod') {
 473       $url .= $self->perldoc_url_prefix || '';
 474       $url .= $flags->{'to'} || '';
 475       $url .= '/' . $flags->{'section'} if ($flags->{'section'});
 476       $url .= $self->perldoc_url_postfix || '';
 477 #    require Data::Dumper;
 478 #    print STDERR Data::Dumper->Dump([$flags]);
 479     }
 480
 481     $self->{'scratch'} .= '<a href="'. $url . '">';
 482 }
 483 sub end_L   { $_[0]{'scratch'} .= '</a>' }
 484
 485 sub start_S { $_[0]{'scratch'} .= '<nobr>' }
 486 sub end_S   { $_[0]{'scratch'} .= '</nobr>' }
 487
 488 sub emit {
 489   my($self) = @_;
 490   if ($self->index) {
 491       push @{ $self->{'output'} }, $self->{'scratch'};
 492   } else {
 493       print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
 494   }
 495   $self->{'scratch'} = '';
 496   return;
 497 }
 498
 499 =head2 idify
 500
 501   my $id   = $pod->idify($text);
 502   my $hash = $pod->idify($text, 1);
 503
 504 This method turns an arbitrary string into a valid XHTML ID attribute value.
 505 The rules enforced, following
 506 L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
 507
 508 =over
 509
 510 =item *
 511
 512 The id must start with a letter (a-z or A-Z)
 513
 514 =item *
 515
 516 All subsequent characters can be letters, numbers (0-9), hyphens (-),
 517 underscores (_), colons (:), and periods (.).
 518
 519 =item *
 520
 521 Each id must be unique within the document.
 522
 523 =back
 524
 525 In addition, the returned value will be unique within the context of the
 526 Pod::Simple::XHTML object unless a second argument is passed a true value. ID
 527 attributes should always be unique within a single XHTML document, but pass
 528 the true value if you are creating not an ID but a URL hash to point to
 529 an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
 530
 531 =cut
 532
 533 sub idify {
 534     my ($self, $t, $not_unique) = @_;
 535     for ($t) {
 536         s/<[^>]+>//g;            # Strip HTML.
 537         s/&[^;]+;//g;            # Strip entities.
 538         s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
 539         s/^[^a-zA-Z]+//;         # First char must be a letter.
 540         s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
 541     }
 542     return $t if $not_unique;
 543     my $i = '';
 544     $i++ while $self->{ids}{"$t$i"}++;
 545     return "$t$i";
 546 }
 547
 548 # Bypass built-in E<> handling to preserve entity encoding
 549 sub _treat_Es {}
 550
 551 1;
 552
 553 __END__
 554
 555 =head1 SEE ALSO
 556
 557 L<Pod::Simple>, L<Pod::Simple::Methody>
 558
 559 =head1 COPYRIGHT
 560
 561 Copyright (c) 2003-2005 Allison Randal.
 562
 563 This library is free software; you can redistribute it and/or modify
 564 it under the same terms as Perl itself.
 565
 566 This library is distributed in the hope that it will be useful, but
 567 without any warranty; without even the implied warranty of
 568 merchantability or fitness for a particular purpose.
 569
 570 =head1 AUTHOR
 571
 572 Allison Randal <allison@perl.org>
 573
 574 =cut
 575