perl/lib/Pod/Perldoc/ToMan.pm - chromium/deps/perl - Git at Google

 require 5.006;
 package Pod::Perldoc::ToMan;
 use strict;
 use warnings;
 use parent qw(Pod::Perldoc::BaseTo);

 use vars qw($VERSION);
 $VERSION = '3.17';

 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 ) { 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 = grep !m/^_/s, keys %$self;

 	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 ) = @_;

 	return 0 unless $self->_is_mandoc;
 	my $roffer = $self->__nroffer;

 	my $minimum_mandoc_version = '1.11';

 	my $version_string = `$roffer -V`;
 	my( $version ) = $version_string =~ /mandoc ((\d+)\.(\d+))/;
 	$self->debug( "Found mandoc $version\n" );

 	# is a string comparison good enough?
 	if( $version lt $minimum_mandoc_version ) {
 		$self->warn(
 			"You have an older mandoc." .
 			" Update to version $minimum_mandoc_version for better Unicode support.\n" .
 			"If you don't upgrade, wide characters may come out oddly.\n" .
 			"Your results still might be odd. If you have groff, that's even better.\n"
 			 );
 		}

 	$version ge $minimum_mandoc_version;
 	}

 sub _collect_nroff_switches {
 	my( $self ) = shift;

 	my @render_switches = $self->_is_mandoc ? qw(-mandoc) : qw(-man);

 	push @render_switches, $self->_get_device_switches;

 	# Thanks to Brendan O'Dea for contributing the following block
 	if( $self->_is_roff and $self->is_linux 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(-Tutf8)        }
 	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 seperate 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
	require 5.006;
	package Pod::Perldoc::ToMan;
	use strict;
	use warnings;
	use parent qw(Pod::Perldoc::BaseTo);

	use vars qw($VERSION);
	$VERSION = '3.17';

	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 ) { 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 = grep !m/^_/s, keys %$self;

	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 ) = @_;

	return 0 unless $self->_is_mandoc;
	my $roffer = $self->__nroffer;

	my $minimum_mandoc_version = '1.11';

	my $version_string = `$roffer -V`;
	my( $version ) = $version_string =~ /mandoc ((\d+)\.(\d+))/;
	$self->debug( "Found mandoc $version\n" );

	# is a string comparison good enough?
	if( $version lt $minimum_mandoc_version ) {
	$self->warn(
	"You have an older mandoc." .
	" Update to version $minimum_mandoc_version for better Unicode support.\n" .
	"If you don't upgrade, wide characters may come out oddly.\n" .
	"Your results still might be odd. If you have groff, that's even better.\n"
	);
	}

	$version ge $minimum_mandoc_version;
	}

	sub _collect_nroff_switches {
	my( $self ) = shift;

	my @render_switches = $self->_is_mandoc ? qw(-mandoc) : qw(-man);

	push @render_switches, $self->_get_device_switches;

	# Thanks to Brendan O'Dea for contributing the following block
	if( $self->_is_roff and $self->is_linux 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(-Tutf8) }
	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 seperate 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