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