Annotation of qemu/texi2pod.pl, revision 1.1.1.2

1.1       root        1: #! /usr/bin/perl -w
                      2: 
                      3: #   Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
                      4: 
                      5: # This file is part of GNU CC.
                      6: 
                      7: # GNU CC is free software; you can redistribute it and/or modify
                      8: # it under the terms of the GNU General Public License as published by
                      9: # the Free Software Foundation; either version 2, or (at your option)
                     10: # any later version.
                     11: 
                     12: # GNU CC is distributed in the hope that it will be useful,
                     13: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: # GNU General Public License for more details.
                     16: 
                     17: # You should have received a copy of the GNU General Public License
                     18: # along with GNU CC; see the file COPYING.  If not, write to
                     19: # the Free Software Foundation, 59 Temple Place - Suite 330,
                     20: # Boston MA 02111-1307, USA.
                     21: 
                     22: # This does trivial (and I mean _trivial_) conversion of Texinfo
                     23: # markup to Perl POD format.  It's intended to be used to extract
                     24: # something suitable for a manpage from a Texinfo document.
                     25: 
                     26: $output = 0;
                     27: $skipping = 0;
                     28: %sects = ();
                     29: $section = "";
                     30: @icstack = ();
                     31: @endwstack = ();
                     32: @skstack = ();
                     33: @instack = ();
                     34: $shift = "";
                     35: %defs = ();
                     36: $fnno = 1;
                     37: $inf = "";
                     38: $ibase = "";
                     39: 
                     40: while ($_ = shift) {
                     41:     if (/^-D(.*)$/) {
                     42:        if ($1 ne "") {
                     43:            $flag = $1;
                     44:        } else {
                     45:            $flag = shift;
                     46:        }
                     47:        $value = "";
                     48:        ($flag, $value) = ($flag =~ /^([^=]+)(?:=(.+))?/);
                     49:        die "no flag specified for -D\n"
                     50:            unless $flag ne "";
                     51:        die "flags may only contain letters, digits, hyphens, dashes and underscores\n"
                     52:            unless $flag =~ /^[a-zA-Z0-9_-]+$/;
                     53:        $defs{$flag} = $value;
                     54:     } elsif (/^-/) {
                     55:        usage();
                     56:     } else {
                     57:        $in = $_, next unless defined $in;
                     58:        $out = $_, next unless defined $out;
                     59:        usage();
                     60:     }
                     61: }
                     62: 
                     63: if (defined $in) {
                     64:     $inf = gensym();
                     65:     open($inf, "<$in") or die "opening \"$in\": $!\n";
                     66:     $ibase = $1 if $in =~ m|^(.+)/[^/]+$|;
                     67: } else {
                     68:     $inf = \*STDIN;
                     69: }
                     70: 
                     71: if (defined $out) {
                     72:     open(STDOUT, ">$out") or die "opening \"$out\": $!\n";
                     73: }
                     74: 
                     75: while(defined $inf) {
                     76: while(<$inf>) {
                     77:     # Certain commands are discarded without further processing.
                     78:     /^\@(?:
                     79:         [a-z]+index            # @*index: useful only in complete manual
                     80:         |need                  # @need: useful only in printed manual
                     81:         |(?:end\s+)?group      # @group .. @end group: ditto
                     82:         |page                  # @page: ditto
                     83:         |node                  # @node: useful only in .info file
                     84:         |(?:end\s+)?ifnottex   # @ifnottex .. @end ifnottex: use contents
                     85:        )\b/x and next;
                     86: 
                     87:     chomp;
                     88: 
                     89:     # Look for filename and title markers.
                     90:     /^\@setfilename\s+([^.]+)/ and $fn = $1, next;
                     91:     /^\@settitle\s+([^.]+)/ and $tl = postprocess($1), next;
                     92: 
                     93:     # Identify a man title but keep only the one we are interested in.
                     94:     /^\@c\s+man\s+title\s+([A-Za-z0-9-]+)\s+(.+)/ and do {
                     95:        if (exists $defs{$1}) {
                     96:            $fn = $1;
                     97:            $tl = postprocess($2);
                     98:        }
                     99:        next;
                    100:     };
                    101: 
                    102:     # Look for blocks surrounded by @c man begin SECTION ... @c man end.
                    103:     # This really oughta be @ifman ... @end ifman and the like, but such
                    104:     # would require rev'ing all other Texinfo translators.
                    105:     /^\@c\s+man\s+begin\s+([A-Z]+)\s+([A-Za-z0-9-]+)/ and do {
                    106:        $output = 1 if exists $defs{$2};
                    107:         $sect = $1;
                    108:        next;
                    109:     };
                    110:     /^\@c\s+man\s+begin\s+([A-Z]+)/ and $sect = $1, $output = 1, next;
                    111:     /^\@c\s+man\s+end/ and do {
                    112:        $sects{$sect} = "" unless exists $sects{$sect};
                    113:        $sects{$sect} .= postprocess($section);
                    114:        $section = "";
                    115:        $output = 0;
                    116:        next;
                    117:     };
                    118: 
                    119:     # handle variables
                    120:     /^\@set\s+([a-zA-Z0-9_-]+)\s*(.*)$/ and do {
                    121:        $defs{$1} = $2;
                    122:        next;
                    123:     };
                    124:     /^\@clear\s+([a-zA-Z0-9_-]+)/ and do {
                    125:        delete $defs{$1};
                    126:        next;
                    127:     };
                    128: 
                    129:     next unless $output;
                    130: 
                    131:     # Discard comments.  (Can't do it above, because then we'd never see
                    132:     # @c man lines.)
                    133:     /^\@c\b/ and next;
                    134: 
                    135:     # End-block handler goes up here because it needs to operate even
                    136:     # if we are skipping.
                    137:     /^\@end\s+([a-z]+)/ and do {
                    138:        # Ignore @end foo, where foo is not an operation which may
                    139:        # cause us to skip, if we are presently skipping.
                    140:        my $ended = $1;
                    141:        next if $skipping && $ended !~ /^(?:ifset|ifclear|ignore|menu|iftex)$/;
                    142: 
                    143:        die "\@end $ended without \@$ended at line $.\n" unless defined $endw;
                    144:        die "\@$endw ended by \@end $ended at line $.\n" unless $ended eq $endw;
                    145: 
                    146:        $endw = pop @endwstack;
                    147: 
                    148:        if ($ended =~ /^(?:ifset|ifclear|ignore|menu|iftex)$/) {
                    149:            $skipping = pop @skstack;
                    150:            next;
                    151:        } elsif ($ended =~ /^(?:example|smallexample|display)$/) {
                    152:            $shift = "";
                    153:            $_ = "";    # need a paragraph break
                    154:        } elsif ($ended =~ /^(?:itemize|enumerate|[fv]?table)$/) {
                    155:            $_ = "\n=back\n";
                    156:            $ic = pop @icstack;
                    157:        } else {
                    158:            die "unknown command \@end $ended at line $.\n";
                    159:        }
                    160:     };
                    161: 
                    162:     # We must handle commands which can cause skipping even while we
                    163:     # are skipping, otherwise we will not process nested conditionals
                    164:     # correctly.
                    165:     /^\@ifset\s+([a-zA-Z0-9_-]+)/ and do {
                    166:        push @endwstack, $endw;
                    167:        push @skstack, $skipping;
                    168:        $endw = "ifset";
                    169:        $skipping = 1 unless exists $defs{$1};
                    170:        next;
                    171:     };
                    172: 
                    173:     /^\@ifclear\s+([a-zA-Z0-9_-]+)/ and do {
                    174:        push @endwstack, $endw;
                    175:        push @skstack, $skipping;
                    176:        $endw = "ifclear";
                    177:        $skipping = 1 if exists $defs{$1};
                    178:        next;
                    179:     };
                    180: 
                    181:     /^\@(ignore|menu|iftex)\b/ and do {
                    182:        push @endwstack, $endw;
                    183:        push @skstack, $skipping;
                    184:        $endw = $1;
                    185:        $skipping = 1;
                    186:        next;
                    187:     };
                    188: 
                    189:     next if $skipping;
                    190: 
                    191:     # Character entities.  First the ones that can be replaced by raw text
                    192:     # or discarded outright:
                    193:     s/\@copyright\{\}/(c)/g;
                    194:     s/\@dots\{\}/.../g;
                    195:     s/\@enddots\{\}/..../g;
                    196:     s/\@([.!? ])/$1/g;
                    197:     s/\@[:-]//g;
                    198:     s/\@bullet(?:\{\})?/*/g;
                    199:     s/\@TeX\{\}/TeX/g;
                    200:     s/\@pounds\{\}/\#/g;
                    201:     s/\@minus(?:\{\})?/-/g;
                    202:     s/\\,/,/g;
                    203: 
                    204:     # Now the ones that have to be replaced by special escapes
                    205:     # (which will be turned back into text by unmunge())
                    206:     s/&/&amp;/g;
                    207:     s/\@\{/&lbrace;/g;
                    208:     s/\@\}/&rbrace;/g;
                    209:     s/\@\@/&at;/g;
                    210: 
                    211:     # Inside a verbatim block, handle @var specially.
                    212:     if ($shift ne "") {
                    213:        s/\@var\{([^\}]*)\}/<$1>/g;
                    214:     }
                    215: 
                    216:     # POD doesn't interpret E<> inside a verbatim block.
                    217:     if ($shift eq "") {
                    218:        s/</&lt;/g;
                    219:        s/>/&gt;/g;
                    220:     } else {
                    221:        s/</&LT;/g;
                    222:        s/>/&GT;/g;
                    223:     }
                    224: 
                    225:     # Single line command handlers.
                    226: 
                    227:     /^\@include\s+(.+)$/ and do {
                    228:        push @instack, $inf;
                    229:        $inf = gensym();
                    230: 
                    231:        # Try cwd and $ibase.
1.1.1.2 ! root      232:        open($inf, "<" . $1)
1.1       root      233:            or open($inf, "<" . $ibase . "/" . $1)
                    234:                or die "cannot open $1 or $ibase/$1: $!\n";
                    235:        next;
                    236:     };
                    237: 
                    238:     /^\@(?:section|unnumbered|unnumberedsec|center)\s+(.+)$/
                    239:        and $_ = "\n=head2 $1\n";
                    240:     /^\@subsection\s+(.+)$/
                    241:        and $_ = "\n=head3 $1\n";
                    242: 
                    243:     # Block command handlers:
                    244:     /^\@itemize\s+(\@[a-z]+|\*|-)/ and do {
                    245:        push @endwstack, $endw;
                    246:        push @icstack, $ic;
                    247:        $ic = $1;
                    248:        $_ = "\n=over 4\n";
                    249:        $endw = "itemize";
                    250:     };
                    251: 
                    252:     /^\@enumerate(?:\s+([a-zA-Z0-9]+))?/ and do {
                    253:        push @endwstack, $endw;
                    254:        push @icstack, $ic;
                    255:        if (defined $1) {
                    256:            $ic = $1 . ".";
                    257:        } else {
                    258:            $ic = "1.";
                    259:        }
                    260:        $_ = "\n=over 4\n";
                    261:        $endw = "enumerate";
                    262:     };
                    263: 
                    264:     /^\@([fv]?table)\s+(\@[a-z]+)/ and do {
                    265:        push @endwstack, $endw;
                    266:        push @icstack, $ic;
                    267:        $endw = $1;
                    268:        $ic = $2;
                    269:        $ic =~ s/\@(?:samp|strong|key|gcctabopt|option|env)/B/;
                    270:        $ic =~ s/\@(?:code|kbd)/C/;
                    271:        $ic =~ s/\@(?:dfn|var|emph|cite|i)/I/;
                    272:        $ic =~ s/\@(?:file)/F/;
                    273:        $_ = "\n=over 4\n";
                    274:     };
                    275: 
                    276:     /^\@((?:small)?example|display)/ and do {
                    277:        push @endwstack, $endw;
                    278:        $endw = $1;
                    279:        $shift = "\t";
                    280:        $_ = "";        # need a paragraph break
                    281:     };
                    282: 
                    283:     /^\@itemx?\s*(.+)?$/ and do {
                    284:        if (defined $1) {
                    285:            # Entity escapes prevent munging by the <> processing below.
                    286: #            print "$ic\n";
                    287:            $_ = "\n=item $ic\&LT;$1\&GT;\n";
                    288:        } else {
                    289:            $_ = "\n=item $ic\n";
                    290:            $ic =~ y/A-Ya-y/B-Zb-z/;
                    291:            $ic =~ s/(\d+)/$1 + 1/eg;
                    292:        }
                    293:     };
                    294: 
                    295:     $section .= $shift.$_."\n";
                    296: }
                    297: # End of current file.
                    298: close($inf);
                    299: $inf = pop @instack;
                    300: }
                    301: 
                    302: die "No filename or title\n" unless defined $fn && defined $tl;
                    303: 
                    304: $sects{NAME} = "$fn \- $tl\n";
                    305: $sects{FOOTNOTES} .= "=back\n" if exists $sects{FOOTNOTES};
                    306: 
                    307: for $sect (qw(NAME SYNOPSIS DESCRIPTION OPTIONS ENVIRONMENT FILES
                    308:              BUGS NOTES FOOTNOTES SEEALSO AUTHOR COPYRIGHT)) {
                    309:     if(exists $sects{$sect}) {
                    310:        $head = $sect;
                    311:        $head =~ s/SEEALSO/SEE ALSO/;
                    312:        print "=head1 $head\n\n";
                    313:        print scalar unmunge ($sects{$sect});
                    314:        print "\n";
                    315:     }
                    316: }
                    317: 
                    318: sub usage
                    319: {
                    320:     die "usage: $0 [-D toggle...] [infile [outfile]]\n";
                    321: }
                    322: 
                    323: sub postprocess
                    324: {
                    325:     local $_ = $_[0];
                    326: 
                    327:     # @value{foo} is replaced by whatever 'foo' is defined as.
                    328:     while (m/(\@value\{([a-zA-Z0-9_-]+)\})/g) {
                    329:        if (! exists $defs{$2}) {
                    330:            print STDERR "Option $2 not defined\n";
                    331:            s/\Q$1\E//;
                    332:        } else {
                    333:            $value = $defs{$2};
                    334:            s/\Q$1\E/$value/;
                    335:        }
                    336:     }
                    337: 
                    338:     # Formatting commands.
                    339:     # Temporary escape for @r.
                    340:     s/\@r\{([^\}]*)\}/R<$1>/g;
                    341:     s/\@(?:dfn|var|emph|cite|i)\{([^\}]*)\}/I<$1>/g;
                    342:     s/\@(?:code|kbd)\{([^\}]*)\}/C<$1>/g;
                    343:     s/\@(?:gccoptlist|samp|strong|key|option|env|command|b)\{([^\}]*)\}/B<$1>/g;
                    344:     s/\@sc\{([^\}]*)\}/\U$1/g;
                    345:     s/\@file\{([^\}]*)\}/F<$1>/g;
                    346:     s/\@w\{([^\}]*)\}/S<$1>/g;
                    347:     s/\@(?:dmn|math)\{([^\}]*)\}/$1/g;
                    348: 
                    349:     # Cross references are thrown away, as are @noindent and @refill.
                    350:     # (@noindent is impossible in .pod, and @refill is unnecessary.)
                    351:     # @* is also impossible in .pod; we discard it and any newline that
                    352:     # follows it.  Similarly, our macro @gol must be discarded.
                    353: 
                    354:     s/\(?\@xref\{(?:[^\}]*)\}(?:[^.<]|(?:<[^<>]*>))*\.\)?//g;
                    355:     s/\s+\(\@pxref\{(?:[^\}]*)\}\)//g;
                    356:     s/;\s+\@pxref\{(?:[^\}]*)\}//g;
                    357:     s/\@noindent\s*//g;
                    358:     s/\@refill//g;
                    359:     s/\@gol//g;
                    360:     s/\@\*\s*\n?//g;
                    361: 
                    362:     # @uref can take one, two, or three arguments, with different
                    363:     # semantics each time.  @url and @email are just like @uref with
                    364:     # one argument, for our purposes.
                    365:     s/\@(?:uref|url|email)\{([^\},]*)\}/&lt;B<$1>&gt;/g;
                    366:     s/\@uref\{([^\},]*),([^\},]*)\}/$2 (C<$1>)/g;
                    367:     s/\@uref\{([^\},]*),([^\},]*),([^\},]*)\}/$3/g;
                    368: 
                    369:     # Turn B<blah I<blah> blah> into B<blah> I<blah> B<blah> to
                    370:     # match Texinfo semantics of @emph inside @samp.  Also handle @r
                    371:     # inside bold.
                    372:     s/&LT;/</g;
                    373:     s/&GT;/>/g;
                    374:     1 while s/B<((?:[^<>]|I<[^<>]*>)*)R<([^>]*)>/B<$1>${2}B</g;
                    375:     1 while (s/B<([^<>]*)I<([^>]+)>/B<$1>I<$2>B</g);
                    376:     1 while (s/I<([^<>]*)B<([^>]+)>/I<$1>B<$2>I</g);
                    377:     s/[BI]<>//g;
                    378:     s/([BI])<(\s+)([^>]+)>/$2$1<$3>/g;
                    379:     s/([BI])<([^>]+?)(\s+)>/$1<$2>$3/g;
                    380: 
                    381:     # Extract footnotes.  This has to be done after all other
                    382:     # processing because otherwise the regexp will choke on formatting
                    383:     # inside @footnote.
                    384:     while (/\@footnote/g) {
                    385:        s/\@footnote\{([^\}]+)\}/[$fnno]/;
                    386:        add_footnote($1, $fnno);
                    387:        $fnno++;
                    388:     }
                    389: 
                    390:     return $_;
                    391: }
                    392: 
                    393: sub unmunge
                    394: {
                    395:     # Replace escaped symbols with their equivalents.
                    396:     local $_ = $_[0];
                    397: 
                    398:     s/&lt;/E<lt>/g;
                    399:     s/&gt;/E<gt>/g;
                    400:     s/&lbrace;/\{/g;
                    401:     s/&rbrace;/\}/g;
                    402:     s/&at;/\@/g;
                    403:     s/&amp;/&/g;
                    404:     return $_;
                    405: }
                    406: 
                    407: sub add_footnote
                    408: {
                    409:     unless (exists $sects{FOOTNOTES}) {
                    410:        $sects{FOOTNOTES} = "\n=over 4\n\n";
                    411:     }
                    412: 
                    413:     $sects{FOOTNOTES} .= "=item $fnno.\n\n"; $fnno++;
                    414:     $sects{FOOTNOTES} .= $_[0];
                    415:     $sects{FOOTNOTES} .= "\n\n";
                    416: }
                    417: 
                    418: # stolen from Symbol.pm
                    419: {
                    420:     my $genseq = 0;
                    421:     sub gensym
                    422:     {
                    423:        my $name = "GEN" . $genseq++;
                    424:        my $ref = \*{$name};
                    425:        delete $::{$name};
                    426:        return $ref;
                    427:     }
                    428: }

unix.superglobalmegacorp.com