1require 5.006; 2package Pod::Perldoc::ToMan; 3use strict; 4use warnings; 5use parent qw(Pod::Perldoc::BaseTo); 6 7use vars qw($VERSION); 8$VERSION = '3.28'; 9 10use File::Spec::Functions qw(catfile); 11use Pod::Man 2.18; 12# This class is unlike ToText.pm et al, because we're NOT paging thru 13# the output in our particular format -- we make the output and 14# then we run nroff (or whatever) on it, and then page thru the 15# (plaintext) output of THAT! 16 17sub SUCCESS () { 1 } 18sub FAILED () { 0 } 19 20sub is_pageable { 1 } 21sub write_with_binmode { 0 } 22sub output_extension { 'txt' } 23 24sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) } 25sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) } 26sub __bindir { shift->_perldoc_elem('__bindir' , @_) } 27sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) } 28sub __output_file { shift->_perldoc_elem('__output_file' , @_) } 29 30sub center { shift->_perldoc_elem('center' , @_) } 31sub date { shift->_perldoc_elem('date' , @_) } 32sub fixed { shift->_perldoc_elem('fixed' , @_) } 33sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } 34sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } 35sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } 36sub name { shift->_perldoc_elem('name' , @_) } 37sub quotes { shift->_perldoc_elem('quotes' , @_) } 38sub release { shift->_perldoc_elem('release' , @_) } 39sub section { shift->_perldoc_elem('section' , @_) } 40 41sub new { 42 my( $either ) = shift; 43 my $self = bless {}, ref($either) || $either; 44 $self->init( @_ ); 45 return $self; 46 } 47 48sub init { 49 my( $self, @args ) = @_; 50 51 unless( $self->__nroffer ) { 52 my $roffer = $self->_find_roffer( $self->_roffer_candidates ); 53 $self->debug( "Using $roffer\n" ); 54 $self->__nroffer( $roffer ); 55 } 56 else { 57 $self->debug( "__nroffer is " . $self->__nroffer() . "\n" ); 58 } 59 60 $self->_check_nroffer; 61 } 62 63sub _roffer_candidates { 64 my( $self ) = @_; 65 66 if( $self->is_openbsd || $self->is_freebsd || $self->is_bitrig ) { qw( mandoc groff nroff ) } 67 else { qw( groff nroff mandoc ) } 68 } 69 70sub _find_roffer { 71 my( $self, @candidates ) = @_; 72 73 my @found = (); 74 foreach my $candidate ( @candidates ) { 75 push @found, $self->_find_executable_in_path( $candidate ); 76 } 77 78 return wantarray ? @found : $found[0]; 79 } 80 81sub _check_nroffer { 82 return 1; 83 # where is it in the PATH? 84 85 # is it executable? 86 87 # what is its real name? 88 89 # what is its version? 90 91 # does it support the flags we need? 92 93 # is it good enough for us? 94 } 95 96sub _get_stty { `stty -a` } 97 98sub _get_columns_from_stty { 99 my $output = $_[0]->_get_stty; 100 101 if( $output =~ /\bcolumns\s+(\d+)/ ) { return $1 } 102 elsif( $output =~ /;\s*(\d+)\s+columns;/ ) { return $1 } 103 else { return 0 } 104 } 105 106sub _get_columns_from_manwidth { 107 my( $self ) = @_; 108 109 return 0 unless defined $ENV{MANWIDTH}; 110 111 if ($ENV{MANWIDTH} eq 'tty') { return 0; } 112 113 unless( $ENV{MANWIDTH} =~ m/\A\d+\z/ ) { 114 $self->warn( "Ignoring non-numeric MANWIDTH ($ENV{MANWIDTH})\n" ); 115 return 0; 116 } 117 118 if( $ENV{MANWIDTH} == 0 ) { 119 $self->warn( "Ignoring MANWIDTH of 0. Really? Why even run the program? :)\n" ); 120 return 0; 121 } 122 123 if( $ENV{MANWIDTH} =~ m/\A(\d+)\z/ ) { return $1 } 124 125 return 0; 126 } 127 128sub _get_default_width { 129 73 130 } 131 132sub _get_columns { 133 $_[0]->_get_columns_from_manwidth || 134 $_[0]->_get_columns_from_stty || 135 $_[0]->_get_default_width; 136 } 137 138sub _get_podman_switches { 139 my( $self ) = @_; 140 141 my @switches = map { $_, $self->{$_} } grep !m/^_/s, keys %$self; 142 143 # There needs to be a cleaner way to handle setting 144 # the UTF-8 flag, but for now, comment out this 145 # line because it often does the wrong thing. 146 # 147 # See RT #77465 148 # 149 #push @switches, 'utf8' => 1; 150 151 $self->debug( "Pod::Man switches are [@switches]\n" ); 152 153 return @switches; 154 } 155 156sub _parse_with_pod_man { 157 my( $self, $file ) = @_; 158 159 #->output_fh and ->output_string from Pod::Simple aren't 160 # working, apparently, so there's this ugly hack: 161 local *STDOUT; 162 open STDOUT, '>', $self->{_text_ref}; 163 my $parser = Pod::Man->new( $self->_get_podman_switches ); 164 $self->debug( "Parsing $file\n" ); 165 $parser->parse_from_file( $file ); 166 $self->debug( "Done parsing $file\n" ); 167 close STDOUT; 168 169 $self->die( "No output from Pod::Man!\n" ) 170 unless length $self->{_text_ref}; 171 172 $self->_save_pod_man_output if $self->debugging; 173 174 return SUCCESS; 175 } 176 177sub _save_pod_man_output { 178 my( $self, $fh ) = @_; 179 180 $fh = do { 181 my $file = "podman.out.$$.txt"; 182 $self->debug( "Writing $file with Pod::Man output\n" ); 183 open my $fh2, '>', $file; 184 $fh2; 185 } unless $fh; 186 187 print { $fh } ${ $self->{_text_ref} }; 188 } 189 190sub _have_groff_with_utf8 { 191 my( $self ) = @_; 192 193 return 0 unless $self->_is_groff; 194 my $roffer = $self->__nroffer; 195 196 my $minimum_groff_version = '1.20.1'; 197 198 my $version_string = `$roffer -v`; 199 my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; 200 $self->debug( "Found groff $version\n" ); 201 202 # is a string comparison good enough? 203 if( $version lt $minimum_groff_version ) { 204 $self->warn( 205 "You have an old groff." . 206 " Update to version $minimum_groff_version for good Unicode support.\n" . 207 "If you don't upgrade, wide characters may come out oddly.\n" 208 ); 209 } 210 211 $version ge $minimum_groff_version; 212 } 213 214sub _have_mandoc_with_utf8 { 215 my( $self ) = @_; 216 217 $self->_is_mandoc and not system 'mandoc -Tlocale -V > /dev/null 2>&1'; 218 } 219 220sub _collect_nroff_switches { 221 my( $self ) = shift; 222 223 my @render_switches = ('-man', $self->_get_device_switches); 224 225 # Thanks to Brendan O'Dea for contributing the following block 226 if( $self->_is_roff and -t STDOUT and my ($cols) = $self->_get_columns ) { 227 my $c = $cols * 39 / 40; 228 $cols = $c > $cols - 2 ? $c : $cols -2; 229 push @render_switches, '-rLL=' . (int $c) . 'n' if $cols > 80; 230 } 231 232 # I hear persistent reports that adding a -c switch to $render 233 # solves many people's problems. But I also hear that some mans 234 # don't have a -c switch, so that unconditionally adding it here 235 # would presumably be a Bad Thing -- sburke@cpan.org 236 push @render_switches, '-c' if( $self->_is_roff and $self->is_cygwin ); 237 238 return @render_switches; 239 } 240 241sub _get_device_switches { 242 my( $self ) = @_; 243 244 if( $self->_is_nroff ) { qw() } 245 elsif( $self->_have_groff_with_utf8 ) { qw(-Kutf8 -Tutf8) } 246 elsif( $self->_is_ebcdic ) { qw(-Tcp1047) } 247 elsif( $self->_have_mandoc_with_utf8 ) { qw(-Tlocale) } 248 elsif( $self->_is_mandoc ) { qw() } 249 else { qw(-Tlatin1) } 250 } 251 252sub _is_roff { 253 my( $self ) = @_; 254 255 $self->_is_nroff or $self->_is_groff; 256 } 257 258sub _is_nroff { 259 my( $self ) = @_; 260 261 $self->__nroffer =~ /\bnroff\b/; 262 } 263 264sub _is_groff { 265 my( $self ) = @_; 266 267 $self->__nroffer =~ /\bgroff\b/; 268 } 269 270sub _is_mandoc { 271 my ( $self ) = @_; 272 273 $self->__nroffer =~ /\bmandoc\b/; 274 } 275 276sub _is_ebcdic { 277 my( $self ) = @_; 278 279 return 0; 280 } 281 282sub _filter_through_nroff { 283 my( $self ) = shift; 284 $self->debug( "Filtering through " . $self->__nroffer() . "\n" ); 285 286 # Maybe someone set rendering switches as part of the opt_n value 287 # Deal with that here. 288 289 my ($render, $switches) = $self->__nroffer() =~ /\A([\/a-zA-Z0-9_\.-]+)\b(.+)?\z/; 290 291 $self->die("no nroffer!?") unless $render; 292 my @render_switches = $self->_collect_nroff_switches; 293 294 if ( $switches ) { 295 # Eliminate whitespace 296 $switches =~ s/\s//g; 297 298 # Then separate the switches with a zero-width positive 299 # lookahead on the dash. 300 # 301 # See: 302 # http://www.effectiveperlprogramming.com/blog/1411 303 # for a good discussion of this technique 304 305 push @render_switches, split(/(?=-)/, $switches); 306 } 307 308 $self->debug( "render is $render\n" ); 309 $self->debug( "render options are @render_switches\n" ); 310 311 require Symbol; 312 require IPC::Open3; 313 require IO::Handle; 314 315 # Reset this??? 316 $?=0; 317 318 my $pid = IPC::Open3::open3( 319 my $writer, 320 my $reader, 321 my $err = Symbol::gensym(), 322 $render, 323 @render_switches 324 ); 325 326 $reader->autoflush(1); 327 328 use IO::Select; 329 my $selector = IO::Select->new( $reader ); 330 331 $self->debug( "Writing to pipe to $render\n" ); 332 333 my $offset = 0; 334 my $chunk_size = 4096; 335 my $length = length( ${ $self->{_text_ref} } ); 336 my $chunks = $length / $chunk_size; 337 my $done; 338 my $buffer; 339 while( $offset <= $length ) { 340 $self->debug( "Writing chunk $chunks\n" ); $chunks++; 341 syswrite $writer, ${ $self->{_text_ref} }, $chunk_size, $offset 342 or $self->die( $! ); 343 $offset += $chunk_size; 344 $self->debug( "Checking read\n" ); 345 READ: { 346 last READ unless $selector->can_read( 0.01 ); 347 $self->debug( "Reading\n" ); 348 my $bytes = sysread $reader, $buffer, 4096; 349 $self->debug( "Read $bytes bytes\n" ); 350 $done .= $buffer; 351 $self->debug( sprintf "Output is %d bytes\n", 352 length $done 353 ); 354 next READ; 355 } 356 } 357 close $writer; 358 $self->debug( "Done writing\n" ); 359 360 # read any leftovers 361 $done .= do { local $/; <$reader> }; 362 $self->debug( sprintf "Done reading. Output is %d bytes\n", 363 length $done 364 ); 365 366 if( $? ) { 367 $self->warn( "Error from pipe to $render!\n" ); 368 $self->debug( 'Error: ' . do { local $/; <$err> } ); 369 } 370 371 372 close $reader; 373 if( my $err = $? ) { 374 $self->debug( 375 "Nonzero exit ($?) while running `$render @render_switches`.\n" . 376 "Falling back to Pod::Perldoc::ToPod\n" 377 ); 378 return $self->_fallback_to_pod( @_ ); 379 } 380 381 $self->debug( "Output:\n----\n$done\n----\n" ); 382 383 ${ $self->{_text_ref} } = $done; 384 385 return length ${ $self->{_text_ref} } ? SUCCESS : FAILED; 386 } 387 388sub parse_from_file { 389 my( $self, $file, $outfh) = @_; 390 391 # We have a pipeline of filters each affecting the reference 392 # in $self->{_text_ref} 393 $self->{_text_ref} = \my $output; 394 395 $self->_parse_with_pod_man( $file ); 396 # so far, nroff is an external command so we ensure it worked 397 my $result = $self->_filter_through_nroff; 398 return $self->_fallback_to_pod( @_ ) unless $result == SUCCESS; 399 400 $self->_post_nroff_processing; 401 402 print { $outfh } $output or 403 $self->die( "Can't print to $$self{__output_file}: $!" ); 404 405 return; 406 } 407 408sub _fallback_to_pod { 409 my( $self, @args ) = @_; 410 $self->warn( "Falling back to Pod because there was a problem!\n" ); 411 require Pod::Perldoc::ToPod; 412 return Pod::Perldoc::ToPod->new->parse_from_file(@_); 413 } 414 415# maybe there's a user setting we should check? 416sub _get_tab_width { 4 } 417 418sub _expand_tabs { 419 my( $self ) = @_; 420 421 my $tab_width = ' ' x $self->_get_tab_width; 422 423 ${ $self->{_text_ref} } =~ s/\t/$tab_width/g; 424 } 425 426sub _post_nroff_processing { 427 my( $self ) = @_; 428 429 if( $self->is_hpux ) { 430 $self->debug( "On HP-UX, I'm going to expand tabs for you\n" ); 431 # this used to be a pipe to `col -x` for HP-UX 432 $self->_expand_tabs; 433 } 434 435 if( $self->{'__filter_nroff'} ) { 436 $self->debug( "filter_nroff is set, so filtering\n" ); 437 $self->_remove_nroff_header; 438 $self->_remove_nroff_footer; 439 } 440 else { 441 $self->debug( "filter_nroff is not set, so not filtering\n" ); 442 } 443 444 $self->_handle_unicode; 445 446 return 1; 447 } 448 449# I don't think this does anything since there aren't two consecutive 450# newlines in the Pod::Man output 451sub _remove_nroff_header { 452 my( $self ) = @_; 453 $self->debug( "_remove_nroff_header is still a stub!\n" ); 454 return 1; 455 456# my @data = split /\n{2,}/, shift; 457# shift @data while @data and $data[0] !~ /\S/; # Go to header 458# shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header 459 } 460 461# I don't think this does anything since there aren't two consecutive 462# newlines in the Pod::Man output 463sub _remove_nroff_footer { 464 my( $self ) = @_; 465 $self->debug( "_remove_nroff_footer is still a stub!\n" ); 466 return 1; 467 ${ $self->{_text_ref} } =~ s/\n\n+.*\w.*\Z//m; 468 469# my @data = split /\n{2,}/, shift; 470# pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like 471 # 28/Jan/99 perl 5.005, patch 53 1 472 } 473 474sub _unicode_already_handled { 475 my( $self ) = @_; 476 477 $self->_have_groff_with_utf8 || 478 1 # so, we don't have a case that needs _handle_unicode 479 ; 480 } 481 482sub _handle_unicode { 483# this is the job of preconv 484# we don't need this with groff 1.20 and later. 485 my( $self ) = @_; 486 487 return 1 if $self->_unicode_already_handled; 488 489 require Encode; 490 491 # it's UTF-8 here, but we need character data 492 my $text = Encode::decode( 'UTF-8', ${ $self->{_text_ref} } ) ; 493 494# http://www.mail-archive.com/groff@gnu.org/msg01378.html 495# http://linux.die.net/man/7/groff_char 496# http://www.gnu.org/software/groff/manual/html_node/Using-Symbols.html 497# http://lists.gnu.org/archive/html/groff/2011-05/msg00007.html 498# http://www.simplicidade.org/notes/archives/2009/05/fixing_the_pod.html 499# http://lists.freebsd.org/pipermail/freebsd-questions/2011-July/232239.html 500 $text =~ s/(\P{ASCII})/ 501 sprintf '\\[u%04X]', ord $1 502 /eg; 503 504 # should we encode? 505 ${ $self->{_text_ref} } = $text; 506 } 507 5081; 509 510__END__ 511 512=head1 NAME 513 514Pod::Perldoc::ToMan - let Perldoc render Pod as man pages 515 516=head1 SYNOPSIS 517 518 perldoc -o man Some::Modulename 519 520=head1 DESCRIPTION 521 522This is a "plug-in" class that allows Perldoc to use 523Pod::Man and C<groff> for reading Pod pages. 524 525The following options are supported: center, date, fixed, fixedbold, 526fixeditalic, fixedbolditalic, quotes, release, section 527 528(Those options are explained in L<Pod::Man>.) 529 530For example: 531 532 perldoc -o man -w center:Pod Some::Modulename 533 534=head1 CAVEAT 535 536This module may change to use a different pod-to-nroff formatter class 537in the future, and this may change what options are supported. 538 539=head1 SEE ALSO 540 541L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff> 542 543=head1 COPYRIGHT AND DISCLAIMERS 544 545Copyright (c) 2011 brian d foy. All rights reserved. 546 547Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved. 548 549This library is free software; you can redistribute it and/or modify it 550under the same terms as Perl itself. 551 552This program is distributed in the hope that it will be useful, but 553without any warranty; without even the implied warranty of 554merchantability or fitness for a particular purpose. 555 556=head1 AUTHOR 557 558Current maintainer: Mark Allen C<< <mallen@cpan.org> >> 559 560Past contributions from: 561brian d foy C<< <bdfoy@cpan.org> >> 562Adriano R. Ferreira C<< <ferreira@cpan.org> >>, 563Sean M. Burke C<< <sburke@cpan.org> >> 564 565=cut 566 567