File Coverage

blib/lib/Pod/Man.pm
Criterion Covered Total %
statement 563 597 94.3
branch 199 250 79.6
condition 85 120 70.8
subroutine 69 70 98.5
pod 5 55 9.0
total 921 1092 84.3


line stmt bran cond sub pod time code
1             # Pod::Man -- Convert POD data to formatted *roff input.
2             #
3             # This module translates POD documentation into *roff markup using the man
4             # macro set, and is intended for converting POD documents written as Unix
5             # manual pages to manual pages that can be read by the man(1) command. It is
6             # a replacement for the pod2man command distributed with versions of Perl
7             # prior to 5.6.
8             #
9             # Perl core hackers, please note that this module is also separately
10             # maintained outside of the Perl core as part of the podlators. Please send
11             # me any patches at the address above in addition to sending them to the
12             # standard Perl mailing lists.
13             #
14             # Written by Russ Allbery
15             # Substantial contributions by Sean Burke
16             # Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
17             # 2010, 2012, 2013, 2014, 2015, 2016 Russ Allbery
18             #
19             # This program is free software; you may redistribute it and/or modify it
20             # under the same terms as Perl itself.
21              
22             ##############################################################################
23             # Modules and declarations
24             ##############################################################################
25              
26             package Pod::Man;
27              
28 11     11   244452 use 5.006;
  11         31  
29 11     11   37 use strict;
  11         14  
  11         193  
30 11     11   36 use warnings;
  11         13  
  11         283  
31              
32 11     11   4557 use subs qw(makespace);
  11         618  
  11         49  
33 11     11   1384 use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
  11         13  
  11         2213  
34              
35 11     11   41 use Carp qw(carp croak);
  11         12  
  11         558  
36 11     11   5377 use Pod::Simple ();
  11         248546  
  11         451  
37              
38             # Conditionally import Encode and set $HAS_ENCODE if it is available.
39             our $HAS_ENCODE;
40             BEGIN {
41 11     11   21 $HAS_ENCODE = eval { require Encode };
  11         2567  
42             }
43              
44             @ISA = qw(Pod::Simple);
45              
46             $VERSION = '4.08';
47              
48             # Set the debugging level. If someone has inserted a debug function into this
49             # class already, use that. Otherwise, use any Pod::Simple debug function
50             # that's defined, and failing that, define a debug level of 10.
51             BEGIN {
52 11 50   11   28953 my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef;
53 11 50       43 unless (defined &DEBUG) {
54 11   50     223 *DEBUG = $parent || sub () { 10 };
55             }
56             }
57              
58             # Import the ASCII constant from Pod::Simple. This is true iff we're in an
59             # ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is
60             # generally only false for EBCDIC.
61 11     11   167 BEGIN { *ASCII = \&Pod::Simple::ASCII }
62              
63             # Pretty-print a data structure. Only used for debugging.
64 11     11   65545 BEGIN { *pretty = \&Pod::Simple::pretty }
65              
66             # Formatting instructions for various types of blocks. cleanup makes hyphens
67             # hard, adds spaces between consecutive underscores, and escapes backslashes.
68             # convert translates characters into escapes. guesswork means to apply the
69             # transformations done by the guesswork sub. literal says to protect literal
70             # quotes from being turned into UTF-8 quotes. By default, all transformations
71             # are on except literal, but some elements override.
72             #
73             # DEFAULT specifies the default settings. All other elements should list only
74             # those settings that they are overriding. Data indicates =for roff blocks,
75             # which should be passed along completely verbatim.
76             #
77             # Formatting inherits negatively, in the sense that if the parent has turned
78             # off guesswork, all child elements should leave it off.
79             my %FORMATTING = (
80             DEFAULT => { cleanup => 1, convert => 1, guesswork => 1, literal => 0 },
81             Data => { cleanup => 0, convert => 0, guesswork => 0, literal => 0 },
82             Verbatim => { guesswork => 0, literal => 1 },
83             C => { guesswork => 0, literal => 1 },
84             X => { cleanup => 0, guesswork => 0 },
85             );
86              
87             ##############################################################################
88             # Object initialization
89             ##############################################################################
90              
91             # Initialize the object and set various Pod::Simple options that we need.
92             # Here, we also process any additional options passed to the constructor or
93             # set up defaults if none were given. Note that all internal object keys are
94             # in all-caps, reserving all lower-case object keys for Pod::Simple and user
95             # arguments.
96             sub new {
97 30     30 1 36239 my $class = shift;
98 30         168 my $self = $class->SUPER::new;
99              
100             # Tell Pod::Simple not to handle S<> by automatically inserting  .
101 30         675 $self->nbsp_for_S (1);
102              
103             # Tell Pod::Simple to keep whitespace whenever possible.
104 30 50       404 if (my $preserve_whitespace = $self->can ('preserve_whitespace')) {
105 30         77 $self->$preserve_whitespace (1);
106             } else {
107 0         0 $self->fullstop_space_harden (1);
108             }
109              
110             # The =for and =begin targets that we accept.
111 30         205 $self->accept_targets (qw/man MAN roff ROFF/);
112              
113             # Ensure that contiguous blocks of code are merged together. Otherwise,
114             # some of the guesswork heuristics don't work right.
115 30         631 $self->merge_text (1);
116              
117             # Pod::Simple doesn't do anything useful with our arguments, but we want
118             # to put them in our object as hash keys and values. This could cause
119             # problems if we ever clash with Pod::Simple's own internal class
120             # variables.
121 30         303 %$self = (%$self, @_);
122              
123             # Send errors to stderr if requested.
124 30 100 66     140 if ($$self{stderr} and not $$self{errors}) {
125 1         2 $$self{errors} = 'stderr';
126             }
127 30         37 delete $$self{stderr};
128              
129             # Validate the errors parameter and act on it.
130 30 100       72 if (not defined $$self{errors}) {
131 23         44 $$self{errors} = 'pod';
132             }
133 30 100 100     202 if ($$self{errors} eq 'stderr' || $$self{errors} eq 'die') {
    100          
    50          
134 3         10 $self->no_errata_section (1);
135 3         16 $self->complain_stderr (1);
136 3 100       14 if ($$self{errors} eq 'die') {
137 1         2 $$self{complain_die} = 1;
138             }
139             } elsif ($$self{errors} eq 'pod') {
140 25         90 $self->no_errata_section (0);
141 25         164 $self->complain_stderr (0);
142             } elsif ($$self{errors} eq 'none') {
143 2         10 $self->no_whining (1);
144             } else {
145 0         0 croak (qq(Invalid errors setting: "$$self{errors}"));
146             }
147 30         120 delete $$self{errors};
148              
149             # Degrade back to non-utf8 if Encode is not available.
150             #
151             # Suppress the warning message when PERL_CORE is set, indicating this is
152             # running as part of the core Perl build. Perl builds podlators (and all
153             # pure Perl modules) before Encode and other XS modules, so Encode won't
154             # yet be available. Rely on the Perl core build to generate man pages
155             # later, after all the modules are available, so that UTF-8 handling will
156             # be correct.
157 30 100 100     91 if ($$self{utf8} and !$HAS_ENCODE) {
158 1 50       3 if (!$ENV{PERL_CORE}) {
159 1         238 carp ('utf8 mode requested but Encode module not available,'
160             . ' falling back to non-utf8');
161             }
162 1         496 delete $$self{utf8};
163             }
164              
165             # Initialize various other internal constants based on our arguments.
166 30         75 $self->init_fonts;
167 30         85 $self->init_quotes;
168 30         73 $self->init_page;
169              
170             # For right now, default to turning on all of the magic.
171 30         37 $$self{MAGIC_CPP} = 1;
172 30         40 $$self{MAGIC_EMDASH} = 1;
173 30         35 $$self{MAGIC_FUNC} = 1;
174 30         30 $$self{MAGIC_MANREF} = 1;
175 30         42 $$self{MAGIC_SMALLCAPS} = 1;
176 30         31 $$self{MAGIC_VARS} = 1;
177              
178 30         67 return $self;
179             }
180              
181             # Translate a font string into an escape.
182 120 50   120 0 414 sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
183              
184             # Determine which fonts the user wishes to use and store them in the object.
185             # Regular, italic, bold, and bold-italic are constants, but the fixed width
186             # fonts may be set by the user. Sets the internal hash key FONTS which is
187             # used to map our internal font escapes to actual *roff sequences later.
188             sub init_fonts {
189 30     30 0 35 my ($self) = @_;
190              
191             # Figure out the fixed-width font. If user-supplied, make sure that they
192             # are the right length.
193 30         66 for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
194 120         112 my $font = $$self{$_};
195 120 50 33     209 if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) {
      66        
196 0         0 croak qq(roff font should be 1 or 2 chars, not "$font");
197             }
198             }
199              
200             # Set the default fonts. We can't be sure portably across different
201             # implementations what fixed bold-italic may be called (if it's even
202             # available), so default to just bold.
203 30   100     113 $$self{fixed} ||= 'CW';
204 30   100     107 $$self{fixedbold} ||= 'CB';
205 30   100     180 $$self{fixeditalic} ||= 'CI';
206 30   100     110 $$self{fixedbolditalic} ||= 'CB';
207              
208             # Set up a table of font escapes. First number is fixed-width, second is
209             # bold, third is italic.
210             $$self{FONTS} = { '000' => '\fR', '001' => '\fI',
211             '010' => '\fB', '011' => '\f(BI',
212             '100' => toescape ($$self{fixed}),
213             '101' => toescape ($$self{fixeditalic}),
214             '110' => toescape ($$self{fixedbold}),
215 30         89 '111' => toescape ($$self{fixedbolditalic}) };
216             }
217              
218             # Initialize the quotes that we'll be using for C<> text. This requires some
219             # special handling, both to parse the user parameters if given and to make
220             # sure that the quotes will be safe against *roff. Sets the internal hash
221             # keys LQUOTE and RQUOTE.
222             sub init_quotes {
223 30     30 0 41 my ($self) = (@_);
224              
225             # Handle the quotes option first, which sets both quotes at once.
226 30   100     120 $$self{quotes} ||= '"';
227 30 50       113 if ($$self{quotes} eq 'none') {
    100          
    50          
228 0         0 $$self{LQUOTE} = $$self{RQUOTE} = '';
229             } elsif (length ($$self{quotes}) == 1) {
230 29         82 $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
231             } elsif (length ($$self{quotes}) % 2 == 0) {
232 1         3 my $length = length ($$self{quotes}) / 2;
233 1         4 $$self{LQUOTE} = substr ($$self{quotes}, 0, $length);
234 1         2 $$self{RQUOTE} = substr ($$self{quotes}, $length);
235             } else {
236 0         0 croak(qq(Invalid quote specification "$$self{quotes}"))
237             }
238              
239             # Now handle the lquote and rquote options.
240 30 100       74 if (defined $$self{lquote}) {
241 2 50       7 $$self{LQUOTE} = $$self{lquote} eq 'none' ? q{} : $$self{lquote};
242             }
243 30 100       63 if (defined $$self{rquote}) {
244 2 100       6 $$self{RQUOTE} = $$self{rquote} eq 'none' ? q{} : $$self{rquote};
245             }
246              
247             # Double the first quote; note that this should not be s///g as two double
248             # quotes is represented in *roff as three double quotes, not four. Weird,
249             # I know.
250 30         89 $$self{LQUOTE} =~ s/\"/\"\"/;
251 30         60 $$self{RQUOTE} =~ s/\"/\"\"/;
252             }
253              
254             # Initialize the page title information and indentation from our arguments.
255             sub init_page {
256 30     30 0 30 my ($self) = @_;
257              
258             # We used to try first to get the version number from a local binary, but
259             # we shouldn't need that any more. Get the version from the running Perl.
260             # Work a little magic to handle subversions correctly under both the
261             # pre-5.6 and the post-5.6 version numbering schemes.
262 30         181 my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
263 30   50     64 $version[2] ||= 0;
264 30         93 $version[2] *= 10 ** (3 - length $version[2]);
265 30         58 for (@version) { $_ += 0 }
  90         112  
266 30         74 my $version = join ('.', @version);
267              
268             # Set the defaults for page titles and indentation if the user didn't
269             # override anything.
270             $$self{center} = 'User Contributed Perl Documentation'
271 30 100       94 unless defined $$self{center};
272             $$self{release} = 'perl v' . $version
273 30 100       114 unless defined $$self{release};
274             $$self{indent} = 4
275 30 50       73 unless defined $$self{indent};
276              
277             # Double quotes in things that will be quoted.
278 30         56 for (qw/center release/) {
279 60 100       172 $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
280             }
281             }
282              
283             ##############################################################################
284             # Core parsing
285             ##############################################################################
286              
287             # This is the glue that connects the code below with Pod::Simple itself. The
288             # goal is to convert the event stream coming from the POD parser into method
289             # calls to handlers once the complete content of a tag has been seen. Each
290             # paragraph or POD command will have textual content associated with it, and
291             # as soon as all of a paragraph or POD command has been seen, that content
292             # will be passed in to the corresponding method for handling that type of
293             # object. The exceptions are handlers for lists, which have opening tag
294             # handlers and closing tag handlers that will be called right away.
295             #
296             # The internal hash key PENDING is used to store the contents of a tag until
297             # all of it has been seen. It holds a stack of open tags, each one
298             # represented by a tuple of the attributes hash for the tag, formatting
299             # options for the tag (which are inherited), and the contents of the tag.
300              
301             # Add a block of text to the contents of the current node, formatting it
302             # according to the current formatting instructions as we do.
303             sub _handle_text {
304 674     674   3231 my ($self, $text) = @_;
305 674         406 DEBUG > 3 and print "== $text\n";
306 674         569 my $tag = $$self{PENDING}[-1];
307 674         850 $$tag[2] .= $self->format_text ($$tag[1], $text);
308             }
309              
310             # Given an element name, get the corresponding method name.
311             sub method_for_element {
312 1442     1442 0 1070 my ($self, $element) = @_;
313 1442         1276 $element =~ tr/A-Z-/a-z_/;
314 1442         1160 $element =~ tr/_a-z0-9//cd;
315 1442         1743 return $element;
316             }
317              
318             # Handle the start of a new element. If cmd_element is defined, assume that
319             # we need to collect the entire tree for this element before passing it to the
320             # element method, and create a new tree into which we'll collect blocks of
321             # text and nested elements. Otherwise, if start_element is defined, call it.
322             sub _handle_element_start {
323 721     721   90520 my ($self, $element, $attrs) = @_;
324 721         498 DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n";
325 721         859 my $method = $self->method_for_element ($element);
326              
327             # If we have a command handler, we need to accumulate the contents of the
328             # tag before calling it. Turn off IN_NAME for any command other than
329             # and the formatting codes so that IN_NAME isn't still set for the
330             # first heading after the NAME heading.
331 721 100       2500 if ($self->can ("cmd_$method")) {
    100          
332 612         378 DEBUG > 2 and print "<$element> starts saving a tag\n";
333 612 100 100     1799 $$self{IN_NAME} = 0 if ($element ne 'Para' && length ($element) > 1);
334              
335             # How we're going to format embedded text blocks depends on the tag
336             # and also depends on our parent tags. Thankfully, inside tags that
337             # turn off guesswork and reformatting, nothing else can turn it back
338             # on, so this can be strictly inherited.
339             my $formatting = {
340 612 100       1696 %{ $$self{PENDING}[-1][1] || $FORMATTING{DEFAULT} },
341 612 100       422 %{ $FORMATTING{$element} || {} },
  612         2295  
342             };
343 612         741 push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]);
  612         989  
