man.pm

UNIX下perl实现代码

# so that hanging paragraph tags will be correct.
sub cmd_over {
    my $self = shift;
    local $_ = shift;
    unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
    if (@{ $$self{INDENTS} } > 0) {
        $self->output (".RS $$self{INDENT}\n");
    }
    push (@{ $$self{INDENTS} }, $$self{INDENT});
    $$self{INDENT} = ($_ + 0);
}

# End a list.  If we've closed an embedded indent, we've mangled the hanging
# paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT.
# We'll close that .RS at the next =back or =item.
sub cmd_back {
    my $self = shift;
    $$self{INDENT} = pop @{ $$self{INDENTS} };
    unless (defined $$self{INDENT}) {
        carp "Unmatched =back";
        $$self{INDENT} = 0;
    }
    if ($$self{WEIRDINDENT}) {
        $self->output (".RE\n");
        $$self{WEIRDINDENT} = 0;
    }
    if (@{ $$self{INDENTS} } > 0) {
        $self->output (".RE\n");
        $self->output (".RS $$self{INDENT}\n");
        $$self{WEIRDINDENT} = 1;
    }
    $$self{NEEDSPACE} = 1;
}

# An individual list item.  Emit an index entry for anything that's
# interesting, but don't emit index entries for things like bullets and
# numbers.  rofficate bullets too while we're at it (so for nice output, use
# * for your lists rather than o or . or - or some other thing).  Newlines
# in an item title are turned into spaces since *roff can't handle them
# embedded.
sub cmd_item {
    my $self = shift;
    local $_ = $self->parse (@_);
    s/\s+$//;
    s/\s*\n\s*/ /g;
    my $index;
    if (/\w/ && !/^\w[.\)]\s*$/) {
        $index = $_;
        $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//;
    }
    s/^\*(\s|\Z)/\\\(bu$1/;
    if ($$self{WEIRDINDENT}) {
        $self->output (".RE\n");
        $$self{WEIRDINDENT} = 0;
    }
    $_ = $self->textmapfonts ($_);
    $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
    $self->output ($self->switchquotes ('.Ip', $_, $$self{INDENT}));
    $self->outindex ($index ? ('Item', $index) : ());
    $$self{NEEDSPACE} = 0;
    $$self{ITEMS}++;
}

# Begin a block for a particular translator.  Setting VERBATIM triggers
# special handling in textblock().
sub cmd_begin {
    my $self = shift;
    local $_ = shift;
    my ($kind) = /^(\S+)/ or return;
    if ($kind eq 'man' || $kind eq 'roff') {
        $$self{VERBATIM} = 1;
    } else {
        $$self{EXCLUDE} = 1;
    }
}

# End a block for a particular translator.  We assume that all =begin/=end
# pairs are properly closed.
sub cmd_end {
    my $self = shift;
    $$self{EXCLUDE} = 0;
    $$self{VERBATIM} = 0;
}

# One paragraph for a particular translator.  Ignore it unless it's intended
# for man or roff, in which case we output it verbatim.
sub cmd_for {
    my $self = shift;
    local $_ = shift;
    return unless s/^(?:man|roff)\b[ \t]*\n?//;
    $self->output ($_);
}


############################################################################
# Link handling
############################################################################

