File Coverage

blib/lib/Pod/Dsr.pm
Criterion Covered Total %
statement 15 393 3.8
branch 0 180 0.0
condition 0 85 0.0
subroutine 5 35 14.2
pod 2 29 6.9
total 22 722 3.0


line stmt bran cond sub pod time code
1             # Pod::Dsr -- Convert POD data to formatted Digital Standard Runoff input.
2             # $Id: Dsr.pm,v 0.01 2001/01/16 13:39:45 pvhp Exp $
3             #
4             # Copyright 2001 by Peter Prymmer
5             #
6             # This program is free software; you can redistribute it and/or modify it
7             # under the same terms as Perl itself.
8             #
9             # This module uses Pod::Parser and is designed to be easy
10             # to subclass.
11             #
12             # Based upon: Pod::Man 1.14 by Russ Allbery
13              
14             ############################################################################
15             # Modules and declarations
16             ############################################################################
17              
18             package Pod::Dsr;
19              
20             require 5.004;
21              
22 1     1   930 use Carp qw(carp croak);
  1         1  
  1         79  
23 1     1   5 use Pod::Parser ();
  1         2  
  1         16  
24              
25 1     1   4 use strict;
  1         5  
  1         28  
26 1     1   964 use subs qw(makespace);
  1         28  
  1         5  
27 1     1   48 use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
  1         1  
  1         14451  