344 612         863 DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
345             } elsif (my $start_method = $self->can ("start_$method")) {
346 105         210 $self->$start_method ($attrs, '');
347             } else {
348 4         7 DEBUG > 2 and print "No $method start method, skipping\n";
349             }
350             }
351              
352             # Handle the end of an element. If we had a cmd_ method for this element,
353             # this is where we pass along the tree that we built. Otherwise, if we have
354             # an end_ method for the element, call that.
355             sub _handle_element_end {
356 721     721   5086 my ($self, $element) = @_;
357 721         465 DEBUG > 3 and print "-- $element\n";
358 721         777 my $method = $self->method_for_element ($element);
359              
360             # If we have a command handler, pull off the pending text and pass it to
361             # the handler along with the saved attribute hash.
362 721 100       2238 if (my $cmd_method = $self->can ("cmd_$method")) {
    100          
363 612         364 DEBUG > 2 and print " stops saving a tag\n";
364 612         359 my $tag = pop @{ $$self{PENDING} };
  612         630  
365 612         396 DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n";
366 612         329 DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
367 612         901 my $text = $self->$cmd_method ($$tag[0], $$tag[2]);
368 612 100       1177 if (defined $text) {
369 578 100       351 if (@{ $$self{PENDING} } > 1) {
  578         849  
370 191         519 $$self{PENDING}[-1][2] .= $text;
371             } else {
372 387         427 $self->output ($text);
373             }
374             }
375             } elsif (my $end_method = $self->can ("end_$method")) {
376 105         167 $self->$end_method ();
377             } else {
378 4         6 DEBUG > 2 and print "No $method end method, skipping\n";
379             }
380             }
381              
382             ##############################################################################
383             # General formatting
384             ##############################################################################
385              
386             # Format a text block. Takes a hash of formatting options and the text to
387             # format. Currently, the only formatting options are guesswork, cleanup, and
388             # convert, all of which are boolean.
389             sub format_text {
390 678     678 0 593 my ($self, $options, $text) = @_;
391 678   100     1697 my $guesswork = $$options{guesswork} && !$$self{IN_NAME};
392 678         481 my $cleanup = $$options{cleanup};
393 678         441 my $convert = $$options{convert};
394 678         441 my $literal = $$options{literal};
395              
396             # Cleanup just tidies up a few things, telling *roff that the hyphens are
397             # hard, putting a bit of space between consecutive underscores, and
398             # escaping backslashes. Be careful not to mangle our character
399             # translations by doing this before processing character translation.
400 678 100       848 if ($cleanup) {
401 669         716 $text =~ s/\\/\\e/g;
402 669         656 $text =~ s/-/\\-/g;
403 669         575 $text =~ s/_(?=_)/_\\|/g;
404             }
405              
406             # Normally we do character translation, but we won't even do that in
407             # blocks or if UTF-8 output is desired.
408 678 100 100     2751 if ($convert && !$$self{utf8} && ASCII) {
      100        
409 662 100       933 $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg;
  65         211  
410             }
411              
412             # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes,
413             # but don't mess up our accept escapes.
414 678 100       868 if ($literal) {
415 110         128 $text =~ s/(?
416 110         89 $text =~ s/(?
417             }
418              
419             # If guesswork is asked for, do that. This involves more substantial
420             # formatting based on various heuristics that may only be appropriate for
421             # particular documents.
422 678 100       812 if ($guesswork) {
423 540         727 $text = $self->guesswork ($text);
424             }
425              
426 678         1601 return $text;
427             }
428              
429             # Handles C<> text, deciding whether to put \*C` around it or not. This is a
430             # whole bunch of messy heuristics to try to avoid overquoting, originally from
431             # Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
432             sub quote_literal {
433 73     73 0 54 my $self = shift;
434 73         70 local $_ = shift;
435              
436             # A regex that matches the portion of a variable reference that's the
437             # array or hash index, separated out just because we want to use it in
438             # several places in the following regex.
439 73         62 my $index = '(?: \[.*\] | \{.*\} )?';
440              
441             # If in NAME section, just return an ASCII quoted string to avoid
442             # confusing tools like whatis.
443 73 100       110 return qq{"$_"} if $$self{IN_NAME};
444              
445             # Check for things that we don't want to quote, and if we find any of
446             # them, return the string with just a font change and no quoting.
447 71 100       2525 m{
448             ^\s*
449             (?:
450             ( [\'\`\"] ) .* \1 # already quoted
451             | \\\*\(Aq .* \\\*\(Aq # quoted and escaped
452             | \\?\` .* ( \' | \\\*\(Aq ) # `quoted'
453             | \$+ [\#^]? \S $index # special ($^Foo, $")
454             | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
455             | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
456             | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number
457             | 0x [a-fA-F\d]+ # a hex constant
458             )
459             \s*\z
460             }xso and return '\f(FS' . $_ . '\f(FE';
461              
462             # If we didn't return, go ahead and quote the text.
463 65         307 return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
464             }
465              
466             # Takes a text block to perform guesswork on. Returns the text block with
467             # formatting codes added. This is the code that marks up various Perl
468             # constructs and things commonly used in man pages without requiring the user
469             # to add any explicit markup, and is applied to all non-literal text. We're
470             # guaranteed that the text we're applying guesswork to does not contain any
471             # *roff formatting codes. Note that the inserted font sequences must be
472             # treated later with mapfonts or textmapfonts.
473             #
474             # This method is very fragile, both in the regular expressions it uses and in
475             # the ordering of those modifications. Care and testing is required when
476             # modifying it.
477             sub guesswork {
478 540     540 0 420 my $self = shift;
479 540         510 local $_ = shift;
480 540         371 DEBUG > 5 and print " Guesswork called on [$_]\n";
481              
482             # By the time we reach this point, all hyphens will be escaped by adding a
483             # backslash. We want to undo that escaping if they're part of regular
484             # words and there's only a single dash, since that's a real hyphen that
485             # *roff gets to consider a possible break point. Make sure that a dash
486             # after the first character of a word stays non-breaking, however.
487             #
488             # Note that this is not user-controllable; we pretty much have to do this
489             # transformation or *roff will mangle the output in unacceptable ways.
490 540         754 s{
491             ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )?
492             ( (?: [a-zA-Z\']+ \\-)+ )
493             ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) )
494             \b
495             } {
496 19         66 my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4);
497 19   50     65 $hyphen ||= '';
498 19         39 $main =~ s/\\-/-/g;
499 19         79 $prefix . $hyphen . $main . $suffix;
500             }egx;
501              
502             # Translate "--" into a real em-dash if it's used like one. This means
503             # that it's either surrounded by whitespace, it follows a regular word, or
504             # it occurs between two regular words.
505 540 50       749 if ($$self{MAGIC_EMDASH}) {
506 540         452 s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
  0         0  
507 540         471 s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
  0         0  
508             }
509              
510             # Make words in all-caps a little bit smaller; they look better that way.
511             # However, we don't want to change Perl code (like @ARGV), nor do we want
512             # to fix the MIME in MIME-Version since it looks weird with the
513             # full-height V.
514             #
515             # We change only a string of all caps (2) either at the beginning of the
516             # line or following regular punctuation (like quotes) or whitespace (1),
517             # and followed by either similar punctuation, an em-dash, or the end of
518             # the line (3).
519             #
520             # Allow the text we're changing to small caps to include double quotes,
521             # commas, newlines, and periods as long as it doesn't otherwise interrupt
522             # the string of small caps and still fits the criteria. This lets us turn
523             # entire warranty disclaimers in man page output into small caps.
524 540 50       725 if ($$self{MAGIC_SMALLCAPS}) {
525 540         2813 s{
526             ( ^ | [\s\(\"\'\`\[\{<>] | \\[ ] ) # (1)
527             ( [A-Z] [A-Z] (?: \s? [/A-Z+:\d_\$&] | \\- | \s? [.,\"] )* ) # (2)
528             (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\[ ] | $ ) # (3)
529             } {
530 74         320 $1 . '\s-1' . $2 . '\s0'
531             }egx;
532             }
533              
534             # Note that from this point forward, we have to adjust for \s-1 and \s-0
535             # strings inserted around things that we've made small-caps if later
536             # transforms should work on those strings.
537              
538             # Italicize functions in the form func(), including functions that are in
539             # all capitals, but don't italize if there's anything between the parens.
540             # The function must start with an alphabetic character or underscore and
541             # then consist of word characters or colons.
542 540 50       790 if ($$self{MAGIC_FUNC}) {
543 540         477 s{
544             ( \b | \\s-1 )
545             ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) )
546             } {
547 2         14 $1 . '\f(IS' . $2 . '\f(IE'
548             }egx;
549             }
550              
551             # Change references to manual pages to put the page name in italics but
552             # the number in the regular font, with a thin space between the name and
553             # the number. Only recognize func(n) where func starts with an alphabetic
554             # character or underscore and contains only word characters, periods (for
555             # configuration file man pages), or colons, and n is a single digit,
556             # optionally followed by some number of lowercase letters. Note that this
557             # does not recognize man page references like perl(l) or socket(3SOCKET).
558 540 50       681 if ($$self{MAGIC_MANREF}) {
559 540         592 s{
560             ( \b | \\s-1 )
561             (?
562             ( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
563             ( \( \d [a-z]* \) )
564             } {
565 0         0 $1 . '\f(IS' . $2 . '\f(IE\|' . $3
566             }egx;
567             }
568              
569             # Convert simple Perl variable references to a fixed-width font. Be
570             # careful not to convert functions, though; there are too many subtleties
571             # with them to want to perform this transformation.
572 540 50       678 if ($$self{MAGIC_VARS}) {
573 540         2146 s{
574             ( ^ | \s+ )
575             ( [\$\@%] [\w:]+ )
576             (?! \( )
577             } {
578 3         14 $1 . '\f(FS' . $2 . '\f(FE'
579             }egx;
580             }
581              
582             # Fix up double quotes. Unfortunately, we miss this transformation if the
583             # quoted text contains any code with formatting codes and there's not much
584             # we can effectively do about that, which makes it somewhat unclear if
585             # this is really a good idea.
586 540         578 s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
  47         128  
587              
588             # Make C++ into \*(C+, which is a squinched version.
589 540 50       701 if ($$self{MAGIC_CPP}) {
590 540         524 s{ \b C\+\+ } {\\*\(C+}gx;
591             }
592              
593             # Done.
594 540         330 DEBUG > 5 and print " Guesswork returning [$_]\n";
595 540         775 return $_;
596             }
597              
598             ##############################################################################
599             # Output
600             ##############################################################################
601              
602             # When building up the *roff code, we don't use real *roff fonts. Instead, we
603             # embed font codes of the form \f([SE] where is one of B, I, or
604             # F, S stands for start, and E stands for end. This method turns these into
605             # the right start and end codes.
606             #
607             # We add this level of complexity because the old pod2man didn't get code like
608             # B else> right; after I<> it switched back to normal text rather
609             # than bold. We take care of this by using variables that state whether bold,
610             # italic, or fixed are turned on as a combined pointer to our current font
611             # sequence, and set each to the number of current nestings of start tags for
612             # that font.
613             #
614             # \fP changes to the previous font, but only one previous font is kept. We
615             # don't know what the outside level font is; normally it's R, but if we're
616             # inside a heading it could be something else. So arrange things so that the
617             # outside font is always the "previous" font and end with \fP instead of \fR.
618             # Idea from Zack Weinberg.
619             sub mapfonts {
620 78     78 0 77 my ($self, $text) = @_;
621 78         87 my ($fixed, $bold, $italic) = (0, 0, 0);
622 78         198 my %magic = (F => \$fixed, B => \$bold, I => \$italic);
623 78         79 my $last = '\fR';
624 78         108 $text =~ s<
625             \\f\((.)(.)
626             > <
627 28         29 my $sequence = '';
628 28         20 my $f;
629 28 100       44 if ($last ne '\fR') { $sequence = '\fP' }
  14         13  
630 28 100       20 ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
  28         70  
631 28   100     129 $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
      50        
      100        
632 28 50       33 if ($f eq $last) {
633 0         0 '';
634             } else {
635 28 100       39 if ($f ne '\fR') { $sequence .= $f }
  14         15  
636 28         18 $last = $f;
637 28         63 $sequence;
638             }
639             >gxe;
640 78         196 return $text;
641             }
642              
643             # Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
644             # groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
645             # than R, presumably because \f(CW doesn't actually do a font change. To work
646             # around this, use a separate textmapfonts for text blocks where the default
647             # font is always R and only use the smart mapfonts for headings.
648             sub textmapfonts {
649 346     346 0 350 my ($self, $text) = @_;
650 346         295 my ($fixed, $bold, $italic) = (0, 0, 0);
651 346         720 my %magic = (F => \$fixed, B => \$bold, I => \$italic);
652 346         535 $text =~ s<
653             \\f\((.)(.)
654             > <
655 236 100       141 ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
  236         463  
656 236   100     1230 $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
      100        
      100        
657             >gxe;
658 346         682 return $text;
659             }
660              
661             # Given a command and a single argument that may or may not contain double
662             # quotes, handle double-quote formatting for it. If there are no double
663             # quotes, just return the command followed by the argument in double quotes.
664             # If there are double quotes, use an if statement to test for nroff, and for
665             # nroff output the command followed by the argument in double quotes with
666             # embedded double quotes doubled. For other formatters, remap paired double
667             # quotes to LQUOTE and RQUOTE.
668             sub switchquotes {
669 152     152 0 171 my ($self, $command, $text, $extra) = @_;
670 152         167 $text =~ s/\\\*\([LR]\"/\"/g;
671              
672             # We also have to deal with \*C` and \*C', which are used to add the
673             # quotes around C<> text, since they may expand to " and if they do this
674             # confuses the .SH macros and the like no end. Expand them ourselves.
675             # Also separate troff from nroff if there are any fixed-width fonts in use
676             # to work around problems with Solaris nroff.
677 152   66     368 my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
678 152         146 my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'};
  152         349  
679 152         391 $fixedpat =~ s/\\/\\\\/g;
680 152         303 $fixedpat =~ s/\(/\\\(/g;
681 152 100 100     983 if ($text =~ m/\"/ || $text =~ m/$fixedpat/) {
682 20         39 $text =~ s/\"/\"\"/g;
683 20         20 my $nroff = $text;
684 20         22 my $troff = $text;
685 20         51 $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
686 20 100 66     95 if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) {
687 13         46 $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
688 13         39 $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
689 13         43 $troff =~ s/\\\*\(C[\'\`]//g;
690             }
691 20 100       64 $nroff = qq("$nroff") . ($extra ? " $extra" : '');
692 20 100       44 $troff = qq("$troff") . ($extra ? " $extra" : '');
693              
694             # Work around the Solaris nroff bug where \f(CW\fP leaves the font set
695             # to Roman rather than the actual previous font when used in headings.
696             # troff output may still be broken, but at least we can fix nroff by
697             # just switching the font changes to the non-fixed versions.
698 20         48 my $font_end = "(?:\\f[PR]|\Q$$self{FONTS}{100}\E)";
699 20         157 $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f([PR])/$1/g;
700 20         126 $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)$font_end/\\fI$1\\fP/g;
701 20         95 $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)$font_end/\\fB$1\\fP/g;
702 20         80 $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)$font_end/\\f\(BI$1\\fP/g;
703              
704             # Now finally output the command. Bother with .ie only if the nroff
705             # and troff output aren't the same.
706 20 100       34 if ($nroff ne $troff) {
707 16         77 return ".ie n $command $nroff\n.el $command $troff\n";
708             } else {
709 4         17 return "$command $nroff\n";
710             }
711             } else {
712 132 100       273 $text = qq("$text") . ($extra ? " $extra" : '');
713 132         375 return "$command $text\n";
714             }
715             }
716              
717             # Protect leading quotes and periods against interpretation as commands. Also
718             # protect anything starting with a backslash, since it could expand or hide
719             # something that *roff would interpret as a command. This is overkill, but
720             # it's much simpler than trying to parse *roff here.
721             sub protect {
722 264     264 0 250 my ($self, $text) = @_;
723 264         479 $text =~ s/^([.\'\\])/\\&$1/mg;
724 264         446 return $text;
725             }
726              
727             # Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation
728             # level the situation. This function is needed since in *roff one has to
729             # create vertical whitespace after paragraphs and between some things, but
730             # other macros create their own whitespace. Also close out a sequence of
731             # repeated =items, since calling makespace means we're about to begin the item
732             # body.
733             sub makespace {
734 285     285   230 my ($self) = @_;
735 285 100       474 $self->output (".PD\n") if $$self{ITEMS} > 1;
736 285         223 $$self{ITEMS} = 0;
737             $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n")
738 285 100       637 if $$self{NEEDSPACE};
    100          
739             }
740              
741             # Output any pending index entries, and optionally an index entry given as an
742             # argument. Support multiple index entries in X<> separated by slashes, and
743             # strip special escapes from index entries.
744             sub outindex {
745 391     391 0 366 my ($self, $section, $index) = @_;
746 391         289 my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
  5         22  
  391         552  
747 391 100 100     1226 return unless ($section || @entries);
748              
749             # We're about to output all pending entries, so clear our pending queue.
750 118         132 $$self{INDEX} = [];
751              
752             # Build the output. Regular index entries are marked Xref, and headings
753             # pass in their own section. Undo some *roff formatting on headings.
754 118         101 my @output;
755 118 100       171 if (@entries) {
756 5         14 push @output, [ 'Xref', join (' ', @entries) ];
757             }
758 118 100       188 if ($section) {
759 113         124 $index =~ s/\\-/-/g;
760 113         214 $index =~ s/\\(?:s-?\d|.\(..|.)//g;
761 113         176 push @output, [ $section, $index ];
762             }
763              
764             # Print out the .IX commands.
765 118         157 for (@output) {
766 118         151 my ($type, $entry) = @$_;
767 118         339 $entry =~ s/\s+/ /g;
768 118         120 $entry =~ s/\"/\"\"/g;
769 118         100 $entry =~ s/\\/\\\\/g;
770 118         292 $self->output (".IX $type " . '"' . $entry . '"' . "\n");
771             }
772             }
773              
774             # Output some text, without any additional changes.
775             sub output {
776 1213     1213 0 1293 my ($self, @text) = @_;
777 1213 100       1677 if ($$self{ENCODE}) {
778 18         14 print { $$self{output_fh} } Encode::encode ('UTF-8', join ('', @text));
  18         55  
779             } else {
780 1195         733 print { $$self{output_fh} } @text;
  1195         2763  
781             }
782             }
783              
784             ##############################################################################
785             # Document initialization
786             ##############################################################################
787              
788             # Handle the start of the document. Here we handle empty documents, as well
789             # as setting up our basic macros in a preamble and building the page title.
790             sub start_document {
791 63     63 0 59 my ($self, $attrs) = @_;
792 63 100 66     163 if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
793 1         2 DEBUG and print "Document is contentless\n";
794 1         2 $$self{CONTENTLESS} = 1;
795             } else {
796 62         71 delete $$self{CONTENTLESS};
797             }
798              
799             # When UTF-8 output is set, check whether our output file handle already
800             # has a PerlIO encoding layer set. If it does not, we'll need to encode
801             # our output before printing it (handled in the output() sub). Wrap the
802             # check in an eval to handle versions of Perl without PerlIO.
803 63         69 $$self{ENCODE} = 0;
804 63 100       107 if ($$self{utf8}) {
805 4         10 $$self{ENCODE} = 1;
806 4         6 eval {
807 4         13 my @options = (output => 1, details => 1);
808 4         32 my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1];
809 4 100       26 if ($flag & PerlIO::F_UTF8 ()) {
810 2         7 $$self{ENCODE} = 0;
811             }
812             }
813             }
814              
815             # Determine information for the preamble and then output it unless the
816             # document was content-free.
817 63 100       114 if (!$$self{CONTENTLESS}) {
818 62         55 my ($name, $section);
819 62 100       98 if (defined $$self{name}) {
820 20         24 $name = $$self{name};
821 20   100     70 $section = $$self{section} || 1;
822             } else {
823 42         64 ($name, $section) = $self->devise_title;
824             }
825 62 100       195 my $date = defined($$self{date}) ? $$self{date} : $self->devise_date;
826 62 50 50     169 $self->preamble ($name, $section, $date)
827             unless $self->bare_output or DEBUG > 9;
828             }
829              
830             # Initialize a few per-document variables.
831 63         78 $$self{INDENT} = 0; # Current indentation level.
832 63         82 $$self{INDENTS} = []; # Stack of indentations.
833 63         99 $$self{INDEX} = []; # Index keys waiting to be printed.
834 63         73 $$self{IN_NAME} = 0; # Whether processing the NAME section.
835 63         54 $$self{ITEMS} = 0; # The number of consecutive =items.
836 63         66 $$self{ITEMTYPES} = []; # Stack of =item types, one per list.
837 63         64 $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting.
838 63         58 $$self{SHIFTS} = []; # Stack of .RS shifts.
839 63         178 $$self{PENDING} = [[]]; # Pending output.
840             }
841              
842             # Handle the end of the document. This handles dying on POD errors, since
843             # Pod::Parser currently doesn't. Otherwise, does nothing but print out a
844             # final comment at the end of the document under debugging.
845             sub end_document {
846 63     63 0 62 my ($self) = @_;
847 63 100 66     153 if ($$self{complain_die} && $self->errors_seen) {
848 1         264 croak ("POD document had syntax errors");
849             }
850 62 50       144 return if $self->bare_output;
851 62 100 66     427 return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING});
852 61         102 $self->output (q(.\" [End document]) . "\n") if DEBUG;
853             }
854              
855             # Try to figure out the name and section from the file name and return them as
856             # a list, returning an empty name and section 1 if we can't find any better
857             # information. Uses File::Basename and File::Spec as necessary.
858             sub devise_title {
859 44     44 0 1114 my ($self) = @_;
860 44   100     95 my $name = $self->source_filename || '';
861 44   50     355 my $section = $$self{section} || 1;
862 44 100 66     214 $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
863 44         138 $name =~ s/\.p(od|[lm])\z//i;
864              
865             # If Pod::Parser gave us an IO::File reference as the source file name,
866             # convert that to the empty string as well. Then, if we don't have a
867             # valid name, convert it to STDIN.
868             #
869             # In podlators 4.00 through 4.07, this also produced a warning, but that
870             # was surprising to a lot of programs that had expected to be able to pipe
871             # POD through pod2man without specifying the name. In the name of
872             # backward compatibility, just quietly set STDIN as the page title.
873 44 100       84 if ($name =~ /^IO::File(?:=\w+)\(0x[\da-f]+\)$/i) {
874 2         3 $name = '';
875             }
876 44 100       67 if ($name eq '') {
877 5         6 $name = 'STDIN';
878             }
879              
880             # If the section isn't 3, then the name defaults to just the basename of
881             # the file.
882 44 100       81 if ($section !~ /^3/) {
883 43         197 require File::Basename;
884 43         1017 $name = uc File::Basename::basename ($name);
885             } else {
886 1         6 require File::Spec;
887 1         24 my ($volume, $dirs, $file) = File::Spec->splitpath ($name);
888              
889             # Otherwise, assume we're dealing with a module. We want to figure
890             # out the full module name from the path to the file, but we don't
891             # want to include too much of the path into the module name. Lose
892             # anything up to the first of:
893             #
894             # */lib/*perl*/ standard or site_perl module
895             # */*perl*/lib/ from -Dprefix=/opt/perl
896             # */*perl*/ random module hierarchy
897             #
898             # Also strip off a leading site, site_perl, or vendor_perl component,
899             # any OS-specific component, and any version number component, and
900             # strip off an initial component of "lib" or "blib/lib" since that's
901             # what ExtUtils::MakeMaker creates.
902             #
903             # splitdir requires at least File::Spec 0.8.
904 1         11 my @dirs = File::Spec->splitdir ($dirs);
905 1 50       6 if (@dirs) {
906 0         0 my $cut = 0;
907 0         0 my $i;
908 0         0 for ($i = 0; $i < @dirs; $i++) {
909 0 0       0 if ($dirs[$i] =~ /perl/) {
910 0         0 $cut = $i + 1;
911 0 0 0     0 $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib');
912 0         0 last;
913             }
914             }
915 0 0       0 if ($cut > 0) {
916 0         0 splice (@dirs, 0, $cut);
917 0 0       0 shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/);
918 0 0       0 shift @dirs if ($dirs[0] =~ /^[\d.]+$/);
919 0 0       0 shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/);
920             }
921 0 0       0 shift @dirs if $dirs[0] eq 'lib';
922 0 0 0     0 splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib');
923             }
924              
925             # Remove empty directories when building the module name; they
926             # occur too easily on Unix by doubling slashes.
927 1 0       4 $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file);
  0         0  
928             }
929 44         95 return ($name, $section);
930             }
931              
932             # Determine the modification date and return that, properly formatted in ISO
933             # format.
934             #
935             # If POD_MAN_DATE is set, that overrides anything else. This can be used for
936             # reproducible generation of the same file even if the input file timestamps
937             # are unpredictable or the POD coms from standard input.
938             #
939             # Otherwise, if SOURCE_DATE_EPOCH is set and can be parsed as seconds since
940             # the UNIX epoch, base the timestamp on that. See
941             #
942             #
943             # Otherwise, use the modification date of the input if we can stat it. Be
944             # aware that Pod::Simple returns the stringification of the file handle as
945             # source_filename for input from a file handle, so we'll stat some random ref
946             # string in that case. If that fails, instead use the current time.
947             #
948             # $self - Pod::Man object, used to get the source file
949             #
950             # Returns: YYYY-MM-DD date suitable for the left-hand footer
951             sub devise_date {
952 64     64 0 71 my ($self) = @_;
953              
954             # If POD_MAN_DATE is set, always use it.
955 64 100       126 if (defined($ENV{POD_MAN_DATE})) {
956 3         10 return $ENV{POD_MAN_DATE};
957             }
958              
959             # If SOURCE_DATE_EPOCH is set and can be parsed, use that.
960 61         52 my $time;
961 61 100 100     137 if (defined($ENV{SOURCE_DATE_EPOCH}) && $ENV{SOURCE_DATE_EPOCH} !~ /\D/) {
962 1         2 $time = $ENV{SOURCE_DATE_EPOCH};
963             }
964              
965             # Otherwise, get the input filename and try to stat it. If that fails,
966             # use the current time.
967 61 100       105 if (!defined $time) {
968 60         125 my $input = $self->source_filename;
969 60 100       296 if ($input) {
970 43   66     508 $time = (stat($input))[9] || time();
971             } else {
972 17         33 $time = time();
973             }
974             }
975              
976             # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker uses
977             # this and it has to work in the core which can't load dynamic libraries.
978             # Use gmtime instead of localtime so that the generated man page does not
979             # depend on the local time zone setting and is more reproducible
980 61         344 my ($year, $month, $day) = (gmtime($time))[5,4,3];
981 61         469 return sprintf("%04d-%02d-%02d", $year + 1900, $month + 1, $day);
982             }
983              
984             # Print out the preamble and the title. The meaning of the arguments to .TH
985             # unfortunately vary by system; some systems consider the fourth argument to
986             # be a "source" and others use it as a version number. Generally it's just
987             # presented as the left-side footer, though, so it doesn't matter too much if
988             # a particular system gives it another interpretation.
989             #
990             # The order of date and release used to be reversed in older versions of this
991             # module, but this order is correct for both Solaris and Linux.
992             sub preamble {
993 62     62 0 493 my ($self, $name, $section, $date) = @_;
994 62         125 my $preamble = $self->preamble_template (!$$self{utf8});
995              
996             # Build the index line and make sure that it will be syntactically valid.
997 62         87 my $index = "$name $section";
998 62         83 $index =~ s/\"/\"\"/g;
999              
1000             # If name or section contain spaces, quote them (section really never
1001             # should, but we may as well be cautious).
1002 62         97 for ($name, $section) {
1003 124 50       252 if (/\s/) {
1004 0         0 s/\"/\"\"/g;
1005 0         0 $_ = '"' . $_ . '"';
1006             }
1007             }
1008              
1009             # Double quotes in date, since it will be quoted.
1010 62         69 $date =~ s/\"/\"\"/g;
1011              
1012             # Substitute into the preamble the configuration options.
1013 62         405 $preamble =~ s/\@CFONT\@/$$self{fixed}/;
1014 62         313 $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/;
1015 62         315 $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/;
1016 62         77 chomp $preamble;
1017              
1018             # Get the version information.
1019 62         167 my $version = $self->version_report;
1020              
1021             # Finally output everything.
1022 62         1370 $self->output (<<"----END OF HEADER----");
1023             .\\" Automatically generated by $version
1024             .\\"
1025             .\\" Standard preamble:
1026             .\\" ========================================================================
1027             $preamble
1028             .\\" ========================================================================
1029             .\\"
1030             .IX Title "$index"
1031             .TH $name $section "$date" "$$self{release}" "$$self{center}"
1032             .\\" For nroff, turn off justification. Always turn off hyphenation; it makes
1033             .\\" way too many mistakes in technical documents.
1034             .if n .ad l
1035             .nh
1036             ----END OF HEADER----
1037 62         341 $self->output (".\\\" [End of preamble]\n") if DEBUG;
1038             }
1039              
1040             ##############################################################################
1041             # Text blocks
1042             ##############################################################################
1043              
1044             # Handle a basic block of text. The only tricky part of this is if this is
1045             # the first paragraph of text after an =over, in which case we have to change
1046             # indentations for *roff.
1047             sub cmd_para {
1048 244     244 0 253 my ($self, $attrs, $text) = @_;
1049 244         213 my $line = $$attrs{start_line};
1050              
1051             # Output the paragraph. We also have to handle =over without =item. If
1052             # there's an =over without =item, SHIFTWAIT will be set, and we need to
1053             # handle creation of the indent here. Add the shift to SHIFTS so that it
1054             # will be cleaned up on =back.
1055 244         340 $self->makespace;
1056 244 100       891 if ($$self{SHIFTWAIT}) {
1057 4         10 $self->output (".RS $$self{INDENT}\n");
1058 4         15 push (@{ $$self{SHIFTS} }, $$self{INDENT});
  4         7  
1059 4         6 $$self{SHIFTWAIT} = 0;
1060             }
1061              
1062             # Add the line number for debugging, but not in the NAME section just in
1063             # case the comment would confuse apropos.
1064             $self->output (".\\\" [At source line $line]\n")
1065 244 50 50     812 if defined ($line) && DEBUG && !$$self{IN_NAME};
      33        
1066              
1067             # Force exactly one newline at the end and strip unwanted trailing
1068             # whitespace at the end, but leave "\ " backslashed space from an S< > at
1069             # the end of a line. Reverse the text first, to avoid having to scan the
1070             # entire paragraph.
1071 244         337 $text = reverse $text;
1072 244         760 $text =~ s/\A\s*?(?= \\|\S|\z)/\n/;
1073 244         314 $text = reverse $text;
1074              
1075             # Output the paragraph.
1076 244         370 $self->output ($self->protect ($self->textmapfonts ($text)));
1077 244         1169 $self->outindex;
1078 244         238 $$self{NEEDSPACE} = 1;
1079 244         266 return '';
1080             }
1081              
1082             # Handle a verbatim paragraph. Put a null token at the beginning of each line
1083             # to protect against commands and wrap in .Vb/.Ve (which we define in our
1084             # prelude).
1085             sub cmd_verbatim {
1086 13     13 0 17 my ($self, $attrs, $text) = @_;
1087              
1088             # Ignore an empty verbatim paragraph.
1089 13 50       48 return unless $text =~ /\S/;
1090              
1091             # Force exactly one newline at the end and strip unwanted trailing
1092             # whitespace at the end. Reverse the text first, to avoid having to scan
1093             # the entire paragraph.
1094 13         27 $text = reverse $text;
1095 13         36 $text =~ s/\A\s*/\n/;
1096 13         23 $text = reverse $text;
1097              
1098             # Get a count of the number of lines before the first blank line, which
1099             # we'll pass to .Vb as its parameter. This tells *roff to keep that many
1100             # lines together. We don't want to tell *roff to keep huge blocks
1101             # together.
1102 13         44 my @lines = split (/\n/, $text);
1103 13         15 my $unbroken = 0;
1104 13         20 for (@lines) {
1105 61 100       102 last if /^\s*$/;
1106 57         46 $unbroken++;
1107             }
1108 13 50 33     36 $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT});
1109              
1110             # Prepend a null token to each line.
1111 13         67 $text =~ s/^/\\&/gm;
1112              
1113             # Output the results.
1114 13         30 $self->makespace;
1115 13         102 $self->output (".Vb $unbroken\n$text.Ve\n");
1116 13         76 $$self{NEEDSPACE} = 1;
1117 13         23 return '';
1118             }
1119              
1120             # Handle literal text (produced by =for and similar constructs). Just output
1121             # it with the minimum of changes.
1122             sub cmd_data {
1123 4     4 0 3 my ($self, $attrs, $text) = @_;
1124 4         10 $text =~ s/^\n+//;
1125 4         13 $text =~ s/\n{0,2}$/\n/;
1126 4         6 $self->output ($text);
1127 4         4 return '';
1128             }
1129              
1130             ##############################################################################
1131             # Headings
1132             ##############################################################################
1133              
1134             # Common code for all headings. This is called before the actual heading is
1135             # output. It returns the cleaned up heading text (putting the heading all on
1136             # one line) and may do other things, like closing bad =item blocks.
1137             sub heading_common {
1138 86     86 0 83 my ($self, $text, $line) = @_;
1139 86         170 $text =~ s/\s+$//;
1140 86         79 $text =~ s/\s*\n\s*/ /g;
1141              
1142             # This should never happen; it means that we have a heading after =item
1143             # without an intervening =back. But just in case, handle it anyway.
1144 86 50       174 if ($$self{ITEMS} > 1) {
1145 0         0 $$self{ITEMS} = 0;
1146 0         0 $self->output (".PD\n");
1147             }
1148              
1149             # Output the current source line.
1150 86 50 50     283 $self->output ( ".\\\" [At source line $line]\n" )
1151             if defined ($line) && DEBUG;
1152 86         145 return $text;
1153             }
1154              
1155             # First level heading. We can't output .IX in the NAME section due to a bug
1156             # in some versions of catman, so don't output a .IX for that section. .SH
1157             # already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as
1158             # appropriate.
1159             sub cmd_head1 {
1160 73     73 0 75 my ($self, $attrs, $text) = @_;
1161 73         265 $text =~ s/\\s-?\d//g;
1162 73         163 $text = $self->heading_common ($text, $$attrs{start_line});
1163 73   66     239 my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/);
1164 73         141 $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text)));
1165 73 100       486 $self->outindex ('Header', $text) unless $isname;
1166 73         279 $$self{NEEDSPACE} = 0;
1167 73         79 $$self{IN_NAME} = $isname;
1168 73         80 return '';
1169             }
1170              
1171             # Second level heading.
1172             sub cmd_head2 {
1173 5     5 0 9 my ($self, $attrs, $text) = @_;
1174 5         11 $text = $self->heading_common ($text, $$attrs{start_line});
1175 5         12 $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text)));
1176 5         28 $self->outindex ('Subsection', $text);
1177 5         23 $$self{NEEDSPACE} = 0;
1178 5         39 return '';
1179             }
1180              
1181             # Third level heading. *roff doesn't have this concept, so just put the
1182             # heading in italics as a normal paragraph.
1183             sub cmd_head3 {
1184 4     4 0 5 my ($self, $attrs, $text) = @_;
1185 4         11 $text = $self->heading_common ($text, $$attrs{start_line});
1186 4         10 $self->makespace;
1187 4         19 $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n");
1188 4         28 $self->outindex ('Subsection', $text);
1189 4         22 $$self{NEEDSPACE} = 1;
1190 4         6 return '';
1191             }
1192              
1193             # Fourth level heading. *roff doesn't have this concept, so just put the
1194             # heading as a normal paragraph.
1195             sub cmd_head4 {
1196 4     4 0 6 my ($self, $attrs, $text) = @_;
1197 4         10 $text = $self->heading_common ($text, $$attrs{start_line});
1198 4         10 $self->makespace;
1199 4         24 $self->output ($self->textmapfonts ($text) . "\n");
1200 4         23 $self->outindex ('Subsection', $text);
1201 4         22 $$self{NEEDSPACE} = 1;
1202 4         6 return '';
1203             }
1204              
1205             ##############################################################################
1206             # Formatting codes
1207             ##############################################################################
1208              
1209             # All of the formatting codes that aren't handled internally by the parser,
1210             # other than L<> and X<>.
1211 17 100   17 0 55 sub cmd_b { return $_[0]->{IN_NAME} ? $_[2] : '\f(BS' . $_[2] . '\f(BE' }
1212 31 100   31 0 86 sub cmd_i { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
1213 7 100   7 0 24 sub cmd_f { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' }
1214 73     73 0 101 sub cmd_c { return $_[0]->quote_literal ($_[2]) }
1215              
1216             # Index entries are just added to the pending entries.
1217             sub cmd_x {
1218 5     5 0 9 my ($self, $attrs, $text) = @_;
1219 5         5 push (@{ $$self{INDEX} }, $text);
  5         15  
1220 5         9 return '';
1221             }
1222              
1223             # Links reduce to the text that we're given, wrapped in angle brackets if it's
1224             # a URL, followed by the URL. We take an option to suppress the URL if anchor
1225             # text is given. We need to format the "to" value of the link before
1226             # comparing it to the text since we may escape hyphens.
1227             sub cmd_l {
1228 58     58 0 59 my ($self, $attrs, $text) = @_;
1229 58 100       86 if ($$attrs{type} eq 'url') {
1230 4         5 my $to = $$attrs{to};
1231 4 50       8 if (defined $to) {
1232 4         8 my $tag = $$self{PENDING}[-1];
1233 4         8 $to = $self->format_text ($$tag[1], $to);
1234             }
1235 4 100 66     18 if (not defined ($to) or $to eq $text) {
    100          
1236 1         4 return "<$text>";
1237             } elsif ($$self{nourls}) {
1238 1         12 return $text;
1239             } else {
1240 2         23 return "$text <$$attrs{to}>";
1241             }
1242             } else {
1243 54         123 return $text;
1244             }
1245             }
1246              
1247             ##############################################################################
1248             # List handling
1249             ##############################################################################
1250              
1251             # Handle the beginning of an =over block. Takes the type of the block as the
1252             # first argument, and then the attr hash. This is called by the handlers for
1253             # the four different types of lists (bullet, number, text, and block).
1254             sub over_common_start {
1255 42     42 0 42 my ($self, $type, $attrs) = @_;
1256 42         41 my $line = $$attrs{start_line};
1257 42         40 my $indent = $$attrs{indent};
1258 42         31 DEBUG > 3 and print " Starting =over $type (line $line, indent ",
1259             ($indent || '?'), "\n";
1260              
1261             # Find the indentation level.
1262 42 50 33     219 unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) {
1263 0         0 $indent = $$self{indent};
1264             }
1265              
1266             # If we've gotten multiple indentations in a row, we need to emit the
1267             # pending indentation for the last level that we saw and haven't acted on
1268             # yet. SHIFTS is the stack of indentations that we've actually emitted
1269             # code for.
1270 42 100       34 if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
  42         53  
  42         76  
1271 7         16 $self->output (".RS $$self{INDENT}\n");
1272 7         31 push (@{ $$self{SHIFTS} }, $$self{INDENT});
  7         14  
1273             }
1274              
1275             # Now, do record-keeping. INDENTS is a stack of indentations that we've
1276             # seen so far, and INDENT is the current level of indentation. ITEMTYPES
1277             # is a stack of list types that we've seen.
1278 42         37 push (@{ $$self{INDENTS} }, $$self{INDENT});
  42         67  
1279 42         30 push (@{ $$self{ITEMTYPES} }, $type);
  42         52  
1280 42         120 $$self{INDENT} = $indent + 0;
1281 42         85 $$self{SHIFTWAIT} = 1;
1282             }
1283              
1284             # End an =over block. Takes no options other than the class pointer.
1285             # Normally, once we close a block and therefore remove something from INDENTS,
1286             # INDENTS will now be longer than SHIFTS, indicating that we also need to emit
1287             # *roff code to close the indent. This isn't *always* true, depending on the
1288             # circumstance. If we're still inside an indentation, we need to emit another
1289             # .RE and then a new .RS to unconfuse *roff.
1290             sub over_common_end {
1291 42     42 0 40 my ($self) = @_;
1292 42         32 DEBUG > 3 and print " Ending =over\n";
1293 42         27 $$self{INDENT} = pop @{ $$self{INDENTS} };
  42         70  
1294 42         30 pop @{ $$self{ITEMTYPES} };
  42         46  
1295              
1296             # If we emitted code for that indentation, end it.
1297 42 100       27 if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
  42         41  
  42         82  
1298 9         14 $self->output (".RE\n");
1299 9         40 pop @{ $$self{SHIFTS} };
  9         13  
1300             }
1301              
1302             # If we're still in an indentation, *roff will have now lost track of the
1303             # right depth of that indentation, so fix that.
1304 42 100       37 if (@{ $$self{INDENTS} } > 0) {
  42         79  
1305 9         15 $self->output (".RE\n");
1306 9         86 $self->output (".RS $$self{INDENT}\n");
1307             }
1308 42         65 $$self{NEEDSPACE} = 1;
1309 42         95 $$self{SHIFTWAIT} = 0;
1310             }
1311              
1312             # Dispatch the start and end calls as appropriate.
1313 6     6 0 8 sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) }
  6         15  
1314 4     4 0 6 sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) }
  4         8  
1315 26     26 0 26 sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) }
  26         57  
