File Coverage

blib/lib/Pod/Text/Overstrike.pm

Criterion	Covered	Total	%
statement	65	69	94.2
branch	3	6	50.0
condition			n/a
subroutine	15	16	93.7
pod	0	11	0.0
total	83	102	81.3

# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text
#
# This was written because the output from:
#
#     pod2text Text.pm > plain.txt; less plain.txt
#
# is not as rich as the output from
#
#     pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt
#
# and because both Pod::Text::Color and Pod::Text::Termcap are not device
# independent.
#
# Created by Joe Smith  30-Nov-2000
#   (based on Pod::Text::Color by Russ Allbery )
# Copyright 2000 Joe Smith .
# Copyright 2001, 2004, 2008, 2014 Russ Allbery .
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.

##############################################################################
# Modules and declarations
##############################################################################

package Pod::Text::Overstrike;

use 5.006;
use strict;
use warnings;

use vars qw(@ISA $VERSION);

use Pod::Text ();

@ISA = qw(Pod::Text);

$VERSION = '4.10';

##############################################################################
# Overrides
##############################################################################

# Make level one headings bold, overriding any existing formatting.
sub cmd_head1 {
    my ($self, $attrs, $text) = @_;
    $text =~ s/\s+$//;
    $text = $self->strip_format ($text);
    $text =~ s/(.)/$1\b$1/g;
    return $self->SUPER::cmd_head1 ($attrs, $text);
}

# Make level two headings bold, overriding any existing formatting.
sub cmd_head2 {
    my ($self, $attrs, $text) = @_;
    $text =~ s/\s+$//;
    $text = $self->strip_format ($text);
    $text =~ s/(.)/$1\b$1/g;
    return $self->SUPER::cmd_head2 ($attrs, $text);
}

# Make level three headings underscored, overriding any existing formatting.
sub cmd_head3 {
    my ($self, $attrs, $text) = @_;
    $text =~ s/\s+$//;
    $text = $self->strip_format ($text);
    $text =~ s/(.)/_\b$1/g;
    return $self->SUPER::cmd_head3 ($attrs, $text);
}

# Level four headings look like level three headings.
sub cmd_head4 {
    my ($self, $attrs, $text) = @_;
    $text =~ s/\s+$//;
    $text = $self->strip_format ($text);
    $text =~ s/(.)/_\b$1/g;
    return $self->SUPER::cmd_head4 ($attrs, $text);
}

# The common code for handling all headers.  We have to override to avoid
# interpolating twice and because we don't want to honor alt.
sub heading {
    my ($self, $text, $indent, $marker) = @_;
    $self->item ("\n\n") if defined $$self{ITEM};
    $text .= "\n" if $$self{opt_loose};
    my $margin = ' ' x ($$self{opt_margin} + $indent);
    $self->output ($margin . $text . "\n");
    return '';
}

# Fix the various formatting codes.
sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ }
sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }
sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ }

# Output any included code in bold.
sub output_code {
    my ($self, $code) = @_;
    $code =~ s/(.)/$1\b$1/g;
    $self->output ($code);
}

# Strip all of the formatting from a provided string, returning the stripped
# version.
sub strip_format {
    my ($self, $text) = @_;
    $text =~ s/(.)[\b]\1/$1/g;
    $text =~ s/_[\b]//g;
    return $text;
}

# We unfortunately have to override the wrapping code here, since the normal
# wrapping code gets really confused by all the backspaces.
sub wrap {
    my $self = shift;
    local $_ = shift;
    my $output = '';
    my $spaces = ' ' x $$self{MARGIN};
    my $width = $$self{opt_width} - $$self{MARGIN};
    while (length > $width) {
        # This regex represents a single character, that's possibly underlined
        # or in bold (in which case, it's three characters; the character, a
        # backspace, and a character).  Use [^\n] rather than . to protect
        # against odd settings of $*.
        my $char = '(?:[^\n][\b])?[^\n]';
        if (s/^((?>$char){0,$width})(?:\Z|\s+)//) {
            $output .= $spaces . $1 . "\n";
        } else {
            last;
        }
    }
    $output .= $spaces . $_;
    $output =~ s/\s+$/\n\n/;
    return $output;
}

##############################################################################
# Module return value and documentation
##############################################################################

1;
__END__