28              
29             @ISA = qw(Pod::Parser);
30              
31             # Don't use the CVS revision as the version, since this module is also in
32             # Perl core and too many things could munge CVS magic revision strings.
33             # This number should ideally be the same as the CVS revision in podlators,
34             # however.
35             $VERSION = 0.01;
36              
37              
38             ############################################################################
39             # Preamble and *roff output tables
40             ############################################################################
41              
42             # The following is the static preamble which starts all dsr output we
43             # generate. It's completely static except for the .LAYOUT to use,
44             # designated by @LAYOUT@. Hence, $PREAMBLE should therefore be run
45             # through s/\@LAYOUT\@/.LAYOUT $n1,$n2/g before output.
46              
47             $PREAMBLE = <<'----END OF PREAMBLE----';
48             @LAYOUT@
49             .! We need .CONTROL CHARACTERS in order to accept 255 (also 0-31,127-159).
50             .CONTROL CHARACTERS
51             .! The % character can often appear in documentation.
52             .DISABLE OVERSTRIKING
53             .! Turn on ^*bold\* recognition
54             .FLAGS BOLD
55             .! and ^&underlining\& (for italics)
56             .FLAGS UNDERLINE
57             ----END OF PREAMBLE----
58              
59             # This table is adapted from Tom Christiansen's pod2man. It
60             # assumes that _ can be used as the accept character, and that
61             # eight bit Latin-1 characters (derived from the DEC Multnational
62             # Character Set) are acceptable to your version of runoff.
63             %ESCAPES = (
64             'amp' => '_&', # ampersand
65             'lt' => '_<', # left chevron "angle bracket", less-than
66             'gt' => '_>', # right chevron "angle bracket", greater-than
67             'quot' => '"', # double quotation mark
68             'sol' => '/', # solidus (forward slash)
69             'verbar' => '_|', # vertical bar
70              
71             'Aacute' => 'Á', # capital A, acute accent
72             'aacute' => 'á', # small a, acute accent
73             'Acirc' => 'Â', # capital A, circumflex accent
74             'acirc' => 'â', # small a, circumflex accent
75             'AElig' => 'Æ', # capital AE diphthong (ligature)
76             'aelig' => 'æ', # small ae diphthong (ligature)
77             'Agrave' => 'À', # capital A, grave accent
78             'agrave' => 'à', # small a, grave accent
79             'Aring' => 'Å', # capital A, ring
80             'aring' => 'å', # small a, ring
81             'Atilde' => 'Ã', # capital A, tilde
82             'atilde' => 'ã', # small a, tilde
83             'Auml' => 'Ä', # capital A, dieresis or umlaut mark
84             'auml' => 'ä', # small a, dieresis or umlaut mark
85             'Ccedil' => 'Ç', # capital C, cedilla
86             'ccedil' => 'ç', # small c, cedilla
87             'Eacute' => 'É', # capital E, acute accent
88             'eacute' => 'é', # small e, acute accent
89             'Ecirc' => 'Ê', # capital E, circumflex accent
90             'ecirc' => 'ê', # small e, circumflex accent
91             'Egrave' => 'È', # capital E, grave accent
92             'egrave' => 'è', # small e, grave accent
93             'ETH' => 'Ð', # capital Eth, Icelandic
94             'eth' => 'ð', # small eth, Icelandic
95             'Euml' => 'Ë', # capital E, dieresis or umlaut mark
96             'euml' => 'ë', # small e, dieresis or umlaut mark
97             'Iacute' => 'Í', # capital I, acute accent
98             'iacute' => 'í', # small i, acute accent
99             'Icirc' => 'Î', # capital I, circumflex accent
100             'icirc' => 'î', # small i, circumflex accent
101             'Igrave' => 'Ì', # capital I, grave accent
102             'igrave' => 'ì', # small i, grave accent
103             'Iuml' => 'Ï', # capital I, dieresis or umlaut mark
104             'iuml' => 'ï', # small i, dieresis or umlaut mark
105             'Ntilde' => 'Ñ', # capital N, tilde
106             'ntilde' => 'ñ', # small n, tilde
107             'Oacute' => 'Ó', # capital O, acute accent
108             'oacute' => 'ó', # small o, acute accent
109             'Ocirc' => 'Ô', # capital O, circumflex accent
110             'ocirc' => 'ô', # small o, circumflex accent
111             'Ograve' => 'Ò', # capital O, grave accent
112             'ograve' => 'ò', # small o, grave accent
113             'Oslash' => 'Ø', # capital O, slash
114             'oslash' => 'ø', # small o, slash
115             'Otilde' => 'Õ', # capital O, tilde
116             'otilde' => 'õ', # small o, tilde
117             'Ouml' => 'Ö', # capital O, dieresis or umlaut mark
118             'ouml' => 'ö', # small o, dieresis or umlaut mark
119             'szlig' => 'ß', # small sharp s, German (sz ligature)
120             'THORN' => 'Þ', # capital THORN, Icelandic
121             'thorn' => 'þ', # small thorn, Icelandic
122             'Uacute' => 'Ú', # capital U, acute accent
123             'uacute' => 'ú', # small u, acute accent
124             'Ucirc' => 'Û', # capital U, circumflex accent
125             'ucirc' => 'û', # small u, circumflex accent
126             'Ugrave' => 'Ù', # capital U, grave accent
127             'ugrave' => 'ù', # small u, grave accent
128             'Uuml' => 'Ü', # capital U, dieresis or umlaut mark
129             'uuml' => 'ü', # small u, dieresis or umlaut mark
130             'Yacute' => 'Ý', # capital Y, acute accent
131             'yacute' => 'ý', # small y, acute accent
132             'yuml' => 'ÿ', # small y, dieresis or umlaut mark
133             );
134              
135              
136             ############################################################################
137             # Static helper functions
138             ############################################################################
139              
140             # Protect leading periods against interpretation as commands.
141             # Also protect flags:
142             # _ Accept
143             # * Bold
144             # | Break
145             # < Capitolize
146             # ! Comment
147             # . Control, DSR command
148             # = Hyphenate
149             # > Index
150             # \ Lowercase
151             # % Overstrike
152             # + Period
153             # # Space
154             # > Subindex
155             # $$ Substitute
156             # & Underline
157             # ^ Uppercase next char
158             sub protect {
159 0     0 0   local $_ = shift;
160             # s/^([.\*\|\\\\%+\#\^])/_$1/mg;
161 0           s/^([.])/_$1/mg;
162 0           $_;
163             }
164              
165             # Translate a font string into an escape.
166             sub toescape {
167             # (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0]
168 0     0 0   return(@_);
169             }
170              
171              
172             ############################################################################
173             # Initialization
174             ############################################################################
175              
176             # Initialize the object. Here, we also process any additional options
177             # passed to the constructor or set up defaults if none were given. center
178             # is the centered title, release is the version number, and date is the date
179             # for the documentation. Note that we can't know what file name we're
180             # processing due to the architecture of Pod::Parser, so that *has* to either
181             # be passed to the constructor or set separately with Pod::Dsr::name().
182             sub initialize {
183 0     0 0   my $self = shift;
184              
185             # Figure out the fixed-width font. If user-supplied, make sure that
186             # they are the right length.
187 0           for (qw/chapter layout fixed fixedbold fixeditalic fixedbolditalic/) {
188 0 0         if (defined $$self{$_}) {
189 0 0 0       if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) {
190             # croak qq(roff font should be 1 or 2 chars,)
191             # . qq( not "$$self{$_}");
192             }
193             } else {
194 0           $$self{$_} = '';
195             }
196             }
197              
198             # Set the default .LAYOUT.
199 0   0       $$self{layout} ||= '.LAYOUT 0';
200              
201             # Set the default .CHAPTER.
202             # $$self{chapter} ||= '';
203              
204             # Set the default fonts. We can't be sure what fixed bold-italic is
205             # going to be called, so default to just bold.
206 0   0       $$self{fixed} ||= 'CW';
207 0   0       $$self{fixedbold} ||= 'CB';
208 0   0       $$self{fixeditalic} ||= 'CI';
209 0   0       $$self{fixedbolditalic} ||= 'CB';
210              
211             # Set up a table of font escapes. First number is fixed-width, second
212             # is bold, third is italic.
213 0           $$self{FONTS} = { '000' => '\fR', '001' => '\fI',
214             '010' => '\fB', '011' => '\f(BI',
215             '100' => toescape ($$self{fixed}),
216             '101' => toescape ($$self{fixeditalic}),
217             '110' => toescape ($$self{fixedbold}),
218             '111' => toescape ($$self{fixedbolditalic})};
219              
220             # Extra stuff for page titles.
221 0 0         $$self{center} = 'User Contributed Perl Documentation'
222             unless defined $$self{center};
223 0 0         $$self{indent} = 4 unless defined $$self{indent};
224              
225             # We used to try first to get the version number from a local binary,
226             # but we shouldn't need that any more. Get the version from the running
227             # Perl. Work a little magic to handle subversions correctly under both
228             # the pre-5.6 and the post-5.6 version numbering schemes.
229 0 0         if (!defined $$self{release}) {
230 0           my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
231 0   0       $version[2] ||= 0;
232 0           $version[2] *= 10 ** (3 - length $version[2]);
233 0           for (@version) { $_ += 0 }
  0            
234 0           $$self{release} = 'perl v' . join ('.', @version);
235             }
236              
237             # Double quotes in things that will be quoted.
238             #for (qw/center date release/) {
239             # $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
240             #}
241              
242             # Figure out what quotes we'll be using for C<> text.
243 0   0       $$self{quotes} ||= '"';
244 0 0 0       if ($$self{quotes} eq 'none') {
    0          
    0          
245 0           $$self{LQUOTE} = $$self{RQUOTE} = '';
246             } elsif (length ($$self{quotes}) == 1) {
247 0           $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
248             } elsif ($$self{quotes} =~ /^(.)(.)$/
249             || $$self{quotes} =~ /^(..)(..)$/) {
250 0           $$self{LQUOTE} = $1;
251 0           $$self{RQUOTE} = $2;
252             } else {
253 0           croak qq(Invalid quote specification "$$self{quotes}");
254             }
255              
256             # Double the first quote; note that this should not be s///g as two
257             # double quotes is represented in *roff as three double quotes, not
258             # four. Weird, I know.
259 0           $$self{LQUOTE} =~ s/\"/\"\"/;
260 0           $$self{RQUOTE} =~ s/\"/\"\"/;
261              
262 0           $$self{INDENT} = 0; # Current indentation level.
263 0           $$self{INDENTS} = []; # Stack of indentations.
264 0           $$self{INDEX} = []; # Index keys waiting to be printed.
265 0           $$self{ITEMS} = 0; # The number of consecutive =items.
266              
267 0           $self->SUPER::initialize;
268             }
269              
270             # For each document we process, output the preamble first.
271             sub begin_pod {
272 0     0 0   my $self = shift;
273              
274             # Try to figure out the name and section from the file name.
275 0   0       my $section = $$self{section} || 1;
276 0           my $name = $$self{name};
277 0 0         if (!defined $name) {
278 0           $name = $self->input_file;
279 0 0 0       $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
280 0           $name =~ s/\.p(od|[lm])\z//i;
281 0 0         if ($section =~ /^1/) {
282 0           require File::Basename;
283 0           $name = uc File::Basename::basename ($name);
284             } else {
285             # Lose everything up to the first of
286             # */lib/*perl* standard or site_perl module
287             # */*perl*/lib from -D prefix=/opt/perl
288             # */*perl*/ random module hierarchy
289             # which works. Should be fixed to use File::Spec. Also handle
290             # a leading lib/ since that's what ExtUtils::MakeMaker creates.
291 0           for ($name) {
292 0           s%//+%/%g;
293 0 0 0       if ( s%^.*?/lib/[^/]*perl[^/]*/%%si
294             or s%^.*?/[^/]*perl[^/]*/(?:lib/)?%%si) {
295 0           s%^site(_perl)?/%%s; # site and site_perl
296 0           s%^(.*-$^O|$^O-.*)/%%so; # arch
297 0           s%^\d+\.\d+%%s; # version
298             }
299 0           s%^lib/%%;
300 0           s%/%::%g;
301             }
302             }
303             }
304              
305             # If $name contains spaces, quote it; this mostly comes up in the case
306             # of input from stdin.
307 0 0         $name = '"' . $name . '"' if ($name =~ /\s/);
308              
309             # Modification date header. Try to use the modification time of our
310             # input.
311             # Note that DSR .DATE and $$ are for appearence in text, whereas
312             # this date may appear in .! comments.
313 0 0         if (!defined $$self{date}) {
314 0   0       my $time = (stat $self->input_file)[9] || time;
315 0           my ($day, $month, $year) = (localtime $time)[3,4,5];
316             # $month++;
317 0           $month = ('JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','NOV','DEC')[$month];
318 0           $year += 1900;
319             # $$self{date} = sprintf ('%4d-%02d-%02d', $year, $month, $day);
320 0           $$self{date} = sprintf ('%02d-%s-%4d', $day, $month, $year);
321             }
322              
323             # Now, print out the preamble and the title.
324 0           local $_ = $PREAMBLE;
325 0           s/\@LAYOUT\@/$$self{layout}/;
326             # s/\@CFONT\@/$$self{fixed}/;
327             # s/\@LQUOTE\@/$$self{LQUOTE}/;
328             # s/\@RQUOTE\@/$$self{RQUOTE}/;
329 0           chomp $_;
330 0           print { $self->output_handle } <<"----END OF HEADER----";
  0            
331 0           .! Automatically generated by Pod::Dsr version $VERSION
332             .! @{[ scalar localtime ]}
333             .!
334             .! Standard preamble:
335             .! ======================================================================
336             $_
337             .! ======================================================================
338             .!
339             .INDEX $name
340             .TITLE $name
341             .SUBTITLE "$$self{release}" "$$self{date}" "$$self{center}"
342             ----END OF HEADER----
343             #"# for cperl-mode
344 0           my $chapter = $$self{chapter};
345 0 0         if ($chapter =~ /\d/) {
346 0           print { $self->output_handle } <<"----END OF CHAPTER----";
  0            
347             .NUMBER CHAPTER $chapter
348             .CHAPTER $name
349             ----END OF CHAPTER----
350             #"# for cperl-mode
351             }
352             # .INDEX is probably preferable to .ENTRY here. Did we want $name>$section?
353             # Did we want .FIRST TITLE or instead ?
354             # What to do with $section ?
355              
356             # Initialize a few per-file variables.
357 0           $$self{INDENT} = 0;
358 0           $$self{NEEDSPACE} = 0;
359             }
360              
361              
362             ############################################################################
363             # Core overrides
364             ############################################################################
365              
366             # Called for each command paragraph. Gets the command, the associated
367             # paragraph, the line number, and a Pod::Paragraph object. Just dispatches
368             # the command to a method named the same as the command. =cut is handled
369             # internally by Pod::Parser.
370             sub command {
371 0     0 1   my $self = shift;
372 0           my $command = shift;
373 0 0         return if $command eq 'pod';
374 0 0 0       return if ($$self{EXCLUDE} && $command ne 'end');
375 0 0         if ($self->can ('cmd_' . $command)) {
376 0           $command = 'cmd_' . $command;
377 0           $self->$command (@_);
378             } else {
379 0           my ($text, $line, $paragraph) = @_;
380 0           my $file;
381 0           ($file, $line) = $paragraph->file_line;
382 0           $text =~ s/\n+\z//;
383 0 0         $text = " $text" if ($text =~ /^\S/);
384 0           warn qq($file:$line: Unknown command paragraph "=$command$text"\n);
385 0           return;
386             }
387             }
388              
389             # Called for a verbatim paragraph. Gets the paragraph, the line number, and
390             # a Pod::Paragraph object. Rofficate backslashes, untabify, put a
391             # zero-width character at the beginning of each line to protect against
392             # commands, and wrap in .LITERAL/.END LITERAL.
393             sub verbatim {
394 0     0 0   my $self = shift;
395 0 0         return if $$self{EXCLUDE};
396 0           local $_ = shift;
397 0 0         return if /^\s+$/;
398 0           s/\s+$/\n/;
399             # my $lines = tr/\n/\n/;
400             ## 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
401             # s/\\/\\e/g;
402             # s/^(\s*\S)/'\&' . $1/gme;
403 0           $self->makespace;
404 0           $self->output (".LITERAL\n$_.END LITERAL\n");
405 0           $$self{NEEDSPACE} = 0;
406             }
407              
408             # Called for a regular text block. Gets the paragraph, the line number, and
409             # a Pod::Paragraph object. Perform interpolation and output the results.
410             sub textblock {
411 0     0 0   my $self = shift;
412 0 0         return if $$self{EXCLUDE};
413 0 0         $self->output ($_[0]), return if $$self{VERBATIM};
414              
415             # Perform a little magic to collapse multiple L<> references. We'll
416             # just rewrite the whole thing into actual text at this part, bypassing
417             # the whole internal sequence parsing thing.
418 0           my $text = shift;
419 0           $text =~ s{
420             (L< # A link of the form L.
421             /
422             (
423             [:\w]+ # The item has to be a simple word...
424             (\(\))? # ...or simple function.
425             )
426             >
427             (
428             ,?\s+(and\s+)? # Allow lots of them, conjuncted.
429             L<
430             /
431             ( [:\w]+ ( \(\) )? )
432             >
433             )+
434             )
435             } {
436 0           local $_ = $1;
437 0           s{ L< / ( [^>]+ ) > } {$1}xg;
438 0           my @items = split /(?:,?\s+(?:and\s+)?)/;
439 0           my $string = 'the ';
440 0           my $i;
441 0           for ($i = 0; $i < @items; $i++) {
442 0           $string .= $items[$i];
443 0 0 0       $string .= ', ' if @items > 2 && $i != $#items;
444 0 0 0       $string .= ' ' if @items == 2 && $i == 2;
445 0 0         $string .= 'and ' if ($i == $#items - 1);
446             }
447 0           $string .= ' entries elsewhere in this document';
448 0           $string;
449             }gex;
450              
451             # Parse the tree and output it. collapse knows about references to
452             # scalars as well as scalars and does the right thing with them.
453 0           $text = $self->parse ($text, @_);
454 0           $text =~ s/\n\s*$/\n/;
455 0           $self->makespace;
456 0           $self->output (protect $self->textmapfonts ($text));
457 0           $self->outindex;
458 0           $$self{NEEDSPACE} = 1;
459             }
460              
461             # Called for an interior sequence. Takes a Pod::InteriorSequence object and
462             # returns a reference to a scalar. This scalar is the final formatted text.
463             # It's returned as a reference so that other interior sequences above us
464             # know that the text has already been processed.
465             sub sequence {
466 0     0 1   my ($self, $seq) = @_;
467 0           my $command = $seq->cmd_name;
468              
469             # Zero-width characters.
470 0 0         if ($command eq 'Z') {
471             # Workaround to generate a blessable reference, needed by 5.005.
472             # my $tmp = '\&';
473 0           my $tmp = '#';
474 0           return bless \ "$tmp", 'Pod::Dsr::String';
475             }
476              
477             # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<>
478             # needs some additional special handling.
479 0           my $literal = ($command =~ /^[CELX]$/);
480 0 0         $literal++ if $command eq 'C';
481 0           local $_ = $self->collapse ($seq->parse_tree, $literal);
482              
483             # Handle E<> escapes.
484 0 0         if ($command eq 'E') {
485 0 0         if (/^\d+$/) {
    0          
486 0           return bless \ chr ($_), 'Pod::Dsr::String';
487             } elsif (exists $ESCAPES{$_}) {
488 0           return bless \ "$ESCAPES{$_}", 'Pod::Dsr::String';
489             } else {
490 0           carp "Unknown escape E<$1>";
491 0           return bless \ "E<$_>", 'Pod::Dsr::String';
492             }
493             }
494              
495             # For all the other sequences, empty content produces no output.
496 0 0         return '' if $_ eq '';
497              
498             # Handle formatting sequences.
499 0 0         if ($command eq 'B') {
    0          
    0          
    0          
500             # return bless \ ('\f(BS' . $_ . '\f(BE'), 'Pod::Dsr::String';
501 0           return bless \ ('^*' . $_ . '\*'), 'Pod::Dsr::String';
502             } elsif ($command eq 'F') {
503             # return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Dsr::String';
504 0           return bless \ ( $_ ), 'Pod::Dsr::String';
505             } elsif ($command eq 'I') {
506             # return bless \ ('\f(IS' . $_ . '\f(IE'), 'Pod::Dsr::String';
507 0           return bless \ ('^&' . $_ . '\&'), 'Pod::Dsr::String';
508             } elsif ($command eq 'C') {
509             # return bless \ ('\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"),
510 0           return bless \ ($_),
511             'Pod::Dsr::String';
512             }
513              
514             # Handle links.
515 0 0         if ($command eq 'L') {
516             # A bug in lvalue subs in 5.6 requires the temporary variable.
517 0           my $tmp = $self->buildlink ($_);
518 0           return bless \ "$tmp", 'Pod::Dsr::String';
519             }
520              
521             # Whitespace protection replaces whitespace with "\ ".
522 0 0         if ($command eq 'S') {
523             # s/\s+/\\ /g;
524 0           return bless \ "$_", 'Pod::Dsr::String';
525             }
526              
527             # Add an index entry to the list of ones waiting to be output.
528 0 0         if ($command eq 'X') { push (@{ $$self{INDEX} }, $_); return '' }
  0            
  0            
  0            
529              
530             # Anything else is unknown.
531 0           carp "Unknown sequence $command<$_>";
532             }
533              
534              
535             ############################################################################
536             # Command paragraphs
537             ############################################################################
538              
539             # All command paragraphs take the paragraph and the line number.
540              
541             # .SH
542             # already uses small caps, so remove any E<> sequences that would cause
543             # them.
544             sub cmd_head1 {
545 0     0 0   my $self = shift;
546 0           local $_ = $self->parse (@_);
547 0           s/\s+$//;
548 0           s/\\s-?\d//g;
549 0           s/\s*\n\s*/ /g;
550 0 0         if ($$self{ITEMS} > 1) {
551 0           $$self{ITEMS} = 0;
552             }
553 0           $self->output ($self->switchquotes ('.HEADER LEVEL 1', $self->mapfonts ($_)));
554 0 0         $self->outindex (($_ eq 'NAME') ? () : ($_));
555 0           $$self{NEEDSPACE} = 0;
556             }
557              
558             # Second level heading.
559             sub cmd_head2 {
560 0     0 0   my $self = shift;
561 0           local $_ = $self->parse (@_);
562 0           s/\s+$//;
563 0           s/\s*\n\s*/ /g;
564 0 0         if ($$self{ITEMS} > 1) {
565 0           $$self{ITEMS} = 0;
566             }
567 0           $self->output ($self->switchquotes ('.HEADER LEVEL 2', $self->mapfonts ($_)));
568 0           $self->outindex ($_);
569 0           $$self{NEEDSPACE} = 0;
570             }
571              
572             # Third level heading.
573             sub cmd_head3 {
574 0     0 0   my $self = shift;
575 0           local $_ = $self->parse (@_);
576 0           s/\s+$//;
577 0           s/\s*\n\s*/ /g;
578 0 0         if ($$self{ITEMS} > 1) {
579 0           $$self{ITEMS} = 0;
580             }
581 0           $self->makespace;
582 0           $self->output ($self->switchquotes ('.HEADER LEVEL 3', $self->mapfonts ($_)));
583 0           $self->outindex ($_);
584 0           $$self{NEEDSPACE} = 1;
585             }
586              
587             # Fourth level heading. DSR only offsets from test to .HEADER LEVEL 3
588             sub cmd_head4 {
589 0     0 0   my $self = shift;
590 0           local $_ = $self->parse (@_);
591 0           s/\s+$//;
592 0           s/\s*\n\s*/ /g;
593 0 0         if ($$self{ITEMS} > 1) {
594 0           $$self{ITEMS} = 0;
595             }
596 0           $self->makespace;
597 0           $self->output ($self->switchquotes ('.HEADER LEVEL 3', $self->mapfonts ($_)));
598 0           $self->outindex ($_);
599 0           $$self{NEEDSPACE} = 1;
600             }
601              
602             # Fifth level heading -> .HEADER LEVEL 4
603             sub cmd_head5 {
604 0     0 0   my $self = shift;
605 0           local $_ = $self->parse (@_);
606 0           s/\s+$//;
607 0           s/\s*\n\s*/ /g;
608 0 0         if ($$self{ITEMS} > 1) {
609 0           $$self{ITEMS} = 0;
610             }
611 0           $self->makespace;
612 0           $self->output ($self->switchquotes ('.HEADER LEVEL 4', $self->mapfonts ($_)));
613 0           $self->outindex ($_);
614 0           $$self{NEEDSPACE} = 1;
615             }
616              
617             # Sixth level heading. .HEADER LEVEL 5
618             sub cmd_head6 {
619 0     0 0   my $self = shift;
620 0           local $_ = $self->parse (@_);
621 0           s/\s+$//;
622 0           s/\s*\n\s*/ /g;
623 0 0         if ($$self{ITEMS} > 1) {
624 0           $$self{ITEMS} = 0;
625             }
626 0           $self->makespace;
627 0           $self->output ($self->switchquotes ('.HEADER LEVEL 5', $self->mapfonts ($_)));
628 0           $self->outindex ($_);
629 0           $$self{NEEDSPACE} = 1;
630             }
631              
632             # Start a list.
633             sub cmd_over {
634 0     0 0   my $self = shift;
635 0           local $_ = shift;
636 0 0         unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
  0            
637 0 0         if (@{ $$self{INDENTS} } > -1) {
  0            
638 0           $self->output (".LIST\n");
639             }
640 0           push (@{ $$self{INDENTS} }, $$self{INDENT});
  0            
641 0           $$self{INDENT} = ($_ + 0);
642             }
643              
644             # End a list. If we've closed an embedded indent, we've mangled the hanging
645             # paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT.
646             # We'll close that .RS at the next =back or =item.
647             sub cmd_back {
648 0     0 0   my $self = shift;
649 0           $$self{INDENT} = pop @{ $$self{INDENTS} };
  0            
650 0 0         unless (defined $$self{INDENT}) {
651 0           carp "Unmatched =back";
652 0           $$self{INDENT} = 0;
653             }
654             # if ($$self{WEIRDINDENT}) {
655             # $self->output (".END LIST\n");
656             # $$self{WEIRDINDENT} = 0;
657             # }
658 0 0         if (@{ $$self{INDENTS} } > -1) {
  0            
659 0           $self->output (".END LIST\n");
660 0           $$self{WEIRDINDENT} = 1;
661             }
662 0           $$self{NEEDSPACE} = 1;
663             }
664              
665             # An individual list item. Emit an index entry for anything that's
666             # interesting, but don't emit index entries for things like bullets and
667             # numbers. Turn * bullets into center dot characters (DEC MNCS) so use
668             # * for your lists rather than o or . or - or some other thing. Newlines
669             # in an item title are turned into spaces since RUNOFF can't handle them
670             # embedded.
671             sub cmd_item {
672 0     0 0   my $self = shift;
673 0           local $_ = $self->parse (@_);
674 0           s/\s+$//;
675 0           s/\s*\n\s*/ /g;
676 0           my $index;
677 0 0 0       if (/\w/ && !/^\w[.\)]\s*$/) {
678 0           $index = $_;
679 0           $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//;
680             }
681 0           s/^\*(\s|\Z)/·$1/;
682             # if ($$self{WEIRDINDENT}) {
683             # $self->output (".LIST ELEMENT;");
684             # $$self{WEIRDINDENT} = 0;
685             # }
686 0           $_ = $self->textmapfonts ($_);
687 0           $self->output ($self->switchquotes ('.LIST ELEMENT;', $_ ));
688 0 0         $self->outindex ($index ? ('Item', $index) : ());
689 0           $$self{NEEDSPACE} = 0;
690 0           $$self{ITEMS}++;
691             }
692              
693             # Begin a block for a particular translator. Setting VERBATIM triggers
694             # special handling in textblock().
695             sub cmd_begin {
696 0     0 0   my $self = shift;
697 0           local $_ = shift;
698 0 0         my ($kind) = /^(\S+)/ or return;
699 0 0 0       if ($kind eq 'man' || $kind eq 'roff' ||
      0        
      0        
700             $kind eq 'dsr' || $kind eq 'rno') {
701 0           $$self{VERBATIM} = 1;
702             } else {
703 0           $$self{EXCLUDE} = 1;
704             }
705             }
706              
707             # End a block for a particular translator. We assume that all =begin/=end
708             # pairs are properly closed.
709             sub cmd_end {
710 0     0 0   my $self = shift;
711 0           $$self{EXCLUDE} = 0;
712 0           $$self{VERBATIM} = 0;
713             }
714              
715             # One paragraph for a particular translator. Ignore it unless it's intended
716             # for dsr, rno, man or roff; in which case we output it verbatim.
717             sub cmd_for {
718 0     0 0   my $self = shift;
719 0           local $_ = shift;
720 0 0         return unless s/^(?:dsr|rno|man|roff)\b[ \t]*\n?//;
721 0           $self->output ($_);
722             }
723              
724              
725             ############################################################################
726             # Link handling
727             ############################################################################
728              
729             # Handle links. We can't actually make real hyperlinks, so this is all to
730             # figure out what text and formatting we print out.
731             sub buildlink {
732 0     0 0   my $self = shift;
733 0           local $_ = shift;
734              
735             # Smash whitespace in case we were split across multiple lines.
736 0           s/\s+/ /g;
737              
738             # If we were given any explicit text, just output it.
739 0 0         if (m{ ^ ([^|]+) \| }x) { return $1 }
  0            
740              
741             # Okay, leading and trailing whitespace isn't important.
742 0           s/^\s+//;
743 0           s/\s+$//;
744              
745             # Default to using the whole content of the link entry as a section
746             # name. Note that L forces a manpage interpretation, as does
747             # something looking like L. Do the same thing to
748             # L as we would to manpage(section) without the L<>;
749             # see guesswork(). If we've added italics, don't add the "manpage"
750             # text; markup is sufficient.
751             # DSR note: s/manpage/document/g; in the above.
752 0           my ($manpage, $section) = ('', $_);
753 0 0         if (/^"\s*(.*?)\s*"$/) {
    0          
    0          
754 0           $section = $1;
755             } elsif (m{ ^ [-:.\w]+ (?: \( \S+ \) )? $ }x) {
756 0           ($manpage, $section) = ($_, '');
757 0           $manpage =~ s/^([^\(]+)\(/'^&' . $1 . '\&('/e;
  0            
758             } elsif (m%/%) {
759 0           ($manpage, $section) = split (/\s*\/\s*/, $_, 2);
760 0 0         if ($manpage =~ /^[-:.\w]+(?:\(\S+\))?$/) {
761             # $manpage =~ s/^([^\(]+)\(/'\f(IS' . $1 . '\f(IE\|'/e;
762             }
763 0           $section =~ s/^\"\s*//;
764 0           $section =~ s/\s*\"$//;
765             }
766 0 0 0       if ($manpage && $manpage !~ /\^\&/) {
767 0           $manpage = "the $manpage document";
768             }
769              
770             # Now build the actual output text.
771 0           my $text = '';
772 0 0 0       if (!length ($section) && !length ($manpage)) {
    0          
    0          
773 0           carp "Invalid link $_";
774             } elsif (!length ($section)) {
775 0           $text = $manpage;
776             } elsif ($section =~ /^[:\w]+(?:\(\))?/) {
777 0           $text .= 'the ' . $section . ' entry';
778 0 0         $text .= (length $manpage) ? " in $manpage"
779             : " elsewhere in this document";
780             } else {
781 0 0         if ($section !~ /^".*"$/) { $section = '"' . $section . '"' }
  0            
782 0           $text .= 'the section on ' . $section;
783 0 0         $text .= " in $manpage" if length $manpage;
784             }
785 0           $text;
786             }
787              
788              
789             ############################################################################
790             # Escaping and fontification
791             ############################################################################
792              
793             # At this point, we'll have embedded font codes of the form \f([SE]
794             # where is one of B, I, or F. Turn those into the right font start
795             # or end codes. The old pod2man didn't get B else> right;
796             # after I<> it switched back to normal text rather than bold. We take care
797             # of this by using variables as a combined pointer to our current font
798             # sequence, and set each to the number of current nestings of start tags for
799             # that font. Use them as a vector to look up what font sequence to use.
800             #
801             # \fP changes to the previous font, but only one previous font is kept. We
802             # don't know what the outside level font is; normally it's R, but if we're
803             # inside a heading it could be something else. So arrange things so that
804             # the outside font is always the "previous" font and end with \fP instead of
805             # \fR. Idea from Zack Weinberg.
806             sub mapfonts {
807 0     0 0   my $self = shift;
808 0           local $_ = shift;
809              
810 0           my ($fixed, $bold, $italic) = (0, 0, 0);
811 0           my %magic = (F => \$fixed, B => \$bold, I => \$italic);
812 0           my $last = '\fR';
813 0           s { \\f\((.)(.) } {
814 0           my $sequence = '';
815 0           my $f;
816 0 0         if ($last ne '\fR') { $sequence = '\fP' }
  0            
817 0 0         ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
  0            
818 0   0       $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
      0        
      0        
819 0 0         if ($f eq $last) {
820 0           '';
821             } else {
822 0 0         if ($f ne '\fR') { $sequence .= $f }
  0            
823 0           $last = $f;
824 0           $sequence;
825             }
826             }gxe;
827 0           $_;
828             }
829              
830             # Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
831             # groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
832             # than R, presumably because \f(CW doesn't actually do a font change. To
833             # work around this, use a separate textmapfonts for text blocks where the
834             # default font is always R and only use the smart mapfonts for headings.
835             sub textmapfonts {
836 0     0 0   my $self = shift;
837 0           local $_ = shift;
838              
839 0           my ($fixed, $bold, $italic) = (0, 0, 0);
840 0           my %magic = (F => \$fixed, B => \$bold, I => \$italic);
841 0           s { \\f\((.)(.) } {
842 0 0         ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
  0            
843 0   0       $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
      0        
      0        
844             }gxe;
845 0           $_;
846             }
847              
848              
849             ############################################################################
850             # *roff-specific parsing
851             ############################################################################
852              
853             # Called instead of parse_text, calls parse_text with the right flags.
854             sub parse {
855 0     0 0   my $self = shift;
856 0           $self->parse_text ({ -expand_seq => 'sequence',
857             -expand_ptree => 'collapse' }, @_);
858             }
859              
860             # Takes a parse tree and a flag saying whether or not to treat it as literal
861             # text (not call guesswork on it), and returns the concatenation of all of
862             # the text strings in that parse tree. If the literal flag isn't true,
863             # guesswork() will be called on all plain scalars in the parse tree.
864             # Otherwise, just escape backslashes in the normal case. If collapse is
865             # being called on a C<> sequence, literal is set to 2, and we do some
866             # additional cleanup. Assumes that everything in the parse tree is either a
867             # scalar or a reference to a scalar.
868             sub collapse {
869 0     0 0   my ($self, $ptree, $literal) = @_;
870 0 0         if ($literal) {
871             return join ('', map {
872 0 0         if (ref $_) {
  0            
873 0           $$_;
874             } else {
875 0           s/\\/\\e/g;
876 0 0         s/-/\\-/g if $literal > 1;
877 0 0         s/__/_\\|_/g if $literal > 1;
878 0           $_;
879             }
880             } $ptree->children);
881             } else {
882 0 0         return join ('', map {
883 0           ref ($_) ? $$_ : $self->guesswork ($_)
884             } $ptree->children);
885             }
886             }
887              
888             # Takes a text block to perform guesswork on; this is guaranteed not to
889             # contain any interior sequences. Returns the text block with remapping
890             # done.
891             sub guesswork {
892 0     0 0   my $self = shift;
893 0           local $_ = shift;
894              
895             # rofficate backslashes.
896             # s/\\/\\e/g;
897              
898             # Ensure double underbars have a tiny space between them.
899             # s/__/_\\|_/g;
900              
901             # Make all caps a little smaller. Be careful here, since we don't want
902             # to make @ARGV into small caps, nor do we want to fix the MIME in
903             # MIME-Version, since it looks weird with the full-height V.
904             # s{
905             # ( ^ | [\s\(\"\'\`\[\{<>] )
906             # ( [A-Z] [A-Z] [/A-Z+:\d_\$&-]* )
907             # (?: (?= [\s>\}\]\)\'\".?!,;:] | -- ) | $ )
908             # } { $1 . '\s-1' . $2 . '\s0' }egx;
909              
910             # Turn PI into a pretty pi.
911             # s{ (?: \\s-1 | \b ) PI (?: \\s0 | \b ) } {\\*\(PI}gx;
912              
913             # Underline functions in the form func().
914 0           s{
915             \b
916             (
917             [:\w]+ (?:\\s-1)? \(\)
918             )
919 0           } { '^&' . $1 . '\&' }egx;
920              
921             # func(n) is a reference to a manual page. Make it ^&func\&(n).
922 0           s{
923             \b
924             (\w[-:.\w]+ (?:\\s-1)?)
925             (
926             \( [^\)] \)
927             )
928 0           } { '^&' . $1 . '\&' . $2 }egx;
929              
930             # Convert simple Perl variable references to a fixed-width font.
931             # s{
932             # ( \s+ )
933             # ( [\$\@%] [\w:]+ )
934             # (?! \( )
935             # } { $1 . '\f(FS' . $2 . '\f(FE'}egx;
936              
937             # Translate -- into a real em dash if it's used like one and fix up
938             # dashes, but keep hyphens hyphens.
939             # s{ (\G|^|.) (-+) (\b|.) } {
940             # my ($pre, $dash, $post) = ($1, $2, $3);
941             # if (length ($dash) == 1) {
942             # ($pre =~ /[a-zA-Z]/) ? "$pre-$post" : "$pre\\-$post";
943             # } elsif (length ($dash) == 2
944             # && ((!$pre && !$post)
945             # || ($pre =~ /\w/ && !$post)
946             # || ($pre eq ' ' && $post eq ' ')
947             # || ($pre eq '=' && $post ne '=')
948             # || ($pre ne '=' && $post eq '='))) {
949             # "$pre\\*(--$post";
950             # } else {
951             # $pre . ('\-' x length $dash) . $post;
952             # }
953             # }egxs;
954              
955             # All done.
956 0           $_;
957             }
958              
959              
960             ############################################################################
961             # Output formatting
962             ############################################################################
963              
964             # Make vertical whitespace.
965             sub makespace {
966 0     0     my $self = shift;
967 0 0         $self->output (".BREAK\n") if ($$self{ITEMS} > 1);
968 0           $$self{ITEMS} = 0;
969 0 0         $self->output ($$self{INDENT} > 0 ? ".PARAGRAPH\n" : ".PARAGRAPH\n")
    0          
970             if $$self{NEEDSPACE};
971             }
972              
973             # Output any pending index entries, and optionally an index entry given as
974             # an argument. Support multiple index entries in X<> separated by slashes,
975             # and strip special escapes from index entries.
976             sub outindex {
977 0     0 0   my ($self, $section, $index) = @_;
978 0           my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
  0            
  0            
979 0 0 0       return unless ($section || @entries);
980 0           $$self{INDEX} = [];
981 0           my $output;
982 0 0         if (@entries) {
983 0           my $output = '.INDEX '
984             . join (' ', @entries)
985             . "\n";
986             }
987 0 0         if ($section) {
988 0 0 0       if (defined($index) && $index ne '') {
989 0           $index =~ s/\\-/-/g;
990 0           $index =~ s/\\(?:s-?\d|.\(..|.)//g;
991 0           $output .= ".INDEX $section>$index\n";
992             }
993             else {
994 0           $output .= ".INDEX $section\n";
995             }
996             }
997 0           $self->output ($output);
998             }
999              
1000             # Output text to the output device.
1001 0     0 0   sub output { print { $_[0]->output_handle } $_[1] }
  0            
1002              
1003             # Given a command and a single argument that may or may not contain double
1004             # quotes, handle double-quote formatting for it. If there are no double
1005             # quotes, just return the command followed by the argument in double quotes.
1006             # If there are double quotes, use an if statement to test for nroff, and for
1007             # nroff output the command followed by the argument in double quotes with
1008             # embedded double quotes doubled. For other formatters, remap paired double
1009             # quotes to LQUOTE and RQUOTE.
1010             sub switchquotes {
1011 0     0 0   my $self = shift;
1012 0           my $command = shift;
1013 0           local $_ = shift;
1014 0           my $extra = shift;
1015 0           s/\\\*\([LR]\"/\"/g;
1016              
1017             # We also have to deal with \*C` and \*C', which are used to add the
1018             # quotes around C<> text, since they may expand to " and if they do this
1019             # confuses the .SH macros and the like no end. Expand them ourselves.
1020             # If $extra is set, we're dealing with =item, which in most nroff macro
1021             # sets requires an extra level of quoting of double quotes.
1022 0   0       my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
1023 0 0 0       if (/\"/ || ($c_is_quote && /\\\*\(C[\'\`]/)) {
      0        
1024 0           s/\"/\"\"/g;
1025 0           my $troff = $_;
1026 0           $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
1027 0           s/\\\*\(C\`/$$self{LQUOTE}/g;
1028 0           s/\\\*\(C\'/$$self{RQUOTE}/g;
1029 0           $troff =~ s/\\\*\(C[\'\`]//g;
1030 0 0         s/\"/\"\"/g if $extra;
1031 0 0         $troff =~ s/\"/\"\"/g if $extra;
1032 0 0         $_ = qq("$_") . ($extra ? " $extra" : '');
1033 0 0         $troff = qq("$troff") . ($extra ? " $extra" : '');
1034 0           return ".if n $command $_\n.el $command $troff\n";
1035             } else {
1036 0 0         $_ = qq("$_") . ($extra ? " $extra" : '');
1037 0           return "$command $_\n";
1038             }
1039             }
1040              
1041             __END__