1316 6     6 0 7 sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) }
  6         10  
1317 6     6 0 20 sub end_over_bullet { $_[0]->over_common_end }
1318 4     4 0 9 sub end_over_number { $_[0]->over_common_end }
1319 26     26 0 46 sub end_over_text { $_[0]->over_common_end }
1320 6     6 0 11 sub end_over_block { $_[0]->over_common_end }
1321              
1322             # The common handler for all item commands. Takes the type of the item, the
1323             # attributes, and then the text of the item.
1324             #
1325             # Emit an index entry for anything that's interesting, but don't emit index
1326             # entries for things like bullets and numbers. Newlines in an item title are
1327             # turned into spaces since *roff can't handle them embedded.
1328             sub item_common {
1329 74     74 0 75 my ($self, $type, $attrs, $text) = @_;
1330 74         71 my $line = $$attrs{start_line};
1331 74         42 DEBUG > 3 and print " $type item (line $line): $text\n";
1332              
1333             # Clean up the text. We want to end up with two variables, one ($text)
1334             # which contains any body text after taking out the item portion, and
1335             # another ($item) which contains the actual item text.
1336 74         133 $text =~ s/\s+$//;
1337 74         50 my ($item, $index);
1338 74 100       142 if ($type eq 'bullet') {
    100          
1339 12         10 $item = "\\\(bu";
1340 12         67 $text =~ s/\n*$/\n/;
1341             } elsif ($type eq 'number') {
1342 8         10 $item = $$attrs{number} . '.';
1343             } else {
1344 54         43 $item = $text;
1345 54         61 $item =~ s/\s*\n\s*/ /g;
1346 54         45 $text = '';
1347 54 100       126 $index = $item if ($item =~ /\w/);
1348             }
1349              
1350             # Take care of the indentation. If shifts and indents are equal, close
1351             # the top shift, since we're about to create an indentation with .IP.
1352             # Also output .PD 0 to turn off spacing between items if this item is
1353             # directly following another one. We only have to do that once for a
1354             # whole chain of items so do it for the second item in the change. Note
1355             # that makespace is what undoes this.
1356 74 100       67 if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
  74         79  
  74         118  
1357 2         5 $self->output (".RE\n");
1358 2         9 pop @{ $$self{SHIFTS} };
  2         4  
1359             }
1360 74 100       117 $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
1361              
1362             # Now, output the item tag itself.
1363 74         131 $item = $self->textmapfonts ($item);
1364 74         152 $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT}));
1365 74         389 $$self{NEEDSPACE} = 0;
1366 74         56 $$self{ITEMS}++;
1367 74         59 $$self{SHIFTWAIT} = 0;
1368              
1369             # If body text for this item was included, go ahead and output that now.
1370 74 100       104 if ($text) {
1371 20         103 $text =~ s/\s*$/\n/;
1372 20         28 $self->makespace;
1373 20         28 $self->output ($self->protect ($self->textmapfonts ($text)));
1374 20         73 $$self{NEEDSPACE} = 1;
1375             }
1376 74 100       131 $self->outindex ($index ? ('Item', $index) : ());
1377             }
1378              
1379             # Dispatch the item commands to the appropriate place.
1380 12     12 0 12 sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
  12         23  
