Annotation of qemu/texi2pod.pl, revision 1.1

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.
        !           232:        open($inf, "<" . $1) 
        !           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