1: : #!/usr/bin/perl-5.005
    2:     eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
    3:         if $running_under_some_shell;
    4: 
    5: $DEF_PM_SECTION = '3pm' || '3';
    6: 
    7: =head1 NAME
    8: 
    9: pod2man - translate embedded Perl pod directives into man pages
   10: 
   11: =head1 SYNOPSIS
   12: 
   13: B<pod2man>
   14: [ B<--section=>I<manext> ]
   15: [ B<--release=>I<relpatch> ]
   16: [ B<--center=>I<string> ]
   17: [ B<--date=>I<string> ]
   18: [ B<--fixed=>I<font> ]
   19: [ B<--official> ]
   20: [ B<--lax> ]
   21: I<inputfile>
   22: 
   23: =head1 DESCRIPTION
   24: 
   25: B<pod2man> converts its input file containing embedded pod directives (see
   26: L<perlpod>) into nroff source suitable for viewing with nroff(1) or
   27: troff(1) using the man(7) macro set.
   28: 
   29: Besides the obvious pod conversions, B<pod2man> also takes care of
   30: func(), func(n), and simple variable references like $foo or @bar so
   31: you don't have to use code escapes for them; complex expressions like
   32: C<$fred{'stuff'}> will still need to be escaped, though.  Other nagging
   33: little roffish things that it catches include translating the minus in
   34: something like foo-bar, making a long dash--like this--into a real em
   35: dash, fixing up "paired quotes", putting a little space after the
   36: parens in something like func(), making C++ and PI look right, making
   37: double underbars have a little tiny space between them, making ALLCAPS
   38: a teeny bit smaller in troff(1), and escaping backslashes so you don't
   39: have to.
   40: 
   41: =head1 OPTIONS
   42: 
   43: =over 8
   44: 
   45: =item center
   46: 
   47: Set the centered header to a specific string.  The default is
   48: "User Contributed Perl Documentation", unless the C<--official> flag is
   49: given, in which case the default is "Perl Programmers Reference Guide".
   50: 
   51: =item date
   52: 
   53: Set the left-hand footer string to this value.  By default,
   54: the modification date of the input file will be used.
   55: 
   56: =item fixed
   57: 
   58: The fixed font to use for code refs.  Defaults to CW.
   59: 
   60: =item official
   61: 
   62: Set the default header to indicate that this page is of
   63: the standard release in case C<--center> is not given.
   64: 
   65: =item release
   66: 
   67: Set the centered footer.  By default, this is the current
   68: perl release.
   69: 
   70: =item section
   71: 
   72: Set the section for the C<.TH> macro.  The standard conventions on
   73: sections are to use 1 for user commands,  2 for system calls, 3 for
   74: functions, 4 for devices, 5 for file formats, 6 for games, 7 for
   75: miscellaneous information, and 8 for administrator commands.  This works
   76: best if you put your Perl man pages in a separate tree, like
   77: F</usr/local/perl/man/>.  By default, section 1 will be used
   78: unless the file ends in F<.pm> in which case section 3 will be selected.
   79: 
   80: =item lax
   81: 
   82: Don't complain when required sections aren't present.
   83: 
   84: =back
   85: 
   86: =head1 Anatomy of a Proper Man Page
   87: 
   88: For those not sure of the proper layout of a man page, here's
   89: an example of the skeleton of a proper man page.  Head of the
   90: major headers should be setout as a C<=head1> directive, and
   91: are historically written in the rather startling ALL UPPER CASE
   92: format, although this is not mandatory.
   93: Minor headers may be included using C<=head2>, and are
   94: typically in mixed case.
   95: 
   96: =over 10
   97: 
   98: =item NAME
   99: 
  100: Mandatory section; should be a comma-separated list of programs or
  101: functions documented by this podpage, such as:
  102: 
  103:     foo, bar - programs to do something
  104: 
  105: =item SYNOPSIS
  106: 
  107: A short usage summary for programs and functions, which
  108: may someday be deemed mandatory.
  109: 
  110: =item DESCRIPTION
  111: 
  112: Long drawn out discussion of the program.  It's a good idea to break this
  113: up into subsections using the C<=head2> directives, like
  114: 
  115:     =head2 A Sample Subection
  116: 
  117:     =head2 Yet Another Sample Subection
  118: 
  119: =item OPTIONS
  120: 
  121: Some people make this separate from the description.
  122: 
  123: =item RETURN VALUE
  124: 
  125: What the program or function returns if successful.
  126: 
  127: =item ERRORS
  128: 
  129: Exceptions, return codes, exit stati, and errno settings.
  130: 
  131: =item EXAMPLES
  132: 
  133: Give some example uses of the program.
  134: 
  135: =item ENVIRONMENT
  136: 
  137: Envariables this program might care about.
  138: 
  139: =item FILES
  140: 
  141: All files used by the program.  You should probably use the FE<lt>E<gt>
  142: for these.
  143: 
  144: =item SEE ALSO
  145: 
  146: Other man pages to check out, like man(1), man(7), makewhatis(8), or catman(8).
  147: 
  148: =item NOTES
  149: 
  150: Miscellaneous commentary.
  151: 
  152: =item CAVEATS
  153: 
  154: Things to take special care with; sometimes called WARNINGS.
  155: 
  156: =item DIAGNOSTICS
  157: 
  158: All possible messages the program can print out--and
  159: what they mean.
  160: 
  161: =item BUGS
  162: 
  163: Things that are broken or just don't work quite right.
  164: 
  165: =item RESTRICTIONS
  166: 
  167: Bugs you don't plan to fix :-)
  168: 
  169: =item AUTHOR
  170: 
  171: Who wrote it (or AUTHORS if multiple).
  172: 
  173: =item HISTORY
  174: 
  175: Programs derived from other sources sometimes have this, or
  176: you might keep a modification log here.
  177: 
  178: =back
  179: 
  180: =head1 EXAMPLES
  181: 
  182:     pod2man program > program.1
  183:     pod2man some_module.pm > /usr/perl/man/man3/some_module.3
  184:     pod2man --section=7 note.pod > note.7
  185: 
  186: =head1 DIAGNOSTICS
  187: 
  188: The following diagnostics are generated by B<pod2man>.  Items
  189: marked "(W)" are non-fatal, whereas the "(F)" errors will cause
  190: B<pod2man> to immediately exit with a non-zero status.
  191: 
  192: =over 4
  193: 
  194: =item bad option in paragraph %d of %s: ``%s'' should be [%s]<%s>
  195: 
  196: (W) If you start include an option, you should set it off
  197: as bold, italic, or code.
  198: 
  199: =item can't open %s: %s
  200: 
  201: (F) The input file wasn't available for the given reason.
  202: 
  203: =item Improper man page - no dash in NAME header in paragraph %d of %s
  204: 
  205: (W) The NAME header did not have an isolated dash in it.  This is
  206: considered important.
  207: 
  208: =item Invalid man page - no NAME line in %s
  209: 
  210: (F) You did not include a NAME header, which is essential.
  211: 
  212: =item roff font should be 1 or 2 chars, not `%s'  (F)
  213: 
  214: (F) The font specified with the C<--fixed> option was not
  215: a one- or two-digit roff font.
  216: 
  217: =item %s is missing required section: %s
  218: 
  219: (W) Required sections include NAME, DESCRIPTION, and if you're
  220: using a section starting with a 3, also a SYNOPSIS.  Actually,
  221: not having a NAME is a fatal.
  222: 
  223: =item Unknown escape: %s in %s
  224: 
  225: (W) An unknown HTML entity (probably for an 8-bit character) was given via
  226: a C<EE<lt>E<gt>> directive.  Besides amp, lt, gt, and quot, recognized
  227: entities are Aacute, aacute, Acirc, acirc, AElig, aelig, Agrave, agrave,
  228: Aring, aring, Atilde, atilde, Auml, auml, Ccedil, ccedil, Eacute, eacute,
  229: Ecirc, ecirc, Egrave, egrave, ETH, eth, Euml, euml, Iacute, iacute, Icirc,
  230: icirc, Igrave, igrave, Iuml, iuml, Ntilde, ntilde, Oacute, oacute, Ocirc,
  231: ocirc, Ograve, ograve, Oslash, oslash, Otilde, otilde, Ouml, ouml, szlig,
  232: THORN, thorn, Uacute, uacute, Ucirc, ucirc, Ugrave, ugrave, Uuml, uuml,
  233: Yacute, yacute, and yuml.
  234: 
  235: =item Unmatched =back
  236: 
  237: (W) You have a C<=back> without a corresponding C<=over>.
  238: 
  239: =item Unrecognized pod directive: %s
  240: 
  241: (W) You specified a pod directive that isn't in the known list of
  242: C<=head1>, C<=head2>, C<=item>, C<=over>, C<=back>, or C<=cut>.
  243: 
  244: 
  245: =back
  246: 
  247: =head1 NOTES
  248: 
  249: If you would like to print out a lot of man page continuously, you
  250: probably want to set the C and D registers to set contiguous page
  251: numbering and even/odd paging, at least on some versions of man(7).
  252: Settting the F register will get you some additional experimental
  253: indexing:
  254: 
  255:     troff -man -rC1 -rD1 -rF1 perl.1 perldata.1 perlsyn.1 ...
  256: 
  257: The indexing merely outputs messages via C<.tm> for each
  258: major page, section, subsection, item, and any C<XE<lt>E<gt>>
  259: directives.
  260: 
  261: 
  262: =head1 RESTRICTIONS
  263: 
  264: None at this time.
  265: 
  266: =head1 BUGS
  267: 
  268: The =over and =back directives don't really work right.  They
  269: take absolute positions instead of offsets, don't nest well, and
  270: making people count is suboptimal in any event.
  271: 
  272: =head1 AUTHORS
  273: 
  274: Original prototype by Larry Wall, but so massively hacked over by
  275: Tom Christiansen such that Larry probably doesn't recognize it anymore.
  276: 
  277: =cut
  278: 
  279: $/ = "";
  280: $cutting = 1;
  281: @Indices = ();
  282: 
  283: # We try first to get the version number from a local binary, in case we're
  284: # running an installed version of Perl to produce documentation from an
  285: # uninstalled newer version's pod files.
  286: if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') {
  287:   my $perl = (-x './perl' && -f './perl' ) ?
  288:                  './perl' :
  289:                  ((-x '../perl' && -f '../perl') ?
  290:                       '../perl' :
  291:                       '');
  292:   ($version,$patch) = `$perl -e 'print $]'` =~ /^(\d\.\d{3})(\d{2})?/ if $perl;
  293: }
  294: # No luck; we'll just go with the running Perl's version
  295: ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version;
  296: $DEF_RELEASE  = "perl $version";
  297: $DEF_RELEASE .= ", patch $patch" if $patch;
  298: 
  299: 
  300: sub makedate {
  301:     my $secs = shift;
  302:     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs);
  303:     my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon];
  304:     $year += 1900;
  305:     return "$mday/$mname/$year";
  306: }
  307: 
  308: use Getopt::Long;
  309: 
  310: $DEF_SECTION = 1;
  311: $DEF_CENTER = "User Contributed Perl Documentation";
  312: $STD_CENTER = "Perl Programmers Reference Guide";
  313: $DEF_FIXED = 'CW';
  314: $DEF_LAX = 0;
  315: 
  316: sub usage {
  317:     warn "$0: @_\n" if @_;
  318:     die <<EOF;
  319: usage: $0 [options] podpage
  320: Options are:
  321:         --section=manext      (default "$DEF_SECTION")
  322:         --release=relpatch    (default "$DEF_RELEASE")
  323:         --center=string       (default "$DEF_CENTER")
  324:         --date=string         (default "$DEF_DATE")
  325:         --fixed=font         (default "$DEF_FIXED")
  326:         --official           (default NOT)
  327:         --lax                 (default NOT)
  328: EOF
  329: }
  330: 
  331: $uok = GetOptions( qw(
  332:         section=s
  333:         release=s
  334:         center=s
  335:         date=s
  336:         fixed=s
  337:         official
  338:         lax
  339:         help));
  340: 
  341: $DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
  342: 
  343: usage("Usage error!") unless $uok;
  344: usage() if $opt_help;
  345: usage("Need one and only one podpage argument") unless @ARGV == 1;
  346: 
  347: $section = $opt_section || ($ARGV[0] =~ /\.pm$/
  348:                                 ? $DEF_PM_SECTION : $DEF_SECTION);
  349: $RP = $opt_release || $DEF_RELEASE;
  350: $center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
  351: $lax = $opt_lax || $DEF_LAX;
  352: 
  353: $CFont = $opt_fixed || $DEF_FIXED;
  354: 
  355: if (length($CFont) == 2) {
  356:     $CFont_embed = "\\f($CFont";
  357: }
  358: elsif (length($CFont) == 1) {
  359:     $CFont_embed = "\\f$CFont";
  360: }
  361: else {
  362:     die "roff font should be 1 or 2 chars, not `$CFont_embed'";
  363: }
  364: 
  365: $date = $opt_date || $DEF_DATE;
  366: 
  367: for (qw{NAME DESCRIPTION}) {
  368: # for (qw{NAME DESCRIPTION AUTHOR}) {
  369:     $wanna_see{$_}++;
  370: }
  371: $wanna_see{SYNOPSIS}++ if $section =~ /^3/;
  372: 
  373: 
  374: $name = @ARGV ? $ARGV[0] : "<STDIN>";
  375: $Filename = $name;
  376: if ($section =~ /^1/) {
  377:     require File::Basename;
  378:     $name = uc File::Basename::basename($name);
  379: }
  380: $name =~ s/\.(pod|p[lm])$//i;
  381: 
  382: # Lose everything up to the first of
  383: #     */lib/*perl*      standard or site_perl module
  384: #     */*perl*/lib      from -D prefix=/opt/perl
  385: #     */*perl*/         random module hierarchy
  386: # which works.
  387: $name =~ s-//+-/-g;
  388: if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i
  389:         or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i
  390:         or $name =~ s-^.*?/[^/]*perl[^/]*/--i) {
  391:     # Lose ^site(_perl)?/.
  392:     $name =~ s-^site(_perl)?/--;
  393:     # Lose ^arch/.      (XXX should we use Config? Just for archname?)
  394:     $name =~ s~^(.*-$^O|$^O-.*)/~~o;
  395:     # Lose ^version/.
  396:     $name =~ s-^\d+\.\d+/--;
  397: }
  398: 
  399: # Translate Getopt/Long to Getopt::Long, etc.
  400: $name =~ s(/)(::)g;
  401: 
  402: if ($name ne 'something') {
  403:     FCHECK: {
  404:         open(F, "< $ARGV[0]") || die "can't open $ARGV[0]: $!";
  405:         while (<F>) {
  406:             next unless /^=\b/;
  407:             if (/^=head1\s+NAME\s*$/) {  # an /m would forgive mistakes
  408:                 $_ = <F>;
  409:                 unless (/\s*-+\s+/) {
  410:                     $oops++;
  411:                     warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n"
  412:                 } else {
  413:                     my @n = split /\s+-+\s+/;
  414:                     if (@n != 2) {
  415:                         $oops++;
  416:                         warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n"
  417:                     }
  418:                     else {
  419:                         $n[0] =~ s/\n/ /g;
  420:                         $n[1] =~ s/\n/ /g;
  421:                         %namedesc = @n;
  422:                     }
  423:                 }
  424:                 last FCHECK;
  425:             }
  426:             next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME
  427:             next if /^=pod\b/;  # It is OK to have =pod before NAME
  428:             next if /^=for\s+comment\b/;  # It is OK to have =for comment before NAME
  429:             die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
  430:         }
  431:         die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
  432:     }
  433:     close F;
  434: }
  435: 
  436: print <<"END";
  437: .rn '' }`
  438: ''' \$RCSfile\$\$Revision\$\$Date\$
  439: '''
  440: ''' \$Log\$
  441: '''
  442: .de Sh
  443: .br
  444: .if t .Sp
  445: .ne 5
  446: .PP
  447: \\fB\\\\\$1\\fR
  448: .PP
  449: ..
  450: .de Sp
  451: .if t .sp .5v
  452: .if n .sp
  453: ..
  454: .de Ip
  455: .br
  456: .ie \\\\n(.\$>=3 .ne \\\\\$3
  457: .el .ne 3
  458: .IP "\\\\\$1" \\\\\$2
  459: ..
  460: .de Vb
  461: .ft $CFont
  462: .nf
  463: .ne \\\\\$1
  464: ..
  465: .de Ve
  466: .ft R
  467: 
  468: .fi
  469: ..
  470: '''
  471: '''
  472: '''     Set up \\*(-- to give an unbreakable dash;
  473: '''     string Tr holds user defined translation string.
  474: '''     Bell System Logo is used as a dummy character.
  475: '''
  476: .tr \\(*W-|\\(bv\\*(Tr
  477: .ie n \\{\\
  478: .ds -- \\(*W-
  479: .ds PI pi
  480: .if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch
  481: .if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch
  482: .ds L" ""
  483: .ds R" ""
  484: '''   \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of
  485: '''   \\*(L" and \\*(R", except that they are used on ".xx" lines,
  486: '''   such as .IP and .SH, which do another additional levels of
  487: '''   double-quote interpretation
  488: .ds M" """
  489: .ds S" """
  490: .ds N" """""
  491: .ds T" """""
  492: .ds L' '
  493: .ds R' '
  494: .ds M' '
  495: .ds S' '
  496: .ds N' '
  497: .ds T' '
  498: 'br\\}
  499: .el\\{\\
  500: .ds -- \\(em\\|
  501: .tr \\*(Tr
  502: .ds L" ``
  503: .ds R" ''
  504: .ds M" ``
  505: .ds S" ''
  506: .ds N" ``
  507: .ds T" ''
  508: .ds L' `
  509: .ds R' '
  510: .ds M' `
  511: .ds S' '
  512: .ds N' `
  513: .ds T' '
  514: .ds PI \\(*p
  515: 'br\\}
  516: END
  517: 
  518: print <<'END';
  519: .\"     If the F register is turned on, we'll generate
  520: .\"     index entries out stderr for the following things:
  521: .\"             TH Title 
  522: .\"             SH Header
  523: .\"             Sh Subsection 
  524: .\"             Ip Item
  525: .\"             X<>        Xref  (embedded
  526: .\"     Of course, you have to process the output yourself
  527: .\"     in some meaninful fashion.
  528: .if \nF \{
  529: .de IX
  530: .tm Index:\\$1\t\\n%\t"\\$2"
  531: ..
  532: .nr % 0
  533: .rr F
  534: .\}
  535: END
  536: 
  537: print <<"END";
  538: .TH $name $section "$RP" "$date" "$center"
  539: .UC
  540: END
  541: 
  542: push(@Indices, qq{.IX Title "$name $section"});
  543: 
  544: while (($name, $desc) = each %namedesc) {
  545:     for ($name, $desc) { s/^\s+//; s/\s+$//; }
  546:     push(@Indices, qq(.IX Name "$name - $desc"\n));
  547: }
  548: 
  549: print <<'END';
  550: .if n .hy 0
  551: .if n .na
  552: .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
  553: .de CQ          \" put $1 in typewriter font
  554: END
  555: print ".ft $CFont\n";
  556: print <<'END';
  557: 'if n "\c
  558: 'if t \\&\\$1\c
  559: 'if n \\&\\$1\c
  560: 'if n \&"
  561: \\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7
  562: '.ft R
  563: ..
  564: .\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2
  565: .       \" AM - accent mark definitions
  566: .bd B 3
  567: .       \" fudge factors for nroff and troff
  568: .if n \{\
  569: .       ds #H 0
  570: .       ds #V .8m
  571: .       ds #F .3m
  572: .       ds #[ \f1
  573: .       ds #] \fP
  574: .\}
  575: .if t \{\
  576: .       ds #H ((1u-(\\\\n(.fu%2u))*.13m)
  577: .       ds #V .6m
  578: .       ds #F 0
  579: .       ds #[ \&
  580: .       ds #] \&
  581: .\}
  582: .       \" simple accents for nroff and troff
  583: .if n \{\
  584: .       ds ' \&
  585: .       ds ` \&
  586: .       ds ^ \&
  587: .       ds , \&
  588: .       ds ~ ~
  589: .       ds ? ?
  590: .       ds ! !
  591: .       ds /
  592: .       ds q
  593: .\}
  594: .if t \{\
  595: .       ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
  596: .       ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
  597: .       ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
  598: .       ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
  599: .       ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
  600: .       ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10'
  601: .       ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m'
  602: .       ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
  603: .       ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10'
  604: .\}
  605: .       \" troff and (daisy-wheel) nroff accents
  606: .ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
  607: .ds 8 \h'\*(#H'\(*b\h'-\*(#H'
  608: .ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#]
  609: .ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u'
  610: .ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u'
  611: .ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#]
  612: .ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
  613: .ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
  614: .ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
  615: .ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
  616: .ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
  617: .ds ae a\h'-(\w'a'u*4/10)'e
  618: .ds Ae A\h'-(\w'A'u*4/10)'E
  619: .ds oe o\h'-(\w'o'u*4/10)'e
  620: .ds Oe O\h'-(\w'O'u*4/10)'E
  621: .       \" corrections for vroff
  622: .if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
  623: .if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
  624: .       \" for low resolution devices (crt and lpr)
  625: .if \n(.H>23 .if \n(.V>19 \
  626: \{\
  627: .       ds : e
  628: .       ds 8 ss
  629: .       ds v \h'-1'\o'\(aa\(ga'
  630: .       ds _ \h'-1'^
  631: .       ds . \h'-1'.
  632: .       ds 3 3
  633: .       ds o a
  634: .       ds d- d\h'-1'\(ga
  635: .       ds D- D\h'-1'\(hy
  636: .       ds th \o'bp'
  637: .       ds Th \o'LP'
  638: .       ds ae ae
  639: .       ds Ae AE
  640: .       ds oe oe
  641: .       ds Oe OE
  642: .\}
  643: .rm #[ #] #H #V #F C
  644: END
  645: 
  646: $indent = 0;
  647: 
  648: $begun = "";
  649: 
  650: # Unrolling [^A-Z>]|[A-Z](?!<) gives:    // MRE pp 165.
  651: my $nonest = '(?:[^A-Z>]*(?:[A-Z](?!<)[^A-Z>]*)*)';
  652: 
  653: while (<>) {
  654:     if ($cutting) {
  655:         next unless /^=/;
  656:         $cutting = 0;
  657:     }
  658:     if ($begun) {
  659:         if (/^=end\s+$begun/) {
  660:             $begun = "";
  661:         }
  662:         elsif ($begun =~ /^(roff|man)$/) {
  663:             print STDOUT $_;
  664:         }
  665:         next;
  666:     }
  667:     chomp;
  668: 
  669:     # Translate verbatim paragraph
  670: 
  671:     if (/^\s/) {
  672:         @lines = split(/\n/);
  673:         for (@lines) {
  674:             1 while s
  675:                 {^( [^\t]* ) \t ( \t* ) }
  676:                 { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex;
  677:             s/\\/\\e/g;
  678:             s/\A/\\&/s;
  679:         }
  680:         $lines = @lines;
  681:         makespace() unless $verbatim++;
  682:         print ".Vb $lines\n";
  683:         print join("\n", @lines), "\n";
  684:         print ".Ve\n";
  685:         $needspace = 0;
  686:         next;
  687:     }
  688: 
  689:     $verbatim = 0;
  690: 
  691:     if (/^=for\s+(\S+)\s*/s) {
  692:         if ($1 eq "man" or $1 eq "roff") {
  693:             print STDOUT $',"\n\n";
  694:         } else {
  695:             # ignore unknown for
  696:         }
  697:         next;
  698:     }
  699:     elsif (/^=begin\s+(\S+)\s*/s) {
  700:         $begun = $1;
  701:         if ($1 eq "man" or $1 eq "roff") {
  702:             print STDOUT $'."\n\n";
  703:         }
  704:         next;
  705:     }
  706: 
  707:     # check for things that'll hosed our noremap scheme; affects $_
  708:     init_noremap();
  709: 
  710:     if (!/^=item/) {
  711: 
  712:         # trofficate backslashes; must do it before what happens below
  713:         s/\\/noremap('\\e')/ge;
  714: 
  715:         # protect leading periods and quotes against *roff
  716:         # mistaking them for directives
  717:         s/^(?:[A-Z]<)?[.']/\\&$&/gm;
  718: 
  719:         # first hide the escapes in case we need to
  720:         # intuit something and get it wrong due to fmting
  721: 
  722:         1 while s/([A-Z]<$nonest>)/noremap($1)/ge;
  723: 
  724:         # func() is a reference to a perl function
  725:         s{
  726:             \b
  727:             (
  728:                 [:\w]+ \(\)
  729:             )
  730:         } {I<$1>}gx;
  731: 
  732:         # func(n) is a reference to a perl function or a man page
  733:         s{
  734:             ([:\w]+)
  735:             (
  736:                 \( [^\051]+ \)
  737:             )
  738:         } {I<$1>\\|$2}gx;
  739: 
  740:         # convert simple variable references
  741:         s/(\s+)([\$\@%][\w:]+)(?!\()/${1}C<$2>/g;
  742: 
  743:         if (m{ (
  744:                     [\-\w]+
  745:                     \(
  746:                         [^\051]*?
  747:                         [\@\$,]
  748:                         [^\051]*?
  749:                     \)
  750:                 )
  751:             }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
  752:         {
  753:             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [LCI]<$1>\n";
  754:             $oops++;
  755:         }
  756: 
  757:         while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
  758:             warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [CB]<$1>\n";
  759:             $oops++;
  760:         }
  761: 
  762:         # put it back so we get the <> processed again;
  763:         clear_noremap(0); # 0 means leave the E's
  764: 
  765:     } else {
  766:         # trofficate backslashes
  767:         s/\\/noremap('\\e')/ge;
  768: 
  769:     }
  770: 
  771:     # need to hide E<> first; they're processed in clear_noremap
  772:     s/(E<[^<>]+>)/noremap($1)/ge;
  773: 
  774: 
  775:     $maxnest = 10;
  776:     while ($maxnest-- && /[A-Z]</) {
  777: 
  778:         # can't do C font here
  779:         s/([BI])<($nonest)>/font($1) . $2 . font('R')/eg;
  780: 
  781:         # files and filelike refs in italics
  782:         s/F<($nonest)>/I<$1>/g;
  783: 
  784:         # no break -- usually we want C<> for this
  785:         s/S<($nonest)>/nobreak($1)/eg;
  786: 
  787:         # LREF: a la HREF L<show this text|man/section>
  788:         s:L<([^|>]+)\|[^>]+>:$1:g;
  789: 
  790:         # LREF: a manpage(3f)
  791:         s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g;
  792: 
  793:         # LREF: an =item on another manpage
  794:         s{
  795:             L<
  796:                 ([^/]+)
  797:                 /
  798:                 (
  799:                     [:\w]+
  800:                     (\(\))?
  801:                 )
  802:             >
  803: