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   ($version,$patch) =
 322     `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/;
 323 }
 324 # No luck; we'll just go with the running Perl's version
 325 ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version;
 326 $DEF_RELEASE  = "perl $version";
 327 $DEF_RELEASE .= ", patch $patch" if $patch;
 328
 329
 330 sub makedate {
 331     my $secs = shift;
 332     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs);
 333     my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon];
 334     return "$mday/$mname/$year";
 335 }
 336
 337 use Getopt::Long;
 338
 339 $DEF_SECTION = 1;
 340 $DEF_CENTER = "User Contributed Perl Documentation";
 341 $STD_CENTER = "Perl Programmers Reference Guide";
 342 $DEF_FIXED = 'CW';
 343 $DEF_LAX = 0;
 344
 345 sub usage {
 346     warn "$0: @_\n" if @_;
 347     die <<EOF;
 348 usage: $0 [options] podpage
 349 Options are:
 350         --section=manext      (default "$DEF_SECTION")
 351         --release=relpatch    (default "$DEF_RELEASE")
 352         --center=string       (default "$DEF_CENTER")
 353         --date=string         (default "$DEF_DATE")
 354         --fixed=font          (default "$DEF_FIXED")
 355         --official            (default NOT)
 356         --lax                 (default NOT)
 357 EOF
 358 }
 359
 360 $uok = GetOptions( qw(
 361         section=s
 362         release=s
 363         center=s
 364         date=s
 365         fixed=s
 366         official
 367         lax
 368         help));
 369
 370 $DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
 371
 372 usage("Usage error!") unless $uok;
 373 usage() if $opt_help;
 374 usage("Need one and only one podpage argument") unless @ARGV == 1;
 375
 376 $section = $opt_section || ($ARGV[0] =~ /\.pm$/
 377                                 ? $DEF_PM_SECTION : $DEF_SECTION);
 378 $RP = $opt_release || $DEF_RELEASE;
 379 $center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
 380 $lax = $opt_lax || $DEF_LAX;
 381
 382 $CFont = $opt_fixed || $DEF_FIXED;
 383
 384 if (length($CFont) == 2) {
 385     $CFont_embed = "\\f($CFont";
 386 }
 387 elsif (length($CFont) == 1) {
 388     $CFont_embed = "\\f$CFont";
 389 }
 390 else {
 391     die "roff font should be 1 or 2 chars, not `$CFont_embed'";
 392 }
 393
 394 $date = $opt_date || $DEF_DATE;
 395
 396 for (qw{NAME DESCRIPTION}) {
 397 # for (qw{NAME DESCRIPTION AUTHOR}) {
 398     $wanna_see{$_}++;
 399 }
 400 $wanna_see{SYNOPSIS}++ if $section =~ /^3/;
 401
 402
 403 $name = @ARGV ? $ARGV[0] : "<STDIN>";
 404 $Filename = $name;
 405 if ($section =~ /^1/) {
 406     require File::Basename;
 407     $name = uc File::Basename::basename($name);
 408 }
 409 $name =~ s/\.(pod|p[lm])$//i;
 410
 411 # Lose everything up to the first of
 412 #     */lib/*perl*      standard or site_perl module
 413 #     */*perl*/lib      from -D prefix=/opt/perl
 414 #     */*perl*/         random module hierarchy
 415 # which works.
 416 $name =~ s-//+-/-g;
 417 if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i
 418         or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i
 419         or $name =~ s-^.*?/[^/]*perl[^/]*/--i) {
 420     # Lose ^arch/version/.
 421     $name =~ s-^[^/]+/\d+\.\d+/--;
 422 }
 423
 424 # Translate Getopt/Long to Getopt::Long, etc.
 425 $name =~ s(/)(::)g;
 426
 427 if ($name ne 'something') {
 428     FCHECK: {
 429         open(F, "< $ARGV[0]") || die "can't open $ARGV[0]: $!";
 430         while (<F>) {
 431             next unless /^=\b/;
 432             if (/^=head1\s+NAME\s*$/) {  # an /m would forgive mistakes
 433                 $_ = <F>;
 434                 unless (/\s*-+\s+/) {
 435                     $oops++;
 436                     warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n"
 437                 } else {
 438                     my @n = split /\s+-+\s+/;
 439                     if (@n != 2) {
 440                         $oops++;
 441                         warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n"
 442                     }
 443                     else {
 444                         %namedesc = @n;
 445                     }
 446                 }
 447                 last FCHECK;
 448             }
 449             next if /^=cut\b/;  # DB_File and Net::Ping have =cut before NAME
 450             next if /^=pod\b/;  # It is OK to have =pod before NAME
 451             die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
 452         }
 453         die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
 454     }
 455     close F;
 456 }
 457
 458 print <<"END";
 459 .rn '' }`
 460 ''' \$RCSfile\$\$Revision\$\$Date\$
 461 '''
 462 ''' \$Log\$
 463 '''
 464 .de Sh
 465 .br
 466 .if t .Sp
 467 .ne 5
 468 .PP
 469 \\fB\\\\\$1\\fR
 470 .PP
 471 ..
 472 .de Sp
 473 .if t .sp .5v
 474 .if n .sp
 475 ..
 476 .de Ip
 477 .br
 478 .ie \\\\n(.\$>=3 .ne \\\\\$3
 479 .el .ne 3
 480 .IP "\\\\\$1" \\\\\$2
 481 ..
 482 .de Vb
 483 .ft $CFont
 484 .nf
 485 .ne \\\\\$1
 486 ..
 487 .de Ve
 488 .ft R
 489
 490 .fi
 491 ..
 492 '''
 493 '''
 494 '''     Set up \\*(-- to give an unbreakable dash;
 495 '''     string Tr holds user defined translation string.
 496 '''     Bell System Logo is used as a dummy character.
 497 '''
 498 .tr \\(*W-|\\(bv\\*(Tr
 499 .ie n \\{\\
 500 .ds -- \\(*W-
 501 .ds PI pi
 502 .if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch
 503 .if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch
 504 .ds L" ""
 505 .ds R" ""
 506 '''   \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of
 507 '''   \\*(L" and \\*(R", except that they are used on ".xx" lines,
 508 '''   such as .IP and .SH, which do another additional levels of
 509 '''   double-quote interpretation
 510 .ds M" """
 511 .ds S" """
 512 .ds N" """""
 513 .ds T" """""
 514 .ds L' '
 515 .ds R' '
 516 .ds M' '
 517 .ds S' '
 518 .ds N' '
 519 .ds T' '
 520 'br\\}
 521 .el\\{\\
 522 .ds -- \\(em\\|
 523 .tr \\*(Tr
 524 .ds L" ``
 525 .ds R" ''
 526 .ds M" ``
 527 .ds S" ''
 528 .ds N" ``
 529 .ds T" ''
 530 .ds L' `
 531 .ds R' '
 532 .ds M' `
 533 .ds S' '
 534 .ds N' `
 535 .ds T' '
 536 .ds PI \\(*p
 537 'br\\}
 538 END
 539
 540 print <<'END';
 541 .\"     If the F register is turned on, we'll generate
 542 .\"     index entries out stderr for the following things:
 543 .\"             TH      Title
 544 .\"             SH      Header
 545 .\"             Sh      Subsection
 546 .\"             Ip      Item
 547 .\"             X<>     Xref  (embedded
 548 .\"     Of course, you have to process the output yourself
 549 .\"     in some meaninful fashion.
 550 .if \nF \{
 551 .de IX
 552 .tm Index:\\$1\t\\n%\t"\\$2"
 553 ..
 554 .nr % 0
 555 .rr F
 556 .\}
 557 END
 558
 559 print <<"END";
 560 .TH $name $section "$RP" "$date" "$center"
 561 .UC
 562 END
 563
 564 push(@Indices, qq{.IX Title "$name $section"});
 565
 566 while (($name, $desc) = each %namedesc) {
 567     for ($name, $desc) { s/^\s+//; s/\s+$//; }
 568     push(@Indices, qq(.IX Name "$name - $desc"\n));
 569 }
 570
 571 print <<'END';
 572 .if n .hy 0
 573 .if n .na
 574 .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
 575 .de CQ          \" put $1 in typewriter font
 576 END
 577 print ".ft $CFont\n";
 578 print <<'END';
 579 'if n "\c
 580 'if t \\&\\$1\c
 581 'if n \\&\\$1\c
 582 'if n \&"
 583 \\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7
 584 '.ft R
 585 ..
 586 .\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2
 587 .       \" AM - accent mark definitions
 588 .bd B 3
 589 .       \" fudge factors for nroff and troff
 590 .if n \{\
 591 .       ds #H 0
 592 .       ds #V .8m
 593 .       ds #F .3m
 594 .       ds #[ \f1
 595 .       ds #] \fP
 596 .\}
 597 .if t \{\
 598 .       ds #H ((1u-(\\\\n(.fu%2u))*.13m)
 599 .       ds #V .6m
 600 .       ds #F 0
 601 .       ds #[ \&
 602 .       ds #] \&
 603 .\}
 604 .       \" simple accents for nroff and troff
 605 .if n \{\
 606 .       ds ' \&
 607 .       ds ` \&
 608 .       ds ^ \&
 609 .       ds , \&
 610 .       ds ~ ~
 611 .       ds ? ?
 612 .       ds ! !
 613 .       ds /
 614 .       ds q
 615 .\}
 616 .if t \{\
 617 .       ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
 618 .       ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
 619 .       ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
 620 .       ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
 621 .       ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
 622 .       ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10'
 623 .       ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m'
 624 .       ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
 625 .       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'
 626 .\}
 627 .       \" troff and (daisy-wheel) nroff accents
 628 .ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
 629 .ds 8 \h'\*(#H'\(*b\h'-\*(#H'
 630 .ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#]
 631 .ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u'
 632 .ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u'
 633 .ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#]
 634 .ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
 635 .ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
 636 .ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
 637 .ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
 638 .ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
 639 .ds ae a\h'-(\w'a'u*4/10)'e
 640 .ds Ae A\h'-(\w'A'u*4/10)'E
 641 .ds oe o\h'-(\w'o'u*4/10)'e
 642 .ds Oe O\h'-(\w'O'u*4/10)'E
 643 .       \" corrections for vroff
 644 .if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
 645 .if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
 646 .       \" for low resolution devices (crt and lpr)
 647 .if \n(.H>23 .if \n(.V>19 \
 648 \{\
 649 .       ds : e
 650 .       ds 8 ss
 651 .       ds v \h'-1'\o'\(aa\(ga'
 652 .       ds _ \h'-1'^
 653 .       ds . \h'-1'.
 654 .       ds 3 3
 655 .       ds o a
 656 .       ds d- d\h'-1'\(ga
 657 .       ds D- D\h'-1'\(hy
 658 .       ds th \o'bp'
 659 .       ds Th \o'LP'
 660 .       ds ae ae
 661 .       ds Ae AE
 662 .       ds oe oe
 663 .       ds Oe OE
 664 .\}
 665 .rm #[ #] #H #V #F C
 666 END
 667
 668 $indent = 0;
 669
 670 $begun = "";
 671
 672 while (<>) {
 673     if ($cutting) {
 674         next unless /^=/;
 675         $cutting = 0;
 676     }
 677     if ($begun) {
 678         if (/^=end\s+$begun/) {
 679             $begun = "";
 680         }
 681         elsif ($begun =~ /^(roff|man)$/) {
 682             print STDOUT $_;
 683         }
 684         next;
 685     }
 686     chomp;
 687
 688     # Translate verbatim paragraph
 689
 690     if (/^\s/) {
 691         @lines = split(/\n/);
 692         for (@lines) {
 693             1 while s
 694                 {^( [^\t]* ) \t ( \t* ) }
 695                 { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex;
 696             s/\\/\\e/g;
 697             s/\A/\\&/s;
 698         }
 699         $lines = @lines;
 700         makespace() unless $verbatim++;
 701         print ".Vb $lines\n";
 702         print join("\n", @lines), "\n";
 703         print ".Ve\n";
 704         $needspace = 0;
 705         next;
 706     }
 707
 708     $verbatim = 0;
 709
 710     if (/^=for\s+(\S+)\s*/s) {
 711         if ($1 eq "man" or $1 eq "roff") {
 712             print STDOUT $',"\n\n";
 713         } else {
 714             # ignore unknown for
 715         }
 716         next;
 717     }
 718     elsif (/^=begin\s+(\S+)\s*/s) {
 719         $begun = $1;
 720         if ($1 eq "man" or $1 eq "roff") {
 721             print STDOUT $'."\n\n";
 722         }
 723         next;
 724     }
 725
 726     # check for things that'll hosed our noremap scheme; affects $_
 727     init_noremap();
 728
 729     if (!/^=item/) {
 730
 731         # trofficate backslashes; must do it before what happens below
 732         s/\\/noremap('\\e')/ge;
 733
 734         # protect leading periods and quotes against *roff
 735         # mistaking them for directives
 736         s/^(?:[A-Z]<)?[.']/\\&$&/gm;
 737
 738         # first hide the escapes in case we need to
 739         # intuit something and get it wrong due to fmting
 740
 741         1 while s/([A-Z]<[^<>]*>)/noremap($1)/ge;
 742
 743         # func() is a reference to a perl function
 744         s{
 745             \b
 746             (
 747                 [:\w]+ \(\)
 748             )
 749         } {I<$1>}gx;
 750
 751         # func(n) is a reference to a perl function or a man page
 752         s{
 753             ([:\w]+)
 754             (
 755                 \( [^\051]+ \)
 756             )
 757         } {I<$1>\\|$2}gx;
 758
 759         # convert simple variable references
 760         s/(\s+)([\$\@%][\w:]+)(?!\()/${1}C<$2>/g;
 761
 762         if (m{ (
 763                     [\-\w]+
 764                     \(
 765                         [^\051]*?
 766                         [\@\$,]
 767                         [^\051]*?
 768                     \)
 769                 )
 770             }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
 771         {
 772             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [LCI]<$1>\n";
 773             $oops++;
 774         }
 775
 776         while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
 777             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [CB]<$1>\n";
 778             $oops++;
 779         }
 780
 781         # put it back so we get the <> processed again;
 782         clear_noremap(0); # 0 means leave the E's
 783
 784     } else {
 785         # trofficate backslashes
 786         s/\\/noremap('\\e')/ge;
 787
 788     }
 789
 790     # need to hide E<> first; they're processed in clear_noremap
 791     s/(E<[^<>]+>)/noremap($1)/ge;
 792
 793
 794     $maxnest = 10;
 795     while ($maxnest-- && /[A-Z]</) {
 796
 797         # can't do C font here
 798         s/([BI])<([^<>]*)>/font($1) . $2 . font('R')/eg;
 799
 800         # files and filelike refs in italics
 801         s/F<([^<>]*)>/I<$1>/g;
 802
 803         # no break -- usually we want C<> for this
 804         s/S<([^<>]*)>/nobreak($1)/eg;
 805
 806         # LREF: a la HREF L<show this text|man/section>
 807         s:L<([^|>]+)\|[^>]+>:$1:g;
 808
 809         # LREF: a manpage(3f)
 810         s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g;
 811
 812         # LREF: an =item on another manpage
 813         s{
 814             L<
 815                 ([^/]+)
 816                 /
 817                 (
 818                     [:\w]+
 819                     (\(\))?
 820                 )
 821             >
 822         } {the C<$2> entry in the I<$1> manpage}gx;
 823
 824         # LREF: an =item on this manpage
 825         s{
 826            ((?:
 827             L<
 828                 /
 829                 (
 830                     [:\w]+
 831                     (\(\))?
 832                 )
 833             >
 834             (,?\s+(and\s+)?)?
 835           )+)
 836         } { internal_lrefs($1) }gex;
 837
 838         # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
 839         # the "func" can disambiguate
 840         s{
 841             L<
 842                 (?:
 843                     ([a-zA-Z]\S+?) /
 844                 )?
 845                 "?(.*?)"?
 846             >
 847         }{
 848             do {
 849                 $1      # if no $1, assume it means on this page.
 850                     ?  "the section on I<$2> in the I<$1> manpage"
 851                     :  "the section on I<$2>"
 852             }
 853         }gesx; # s in case it goes over multiple lines, so . matches \n
 854
 855         s/Z<>/\\&/g;
 856
 857         # comes last because not subject to reprocessing
 858         s/C<([^<>]*)>/noremap("${CFont_embed}${1}\\fR")/eg;
 859     }
 860
 861     if (s/^=//) {
 862         $needspace = 0;         # Assume this.
 863
 864         s/\n/ /g;
 865
 866         ($Cmd, $_) = split(' ', $_, 2);
 867
 868         $dotlevel = 1;
 869         if ($Cmd eq 'head1') {
 870            $dotlevel = 1;
 871         }
 872         elsif ($Cmd eq 'head2') {
 873            $dotlevel = 1;
 874         }
 875         elsif ($Cmd eq 'item') {
 876            $dotlevel = 2;
 877         }
 878
 879         if (defined $_) {
 880             &escapes($dotlevel);
 881             s/"/""/g;
 882         }
 883
 884         clear_noremap(1);
 885
 886         if ($Cmd eq 'cut') {
 887             $cutting = 1;
 888         }
 889         elsif ($Cmd eq 'head1') {
 890             s/\s+$//;
 891             delete $wanna_see{$_} if exists $wanna_see{$_};
 892             print qq{.SH "$_"\n};
 893       push(@Indices, qq{.IX Header "$_"\n});
 894         }
 895         elsif ($Cmd eq 'head2') {
 896             print qq{.Sh "$_"\n};
 897       push(@Indices, qq{.IX Subsection "$_"\n});
 898         }
 899         elsif ($Cmd eq 'over') {
 900             push(@indent,$indent);
 901             $indent += ($_ + 0) || 5;
 902         }
 903         elsif ($Cmd eq 'back') {
 904             $indent = pop(@indent);
 905             warn "$0: Unmatched =back in paragraph $. of $ARGV\n" unless defined $indent;
 906             $needspace = 1;
 907         }
 908         elsif ($Cmd eq 'item') {
 909             s/^\*( |$)/\\(bu$1/g;
 910             # if you know how to get ":s please do
 911             s/\\\*\(L"([^"]+?)\\\*\(R"/'$1'/g;
 912             s/\\\*\(L"([^"]+?)""/'$1'/g;
 913             s/[^"]""([^"]+?)""[^"]/'$1'/g;
 914             # here do something about the $" in perlvar?
 915             print STDOUT qq{.Ip "$_" $indent\n};
 916       push(@Indices, qq{.IX Item "$_"\n});
 917         }
 918         elsif ($Cmd eq 'pod') {
 919             # this is just a comment
 920         }
 921         else {
 922             warn "$0: Unrecognized pod directive in paragraph $. of $ARGV: $Cmd\n";
 923         }
 924     }
 925     else {
 926         if ($needspace) {
 927             &makespace;
 928         }
 929         &escapes(0);
 930         clear_noremap(1);
 931         print $_, "\n";
 932         $needspace = 1;
 933     }
 934 }
 935
 936 print <<"END";
 937
 938 .rn }` ''
 939 END
 940
 941 if (%wanna_see && !$lax) {
 942     @missing = keys %wanna_see;
 943     warn "$0: $Filename is missing required section"
 944         .  (@missing > 1 && "s")
 945         .  ": @missing\n";
 946     $oops++;
 947 }
 948
 949 foreach (@Indices) { print "$_\n"; }
 950
 951 exit;
 952 #exit ($oops != 0);
 953
 954 #########################################################################
 955
 956 sub nobreak {
 957     my $string = shift;
 958     $string =~ s/ /\\ /g;
 959     $string;
 960 }
 961
 962 sub escapes {
 963     my $indot = shift;
 964
 965     s/X<(.*?)>/mkindex($1)/ge;
 966
 967     # translate the minus in foo-bar into foo\-bar for roff
 968     s/([^0-9a-z-])-([^-])/$1\\-$2/g;
 969
 970     # make -- into the string version \*(-- (defined above)
 971     s/\b--\b/\\*(--/g;
 972     s/"--([^"])/"\\*(--$1/g;  # should be a better way
 973     s/([^"])--"/$1\\*(--"/g;
 974
 975     # fix up quotes; this is somewhat tricky
 976     my $dotmacroL = 'L';
 977     my $dotmacroR = 'R';
 978     if ( $indot == 1 ) {
 979         $dotmacroL = 'M';
 980         $dotmacroR = 'S';
 981     }
 982     elsif ( $indot >= 2 ) {
 983         $dotmacroL = 'N';
 984         $dotmacroR = 'T';
 985     }
 986     if (!/""/) {
 987         s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge;
 988         s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge;
 989     }
 990
 991     #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g;
 992     #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g;
 993
 994
 995     # make sure that func() keeps a bit a space tween the parens
 996     ### s/\b\(\)/\\|()/g;
 997     ### s/\b\(\)/(\\|)/g;
 998
 999     # make C++ into \*C+, which is a squinched version (defined above)
1000     s/\bC\+\+/\\*(C+/g;
1001
1002     # make double underbars have a little tiny space between them
1003     s/__/_\\|_/g;
1004
1005     # PI goes to \*(PI (defined above)
1006     s/\bPI\b/noremap('\\*(PI')/ge;
1007
1008     # make all caps a teeny bit smaller, but don't muck with embedded code literals
1009     my $hidCFont = font('C');
1010     if ($Cmd !~ /^head1/) { # SH already makes smaller
1011         # /g isn't enough; 1 while or we'll be off
1012
1013 #       1 while s{
1014 #           (?!$hidCFont)(..|^.|^)
1015 #           \b
1016 #           (
1017 #               [A-Z][\/A-Z+:\-\d_$.]+
1018 #           )
1019 #           (s?)
1020 #           \b
1021 #       } {$1\\s-1$2\\s0}gmox;
1022
1023         1 while s{
1024             (?!$hidCFont)(..|^.|^)
1025             (
1026                 \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b
1027             )
1028         } {
1029             $1 . noremap( '\\s-1' .  $2 . '\\s0' )
1030         }egmox;
1031
1032     }
1033 }
1034
1035 # make troff just be normal, but make small nroff get quoted
1036 # decided to just put the quotes in the text; sigh;
1037 sub ccvt {
1038     local($_,$prev) = @_;
1039     noremap(qq{.CQ "$_" \n\\&});
1040 }
1041
1042 sub makespace {
1043     if ($indent) {
1044         print ".Sp\n";
1045     }
1046     else {
1047         print ".PP\n";
1048     }
1049 }
1050
1051 sub mkindex {
1052     my ($entry) = @_;
1053     my @entries = split m:\s*/\s*:, $entry;
1054     push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries;
1055     return '';
1056 }
1057
1058 sub font {
1059     local($font) = shift;
1060     return '\\f' . noremap($font);
1061 }
1062
1063 sub noremap {
1064     local($thing_to_hide) = shift;
1065     $thing_to_hide =~ tr/\000-\177/\200-\377/;
1066     return $thing_to_hide;
1067 }
1068
1069 sub init_noremap {
1070         # escape high bit characters in input stream
1071         s/([\200-\377])/"E<".ord($1).">"/ge;
1072 }
1073
1074 sub clear_noremap {
1075     my $ready_to_print = $_[0];
1076
1077     tr/\200-\377/\000-\177/;
1078
1079     # trofficate backslashes
1080     # s/(?!\\e)(?:..|^.|^)\\/\\e/g;
1081
1082     # now for the E<>s, which have been hidden until now
1083     # otherwise the interative \w<> processing would have
1084     # been hosed by the E<gt>
1085     s {
1086             E<
1087             (
1088                 ( \d + )
1089                 | ( [A-Za-z]+ )
1090             )
1091             >
1092     } {
1093          do {
1094              defined $2
1095                 ? chr($2)
1096                 :
1097              exists $HTML_Escapes{$3}
1098                 ? do { $HTML_Escapes{$3} }
1099                 : do {
1100                     warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
1101                     "E<$1>";
1102                 }
1103          }
1104     }egx if $ready_to_print;
1105 }
1106
1107 sub internal_lrefs {
1108     local($_) = shift;
1109     local $trailing_and = s/and\s+$// ? "and " : "";
1110
1111     s{L</([^>]+)>}{$1}g;
1112     my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
1113     my $retstr = "the ";
1114     my $i;
1115     for ($i = 0; $i <= $#items; $i++) {
1116         $retstr .= "C<$items[$i]>";
1117         $retstr .= ", " if @items > 2 && $i != $#items;
1118         $retstr .= " and " if $i+2 == @items;
1119     }
1120
1121     $retstr .= " entr" . ( @items > 1  ? "ies" : "y" )
1122             .  " elsewhere in this document "; # terminal space to avoid words running together (pattern used strips terminal spaces)
1123     $retstr .=  $trailing_and;
1124
1125     return $retstr;
1126
1127 }
1128
1129 BEGIN {
1130 %HTML_Escapes = (
1131     'amp'       =>      '&',    #   ampersand
1132     'lt'        =>      '<',    #   left chevron, less-than
1133     'gt'        =>      '>',    #   right chevron, greater-than
1134     'quot'      =>      '"',    #   double quote
1135
1136     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
1137     "aacute"    =>      "a\\*'",        #   small a, acute accent
1138     "Acirc"     =>      "A\\*^",        #   capital A, circumflex accent
1139     "acirc"     =>      "a\\*^",        #   small a, circumflex accent
1140     "AElig"     =>      '\*(AE',        #   capital AE diphthong (ligature)
1141     "aelig"     =>      '\*(ae',        #   small ae diphthong (ligature)
1142     "Agrave"    =>      "A\\*`",        #   capital A, grave accent
1143     "agrave"    =>      "A\\*`",        #   small a, grave accent
1144     "Aring"     =>      'A\\*o',        #   capital A, ring
1145     "aring"     =>      'a\\*o',        #   small a, ring
1146     "Atilde"    =>      'A\\*~',        #   capital A, tilde
1147     "atilde"    =>      'a\\*~',        #   small a, tilde
1148     "Auml"      =>      'A\\*:',        #   capital A, dieresis or umlaut mark
1149     "auml"      =>      'a\\*:',        #   small a, dieresis or umlaut mark
1150     "Ccedil"    =>      'C\\*,',        #   capital C, cedilla
1151     "ccedil"    =>      'c\\*,',        #   small c, cedilla
1152     "Eacute"    =>      "E\\*'",        #   capital E, acute accent
1153     "eacute"    =>      "e\\*'",        #   small e, acute accent
1154     "Ecirc"     =>      "E\\*^",        #   capital E, circumflex accent
1155     "ecirc"     =>      "e\\*^",        #   small e, circumflex accent
1156     "Egrave"    =>      "E\\*`",        #   capital E, grave accent
1157     "egrave"    =>      "e\\*`",        #   small e, grave accent
1158     "ETH"       =>      '\\*(D-',       #   capital Eth, Icelandic
1159     "eth"       =>      '\\*(d-',       #   small eth, Icelandic
1160     "Euml"      =>      "E\\*:",        #   capital E, dieresis or umlaut mark
1161     "euml"      =>      "e\\*:",        #   small e, dieresis or umlaut mark
1162     "Iacute"    =>      "I\\*'",        #   capital I, acute accent
1163     "iacute"    =>      "i\\*'",        #   small i, acute accent
1164     "Icirc"     =>      "I\\*^",        #   capital I, circumflex accent
1165     "icirc"     =>      "i\\*^",        #   small i, circumflex accent
1166     "Igrave"    =>      "I\\*`",        #   capital I, grave accent
1167     "igrave"    =>      "i\\*`",        #   small i, grave accent
1168     "Iuml"      =>      "I\\*:",        #   capital I, dieresis or umlaut mark
1169     "iuml"      =>      "i\\*:",        #   small i, dieresis or umlaut mark
1170     "Ntilde"    =>      'N\*~',         #   capital N, tilde
1171     "ntilde"    =>      'n\*~',         #   small n, tilde
1172     "Oacute"    =>      "O\\*'",        #   capital O, acute accent
1173     "oacute"    =>      "o\\*'",        #   small o, acute accent
1174     "Ocirc"     =>      "O\\*^",        #   capital O, circumflex accent
1175     "ocirc"     =>      "o\\*^",        #   small o, circumflex accent
1176     "Ograve"    =>      "O\\*`",        #   capital O, grave accent
1177     "ograve"    =>      "o\\*`",        #   small o, grave accent
1178     "Oslash"    =>      "O\\*/",        #   capital O, slash
1179     "oslash"    =>      "o\\*/",        #   small o, slash
1180     "Otilde"    =>      "O\\*~",        #   capital O, tilde
1181     "otilde"    =>      "o\\*~",        #   small o, tilde
1182     "Ouml"      =>      "O\\*:",        #   capital O, dieresis or umlaut mark
1183     "ouml"      =>      "o\\*:",        #   small o, dieresis or umlaut mark
1184     "szlig"     =>      '\*8',          #   small sharp s, German (sz ligature)
1185     "THORN"     =>      '\\*(Th',       #   capital THORN, Icelandic
1186     "thorn"     =>      '\\*(th',,      #   small thorn, Icelandic
1187     "Uacute"    =>      "U\\*'",        #   capital U, acute accent
1188     "uacute"    =>      "u\\*'",        #   small u, acute accent
1189     "Ucirc"     =>      "U\\*^",        #   capital U, circumflex accent
1190     "ucirc"     =>      "u\\*^",        #   small u, circumflex accent
1191     "Ugrave"    =>      "U\\*`",        #   capital U, grave accent
1192     "ugrave"    =>      "u\\*`",        #   small u, grave accent
1193     "Uuml"      =>      "U\\*:",        #   capital U, dieresis or umlaut mark
1194     "uuml"      =>      "u\\*:",        #   small u, dieresis or umlaut mark
1195     "Yacute"    =>      "Y\\*'",        #   capital Y, acute accent
1196     "yacute"    =>      "y\\*'",        #   small y, acute accent
1197     "yuml"      =>      "y\\*:",        #   small y, dieresis or umlaut mark
1198 );
1199 }
1200
1201 !NO!SUBS!
1202
1203 close OUT or die "Can't close $file: $!";
1204 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
1205 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
1206 chdir $origdir;