diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index cd52aa2..92ce153 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -14,6 +14,9 @@ use vars qw($VERSION @Pagers $Bindir $Pod2man ); $VERSION = '3.28'; +sub MIN_GROFF_VERSION () { '1.20.1' } +sub MIN_LESS_VERSION () { '346' } + #.......................................................................... BEGIN { # Make a DEBUG constant very first thing... @@ -70,6 +73,9 @@ BEGIN { *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; + *is_openbsd = $^O =~ m/openbsd/ ? \&TRUE : \&FALSE unless defined &is_openbsd; + *is_freebsd = $^O =~ m/freebsd/ ? \&TRUE : \&FALSE unless defined &is_freebsd; + *is_bitrig = $^O =~ m/bitrig/ ? \&TRUE : \&FALSE unless defined &is_bitrig; } $Temp_File_Lifetime ||= 60 * 60 * 24 * 5; @@ -450,14 +456,17 @@ sub init { $self->{'target'} = undef; - - $self->init_formatter_class_list; + $self->{'executables'} = $self->inspect_execs(); $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; $self->{'search_path'} = [ ] unless exists $self->{'search_path'}; + # Formatters are dependent on available pagers + $self->pagers_guessing; + $self->init_formatter_class_list; + push @{ $self->{'formatter_switches'} = [] }, ( # Yeah, we could use a hashref, but maybe there's some class where options # have to be ordered; so we'll use an arrayref. @@ -477,6 +486,97 @@ sub init { #.......................................................................... +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 _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? + } + +#.......................................................................... + +# Inspect each program to determine if it's available and what version it is +# This is important because it helps determine which formatter we can use +# It used to choose and then the formatter would inspect if it has the binaries it needs +# But we need to know whether binaries are available in order to determine the formatter +sub _exec_data { + my $self = shift; + return +{ + 'nroffer' => { + 'candidates' => [ $self->_roffer_candidates ], + 'check' => sub { $self->_check_nroffer(@_) }, + }, + }; +} + +sub inspect_execs { + my $self = shift; + + # nroffer + my $nroffer_data = $self->_exec_data->{'nroffer'}; + my $nroffer = $self->_find_executable( @{ $nroffer_data->{'candidates'} } ); + $nroffer_data->{'check'}->($nroffer); + + return +{ + 'nroffer' => $nroffer, + }; +} + +sub _find_executable { + my( $self, @candidates ) = @_; + + my @found = (); + foreach my $candidate ( @candidates ) { + push @found, $self->_find_executable_in_path( $candidate ); + } + + return wantarray ? @found : $found[0]; + } + +sub _get_path_components { + my( $self ) = @_; + + my @paths = split /\Q$Config{path_sep}/, $ENV{PATH}; + + return @paths; + } + +sub _find_executable_in_path { + my( $self, $program ) = @_; + + my @found = (); + foreach my $dir ( $self->_get_path_components ) { + my $binary = catfile( $dir, $program ); + $self->debug( "Looking for $binary\n" ); + next unless -e $binary; + unless( -x $binary ) { + $self->warn( "Found $binary but it's not executable. Skipping.\n" ); + next; + } + $self->debug( "Found $binary\n" ); + push @found, $binary; + } + + return @found; + } + +#.......................................................................... + sub init_formatter_class_list { my $self = shift; $self->{'formatter_classes'} ||= []; @@ -484,15 +584,55 @@ sub init_formatter_class_list { # Remember, no switches have been read yet, when # we've started this routine. + # Here we decide the different formatter classes + # but do *not* instantiate them yet, despite the subroutine name! $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru $self->opt_o_with('text'); - $self->opt_o_with('term') - unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos - || !($ENV{TERM} && ( - ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i - )); - return; + $self->is_mswin32 || $self->is_dos || $self->is_amigaos + and return; + + ( $ENV{TERM} || '' ) =~ /dumb|emacs|none|unknown/i + and return; + + # We need a version that properly supports ANSI escape codes + # Only those will work propertly with ToMan + # The rest is either ToTerm or ToMan again + if ( my $roffer = $self->{'executables'}{'nroffer'} ) { + my $version_string = `$roffer -v`; + my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; + + semver_ge( $version, MIN_GROFF_VERSION() ) + and return $self->opt_o_with('man'); + + # groff is old, we need to check if our pager is less + # because if so, we can use ToTerm + # We can only know if it's one of the detected pagers + # (there could be others that would be tried) + + if ( my @less_bins = grep /less/, $self->pagers ) { + foreach my $less_bin (@less_bins) { + # The less binary can have shell redirection characters + # So we're cleaning that up and everything afterwards + my ($less_bin_clean) = $less_bin =~ /^([^<>\s]+)/; + my $version_string = `$less_bin_clean --version`; + my( $version ) = $version_string =~ /less (\d+)/; + + # We're using the regexp match here to figure out + # if we found less to begin with, because the initial + # regexp match for @less_bins is too permissive + $version + or next; + + # added between 340 and 346 + $version ge MIN_LESS_VERSION() + and return $self->opt_o_with('term'); + } + } + } + + # No fallback listed here, which means we will use ToText + # (provided above) } #.......................................................................... @@ -520,7 +660,6 @@ sub process { return $self->usage_brief unless @{ $self->{'args'} }; $self->options_reading; - $self->pagers_guessing; $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); $self->drop_privs_maybe unless ($self->opt_U || $self->opt_F); $self->options_processing; @@ -568,6 +707,31 @@ sub process { } #.......................................................................... + +sub semver_ge { + my ( $version, $target_version ) = @_; + + my @version_parts = split /\./, $version; + my @target_version_parts = split /\./, $target_version; + + for (my $i = 0; $i <= $#version_parts; $i++) { + # Version part greater, return true + $version_parts[$i] > $target_version_parts[$i] + and return 1; + + # Version part less, return false + $version_parts[$i] < $target_version_parts[$i] + and return 0; + + # Parts equal, keep going + } + + # All parts equal, return true + return 1; +} + +#.......................................................................... + { my( %class_seen, %class_loaded ); @@ -774,11 +938,14 @@ sub options_processing { $self->options_sanity; - # This used to set a default, but that's now moved into any + # This used to set a default, but then moved into any # formatter that cares to have a default. + # However, we need to set the default nroffer if( $self->opt_n ) { $self->add_formatter_option( '__nroffer' => $self->opt_n ); - } + } else { + $self->add_formatter_option( '__nroffer' => $self->{'executables'}{'nroffer'} ); + } # Get language from PERLDOC_POD2 environment variable if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) { diff --git a/lib/Pod/Perldoc/BaseTo.pm b/lib/Pod/Perldoc/BaseTo.pm index 37f6510..221f47a 100644 --- a/lib/Pod/Perldoc/BaseTo.pm +++ b/lib/Pod/Perldoc/BaseTo.pm @@ -32,6 +32,7 @@ BEGIN { *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin; *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; + *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; *is_openbsd = $^O =~ m/openbsd/ ? \&TRUE : \&FALSE unless defined &is_openbsd; *is_freebsd = $^O =~ m/freebsd/ ? \&TRUE : \&FALSE unless defined &is_freebsd; *is_bitrig = $^O =~ m/bitrig/ ? \&TRUE : \&FALSE unless defined &is_bitrig; @@ -68,33 +69,6 @@ sub die { croak join "\n", @messages, ''; } -sub _get_path_components { - my( $self ) = @_; - - my @paths = split /\Q$Config{path_sep}/, $ENV{PATH}; - - return @paths; - } - -sub _find_executable_in_path { - my( $self, $program ) = @_; - - my @found = (); - foreach my $dir ( $self->_get_path_components ) { - my $binary = catfile( $dir, $program ); - $self->debug( "Looking for $binary\n" ); - next unless -e $binary; - unless( -x $binary ) { - $self->warn( "Found $binary but it's not executable. Skipping.\n" ); - next; - } - $self->debug( "Found $binary\n" ); - push @found, $binary; - } - - return @found; - } - 1; __END__ diff --git a/lib/Pod/Perldoc/ToMan.pm b/lib/Pod/Perldoc/ToMan.pm index bfcb5c4..2325291 100644 --- a/lib/Pod/Perldoc/ToMan.pm +++ b/lib/Pod/Perldoc/ToMan.pm @@ -47,50 +47,10 @@ sub new { 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? + # We used to print the __nroffer here, but we can't anymore + # Because it only gets applied after the new() and init() calls + # Check Pod::Perldoc::render_findings() (under formatter_switches) + #$self->debug( "__nroffer is " . $self->__nroffer() . "\n" ); } sub _get_stty { `stty -a` } diff --git a/t/pagers_guessing.t b/t/pagers_guessing.t new file mode 100644 index 0000000..9715230 --- /dev/null +++ b/t/pagers_guessing.t @@ -0,0 +1,192 @@ +use strict; +use warnings; +use Pod::Perldoc; +use Test::More 'tests' => 23; + +{ + + package MyTestObject; + sub pagers { defined $_[0]->{'pagers'} ? $_[0]->{'pagers'} : () } + sub is_mswin32 { $_[0]->{'mswin32'} } + sub is_vms { $_[0]->{'vms'} } + sub is_dos { $_[0]->{'dos'} } + sub is_amigaos { $_[0]->{'amigaos'} } + sub is_os2 { $_[0]->{'os2'} } + sub is_cygwin { $_[0]->{'cygwin'} } + sub opt_m { $_[0]->{'opt_m'} } + sub aside {1} +} + +my $env_pager = 'myenvpager'; +my $env_pdoc_src_pager = 'src_pager'; +my $env_man_pager = 'man_pager'; +my $env_pdoc_pager = 'perldoc_pager'; +my %test_cases = ( + 'MSWin' => { + 'mswin32' => 1, + 'test' => [ $env_pager, 'more<', 'less', 'notepad' ], + }, + + 'VMS' => { + 'vms' => 1, + 'test' => [ 'most', 'more', 'less', 'type/page' ], + }, + + 'DOS' => { + 'dos' => 1, + 'test' => [ $env_pager, 'less.exe', 'more.com<' ], + }, + + 'AmigaOS' => { + 'amigaos' => 1, + 'test' => [ + $env_pager, '/SYS/Utilities/MultiView', + '/SYS/Utilities/More', '/C/TYPE' + ], + }, + + 'OS2' => { + 'os2' => 1, + 'test' => [ + "$env_pager <", 'less', 'cmd /c more <', 'more', + 'less', 'pg', 'view', 'cat' + ], + }, + + 'Unix' => { + 'unix' => 1, + 'test' => [ "$env_pager <", 'more', 'less', 'pg', 'view', 'cat' ], + }, + + 'Cygwin (with less with PAGER)' => { + 'cygwin' => 1, + 'pagers' => 'less', + 'test' => + [ "$env_pager <", 'less', 'more', 'less', 'pg', 'view', 'cat' ], + }, + + 'Cygwin (with /usr/bin/less with PAGER)' => { + 'cygwin' => 1, + 'pagers' => '/usr/bin/less', + 'test' => [ + "$env_pager <", '/usr/bin/less', + 'more', 'less', + 'pg', 'view', + 'cat' + ], + }, + + # XXX: Apparently less now appears twice + 'Cygwin (with less without PAGER)' => { + 'cygwin' => 1, + 'pagers' => 'less', + 'test_no_pager' => 1, + 'test' => [ + '/usr/bin/less -isrR', + 'less', 'more', 'less', 'pg', 'view', 'cat' + ], + }, + + # XXX: Apparently less now appears twice + 'Cygwin (with /usr/bin/less without PAGER)' => { + 'cygwin' => 1, + 'pagers' => '/usr/bin/less', + 'test_no_pager' => 1, + 'test' => [ + '/usr/bin/less -isrR', + '/usr/bin/less', 'more', 'less', 'pg', 'view', 'cat' + ], + }, + + 'Cygwin (without less)' => { + 'cygwin' => 1, + 'test' => [ "$env_pager <", 'more', 'less', 'pg', 'view', 'cat' ], + }, +); + +test_with_env( { 'opt_m' => 1 }, ); + +test_with_env( { 'opt_m' => 0 }, ); + +test_less_version(); + +sub test_with_env { + my ($args) = @_; + local $ENV{'PERLDOC_SRC_PAGER'} = $env_pdoc_src_pager; + local $ENV{'MANPAGER'} = $env_man_pager; + local $ENV{'PERLDOC_PAGER'} = $env_pdoc_pager; + + foreach my $os ( sort keys %test_cases ) { + my $perldoc = bless +{ %{ $test_cases{$os} }, %{$args} }, + 'MyTestObject'; + my $test = [ @{ $test_cases{$os}{'test'} } ]; + my $no_pager = $test_cases{$os}{'test_no_pager'}; + + $no_pager + or local $ENV{'PAGER'} = $env_pager; + + if ( $args->{'opt_m'} ) { + unshift @{$test}, $env_pdoc_src_pager; + } else { + unshift @{$test}, "$env_pdoc_pager <", "$env_man_pager <"; + } + + Pod::Perldoc::pagers_guessing($perldoc); + is_deeply( + $perldoc->{'pagers'}, $test, + "Correct pager ($os): " . join ', ', + @{ $perldoc->{'pagers'} }, + ); + } +} + +sub test_less_version { + my $less_version_high = 'less 347 (GNU regular expressions)'; + my $less_version_low = 'less 345'; + my $minimum = '346'; # added between 340 and 346 + my @found_bins; + + foreach my $os ( sort keys %test_cases ) { + for ( my $i = 0; $i <= $#{ $test_cases{$os}{'test'} }; $i++ ) { + my $less_bin = $test_cases{$os}{'test'}[$i]; + + $less_bin =~ /less/ + or next; + + foreach my $version_string ( $less_version_high, $less_version_low ) { + # The less binary can have shell redirection characters + # So we're cleaning that up and everything afterwards + my ($less_bin_clean) = $less_bin =~ /^([^<>\s]+)/; + my ($version) = $version_string =~ /less (\d+)/; + + $version ge $minimum + and push @found_bins, [ $os, $less_bin_clean, $i ]; + } + } + } + + is_deeply( + \@found_bins, + [ + [ 'Cygwin (with /usr/bin/less with PAGER)', '/usr/bin/less', 1 ], + [ 'Cygwin (with /usr/bin/less with PAGER)', 'less', 3 ], + [ 'Cygwin (with /usr/bin/less without PAGER)', '/usr/bin/less', 0 ], + [ 'Cygwin (with /usr/bin/less without PAGER)', '/usr/bin/less', 1 ], + [ 'Cygwin (with /usr/bin/less without PAGER)', 'less', 3 ], + [ 'Cygwin (with less with PAGER)', 'less', 1 ], + [ 'Cygwin (with less with PAGER)', 'less', 3 ], + [ 'Cygwin (with less without PAGER)', '/usr/bin/less', 0 ], + [ 'Cygwin (with less without PAGER)', 'less', 1 ], + [ 'Cygwin (with less without PAGER)', 'less', 3 ], + [ 'Cygwin (without less)', 'less', 2 ], + [ 'DOS', 'less.exe', 1 ], + [ 'MSWin', 'less', 2 ], + [ 'OS2', 'less', 1 ], + [ 'OS2', 'less', 4 ], + [ 'Unix', 'less', 2], + [ 'VMS', 'less', 2 ], + ], + 'All less versions handled without redirection and arguments', + ); +} + diff --git a/t/semver_ge.t b/t/semver_ge.t new file mode 100644 index 0000000..faf1577 --- /dev/null +++ b/t/semver_ge.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More 'tests' => 17; +use Pod::Perldoc; + +# Version Tested | Tested Against | Description +my @test_cases = ( + [ '2.0.0', '1.0.0', 'Increment in Major Version' ], + [ '1.0.0', '0.1.0', 'Major Version Zero' ], + [ '1.2.0', '1.1.0', 'Increment in Minor Version' ], + [ '2.1.0', '1.5.0', 'Minor Version Changes with Same Major' ], + [ '1.0.2', '1.0.1', 'Increment in Patch Version' ], + [ '1.3.0', '1.2.3', 'Patch Version with Same Major and Minor' ], + [ '1.1.0', '1.0.999999999', 'Very Large Numbers' ], +); + +# more use-cases +# '1.0.0', '1.0.0-alpha', 'Pre-release Versions', +# '1.0.0+build.2', '1.0.0+build.1', 'Build Metadata', +# '1.a.0', 'Valid versions', 'Non-Numeric Parts', + +foreach my $test (@test_cases) { + ok( Pod::Perldoc::semver_ge( $test->[0], $test->[1] ), $test->[2] ); + ok( !Pod::Perldoc::semver_ge( $test->[1], $test->[0] ), $test->[2] ); +} + +my $equal_ver = '1.2.3'; +ok( Pod::Perldoc::semver_ge( $equal_ver, $equal_ver ), 'Equal Versions' ); +ok( + Pod::Perldoc::semver_ge( $equal_ver, '01.02.03' ), + 'Equal Versions (Zero Padding)', +); + +ok( + Pod::Perldoc::semver_ge( '01.02.03', $equal_ver ), + 'Equal Versions (Zero Padding) in reverse' +);