# Handle links.  We can't actually make real hyperlinks, so this is all to
# figure out what text and formatting we print out.
sub buildlink {
    my $self = shift;
    local $_ = shift;

    # Smash whitespace in case we were split across multiple lines.
    s/\s+/ /g;

    # If we were given any explicit text, just output it.
    if (m{ ^ ([^|]+) \| }x) { return $1 }

    # Okay, leading and trailing whitespace isn't important.
    s/^\s+//;
    s/\s+$//;

    # If the argument looks like a URL, return it verbatim.  This only
    # handles URLs that use the server syntax.
    if (m%^[a-z]+://\S+$%) { return $_ }

    # Default to using the whole content of the link entry as a section
    # name.  Note that L<manpage/> forces a manpage interpretation, as does
    # something looking like L<manpage(section)>.  Do the same thing to
    # L<manpage(section)> as we would to manpage(section) without the L<>;
    # see guesswork().  If we've added italics, don't add the "manpage"
    # text; markup is sufficient.
    my ($manpage, $section) = ('', $_);
    if (/^"\s*(.*?)\s*"$/) {
        $section = '"' . $1 . '"';
    } elsif (m{ ^ [-:.\w]+ (?: \( \S+ \) )? $ }x) {
        ($manpage, $section) = ($_, '');
        $manpage =~ s/^([^\(]+)\(/'\f(IS' . $1 . '\f(IE\|('/e;
    } elsif (m%/%) {
        ($manpage, $section) = split (/\s*\/\s*/, $_, 2);
        if ($manpage =~ /^[-:.\w]+(?:\(\S+\))?$/) {
            $manpage =~ s/^([^\(]+)\(/'\f(IS' . $1 . '\f(IE\|'/e;
        }
        $section =~ s/^\"\s*//;
        $section =~ s/\s*\"$//;
    }
    if ($manpage && $manpage !~ /\\f\(IS/) {
        $manpage = "the $manpage manpage";
    }

    # Now build the actual output text.
    my $text = '';
    if (!length ($section) && !length ($manpage)) {
        carp "Invalid link $_";
    } elsif (!length ($section)) {
        $text = $manpage;
    } elsif ($section =~ /^[:\w]+(?:\(\))?/) {
        $text .= 'the ' . $section . ' entry';
        $text .= (length $manpage) ? " in $manpage"
                                   : " elsewhere in this document";
    } else {
        if ($section !~ /^".*"$/) { $section = '"' . $section . '"' }
        $text .= 'the section on ' . $section;
        $text .= " in $manpage" if length $manpage;
    }
    $text;
}


############################################################################
# Escaping and fontification
############################################################################

# At this point, we'll have embedded font codes of the form \f(<font>[SE]
# where <font> is one of B, I, or F.  Turn those into the right font start
# or end codes.  The old pod2man didn't get B<someI<thing> else> right;
# after I<> it switched back to normal text rather than bold.  We take care
# of this by using variables as a combined pointer to our current font
# sequence, and set each to the number of current nestings of start tags for
# that font.  Use them as a vector to look up what font sequence to use.
#
# \fP changes to the previous font, but only one previous font is kept.  We
# don't know what the outside level font is; normally it's R, but if we're
# inside a heading it could be something else.  So arrange things so that
# the outside font is always the "previous" font and end with \fP instead of
# \fR.  Idea from Zack Weinberg.
sub mapfonts {
    my $self = shift;
    local $_ = shift;

    my ($fixed, $bold, $italic) = (0, 0, 0);
    my %magic = (F => \$fixed, B => \$bold, I => \$italic);
    my $last = '\fR';
    s { \\f\((.)(.) } {
        my $sequence = '';
        my $f;
        if ($last ne '\fR') { $sequence = '\fP' }
        ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
        $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
        if ($f eq $last) {
            '';
        } else {
            if ($f ne '\fR') { $sequence .= $f }
            $last = $f;
            $sequence;
        }
    }gxe;
    $_;
}

# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
# than R, presumably because \f(CW doesn't actually do a font change.  To
# work around this, use a separate textmapfonts for text blocks where the
# default font is always R and only use the smart mapfonts for headings.
sub textmapfonts {
    my $self = shift;
    local $_ = shift;

    my ($fixed, $bold, $italic) = (0, 0, 0);
    my %magic = (F => \$fixed, B => \$bold, I => \$italic);
    s { \\f\((.)(.) } {
        ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
        $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)};
    }gxe;
    $_;
}


############################################################################
# *roff-specific parsing
############################################################################

# Called instead of parse_text, calls parse_text with the right flags.
sub parse {
    my $self = shift;
    $self->parse_text ({ -expand_seq   => 'sequence',
                         -expand_ptree => 'collapse' }, @_);
}

# Takes a parse tree and a flag saying whether or not to treat it as literal
# text (not call guesswork on it), and returns the concatenation of all of
# the text strings in that parse tree.  If the literal flag isn't true,
# guesswork() will be called on all plain scalars in the parse tree.
# Otherwise, just escape backslashes in the normal case.  If collapse is
# being called on a C<> sequence, literal is set to 2, and we do some
# additional cleanup.  Assumes that everything in the parse tree is either a
# scalar or a reference to a scalar.
sub collapse {
    my ($self, $ptree, $literal) = @_;
    if ($literal) {
        return join ('', map {
            if (ref $_) {
                $$_;
            } else {
                s/\\/\\e/g;
                s/-/\\-/g    if $literal > 1;
                s/__/_\\|_/g if $literal > 1;
                $_;
            }
        } $ptree->children);
    } else {
        return join ('', map {
            ref ($_) ? $$_ : $self->guesswork ($_)
        } $ptree->children);
    }
}

# Takes a text block to perform guesswork on; this is guaranteed not to
# contain any interior sequences.  Returns the text block with remapping
# done.
sub guesswork {
    my $self = shift;
    local $_ = shift;

    # rofficate backslashes.
    s/\\/\\e/g;

    # Ensure double underbars have a tiny space between them.
    s/__/_\\|_/g;

    # Make all caps a little smaller.  Be careful here, since we don't want
    # to make @ARGV into small caps, nor do we want to fix the MIME in
    # MIME-Version, since it looks weird with the full-height V.
    s{
        ( ^ | [\s\(\"\'\`\[\{<>] )
        ( [A-Z] [A-Z] [/A-Z+:\d_\$&-]* )
        (?: (?= [\s>\}\]\)\'\".?!,;:] | -- ) | $ )
    } { $1 . '\s-1' . $2 . '\s0' }egx;

    # Turn PI into a pretty pi.
    s{ (?: \\s-1 | \b ) PI (?: \\s0 | \b ) } {\\*\(PI}gx;

    # Italize functions in the form func().
    s{
        \b
        (
            [:\w]+ (?:\\s-1)? \(\)
        )
    } { '\f(IS' . $1 . '\f(IE' }egx;

    # func(n) is a reference to a manual page.  Make it \fIfunc\fR\|(n).
    s{
        \b
        (\w[-:.\w]+ (?:\\s-1)?)
        (
            \( [^\)] \)
        )
    } { '\f(IS' . $1 . '\f(IE\|' . $2 }egx;

    # Convert simple Perl variable references to a fixed-width font.
    s{
        ( \s+ )
        ( [\$\@%] [\w:]+ )
        (?! \( )
    } { $1 . '\f(FS' . $2 . '\f(FE'}egx;

    # Translate -- into a real em dash if it's used like one and fix up
    # dashes, but keep hyphens hyphens.
    s{ (\G|^|.) (-+) (\b|.) } {
        my ($pre, $dash, $post) = ($1, $2, $3);
        if (length ($dash) == 1) {
            ($pre =~ /[a-zA-Z]/) ? "$pre-$post" : "$pre\\-$post";
        } elsif (length ($dash) == 2
                 && ((!$pre && !$post)
                     || ($pre =~ /\w/ && !$post)
                     || ($pre eq ' ' && $post eq ' ')
                     || ($pre eq '=' && $post ne '=')
                     || ($pre ne '=' && $post eq '='))) {
            "$pre\\*(--$post";
        } else {
            $pre . ('\-' x length $dash) . $post;
        }
    }egxs;

    # Fix up double quotes.
    s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;

    # Make C++ into \*(C+, which is a squinched version.
    s{ \b C\+\+ } {\\*\(C+}gx;

    # All done.
    $_;
}


############################################################################
# Output formatting
############################################################################

# Make vertical whitespace.
sub makespace {
    my $self = shift;
    $self->output (".PD\n") if ($$self{ITEMS} > 1);
    $$self{ITEMS} = 0;