Conditionally restore ToMan functionality

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,22 +486,153 @@ 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'} ||= [];
 
   # 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} ) {

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__

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` }

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',
+    );
+}
+

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'
+);