1 #! /usr/bin/perl -w

     2 

     3 #   Copyright (C) 1999, 2000, 2001, 2003 Free Software Foundation, Inc.

     4 

     5 # This file is part of GCC.

     6 

     7 # GCC 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 # GCC 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 GCC; see the file COPYING.  If not, write to

    19 # the Free Software Foundation, 51 Franklin Street, Fifth Floor,

    20 # Boston MA 02110-1301, 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 @ipath = ();

    40 

    41 while ($_ = shift) {

    42     if (/^-D(.*)$/) {

    43 	if ($1 ne "") {

    44 	    $flag = $1;

    45 	} else {

    46 	    $flag = shift;

    47 	}

    48 	$value = "";

    49 	($flag, $value) = ($flag =~ /^([^=]+)(?:=(.+))?/);

    50 	die "no flag specified for -D\n"

    51 	    unless $flag ne "";

    52 	die "flags may only contain letters, digits, hyphens, dashes and underscores\n"

    53 	    unless $flag =~ /^[a-zA-Z0-9_-]+$/;

    54 	$defs{$flag} = $value;

    55     } elsif (/^-I(.*)$/) {

    56 	if ($1 ne "") {

    57 	    $flag = $1;

    58 	} else {

    59 	    $flag = shift;

    60 	}

    61         push (@ipath, $flag);

    62     } elsif (/^-/) {

    63 	usage();

    64     } else {

    65 	$in = $_, next unless defined $in;

    66 	$out = $_, next unless defined $out;

    67 	usage();

    68     }

    69 }

    70 

    71 if (defined $in) {

    72     $inf = gensym();

    73     open($inf, "<$in") or die "opening \"$in\": $!\n";

    74     $ibase = $1 if $in =~ m|^(.+)/[^/]+$|;

    75 } else {

    76     $inf = \*STDIN;

    77 }

    78 

    79 if (defined $out) {

    80     open(STDOUT, ">$out") or die "opening \"$out\": $!\n";

    81 }

    82 

    83 while(defined $inf) {

    84 while(<$inf>) {

    85     # Certain commands are discarded without further processing.

    86     /^\@(?:

    87 	 [a-z]+index		# @*index: useful only in complete manual

    88 	 |need			# @need: useful only in printed manual

    89 	 |(?:end\s+)?group	# @group .. @end group: ditto

    90 	 |page			# @page: ditto

    91 	 |node			# @node: useful only in .info file

    92 	 |(?:end\s+)?ifnottex   # @ifnottex .. @end ifnottex: use contents

    93 	)\b/x and next;

    94 

    95     chomp;

    96 

    97     # Look for filename and title markers.

    98     /^\@setfilename\s+([^.]+)/ and $fn = $1, next;

    99     /^\@settitle\s+([^.]+)/ and $tl = postprocess($1), next;

   100 

   101     # Identify a man title but keep only the one we are interested in.

   102     /^\@c\s+man\s+title\s+([A-Za-z0-9-]+)\s+(.+)/ and do {

   103 	if (exists $defs{$1}) {

   104 	    $fn = $1;

   105 	    $tl = postprocess($2);

   106 	}

   107 	next;

   108     };

   109 

   110     # Look for blocks surrounded by @c man begin SECTION ... @c man end.

   111     # This really oughta be @ifman ... @end ifman and the like, but such

   112     # would require rev'ing all other Texinfo translators.

   113     /^\@c\s+man\s+begin\s+([A-Z]+)\s+([A-Za-z0-9-]+)/ and do {

   114 	$output = 1 if exists $defs{$2};

   115         $sect = $1;

   116 	next;

   117     };

   118     /^\@c\s+man\s+begin\s+([A-Z]+)/ and $sect = $1, $output = 1, next;

   119     /^\@c\s+man\s+end/ and do {

   120 	$sects{$sect} = "" unless exists $sects{$sect};

   121 	$sects{$sect} .= postprocess($section);

   122 	$section = "";

   123 	$output = 0;

   124 	next;

   125     };

   126 

   127     # handle variables

   128     /^\@set\s+([a-zA-Z0-9_-]+)\s*(.*)$/ and do {

   129 	$defs{$1} = $2;

   130 	next;

   131     };

   132     /^\@clear\s+([a-zA-Z0-9_-]+)/ and do {

   133 	delete $defs{$1};

   134 	next;

   135     };

   136 

   137     next unless $output;

   138 

   139     # Discard comments.  (Can't do it above, because then we'd never see

   140     # @c man lines.)

   141     /^\@c\b/ and next;

   142 

   143     # End-block handler goes up here because it needs to operate even

   144     # if we are skipping.

   145     /^\@end\s+([a-z]+)/ and do {

   146 	# Ignore @end foo, where foo is not an operation which may

   147 	# cause us to skip, if we are presently skipping.

   148 	my $ended = $1;

   149 	next if $skipping && $ended !~ /^(?:ifset|ifclear|ignore|menu|iftex|copying)$/;

   150 

   151 	die "\@end $ended without \@$ended at line $.\n" unless defined $endw;

   152 	die "\@$endw ended by \@end $ended at line $.\n" unless $ended eq $endw;

   153 

   154 	$endw = pop @endwstack;

   155 

   156 	if ($ended =~ /^(?:ifset|ifclear|ignore|menu|iftex)$/) {

   157 	    $skipping = pop @skstack;

   158 	    next;

   159 	} elsif ($ended =~ /^(?:example|smallexample|display)$/) {

   160 	    $shift = "";

   161 	    $_ = "";	# need a paragraph break

   162 	} elsif ($ended =~ /^(?:itemize|enumerate|[fv]?table)$/) {

   163 	    $_ = "\n=back\n";

   164 	    $ic = pop @icstack;

   165 	} elsif ($ended eq "multitable") {

   166 	    $_ = "\n=back\n";

   167 	} else {

   168 	    die "unknown command \@end $ended at line $.\n";

   169 	}

   170     };

   171 

   172     # We must handle commands which can cause skipping even while we

   173     # are skipping, otherwise we will not process nested conditionals

   174     # correctly.

   175     /^\@ifset\s+([a-zA-Z0-9_-]+)/ and do {

   176 	push @endwstack, $endw;

   177 	push @skstack, $skipping;

   178 	$endw = "ifset";

   179 	$skipping = 1 unless exists $defs{$1};

   180 	next;

   181     };

   182 

   183     /^\@ifclear\s+([a-zA-Z0-9_-]+)/ and do {

   184 	push @endwstack, $endw;

   185 	push @skstack, $skipping;

   186 	$endw = "ifclear";

   187 	$skipping = 1 if exists $defs{$1};

   188 	next;

   189     };

   190 

   191     /^\@(ignore|menu|iftex|copying)\b/ and do {

   192 	push @endwstack, $endw;

   193 	push @skstack, $skipping;

   194 	$endw = $1;

   195 	$skipping = 1;

   196 	next;

   197     };

   198 

   199     next if $skipping;

   200 

   201     # Character entities.  First the ones that can be replaced by raw text

   202     # or discarded outright:

   203     s/\@copyright\{\}/(c)/g;

   204     s/\@dots\{\}/.../g;

   205     s/\@enddots\{\}/..../g;

   206     s/\@([.!? ])/$1/g;

   207     s/\@[:-]//g;

   208     s/\@bullet(?:\{\})?/*/g;

   209     s/\@TeX\{\}/TeX/g;

   210     s/\@pounds\{\}/\#/g;

   211     s/\@minus(?:\{\})?/-/g;

   212     s/\\,/,/g;

   213 

   214     # Now the ones that have to be replaced by special escapes

   215     # (which will be turned back into text by unmunge())

   216     s/&/&/g;

   217     s/\@\{/{/g;

   218     s/\@\}/}/g;

   219     s/\@\@/&at;/g;

   220 

   221     # Inside a verbatim block, handle @var specially.

   222     if ($shift ne "") {

   223 	s/\@var\{([^\}]*)\}/<$1>/g;

   224     }

   225 

   226     # POD doesn't interpret E<> inside a verbatim block.

   227     if ($shift eq "") {

   228 	s/</&lt;/g;

   229 	s/>/>/g;

   230     } else {

   231 	s/</&LT;/g;

   232 	s/>/>/g;

   233     }

   234 

   235     # Single line command handlers.

   236 

   237     /^\@include\s+(.+)$/ and do {

   238 	push @instack, $inf;

   239 	$inf = gensym();

   240 	$file = postprocess($1);

   241 

   242 	# Try cwd and $ibase, then explicit -I paths.

   243 	$done = 0;

   244 	foreach $path ("", $ibase, @ipath) {

   245 	    $mypath = $file;

   246 	    $mypath = $path . "/" . $mypath if ($path ne "");

   247 	    open($inf, "<" . $mypath) and ($done = 1, last);

   248 	}

   249 	die "cannot find $file" if !$done;

   250 	next;

   251     };

   252 

   253     /^\@(?:section|unnumbered|unnumberedsec|center)\s+(.+)$/

   254 	and $_ = "\n=head2 $1\n";

   255     /^\@subsection\s+(.+)$/

   256 	and $_ = "\n=head3 $1\n";

   257     /^\@subsubsection\s+(.+)$/

   258 	and $_ = "\n=head4 $1\n";

   259 

   260     # Block command handlers:

   261     /^\@itemize(?:\s+(\@[a-z]+|\*|-))?/ and do {

   262 	push @endwstack, $endw;

   263 	push @icstack, $ic;

   264 	if (defined $1) {

   265 	    $ic = $1;

   266 	} else {

   267 	    $ic = '*';

   268 	}

   269 	$_ = "\n=over 4\n";

   270 	$endw = "itemize";

   271     };

   272 

   273     /^\@enumerate(?:\s+([a-zA-Z0-9]+))?/ and do {

   274 	push @endwstack, $endw;

   275 	push @icstack, $ic;

   276 	if (defined $1) {

   277 	    $ic = $1 . ".";

   278 	} else {

   279 	    $ic = "1.";

   280 	}

   281 	$_ = "\n=over 4\n";

   282 	$endw = "enumerate";

   283     };

   284 

   285     /^\@multitable\s.*/ and do {

   286 	push @endwstack, $endw;

   287 	$endw = "multitable";

   288 	$_ = "\n=over 4\n";

   289     };

   290 

   291     /^\@([fv]?table)\s+(\@[a-z]+)/ and do {

   292 	push @endwstack, $endw;

   293 	push @icstack, $ic;

   294 	$endw = $1;

   295 	$ic = $2;

   296 	$ic =~ s/\@(?:samp|strong|key|gcctabopt|option|env)/B/;

   297 	$ic =~ s/\@(?:code|kbd)/C/;

   298 	$ic =~ s/\@(?:dfn|var|emph|cite|i)/I/;

   299 	$ic =~ s/\@(?:file)/F/;

   300 	$_ = "\n=over 4\n";

   301     };

   302 

   303     /^\@((?:small)?example|display)/ and do {

   304 	push @endwstack, $endw;

   305 	$endw = $1;

   306 	$shift = "\t";

   307 	$_ = "";	# need a paragraph break

   308     };

   309 

   310     /^\@item\s+(.*\S)\s*$/ and $endw eq "multitable" and do {

   311 	@columns = ();

   312 	for $column (split (/\s*\@tab\s*/, $1)) {

   313 	    # @strong{...} is used a @headitem work-alike

   314 	    $column =~ s/^\@strong{(.*)}$/$1/;

   315 	    push @columns, $column;

   316 	}

   317 	$_ = "\n=item ".join (" : ", @columns)."\n";

   318     };

   319 

   320     /^\@itemx?\s*(.+)?$/ and do {

   321 	if (defined $1) {

   322 	    # Entity escapes prevent munging by the <> processing below.

   323 	    $_ = "\n=item $ic\<$1\>\n";

   324 	} else {

   325 	    $_ = "\n=item $ic\n";

   326 	    $ic =~ y/A-Ya-y/B-Zb-z/;

   327 	    $ic =~ s/(\d+)/$1 + 1/eg;

   328 	}

   329     };

   330 

   331     $section .= $shift.$_."\n";

   332 }

   333 # End of current file.

   334 close($inf);

   335 $inf = pop @instack;

   336 }

   337 

   338 die "No filename or title\n" unless defined $fn && defined $tl;

   339 

   340 $sects{NAME} = "$fn \- $tl\n";

   341 $sects{FOOTNOTES} .= "=back\n" if exists $sects{FOOTNOTES};

   342 

   343 for $sect (qw(NAME SYNOPSIS DESCRIPTION OPTIONS ENVIRONMENT FILES

   344 	      BUGS NOTES FOOTNOTES SEEALSO AUTHOR COPYRIGHT)) {

   345     if(exists $sects{$sect}) {

   346 	$head = $sect;

   347 	$head =~ s/SEEALSO/SEE ALSO/;

   348 	print "=head1 $head\n\n";

   349 	print scalar unmunge ($sects{$sect});

   350 	print "\n";

   351     }

   352 }

   353 

   354 sub usage

   355 {

   356     die "usage: $0 [-D toggle...] [infile [outfile]]\n";

   357 }

   358 

   359 sub postprocess

   360 {

   361     local $_ = $_[0];

   362 

   363     # @value{foo} is replaced by whatever 'foo' is defined as.

   364     while (m/(\@value\{([a-zA-Z0-9_-]+)\})/g) {

   365 	if (! exists $defs{$2}) {

   366 	    print STDERR "Option $2 not defined\n";

   367 	    s/\Q$1\E//;

   368 	} else {

   369 	    $value = $defs{$2};

   370 	    s/\Q$1\E/$value/;

   371 	}

   372     }

   373 

   374     # Formatting commands.

   375     # Temporary escape for @r.

   376     s/\@r\{([^\}]*)\}/R<$1>/g;

   377     s/\@(?:dfn|var|emph|cite|i)\{([^\}]*)\}/I<$1>/g;

   378     s/\@(?:code|kbd)\{([^\}]*)\}/C<$1>/g;

   379     s/\@(?:gccoptlist|samp|strong|key|option|env|command|b)\{([^\}]*)\}/B<$1>/g;

   380     s/\@sc\{([^\}]*)\}/\U$1/g;

   381     s/\@file\{([^\}]*)\}/F<$1>/g;

   382     s/\@w\{([^\}]*)\}/S<$1>/g;

   383     s/\@(?:dmn|math)\{([^\}]*)\}/$1/g;

   384 

   385     # keep references of the form @ref{...}, print them bold

   386     s/\@(?:ref)\{([^\}]*)\}/B<$1>/g;

   387 

   388     # Change double single quotes to double quotes.

   389     s/''/"/g;

   390     s/``/"/g;

   391 

   392     # Cross references are thrown away, as are @noindent and @refill.

   393     # (@noindent is impossible in .pod, and @refill is unnecessary.)

   394     # @* is also impossible in .pod; we discard it and any newline that

   395     # follows it.  Similarly, our macro @gol must be discarded.

   396 

   397     s/\(?\@xref\{(?:[^\}]*)\}(?:[^.<]|(?:<[^<>]*>))*\.\)?//g;

   398     s/\s+\(\@pxref\{(?:[^\}]*)\}\)//g;

   399     s/;\s+\@pxref\{(?:[^\}]*)\}//g;

   400     s/\@noindent\s*//g;

   401     s/\@refill//g;

   402     s/\@gol//g;

   403     s/\@\*\s*\n?//g;

   404 

   405     # Anchors are thrown away

   406     s/\@anchor\{(?:[^\}]*)\}//g;

   407 

   408     # @uref can take one, two, or three arguments, with different

   409     # semantics each time.  @url and @email are just like @uref with

   410     # one argument, for our purposes.

   411     s/\@(?:uref|url|email)\{([^\},]*)\}/&lt;B<$1>&gt;/g;

   412     s/\@uref\{([^\},]*),([^\},]*)\}/$2 (C<$1>)/g;

   413     s/\@uref\{([^\},]*),([^\},]*),([^\},]*)\}/$3/g;

   414 

   415     # Un-escape <> at this point.

   416     s/&LT;/</g;

   417     s/>/>/g;

   418 

   419     # Now un-nest all B<>, I<>, R<>.  Theoretically we could have

   420     # indefinitely deep nesting; in practice, one level suffices.

   421     1 while s/([BIR])<([^<>]*)([BIR])<([^<>]*)>/$1<$2>$3<$4>$1</g;

   422 

   423     # Replace R<...> with bare ...; eliminate empty markup, B<>;

   424     # shift white space at the ends of [BI]<...> expressions outside

   425     # the expression.

   426     s/R<([^<>]*)>/$1/g;

   427     s/[BI]<>//g;

   428     s/([BI])<(\s+)([^>]+)>/$2$1<$3>/g;

   429     s/([BI])<([^>]+?)(\s+)>/$1<$2>$3/g;

   430 

   431     # Extract footnotes.  This has to be done after all other

   432     # processing because otherwise the regexp will choke on formatting

   433     # inside @footnote.

   434     while (/\@footnote/g) {

   435 	s/\@footnote\{([^\}]+)\}/[$fnno]/;

   436 	add_footnote($1, $fnno);

   437 	$fnno++;

   438     }

   439 

   440     return $_;

   441 }

   442 

   443 sub unmunge

   444 {

   445     # Replace escaped symbols with their equivalents.

   446     local $_ = $_[0];

   447 

   448     s/&lt;/E<lt>/g;

   449     s/&gt;/E<gt>/g;

   450     s/{/\{/g;

   451     s/}/\}/g;

   452     s/&at;/\@/g;

   453     s/&/&/g;

   454     return $_;

   455 }

   456 

   457 sub add_footnote

   458 {

   459     unless (exists $sects{FOOTNOTES}) {

   460 	$sects{FOOTNOTES} = "\n=over 4\n\n";

   461     }

   462 

   463     $sects{FOOTNOTES} .= "=item $fnno.\n\n"; $fnno++;

   464     $sects{FOOTNOTES} .= $_[0];

   465     $sects{FOOTNOTES} .= "\n\n";

   466 }

   467 

   468 # stolen from Symbol.pm

   469 {

   470     my $genseq = 0;

   471     sub gensym

   472     {

   473 	my $name = "GEN" . $genseq++;

   474 	my $ref = \*{$name};

   475 	delete $::{$name};

   476 	return $ref;

   477     }

   478 }