Commit | Line | Data |
4633a7c4 |
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$// |
f360dba1 |
18 | if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" |
4633a7c4 |
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!"; |
5f05dabc |
28 | $Config{startperl} |
29 | eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' |
30 | if \$running_under_some_shell; |
4633a7c4 |
31 | !GROK!THIS! |
32 | |
33 | # In the following, perl variables are not expanded during extraction. |
34 | |
35 | print OUT <<'!NO!SUBS!'; |
5f05dabc |
36 | |
4633a7c4 |
37 | # |
38 | # pod2html - convert pod format to html |
39 | # Version 1.15 |
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. |
43 | # |
44 | # Many helps, suggestions, and fixes from the perl5 porters, and all over. |
45 | # Bill Middleton - wjm@metronet.com |
46 | # |
47 | # Please send patches/fixes/features to me |
48 | # |
49 | # |
50 | # |
51 | *RS = */; |
52 | *ERRNO = *!; |
53 | |
54 | ################################################################################ |
55 | # Invoke with various levels of debugging possible |
56 | ################################################################################ |
57 | while ($ARGV[0] =~ /^-d(.*)/) { |
58 | shift; |
59 | $Debug{ lc($1 || shift) }++; |
60 | } |
61 | |
62 | # ck for podnames on command line |
63 | while ($ARGV[0]) { |
64 | push(@Pods,shift); |
65 | } |
66 | |
67 | ################################################################################ |
68 | # CONFIGURE |
69 | # |
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 |
75 | # |
76 | ################################################################################ |
77 | |
78 | $type = '<A HREF="'; |
79 | $dir = "."; # location of pods |
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) { |
347a6e91 |
102 | print STDERR "Scanning pods...\n" unless $count; |
4633a7c4 |
103 | foreach $podfh ( @Pods ) { |
347a6e91 |
104 | ($pod = $podfh) =~ s/\.(?:pod|pm)$//; |
4633a7c4 |
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; |
a4165598 |
122 | print HTML "<TITLE>$pod</TITLE>"; |
4633a7c4 |
123 | print HTML "</CENTER>" unless $NO_NS; |
a4165598 |
124 | print HTML "\n</HEAD>\n<BODY>"; |
4633a7c4 |
125 | } |
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); |
133 | } |
134 | else { |
135 | # scan item |
136 | scan_thing("item",$title,$pod); |
137 | } |
138 | } |
139 | elsif ($cmd =~ /^head([12])/) { |
140 | $num = $1; |
141 | if ($count) { # producing html |
142 | do_hdr($num,$title,$rest,$depth); |
143 | } |
144 | else { |
145 | # header scan |
146 | scan_thing($cmd,$title,$pod); # skip head1 |
147 | } |
148 | } |
149 | elsif ($cmd =~ /^over/) { |
150 | $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth); |
151 | } |
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); |
347a6e91 |
156 | do_rest($title.$rest); |
4633a7c4 |
157 | } |
158 | } |
159 | elsif ($cmd =~ /^cut/) { |
160 | next; |
161 | } |
162 | elsif ($cmd =~ /^for/) { # experimental pragma html |
163 | if ($count) { # producing html |
164 | if ($title =~ s/^html//) { |
165 | $in_html =1; |
347a6e91 |
166 | do_rest($title.$rest); |
4633a7c4 |
167 | } |
168 | } |
169 | } |
170 | elsif ($cmd =~ /^begin/) { # experimental pragma html |
171 | if ($count) { # producing html |
172 | if ($title =~ s/^html//) { |
173 | print HTML $title,"\n",$rest; |
174 | } |
175 | elsif ($title =~ /^end/) { |
176 | next; |
177 | } |
178 | } |
179 | } |
180 | elsif ($Debug{"misc"}) { |
181 | warn("unrecognized header: $cmd"); |
182 | } |
183 | } |
184 | # close open lists without '=back' stmts |
185 | if ($count) { # producing html |
186 | while ($depth) { |
187 | do_list("back",$all[$i+1],\$in_list,\$depth); |
188 | } |
189 | print HTML "\n</BODY>\n</HTML>\n"; |
190 | } |
191 | } |
192 | } |
193 | |
194 | sub do_list{ # setup a list type, depending on some grok logic |
195 | my($which,$next_one,$list_type,$depth) = @_; |
196 | my($key); |
197 | if ($which eq "over") { |
198 | unless ($next_one =~ /^item\s+(.*)/) { |
199 | warn "Bad list, $1\n" if $Debug{"misc"}; |
200 | } |
201 | $key = $1; |
202 | |
203 | if ($key =~ /^1\.?/) { |
204 | $$list_type = "OL"; |
205 | } elsif ($key =~ /\*\s*$/) { |
206 | $$list_type = "UL"; |
207 | } elsif ($key =~ /\*?\s*\w/) { |
208 | $$list_type = "DL"; |
209 | } else { |
210 | warn "unknown list type for item $key" if $Debug{"misc"}; |
211 | } |
212 | |
213 | print HTML qq{\n}; |
214 | print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>}; |
215 | $$depth++; |
216 | } |
217 | elsif ($which eq "back") { |
218 | print HTML qq{\n</$$list_type>\n}; |
219 | $$depth--; |
220 | } |
221 | } |
222 | |
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> }; |
228 | print HTML $title; |
229 | print HTML qq{</H$num>\n}; |
230 | do_rest($rest); |
231 | } |
232 | |
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}; |
239 | print HTML $title; |
240 | print HTML qq{\n</STRONG>\n}; |
241 | print HTML qq{<DD>\n}; |
242 | } |
243 | else { |
244 | print HTML qq{\n<LI>}; |
245 | unless ($bullet_only or $list_type eq "OL") { |
246 | print HTML $title,"\n"; |
247 | } |
248 | } |
249 | do_rest($rest); |
250 | } |
251 | |
252 | sub do_rest{ # the rest of the chunk handled here |
253 | my($rest) = @_; |
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]; |
261 | $in_html = 0; |
262 | next; |
263 | } |
264 | elsif ($lines[0] =~ /^\s+\w*\t.*/) { # listing or unordered list |
265 | print HTML qq{<UL>}; |
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"; |
271 | } |
272 | print HTML qq{</UL>\n}; |
273 | } |
274 | elsif ($lines[0] =~ /^\s/) { # preformatted code |
275 | if ($paras[$p] =~/>>|<</) { |
276 | print HTML qq{\n<PRE>\n}; |
277 | $inpre=1; |
278 | } |
279 | else { # Still cant beat XMP. Yes, I know |
280 | print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions? |
281 | $inpre = 0; |
282 | } |
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] =~ />>|<</) { |
287 | if ($inpre) { |
288 | process_thing(\$q,"HTML"); |
289 | } |
290 | else { |
291 | print HTML qq{\n</XMP>\n}; |
292 | print HTML qq{<PRE>\n}; |
293 | $inpre=1; |
294 | process_thing(\$q,"HTML"); |
295 | } |
296 | } |
297 | 1 while $q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e; |
298 | print HTML $q,"\n"; |
299 | } |
300 | last if $paras[$p+1] !~ /^\s/; |
301 | $p++; |
302 | } |
303 | print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n}); |
304 | } |
305 | else { # other text |
306 | @lines = split(/\n/,$paras[$p]); |
307 | foreach $line (@lines) { |
308 | process_thing(\$line,"HTML"); |
309 | print HTML qq{$line\n}; |
310 | } |
311 | } |
312 | print HTML qq{<p>}; |
313 | } |
314 | } |
315 | |
316 | sub process_thing{ # process a chunk, order important |
317 | my($thing,$htype) = @_; |
318 | pre_escapes($thing); |
319 | find_refs($thing,$htype); |
320 | post_escapes($thing); |
321 | } |
322 | |
323 | sub scan_thing{ # scan a chunk for later references |
324 | my($cmd,$title,$pod) = @_; |
325 | $_ = $title; |
326 | s/\n$//; |
7f3dfc00 |
327 | s/E<(\d+)>/&#$1;/g; |
4633a7c4 |
328 | s/E<(.*?)>/&$1;/g; |
329 | # remove any formatting information for the headers |
330 | s/[SFCBI]<(.*?)>/$1/g; |
331 | # the "don't format me" thing |
332 | s/Z<>//g; |
333 | if ($cmd eq "item") { |
334 | /^\*/ and return; # skip bullets |
335 | /^\d+\./ and return; # skip numbers |
336 | s/(-[a-z]).*/$1/i; |
337 | trim($_); |
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)) |
344 | { |
345 | $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_}; |
346 | Debug("items", "item $1 REF TO $_"); |
347 | } |
348 | if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) { |
349 | my $pf = $1 . '//'; |
350 | $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s"; |
351 | if ($pf ne $_) { |
352 | $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_}; |
353 | Debug("items", "item $pf REF TO $_"); |
354 | } |
355 | } |
356 | } |
357 | elsif ($cmd =~ /^head[12]/) { |
358 | return if defined($A->{$pod}->{"Headers"}->{$_}); |
359 | $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_); |
360 | Debug("headers", "header $_"); |
361 | } |
362 | else { |
363 | warn "unrecognized header: $cmd" if $Debug; |
364 | } |
365 | } |
366 | |
367 | |
368 | sub picrefs { |
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"); |
376 | } |
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"); |
381 | } |
382 | } |
383 | if (length($key)) { |
a4165598 |
384 | ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/; |
4633a7c4 |
385 | if ($htype eq "NAME") { |
386 | return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n" |
387 | } |
388 | else { |
389 | return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n"; |
390 | } |
391 | } |
392 | } |
393 | if ($char =~ /[IF]/) { |
394 | return "<EM>$bigkey</EM>"; |
395 | } elsif ($char =~ /C/) { |
396 | return "<CODE>$bigkey</CODE>"; |
397 | } else { |
398 | return "<STRONG>$bigkey</STRONG>"; |
399 | } |
400 | } |
401 | |
402 | sub find_refs { |
403 | my($thing,$htype) = @_; |
404 | my($orig) = $$thing; |
405 | # LREF: a manpage(3f) we don't know about |
406 | for ($$thing) { |
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; |
415 | } |
416 | if ($$thing eq $orig && $htype eq "NAME") { |
417 | $$thing = picrefs("I", $$thing, "", $htype); |
418 | } |
419 | |
420 | } |
421 | |
422 | sub lrefs { |
423 | my($page, $item) = split(m#/#, $_[0], 2); |
424 | my($htype) = $_[1]; |
425 | my($podname); |
426 | my($section) = $page =~ /\((.*)\)/; |
427 | my $selfref; |
428 | if ($page =~ /^[A-Z]/ && $item) { |
429 | $selfref++; |
430 | $item = "$page/$item"; |
431 | $page = $pod; |
432 | } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) { |
433 | $selfref++; |
434 | $item = $page; |
435 | $page = $pod; |
436 | } |
437 | $item =~ s/\(\)$//; |
438 | if (!$item) { |
439 | if (!defined $section && defined $Podnames{$page}) { |
440 | return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n"; |
441 | } else { |
442 | (warn "Bizarre entry $page/$item") if $Debug; |
443 | return "the <EM>$_[0]</EM> manpage\n"; |
444 | } |
445 | } |
446 | |
447 | if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) { |
448 | $text = "<EM>$item</EM>"; |
449 | $ref = "Headers"; |
450 | } else { |
451 | $text = "<EM>$item</EM>"; |
452 | $ref = "Items"; |
453 | } |
454 | for $podname ($pod, @inclusions) { |
455 | undef $value; |
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"; |
462 | } |
463 | } |
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"; |
470 | } |
471 | } |
472 | } |
473 | warn "No $ref reference for $item (@_)" if $Debug; |
474 | return $text; |
475 | } |
476 | |
477 | sub varrefs { |
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"; |
486 | } |
487 | } |
488 | Debug( "vars", "bummer, $var not a var"); |
489 | return "<STRONG>$var</STRONG>"; |
490 | } |
491 | |
492 | sub gensym { |
493 | my ($podname, $key) = @_; |
494 | $key =~ s/\s.*//; |
495 | ($key = lc($key)) =~ tr/a-z/_/cs; |
496 | my $name = "${podname}_${key}_0"; |
497 | $name =~ s/__/_/g; |
498 | while ($sawsym{$name}++) { |
499 | $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e; |
500 | } |
501 | return $name; |
502 | } |
503 | |
504 | sub pre_escapes { # twiddle these, and stay up late :-) |
505 | my($thing) = @_; |
506 | for ($$thing) { |
347a6e91 |
507 | s/([\200-\377])/noremap("&".ord($1).";")/ge; |
4633a7c4 |
508 | s/"(.*?)"/``$1''/gs; |
509 | s/&/noremap("&")/ge; |
510 | s/<</noremap("<<")/eg; |
511 | s/([^ESIBLCF])</$1\<\;/g; |
7f3dfc00 |
512 | s/E<(\d+)>/\&#$1\;/g; # embedded numeric special |
4633a7c4 |
513 | s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special |
514 | } |
515 | } |
516 | sub noremap { # adding translator for hibit chars soon |
517 | my $hide = $_[0]; |
518 | $hide =~ tr/\000-\177/\200-\377/; |
519 | $hide; |
520 | } |
521 | |
522 | |
523 | sub post_escapes { |
524 | my($thing) = @_; |
525 | for ($$thing) { |
526 | s/([^GM])>>/$1\>\;\>\;/g; |
527 | s/([^D][^"MGA])>/$1\>\;/g; |
528 | tr/\200-\377/\000-\177/; |
529 | } |
530 | } |
531 | |
532 | sub Debug { |
533 | my $level = shift; |
534 | print STDERR @_,"\n" if $Debug{$level}; |
535 | } |
536 | |
537 | sub dumptable { |
538 | my $t = shift; |
539 | print STDERR "TABLE DUMP $t\n"; |
540 | foreach $k (sort keys %$t) { |
541 | printf STDERR "%-20s <%s>\n", $t->{$k}, $k; |
542 | } |
543 | } |
544 | sub trim { |
545 | for (@_) { |
546 | s/^\s+//; |
547 | s/\s\n?$//; |
548 | } |
549 | } |
550 | !NO!SUBS! |
551 | |
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 ':'; |