home *** CD-ROM | disk | FTP | other *** search
/ Tutto per Internet / Internet.iso / soft95 / Html / PerlW32 / pod2htm.bat < prev    next >
Encoding:
DOS Batch File  |  1996-01-31  |  12.1 KB  |  474 lines
  1. @rem = '--*-Perl-*--';
  2. @rem = '
  3. @echo off
  4. perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. @rem ';
  7. #!/ugrad0/csss/pub/bin/hp700/perl
  8. eval 'exec perl -S $0 ${1+"$@"}'
  9.     if $running_under_some_shell;
  10. #
  11. # pod2html - convert pod format to html
  12. # 
  13. # usage: pod2html [podfiles]
  14. # will read the cwd and parse all files with .pod extension
  15. # if no arguments are given on the command line.
  16. #
  17. *RS = */;
  18. *ERRNO = *!;
  19.  
  20. use Carp;
  21.  
  22. $gensym = 0;
  23.  
  24. while ($ARGV[0] =~ /^-d(.*)/) {
  25.     shift;
  26.     $Debug{ lc($1 || shift) }++;
  27. }
  28.  
  29. # look in these pods for things not found within the current pod
  30. @inclusions = qw[
  31.      perlfunc perlvar perlrun perlop 
  32. ];
  33.  
  34. # ck for podnames on command line
  35. while ($ARGV[0]) {
  36.     push(@Pods,shift);
  37. }
  38. $A={};
  39.  
  40. # location of pods
  41. $dir="."; 
  42.  
  43. # The beginning of the url for the anchors to the other sections.
  44. # Edit $type to suit.  It's configured for relative url's now.
  45. $type='<A HREF="';        
  46. $debug = 0;
  47.  
  48. unless(@Pods){
  49.     opendir(DIR,$dir)  or  die "Can't opendir $dir: $ERRNO";
  50.     @Pods = grep(/\.pod$/,readdir(DIR));
  51.     closedir(DIR) or die "Can't closedir $dir: $ERRNO";
  52. }
  53. @Pods or die "expected pods";
  54.  
  55. # loop twice through the pods, first to learn the links, then to produce html
  56. for $count (0,1){
  57.     (print "Scanning pods...\n") unless $count;
  58.     foreach $podfh ( @Pods ) {
  59.     ($pod = $podfh) =~ s/\.pod$//;
  60.     Debug("files", "opening 2 $podfh" );
  61.     (print "Creating $pod.htm from $podfh\n") if $count;
  62.     $RS = "\n=";
  63.     open($podfh,"<".$podfh)  || die "can't open $podfh: $ERRNO";
  64.     @all=<$podfh>;
  65.     close($podfh);
  66.     $RS = "\n";
  67.     $all[0]=~s/^=//;
  68.     for(@all){s/=$//;}
  69.     $Podnames{$pod} = 1;
  70.     $in_list=0;
  71.     $html=$pod.".htm";
  72.     if($count){
  73.         open(HTML,">$html") || die "can't create $html: $ERRNO";
  74.         print HTML <<'HTML__EOQ', <<"HTML__EOQQ";
  75.         <!-- \$RCSfile\$\$Revision\$\$Date\$ -->
  76.         <!-- \$Log\$ -->
  77.         <HTML>
  78. HTML__EOQ
  79.         <TITLE>\U$pod\E</TITLE>
  80. HTML__EOQQ
  81.     }
  82.  
  83.     for($i=0;$i<=$#all;$i++){
  84.  
  85.         $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
  86.         ($cmd, $title, $rest) = ($1,$2,$3);
  87.         if ($cmd eq "item") {
  88.         if($count ){
  89.             ($depth) or do_list("over",$all[$i],\$in_list,\$depth);
  90.             do_item($title,$rest,$in_list);
  91.         }
  92.         else{
  93.             # scan item
  94.             scan_thing("item",$title,$pod);
  95.         }
  96.         }
  97.         elsif ($cmd =~ /^head([12])/){
  98.         $num=$1;
  99.         if($count){
  100.             do_hdr($num,$title,$rest,$depth);
  101.         }
  102.         else{
  103.             # header scan
  104.             scan_thing($cmd,$title,$pod); # skip head1
  105.         }
  106.         }
  107.         elsif ($cmd =~ /^over/) {
  108.         $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
  109.         }
  110.         elsif ($cmd =~ /^back/) {
  111.         if($count){
  112.             ($depth) or next; # just skip it
  113.             do_list("back",$all[$i+1],\$in_list,\$depth);
  114.             do_rest("$title.$rest");
  115.         }
  116.         }
  117.         elsif ($cmd =~ /^cut/) {
  118.         next;
  119.         }
  120.         elsif($Debug){
  121.         (warn "unrecognized header: $cmd") if $Debug;
  122.         }
  123.     }
  124.         # close open lists without '=back' stmts
  125.     if($count){
  126.         while($depth){
  127.          do_list("back",$all[$i+1],\$in_list,\$depth);
  128.         }
  129.         print HTML "\n</HTML>\n";
  130.     }
  131.     }
  132. }
  133.  
  134. sub do_list{
  135.     my($which,$next_one,$list_type,$depth)=@_;
  136.     my($key);
  137.     if($which eq "over"){
  138.     ($next_one =~ /^item\s+(.*)/ ) or (warn "Bad list, $1\n") if $Debug;
  139.     $key=$1;
  140.     if($key =~ /^1\.?/){
  141.     $$list_type = "OL";
  142.     }
  143.     elsif($key =~ /\*\s*$/){
  144.     $$list_type="UL";
  145.     }
  146.     elsif($key =~ /\*?\s*\w/){
  147.     $$list_type="DL";
  148.     }
  149.     else{
  150.     (warn "unknown list type for item $key") if $Debug;
  151.     }
  152.     print HTML qq{\n};
  153.     print HTML qq{<$$list_type>};
  154.     $$depth++;
  155.     }
  156.     elsif($which eq "back"){
  157.     print HTML qq{\n</$$list_type>\n};
  158.     $$depth--;
  159.     }
  160. }
  161.  
  162. sub do_hdr{
  163.     my($num,$title,$rest,$depth)=@_;
  164.     ($num == 1) and print HTML qq{<p><hr>\n};
  165.     process_thing(\$title,"NAME");
  166.     print HTML qq{\n<H$num> };
  167.     print HTML $title; 
  168.     print HTML qq{</H$num>\n};
  169.     do_rest($rest);
  170. }
  171.  
  172. sub do_item{
  173.     my($title,$rest,$list_type)=@_;
  174.     process_thing(\$title,"NAME");
  175.     if($list_type eq "DL"){
  176.     print HTML qq{\n<DT><STRONG>\n};
  177.     print HTML $title; 
  178.     print HTML qq{\n</STRONG></DT>\n};
  179.     print HTML qq{<DD>\n};
  180.     }
  181.     else{
  182.     print HTML qq{\n<LI>};
  183.     ($list_type ne "OL") && (print HTML $title,"\n");
  184.     }
  185.     do_rest($rest);
  186.     print HTML ($list_type eq "DL" )? qq{</DD>} : qq{</LI>};
  187. }
  188.  
  189. sub do_rest{
  190.     my($rest)=@_;
  191.     my(@lines,$p,$q,$line,,@paras,$inpre);
  192.     @paras=split(/\n\n+/,$rest);
  193.     for($p=0;$p<=$#paras;$p++){
  194.     @lines=split(/\n/,$paras[$p]);
  195.     if($lines[0] =~ /^\s+\w*\t.*/){  # listing or unordered list
  196.         print HTML qq{<UL>};
  197.         foreach $line (@lines){ 
  198.         ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
  199.         print HTML defined($Podnames{$key}) ?
  200.             "<LI>$type$key.htm\">$key<\/A>\t$rem</LI>\n" : 
  201.             "<LI>$line</LI>\n";
  202.         }
  203.         print HTML qq{</UL>\n};
  204.     }
  205.     elsif($lines[0] =~ /^\s/){       # preformatted code
  206.         if($paras[$p] =~/>>|<</){
  207.         print HTML qq{\n<PRE>\n};
  208.         $inpre=1;
  209.         }
  210.         else{
  211.         print HTML qq{\n<XMP>\n};
  212.         $inpre=0;
  213.         }
  214. inner:
  215.         while(defined($paras[$p])){
  216.             @lines=split(/\n/,$paras[$p]);
  217.         foreach $q (@lines){
  218.             if($paras[$p]=~/>>|<</){
  219.             if($inpre){
  220.                 process_thing(\$q,"HTML");
  221.             }
  222.             else {
  223.                 print HTML qq{\n</XMP>\n};
  224.                 print HTML qq{<PRE>\n};
  225.                 $inpre=1;
  226.                 process_thing(\$q,"HTML");
  227.             }
  228.             }
  229.             while($q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e){
  230.             1;
  231.             }
  232.             print HTML  $q,"\n";
  233.         }
  234.         last if $paras[$p+1] !~ /^\s/;
  235.         $p++;
  236.         }
  237.         print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
  238.     }
  239.     else{                             # other text
  240.         @lines=split(/\n/,$paras[$p]);
  241.         foreach $line (@lines){
  242.                 process_thing(\$line,"HTML");
  243.         print HTML qq{$line\n};
  244.         }
  245.     }
  246.     print HTML qq{<p>};
  247.     }
  248. }
  249.  
  250. sub process_thing{
  251.     my($thing,$htype)=@_;
  252.     pre_escapes($thing);
  253.     find_refs($thing,$htype);
  254.     post_escapes($thing);
  255. }
  256.  
  257. sub scan_thing{
  258.     my($cmd,$title,$pod)=@_;
  259.     $_=$title;
  260.     s/\n$//;
  261.     s/E<(.*?)>/&$1;/g;
  262.     # remove any formatting information for the headers
  263.     s/[SFCBI]<(.*?)>/$1/g;         
  264.     # the "don't format me" thing
  265.     s/Z<>//g;
  266.     if ($cmd eq "item") {
  267.  
  268.         if (/^\*/)     {  return }     # skip bullets
  269.         if (/^\d+\./)     {  return }     # skip numbers
  270.         s/(-[a-z]).*/$1/i;
  271.     trim($_);
  272.         return if defined $A->{$pod}->{"Items"}->{$_};
  273.         $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
  274.         $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
  275.         Debug("items", "item $_");
  276.         if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ 
  277.             && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) 
  278.         {
  279.             $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
  280.             Debug("items", "item $1 REF TO $_");
  281.         } 
  282.         if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
  283.             my $pf = $1 . '//';
  284.             $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
  285.             if ($pf ne $_) {
  286.                 $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
  287.                 Debug("items", "item $pf REF TO $_");
  288.             }
  289.     }
  290.     }
  291.     elsif ($cmd =~ /^head[12]/){                
  292.         return if defined($Headers{$_});
  293.         $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
  294.         Debug("headers", "header $_");
  295.     } 
  296.     else {
  297.         (warn "unrecognized header: $cmd") if $Debug;
  298.     } 
  299. }
  300.  
  301.  
  302. sub picrefs { 
  303.     my($char, $bigkey, $lilkey,$htype) = @_;
  304.     my($key,$ref,$podname);
  305.     for $podname ($pod,@inclusions){
  306.     for $ref ( "Items", "Headers" ) {
  307.         if (defined $A->{$podname}->{$ref}->{$bigkey}) {
  308.         $value = $A->{$podname}->{$ref}->{$key=$bigkey};
  309.         Debug("subs", "bigkey is $bigkey, value is $value\n");
  310.         } 
  311.         elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
  312.         $value = $A->{$podname}->{$ref}->{$key=$lilkey};
  313.         return "" if $lilkey eq '';
  314.         Debug("subs", "lilkey is $lilkey, value is $value\n");
  315.         } 
  316.     } 
  317.     if (length($key)) {
  318.             ($pod2,$num) = split(/_/,$value,2);
  319.         if($htype eq "NAME"){  
  320.         return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
  321.         }
  322.         else{
  323.         return "\n$type$pod2.htm\#".$value."\">$bigkey<\/A>\n";
  324.         }
  325.     } 
  326.     }
  327.     if ($char =~ /[IF]/) {
  328.     return "<EM>$bigkey</EM>";
  329.     } elsif($char =~ /C/) {
  330.     return "<CODE>$bigkey</CODE>";
  331.     } else {
  332.     return "<STRONG>$bigkey</STRONG>";
  333.     }
  334. } 
  335.  
  336. sub find_refs { 
  337.     my($thing,$htype)=@_;
  338.     my($orig) = $$thing;
  339.     # LREF: a manpage(3f) we don't know about
  340.     $$thing=~s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
  341.     $$thing=~s/L<([^>]*)>/lrefs($1,$htype)/ge;
  342.     $$thing=~s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
  343.     $$thing=~s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
  344.     $$thing=~s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge;
  345.     (($$thing eq $orig) && ($htype eq "NAME")) && 
  346.     ($$thing=picrefs("I", $$thing, "", $htype));
  347. }
  348.  
  349. sub lrefs {
  350.     my($page, $item) = split(m#/#, $_[0], 2);
  351.     my($htype)=$_[1];
  352.     my($podname);
  353.     my($section) = $page =~ /\((.*)\)/;
  354.     my $selfref;
  355.     if ($page =~ /^[A-Z]/ && $item) {
  356.     $selfref++;
  357.     $item = "$page/$item";
  358.     $page = $pod;
  359.     }  elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
  360.     $selfref++;
  361.     $item = $page;
  362.     $page = $pod;
  363.     } 
  364.     $item =~ s/\(\)$//;
  365.     if (!$item) {
  366.         if (!defined $section && defined $Podnames{$page}) {
  367.         return "\n$type$page.htm\">\nthe <EM>$page</EM> manpage<\/A>\n";
  368.     } else {
  369.         (warn "Bizarre entry $page/$item") if $Debug;
  370.         return "the <EM>$_[0]</EM>  manpage\n";
  371.     } 
  372.     } 
  373.  
  374.     if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
  375.     $text = "<EM>$item</EM>";
  376.     $ref = "Headers";
  377.     } else {
  378.     $text = "<EM>$item</EM>";
  379.     $ref = "Items";
  380.     } 
  381.     for $podname ($pod, @inclusions){
  382.     undef $value;
  383.     if ($ref eq "Items") {
  384.         if (defined($value = $A->{$podname}->{$ref}->{$item})) {
  385.         ($pod2,$num) = split(/_/,$value,2);
  386.         return (($pod eq $pod2) && ($htype eq "NAME"))
  387.             ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
  388.             : "\n$type$pod2.htm\#".$value."\">$text<\/A>\n";
  389.             }
  390.         } 
  391.     elsif($ref eq "Headers") {
  392.         if (defined($value = $A->{$podname}->{$ref}->{$item})) {
  393.         ($pod2,$num) = split(/_/,$value,2);
  394.         return (($pod eq $pod2) && ($htype eq "NAME")) 
  395.             ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
  396.             : "\n$type$pod2.htm\#".$value."\">$text<\/A>\n";
  397.             }
  398.     }
  399.     }
  400.     (warn "No $ref reference for $item (@_)") if $Debug;
  401.     return $text;
  402. } 
  403.  
  404. sub varrefs {
  405.     my ($var,$htype) = @_;
  406.     for $podname ($pod,@inclusions){
  407.     if ($value = $A->{$podname}->{"Items"}->{$var}) {
  408.         ($pod2,$num) = split(/_/,$value,2);
  409.         Debug("vars", "way cool -- var ref on $var");
  410.         return (($pod eq $pod2) && ($htype eq "NAME"))  # INHERIT $_, $pod
  411.         ? "\n<A NAME=\"".$value."\">\n$var</A>\n"
  412.         : "\n$type$pod2.htm\#".$value."\">$var<\/A>\n";
  413.     }
  414.     }
  415.     Debug( "vars", "bummer, $var not a var");
  416.     return "<STRONG>$var</STRONG>";
  417. } 
  418.  
  419. sub gensym {
  420.     my ($podname, $key) = @_;
  421.     $key =~ s/\s.*//;
  422.     ($key = lc($key)) =~ tr/a-z/_/cs;
  423.     my $name = "${podname}_${key}_0";
  424.     $name =~ s/__/_/g;
  425.     while ($sawsym{$name}++) {
  426.         $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
  427.     }
  428.     return $name;
  429. } 
  430.  
  431. sub pre_escapes {
  432.     my($thing)=@_;
  433.     $$thing=~s/&/noremap("&")/ge;
  434.     $$thing=~s/<</noremap("<<")/eg;
  435.     $$thing=~s/(?:[^ESIBLCF])</noremap("<")/eg;
  436.     $$thing=~s/E<([^\/][^<>]*)>/\&$1\;/g;              # embedded special
  437. }
  438.  
  439. sub noremap {
  440.     my $hide = $_[0];
  441.     $hide =~ tr/\000-\177/\200-\377/;
  442.     $hide;
  443. } 
  444.  
  445. sub post_escapes {
  446.     my($thing)=@_;
  447.     $$thing=~s/[^GM]>>/\>\;\>\;/g;
  448.     $$thing=~s/([^"MGAE])>/$1\>\;/g;
  449.     $$thing=~tr/\200-\377/\000-\177/;
  450. }
  451.  
  452. sub Debug {
  453.     my $level = shift;
  454.     print STDERR @_,"\n" if $Debug{$level};
  455. } 
  456.  
  457. sub dumptable  {
  458.     my $t = shift;
  459.     print STDERR "TABLE DUMP $t\n";
  460.     foreach $k (sort keys %$t) {
  461.     printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
  462.     } 
  463. } 
  464. sub trim {
  465.     for (@_) {
  466.         s/^\s+//;
  467.         s/\s\n?$//;
  468.     }
  469. }
  470.  
  471.  
  472. __END__
  473. :endofperl
  474.