Annotation of qemu/texi2pod.pl, revision 1.1.1.4

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

unix.superglobalmegacorp.com