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