util/pod2man.pl

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