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