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