4 use File::Basename qw(&basename &dirname);
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
11 # to ensure Configure will look for $Config{startperl}.
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.
16 ($file = basename($0)) =~ s/\.PL$//;
18 if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
20 open OUT,">$file" or die "Can't create $file: $!";
22 print "Extracting $file (with variable substitutions)\n";
24 # In this section, perl variables will be expanded during extraction.
25 # You can use $Config{...} to use Configure variables.
27 print OUT <<"!GROK!THIS!";
29 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
30 if \$running_under_some_shell;
33 # In the following, perl variables are not expanded during extraction.
35 print OUT <<'!NO!SUBS!';
38 # pod2html - convert pod format to html
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.
44 # Many helps, suggestions, and fixes from the perl5 porters, and all over.
45 # Bill Middleton - wjm@metronet.com
47 # Please send patches/fixes/features to me
54 ################################################################################
55 # Invoke with various levels of debugging possible
56 ################################################################################
57 while ($ARGV[0] =~ /^-d(.*)/) {
59 $Debug{ lc($1 || shift) }++;
62 # ck for podnames on command line
67 ################################################################################
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
76 ################################################################################
79 $dir = "."; # location of pods
81 # look in these pods for things not found within the current pod
82 # be careful tho, namespace collisions cause stupid links
85 perlfunc perlvar perlrun perlop
87 ################################################################################
89 ################################################################################
91 $A = {}; # The beginning of all things
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";
98 @Pods or die "aak, expected pods";
100 # loop twice through the pods, first to learn the links, then to produce html
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";
114 for (@all) { s/=$// }
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>";
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);
136 scan_thing("item",$title,$pod);
139 elsif ($cmd =~ /^head([12])/) {
141 if ($count) { # producing html
142 do_hdr($num,$title,$rest,$depth);
146 scan_thing($cmd,$title,$pod); # skip head1
149 elsif ($cmd =~ /^over/) {
150 $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
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);
159 elsif ($cmd =~ /^cut/) {
162 elsif ($cmd =~ /^for/) { # experimental pragma html
163 if ($count) { # producing html
164 if ($title =~ s/^html//) {
166 do_rest($title.$rest);
170 elsif ($cmd =~ /^begin/) { # experimental pragma html
171 if ($count) { # producing html
172 if ($title =~ s/^html//) {
173 print HTML $title,"\n",$rest;
175 elsif ($title =~ /^end/) {
180 elsif ($Debug{"misc"}) {
181 warn("unrecognized header: $cmd");
184 # close open lists without '=back' stmts
185 if ($count) { # producing html
187 do_list("back",$all[$i+1],\$in_list,\$depth);
189 print HTML "\n</BODY>\n</HTML>\n";
194 sub do_list{ # setup a list type, depending on some grok logic
195 my($which,$next_one,$list_type,$depth) = @_;
197 if ($which eq "over") {
198 unless ($next_one =~ /^item\s+(.*)/) {
199 warn "Bad list, $1\n" if $Debug{"misc"};
203 if ($key =~ /^1\.?/) {
205 } elsif ($key =~ /\*\s*$/) {
207 } elsif ($key =~ /\*?\s*\w/) {
210 warn "unknown list type for item $key" if $Debug{"misc"};
214 print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
217 elsif ($which eq "back") {
218 print HTML qq{\n</$$list_type>\n};
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> };
229 print HTML qq{</H$num>\n};
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};
240 print HTML qq{\n</STRONG>\n};
241 print HTML qq{<DD>\n};
244 print HTML qq{\n<LI>};
245 unless ($bullet_only or $list_type eq "OL") {
246 print HTML $title,"\n";
252 sub do_rest{ # the rest of the chunk handled here
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];
264 elsif ($lines[0] =~ /^\s+\w*\t.*/) { # listing or unordered list
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";
272 print HTML qq{</UL>\n};
274 elsif ($lines[0] =~ /^\s/) { # preformatted code
275 if ($paras[$p] =~/>>|<</) {
276 print HTML qq{\n<PRE>\n};
279 else { # Still cant beat XMP. Yes, I know
280 print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
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] =~ />>|<</) {
288 process_thing(\$q,"HTML");
291 print HTML qq{\n</XMP>\n};
292 print HTML qq{<PRE>\n};
294 process_thing(\$q,"HTML");
297 1 while $q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
300 last if $paras[$p+1] !~ /^\s/;
303 print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
306 @lines = split(/\n/,$paras[$p]);
307 foreach $line (@lines) {
308 process_thing(\$line,"HTML");
309 print HTML qq{$line\n};
316 sub process_thing{ # process a chunk, order important
317 my($thing,$htype) = @_;
319 find_refs($thing,$htype);
320 post_escapes($thing);
323 sub scan_thing{ # scan a chunk for later references
324 my($cmd,$title,$pod) = @_;
329 # remove any formatting information for the headers
330 s/[SFCBI]<(.*?)>/$1/g;
331 # the "don't format me" thing
333 if ($cmd eq "item") {
334 /^\*/ and return; # skip bullets
335 /^\d+\./ and return; # skip numbers
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))
345 $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
346 Debug("items", "item $1 REF TO $_");
348 if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
350 $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
352 $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
353 Debug("items", "item $pf REF TO $_");
357 elsif ($cmd =~ /^head[12]/) {
358 return if defined($A->{$pod}->{"Headers"}->{$_});
359 $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
360 Debug("headers", "header $_");
363 warn "unrecognized header: $cmd" if $Debug;
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");
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");
384 ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/;
385 if ($htype eq "NAME") {
386 return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
389 return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
393 if ($char =~ /[IF]/) {
394 return "<EM>$bigkey</EM>";
395 } elsif ($char =~ /C/) {
396 return "<CODE>$bigkey</CODE>";
398 return "<STRONG>$bigkey</STRONG>";
403 my($thing,$htype) = @_;
405 # LREF: a manpage(3f) we don't know about
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;
416 if ($$thing eq $orig && $htype eq "NAME") {
417 $$thing = picrefs("I", $$thing, "", $htype);
423 my($page, $item) = split(m#/#, $_[0], 2);
426 my($section) = $page =~ /\((.*)\)/;
428 if ($page =~ /^[A-Z]/ && $item) {
430 $item = "$page/$item";
432 } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
439 if (!defined $section && defined $Podnames{$page}) {
440 return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
442 (warn "Bizarre entry $page/$item") if $Debug;
443 return "the <EM>$_[0]</EM> manpage\n";
447 if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
448 $text = "<EM>$item</EM>";
451 $text = "<EM>$item</EM>";
454 for $podname ($pod, @inclusions) {
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";
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";
473 warn "No $ref reference for $item (@_)" if $Debug;
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";
488 Debug( "vars", "bummer, $var not a var");
489 return "<STRONG>$var</STRONG>";
493 my ($podname, $key) = @_;
495 ($key = lc($key)) =~ tr/a-z/_/cs;
496 my $name = "${podname}_${key}_0";
498 while ($sawsym{$name}++) {
499 $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
504 sub pre_escapes { # twiddle these, and stay up late :-)
507 s/([\200-\377])/noremap("&".ord($1).";")/ge;
509 s/&/noremap("&")/ge;
510 s/<</noremap("<<")/eg;
511 s/([^ESIBLCF])</$1\<\;/g;
512 s/E<(\d+)>/\&#$1\;/g; # embedded numeric special
513 s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special
516 sub noremap { # adding translator for hibit chars soon
518 $hide =~ tr/\000-\177/\200-\377/;
526 s/([^GM])>>/$1\>\;\>\;/g;
527 s/([^D][^"MGA])>/$1\>\;/g;
528 tr/\200-\377/\000-\177/;
534 print STDERR @_,"\n" if $Debug{$level};
539 print STDERR "TABLE DUMP $t\n";
540 foreach $k (sort keys %$t) {
541 printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
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 ':';