562 lines
14 KiB
Perl
562 lines
14 KiB
Perl
require 5.006;
|
|
package Pod::Perldoc::ToMan;
|
|
use strict;
|
|
use warnings;
|
|
use parent qw(Pod::Perldoc::BaseTo);
|
|
|
|
use vars qw($VERSION);
|
|
$VERSION = '3.28';
|
|
|
|
use File::Spec::Functions qw(catfile);
|
|
use Pod::Man 2.18;
|
|
# This class is unlike ToText.pm et al, because we're NOT paging thru
|
|
# the output in our particular format -- we make the output and
|
|
# then we run nroff (or whatever) on it, and then page thru the
|
|
# (plaintext) output of THAT!
|
|
|
|
sub SUCCESS () { 1 }
|
|
sub FAILED () { 0 }
|
|
|
|
sub is_pageable { 1 }
|
|
sub write_with_binmode { 0 }
|
|
sub output_extension { 'txt' }
|
|
|
|
sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) }
|
|
sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) }
|
|
sub __bindir { shift->_perldoc_elem('__bindir' , @_) }
|
|
sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) }
|
|
sub __output_file { shift->_perldoc_elem('__output_file' , @_) }
|
|
|
|
sub center { shift->_perldoc_elem('center' , @_) }
|
|
sub date { shift->_perldoc_elem('date' , @_) }
|
|
sub fixed { shift->_perldoc_elem('fixed' , @_) }
|
|
sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
|
|
sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
|
|
sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
|
|
sub name { shift->_perldoc_elem('name' , @_) }
|
|
sub quotes { shift->_perldoc_elem('quotes' , @_) }
|
|
sub release { shift->_perldoc_elem('release' , @_) }
|
|
sub section { shift->_perldoc_elem('section' , @_) }
|
|
|
|
sub new {
|
|
my( $either ) = shift;
|
|
my $self = bless {}, ref($either) || $either;
|
|
$self->init( @_ );
|
|
return $self;
|
|
}
|
|
|
|
sub init {
|
|
my( $self, @args ) = @_;
|
|
|
|
unless( $self->__nroffer ) {
|
|
my $roffer = $self->_find_roffer( $self->_roffer_candidates );
|
|
$self->debug( "Using $roffer\n" );
|
|
$self->__nroffer( $roffer );
|
|
}
|
|
else {
|
|
$self->debug( "__nroffer is " . $self->__nroffer() . "\n" );
|
|
}
|
|
|
|
$self->_check_nroffer;
|
|
}
|
|
|
|
sub _roffer_candidates {
|
|
my( $self ) = @_;
|
|
|
|
if( $self->is_openbsd || $self->is_freebsd || $self->is_bitrig ) { qw( mandoc groff nroff ) }
|
|
else { qw( groff nroff mandoc ) }
|
|
}
|
|
|
|
sub _find_roffer {
|
|
my( $self, @candidates ) = @_;
|
|
|
|
my @found = ();
|
|
foreach my $candidate ( @candidates ) {
|
|
push @found, $self->_find_executable_in_path( $candidate );
|
|
}
|
|
|
|
return wantarray ? @found : $found[0];
|
|
}
|
|
|
|
sub _check_nroffer {
|
|
return 1;
|
|
# where is it in the PATH?
|
|
|
|
# is it executable?
|
|
|
|
# what is its real name?
|
|
|
|
# what is its version?
|
|
|
|
# does it support the flags we need?
|
|
|
|
# is it good enough for us?
|
|
}
|
|
|
|
sub _get_stty { `stty -a` }
|
|
|
|
sub _get_columns_from_stty {
|
|
my $output = $_[0]->_get_stty;
|
|
|
|
if( $output =~ /\bcolumns\s+(\d+)/ ) { return $1 }
|
|
elsif( $output =~ /;\s*(\d+)\s+columns;/ ) { return $1 }
|
|
else { return 0 }
|
|
}
|
|
|
|
sub _get_columns_from_manwidth {
|
|
my( $self ) = @_;
|
|
|
|
return 0 unless defined $ENV{MANWIDTH};
|
|
|
|
unless( $ENV{MANWIDTH} =~ m/\A\d+\z/ ) {
|
|
$self->warn( "Ignoring non-numeric MANWIDTH ($ENV{MANWIDTH})\n" );
|
|
return 0;
|
|
}
|
|
|
|
if( $ENV{MANWIDTH} == 0 ) {
|
|
$self->warn( "Ignoring MANWIDTH of 0. Really? Why even run the program? :)\n" );
|
|
return 0;
|
|
}
|
|
|
|
if( $ENV{MANWIDTH} =~ m/\A(\d+)\z/ ) { return $1 }
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub _get_default_width {
|
|
73
|
|
}
|
|
|
|
sub _get_columns {
|
|
$_[0]->_get_columns_from_manwidth ||
|
|
$_[0]->_get_columns_from_stty ||
|
|
$_[0]->_get_default_width;
|
|
}
|
|
|
|
sub _get_podman_switches {
|
|
my( $self ) = @_;
|
|
|
|
my @switches = map { $_, $self->{$_} } grep !m/^_/s, keys %$self;
|
|
|
|
# There needs to be a cleaner way to handle setting
|
|
# the UTF-8 flag, but for now, comment out this
|
|
# line because it often does the wrong thing.
|
|
#
|
|
# See RT #77465
|
|
#
|
|
#push @switches, 'utf8' => 1;
|
|
|
|
$self->debug( "Pod::Man switches are [@switches]\n" );
|
|
|
|
return @switches;
|
|
}
|
|
|
|
sub _parse_with_pod_man {
|
|
my( $self, $file ) = @_;
|
|
|
|
#->output_fh and ->output_string from Pod::Simple aren't
|
|
# working, apparently, so there's this ugly hack:
|
|
local *STDOUT;
|
|
open STDOUT, '>', $self->{_text_ref};
|
|
my $parser = Pod::Man->new( $self->_get_podman_switches );
|
|
$self->debug( "Parsing $file\n" );
|
|
$parser->parse_from_file( $file );
|
|
$self->debug( "Done parsing $file\n" );
|
|
close STDOUT;
|
|
|
|
$self->die( "No output from Pod::Man!\n" )
|
|
unless length $self->{_text_ref};
|
|
|
|
$self->_save_pod_man_output if $self->debugging;
|
|
|
|
return SUCCESS;
|
|
}
|
|
|
|
sub _save_pod_man_output {
|
|
my( $self, $fh ) = @_;
|
|
|
|
$fh = do {
|
|
my $file = "podman.out.$$.txt";
|
|
$self->debug( "Writing $file with Pod::Man output\n" );
|
|
open my $fh2, '>', $file;
|
|
$fh2;
|
|
} unless $fh;
|
|
|
|
print { $fh } ${ $self->{_text_ref} };
|
|
}
|
|
|
|
sub _have_groff_with_utf8 {
|
|
my( $self ) = @_;
|
|
|
|
return 0 unless $self->_is_groff;
|
|
my $roffer = $self->__nroffer;
|
|
|
|
my $minimum_groff_version = '1.20.1';
|
|
|
|
my $version_string = `$roffer -v`;
|
|
my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/;
|
|
$self->debug( "Found groff $version\n" );
|
|
|
|
# is a string comparison good enough?
|
|
if( $version lt $minimum_groff_version ) {
|
|
$self->warn(
|
|
"You have an old groff." .
|
|
" Update to version $minimum_groff_version for good Unicode support.\n" .
|
|
"If you don't upgrade, wide characters may come out oddly.\n"
|
|
);
|
|
}
|
|
|
|
$version ge $minimum_groff_version;
|
|
}
|
|
|
|
sub _have_mandoc_with_utf8 {
|
|
my( $self ) = @_;
|
|
|
|
$self->_is_mandoc and not system 'mandoc -Tlocale -V > /dev/null 2>&1';
|
|
}
|
|
|
|
sub _collect_nroff_switches {
|
|
my( $self ) = shift;
|
|
|
|
my @render_switches = ('-man', $self->_get_device_switches);
|
|
|
|
# Thanks to Brendan O'Dea for contributing the following block
|
|
if( $self->_is_roff and -t STDOUT and my ($cols) = $self->_get_columns ) {
|
|
my $c = $cols * 39 / 40;
|
|
$cols = $c > $cols - 2 ? $c : $cols -2;
|
|
push @render_switches, '-rLL=' . (int $c) . 'n' if $cols > 80;
|
|
}
|
|
|
|
# I hear persistent reports that adding a -c switch to $render
|
|
# solves many people's problems. But I also hear that some mans
|
|
# don't have a -c switch, so that unconditionally adding it here
|
|
# would presumably be a Bad Thing -- sburke@cpan.org
|
|
push @render_switches, '-c' if( $self->_is_roff and $self->is_cygwin );
|
|
|
|
return @render_switches;
|
|
}
|
|
|
|
sub _get_device_switches {
|
|
my( $self ) = @_;
|
|
|
|
if( $self->_is_nroff ) { qw() }
|
|
elsif( $self->_have_groff_with_utf8 ) { qw(-Kutf8 -Tutf8) }
|
|
elsif( $self->_is_ebcdic ) { qw(-Tcp1047) }
|
|
elsif( $self->_have_mandoc_with_utf8 ) { qw(-Tlocale) }
|
|
elsif( $self->_is_mandoc ) { qw() }
|
|
else { qw(-Tlatin1) }
|
|
}
|
|
|
|
sub _is_roff {
|
|
my( $self ) = @_;
|
|
|
|
$self->_is_nroff or $self->_is_groff;
|
|
}
|
|
|
|
sub _is_nroff {
|
|
my( $self ) = @_;
|
|
|
|
$self->__nroffer =~ /\bnroff\b/;
|
|
}
|
|
|
|
sub _is_groff {
|
|
my( $self ) = @_;
|
|
|
|
$self->__nroffer =~ /\bgroff\b/;
|
|
}
|
|
|
|
sub _is_mandoc {
|
|
my ( $self ) = @_;
|
|
|
|
$self->__nroffer =~ /\bmandoc\b/;
|
|
}
|
|
|
|
sub _is_ebcdic {
|
|
my( $self ) = @_;
|
|
|
|
return 0;
|
|
}
|
|
|
|
sub _filter_through_nroff {
|
|
my( $self ) = shift;
|
|
$self->debug( "Filtering through " . $self->__nroffer() . "\n" );
|
|
|
|
# Maybe someone set rendering switches as part of the opt_n value
|
|
# Deal with that here.
|
|
|
|
my ($render, $switches) = $self->__nroffer() =~ /\A([\/a-zA-Z0-9_\.-]+)\b(.+)?\z/;
|
|
|
|
$self->die("no nroffer!?") unless $render;
|
|
my @render_switches = $self->_collect_nroff_switches;
|
|
|
|
if ( $switches ) {
|
|
# Eliminate whitespace
|
|
$switches =~ s/\s//g;
|
|
|
|
# Then separate the switches with a zero-width positive
|
|
# lookahead on the dash.
|
|
#
|
|
# See:
|
|
# http://www.effectiveperlprogramming.com/blog/1411
|
|
# for a good discussion of this technique
|
|
|
|
push @render_switches, split(/(?=-)/, $switches);
|
|
}
|
|
|
|
$self->debug( "render is $render\n" );
|
|
$self->debug( "render options are @render_switches\n" );
|
|
|
|
require Symbol;
|
|
require IPC::Open3;
|
|
require IO::Handle;
|
|
|
|
my $pid = IPC::Open3::open3(
|
|
my $writer,
|
|
my $reader,
|
|
my $err = Symbol::gensym(),
|
|
$render,
|
|
@render_switches
|
|
);
|
|
|
|
$reader->autoflush(1);
|
|
|
|
use IO::Select;
|
|
my $selector = IO::Select->new( $reader );
|
|
|
|
$self->debug( "Writing to pipe to $render\n" );
|
|
|
|
my $offset = 0;
|
|
my $chunk_size = 4096;
|
|
my $length = length( ${ $self->{_text_ref} } );
|
|
my $chunks = $length / $chunk_size;
|
|
my $done;
|
|
my $buffer;
|
|
while( $offset <= $length ) {
|
|
$self->debug( "Writing chunk $chunks\n" ); $chunks++;
|
|
syswrite $writer, ${ $self->{_text_ref} }, $chunk_size, $offset
|
|
or $self->die( $! );
|
|
$offset += $chunk_size;
|
|
$self->debug( "Checking read\n" );
|
|
READ: {
|
|
last READ unless $selector->can_read( 0.01 );
|
|
$self->debug( "Reading\n" );
|
|
my $bytes = sysread $reader, $buffer, 4096;
|
|
$self->debug( "Read $bytes bytes\n" );
|
|
$done .= $buffer;
|
|
$self->debug( sprintf "Output is %d bytes\n",
|
|
length $done
|
|
);
|
|
next READ;
|
|
}
|
|
}
|
|
close $writer;
|
|
$self->debug( "Done writing\n" );
|
|
|
|
# read any leftovers
|
|
$done .= do { local $/; <$reader> };
|
|
$self->debug( sprintf "Done reading. Output is %d bytes\n",
|
|
length $done
|
|
);
|
|
|
|
if( $? ) {
|
|
$self->warn( "Error from pipe to $render!\n" );
|
|
$self->debug( 'Error: ' . do { local $/; <$err> } );
|
|
}
|
|
|
|
|
|
close $reader;
|
|
if( my $err = $? ) {
|
|
$self->debug(
|
|
"Nonzero exit ($?) while running `$render @render_switches`.\n" .
|
|
"Falling back to Pod::Perldoc::ToPod\n"
|
|
);
|
|
return $self->_fallback_to_pod( @_ );
|
|
}
|
|
|
|
$self->debug( "Output:\n----\n$done\n----\n" );
|
|
|
|
${ $self->{_text_ref} } = $done;
|
|
|
|
return length ${ $self->{_text_ref} } ? SUCCESS : FAILED;
|
|
}
|
|
|
|
sub parse_from_file {
|
|
my( $self, $file, $outfh) = @_;
|
|
|
|
# We have a pipeline of filters each affecting the reference
|
|
# in $self->{_text_ref}
|
|
$self->{_text_ref} = \my $output;
|
|
|
|
$self->_parse_with_pod_man( $file );
|
|
# so far, nroff is an external command so we ensure it worked
|
|
my $result = $self->_filter_through_nroff;
|
|
return $self->_fallback_to_pod( @_ ) unless $result == SUCCESS;
|
|
|
|
$self->_post_nroff_processing;
|
|
|
|
print { $outfh } $output or
|
|
$self->die( "Can't print to $$self{__output_file}: $!" );
|
|
|
|
return;
|
|
}
|
|
|
|
sub _fallback_to_pod {
|
|
my( $self, @args ) = @_;
|
|
$self->warn( "Falling back to Pod because there was a problem!\n" );
|
|
require Pod::Perldoc::ToPod;
|
|
return Pod::Perldoc::ToPod->new->parse_from_file(@_);
|
|
}
|
|
|
|
# maybe there's a user setting we should check?
|
|
sub _get_tab_width { 4 }
|
|
|
|
sub _expand_tabs {
|
|
my( $self ) = @_;
|
|
|
|
my $tab_width = ' ' x $self->_get_tab_width;
|
|
|
|
${ $self->{_text_ref} } =~ s/\t/$tab_width/g;
|
|
}
|
|
|
|
sub _post_nroff_processing {
|
|
my( $self ) = @_;
|
|
|
|
if( $self->is_hpux ) {
|
|
$self->debug( "On HP-UX, I'm going to expand tabs for you\n" );
|
|
# this used to be a pipe to `col -x` for HP-UX
|
|
$self->_expand_tabs;
|
|
}
|
|
|
|
if( $self->{'__filter_nroff'} ) {
|
|
$self->debug( "filter_nroff is set, so filtering\n" );
|
|
$self->_remove_nroff_header;
|
|
$self->_remove_nroff_footer;
|
|
}
|
|
else {
|
|
$self->debug( "filter_nroff is not set, so not filtering\n" );
|
|
}
|
|
|
|
$self->_handle_unicode;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# I don't think this does anything since there aren't two consecutive
|
|
# newlines in the Pod::Man output
|
|
sub _remove_nroff_header {
|
|
my( $self ) = @_;
|
|
$self->debug( "_remove_nroff_header is still a stub!\n" );
|
|
return 1;
|
|
|
|
# my @data = split /\n{2,}/, shift;
|
|
# shift @data while @data and $data[0] !~ /\S/; # Go to header
|
|
# shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
|
|
}
|
|
|
|
# I don't think this does anything since there aren't two consecutive
|
|
# newlines in the Pod::Man output
|
|
sub _remove_nroff_footer {
|
|
my( $self ) = @_;
|
|
$self->debug( "_remove_nroff_footer is still a stub!\n" );
|
|
return 1;
|
|
${ $self->{_text_ref} } =~ s/\n\n+.*\w.*\Z//m;
|
|
|
|
# my @data = split /\n{2,}/, shift;
|
|
# pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
|
|
# 28/Jan/99 perl 5.005, patch 53 1
|
|
}
|
|
|
|
sub _unicode_already_handled {
|
|
my( $self ) = @_;
|
|
|
|
$self->_have_groff_with_utf8 ||
|
|
1 # so, we don't have a case that needs _handle_unicode
|
|
;
|
|
}
|
|
|
|
sub _handle_unicode {
|
|
# this is the job of preconv
|
|
# we don't need this with groff 1.20 and later.
|
|
my( $self ) = @_;
|
|
|
|
return 1 if $self->_unicode_already_handled;
|
|
|
|
require Encode;
|
|
|
|
# it's UTF-8 here, but we need character data
|
|
my $text = Encode::decode( 'UTF-8', ${ $self->{_text_ref} } ) ;
|
|
|
|
# http://www.mail-archive.com/groff@gnu.org/msg01378.html
|
|
# http://linux.die.net/man/7/groff_char
|
|
# http://www.gnu.org/software/groff/manual/html_node/Using-Symbols.html
|
|
# http://lists.gnu.org/archive/html/groff/2011-05/msg00007.html
|
|
# http://www.simplicidade.org/notes/archives/2009/05/fixing_the_pod.html
|
|
# http://lists.freebsd.org/pipermail/freebsd-questions/2011-July/232239.html
|
|
$text =~ s/(\P{ASCII})/
|
|
sprintf '\\[u%04X]', ord $1
|
|
/eg;
|
|
|
|
# should we encode?
|
|
${ $self->{_text_ref} } = $text;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Pod::Perldoc::ToMan - let Perldoc render Pod as man pages
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
perldoc -o man Some::Modulename
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This is a "plug-in" class that allows Perldoc to use
|
|
Pod::Man and C<groff> for reading Pod pages.
|
|
|
|
The following options are supported: center, date, fixed, fixedbold,
|
|
fixeditalic, fixedbolditalic, quotes, release, section
|
|
|
|
(Those options are explained in L<Pod::Man>.)
|
|
|
|
For example:
|
|
|
|
perldoc -o man -w center:Pod Some::Modulename
|
|
|
|
=head1 CAVEAT
|
|
|
|
This module may change to use a different pod-to-nroff formatter class
|
|
in the future, and this may change what options are supported.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff>
|
|
|
|
=head1 COPYRIGHT AND DISCLAIMERS
|
|
|
|
Copyright (c) 2011 brian d foy. All rights reserved.
|
|
|
|
Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved.
|
|
|
|
This library is free software; you can redistribute it and/or modify it
|
|
under the same terms as Perl itself.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
without any warranty; without even the implied warranty of
|
|
merchantability or fitness for a particular purpose.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
|
|
|
|
Past contributions from:
|
|
brian d foy C<< <bdfoy@cpan.org> >>
|
|
Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
|
|
Sean M. Burke C<< <sburke@cpan.org> >>
|
|
|
|
=cut
|
|
|