1381 8     8 0 10 sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
  8         14  
1382 54     54 0 49 sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
  54         91  
1383 0     0 0 0 sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
  0         0  
1384              
1385             ##############################################################################
1386             # Backward compatibility
1387             ##############################################################################
1388              
1389             # Reset the underlying Pod::Simple object between calls to parse_from_file so
1390             # that the same object can be reused to convert multiple pages.
1391             sub parse_from_file {
1392 41     41 1 33095 my $self = shift;
1393 41         127 $self->reinit;
1394              
1395             # Fake the old cutting option to Pod::Parser. This fiddings with internal
1396             # Pod::Simple state and is quite ugly; we need a better approach.
1397 41 100       751 if (ref ($_[0]) eq 'HASH') {
1398 1         2 my $opts = shift @_;
1399 1 50 33     12 if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
1400 1         2 $$self{in_pod} = 1;
1401 1         3 $$self{last_was_blank} = 1;
1402             }
1403             }
1404              
1405             # Do the work.
1406 41         129 my $retval = $self->SUPER::parse_from_file (@_);
1407              
1408             # Flush output, since Pod::Simple doesn't do this. Ideally we should also
1409             # close the file descriptor if we had to open one, but we can't easily
1410             # figure this out.
1411 41         777 my $fh = $self->output_fh ();
1412 41         221 my $oldfh = select $fh;
1413 41         58 my $oldflush = $|;
1414 41         917 $| = 1;
1415 41         60 print $fh '';
1416 41         63 $| = $oldflush;
1417 41         96 select $oldfh;
1418 41         75 return $retval;
1419             }
1420              
1421             # Pod::Simple failed to provide this backward compatibility function, so
1422             # implement it ourselves. File handles are one of the inputs that
1423             # parse_from_file supports.
1424             sub parse_from_filehandle {
1425 1     1 0 4 my $self = shift;
1426 1         3 return $self->parse_from_file (@_);
1427             }
1428              
1429             # Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so
1430             # ourself unless it was already set by the caller, since our documentation has
1431             # always said that this should work.
1432             sub parse_file {
1433 43     43 1 4091 my ($self, $in) = @_;
1434 43 50       88 unless (defined $$self{output_fh}) {
1435 0         0 $self->output_fh (\*STDOUT);
1436             }
1437 43         91 return $self->SUPER::parse_file ($in);
1438             }
1439              
1440             # Do the same for parse_lines, just to be polite. Pod::Simple's man page
1441             # implies that the caller is responsible for setting this, but I don't see any
1442             # reason not to set a default.
1443             sub parse_lines {
1444 197     197 1 1167381 my ($self, @lines) = @_;
1445 197 50       390 unless (defined $$self{output_fh}) {
1446 0         0 $self->output_fh (\*STDOUT);
1447             }
1448 197         429 return $self->SUPER::parse_lines (@lines);
1449             }
1450              
1451             # Likewise for parse_string_document.
1452             sub parse_string_document {
1453 21     21 1 17001 my ($self, $doc) = @_;
1454 21 50       47 unless (defined $$self{output_fh}) {
1455 0         0 $self->output_fh (\*STDOUT);
1456             }
1457 21         70 return $self->SUPER::parse_string_document ($doc);
1458             }
1459              
1460             ##############################################################################
1461             # Translation tables
1462             ##############################################################################
1463              
1464             # The following table is adapted from Tom Christiansen's pod2man. It assumes
1465             # that the standard preamble has already been printed, since that's what
1466             # defines all of the accent marks. We really want to do something better than
1467             # this when *roff actually supports other character sets itself, since these
1468             # results are pretty poor.
1469             #
1470             # This only works in an ASCII world. What to do in a non-ASCII world is very
1471             # unclear -- hopefully we can assume UTF-8 and just leave well enough alone.
1472             @ESCAPES{0xA0 .. 0xFF} = (
1473             "\\ ", undef, undef, undef, undef, undef, undef, undef,
1474             undef, undef, undef, undef, undef, "\\%", undef, undef,
1475              
1476             undef, undef, undef, undef, undef, undef, undef, undef,
1477             undef, undef, undef, undef, undef, undef, undef, undef,
1478              
1479             "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(Ae", "C\\*,",
1480             "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:",
1481              
1482             "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef,
1483             "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8",
1484              
1485             "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,",
1486             "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:",
1487              
1488             "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef,
1489             "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:",
1490             ) if ASCII;
1491              
1492             ##############################################################################
1493             # Premable
1494             ##############################################################################
1495              
1496             # The following is the static preamble which starts all *roff output we
1497             # generate. Most is static except for the font to use as a fixed-width font,
1498             # which is designed by @CFONT@, and the left and right quotes to use for C<>
1499             # text, designated by @LQOUTE@ and @RQUOTE@. However, the second part, which
1500             # defines the accent marks, is only used if $escapes is set to true.
1501             sub preamble_template {
1502 62     62 0 67 my ($self, $accents) = @_;
1503 62         54 my $preamble = <<'----END OF PREAMBLE----';
1504             .de Sp \" Vertical space (when we can't use .PP)
1505             .if t .sp .5v
1506             .if n .sp
1507             ..
1508             .de Vb \" Begin verbatim text
1509             .ft @CFONT@
1510             .nf
1511             .ne \\$1
1512             ..
1513             .de Ve \" End verbatim text
1514             .ft R
1515             .fi
1516             ..
1517             .\" Set up some character translations and predefined strings. \*(-- will
1518             .\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
1519             .\" double quote, and \*(R" will give a right double quote. \*(C+ will
1520             .\" give a nicer C++. Capital omega is used to do unbreakable dashes and
1521             .\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff,
1522             .\" nothing in troff, for use with C<>.
1523             .tr \(*W-
1524             .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
1525             .ie n \{\
1526             . ds -- \(*W-
1527             . ds PI pi
1528             . if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
1529             . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
1530             . ds L" ""
1531             . ds R" ""
1532             . ds C` @LQUOTE@
1533             . ds C' @RQUOTE@
1534             'br\}
1535             .el\{\
1536             . ds -- \|\(em\|
1537             . ds PI \(*p
1538             . ds L" ``
1539             . ds R" ''
1540             . ds C`
1541             . ds C'
1542             'br\}
1543             .\"
1544             .\" Escape single quotes in literal strings from groff's Unicode transform.
1545             .ie \n(.g .ds Aq \(aq
1546             .el .ds Aq '
1547             .\"
1548             .\" If the F register is >0, we'll generate index entries on stderr for
1549             .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index
1550             .\" entries marked with X<> in POD. Of course, you'll have to process the
1551             .\" output yourself in some meaningful fashion.
1552             .\"
1553             .\" Avoid warning from groff about undefined register 'F'.
1554             .de IX
1555             ..
1556             .if !\nF .nr F 0
1557             .if \nF>0 \{\
1558             . de IX
1559             . tm Index:\\$1\t\\n%\t"\\$2"
1560             ..
1561             . if !\nF==2 \{\
1562             . nr % 0
1563             . nr F 2
1564             . \}
1565             .\}
1566             ----END OF PREAMBLE----
1567             #'# for cperl-mode
1568              
1569 62 100       102 if ($accents) {
1570 58         200 $preamble .= <<'----END OF PREAMBLE----'
1571             .\"
1572             .\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
1573             .\" Fear. Run. Save yourself. No user-serviceable parts.
1574             . \" fudge factors for nroff and troff
1575             .if n \{\
1576             . ds #H 0
1577             . ds #V .8m
1578             . ds #F .3m
1579             . ds #[ \f1
1580             . ds #] \fP
1581             .\}
1582             .if t \{\
1583             . ds #H ((1u-(\\\\n(.fu%2u))*.13m)
1584             . ds #V .6m
1585             . ds #F 0
1586             . ds #[ \&
1587             . ds #] \&
1588             .\}
1589             . \" simple accents for nroff and troff
1590             .if n \{\
1591             . ds ' \&
1592             . ds ` \&
1593             . ds ^ \&
1594             . ds , \&
1595             . ds ~ ~
1596             . ds /
1597             .\}
1598             .if t \{\
1599             . ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
1600             . ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
1601             . ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
1602             . ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
1603             . ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
1604             . ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
1605             .\}
1606             . \" troff and (daisy-wheel) nroff accents
1607             .ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
1608             .ds 8 \h'\*(#H'\(*b\h'-\*(#H'
1609             .ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
1610             .ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
1611             .ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
1612             .ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
1613             .ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
1614             .ds ae a\h'-(\w'a'u*4/10)'e
1615             .ds Ae A\h'-(\w'A'u*4/10)'E
1616             . \" corrections for vroff
1617             .if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
1618             .if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
1619             . \" for low resolution devices (crt and lpr)
1620             .if \n(.H>23 .if \n(.V>19 \
1621             \{\
1622             . ds : e
1623             . ds 8 ss
1624             . ds o a
1625             . ds d- d\h'-1'\(ga
1626             . ds D- D\h'-1'\(hy
1627             . ds th \o'bp'
1628             . ds Th \o'LP'
1629             . ds ae ae
1630             . ds Ae AE
1631             .\}
1632             .rm #[ #] #H #V #F C
1633             ----END OF PREAMBLE----
1634             #`# for cperl-mode
1635             }
1636 62         88 return $preamble;
1637             }
1638              
1639             ##############################################################################
1640             # Module return value and documentation
1641             ##############################################################################
1642              
1643             1;
1644             __END__