1# Convert POD data to ASCII text with format escapes.
2#
3# This is a simple subclass of Pod::Text that overrides a few key methods to
4# output the right termcap escape sequences for formatted text on the current
5# terminal type.
6#
7# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
8
9##############################################################################
10# Modules and declarations
11##############################################################################
12
13package Pod::Text::Termcap;
14
15use 5.008;
16use strict;
17use warnings;
18
19use Pod::Text ();
20use POSIX ();
21use Term::Cap;
22
23use vars qw(@ISA $VERSION);
24
25@ISA = qw(Pod::Text);
26
27$VERSION = '4.14';
28
29##############################################################################
30# Overrides
31##############################################################################
32
33# In the initialization method, grab our terminal characteristics as well as
34# do all the stuff we normally do.
35sub new {
36    my ($self, %args) = @_;
37    my ($ospeed, $term, $termios);
38
39    # Fall back on a hard-coded terminal speed if POSIX::Termios isn't
40    # available (such as on VMS).
41    eval { $termios = POSIX::Termios->new };
42    if ($@) {
43        $ospeed = 9600;
44    } else {
45        $termios->getattr;
46        $ospeed = $termios->getospeed || 9600;
47    }
48
49    # Get data from Term::Cap if possible.
50    my ($bold, $undl, $norm, $width);
51    eval {
52        my $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
53        $bold = $term->Tputs('md');
54        $undl = $term->Tputs('us');
55        $norm = $term->Tputs('me');
56        if (defined $$term{_co}) {
57            $width = $$term{_co};
58            $width =~ s/^\#//;
59        }
60    };
61
62    # Figure out the terminal width before calling the Pod::Text constructor,
63    # since it will otherwise force 76 characters.  Pod::Text::Termcap has
64    # historically used 2 characters less than the width of the screen, while
65    # the other Pod::Text classes have used 76.  This is weirdly inconsistent,
66    # but there's probably no good reason to change it now.
67    unless (defined $args{width}) {
68        $args{width} = $ENV{COLUMNS} || $width || 80;
69        $args{width} -= 2;
70    }
71
72    # Initialize Pod::Text.
73    $self = $self->SUPER::new (%args);
74
75    # If we were unable to get any of the formatting sequences, don't attempt
76    # that type of formatting.  This will do weird things if bold or underline
77    # were available but normal wasn't, but hopefully that will never happen.
78    $$self{BOLD} = $bold || q{};
79    $$self{UNDL} = $undl || q{};
80    $$self{NORM} = $norm || q{};
81
82    return $self;
83}
84
85# Make level one headings bold.
86sub cmd_head1 {
87    my ($self, $attrs, $text) = @_;
88    $text =~ s/\s+$//;
89    $self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}");
90}
91
92# Make level two headings bold.
93sub cmd_head2 {
94    my ($self, $attrs, $text) = @_;
95    $text =~ s/\s+$//;
96    $self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}");
97}
98
99# Fix up B<> and I<>.  Note that we intentionally don't do F<>.
100sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" }
101sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" }
102
103# Return a regex that matches a formatting sequence.  This will only be valid
104# if we were able to get at least some termcap information.
105sub format_regex {
106    my ($self) = @_;
107    my @codes = ($self->{BOLD}, $self->{UNDL}, $self->{NORM});
108    return join(q{|}, map { $_ eq q{} ? () : "\Q$_\E" } @codes);
109}
110
111# Analyze a single line and return any formatting codes in effect at the end
112# of that line.
113sub end_format {
114    my ($self, $line) = @_;
115    my $pattern = "(" . $self->format_regex() . ")";
116    my $current;
117    while ($line =~ /$pattern/g) {
118        my $code = $1;
119        if ($code eq $$self{NORM}) {
120            undef $current;
121        } else {
122            $current .= $code;
123        }
124    }
125    return $current;
126}
127
128# Output any included code in bold.
129sub output_code {
130    my ($self, $code) = @_;
131    $self->output ($$self{BOLD} . $code . $$self{NORM});
132}
133
134# Strip all of the formatting from a provided string, returning the stripped
135# version.
136sub strip_format {
137    my ($self, $text) = @_;
138    $text =~ s/\Q$$self{BOLD}//g;
139    $text =~ s/\Q$$self{UNDL}//g;
140    $text =~ s/\Q$$self{NORM}//g;
141    return $text;
142}
143
144# Override the wrapping code to ignore the special sequences.
145sub wrap {
146    my $self = shift;
147    local $_ = shift;
148    my $output = '';
149    my $spaces = ' ' x $$self{MARGIN};
150    my $width = $$self{opt_width} - $$self{MARGIN};
151
152    # If we were unable to find any termcap sequences, use Pod::Text wrapping.
153    if ($self->{BOLD} eq q{} && $self->{UNDL} eq q{} && $self->{NORM} eq q{}) {
154        return $self->SUPER::wrap($_);
155    }
156
157    # $code matches a single special sequence.  $char matches any number of
158    # special sequences preceding a single character other than a newline.
159    # $shortchar matches some sequence of $char ending in codes followed by
160    # whitespace or the end of the string.  $longchar matches exactly $width
161    # $chars, used when we have to truncate and hard wrap.
162    my $code = "(?:" . $self->format_regex() . ")";
163    my $char = "(?>$code*[^\\n])";
164    my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)';
165    my $longchar = '^(' . $char . "{$width})";
166    while (length > $width) {
167        if (s/$shortchar// || s/$longchar//) {
168            $output .= $spaces . $1 . "\n";
169        } else {
170            last;
171        }
172    }
173    $output .= $spaces . $_;
174
175    # less -R always resets terminal attributes at the end of each line, so we
176    # need to clear attributes at the end of lines and then set them again at
177    # the start of the next line.  This requires a second pass through the
178    # wrapped string, accumulating any attributes we see, remembering them,
179    # and then inserting the appropriate sequences at the newline.
180    if ($output =~ /\n/) {
181        my @lines = split (/\n/, $output);
182        my $start_format;
183        for my $line (@lines) {
184            if ($start_format && $line =~ /\S/) {
185                $line =~ s/^(\s*)(\S)/$1$start_format$2/;
186            }
187            $start_format = $self->end_format ($line);
188            if ($start_format) {
189                $line .= $$self{NORM};
190            }
191        }
192        $output = join ("\n", @lines);
193    }
194
195    # Fix up trailing whitespace and return the results.
196    $output =~ s/\s+$/\n\n/;
197    return $output;
198}
199
200##############################################################################
201# Module return value and documentation
202##############################################################################
203
2041;
205__END__
206
207=head1 NAME
208
209Pod::Text::Termcap - Convert POD data to ASCII text with format escapes
210
211=for stopwords
212ECMA-48 VT100 Allbery Solaris TERMPATH
213
214=head1 SYNOPSIS
215
216    use Pod::Text::Termcap;
217    my $parser = Pod::Text::Termcap->new (sentence => 0, width => 78);
218
219    # Read POD from STDIN and write to STDOUT.
220    $parser->parse_from_filehandle;
221
222    # Read POD from file.pod and write to file.txt.
223    $parser->parse_from_file ('file.pod', 'file.txt');
224
225=head1 DESCRIPTION
226
227Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output
228text using the correct termcap escape sequences for the current terminal.
229Apart from the format codes, it in all ways functions like Pod::Text.  See
230L<Pod::Text> for details and available options.
231
232This module uses L<Term::Cap> to find the correct terminal settings.  See the
233documentation of that module for how it finds terminal database information
234and how to override that behavior if necessary.  If unable to find control
235strings for bold and underscore formatting, that formatting is skipped,
236resulting in the same output as Pod::Text.
237
238=head1 AUTHOR
239
240Russ Allbery <rra@cpan.org>
241
242=head1 COPYRIGHT AND LICENSE
243
244Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018-2019 Russ
245Allbery <rra@cpan.org>
246
247This program is free software; you may redistribute it and/or modify it
248under the same terms as Perl itself.
249
250=head1 SEE ALSO
251
252L<Pod::Text>, L<Pod::Simple>, L<Term::Cap>
253
254The current version of this module is always available from its web site at
255L<https://www.eyrie.org/~eagle/software/podlators/>.  It is also part of the
256Perl core distribution as of 5.6.0.
257
258=cut
259
260# Local Variables:
261# copyright-at-end-flag: t
262# End:
263