This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
indent nested =items properly (suggested by Bill Fenner
[perl5.git] / pod / pod2man.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use File::Basename qw(&basename &dirname);
5 use Cwd;
6
7 # List explicitly here the variables you want Configure to
8 # generate.  Metaconfig only looks for shell variables, so you
9 # have to mention them as if they were shell variables, not
10 # %Config entries.  Thus you write
11 #  $startperl
12 #  $man3ext
13 # to ensure Configure will look for $Config{startperl}.
14
15 # This forces PL files to create target in same directory as PL file.
16 # This is so that make depend always knows where to find PL derivatives.
17 $origdir = cwd;
18 chdir dirname($0);
19 $file = basename($0, '.PL');
20 $file .= '.com' if $^O eq 'VMS';
21
22 open OUT,">$file" or die "Can't create $file: $!";
23
24 print "Extracting $file (with variable substitutions)\n";
25
26 # In this section, perl variables will be expanded during extraction.
27 # You can use $Config{...} to use Configure variables.
28
29 print OUT <<"!GROK!THIS!";
30 $Config{startperl}
31     eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
32         if \$running_under_some_shell;
33
34 \$DEF_PM_SECTION = '$Config{man3ext}' || '3';
35 !GROK!THIS!
36
37 # In the following, perl variables are not expanded during extraction.
38
39 print OUT <<'!NO!SUBS!';
40
41 =head1 NAME
42
43 pod2man - translate embedded Perl pod directives into man pages
44
45 =head1 SYNOPSIS
46
47 B<pod2man>
48 [ B<--section=>I<manext> ]
49 [ B<--release=>I<relpatch> ]
50 [ B<--center=>I<string> ]
51 [ B<--date=>I<string> ]
52 [ B<--fixed=>I<font> ]
53 [ B<--official> ]
54 [ B<--lax> ]
55 I<inputfile>
56
57 =head1 DESCRIPTION
58
59 B<pod2man> converts its input file containing embedded pod directives (see
60 L<perlpod>) into nroff source suitable for viewing with nroff(1) or
61 troff(1) using the man(7) macro set.
62
63 Besides the obvious pod conversions, B<pod2man> also takes care of
64 func(), func(n), and simple variable references like $foo or @bar so
65 you don't have to use code escapes for them; complex expressions like
66 C<$fred{'stuff'}> will still need to be escaped, though.  Other nagging
67 little roffish things that it catches include translating the minus in
68 something like foo-bar, making a long dash--like this--into a real em
69 dash, fixing up "paired quotes", putting a little space after the
70 parens in something like func(), making C++ and PI look right, making
71 double underbars have a little tiny space between them, making ALLCAPS
72 a teeny bit smaller in troff(1), and escaping backslashes so you don't
73 have to.
74
75 =head1 OPTIONS
76
77 =over 8
78
79 =item center
80
81 Set the centered header to a specific string.  The default is
82 "User Contributed Perl Documentation", unless the C<--official> flag is
83 given, in which case the default is "Perl Programmers Reference Guide".
84
85 =item date
86
87 Set the left-hand footer string to this value.  By default,
88 the modification date of the input file will be used.
89
90 =item fixed
91
92 The fixed font to use for code refs.  Defaults to CW.
93
94 =item official
95
96 Set the default header to indicate that this page is of
97 the standard release in case C<--center> is not given.
98
99 =item release
100
101 Set the centered footer.  By default, this is the current
102 perl release.
103
104 =item section
105
106 Set the section for the C<.TH> macro.  The standard conventions on
107 sections are to use 1 for user commands,  2 for system calls, 3 for
108 functions, 4 for devices, 5 for file formats, 6 for games, 7 for
109 miscellaneous information, and 8 for administrator commands.  This works
110 best if you put your Perl man pages in a separate tree, like
111 F</usr/local/perl/man/>.  By default, section 1 will be used
112 unless the file ends in F<.pm> in which case section 3 will be selected.
113
114 =item lax
115
116 Don't complain when required sections aren't present.
117
118 =back
119
120 =head1 Anatomy of a Proper Man Page
121
122 For those not sure of the proper layout of a man page, here's
123 an example of the skeleton of a proper man page.  Head of the
124 major headers should be setout as a C<=head1> directive, and
125 are historically written in the rather startling ALL UPPER CASE
126 format, although this is not mandatory.
127 Minor headers may be included using C<=head2>, and are
128 typically in mixed case.
129
130 =over 10
131
132 =item NAME
133
134 Mandatory section; should be a comma-separated list of programs or
135 functions documented by this podpage, such as:
136
137     foo, bar - programs to do something
138
139 =item SYNOPSIS
140
141 A short usage summary for programs and functions, which
142 may someday be deemed mandatory.
143
144 =item DESCRIPTION
145
146 Long drawn out discussion of the program.  It's a good idea to break this
147 up into subsections using the C<=head2> directives, like
148
149     =head2 A Sample Subection
150
151     =head2 Yet Another Sample Subection
152
153 =item OPTIONS
154
155 Some people make this separate from the description.
156
157 =item RETURN VALUE
158
159 What the program or function returns if successful.
160
161 =item ERRORS
162
163 Exceptions, return codes, exit stati, and errno settings.
164
165 =item EXAMPLES
166
167 Give some example uses of the program.
168
169 =item ENVIRONMENT
170
171 Envariables this program might care about.
172
173 =item FILES
174
175 All files used by the program.  You should probably use the FE<lt>E<gt>
176 for these.
177
178 =item SEE ALSO
179
180 Other man pages to check out, like man(1), man(7), makewhatis(8), or catman(8).
181
182 =item NOTES
183
184 Miscellaneous commentary.
185
186 =item CAVEATS
187
188 Things to take special care with; sometimes called WARNINGS.
189
190 =item DIAGNOSTICS
191
192 All possible messages the program can print out--and
193 what they mean.
194
195 =item BUGS
196
197 Things that are broken or just don't work quite right.
198
199 =item RESTRICTIONS
200
201 Bugs you don't plan to fix :-)
202
203 =item AUTHOR
204
205 Who wrote it (or AUTHORS if multiple).
206
207 =item HISTORY
208
209 Programs derived from other sources sometimes have this, or
210 you might keep a modification log here.
211
212 =back
213
214 =head1 EXAMPLES
215
216     pod2man program > program.1
217     pod2man some_module.pm > /usr/perl/man/man3/some_module.3
218     pod2man --section=7 note.pod > note.7
219
220 =head1 DIAGNOSTICS
221
222 The following diagnostics are generated by B<pod2man>.  Items
223 marked "(W)" are non-fatal, whereas the "(F)" errors will cause
224 B<pod2man> to immediately exit with a non-zero status.
225
226 =over 4
227
228 =item bad option in paragraph %d of %s: ``%s'' should be [%s]<%s>
229
230 (W) If you start include an option, you should set it off
231 as bold, italic, or code.
232
233 =item can't open %s: %s
234
235 (F) The input file wasn't available for the given reason.
236
237 =item Improper man page - no dash in NAME header in paragraph %d of %s
238
239 (W) The NAME header did not have an isolated dash in it.  This is
240 considered important.
241
242 =item Invalid man page - no NAME line in %s
243
244 (F) You did not include a NAME header, which is essential.
245
246 =item roff font should be 1 or 2 chars, not `%s'  (F)
247
248 (F) The font specified with the C<--fixed> option was not
249 a one- or two-digit roff font.
250
251 =item %s is missing required section: %s
252
253 (W) Required sections include NAME, DESCRIPTION, and if you're
254 using a section starting with a 3, also a SYNOPSIS.  Actually,
255 not having a NAME is a fatal.
256
257 =item Unknown escape: %s in %s
258
259 (W) An unknown HTML entity (probably for an 8-bit character) was given via
260 a C<EE<lt>E<gt>> directive.  Besides amp, lt, gt, and quot, recognized
261 entities are Aacute, aacute, Acirc, acirc, AElig, aelig, Agrave, agrave,
262 Aring, aring, Atilde, atilde, Auml, auml, Ccedil, ccedil, Eacute, eacute,
263 Ecirc, ecirc, Egrave, egrave, ETH, eth, Euml, euml, Iacute, iacute, Icirc,
264 icirc, Igrave, igrave, Iuml, iuml, Ntilde, ntilde, Oacute, oacute, Ocirc,
265 ocirc, Ograve, ograve, Oslash, oslash, Otilde, otilde, Ouml, ouml, szlig,
266 THORN, thorn, Uacute, uacute, Ucirc, ucirc, Ugrave, ugrave, Uuml, uuml,
267 Yacute, yacute, and yuml.
268
269 =item Unmatched =back
270
271 (W) You have a C<=back> without a corresponding C<=over>.
272
273 =item Unrecognized pod directive: %s
274
275 (W) You specified a pod directive that isn't in the known list of
276 C<=head1>, C<=head2>, C<=item>, C<=over>, C<=back>, or C<=cut>.
277
278
279 =back
280
281 =head1 NOTES
282
283 If you would like to print out a lot of man page continuously, you
284 probably want to set the C and D registers to set contiguous page
285 numbering and even/odd paging, at least on some versions of man(7).
286 Settting the F register will get you some additional experimental
287 indexing:
288
289     troff -man -rC1 -rD1 -rF1 perl.1 perldata.1 perlsyn.1 ...
290
291 The indexing merely outputs messages via C<.tm> for each
292 major page, section, subsection, item, and any C<XE<lt>E<gt>>
293 directives.
294
295
296 =head1 RESTRICTIONS
297
298 None at this time.
299
300 =head1 BUGS
301
302 The =over and =back directives don't really work right.  They
303 take absolute positions instead of offsets, don't nest well, and
304 making people count is suboptimal in any event.
305
306 =head1 AUTHORS
307
308 Original prototype by Larry Wall, but so massively hacked over by
309 Tom Christiansen such that Larry probably doesn't recognize it anymore.
310
311 =cut
312
313 $/ = "";
314 $cutting = 1;
315 @Indices = ();
316
317 # We try first to get the version number from a local binary, in case we're
318 # running an installed version of Perl to produce documentation from an
319 # uninstalled newer version's pod files.
320 if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') {
321   my $perl = (-x './perl' && -f './perl' ) ?
322                  './perl' :
323                  ((-x '../perl' && -f '../perl') ?
324                       '../perl' :
325                       '');
326   ($version,$patch) = `$perl -e 'print $]'` =~ /^(\d\.\d{3})(\d{2})?/ if $perl;
327 }
328 # No luck; we'll just go with the running Perl's version
329 ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version;
330 $DEF_RELEASE  = "perl $version";
331 $DEF_RELEASE .= ", patch $patch" if $patch;
332
333
334 sub makedate {
335     my $secs = shift;
336     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs);
337     my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon];
338     $year += 1900;
339     return "$mday/$mname/$year";
340 }
341
342 use Getopt::Long;
343
344 $DEF_SECTION = 1;
345 $DEF_CENTER = "User Contributed Perl Documentation";
346 $STD_CENTER = "Perl Programmers Reference Guide";
347 $DEF_FIXED = 'CW';
348 $DEF_LAX = 0;
349
350 sub usage {
351     warn "$0: @_\n" if @_;
352     die <<EOF;
353 usage: $0 [options] podpage
354 Options are:
355         --section=manext      (default "$DEF_SECTION")
356         --release=relpatch    (default "$DEF_RELEASE")
357         --center=string       (default "$DEF_CENTER")
358         --date=string         (default "$DEF_DATE")
359         --fixed=font          (default "$DEF_FIXED")
360         --official            (default NOT)
361         --lax                 (default NOT)
362 EOF
363 }
364
365 $uok = GetOptions( qw(
366         section=s
367         release=s
368         center=s
369         date=s
370         fixed=s
371         official
372         lax
373         help));
374
375 $DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
376
377 usage("Usage error!") unless $uok;
378 usage() if $opt_help;
379 usage("Need one and only one podpage argument") unless @ARGV == 1;
380
381 $section = $opt_section || ($ARGV[0] =~ /\.pm$/
382                                 ? $DEF_PM_SECTION : $DEF_SECTION);
383 $RP = $opt_release || $DEF_RELEASE;
384 $center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
385 $lax = $opt_lax || $DEF_LAX;
386
387 $CFont = $opt_fixed || $DEF_FIXED;
388
389 if (length($CFont) == 2) {
390     $CFont_embed = "\\f($CFont";
391 }
392 elsif (length($CFont) == 1) {
393     $CFont_embed = "\\f$CFont";
394 }
395 else {
396     die "roff font should be 1 or 2 chars, not `$CFont_embed'";
397 }
398
399 $date = $opt_date || $DEF_DATE;
400
401 for (qw{NAME DESCRIPTION}) {
402 # for (qw{NAME DESCRIPTION AUTHOR}) {
403     $wanna_see{$_}++;
404 }
405 $wanna_see{SYNOPSIS}++ if $section =~ /^3/;
406
407
408 $name = @ARGV ? $ARGV[0] : "<STDIN>";
409 $Filename = $name;
410 if ($section =~ /^1/) {
411     require File::Basename;
412     $name = uc File::Basename::basename($name);
413 }
414 $name =~ s/\.(pod|p[lm])$//i;
415
416 # Lose everything up to the first of
417 #     */lib/*perl*      standard or site_perl module
418 #     */*perl*/lib      from -D prefix=/opt/perl
419 #     */*perl*/         random module hierarchy
420 # which works.
421 $name =~ s-//+-/-g;
422 if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i
423         or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i
424         or $name =~ s-^.*?/[^/]*perl[^/]*/--i) {
425     # Lose ^site(_perl)?/.
426     $name =~ s-^site(_perl)?/--;
427     # Lose ^arch/.      (XXX should we use Config? Just for archname?)
428     $name =~ s~^(.*-$^O|$^O-.*)/~~o;
429     # Lose ^version/.
430     $name =~ s-^\d+\.\d+/--;
431 }
432
433 # Translate Getopt/Long to Getopt::Long, etc.
434 $name =~ s(/)(::)g;
435
436 if ($name ne 'something') {
437     FCHECK: {
438         open(F, "< $ARGV[0]") || die "can't open $ARGV[0]: $!";
439         while (<F>) {
440             next unless /^=\b/;
441             if (/^=head1\s+NAME\s*$/) {  # an /m would forgive mistakes
442                 $_ = <F>;
443                 unless (/\s*-+\s+/) {
444                     $oops++;
445                     warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n"
446                 } else {
447                     my @n = split /\s+-+\s+/;
448                     if (@n != 2) {
449                         $oops++;
450                         warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n"
451                     }
452                     else {
453                         %namedesc = @n;
454                     }
455                 }
456                 last FCHECK;
457             }
458             next if /^=cut\b/;  # DB_File and Net::Ping have =cut before NAME
459             next if /^=pod\b/;  # It is OK to have =pod before NAME
460             die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
461         }
462         die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
463     }
464     close F;
465 }
466
467 print <<"END";
468 .rn '' }`
469 ''' \$RCSfile\$\$Revision\$\$Date\$
470 '''
471 ''' \$Log\$
472 '''
473 .de Sh
474 .br
475 .if t .Sp
476 .ne 5
477 .PP
478 \\fB\\\\\$1\\fR
479 .PP
480 ..
481 .de Sp
482 .if t .sp .5v
483 .if n .sp
484 ..
485 .de Ip
486 .br
487 .ie \\\\n(.\$>=3 .ne \\\\\$3
488 .el .ne 3
489 .IP "\\\\\$1" \\\\\$2
490 ..
491 .de Vb
492 .ft $CFont
493 .nf
494 .ne \\\\\$1
495 ..
496 .de Ve
497 .ft R
498
499 .fi
500 ..
501 '''
502 '''
503 '''     Set up \\*(-- to give an unbreakable dash;
504 '''     string Tr holds user defined translation string.
505 '''     Bell System Logo is used as a dummy character.
506 '''
507 .tr \\(*W-|\\(bv\\*(Tr
508 .ie n \\{\\
509 .ds -- \\(*W-
510 .ds PI pi
511 .if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch
512 .if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch
513 .ds L" ""
514 .ds R" ""
515 '''   \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of
516 '''   \\*(L" and \\*(R", except that they are used on ".xx" lines,
517 '''   such as .IP and .SH, which do another additional levels of
518 '''   double-quote interpretation
519 .ds M" """
520 .ds S" """
521 .ds N" """""
522 .ds T" """""
523 .ds L' '
524 .ds R' '
525 .ds M' '
526 .ds S' '
527 .ds N' '
528 .ds T' '
529 'br\\}
530 .el\\{\\
531 .ds -- \\(em\\|
532 .tr \\*(Tr
533 .ds L" ``
534 .ds R" ''
535 .ds M" ``
536 .ds S" ''
537 .ds N" ``
538 .ds T" ''
539 .ds L' `
540 .ds R' '
541 .ds M' `
542 .ds S' '
543 .ds N' `
544 .ds T' '
545 .ds PI \\(*p
546 'br\\}
547 END
548
549 print <<'END';
550 .\"     If the F register is turned on, we'll generate
551 .\"     index entries out stderr for the following things:
552 .\"             TH      Title 
553 .\"             SH      Header
554 .\"             Sh      Subsection 
555 .\"             Ip      Item
556 .\"             X<>     Xref  (embedded
557 .\"     Of course, you have to process the output yourself
558 .\"     in some meaninful fashion.
559 .if \nF \{
560 .de IX
561 .tm Index:\\$1\t\\n%\t"\\$2"
562 ..
563 .nr % 0
564 .rr F
565 .\}
566 END
567
568 print <<"END";
569 .TH $name $section "$date" "$RP" "$center"
570 .UC
571 END
572
573 push(@Indices, qq{.IX Title "$name $section"});
574
575 while (($name, $desc) = each %namedesc) {
576     for ($name, $desc) { s/^\s+//; s/\s+$//; }
577     push(@Indices, qq(.IX Name "$name - $desc"\n));
578 }
579
580 print <<'END';
581 .if n .hy 0
582 .if n .na
583 .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
584 .de CQ          \" put $1 in typewriter font
585 END
586 print ".ft $CFont\n";
587 print <<'END';
588 'if n "\c
589 'if t \\&\\$1\c
590 'if n \\&\\$1\c
591 'if n \&"
592 \\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7
593 '.ft R
594 ..
595 .\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2
596 .       \" AM - accent mark definitions
597 .bd B 3
598 .       \" fudge factors for nroff and troff
599 .if n \{\
600 .       ds #H 0
601 .       ds #V .8m
602 .       ds #F .3m
603 .       ds #[ \f1
604 .       ds #] \fP
605 .\}
606 .if t \{\
607 .       ds #H ((1u-(\\\\n(.fu%2u))*.13m)
608 .       ds #V .6m
609 .       ds #F 0
610 .       ds #[ \&
611 .       ds #] \&
612 .\}
613 .       \" simple accents for nroff and troff
614 .if n \{\
615 .       ds ' \&
616 .       ds ` \&
617 .       ds ^ \&
618 .       ds , \&
619 .       ds ~ ~
620 .       ds ? ?
621 .       ds ! !
622 .       ds /
623 .       ds q
624 .\}
625 .if t \{\
626 .       ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
627 .       ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
628 .       ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
629 .       ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
630 .       ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
631 .       ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10'
632 .       ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m'
633 .       ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
634 .       ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10'
635 .\}
636 .       \" troff and (daisy-wheel) nroff accents
637 .ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
638 .ds 8 \h'\*(#H'\(*b\h'-\*(#H'
639 .ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#]
640 .ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u'
641 .ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u'
642 .ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#]
643 .ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
644 .ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
645 .ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
646 .ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
647 .ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
648 .ds ae a\h'-(\w'a'u*4/10)'e
649 .ds Ae A\h'-(\w'A'u*4/10)'E
650 .ds oe o\h'-(\w'o'u*4/10)'e
651 .ds Oe O\h'-(\w'O'u*4/10)'E
652 .       \" corrections for vroff
653 .if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
654 .if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
655 .       \" for low resolution devices (crt and lpr)
656 .if \n(.H>23 .if \n(.V>19 \
657 \{\
658 .       ds : e
659 .       ds 8 ss
660 .       ds v \h'-1'\o'\(aa\(ga'
661 .       ds _ \h'-1'^
662 .       ds . \h'-1'.
663 .       ds 3 3
664 .       ds o a
665 .       ds d- d\h'-1'\(ga
666 .       ds D- D\h'-1'\(hy
667 .       ds th \o'bp'
668 .       ds Th \o'LP'
669 .       ds ae ae
670 .       ds Ae AE
671 .       ds oe oe
672 .       ds Oe OE
673 .\}
674 .rm #[ #] #H #V #F C
675 END
676
677 $indent = 0;
678
679 $begun = "";
680
681 # Unrolling [^-=A-Z>]|[A-Z](?!<)|[-=](?![A-Z]<)[\x00-\xFF] gives: // MRE pp 165.
682 my $nonest = q{(?x)             # Turn on /x mode.
683               (?:               # Group
684                 [^-=A-Z>]*      # Anything that isn't a dash, equal sign or
685                                 # closing hook isn't special. Eat as much as
686                                 # we can.
687                 (?:             # Group.
688                   (?:           # Group.
689                     [-=]        # We want to recognize -> and =>.
690                     (?![A-Z]<)  # So, as long as it isn't followed by markup
691                     [\x00-\xFF] # anything may follow - and =
692                     |
693                     [A-Z]       # Capitals are fine too,
694                     (?!<)       # But not if they start markup.
695                   )             # End of special sequences.
696                   [^-=A-Z>]*    # Followed by zero or more non-special chars. 
697                 )*              # And we can repeat this as often as we can.
698               )};               # That's all folks.
699
700 while (<>) {
701     if ($cutting) {
702         next unless /^=/;
703         $cutting = 0;
704     }
705     if ($begun) {
706         if (/^=end\s+$begun/) {
707             $begun = "";
708         }
709         elsif ($begun =~ /^(roff|man)$/) {
710             print STDOUT $_;
711         }
712         next;
713     }
714     chomp;
715
716     # Translate verbatim paragraph
717
718     if (/^\s/) {
719         @lines = split(/\n/);
720         for (@lines) {
721             1 while s
722                 {^( [^\t]* ) \t ( \t* ) }
723                 { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex;
724             s/\\/\\e/g;
725             s/\A/\\&/s;
726         }
727         $lines = @lines;
728         makespace() unless $verbatim++;
729         print ".Vb $lines\n";
730         print join("\n", @lines), "\n";
731         print ".Ve\n";
732         $needspace = 0;
733         next;
734     }
735
736     $verbatim = 0;
737
738     if (/^=for\s+(\S+)\s*/s) {
739         if ($1 eq "man" or $1 eq "roff") {
740             print STDOUT $',"\n\n";
741         } else {
742             # ignore unknown for
743         }
744         next;
745     }
746     elsif (/^=begin\s+(\S+)\s*/s) {
747         $begun = $1;
748         if ($1 eq "man" or $1 eq "roff") {
749             print STDOUT $'."\n\n";
750         }
751         next;
752     }
753
754     # check for things that'll hosed our noremap scheme; affects $_
755     init_noremap();
756
757     if (!/^=item/) {
758
759         # trofficate backslashes; must do it before what happens below
760         s/\\/noremap('\\e')/ge;
761
762         # protect leading periods and quotes against *roff
763         # mistaking them for directives
764         s/^(?:[A-Z]<)?[.']/\\&$&/gm;
765
766         # first hide the escapes in case we need to
767         # intuit something and get it wrong due to fmting
768
769         1 while s/([A-Z]<$nonest>)/noremap($1)/ge;
770
771         # func() is a reference to a perl function
772         s{
773             \b
774             (
775                 [:\w]+ \(\)
776             )
777         } {I<$1>}gx;
778
779         # func(n) is a reference to a perl function or a man page
780         s{
781             ([:\w]+)
782             (
783                 \( [^\051]+ \)
784             )
785         } {I<$1>\\|$2}gx;
786
787         # convert simple variable references
788         s/(\s+)([\$\@%&*][\w:]+)(?!\()/${1}C<$2>/g;
789
790         if (m{ (
791                     [\-\w]+
792                     \(
793                         [^\051]*?
794                         [\@\$,]
795                         [^\051]*?
796                     \)
797                 )
798             }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
799         {
800             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [LCI]<$1>\n";
801             $oops++;
802         }
803
804         while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
805             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [CB]<$1>\n";
806             $oops++;
807         }
808
809         # put it back so we get the <> processed again;
810         clear_noremap(0); # 0 means leave the E's
811
812     } else {
813         # trofficate backslashes
814         s/\\/noremap('\\e')/ge;
815
816     }
817
818     # need to hide E<> first; they're processed in clear_noremap
819     s/(E<[^<>]+>)/noremap($1)/ge;
820
821
822     $maxnest = 10;
823     while ($maxnest-- && /[A-Z]</) {
824
825         # can't do C font here
826         s/([BI])<($nonest)>/font($1) . $2 . font('R')/eg;
827
828         # files and filelike refs in italics
829         s/F<($nonest)>/I<$1>/g;
830
831         # no break -- usually we want C<> for this
832         s/S<($nonest)>/nobreak($1)/eg;
833
834         # LREF: a la HREF L<show this text|man/section>
835         s:L<([^|>]+)\|[^>]+>:$1:g;
836
837         # LREF: a manpage(3f)
838         s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g;
839
840         # LREF: an =item on another manpage
841         s{
842             L<
843                 ([^/]+)
844                 /
845                 (
846                     [:\w]+
847                     (\(\))?
848                 )
849             >
850         } {the C<$2> entry in the I<$1> manpage}gx;
851
852         # LREF: an =item on this manpage
853         s{
854            ((?:
855             L<
856                 /
857                 (
858                     [:\w]+
859                     (\(\))?
860                 )
861             >
862             (,?\s+(and\s+)?)?
863           )+)
864         } { internal_lrefs($1) }gex;
865
866         # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
867         # the "func" can disambiguate
868         s{
869             L<
870                 (?:
871                     ([a-zA-Z]\S+?) /
872                 )?
873                 "?(.*?)"?
874             >
875         }{
876             do {
877                 $1      # if no $1, assume it means on this page.
878                     ?  "the section on I<$2> in the I<$1> manpage"
879                     :  "the section on I<$2>"
880             }
881         }gesx; # s in case it goes over multiple lines, so . matches \n
882
883         s/Z<>/\\&/g;
884
885         # comes last because not subject to reprocessing
886         s/C<($nonest)>/noremap("${CFont_embed}${1}\\fR")/eg;
887     }
888
889     if (s/^=//) {
890         $needspace = 0;         # Assume this.
891
892         s/\n/ /g;
893
894         ($Cmd, $_) = split(' ', $_, 2);
895
896         $dotlevel = 1;
897         if ($Cmd eq 'head1') {
898            $dotlevel = 1;
899         }
900         elsif ($Cmd eq 'head2') {
901            $dotlevel = 1;
902         }
903         elsif ($Cmd eq 'item') {
904            $dotlevel = 2;
905         }
906
907         if (defined $_) {
908             &escapes($dotlevel);
909             s/"/""/g;
910         }
911
912         clear_noremap(1);
913
914         if ($Cmd eq 'cut') {
915             $cutting = 1;
916         }
917         elsif ($Cmd eq 'head1') {
918             s/\s+$//;
919             delete $wanna_see{$_} if exists $wanna_see{$_};
920             print qq{.SH "$_"\n};
921       push(@Indices, qq{.IX Header "$_"\n});
922         }
923         elsif ($Cmd eq 'head2') {
924             print qq{.Sh "$_"\n};
925       push(@Indices, qq{.IX Subsection "$_"\n});
926         }
927         elsif ($Cmd eq 'over') {
928             push(@indent,$indent);
929             $indent += ($_ + 0) || 5;
930             if ($#indent > 0) {
931                 print ".RS ", $indent[$#indent] - $indent[$#indent - 1], "\n";
932             }
933         }
934         elsif ($Cmd eq 'back') {
935             $indent = pop(@indent);
936             warn "$0: Unmatched =back in paragraph $. of $ARGV\n" unless defined $indent;
937             if ($#indent >= 0) {
938                 print ".RE\n";
939             }
940             $needspace = 1;
941         }
942         elsif ($Cmd eq 'item') {
943             s/^\*( |$)/\\(bu$1/g;
944             # if you know how to get ":s please do
945             s/\\\*\(L"([^"]+?)\\\*\(R"/'$1'/g;
946             s/\\\*\(L"([^"]+?)""/'$1'/g;
947             s/[^"]""([^"]+?)""[^"]/'$1'/g;
948             # here do something about the $" in perlvar?
949             print STDOUT qq{.Ip "$_" $indent-$indent[$#indent]\n};
950       push(@Indices, qq{.IX Item "$_"\n});
951         }
952         elsif ($Cmd eq 'pod') {
953             # this is just a comment
954         } 
955         else {
956             warn "$0: Unrecognized pod directive in paragraph $. of $ARGV: $Cmd\n";
957         }
958     }
959     else {
960         if ($needspace) {
961             &makespace;
962         }
963         &escapes(0);
964         clear_noremap(1);
965         print $_, "\n";
966         $needspace = 1;
967     }
968 }
969
970 print <<"END";
971
972 .rn }` ''
973 END
974
975 if (%wanna_see && !$lax) {
976     @missing = keys %wanna_see;
977     warn "$0: $Filename is missing required section"
978         .  (@missing > 1 && "s")
979         .  ": @missing\n";
980     $oops++;
981 }
982
983 foreach (@Indices) { print "$_\n"; }
984
985 exit;
986 #exit ($oops != 0);
987
988 #########################################################################
989
990 sub nobreak {
991     my $string = shift;
992     $string =~ s/ /\\ /g;
993     $string;
994 }
995
996 sub escapes {
997     my $indot = shift;
998
999     s/X<(.*?)>/mkindex($1)/ge;
1000
1001     # translate the minus in foo-bar into foo\-bar for roff
1002     s/([^0-9a-z-])-([^-])/$1\\-$2/g;
1003
1004     # make -- into the string version \*(-- (defined above)
1005     s/\b--\b/\\*(--/g;
1006     s/"--([^"])/"\\*(--$1/g;  # should be a better way
1007     s/([^"])--"/$1\\*(--"/g;
1008
1009     # fix up quotes; this is somewhat tricky
1010     my $dotmacroL = 'L';
1011     my $dotmacroR = 'R';
1012     if ( $indot == 1 ) {
1013         $dotmacroL = 'M';
1014         $dotmacroR = 'S';
1015     }  
1016     elsif ( $indot >= 2 ) {
1017         $dotmacroL = 'N';
1018         $dotmacroR = 'T';
1019     }  
1020     if (!/""/) {
1021         s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge;
1022         s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge;
1023     }
1024
1025     #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g;
1026     #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g;
1027
1028
1029     # make sure that func() keeps a bit a space tween the parens
1030     ### s/\b\(\)/\\|()/g;
1031     ### s/\b\(\)/(\\|)/g;
1032
1033     # make C++ into \*C+, which is a squinched version (defined above)
1034     s/\bC\+\+/\\*(C+/g;
1035
1036     # make double underbars have a little tiny space between them
1037     s/__/_\\|_/g;
1038
1039     # PI goes to \*(PI (defined above)
1040     s/\bPI\b/noremap('\\*(PI')/ge;
1041
1042     # make all caps a teeny bit smaller, but don't muck with embedded code literals
1043     my $hidCFont = font('C');
1044     if ($Cmd !~ /^head1/) { # SH already makes smaller
1045         # /g isn't enough; 1 while or we'll be off
1046
1047 #       1 while s{
1048 #           (?!$hidCFont)(..|^.|^)
1049 #           \b
1050 #           (
1051 #               [A-Z][\/A-Z+:\-\d_$.]+
1052 #           )
1053 #           (s?)                
1054 #           \b
1055 #       } {$1\\s-1$2\\s0}gmox;
1056
1057         1 while s{
1058             (?!$hidCFont)(..|^.|^)
1059             (
1060                 \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b
1061             )
1062         } {
1063             $1 . noremap( '\\s-1' .  $2 . '\\s0' )
1064         }egmox;
1065
1066     }
1067 }
1068
1069 # make troff just be normal, but make small nroff get quoted
1070 # decided to just put the quotes in the text; sigh;
1071 sub ccvt {
1072     local($_,$prev) = @_;
1073     noremap(qq{.CQ "$_" \n\\&});
1074 }
1075
1076 sub makespace {
1077     if ($indent) {
1078         print ".Sp\n";
1079     }
1080     else {
1081         print ".PP\n";
1082     }
1083 }
1084
1085 sub mkindex {
1086     my ($entry) = @_;
1087     my @entries = split m:\s*/\s*:, $entry;
1088     push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries;
1089     return '';
1090 }
1091
1092 sub font {
1093     local($font) = shift;
1094     return '\\f' . noremap($font);
1095 }
1096
1097 sub noremap {
1098     local($thing_to_hide) = shift;
1099     $thing_to_hide =~ tr/\000-\177/\200-\377/;
1100     return $thing_to_hide;
1101 }
1102
1103 sub init_noremap {
1104         # escape high bit characters in input stream
1105         s/([\200-\377])/"E<".ord($1).">"/ge;
1106 }
1107
1108 sub clear_noremap {
1109     my $ready_to_print = $_[0];
1110
1111     tr/\200-\377/\000-\177/;
1112
1113     # trofficate backslashes
1114     # s/(?!\\e)(?:..|^.|^)\\/\\e/g;
1115
1116     # now for the E<>s, which have been hidden until now
1117     # otherwise the interative \w<> processing would have
1118     # been hosed by the E<gt>
1119     s {
1120             E<
1121             (
1122                 ( \d + ) 
1123                 | ( [A-Za-z]+ ) 
1124             )
1125             >   
1126     } {
1127          do {
1128              defined $2
1129                 ? chr($2)
1130                 :       
1131              exists $HTML_Escapes{$3}
1132                 ? do { $HTML_Escapes{$3} }
1133                 : do {
1134                     warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
1135                     "E<$1>";
1136                 }
1137          }
1138     }egx if $ready_to_print;
1139 }
1140
1141 sub internal_lrefs {
1142     local($_) = shift;
1143     local $trailing_and = s/and\s+$// ? "and " : "";
1144
1145     s{L</([^>]+)>}{$1}g;
1146     my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
1147     my $retstr = "the ";
1148     my $i;
1149     for ($i = 0; $i <= $#items; $i++) {
1150         $retstr .= "C<$items[$i]>";
1151         $retstr .= ", " if @items > 2 && $i != $#items;
1152         $retstr .= " and " if $i+2 == @items;
1153     }
1154
1155     $retstr .= " entr" . ( @items > 1  ? "ies" : "y" )
1156             .  " elsewhere in this document";
1157     # terminal space to avoid words running together (pattern used
1158     # strips terminal spaces)
1159     $retstr .= " " if length $trailing_and;
1160     $retstr .=  $trailing_and;
1161
1162     return $retstr;
1163
1164 }
1165
1166 BEGIN {
1167 %HTML_Escapes = (
1168     'amp'       =>      '&',    #   ampersand
1169     'lt'        =>      '<',    #   left chevron, less-than
1170     'gt'        =>      '>',    #   right chevron, greater-than
1171     'quot'      =>      '"',    #   double quote
1172
1173     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
1174     "aacute"    =>      "a\\*'",        #   small a, acute accent
1175     "Acirc"     =>      "A\\*^",        #   capital A, circumflex accent
1176     "acirc"     =>      "a\\*^",        #   small a, circumflex accent
1177     "AElig"     =>      '\*(AE',        #   capital AE diphthong (ligature)
1178     "aelig"     =>      '\*(ae',        #   small ae diphthong (ligature)
1179     "Agrave"    =>      "A\\*`",        #   capital A, grave accent
1180     "agrave"    =>      "A\\*`",        #   small a, grave accent
1181     "Aring"     =>      'A\\*o',        #   capital A, ring
1182     "aring"     =>      'a\\*o',        #   small a, ring
1183     "Atilde"    =>      'A\\*~',        #   capital A, tilde
1184     "atilde"    =>      'a\\*~',        #   small a, tilde
1185     "Auml"      =>      'A\\*:',        #   capital A, dieresis or umlaut mark
1186     "auml"      =>      'a\\*:',        #   small a, dieresis or umlaut mark
1187     "Ccedil"    =>      'C\\*,',        #   capital C, cedilla
1188     "ccedil"    =>      'c\\*,',        #   small c, cedilla
1189     "Eacute"    =>      "E\\*'",        #   capital E, acute accent
1190     "eacute"    =>      "e\\*'",        #   small e, acute accent
1191     "Ecirc"     =>      "E\\*^",        #   capital E, circumflex accent
1192     "ecirc"     =>      "e\\*^",        #   small e, circumflex accent
1193     "Egrave"    =>      "E\\*`",        #   capital E, grave accent
1194     "egrave"    =>      "e\\*`",        #   small e, grave accent
1195     "ETH"       =>      '\\*(D-',       #   capital Eth, Icelandic
1196     "eth"       =>      '\\*(d-',       #   small eth, Icelandic
1197     "Euml"      =>      "E\\*:",        #   capital E, dieresis or umlaut mark
1198     "euml"      =>      "e\\*:",        #   small e, dieresis or umlaut mark
1199     "Iacute"    =>      "I\\*'",        #   capital I, acute accent
1200     "iacute"    =>      "i\\*'",        #   small i, acute accent
1201     "Icirc"     =>      "I\\*^",        #   capital I, circumflex accent
1202     "icirc"     =>      "i\\*^",        #   small i, circumflex accent
1203     "Igrave"    =>      "I\\*`",        #   capital I, grave accent
1204     "igrave"    =>      "i\\*`",        #   small i, grave accent
1205     "Iuml"      =>      "I\\*:",        #   capital I, dieresis or umlaut mark
1206     "iuml"      =>      "i\\*:",        #   small i, dieresis or umlaut mark
1207     "Ntilde"    =>      'N\*~',         #   capital N, tilde
1208     "ntilde"    =>      'n\*~',         #   small n, tilde
1209     "Oacute"    =>      "O\\*'",        #   capital O, acute accent
1210     "oacute"    =>      "o\\*'",        #   small o, acute accent
1211     "Ocirc"     =>      "O\\*^",        #   capital O, circumflex accent
1212     "ocirc"     =>      "o\\*^",        #   small o, circumflex accent
1213     "Ograve"    =>      "O\\*`",        #   capital O, grave accent
1214     "ograve"    =>      "o\\*`",        #   small o, grave accent
1215     "Oslash"    =>      "O\\*/",        #   capital O, slash
1216     "oslash"    =>      "o\\*/",        #   small o, slash
1217     "Otilde"    =>      "O\\*~",        #   capital O, tilde
1218     "otilde"    =>      "o\\*~",        #   small o, tilde
1219     "Ouml"      =>      "O\\*:",        #   capital O, dieresis or umlaut mark
1220     "ouml"      =>      "o\\*:",        #   small o, dieresis or umlaut mark
1221     "szlig"     =>      '\*8',          #   small sharp s, German (sz ligature)
1222     "THORN"     =>      '\\*(Th',       #   capital THORN, Icelandic
1223     "thorn"     =>      '\\*(th',,      #   small thorn, Icelandic
1224     "Uacute"    =>      "U\\*'",        #   capital U, acute accent
1225     "uacute"    =>      "u\\*'",        #   small u, acute accent
1226     "Ucirc"     =>      "U\\*^",        #   capital U, circumflex accent
1227     "ucirc"     =>      "u\\*^",        #   small u, circumflex accent
1228     "Ugrave"    =>      "U\\*`",        #   capital U, grave accent
1229     "ugrave"    =>      "u\\*`",        #   small u, grave accent
1230     "Uuml"      =>      "U\\*:",        #   capital U, dieresis or umlaut mark
1231     "uuml"      =>      "u\\*:",        #   small u, dieresis or umlaut mark
1232     "Yacute"    =>      "Y\\*'",        #   capital Y, acute accent
1233     "yacute"    =>      "y\\*'",        #   small y, acute accent
1234     "yuml"      =>      "y\\*:",        #   small y, dieresis or umlaut mark
1235 );
1236 }
1237
1238 !NO!SUBS!
1239
1240 close OUT or die "Can't close $file: $!";
1241 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1242 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1243 chdir $origdir;