pod/pod2html.PL

   1 #!/usr/local/bin/perl
   2
   3 use Config;
   4 use File::Basename qw(&basename &dirname);
   5
   6 # List explicitly here the variables you want Configure to
   7 # generate.  Metaconfig only looks for shell variables, so you
   8 # have to mention them as if they were shell variables, not
   9 # %Config entries.  Thus you write
  10 #  $startperl
  11 # to ensure Configure will look for $Config{startperl}.
  12
  13 # This forces PL files to create target in same directory as PL file.
  14 # This is so that make depend always knows where to find PL derivatives.
  15 chdir(dirname($0));
  16 ($file = basename($0)) =~ s/\.PL$//;
  17 $file =~ s/\.pl$//
  18         if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
  19
  20 open OUT,">$file" or die "Can't create $file: $!";
  21
  22 print "Extracting $file (with variable substitutions)\n";
  23
  24 # In this section, perl variables will be expanded during extraction.
  25 # You can use $Config{...} to use Configure variables.
  26
  27 print OUT <<"!GROK!THIS!";
  28 $Config{startperl}
  29     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
  30         if \$running_under_some_shell;
  31 !GROK!THIS!
  32
  33 # In the following, perl variables are not expanded during extraction.
  34
  35 print OUT <<'!NO!SUBS!';
  36
  37 #
  38 # pod2html - convert pod format to html
  39 # Version 1.15
  40 # usage: pod2html [podfiles]
  41 # Will read the cwd and parse all files with .pod extension
  42 # if no arguments are given on the command line.
  43 #
  44 # Many helps, suggestions, and fixes from the perl5 porters, and all over.
  45 # Bill Middleton - wjm@metronet.com
  46 #
  47 # Please send patches/fixes/features to me
  48 #
  49 #
  50 #
  51 *RS = */;
  52 *ERRNO = *!;
  53
  54 ################################################################################
  55 # Invoke with various levels of debugging possible
  56 ################################################################################
  57 while ($ARGV[0] =~ /^-d(.*)/) {
  58     shift;
  59     $Debug{ lc($1 || shift) }++;
  60 }
  61
  62 # ck for podnames on command line
  63 while ($ARGV[0]) {
  64     push(@Pods,shift);
  65 }
  66
  67 ################################################################################
  68 # CONFIGURE
  69 #
  70 # The beginning of the url for the anchors to the other sections.
  71 # Edit $type to suit.  It's configured for relative url's now.
  72 # Other possibilities are:
  73 # $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
  74 # $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
  75 #
  76 ################################################################################
  77
  78 $type = '<A HREF="';
  79 $dir = ".";             # location of pods
  80
  81 # look in these pods for things not found within the current pod
  82 # be careful tho, namespace collisions cause stupid links
  83
  84 @inclusions = qw[
  85      perlfunc perlvar perlrun perlop
  86 ];
  87 ################################################################################
  88 # END CONFIGURE
  89 ################################################################################
  90
  91 $A = {};  # The beginning of all things
  92
  93 unless (@Pods) {
  94     opendir(DIR,$dir)  or  die "Can't opendir $dir: $ERRNO";
  95     @Pods = grep(/\.pod$/,readdir(DIR));
  96     closedir(DIR) or die "Can't closedir $dir: $ERRNO";
  97 }
  98 @Pods or die "aak, expected pods";
  99
 100 # loop twice through the pods, first to learn the links, then to produce html
 101 for $count (0,1) {
 102     print STDERR "Scanning pods...\n" unless $count;
 103     foreach $podfh ( @Pods ) {
 104         ($pod = $podfh) =~ s/\.(?:pod|pm)$//;
 105         Debug("files", "opening 2 $podfh" );
 106         print "Creating $pod.html from $podfh\n" if $count;
 107         $RS = "\n=";         # grok pods by item (Nonstandard but effecient)
 108         open($podfh,"<".$podfh)  || die "can't open $podfh: $ERRNO";
 109         @all = <$podfh>;
 110         close($podfh);
 111         $RS = "\n";
 112
 113         $all[0] =~ s/^=//;
 114         for (@all) { s/=$// }
 115         $Podnames{$pod} = 1;
 116         $in_list = 0;
 117         $html = $pod.".html";
 118         if ($count) {              # give us a html and rcs header
 119             open(HTML,">$html") || die "can't create $html: $ERRNO";
 120             print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
 121             print HTML "<CENTER>" unless $NO_NS;
 122             print HTML "<TITLE>$pod</TITLE>";
 123             print HTML "</CENTER>" unless $NO_NS;
 124             print HTML "\n</HEAD>\n<BODY>";
 125         }
 126         for ($i = 0; $i <= $#all; $i++) {       # decide what to do with each chunk
 127             $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
 128             ($cmd, $title, $rest) = ($1,$2,$3);
 129             if ($cmd eq "item") {
 130                 if ($count ) { # producing html
 131                     do_list("over",$all[$i],\$in_list,\$depth) unless $depth;
 132                     do_item($title,$rest,$in_list);
 133                 }
 134                 else {
 135                     # scan item
 136                     scan_thing("item",$title,$pod);
 137                 }
 138             }
 139             elsif ($cmd =~ /^head([12])/) {
 140                 $num = $1;
 141                 if ($count) { # producing html
 142                     do_hdr($num,$title,$rest,$depth);
 143                 }
 144                 else {
 145                     # header scan
 146                     scan_thing($cmd,$title,$pod); # skip head1
 147                 }
 148             }
 149             elsif ($cmd =~ /^over/) {
 150                 $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
 151             }
 152             elsif ($cmd =~ /^back/) {
 153                 if ($count) {  # producing html
 154                     ($depth) or next; # just skip it
 155                     do_list("back",$all[$i+1],\$in_list,\$depth);
 156                     do_rest($title.$rest);
 157                 }
 158             }
 159             elsif ($cmd =~ /^cut/) {
 160                 next;
 161             }
 162             elsif ($cmd =~ /^for/) {  # experimental pragma html
 163                 if ($count) {  # producing html
 164                     if ($title =~ s/^html//) {
 165                         $in_html =1;
 166                         do_rest($title.$rest);
 167                     }
 168                 }
 169             }
 170             elsif ($cmd =~ /^begin/) {  # experimental pragma html
 171                 if ($count) {  # producing html
 172                     if ($title =~ s/^html//) {
 173                         print HTML $title,"\n",$rest;
 174                     }
 175                     elsif ($title =~ /^end/) {
 176                         next;
 177                     }
 178                 }
 179             }
 180             elsif ($Debug{"misc"}) {
 181                 warn("unrecognized header: $cmd");
 182             }
 183         }
 184         # close open lists without '=back' stmts
 185         if ($count) {  # producing html
 186             while ($depth) {
 187                  do_list("back",$all[$i+1],\$in_list,\$depth);
 188             }
 189             print HTML "\n</BODY>\n</HTML>\n";
 190         }
 191     }
 192 }
 193
 194 sub do_list{   # setup a list type, depending on some grok logic
 195     my($which,$next_one,$list_type,$depth) = @_;
 196     my($key);
 197     if ($which eq "over") {
 198         unless ($next_one =~ /^item\s+(.*)/) {
 199             warn "Bad list, $1\n" if $Debug{"misc"};
 200         }
 201         $key = $1;
 202
 203         if      ($key =~ /^1\.?/) {
 204             $$list_type = "OL";
 205         } elsif ($key =~ /\*\s*$/) {
 206             $$list_type = "UL";
 207         } elsif ($key =~ /\*?\s*\w/) {
 208             $$list_type = "DL";
 209         } else {
 210             warn "unknown list type for item $key" if $Debug{"misc"};
 211         }
 212
 213         print HTML qq{\n};
 214         print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
 215         $$depth++;
 216     }
 217     elsif ($which eq "back") {
 218         print HTML qq{\n</$$list_type>\n};
 219         $$depth--;
 220     }
 221 }
 222
 223 sub do_hdr{   # headers
 224     my($num,$title,$rest,$depth) = @_;
 225     print HTML qq{<p><hr>\n} if $num == 1;
 226     process_thing(\$title,"NAME");
 227     print HTML qq{\n<H$num> };
 228     print HTML $title;
 229     print HTML qq{</H$num>\n};
 230     do_rest($rest);
 231 }
 232
 233 sub do_item{  # list items
 234     my($title,$rest,$list_type) = @_;
 235     my $bullet_only = $title eq '*' and $list_type eq 'UL';
 236     process_thing(\$title,"NAME");
 237     if ($list_type eq "DL") {
 238         print HTML qq{\n<DT><STRONG>\n};
 239         print HTML $title;
 240         print HTML qq{\n</STRONG>\n};
 241         print HTML qq{<DD>\n};
 242     }
 243     else {
 244         print HTML qq{\n<LI>};
 245         unless ($bullet_only or $list_type eq "OL") {
 246             print HTML $title,"\n";
 247         }
 248     }
 249     do_rest($rest);
 250 }
 251
 252 sub do_rest{   # the rest of the chunk handled here
 253     my($rest) = @_;
 254     my(@lines,$p,$q,$line,,@paras,$inpre);
 255     @paras = split(/\n\n\n*/,$rest);
 256     for ($p = 0; $p <= $#paras; $p++) {
 257         $paras[$p] =~ s/^\n//mg;
 258         @lines = split(/\n/,$paras[$p]);
 259         if ($in_html) {  # handle =for html paragraphs
 260             print HTML $paras[0];
 261             $in_html = 0;
 262             next;
 263         }
 264         elsif ($lines[0] =~ /^\s+\w*\t.*/) {  # listing or unordered list
 265             print HTML qq{<UL>};
 266             foreach $line (@lines) {
 267                 ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
 268                 print HTML defined($Podnames{$key})
 269                                 ?  "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n"
 270                                 : "<LI>$line</LI>\n";
 271             }
 272             print HTML qq{</UL>\n};
 273         }
 274         elsif ($lines[0] =~ /^\s/) {       # preformatted code
 275             if ($paras[$p] =~/>>|<</) {
 276                 print HTML qq{\n<PRE>\n};
 277                 $inpre=1;
 278             }
 279             else {                         # Still cant beat XMP.  Yes, I know
 280                 print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
 281                 $inpre = 0;
 282             }
 283             while (defined($paras[$p])) {
 284                 @lines = split(/\n/,$paras[$p]);
 285                 foreach $q (@lines) {      # mind your p's and q's here :-)
 286                     if ($paras[$p] =~ />>|<</) {
 287                         if ($inpre) {
 288                             process_thing(\$q,"HTML");
 289                         }
 290                         else {
 291                             print HTML qq{\n</XMP>\n};
 292                             print HTML qq{<PRE>\n};
 293                             $inpre=1;
 294                             process_thing(\$q,"HTML");
 295                         }
 296                     }
 297                     1 while $q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
 298                     print HTML  $q,"\n";
 299                 }
 300                 last if $paras[$p+1] !~ /^\s/;
 301                 $p++;
 302             }
 303             print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
 304         }
 305         else {                             # other text
 306             @lines = split(/\n/,$paras[$p]);
 307             foreach $line (@lines) {
 308                 process_thing(\$line,"HTML");
 309                 print HTML qq{$line\n};
 310             }
 311         }
 312         print HTML qq{<p>};
 313     }
 314 }
 315
 316 sub process_thing{       # process a chunk, order important
 317     my($thing,$htype) = @_;
 318     pre_escapes($thing);
 319     find_refs($thing,$htype);
 320     post_escapes($thing);
 321 }
 322
 323 sub scan_thing{           # scan a chunk for later references
 324     my($cmd,$title,$pod) = @_;
 325     $_ = $title;
 326     s/\n$//;
 327     s/E<(\d+)>/&#$1;/g;
 328     s/E<(.*?)>/&$1;/g;
 329     # remove any formatting information for the headers
 330     s/[SFCBI]<(.*?)>/$1/g;
 331     # the "don't format me" thing
 332     s/Z<>//g;
 333     if ($cmd eq "item") {
 334         /^\*/ and  return;      # skip bullets
 335         /^\d+\./ and  return;   # skip numbers
 336         s/(-[a-z]).*/$1/i;
 337         trim($_);
 338         return if defined $A->{$pod}->{"Items"}->{$_};
 339         $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
 340         $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
 341         Debug("items", "item $_");
 342         if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_
 343             && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1))
 344         {
 345             $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
 346             Debug("items", "item $1 REF TO $_");
 347         }
 348         if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
 349             my $pf = $1 . '//';
 350             $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
 351             if ($pf ne $_) {
 352                 $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
 353                 Debug("items", "item $pf REF TO $_");
 354             }
 355         }
 356     }
 357     elsif ($cmd =~ /^head[12]/) {
 358         return if defined($A->{$pod}->{"Headers"}->{$_});
 359         $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
 360         Debug("headers", "header $_");
 361     }
 362     else {
 363         warn "unrecognized header: $cmd" if $Debug;
 364     }
 365 }
 366
 367
 368 sub picrefs {
 369     my($char, $bigkey, $lilkey,$htype) = @_;
 370     my($key,$ref,$podname);
 371     for $podname ($pod,@inclusions) {
 372         for $ref ( "Items", "Headers" ) {
 373             if (defined $A->{$podname}->{$ref}->{$bigkey}) {
 374                 $value = $A->{$podname}->{$ref}->{$key = $bigkey};
 375                 Debug("subs", "bigkey is $bigkey, value is $value\n");
 376             }
 377             elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
 378                 $value = $A->{$podname}->{$ref}->{$key = $lilkey};
 379                 return "" if $lilkey eq '';
 380                 Debug("subs", "lilkey is $lilkey, value is $value\n");
 381             }
 382         }
 383         if (length($key)) {
 384             ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/;
 385             if ($htype eq "NAME") {
 386                 return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
 387             }
 388             else {
 389                 return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
 390             }
 391         }
 392     }
 393     if ($char =~ /[IF]/) {
 394         return "<EM>$bigkey</EM>";
 395     } elsif ($char =~ /C/) {
 396         return "<CODE>$bigkey</CODE>";
 397     } else {
 398         return "<STRONG>$bigkey</STRONG>";
 399     }
 400 }
 401
 402 sub find_refs {
 403     my($thing,$htype) = @_;
 404     my($orig) = $$thing;
 405     # LREF: a manpage(3f) we don't know about
 406     for ($$thing) {
 407         #s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
 408         s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge;
 409         s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie;
 410         s/L<([^>]*)>/lrefs($1,$htype)/ge;
 411         s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
 412         s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
 413         s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
 414         s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge;
 415     }
 416     if ($$thing eq $orig && $htype eq "NAME") {
 417         $$thing = picrefs("I", $$thing, "", $htype);
 418     }
 419
 420 }
 421
 422 sub lrefs {
 423     my($page, $item) = split(m#/#, $_[0], 2);
 424     my($htype) = $_[1];
 425     my($podname);
 426     my($section) = $page =~ /\((.*)\)/;
 427     my $selfref;
 428     if ($page =~ /^[A-Z]/ && $item) {
 429         $selfref++;
 430         $item = "$page/$item";
 431         $page = $pod;
 432     }  elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
 433         $selfref++;
 434         $item = $page;
 435         $page = $pod;
 436     }
 437     $item =~ s/\(\)$//;
 438     if (!$item) {
 439         if (!defined $section && defined $Podnames{$page}) {
 440             return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
 441         } else {
 442             (warn "Bizarre entry $page/$item") if $Debug;
 443             return "the <EM>$_[0]</EM>  manpage\n";
 444         }
 445     }
 446
 447     if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
 448         $text = "<EM>$item</EM>";
 449         $ref = "Headers";
 450     } else {
 451         $text = "<EM>$item</EM>";
 452         $ref = "Items";
 453     }
 454     for $podname ($pod, @inclusions) {
 455         undef $value;
 456         if ($ref eq "Items") {
 457             if (defined($value = $A->{$podname}->{$ref}->{$item})) {
 458                 ($pod2,$num) = split(/_/,$value,2);
 459                 return (($pod eq $pod2) && ($htype eq "NAME"))
 460                 ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
 461                 : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
 462             }
 463         }
 464         elsif ($ref eq "Headers") {
 465             if (defined($value = $A->{$podname}->{$ref}->{$item})) {
 466                 ($pod2,$num) = split(/_/,$value,2);
 467                 return (($pod eq $pod2) && ($htype eq "NAME"))
 468                 ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
 469                 : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
 470             }
 471         }
 472     }
 473     warn "No $ref reference for $item (@_)" if $Debug;
 474     return $text;
 475 }
 476
 477 sub varrefs {
 478     my ($var,$htype) = @_;
 479     for $podname ($pod,@inclusions) {
 480         if ($value = $A->{$podname}->{"Items"}->{$var}) {
 481             ($pod2,$num) = split(/_/,$value,2);
 482             Debug("vars", "way cool -- var ref on $var");
 483             return (($pod eq $pod2) && ($htype eq "NAME"))  # INHERIT $_, $pod
 484                 ? "\n<A NAME=\"".$value."\">\n$var</A>\n"
 485                 : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
 486         }
 487     }
 488     Debug( "vars", "bummer, $var not a var");
 489     return "<STRONG>$var</STRONG>";
 490 }
 491
 492 sub gensym {
 493     my ($podname, $key) = @_;
 494     $key =~ s/\s.*//;
 495     ($key = lc($key)) =~ tr/a-z/_/cs;
 496     my $name = "${podname}_${key}_0";
 497     $name =~ s/__/_/g;
 498     while ($sawsym{$name}++) {
 499         $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
 500     }
 501     return $name;
 502 }
 503
 504 sub pre_escapes {  # twiddle these, and stay up late  :-)
 505     my($thing) = @_;
 506     for ($$thing) {
 507     s/([\200-\377])/noremap("&".ord($1).";")/ge;
 508         s/"(.*?)"/``$1''/gs;
 509         s/&/noremap("&amp;")/ge;
 510         s/<</noremap("&lt;&lt;")/eg;
 511         s/([^ESIBLCF])</$1\&lt\;/g;
 512         s/E<(\d+)>/\&#$1\;/g;                     # embedded numeric special
 513         s/E<([^\/][^<>]*)>/\&$1\;/g;              # embedded special
 514     }
 515 }
 516 sub noremap {   # adding translator for hibit chars soon
 517     my $hide = $_[0];
 518     $hide =~ tr/\000-\177/\200-\377/;
 519     $hide;
 520 }
 521
 522
 523 sub post_escapes {
 524     my($thing) = @_;
 525     for ($$thing) {
 526         s/([^GM])>>/$1\&gt\;\&gt\;/g;
 527         s/([^D][^"MGA])>/$1\&gt\;/g;
 528         tr/\200-\377/\000-\177/;
 529     }
 530 }
 531
 532 sub Debug {
 533     my $level = shift;
 534     print STDERR @_,"\n" if $Debug{$level};
 535 }
 536
 537 sub dumptable  {
 538     my $t = shift;
 539     print STDERR "TABLE DUMP $t\n";
 540     foreach $k (sort keys %$t) {
 541         printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
 542     }
 543 }
 544 sub trim {
 545     for (@_) {
 546         s/^\s+//;
 547         s/\s\n?$//;
 548     }
 549 }
 550 !NO!SUBS!
 551
 552 close OUT or die "Can't close $file: $!";
 553 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 554 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';