pod/pod2man.PL

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