#!/usr/local/bin/perl eval 'exec perl -S $0 ${1+"$@"}' if $running_under_some_shell; require "find.pl"; use Config; # somday when we'll have $Config{installhtmldir}... # # pod2html - convert pod format to html # Version 1.20 # usage: pod2html [podfiles] # Will read the cwd and parse all files with .pod extension # if no arguments are given on the command line. # # Many helps, suggestions, and fixes from the perl5 porters, and all over. # Bill Middleton - wjm@metronet.com # # Please send patches/fixes/features to me # # *RS = */; *ERRNO = *!; ################################################################################ # Invoke with various levels of debugging possible ################################################################################ while ($ARGV[0] =~ /^-d(.*)/) { shift; $Debug{ lc($1 || shift) }++; } # ck for podnames on command line while ($ARGV[0]) { push(@Pods,shift); } ################################################################################ # CONFIGURE - change the following to suit your OS and taste ################################################################################ # The beginning of the url for the anchors to the other sections. # Edit $type to suit. It's configured for relative url's now. # Other possibilities are: # $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url # $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server $type = '<A HREF="'; ################################################################################ # location of all podfiles unless on command line # $installprivlib="HD:usr:local:lib:perl5"; # uncomment and reset for Mac # $installprivlib="C:\usr\local\lib\perl5"; # uncomment and reset for DOS (I hope) $installprivlib="/usr/local/lib/perl5"; # Unix ################################################################################ # Where to write out the html files # $installhtmldir="HD:usr:local:lib:perl5:html"; # uncomment and reset for Mac # $installhtmldir="C:\usr\local\lib\perl5\html"; # uncomment and reset for DOS (I hope) $installhtmldir = "./html"; # test for validness if(!(-d $installhtmldir)){ print "Installation directory $installhtmldir does not exist, using cwd\n"; print "Hit ^C now to edit this script and configure installhtmldir\n"; $installhtmldir = '.'; } ################################################################################ # the html extension, change to htm for DOS $htmlext = "htm"; ################################################################################ # arbitrary name for this group of pods $package = "perl"; ################################################################################ # look in these pods for links to things not found within the current pod # be careful tho, namespace collisions cause stupid links @inclusions = qw[ perlfunc perlvar perlrun perlop ]; ################################################################################ # Directory path separator # $sep= ":"; # uncomment for Mac # $sep= "\"; # uncomment for DOS $sep= "/"; ################################################################################ # Create 8.3 html files if this equals 1 $DOSify=1; ################################################################################ # Create maximum 32 character html files if this equals 1 $MACify=0; ################################################################################ # END CONFIGURE # Beyond here be dragons. :-) ################################################################################ $A = {}; # The beginning of all things unless(@Pods){ find($installprivlib); splice(@Pods,$#Pods+1,0,@modpods);; } @Pods or die "aak, expected pods"; open(INDEX,">".$installhtmldir.$sep."index.".$htmlext) or (die "cant open index.$htmlext"); print INDEX "<HTML>\n<HEAD>\n<CENTER><TITLE>Index of all pods for $package</TITLE></CENTER></HEAD>\n<BODY>\n"; print INDEX "<H1>Index of all pods for $package</H1>\n<hr><UL>\n"; # loop twice through the pods, first to learn the links, then to produce html for $count (0,1) { print STDERR "Scanning pods...\n" unless $count; loop1: foreach $podfh ( @Pods ) { $didindex = 0; $refname = $podfh; $refname =~ s/$installprivlib${sep}?//; $refname =~ s/${sep}/::/g; $refname =~ s/\.p(m|od)$//; $refname =~ s/^pod:://; $savename = $refname; $refname =~ s/::/_/g; if($DOSify && !$count){ # shorten the name for DOS (length($refname) > 8) and ( $refname = substr($refname,0,8)); while(defined($DosNames{$refname})){ @refname=split(//,$refname); # allow 25 of em ($refname[$#refname] eq "z") and ($refname[$#refname] = "a"); $refname[$#refname]++; $refname=join('',@refname); $refname =~ s/\W/_/g; } $DosNames{$refname} = 1; $Podnames{$savename} = $refname . ".$htmlext"; } elsif(!$DOSify and !$count){ $Podnames{$savename} = $refname . ".$htmlext"; } $pod = $savename; Debug("files", "opening 2 $podfh" ); print "Creating $Podnames{$savename} from $podfh\n" if $count; $RS = "\n="; # grok pods by item (Nonstandard but effecient) open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO"; @all = <$podfh>; close($podfh); $RS = "\n"; ($all[0] =~ s/^=//) || pop(@all); for ($i=0;$i <= $#all;$i++){ splice(@all,$i+1,1) unless (($all[$i] =~ s/=$//) && ($all[$i+1] !~ /^cut/)) ; # whoa.. } $in_list = 0; unless (grep(/NAME/,@all)){ print STDERR "NAME header not found in $podfh, skipping\n"; #delete($Podnames{$savename}); next loop1; } if ($count) { next unless length($Podnames{$savename}); open(HTML,">".$installhtmldir.$sep.$Podnames{$savename}) or (die "can't create $Podnames{$savename}: $ERRNO"); print HTML "<HEAD><CENTER>"; print HTML "<TITLE>$refname</TITLE>\n</CENTER></HEAD>\n<BODY>"; } for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ; ($cmd, $title, $rest) = ($1,$2,$3); if(length($cmd)){$cutting =0;} next if $cutting; if(($title =~ /NAME/) and ($didindex == 0) and $count){ print INDEX "<LI><A HREF=\"$Podnames{$savename}\">$rest</A>\n"; $didindex=1; } if ($cmd eq "item") { if ($count ) { # producing html do_list("over",$all[$i],\$in_list,\$depth) unless $depth; do_item($title,$rest,$in_list); } else { # scan item scan_thing("item",$title,$pod); } } elsif ($cmd =~ /^head([12])/) { $num = $1; if ($count) { # producing html do_hdr($num,$title,$rest,$depth); } else { # header scan scan_thing($cmd,$title,$pod); # skip head1 } } elsif ($cmd =~ /^over/) { $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth); } elsif ($cmd =~ /^back/) { if ($count) { # producing html ($depth) or next; # just skip it do_list("back",$all[$i+1],\$in_list,\$depth); do_rest("$title$rest"); } } elsif ($cmd =~ /^cut/) { next; } elsif ($cmd =~ /^for/) { # experimental pragma html if ($count) { # producing html if ($title =~ s/^html//) { $in_html =1; do_rest("$title$rest"); } } } elsif ($cmd =~ /^begin/) { # experimental pragma html if ($count) { # producing html if ($title =~ s/^html//) { print HTML $title,"\n",$rest; } elsif ($title =~ /^end/) { next; } } } elsif ($Debug{"misc"}) { warn("unrecognized header: $cmd"); } } # close open lists without '=back' stmts if ($count) { # producing html while ($depth) { do_list("back",$all[$i+1],\$in_list,\$depth); } print HTML "\n</BODY>\n</HTML>\n"; } } } print INDEX "\n</UL></BODY>\n</HTML>\n"; sub do_list{ # setup a list type, depending on some grok logic my($which,$next_one,$list_type,$depth) = @_; my($key); if ($which eq "over") { unless ($next_one =~ /^item\s+(.*)/) { warn "Bad list, $1\n" if $Debug{"misc"}; } $key = $1; if ($key =~ /^1\.?/) { $$list_type = "OL"; } elsif ($key =~ /\*\s*$/) { $$list_type = "UL"; } elsif ($key =~ /\*?\s*\w/) { $$list_type = "DL"; } else { warn "unknown list type for item $key" if $Debug{"misc"}; } print HTML qq{\n}; print HTML qq{<$$list_type>}; $$depth++; } elsif ($which eq "back") { print HTML qq{\n</$$list_type>\n}; $$depth--; } } sub do_hdr{ # headers my($num,$title,$rest,$depth) = @_; my($savename,$restofname); print HTML qq{<p><hr>\n} if $num == 1; ($savename = $title) =~ s/^(\w+)([\s,]+.*)/$1/; $restofname = $2; (defined($Podnames{$savename})) ? ($savename = $savename) : ($savename = 0); process_thing(\$title,"NAME"); print HTML qq{\n<H$num> }; if($savename){ print HTML "<A HREF=\"$Podnames{$savename}\">$savename$restofname</A>"; } else{ print HTML $title; } print HTML qq{</H$num>\n}; do_rest($rest); } sub do_item{ # list items my($title,$rest,$list_type) = @_; my $bullet_only; $bullet_only = ($title eq '*' and $list_type eq 'UL') ? 1 : 0; my($savename); $savename = $title; (defined($Podnames{$savename})) ? ($savename = $savename) : ($savename = 0); process_thing(\$title,"NAME"); if ($list_type eq "DL") { print HTML qq{\n<DT>\n}; if($savename){ print HTML "<A HREF=\"$Podnames{$savename}\">$savename $rest</A>\n</DT>"; } else{ (print HTML qq{\n<STRONG>\n}) unless ($title =~ /STRONG/); print HTML $title; (print HTML qq{\n</DT></STRONG>\n}) unless ($title =~ /STRONG/); } print HTML qq{<DD>\n}; } else { print HTML qq{\n<LI>}; unless ($bullet_only or $list_type eq "OL") { if($savename){ print HTML "<A HREF=\"$savename.$htmlext\">$savename</A>"; } else{ print HTML $title,"\n"; } } } do_rest($rest); } sub do_rest{ # the rest of the chunk handled here my($rest) = @_; my(@lines,$p,$q,$line,,@paras,$inpre); @paras = split(/\n\n\n*/,$rest); for ($p = 0; $p <= $#paras; $p++) { $paras[$p] =~ s/^\n//mg; @lines = split(/\n/,$paras[$p]); if ($in_html) { # handle =for html paragraphs print HTML $paras[0]; $in_html = 0; next; } elsif ($lines[0] =~ /^\s+\w*\t.*/) { # listing or unordered list print HTML qq{<UL>}; foreach $line (@lines) { ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2)); print HTML defined($Podnames{$key}) ? "<LI>$type$Podnames{$key}\">$key<\/A>\t$rem</LI>\n" : "<LI>$line</LI>\n"; } print HTML qq{</UL>\n}; } elsif ($lines[0] =~ /^\s/) { # preformatted code if ($paras[$p] =~/>>|<</) { print HTML qq{\n<PRE>\n}; $inpre=1; } else { # Still cant beat XMP. Yes, I know print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions? $inpre = 0; } while (defined($paras[$p])) { @lines = split(/\n/,$paras[$p]); foreach $q (@lines) { # mind your p's and q's here :-) if ($paras[$p] =~ />>|<</) { if ($inpre) { process_thing(\$q,"HTML"); } else { print HTML qq{\n</XMP>\n}; print HTML qq{<PRE>\n}; $inpre=1; process_thing(\$q,"HTML"); } } 1 while $q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e; print HTML $q,"\n"; } last if $paras[$p+1] !~ /^\s/; $p++; } print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n}); } else { # other text @lines = split(/\n/,$paras[$p]); foreach $line (@lines) { process_thing(\$line,"HTML"); $line =~ s/STRONG([^>])/STRONG>$1/; print HTML qq{$line\n}; } } print HTML qq{<p>}; } } sub process_thing{ # process a chunk, order important my($thing,$htype) = @_; pre_escapes($thing); find_refs($thing,$htype); post_escapes($thing); } sub scan_thing{ # scan a chunk for later references my($cmd,$title,$pod) = @_; $_ = $title; s/\n$//; s/E<(.*?)>/&$1;/g; # remove any formatting information for the headers s/[SFCBI]<(.*?)>/$1/g; # the "don't format me" thing s/Z<>//g; if ($cmd eq "item") { /^\*/ and return; # skip bullets /^\d+\./ and return; # skip numbers s/(-[a-z]).*/$1/i; trim($_); return if defined $A->{$pod}->{"Items"}->{$_}; $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_); $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_}; Debug("items", "item $_"); if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) { $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_}; Debug("items", "item $1 REF TO $_"); } if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) { my $pf = $1 . '//'; $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s"; if ($pf ne $_) { $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_}; Debug("items", "item $pf REF TO $_"); } } } elsif ($cmd =~ /^head[12]/) { return if defined($A->{$pod}->{"Headers"}->{$_}); $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_); Debug("headers", "header $_"); } else { warn "unrecognized header: $cmd" if $Debug; } } sub picrefs { my($char, $bigkey, $lilkey,$htype) = @_; my($key,$ref,$podname); for $podname ($pod,@inclusions) { for $ref ( "Items", "Headers" ) { if (defined $A->{$podname}->{$ref}->{$bigkey}) { $value = $A->{$podname}->{$ref}->{$key = $bigkey}; Debug("subs", "bigkey is $bigkey, value is $value\n"); } elsif (defined $A->{$podname}->{$ref}->{$lilkey}) { $value = $A->{$podname}->{$ref}->{$key = $lilkey}; return "" if $lilkey eq ''; Debug("subs", "lilkey is $lilkey, value is $value\n"); } } if (length($key)) { ($pod2,$num) = split(/_/,$value,2); if ($htype eq "NAME") { return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n" } else { 1; # break here return "\n$type$Podnames{$pod2}\#".$value."\">$bigkey<\/A>\n"; } } } if ($char =~ /[IF]/) { return "<EM>$bigkey</EM>"; } elsif ($char =~ /C/) { return "<CODE>$bigkey</CODE>"; } else { if($bigkey =~ /STRONG/){ return $bigkey; } else{ return "<STRONG>$bigkey</STRONG>"; } } } sub find_refs { my($thing,$htype) = @_; my($orig) = $$thing; # LREF: a manpage(3f) we don't know about for ($$thing) { #s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g; s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge; s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie; s/L<([^>]*)>/lrefs($1,$htype)/ge; s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge; s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge; s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge; s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge; } if ($$thing eq $orig && $htype eq "NAME") { $$thing = picrefs("I", $$thing, "", $htype); } } sub lrefs { my($page, $item) = split(m#/#, $_[0], 2); my($htype) = $_[1]; my($podname); my($section) = $page =~ /\((.*)\)/; my $selfref; if ($page =~ /^[A-Z]/ && $item) { $selfref++; $item = "$page/$item"; $page = $pod; } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) { $selfref++; $item = $page; $page = $pod; } $item =~ s/\(\)$//; if (!$item) { if (!defined $section && defined $Podnames{$page}) { return "\n$type$Podnames{$page}\">\nthe <EM>$page</EM> manpage<\/A>\n"; } else { (warn "Bizarre entry $page/$item") if $Debug; return "the <EM>$_[0]</EM> manpage\n"; } } if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) { $text = "<EM>$item</EM>"; $ref = "Headers"; } else { $text = "<EM>$item</EM>"; $ref = "Items"; } for $podname ($pod, @inclusions) { undef $value; if ($ref eq "Items") { if (defined($value = $A->{$podname}->{$ref}->{$item})) { ($pod2,$num) = split(/_/,$value,2); # break here return (($pod eq $pod2) && ($htype eq "NAME")) ? "\n<A NAME=\"".$value."\">\n$text</A>\n" : "\n$type$Podnames{$pod2}\#".$value."\">$text<\/A>\n"; } } elsif ($ref eq "Headers") { if (defined($value = $A->{$podname}->{$ref}->{$item})) { ($pod2,$num) = split(/_/,$value,2); # break here return (($pod eq $pod2) && ($htype eq "NAME")) ? "\n<A NAME=\"".$value."\">\n$text</A>\n" : "\n$type$Podnames{$pod2}\#".$value."\">$text<\/A>\n"; } } } warn "No $ref reference for $item (@_)" if $Debug; return $text; } sub varrefs { my ($var,$htype) = @_; for $podname ($pod,@inclusions) { if ($value = $A->{$podname}->{"Items"}->{$var}) { ($pod2,$num) = split(/_/,$value,2); Debug("vars", "way cool -- var ref on $var"); return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod ? "\n<A NAME=\"".$value."\">\n$var</A>\n" : "\n$type$Podnames{$pod2}\#".$value."\">$var<\/A>\n"; } } Debug( "vars", "bummer, $var not a var"); if($var =~ /STRONG/){ return $var; } else{ return "<STRONG>$var</STRONG>"; } } sub gensym { my ($podname, $key) = @_; $key =~ s/\s.*//; ($key = lc($key)) =~ tr/a-z/_/cs; my $name = "${podname}_${key}_0"; $name =~ s/__/_/g; while ($sawsym{$name}++) { $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e; } return $name; } sub pre_escapes { # twiddle these, and stay up late :-) my($thing) = @_; for ($$thing) { s/"(.*?)"/``$1''/gs; s/&/noremap("&")/ge; s/<</noremap("<<")/eg; s/([^ESIBLCF])</$1\<\;/g; s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special } } sub noremap { # adding translator for hibit chars soon my $hide = $_[0]; $hide =~ tr/\000-\177/\200-\377/; $hide; } sub post_escapes { my($thing) = @_; for ($$thing) { s/([^GM])>>/$1\>\;\>\;/g; s/([^D][^"MGA])>/$1\>\;/g; tr/\200-\377/\000-\177/; } } sub Debug { my $level = shift; print STDERR @_,"\n" if $Debug{$level}; } sub dumptable { my $t = shift; print STDERR "TABLE DUMP $t\n"; foreach $k (sort keys %$t) { printf STDERR "%-20s <%s>\n", $t->{$k}, $k; } } sub trim { for (@_) { s/^\s+//; s/\s\n?$//; } } sub wanted { my $name = $name; if (-f $_) { if ($name =~ /\.p(m|od)$/){ push(@modpods, $name) if ($name =~ /\.p(m|od)$/); } } }