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         }
 931         elsif ($Cmd eq 'back') {
 932             $indent = pop(@indent);
 933             warn "$0: Unmatched =back in paragraph $. of $ARGV\n" unless defined $indent;
 934             $needspace = 1;
 935         }
 936         elsif ($Cmd eq 'item') {
 937             s/^\*( |$)/\\(bu$1/g;
 938             # if you know how to get ":s please do
 939             s/\\\*\(L"([^"]+?)\\\*\(R"/'$1'/g;
 940             s/\\\*\(L"([^"]+?)""/'$1'/g;
 941             s/[^"]""([^"]+?)""[^"]/'$1'/g;
 942             # here do something about the $" in perlvar?
 943             print STDOUT qq{.Ip "$_" $indent\n};
 944       push(@Indices, qq{.IX Item "$_"\n});
 945         }
 946         elsif ($Cmd eq 'pod') {
 947             # this is just a comment
 948         }
 949         else {
 950             warn "$0: Unrecognized pod directive in paragraph $. of $ARGV: $Cmd\n";
 951         }
 952     }
 953     else {
 954         if ($needspace) {
 955             &makespace;
 956         }
 957         &escapes(0);
 958         clear_noremap(1);
 959         print $_, "\n";
 960         $needspace = 1;
 961     }
 962 }
 963
 964 print <<"END";
 965
 966 .rn }` ''
 967 END
 968
 969 if (%wanna_see && !$lax) {
 970     @missing = keys %wanna_see;
 971     warn "$0: $Filename is missing required section"
 972         .  (@missing > 1 && "s")
 973         .  ": @missing\n";
 974     $oops++;
 975 }
 976
 977 foreach (@Indices) { print "$_\n"; }
 978
 979 exit;
 980 #exit ($oops != 0);
 981
 982 #########################################################################
 983
 984 sub nobreak {
 985     my $string = shift;
 986     $string =~ s/ /\\ /g;
 987     $string;
 988 }
 989
 990 sub escapes {
 991     my $indot = shift;
 992
 993     s/X<(.*?)>/mkindex($1)/ge;
 994
 995     # translate the minus in foo-bar into foo\-bar for roff
 996     s/([^0-9a-z-])-([^-])/$1\\-$2/g;
 997
 998     # make -- into the string version \*(-- (defined above)
 999     s/\b--\b/\\*(--/g;
1000     s/"--([^"])/"\\*(--$1/g;  # should be a better way
1001     s/([^"])--"/$1\\*(--"/g;
1002
1003     # fix up quotes; this is somewhat tricky
1004     my $dotmacroL = 'L';
1005     my $dotmacroR = 'R';
1006     if ( $indot == 1 ) {
1007         $dotmacroL = 'M';
1008         $dotmacroR = 'S';
1009     }
1010     elsif ( $indot >= 2 ) {
1011         $dotmacroL = 'N';
1012         $dotmacroR = 'T';
1013     }
1014     if (!/""/) {
1015         s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge;
1016         s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge;
1017     }
1018
1019     #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g;
1020     #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g;
1021
1022
1023     # make sure that func() keeps a bit a space tween the parens
1024     ### s/\b\(\)/\\|()/g;
1025     ### s/\b\(\)/(\\|)/g;
1026
1027     # make C++ into \*C+, which is a squinched version (defined above)
1028     s/\bC\+\+/\\*(C+/g;
1029
1030     # make double underbars have a little tiny space between them
1031     s/__/_\\|_/g;
1032
1033     # PI goes to \*(PI (defined above)
1034     s/\bPI\b/noremap('\\*(PI')/ge;
1035
1036     # make all caps a teeny bit smaller, but don't muck with embedded code literals
1037     my $hidCFont = font('C');
1038     if ($Cmd !~ /^head1/) { # SH already makes smaller
1039         # /g isn't enough; 1 while or we'll be off
1040
1041 #       1 while s{
1042 #           (?!$hidCFont)(..|^.|^)
1043 #           \b
1044 #           (
1045 #               [A-Z][\/A-Z+:\-\d_$.]+
1046 #           )
1047 #           (s?)
1048 #           \b
1049 #       } {$1\\s-1$2\\s0}gmox;
1050
1051         1 while s{
1052             (?!$hidCFont)(..|^.|^)
1053             (
1054                 \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b
1055             )
1056         } {
1057             $1 . noremap( '\\s-1' .  $2 . '\\s0' )
1058         }egmox;
1059
1060     }
1061 }
1062
1063 # make troff just be normal, but make small nroff get quoted
1064 # decided to just put the quotes in the text; sigh;
1065 sub ccvt {
1066     local($_,$prev) = @_;
1067     noremap(qq{.CQ "$_" \n\\&});
1068 }
1069
1070 sub makespace {
1071     if ($indent) {
1072         print ".Sp\n";
1073     }
1074     else {
1075         print ".PP\n";
1076     }
1077 }
1078
1079 sub mkindex {
1080     my ($entry) = @_;
1081     my @entries = split m:\s*/\s*:, $entry;
1082     push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries;
1083     return '';
1084 }
1085
1086 sub font {
1087     local($font) = shift;
1088     return '\\f' . noremap($font);
1089 }
1090
1091 sub noremap {
1092     local($thing_to_hide) = shift;
1093     $thing_to_hide =~ tr/\000-\177/\200-\377/;
1094     return $thing_to_hide;
1095 }
1096
1097 sub init_noremap {
1098         # escape high bit characters in input stream
1099         s/([\200-\377])/"E<".ord($1).">"/ge;
1100 }
1101
1102 sub clear_noremap {
1103     my $ready_to_print = $_[0];
1104
1105     tr/\200-\377/\000-\177/;
1106
1107     # trofficate backslashes
1108     # s/(?!\\e)(?:..|^.|^)\\/\\e/g;
1109
1110     # now for the E<>s, which have been hidden until now
1111     # otherwise the interative \w<> processing would have
1112     # been hosed by the E<gt>
1113     s {
1114             E<
1115             (
1116                 ( \d + )
1117                 | ( [A-Za-z]+ )
1118             )
1119             >
1120     } {
1121          do {
1122              defined $2
1123                 ? chr($2)
1124                 :
1125              exists $HTML_Escapes{$3}
1126                 ? do { $HTML_Escapes{$3} }
1127                 : do {
1128                     warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
1129                     "E<$1>";
1130                 }
1131          }
1132     }egx if $ready_to_print;
1133 }
1134
1135 sub internal_lrefs {
1136     local($_) = shift;
1137     local $trailing_and = s/and\s+$// ? "and " : "";
1138
1139     s{L</([^>]+)>}{$1}g;
1140     my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
1141     my $retstr = "the ";
1142     my $i;
1143     for ($i = 0; $i <= $#items; $i++) {
1144         $retstr .= "C<$items[$i]>";
1145         $retstr .= ", " if @items > 2 && $i != $#items;
1146         $retstr .= " and " if $i+2 == @items;
1147     }
1148
1149     $retstr .= " entr" . ( @items > 1  ? "ies" : "y" )
1150             .  " elsewhere in this document";
1151     # terminal space to avoid words running together (pattern used
1152     # strips terminal spaces)
1153     $retstr .= " " if length $trailing_and;
1154     $retstr .=  $trailing_and;
1155
1156     return $retstr;
1157
1158 }
1159
1160 BEGIN {
1161 %HTML_Escapes = (
1162     'amp'       =>      '&',    #   ampersand
1163     'lt'        =>      '<',    #   left chevron, less-than
1164     'gt'        =>      '>',    #   right chevron, greater-than
1165     'quot'      =>      '"',    #   double quote
1166
1167     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
1168     "aacute"    =>      "a\\*'",        #   small a, acute accent
1169     "Acirc"     =>      "A\\*^",        #   capital A, circumflex accent
1170     "acirc"     =>      "a\\*^",        #   small a, circumflex accent
1171     "AElig"     =>      '\*(AE',        #   capital AE diphthong (ligature)
1172     "aelig"     =>      '\*(ae',        #   small ae diphthong (ligature)
1173     "Agrave"    =>      "A\\*`",        #   capital A, grave accent
1174     "agrave"    =>      "A\\*`",        #   small a, grave accent
1175     "Aring"     =>      'A\\*o',        #   capital A, ring
1176     "aring"     =>      'a\\*o',        #   small a, ring
1177     "Atilde"    =>      'A\\*~',        #   capital A, tilde
1178     "atilde"    =>      'a\\*~',        #   small a, tilde
1179     "Auml"      =>      'A\\*:',        #   capital A, dieresis or umlaut mark
1180     "auml"      =>      'a\\*:',        #   small a, dieresis or umlaut mark
1181     "Ccedil"    =>      'C\\*,',        #   capital C, cedilla
1182     "ccedil"    =>      'c\\*,',        #   small c, cedilla
1183     "Eacute"    =>      "E\\*'",        #   capital E, acute accent
1184     "eacute"    =>      "e\\*'",        #   small e, acute accent
1185     "Ecirc"     =>      "E\\*^",        #   capital E, circumflex accent
1186     "ecirc"     =>      "e\\*^",        #   small e, circumflex accent
1187     "Egrave"    =>      "E\\*`",        #   capital E, grave accent
1188     "egrave"    =>      "e\\*`",        #   small e, grave accent
1189     "ETH"       =>      '\\*(D-',       #   capital Eth, Icelandic
1190     "eth"       =>      '\\*(d-',       #   small eth, Icelandic
1191     "Euml"      =>      "E\\*:",        #   capital E, dieresis or umlaut mark
1192     "euml"      =>      "e\\*:",        #   small e, dieresis or umlaut mark
1193     "Iacute"    =>      "I\\*'",        #   capital I, acute accent
1194     "iacute"    =>      "i\\*'",        #   small i, acute accent
1195     "Icirc"     =>      "I\\*^",        #   capital I, circumflex accent
1196     "icirc"     =>      "i\\*^",        #   small i, circumflex accent
1197     "Igrave"    =>      "I\\*`",        #   capital I, grave accent
1198     "igrave"    =>      "i\\*`",        #   small i, grave accent
1199     "Iuml"      =>      "I\\*:",        #   capital I, dieresis or umlaut mark
1200     "iuml"      =>      "i\\*:",        #   small i, dieresis or umlaut mark
1201     "Ntilde"    =>      'N\*~',         #   capital N, tilde
1202     "ntilde"    =>      'n\*~',         #   small n, tilde
1203     "Oacute"    =>      "O\\*'",        #   capital O, acute accent
1204     "oacute"    =>      "o\\*'",        #   small o, acute accent
1205     "Ocirc"     =>      "O\\*^",        #   capital O, circumflex accent
1206     "ocirc"     =>      "o\\*^",        #   small o, circumflex accent
1207     "Ograve"    =>      "O\\*`",        #   capital O, grave accent
1208     "ograve"    =>      "o\\*`",        #   small o, grave accent
1209     "Oslash"    =>      "O\\*/",        #   capital O, slash
1210     "oslash"    =>      "o\\*/",        #   small o, slash
1211     "Otilde"    =>      "O\\*~",        #   capital O, tilde
1212     "otilde"    =>      "o\\*~",        #   small o, tilde
1213     "Ouml"      =>      "O\\*:",        #   capital O, dieresis or umlaut mark
1214     "ouml"      =>      "o\\*:",        #   small o, dieresis or umlaut mark
1215     "szlig"     =>      '\*8',          #   small sharp s, German (sz ligature)
1216     "THORN"     =>      '\\*(Th',       #   capital THORN, Icelandic
1217     "thorn"     =>      '\\*(th',,      #   small thorn, Icelandic
1218     "Uacute"    =>      "U\\*'",        #   capital U, acute accent
1219     "uacute"    =>      "u\\*'",        #   small u, acute accent
1220     "Ucirc"     =>      "U\\*^",        #   capital U, circumflex accent
1221     "ucirc"     =>      "u\\*^",        #   small u, circumflex accent
1222     "Ugrave"    =>      "U\\*`",        #   capital U, grave accent
1223     "ugrave"    =>      "u\\*`",        #   small u, grave accent
1224     "Uuml"      =>      "U\\*:",        #   capital U, dieresis or umlaut mark
1225     "uuml"      =>      "u\\*:",        #   small u, dieresis or umlaut mark
1226     "Yacute"    =>      "Y\\*'",        #   capital Y, acute accent
1227     "yacute"    =>      "y\\*'",        #   small y, acute accent
1228     "yuml"      =>      "y\\*:",        #   small y, dieresis or umlaut mark
1229 );
1230 }
1231
1232 !NO!SUBS!
1233
1234 close OUT or die "Can't close $file: $!";
1235 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1236 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1237 chdir $origdir;