cpan/Pod-Simple/lib/Pod/Simple/HTML.pm

   1
   2 require 5;
   3 package Pod::Simple::HTML;
   4 use strict;
   5 use Pod::Simple::PullParser ();
   6 use vars qw(
   7   @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
   8   $Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix
   9   $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
  10   $Doctype_decl  $Content_decl
  11 );
  12 @ISA = ('Pod::Simple::PullParser');
  13 $VERSION = '3.17';
  14
  15 BEGIN {
  16   if(defined &DEBUG) { } # no-op
  17   elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
  18   else { *DEBUG = sub () {0}; }
  19 }
  20
  21 $Doctype_decl ||= '';  # No.  Just No.  Don't even ask me for it.
  22  # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
  23  #    "http://www.w3.org/TR/html4/loose.dtd">\n};
  24
  25 $Content_decl ||=
  26  q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
  27
  28 $HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
  29 $Computerese =  "" unless defined $Computerese;
  30 $LamePad = '' unless defined $LamePad;
  31
  32 $Linearization_Limit = 120 unless defined $Linearization_Limit;
  33  # headings/items longer than that won't get an <a name="...">
  34 $Perldoc_URL_Prefix  = 'http://search.cpan.org/perldoc?'
  35  unless defined $Perldoc_URL_Prefix;
  36 $Perldoc_URL_Postfix = ''
  37  unless defined $Perldoc_URL_Postfix;
  38
  39
  40 $Man_URL_Prefix  = 'http://man.he.net/man';
  41 $Man_URL_Postfix = '';
  42
  43 $Title_Prefix  = '' unless defined $Title_Prefix;
  44 $Title_Postfix = '' unless defined $Title_Postfix;
  45 %ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
  46   # 'item-text' stuff in the index doesn't quite work, and may
  47   # not be a good idea anyhow.
  48
  49
  50 __PACKAGE__->_accessorize(
  51  'perldoc_url_prefix',
  52    # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
  53    #  to put before the "Foo%3a%3aBar".
  54    # (for singleton mode only?)
  55  'perldoc_url_postfix',
  56    # what to put after "Foo%3a%3aBar" in the URL.  Normally "".
  57
  58  'man_url_prefix',
  59    # In turning L<crontab(5)> into http://whatever/man/1/crontab, what
  60    #  to put before the "1/crontab".
  61  'man_url_postfix',
  62    #  what to put after the "1/crontab" in the URL. Normally "".
  63
  64  'batch_mode', # whether we're in batch mode
  65  'batch_mode_current_level',
  66     # When in batch mode, how deep the current module is: 1 for "LWP",
  67     #  2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
  68
  69  'title_prefix',  'title_postfix',
  70   # What to put before and after the title in the head.
  71   # Should already be &-escaped
  72
  73  'html_h_level',
  74
  75  'html_header_before_title',
  76  'html_header_after_title',
  77  'html_footer',
  78
  79  'index', # whether to add an index at the top of each page
  80     # (actually it's a table-of-contents, but we'll call it an index,
  81     #  out of apparently longstanding habit)
  82
  83  'html_css', # URL of CSS file to point to
  84  'html_javascript', # URL of Javascript file to point to
  85
  86  'force_title',   # should already be &-escaped
  87  'default_title', # should already be &-escaped
  88 );
  89
  90 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  91 my @_to_accept;
  92
  93 %Tagmap = (
  94   'Verbatim'  => "\n<pre$Computerese>",
  95   '/Verbatim' => "</pre>\n",
  96   'VerbatimFormatted'  => "\n<pre$Computerese>",
  97   '/VerbatimFormatted' => "</pre>\n",
  98   'VerbatimB'  => "<b>",
  99   '/VerbatimB' => "</b>",
 100   'VerbatimI'  => "<i>",
 101   '/VerbatimI' => "</i>",
 102   'VerbatimBI'  => "<b><i>",
 103   '/VerbatimBI' => "</i></b>",
 104
 105
 106   'Data'  => "\n",
 107   '/Data' => "\n",
 108
 109   'head1' => "\n<h1>",  # And also stick in an <a name="...">
 110   'head2' => "\n<h2>",  #  ''
 111   'head3' => "\n<h3>",  #  ''
 112   'head4' => "\n<h4>",  #  ''
 113   '/head1' => "</a></h1>\n",
 114   '/head2' => "</a></h2>\n",
 115   '/head3' => "</a></h3>\n",
 116   '/head4' => "</a></h4>\n",
 117
 118   'X'  => "<!--\n\tINDEX: ",
 119   '/X' => "\n-->",
 120
 121   changes(qw(
 122     Para=p
 123     B=b I=i
 124     over-bullet=ul
 125     over-number=ol
 126     over-text=dl
 127     over-block=blockquote
 128     item-bullet=li
 129     item-number=li
 130     item-text=dt
 131   )),
 132   changes2(
 133     map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
 134     qw[
 135       sample=samp
 136       definition=dfn
 137       kbd=keyboard
 138       variable=var
 139       citation=cite
 140       abbreviation=abbr
 141       acronym=acronym
 142       subscript=sub
 143       superscript=sup
 144       big=big
 145       small=small
 146       underline=u
 147       strikethrough=s
 148     ]  # no point in providing a way to get <q>...</q>, I think
 149   ),
 150
 151   '/item-bullet' => "</li>$LamePad\n",
 152   '/item-number' => "</li>$LamePad\n",
 153   '/item-text'   => "</a></dt>$LamePad\n",
 154   'item-body'    => "\n<dd>",
 155   '/item-body'   => "</dd>\n",
 156
 157
 158   'B'      =>  "<b>",                  '/B'     =>  "</b>",
 159   'I'      =>  "<i>",                  '/I'     =>  "</i>",
 160   'F'      =>  "<em$Computerese>",     '/F'     =>  "</em>",
 161   'C'      =>  "<code$Computerese>",   '/C'     =>  "</code>",
 162   'L'  =>  "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used!
 163   '/L' =>  "</a>",
 164 );
 165
 166 sub changes {
 167   return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
 168      ? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_"
 169   } @_;
 170 }
 171 sub changes2 {
 172   return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
 173      ? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_"
 174   } @_;
 175 }
 176
 177 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 178 sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 }
 179  # Just so we can run from the command line.  No options.
 180  #  For that, use perldoc!
 181 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 182
 183 sub new {
 184   my $new = shift->SUPER::new(@_);
 185   #$new->nix_X_codes(1);
 186   $new->nbsp_for_S(1);
 187   $new->accept_targets( 'html', 'HTML' );
 188   $new->accept_codes('VerbatimFormatted');
 189   $new->accept_codes(@_to_accept);
 190   DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
 191
 192   $new->perldoc_url_prefix(  $Perldoc_URL_Prefix  );
 193   $new->perldoc_url_postfix( $Perldoc_URL_Postfix );
 194   $new->man_url_prefix(  $Man_URL_Prefix  );
 195   $new->man_url_postfix( $Man_URL_Postfix );
 196   $new->title_prefix(  $Title_Prefix  );
 197   $new->title_postfix( $Title_Postfix );
 198
 199   $new->html_header_before_title(
 200    qq[$Doctype_decl<html><head><title>]
 201   );
 202   $new->html_header_after_title( join "\n" =>
 203     "</title>",
 204     $Content_decl,
 205     "</head>\n<body class='pod'>",
 206     $new->version_tag_comment,
 207     "<!-- start doc -->\n",
 208   );
 209   $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
 210
 211   $new->{'Tagmap'} = {%Tagmap};
 212
 213   return $new;
 214 }
 215
 216 sub __adjust_html_h_levels {
 217   my ($self) = @_;
 218   my $Tagmap = $self->{'Tagmap'};
 219
 220   my $add = $self->html_h_level;
 221   return unless defined $add;
 222   return if ($self->{'Adjusted_html_h_levels'}||0) == $add;
 223
 224   $add -= 1;
 225   for (1 .. 4) {
 226     $Tagmap->{"head$_"}  =~ s/$_/$_ + $add/e;
 227     $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e;
 228   }
 229 }
 230
 231 sub batch_mode_page_object_init {
 232   my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
 233   DEBUG and print "Initting $self\n  for $module\n",
 234     "  in $infile\n  out $outfile\n  depth $depth\n";
 235   $self->batch_mode(1);
 236   $self->batch_mode_current_level($depth);
 237   return $self;
 238 }
 239
 240 sub run {
 241   my $self = $_[0];
 242   return $self->do_middle if $self->bare_output;
 243   return
 244    $self->do_beginning && $self->do_middle && $self->do_end;
 245 }
 246
 247 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 248
 249 sub do_beginning {
 250   my $self = $_[0];
 251
 252   my $title;
 253
 254   if(defined $self->force_title) {
 255     $title = $self->force_title;
 256     DEBUG and print "Forcing title to be $title\n";
 257   } else {
 258     # Actually try looking for the title in the document:
 259     $title = $self->get_short_title();
 260     unless($self->content_seen) {
 261       DEBUG and print "No content seen in search for title.\n";
 262       return;
 263     }
 264     $self->{'Title'} = $title;
 265
 266     if(defined $title and $title =~ m/\S/) {
 267       $title = $self->title_prefix . esc($title) . $self->title_postfix;
 268     } else {
 269       $title = $self->default_title;
 270       $title = '' unless defined $title;
 271       DEBUG and print "Title defaults to $title\n";
 272     }
 273   }
 274
 275
 276   my $after = $self->html_header_after_title  || '';
 277   if($self->html_css) {
 278     my $link =
 279     $self->html_css =~ m/</
 280      ? $self->html_css # It's a big blob of markup, let's drop it in
 281      : sprintf(        # It's just a URL, so let's wrap it up
 282       qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
 283       $self->html_css,
 284     );
 285     $after =~ s{(</head>)}{$link\n$1}i;  # otherwise nevermind
 286   }
 287   $self->_add_top_anchor(\$after);
 288
 289   if($self->html_javascript) {
 290     my $link =
 291     $self->html_javascript =~ m/</
 292      ? $self->html_javascript # It's a big blob of markup, let's drop it in
 293      : sprintf(        # It's just a URL, so let's wrap it up
 294       qq[<script type="text/javascript" src="%s"></script>\n],
 295       $self->html_javascript,
 296     );
 297     $after =~ s{(</head>)}{$link\n$1}i;  # otherwise nevermind
 298   }
 299
 300   print {$self->{'output_fh'}}
 301     $self->html_header_before_title || '',
 302     $title, # already escaped
 303     $after,
 304   ;
 305
 306   DEBUG and print "Returning from do_beginning...\n";
 307   return 1;
 308 }
 309
 310 sub _add_top_anchor {
 311   my($self, $text_r) = @_;
 312   unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
 313     $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n";
 314   }
 315   return;
 316 }
 317
 318 sub version_tag_comment {
 319   my $self = shift;
 320   return sprintf
 321    "<!--\n  generated by %s v%s,\n  using %s v%s,\n  under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
 322    esc(
 323     ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
 324     $], scalar(gmtime),
 325    ), $self->_modnote(),
 326   ;
 327 }
 328
 329 sub _modnote {
 330   my $class = ref($_[0]) || $_[0];
 331   return join "\n   " => grep m/\S/, split "\n",
 332
 333 qq{
 334 If you want to change this HTML document, you probably shouldn't do that
 335 by changing it directly.  Instead, see about changing the calling options
 336 to $class, and/or subclassing $class,
 337 then reconverting this document from the Pod source.
 338 When in doubt, email the author of $class for advice.
 339 See 'perldoc $class' for more info.
 340 };
 341
 342 }
 343
 344 sub do_end {
 345   my $self = $_[0];
 346   print {$self->{'output_fh'}}  $self->html_footer || '';
 347   return 1;
 348 }
 349
 350 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 351 # Normally this would just be a call to _do_middle_main_loop -- but we
 352 #  have to do some elaborate things to emit all the content and then
 353 #  summarize it and output it /before/ the content that it's a summary of.
 354
 355 sub do_middle {
 356   my $self = $_[0];
 357   return $self->_do_middle_main_loop unless $self->index;
 358
 359   if( $self->output_string ) {
 360     # An efficiency hack
 361     my $out = $self->output_string; #it's a reference to it
 362     my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
 363     $$out .= $sneakytag;
 364     $self->_do_middle_main_loop;
 365     $sneakytag = quotemeta($sneakytag);
 366     my $index = $self->index_as_html();
 367     if( $$out =~ s/$sneakytag/$index/s ) {
 368       # Expected case
 369       DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n";
 370     } else {
 371       DEBUG and print "Odd, couldn't find where to insert the index in the output!\n";
 372       # I don't think this should ever happen.
 373     }
 374     return 1;
 375   }
 376
 377   unless( $self->output_fh ) {
 378     require Carp;
 379     Carp::confess("Parser object \$p doesn't seem to have any output object!  I don't know how to deal with that.");
 380   }
 381
 382   # If we get here, we're outputting to a FH.  So we need to do some magic.
 383   # Namely, divert all content to a string, which we output after the index.
 384   my $fh = $self->output_fh;
 385   my $content = '';
 386   {
 387     # Our horrible bait and switch:
 388     $self->output_string( \$content );
 389     $self->_do_middle_main_loop;
 390     $self->abandon_output_string();
 391     $self->output_fh($fh);
 392   }
 393   print $fh $self->index_as_html();
 394   print $fh $content;
 395
 396   return 1;
 397 }
 398
 399 ###########################################################################
 400
 401 sub index_as_html {
 402   my $self = $_[0];
 403   # This is meant to be called AFTER the input document has been parsed!
 404
 405   my $points = $self->{'PSHTML_index_points'} || [];
 406
 407   @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
 408    # There's no point in having a 0-item or 1-item index, I dare say.
 409
 410   my(@out) = qq{\n<div class='indexgroup'>};
 411   my $level = 0;
 412
 413   my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
 414   foreach my $p (@$points, ['head0', '(end)']) {
 415     ($tagname, $text) = @$p;
 416     $anchorname = $self->section_escape($text);
 417     if( $tagname =~ m{^head(\d+)$} ) {
 418       $target_level = 0 + $1;
 419     } else {  # must be some kinda list item
 420       if($previous_tagname =~ m{^head\d+$} ) {
 421         $target_level = $level + 1;
 422       } else {
 423         $target_level = $level;  # no change needed
 424       }
 425     }
 426
 427     # Get to target_level by opening or closing ULs
 428     while($level > $target_level)
 429      { --$level; push @out, ("  " x $level) . "</ul>"; }
 430     while($level < $target_level)
 431      { ++$level; push @out, ("  " x ($level-1))
 432        . "<ul   class='indexList indexList$level'>"; }
 433
 434     $previous_tagname = $tagname;
 435     next unless $level;
 436
 437     $indent = '  '  x $level;
 438     push @out, sprintf
 439       "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>",
 440       $indent, $level, esc($anchorname), esc($text)
 441     ;
 442   }
 443   push @out, "</div>\n";
 444   return join "\n", @out;
 445 }
 446
 447 ###########################################################################
 448
 449 sub _do_middle_main_loop {
 450   my $self = $_[0];
 451   my $fh = $self->{'output_fh'};
 452   my $tagmap = $self->{'Tagmap'};
 453
 454   $self->__adjust_html_h_levels;
 455
 456   my($token, $type, $tagname, $linkto, $linktype);
 457   my @stack;
 458   my $dont_wrap = 0;
 459
 460   while($token = $self->get_token) {
 461
 462     # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 463     if( ($type = $token->type) eq 'start' ) {
 464       if(($tagname = $token->tagname) eq 'L') {
 465         $linktype = $token->attr('type') || 'insane';
 466
 467         $linkto = $self->do_link($token);
 468
 469         if(defined $linkto and length $linkto) {
 470           esc($linkto);
 471             #   (Yes, SGML-escaping applies on top of %-escaping!
 472             #   But it's rarely noticeable in practice.)
 473           print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
 474         } else {
 475           print $fh "<a>"; # Yes, an 'a' element with no attributes!
 476         }
 477
 478       } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) {
 479         print $fh $tagmap->{$tagname} || next;
 480
 481         my @to_unget;
 482         while(1) {
 483           push @to_unget, $self->get_token;
 484           last if $to_unget[-1]->is_end
 485               and $to_unget[-1]->tagname eq $tagname;
 486
 487           # TODO: support for X<...>'s found in here?  (maybe hack into linearize_tokens)
 488         }
 489
 490         my $name = $self->linearize_tokens(@to_unget);
 491         $name = $self->do_section($name, $token) if defined $name;
 492
 493         print $fh "<a ";
 494         print $fh "class='u' href='#___top' title='click to go to top of document'\n"
 495          if $tagname =~ m/^head\d$/s;
 496
 497         if(defined $name) {
 498           my $esc = esc(  $self->section_name_tidy( $name ) );
 499           print $fh qq[name="$esc"];
 500           DEBUG and print "Linearized ", scalar(@to_unget),
 501            " tokens as \"$name\".\n";
 502           push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
 503            if $ToIndex{ $tagname };
 504             # Obviously, this discards all formatting codes (saving
 505             #  just their content), but ahwell.
 506
 507         } else {  # ludicrously long, so nevermind
 508           DEBUG and print "Linearized ", scalar(@to_unget),
 509            " tokens, but it was too long, so nevermind.\n";
 510         }
 511         print $fh "\n>";
 512         $self->unget_token(@to_unget);
 513
 514       } elsif ($tagname eq 'Data') {
 515         my $next = $self->get_token;
 516         next unless defined $next;
 517         unless( $next->type eq 'text' ) {
 518           $self->unget_token($next);
 519           next;
 520         }
 521         DEBUG and print "    raw text ", $next->text, "\n";
 522         print $fh "\n" . $next->text . "\n";
 523         next;
 524
 525       } else {
 526         if( $tagname =~ m/^over-/s ) {
 527           push @stack, '';
 528         } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) {
 529           print $fh $stack[-1];
 530           $stack[-1] = '';
 531         }
 532         print $fh $tagmap->{$tagname} || next;
 533         ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted"
 534           or $tagname eq 'X';
 535       }
 536
 537     # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 538     } elsif( $type eq 'end' ) {
 539       if( ($tagname = $token->tagname) =~ m/^over-/s ) {
 540         if( my $end = pop @stack ) {
 541           print $fh $end;
 542         }
 543       } elsif( $tagname =~ m/^item-/s and @stack) {
 544         $stack[-1] = $tagmap->{"/$tagname"};
 545         if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) {
 546           $self->unget_token($next);
 547           if( $next->type eq 'start' ) {
 548             print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"};
 549             $stack[-1] = $tagmap->{"/item-body"};
 550           }
 551         }
 552         next;
 553       }
 554       print $fh $tagmap->{"/$tagname"} || next;
 555       --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X';
 556
 557     # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 558     } elsif( $type eq 'text' ) {
 559       esc($type = $token->text);  # reuse $type, why not
 560       $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap;
 561       print $fh $type;
 562     }
 563
 564   }
 565   return 1;
 566 }
 567
 568 ###########################################################################
 569 #
 570
 571 sub do_section {
 572   my($self, $name, $token) = @_;
 573   return $name;
 574 }
 575
 576 sub do_link {
 577   my($self, $token) = @_;
 578   my $type = $token->attr('type');
 579   if(!defined $type) {
 580     $self->whine("Typeless L!?", $token->attr('start_line'));
 581   } elsif( $type eq 'pod') { return $self->do_pod_link($token);
 582   } elsif( $type eq 'url') { return $self->do_url_link($token);
 583   } elsif( $type eq 'man') { return $self->do_man_link($token);
 584   } else {
 585     $self->whine("L of unknown type $type!?", $token->attr('start_line'));
 586   }
 587   return 'FNORG'; # should never get called
 588 }
 589
 590 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 591
 592 sub do_url_link { return $_[1]->attr('to') }
 593
 594 sub do_man_link {
 595   my ($self, $link) = @_;
 596   my $to = $link->attr('to');
 597   my $frag = $link->attr('section');
 598
 599   return undef unless defined $to and length $to; # should never happen
 600
 601   $frag = $self->section_escape($frag)
 602    if defined $frag and length($frag .= ''); # (stringify)
 603
 604   DEBUG and print "Resolving \"$to/$frag\"\n\n";
 605
 606   return $self->resolve_man_page_link($to, $frag);
 607 }
 608
 609
 610 sub do_pod_link {
 611   # And now things get really messy...
 612   my($self, $link) = @_;
 613   my $to = $link->attr('to');
 614   my $section = $link->attr('section');
 615   return undef unless(  # should never happen
 616     (defined $to and length $to) or
 617     (defined $section and length $section)
 618   );
 619
 620   $section = $self->section_escape($section)
 621    if defined $section and length($section .= ''); # (stringify)
 622
 623   DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
 624    $to || "(nil)",  $section || "(nil)";
 625
 626   {
 627     # An early hack:
 628     my $complete_url = $self->resolve_pod_link_by_table($to, $section);
 629     if( $complete_url ) {
 630       DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ",
 631         $complete_url, "\n  (Returning that.)\n";
 632       return $complete_url;
 633     } else {
 634       DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",
 635        " didn't return anything interesting.\n";
 636     }
 637   }
 638
 639   if(defined $to and length $to) {
 640     # Give this routine first hack again
 641     my $there = $self->resolve_pod_link_by_table($to);
 642     if(defined $there and length $there) {
 643       DEBUG > 1
 644        and print "resolve_pod_link_by_table(T) gives $there\n";
 645     } else {
 646       $there =
 647         $self->resolve_pod_page_link($to, $section);
 648          # (I pass it the section value, but I don't see a
 649          #  particular reason it'd use it.)
 650       DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n";
 651       unless( defined $there and length $there ) {
 652         DEBUG and print "Can't resolve $to\n";
 653         return undef;
 654       }
 655       # resolve_pod_page_link returning undef is how it
 656       #  can signal that it gives up on making a link
 657     }
 658     $to = $there;
 659   }
 660
 661   #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
 662
 663   my $out = (defined $to and length $to) ? $to : '';
 664   $out .= "#" . $section if defined $section and length $section;
 665
 666   unless(length $out) { # sanity check
 667     DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
 668      $to || "(nil)",  $section || "(nil)";
 669     return undef;
 670   }
 671
 672   DEBUG and print "Resolved to $out\n";
 673   return $out;
 674 }
 675
 676
 677 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
 678
 679 sub section_escape {
 680   my($self, $section) = @_;
 681   return $self->section_url_escape(
 682     $self->section_name_tidy($section)
 683   );
 684 }
 685
 686 sub section_name_tidy {
 687   my($self, $section) = @_;
 688   $section =~ s/^\s+//;
 689   $section =~ s/\s+$//;
 690   $section =~ tr/ /_/;
 691   $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
 692   $section = $self->unicode_escape_url($section);
 693   $section = '_' unless length $section;
 694   return $section;
 695 }
 696
 697 sub section_url_escape  { shift->general_url_escape(@_) }
 698 sub pagepath_url_escape { shift->general_url_escape(@_) }
 699 sub manpage_url_escape  { shift->general_url_escape(@_) }
 700
 701 sub general_url_escape {
 702   my($self, $string) = @_;
 703
 704   $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
 705      # express Unicode things as urlencode(utf(orig)).
 706
 707   # A pretty conservative escaping, behoovey even for query components
 708   #  of a URL (see RFC 2396)
 709
 710   $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
 711    # Yes, stipulate the list without a range, so that this can work right on
 712    #  all charsets that this module happens to run under.
 713    # Altho, hmm, what about that ord?  Presumably that won't work right
 714    #  under non-ASCII charsets.  Something should be done
 715    #  about that, I guess?
 716
 717   return $string;
 718 }
 719
 720 #--------------------------------------------------------------------------
 721 #
 722 # Oh look, a yawning portal to Hell!  Let's play touch football right by it!
 723 #
 724
 725 sub resolve_pod_page_link {
 726   # resolve_pod_page_link must return a properly escaped URL
 727   my $self = shift;
 728   return $self->batch_mode()
 729    ? $self->resolve_pod_page_link_batch_mode(@_)
 730    : $self->resolve_pod_page_link_singleton_mode(@_)
 731   ;
 732 }
 733
 734 sub resolve_pod_page_link_singleton_mode {
 735   my($self, $it) = @_;
 736   return undef unless defined $it and length $it;
 737   my $url = $self->pagepath_url_escape($it);
 738
 739   $url =~ s{::$}{}s; # probably never comes up anyway
 740   $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
 741
 742   return undef unless length $url;
 743   return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
 744 }
 745
 746 sub resolve_pod_page_link_batch_mode {
 747   my($self, $to) = @_;
 748   DEBUG > 1 and print " During batch mode, resolving $to ...\n";
 749   my @path = grep length($_), split m/::/s, $to, -1;
 750   unless( @path ) { # sanity
 751     DEBUG and print "Very odd!  Splitting $to gives (nil)!\n";
 752     return undef;
 753   }
 754   $self->batch_mode_rectify_path(\@path);
 755   my $out = join('/', map $self->pagepath_url_escape($_), @path)
 756     . $HTML_EXTENSION;
 757   DEBUG > 1 and print " => $out\n";
 758   return $out;
 759 }
 760
 761 sub batch_mode_rectify_path {
 762   my($self, $pathbits) = @_;
 763   my $level = $self->batch_mode_current_level;
 764   $level--; # how many levels up to go to get to the root
 765   if($level < 1) {
 766     unshift @$pathbits, '.'; # just to be pretty
 767   } else {
 768     unshift @$pathbits, ('..') x $level;
 769   }
 770   return;
 771 }
 772
 773 sub resolve_man_page_link {
 774   my ($self, $to, $frag) = @_;
 775   my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
 776
 777   return undef unless defined $page and length $page;
 778   $section ||= 1;
 779
 780   return $self->man_url_prefix . "$section/"
 781       . $self->manpage_url_escape($page)
 782       . $self->man_url_postfix;
 783 }
 784
 785 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 786
 787 sub resolve_pod_link_by_table {
 788   # A crazy hack to allow specifying custom L<foo> => URL mappings
 789
 790   return unless $_[0]->{'podhtml_LOT'};  # An optimizy shortcut
 791
 792   my($self, $to, $section) = @_;
 793
 794   # TODO: add a method that actually populates podhtml_LOT from a file?
 795
 796   if(defined $section) {
 797     $to = '' unless defined $to and length $to;
 798     return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
 799   } else {
 800     return $self->{'podhtml_LOT'}{$to};            # quite possibly undef!
 801   }
 802   return;
 803 }
 804
 805 ###########################################################################
 806
 807 sub linearize_tokens {  # self, tokens
 808   my $self = shift;
 809   my $out = '';
 810
 811   my $t;
 812   while($t = shift @_) {
 813     if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
 814       $out .= $t; # a string, or some insane thing
 815     } elsif($t->is_text) {
 816       $out .= $t->text;
 817     } elsif($t->is_start and $t->tag eq 'X') {
 818       # Ignore until the end of this X<...> sequence:
 819       my $x_open = 1;
 820       while($x_open) {
 821         next if( ($t = shift @_)->is_text );
 822         if(   $t->is_start and $t->tag eq 'X') { ++$x_open }
 823         elsif($t->is_end   and $t->tag eq 'X') { --$x_open }
 824       }
 825     }
 826   }
 827   return undef if length $out > $Linearization_Limit;
 828   return $out;
 829 }
 830
 831 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 832
 833 sub unicode_escape_url {
 834   my($self, $string) = @_;
 835   $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
 836     #  Turn char 1234 into "(1234)"
 837   return $string;
 838 }
 839
 840 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 841 sub esc { # a function.
 842   if(defined wantarray) {
 843     if(wantarray) {
 844       @_ = splice @_; # break aliasing
 845     } else {
 846       my $x = shift;
 847       $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
 848       return $x;
 849     }
 850   }
 851   foreach my $x (@_) {
 852     # Escape things very cautiously:
 853     $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
 854      if defined $x;
 855     # Leave out "- so that "--" won't make it thru in X-generated comments
 856     #  with text in them.
 857
 858     # Yes, stipulate the list without a range, so that this can work right on
 859     #  all charsets that this module happens to run under.
 860     # Altho, hmm, what about that ord?  Presumably that won't work right
 861     #  under non-ASCII charsets.  Something should be done about that.
 862   }
 863   return @_;
 864 }
 865
 866 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 867
 868 1;
 869 __END__
 870
 871 =head1 NAME
 872
 873 Pod::Simple::HTML - convert Pod to HTML
 874
 875 =head1 SYNOPSIS
 876
 877   perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
 878
 879
 880 =head1 DESCRIPTION
 881
 882 This class is for making an HTML rendering of a Pod document.
 883
 884 This is a subclass of L<Pod::Simple::PullParser> and inherits all its
 885 methods (and options).
 886
 887 Note that if you want to do a batch conversion of a lot of Pod
 888 documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
 889
 890
 891
 892 =head1 CALLING FROM THE COMMAND LINE
 893
 894 TODO
 895
 896   perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
 897
 898
 899
 900 =head1 CALLING FROM PERL
 901
 902 =head2 Minimal code
 903
 904   use Pod::Simple::HTML;
 905   my $p = Pod::Simple::HTML->new;
 906   $p->output_string(\my $html);
 907   $p->parse_file('path/to/Module/Name.pm');
 908   open my $out, '>', 'out.html' or die "Cannot open 'out.html': $!\n";
 909   print $out $html;
 910
 911 =head2 More detailed example
 912
 913   use Pod::Simple::HTML;
 914
 915 Set the content type:
 916
 917   $Pod::Simple::HTML::Content_decl =  q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
 918
 919   my $p = Pod::Simple::HTML->new;
 920
 921 Include a single javascript source:
 922
 923   $p->html_javascript('http://abc.com/a.js');
 924
 925 Or insert multiple javascript source in the header
 926 (or for that matter include anything, thought this is not recommended)
 927
 928   $p->html_javascript('
 929       <script type="text/javascript" src="http://abc.com/b.js"></script>
 930       <script type="text/javascript" src="http://abc.com/c.js"></script>');
 931
 932 Include a single css source in the header:
 933
 934   $p->html_css('/style.css');
 935
 936 or insert multiple css sources:
 937
 938   $p->html_css('
 939       <link rel="stylesheet" type="text/css" title="pod_stylesheet" href="http://remote.server.com/jquery.css">
 940       <link rel="stylesheet" type="text/css" title="pod_stylesheet" href="/style.css">');
 941
 942 Tell the parser where should the output go. In this case it will be placed in the $html variable:
 943
 944   my $html;
 945   $p->output_string(\$html);
 946
 947 Parse and process a file with pod in it:
 948
 949   $p->parse_file('path/to/Module/Name.pm');
 950
 951 =head1 METHODS
 952
 953 TODO
 954 all (most?) accessorized methods
 955
 956 The following variables need to be set B<before> the call to the ->new constructor.
 957
 958 Set the string that is included before the opening <html> tag:
 959
 960   $Pod::Simple::HTML::Doctype_decl = qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
 961          "http://www.w3.org/TR/html4/loose.dtd">\n};
 962
 963 Set the content-type in the HTML head: (defaults to ISO-8859-1)
 964
 965   $Pod::Simple::HTML::Content_decl =  q{<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >};
 966
 967 Set the value that will be ebedded in the opening tags of F, C tags and verbatim text.
 968 F maps to <em>, C maps to <code>, Verbatim text maps to <pre> (Computerese defaults to "")
 969
 970   $Pod::Simple::HTML::Computerese =  ' class="some_class_name';
 971
 972 =head2 html_css
 973
 974 =head2 html_javascript
 975
 976 =head2 title_prefix
 977
 978 =head2 title_postfix
 979
 980 =head2 html_header_before_title
 981
 982 This includes everything before the <title> opening tag including the Document type
 983 and including the opening <title> tag. The following call will set it to be a simple HTML
 984 file:
 985
 986   $p->html_header_before_title('<html><head><title>');
 987
 988 =head2 html_h_level
 989
 990 Normally =head1 will become <h1>, =head2 will become <h2> etc.
 991 Using the html_h_level method will change these levels setting the h level
 992 of =head1 tags:
 993
 994   $p->html_h_level(3);
 995
 996 Will make sure that =head1 will become <h3> and =head2 will become <h4> etc...
 997
 998
 999 =head2 index
1000
1001 Set it to some true value if you want to have an index (in reality a table of contents)
1002 to be added at the top of the generated HTML.
1003
1004   $p->index(1);
1005
1006 =head2 html_header_after_title
1007
1008 Includes the closing tag of </title> and through the rest of the head
1009 till the opening of the body
1010
1011   $p->html_header_after_title('</title>...</head><body id="my_id">');
1012
1013 =head2 html_footer
1014
1015 The very end of the document:
1016
1017   $p->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
1018
1019 =head1 SUBCLASSING
1020
1021 Can use any of the methods described above but for further customization
1022 one needs to override some of the methods:
1023
1024   package My::Pod;
1025   use strict;
1026   use warnings;
1027
1028   use base 'Pod::Simple::HTML';
1029
1030   # needs to return a URL string such
1031   # http://some.other.com/page.html
1032   # #anchor_in_the_same_file
1033   # /internal/ref.html
1034   sub do_pod_link {
1035     # My::Pod object and Pod::Simple::PullParserStartToken object
1036     my ($self, $link) = @_;
1037
1038     say $link->tagname;          # will be L for links
1039     say $link->attr('to');       #
1040     say $link->attr('type');     # will be 'pod' always
1041     say $link->attr('section');
1042
1043     # Links local to our web site
1044     if ($link->tagname eq 'L' and $link->attr('type') eq 'pod') {
1045       my $to = $link->attr('to');
1046       if ($to =~ /^Padre::/) {
1047           $to =~ s{::}{/}g;
1048           return "/docs/Padre/$to.html";
1049       }
1050     }
1051
1052     # all other links are generated by the parent class
1053     my $ret = $self->SUPER::do_pod_link($link);
1054     return $ret;
1055   }
1056
1057   1;
1058
1059 Meanwhile in script.pl:
1060
1061   use My::Pod;
1062
1063   my $p = My::Pod->new;
1064
1065   my $html;
1066   $p->output_string(\$html);
1067   $p->parse_file('path/to/Module/Name.pm');
1068   open my $out, '>', 'out.html' or die;
1069   print $out $html;
1070
1071 TODO
1072
1073 maybe override do_beginning do_end
1074
1075 =head1 SEE ALSO
1076
1077 L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
1078
1079 TODO: a corpus of sample Pod input and HTML output?  Or common
1080 idioms?
1081
1082 =head1 SUPPORT
1083
1084 Questions or discussion about POD and Pod::Simple should be sent to the
1085 pod-people@perl.org mail list. Send an empty email to
1086 pod-people-subscribe@perl.org to subscribe.
1087
1088 This module is managed in an open GitHub repository,
1089 L<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
1090 to clone L<git://github.com/theory/pod-simple.git> and send patches!
1091
1092 Patches against Pod::Simple are welcome. Please send bug reports to
1093 <bug-pod-simple@rt.cpan.org>.
1094
1095 =head1 COPYRIGHT AND DISCLAIMERS
1096
1097 Copyright (c) 2002-2004 Sean M. Burke.
1098
1099 This library is free software; you can redistribute it and/or modify it
1100 under the same terms as Perl itself.
1101
1102 This program is distributed in the hope that it will be useful, but
1103 without any warranty; without even the implied warranty of
1104 merchantability or fitness for a particular purpose.
1105
1106 =head1 ACKNOWLEDGEMENTS
1107
1108 Thanks to L<Hurricane Electric|http://he.net/> for permission to use its
1109 L<Linux man pages online|http://man.he.net/> site for man page links.
1110
1111 Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
1112 site for Perl module links.
1113
1114 =head1 AUTHOR
1115
1116 Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
1117 But don't bother him, he's retired.
1118
1119 Pod::Simple is maintained by:
1120
1121 =over
1122
1123 =item * Allison Randal C<allison@perl.org>
1124
1125 =item * Hans Dieter Pearcey C<hdp@cpan.org>
1126
1127 =item * David E. Wheeler C<dwheeler@cpan.org>
1128
1129 =back
1130
1131 =cut