This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.005_54 (pod2html) Generate Relative URLs
[perl5.git] / lib / Pod / Text.pm
1 package Pod::Text;
2
3 =head1 NAME
4
5 Pod::Text - convert POD data to formatted ASCII text
6
7 =head1 SYNOPSIS
8
9         use Pod::Text;
10
11         pod2text("perlfunc.pod");
12
13 Also:
14
15         pod2text [B<-a>] [B<->I<width>] < input.pod
16
17 =head1 DESCRIPTION
18
19 Pod::Text is a module that can convert documentation in the POD format (such
20 as can be found throughout the Perl distribution) into formatted ASCII.
21 Termcap is optionally supported for boldface/underline, and can enabled via
22 C<$Pod::Text::termcap=1>. If termcap has not been enabled, then backspaces
23 will be used to simulate bold and underlined text.
24
25 A separate F<pod2text> program is included that is primarily a wrapper for
26 Pod::Text.
27
28 The single function C<pod2text()> can take the optional options B<-a>
29 for an alternative output format, then a B<->I<width> option with the
30 max terminal width, followed by one or two arguments. The first
31 should be the name of a file to read the pod from, or "E<lt>&STDIN" to read from
32 STDIN. A second argument, if provided, should be a filehandle glob where
33 output should be sent.
34
35 =head1 AUTHOR
36
37 Tom Christiansen E<lt>F<tchrist@mox.perl.com>E<gt>
38
39 =head1 TODO
40
41 Cleanup work. The input and output locations need to be more flexible,
42 termcap shouldn't be a global variable, and the terminal speed needs to
43 be properly calculated.
44
45 =cut
46
47 use Term::Cap;
48 require Exporter;
49 @ISA = Exporter;
50 @EXPORT = qw(pod2text);
51
52 use vars qw($VERSION);
53 $VERSION = "1.0203";
54
55 use locale;     # make \w work right in non-ASCII lands
56
57 $termcap=0;
58
59 $opt_alt_format = 0;
60
61 #$use_format=1;
62
63 $UNDL = "\x1b[4m";
64 $INV = "\x1b[7m";
65 $BOLD = "\x1b[1m";
66 $NORM = "\x1b[0m";
67
68 sub pod2text {
69 shift if $opt_alt_format = ($_[0] eq '-a');
70
71 if($termcap and !$setuptermcap) {
72         $setuptermcap=1;
73
74     my($term) = Tgetent Term::Cap { TERM => undef, OSPEED => 9600 };
75     $UNDL = $term->{'_us'};
76     $INV = $term->{'_mr'};
77     $BOLD = $term->{'_md'};
78     $NORM = $term->{'_me'};
79 }
80
81 $SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1))
82        ||  $ENV{COLUMNS}
83        || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
84        || ($^O ne 'MSWin32' && $^O ne 'dos' && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0])
85        || 72;
86
87 @_ = ("<&STDIN") unless @_;
88 local($file,*OUTPUT) = @_;
89 *OUTPUT = *STDOUT if @_<2;
90
91 local $: = $:;
92 $: = " \n" if $opt_alt_format;  # Do not break ``-L/lib/'' into ``- L/lib/''.
93
94 $/ = "";
95
96 $FANCY = 0;
97
98 $cutting = 1;
99 $DEF_INDENT = 4;
100 $indent = $DEF_INDENT;
101 $needspace = 0;
102 $begun = "";
103
104 open(IN, $file) || die "Couldn't open $file: $!";
105
106 POD_DIRECTIVE: while (<IN>) {
107     if ($cutting) {
108         next unless /^=/;
109         $cutting = 0;
110     }
111     if ($begun) {
112         if (/^=end\s+$begun/) {
113              $begun = "";
114         }
115         elsif ($begun eq "text") {
116             print OUTPUT $_;
117         }
118         next;
119     }
120     1 while s{^(.*?)(\t+)(.*)$}{
121         $1
122         . (' ' x (length($2) * 8 - length($1) % 8))
123         . $3
124     }me;
125     # Translate verbatim paragraph
126     if (/^\s/) {
127         output($_);
128         next;
129     }
130
131     if (/^=for\s+(\S+)\s*(.*)/s) {
132         if ($1 eq "text") {
133             print OUTPUT $2,"";
134         } else {
135             # ignore unknown for
136         }
137         next;
138     }
139     elsif (/^=begin\s+(\S+)\s*(.*)/s) {
140         $begun = $1;
141         if ($1 eq "text") {
142             print OUTPUT $2."";
143         }
144         next;
145     }
146
147 sub prepare_for_output {
148
149     s/\s*$/\n/;
150     &init_noremap;
151
152     # need to hide E<> first; they're processed in clear_noremap
153     s/(E<[^<>]+>)/noremap($1)/ge;
154     $maxnest = 10;
155     while ($maxnest-- && /[A-Z]</) {
156         unless ($FANCY) {
157             if ($opt_alt_format) {
158                 s/[BC]<(.*?)>/``$1''/sg;
159                 s/F<(.*?)>/"$1"/sg;
160             } else {
161                 s/C<(.*?)>/`$1'/sg;
162             }
163         } else {
164             s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge;
165         }
166         # s/[IF]<(.*?)>/italic($1)/ge;
167         s/I<(.*?)>/*$1*/sg;
168         # s/[CB]<(.*?)>/bold($1)/ge;
169         s/X<.*?>//sg;
170
171         # LREF: a la HREF L<show this text|man/section>
172         s:L<([^|>]+)\|[^>]+>:$1:g;
173
174         # LREF: a manpage(3f)
175         s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g;
176         # LREF: an =item on another manpage
177         s{
178             L<
179                 ([^/]+)
180                 /
181                 (
182                     [:\w]+
183                     (\(\))?
184                 )
185             >
186         } {the "$2" entry in the $1 manpage}gx;
187
188         # LREF: an =item on this manpage
189         s{
190            ((?:
191             L<
192                 /
193                 (
194                     [:\w]+
195                     (\(\))?
196                 )
197             >
198             (,?\s+(and\s+)?)?
199           )+)
200         } { internal_lrefs($1) }gex;
201
202         # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
203         # the "func" can disambiguate
204         s{
205             L<
206                 (?:
207                     ([a-zA-Z]\S+?) / 
208                 )?
209                 "?(.*?)"?
210             >
211         }{
212             do {
213                 $1      # if no $1, assume it means on this page.
214                     ?  "the section on \"$2\" in the $1 manpage"
215                     :  "the section on \"$2\""
216             }
217         }sgex;
218
219         s/[A-Z]<(.*?)>/$1/sg;
220     }
221     clear_noremap(1);
222 }
223
224     &prepare_for_output;
225
226     if (s/^=//) {
227         # $needspace = 0;               # Assume this.
228         # s/\n/ /g;
229         ($Cmd, $_) = split(' ', $_, 2);
230         # clear_noremap(1);
231         if ($Cmd eq 'cut') {
232             $cutting = 1;
233         }
234         elsif ($Cmd eq 'pod') {
235             $cutting = 0;
236         }
237         elsif ($Cmd eq 'head1') {
238             makespace();
239             if ($opt_alt_format) {
240                 print OUTPUT "\n";
241                 s/^(.+?)[ \t]*$/==== $1 ====/;
242             }
243             print OUTPUT;
244             # print OUTPUT uc($_);
245             $needspace = $opt_alt_format;
246         }
247         elsif ($Cmd eq 'head2') {
248             makespace();
249             # s/(\w+)/\u\L$1/g;
250             #print ' ' x $DEF_INDENT, $_;
251             # print "\xA7";
252             s/(\w)/\xA7 $1/ if $FANCY;
253             if ($opt_alt_format) {
254                 s/^(.+?)[ \t]*$/==   $1   ==/;
255                 print OUTPUT "\n", $_;
256             } else {
257                 print OUTPUT ' ' x ($DEF_INDENT/2), $_, "\n";
258             }
259             $needspace = $opt_alt_format;
260         }
261         elsif ($Cmd eq 'over') {
262             push(@indent,$indent);
263             $indent += ($_ + 0) || $DEF_INDENT;
264         }
265         elsif ($Cmd eq 'back') {
266             $indent = pop(@indent);
267             warn "Unmatched =back\n" unless defined $indent;
268         }
269         elsif ($Cmd eq 'item') {
270             makespace();
271             # s/\A(\s*)\*/$1\xb7/ if $FANCY;
272             # s/^(\s*\*\s+)/$1 /;
273             {
274                 if (length() + 3 < $indent) {
275                     my $paratag = $_;
276                     $_ = <IN>;
277                     if (/^=/) {  # tricked!
278                         local($indent) = $indent[$#indent - 1] || $DEF_INDENT;
279                         output($paratag);
280                         redo POD_DIRECTIVE;
281                     }
282                     &prepare_for_output;
283                     IP_output($paratag, $_);
284                 } else {
285                     local($indent) = $indent[$#indent - 1] || $DEF_INDENT;
286                     output($_, 0);
287                 }
288             }
289         }
290         else {
291             warn "Unrecognized directive: $Cmd\n";
292         }
293     }
294     else {
295         # clear_noremap(1);
296         makespace();
297         output($_, 1);
298     }
299 }
300
301 close(IN);
302
303 }
304
305 #########################################################################
306
307 sub makespace {
308     if ($needspace) {
309         print OUTPUT "\n";
310         $needspace = 0;
311     }
312 }
313
314 sub bold {
315     my $line = shift;
316     return $line if $use_format;
317     if($termcap) {
318         $line = "$BOLD$line$NORM";
319     } else {
320             $line =~ s/(.)/$1\b$1/g;
321         }
322 #    $line = "$BOLD$line$NORM" if $ansify;
323     return $line;
324 }
325
326 sub italic {
327     my $line = shift;
328     return $line if $use_format;
329     if($termcap) {
330         $line = "$UNDL$line$NORM";
331     } else {
332             $line =~ s/(.)/$1\b_/g;
333     }
334 #    $line = "$UNDL$line$NORM" if $ansify;
335     return $line;
336 }
337
338 # Fill a paragraph including underlined and overstricken chars.
339 # It's not perfect for words longer than the margin, and it's probably
340 # slow, but it works.
341 sub fill {
342     local $_ = shift;
343     my $par = "";
344     my $indent_space = " " x $indent;
345     my $marg = $SCREEN-$indent;
346     my $line = $indent_space;
347     my $line_length;
348     foreach (split) {
349         my $word_length = length;
350         $word_length -= 2 while /\010/g;  # Subtract backspaces
351
352         if ($line_length + $word_length > $marg) {
353             $par .= $line . "\n";
354             $line= $indent_space . $_;
355             $line_length = $word_length;
356         }
357         else {
358             if ($line_length) {
359                 $line_length++;
360                 $line .= " ";
361             }
362             $line_length += $word_length;
363             $line .= $_;
364         }
365     }
366     $par .= "$line\n" if $line;
367     $par .= "\n";
368     return $par;
369 }
370
371 sub IP_output {
372     local($tag, $_) = @_;
373     local($tag_indent) = $indent[$#indent - 1] || $DEF_INDENT;
374     $tag_cols = $SCREEN - $tag_indent;
375     $cols = $SCREEN - $indent;
376     $tag =~ s/\s*$//;
377     s/\s+/ /g;
378     s/^ //;
379     $str = "format OUTPUT = \n"
380         . (($opt_alt_format && $tag_indent > 1)
381            ? ":" . " " x ($tag_indent - 1)
382            : " " x ($tag_indent))
383         . '@' . ('<' x ($indent - $tag_indent - 1))
384         . "^" .  ("<" x ($cols - 1)) . "\n"
385         . '$tag, $_'
386         . "\n~~"
387         . (" " x ($indent-2))
388         . "^" .  ("<" x ($cols - 5)) . "\n"
389         . '$_' . "\n\n.\n1";
390     #warn $str; warn "tag is $tag, _ is $_";
391     eval $str || die;
392     write OUTPUT;
393 }
394
395 sub output {
396     local($_, $reformat) = @_;
397     if ($reformat) {
398         $cols = $SCREEN - $indent;
399         s/\s+/ /g;
400         s/^ //;
401         $str = "format OUTPUT = \n~~"
402             . (" " x ($indent-2))
403             . "^" .  ("<" x ($cols - 5)) . "\n"
404             . '$_' . "\n\n.\n1";
405         eval $str || die;
406         write OUTPUT;
407     } else {
408         s/^/' ' x $indent/gem;
409         s/^\s+\n$/\n/gm;
410         s/^  /: /s if defined($reformat) && $opt_alt_format;
411         print OUTPUT;
412     }
413 }
414
415 sub noremap {
416     local($thing_to_hide) = shift;
417     $thing_to_hide =~ tr/\000-\177/\200-\377/;
418     return $thing_to_hide;
419 }
420
421 sub init_noremap {
422     die "unmatched init" if $mapready++;
423     #mask off high bit characters in input stream
424     s/([\200-\377])/"E<".ord($1).">"/ge;
425 }
426
427 sub clear_noremap {
428     my $ready_to_print = $_[0];
429     die "unmatched clear" unless $mapready--;
430     tr/\200-\377/\000-\177/;
431     # now for the E<>s, which have been hidden until now
432     # otherwise the interative \w<> processing would have
433     # been hosed by the E<gt>
434     s {
435             E<
436             (
437                 ( \d+ )
438                 | ( [A-Za-z]+ )
439             )
440             >   
441     } {
442          do {
443                 defined $2
444                 ? chr($2)
445                 :
446              defined $HTML_Escapes{$3}
447                 ? do { $HTML_Escapes{$3} }
448                 : do {
449                     warn "Unknown escape: E<$1> in $_";
450                     "E<$1>";
451                 }
452          }
453     }egx if $ready_to_print;
454 }
455
456 sub internal_lrefs {
457     local($_) = shift;
458     s{L</([^>]+)>}{$1}g;
459     my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
460     my $retstr = "the ";
461     my $i;
462     for ($i = 0; $i <= $#items; $i++) {
463         $retstr .= "C<$items[$i]>";
464         $retstr .= ", " if @items > 2 && $i != $#items;
465         $retstr .= " and " if $i+2 == @items;
466     }
467
468     $retstr .= " entr" . ( @items > 1  ? "ies" : "y" )
469             .  " elsewhere in this document ";
470
471     return $retstr;
472
473 }
474
475 BEGIN {
476
477 %HTML_Escapes = (
478     'amp'       =>      '&',    #   ampersand
479     'lt'        =>      '<',    #   left chevron, less-than
480     'gt'        =>      '>',    #   right chevron, greater-than
481     'quot'      =>      '"',    #   double quote
482
483     "Aacute"    =>      "\xC1", #   capital A, acute accent
484     "aacute"    =>      "\xE1", #   small a, acute accent
485     "Acirc"     =>      "\xC2", #   capital A, circumflex accent
486     "acirc"     =>      "\xE2", #   small a, circumflex accent
487     "AElig"     =>      "\xC6", #   capital AE diphthong (ligature)
488     "aelig"     =>      "\xE6", #   small ae diphthong (ligature)
489     "Agrave"    =>      "\xC0", #   capital A, grave accent
490     "agrave"    =>      "\xE0", #   small a, grave accent
491     "Aring"     =>      "\xC5", #   capital A, ring
492     "aring"     =>      "\xE5", #   small a, ring
493     "Atilde"    =>      "\xC3", #   capital A, tilde
494     "atilde"    =>      "\xE3", #   small a, tilde
495     "Auml"      =>      "\xC4", #   capital A, dieresis or umlaut mark
496     "auml"      =>      "\xE4", #   small a, dieresis or umlaut mark
497     "Ccedil"    =>      "\xC7", #   capital C, cedilla
498     "ccedil"    =>      "\xE7", #   small c, cedilla
499     "Eacute"    =>      "\xC9", #   capital E, acute accent
500     "eacute"    =>      "\xE9", #   small e, acute accent
501     "Ecirc"     =>      "\xCA", #   capital E, circumflex accent
502     "ecirc"     =>      "\xEA", #   small e, circumflex accent
503     "Egrave"    =>      "\xC8", #   capital E, grave accent
504     "egrave"    =>      "\xE8", #   small e, grave accent
505     "ETH"       =>      "\xD0", #   capital Eth, Icelandic
506     "eth"       =>      "\xF0", #   small eth, Icelandic
507     "Euml"      =>      "\xCB", #   capital E, dieresis or umlaut mark
508     "euml"      =>      "\xEB", #   small e, dieresis or umlaut mark
509     "Iacute"    =>      "\xCD", #   capital I, acute accent
510     "iacute"    =>      "\xED", #   small i, acute accent
511     "Icirc"     =>      "\xCE", #   capital I, circumflex accent
512     "icirc"     =>      "\xEE", #   small i, circumflex accent
513     "Igrave"    =>      "\xCD", #   capital I, grave accent
514     "igrave"    =>      "\xED", #   small i, grave accent
515     "Iuml"      =>      "\xCF", #   capital I, dieresis or umlaut mark
516     "iuml"      =>      "\xEF", #   small i, dieresis or umlaut mark
517     "Ntilde"    =>      "\xD1",         #   capital N, tilde
518     "ntilde"    =>      "\xF1",         #   small n, tilde
519     "Oacute"    =>      "\xD3", #   capital O, acute accent
520     "oacute"    =>      "\xF3", #   small o, acute accent
521     "Ocirc"     =>      "\xD4", #   capital O, circumflex accent
522     "ocirc"     =>      "\xF4", #   small o, circumflex accent
523     "Ograve"    =>      "\xD2", #   capital O, grave accent
524     "ograve"    =>      "\xF2", #   small o, grave accent
525     "Oslash"    =>      "\xD8", #   capital O, slash
526     "oslash"    =>      "\xF8", #   small o, slash
527     "Otilde"    =>      "\xD5", #   capital O, tilde
528     "otilde"    =>      "\xF5", #   small o, tilde
529     "Ouml"      =>      "\xD6", #   capital O, dieresis or umlaut mark
530     "ouml"      =>      "\xF6", #   small o, dieresis or umlaut mark
531     "szlig"     =>      "\xDF",         #   small sharp s, German (sz ligature)
532     "THORN"     =>      "\xDE", #   capital THORN, Icelandic
533     "thorn"     =>      "\xFE", #   small thorn, Icelandic
534     "Uacute"    =>      "\xDA", #   capital U, acute accent
535     "uacute"    =>      "\xFA", #   small u, acute accent
536     "Ucirc"     =>      "\xDB", #   capital U, circumflex accent
537     "ucirc"     =>      "\xFB", #   small u, circumflex accent
538     "Ugrave"    =>      "\xD9", #   capital U, grave accent
539     "ugrave"    =>      "\xF9", #   small u, grave accent
540     "Uuml"      =>      "\xDC", #   capital U, dieresis or umlaut mark
541     "uuml"      =>      "\xFC", #   small u, dieresis or umlaut mark
542     "Yacute"    =>      "\xDD", #   capital Y, acute accent
543     "yacute"    =>      "\xFD", #   small y, acute accent
544     "yuml"      =>      "\xFF", #   small y, dieresis or umlaut mark
545
546     "lchevron"  =>      "\xAB", #   left chevron (double less than)
547     "rchevron"  =>      "\xBB", #   right chevron (double greater than)
548 );
549 }
550
551 1;