From 97d7e887791f91705f83aa0da31010dbc67e247c Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 29 Nov 2017 14:34:45 +0200 Subject: [PATCH 01/18] Sync all OS detection lines --- lib/Pod/Perldoc.pm | 3 +++ lib/Pod/Perldoc/BaseTo.pm | 1 + 2 files changed, 4 insertions(+) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index cd52aa2..df8f910 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -70,6 +70,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; diff --git a/lib/Pod/Perldoc/BaseTo.pm b/lib/Pod/Perldoc/BaseTo.pm index 37f6510..803e5a5 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; From 95baa18b3223fee86c2b8cfcb9b43fb893d84f1e Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 29 Nov 2017 15:07:12 +0200 Subject: [PATCH 02/18] Move inspection of groff into main module (Perldoc.pm) from ToMan.pm: The ToMan formatter would search for the groff version it has available but based on CPAN RT #120229, we need to determine this much earlier to decide whether to pass on to ToMan or not. This does not make any behavioral changes (other than temporarily removing a debug message). * Two helper functions from Pod::Perldoc::BaseTo were moved into Perldoc.pm: _get_path_components() and _find_executable_in_path(). * Perldoc.pm now has a method inspect_execs() which tries to find all available executables of a given program. It uses data from a new helper function, _exec_data(). Currently only nroff is supported. * From ToMan we removed the code for detecting nroff and instead incorporated them in _exec_data() or a new function _find_executable() -- both in Perldoc.pm. * Perldoc.pm's _inspect_execs() now calls _find_executable(), _find_executable_in_path(), and _get_path_components(). ToTerm can now be switched to ToMan and everything still works as it did before, but we are not doing this yet. The next commit will start addressing the logic for picking ToMan or ToTerm. --- lib/Pod/Perldoc.pm | 104 ++++++++++++++++++++++++++++++++++++-- lib/Pod/Perldoc/BaseTo.pm | 27 ---------- lib/Pod/Perldoc/ToMan.pm | 48 ++---------------- 3 files changed, 104 insertions(+), 75 deletions(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index df8f910..5f1d0f8 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -453,7 +453,7 @@ sub init { $self->{'target'} = undef; - + $self->{'executables'} = $self->inspect_execs(); $self->init_formatter_class_list; $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; @@ -480,6 +480,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'} ||= []; @@ -487,9 +578,11 @@ 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') + $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos || !($ENV{TERM} && ( ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i @@ -777,11 +870,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 803e5a5..221f47a 100644 --- a/lib/Pod/Perldoc/BaseTo.pm +++ b/lib/Pod/Perldoc/BaseTo.pm @@ -69,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` } From 42cab06b8c21e8086987774cab3313f8fe0a6b8e Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 29 Nov 2017 15:27:41 +0200 Subject: [PATCH 03/18] Clean up existing logic for determining whether to use ToTerm: This is just too much to read or figure out at once. Instead of every possible condition (including unless !(...), which is ridiculous), it's simply the obvious cocnditions: A set of OS's or a check on term. If I understand this logic correctly (and I had to write some tests to verify), it means that we are not using ToTerm for Windows, DOS, AmigaOS, or for the recognized terms listed ("*dumb*", "*emacs*", "*none*", and "*unknown*". The fallback is ToText. I guess that makes sense. --- lib/Pod/Perldoc.pm | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 5f1d0f8..462d570 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -582,13 +582,14 @@ sub init_formatter_class_list { # 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; + + $self->opt_o_with('term'); } #.......................................................................... From 4b74b0ec327eba0fba6d6cac3eeba91813ecfbb4 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 29 Nov 2017 16:54:35 +0200 Subject: [PATCH 04/18] Initialize pager (and more) before formatter classes: The formatter class will need to know which pagers have been found so it could determine whether ToTerm is a good option. --- lib/Pod/Perldoc.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 462d570..43ebc7a 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -454,13 +454,14 @@ sub init { $self->{'target'} = undef; $self->{'executables'} = $self->inspect_execs(); - $self->init_formatter_class_list; $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'}; + $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. From 38c0f1f1b1410fe506f26a8a4db24eda6084d59a Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 29 Nov 2017 17:14:24 +0200 Subject: [PATCH 05/18] Only conditionally enable ToTerm, and back to ToMan where possible: The idea is: * If we have an updated version of groff, we can just use ToMan. * If not, we can use ToTerm on the condition that less is updated enough and supports the "-R" flag that will be added to it by ToTerm. * Otherwise, do not apply anything, using the first default set of ToText. --- lib/Pod/Perldoc.pm | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 43ebc7a..ca82194 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -590,7 +590,34 @@ sub init_formatter_class_list { ( $ENV{TERM} || '' ) =~ /dumb|emacs|none|unknown/i and return; - $self->opt_o_with('term'); + # 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 $minimum_groff_version = '1.20.1'; + my $version_string = `$roffer -v`; + my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; + + $version ge $minimum_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_bin) = grep /less/, $self->pagers ) { + my $minimum = '346'; # added between 340 and 346 + my $version_string = `$less_bin --version`; + my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; + + $version ge $minimum + and return $self->opt_o_with('term'); + } + } + + # No fallback listed here, which means we will use ToText + # (provided above) } #.......................................................................... From 51a39e0417ebf35cbe276acb459c7b0bf4b83384 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Fri, 1 Dec 2017 00:07:01 +0200 Subject: [PATCH 06/18] Fix regexp - whoops --- lib/Pod/Perldoc.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index ca82194..9275851 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -609,7 +609,7 @@ sub init_formatter_class_list { if ( my ($less_bin) = grep /less/, $self->pagers ) { my $minimum = '346'; # added between 340 and 346 my $version_string = `$less_bin --version`; - my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; + my( $version ) = $version_string =~ /less (\d+)/; $version ge $minimum and return $self->opt_o_with('term'); From ec918ec974e3d964181179a7825f7f00af45bf05 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Mon, 6 May 2019 20:15:50 +0300 Subject: [PATCH 07/18] Handle pagers set with shell redirection: This is resolving an issue raised by Zefram: The use of `$less_bin --version` is dubious, because, per ->pagers_guessing, $less_bin may contain shell redirection characters, such that "--version" wouldn't necessarily function as a command-line argument to less(1). You may need to parse pager strings in more detail. Instead we're removing any shell redirect character and anything that runs afterwards. --- lib/Pod/Perldoc.pm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 9275851..e1f2f80 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -608,7 +608,10 @@ sub init_formatter_class_list { if ( my ($less_bin) = grep /less/, $self->pagers ) { my $minimum = '346'; # added between 340 and 346 - my $version_string = `$less_bin --version`; + # The less binary can have shell redirection characters + # So we're cleaning that up and everything afterwards + my ($less_bin_clean) = $less_bin =~ /^([^<>]+)/; + my $version_string = `$less_bin_clean --version`; my( $version ) = $version_string =~ /less (\d+)/; $version ge $minimum From 70a7db8c851ed4f43ffbf60ba65c8a58abd3cc8f Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Mon, 6 May 2019 20:35:48 +0300 Subject: [PATCH 08/18] Find the best `less` from *all* available pagers: We had assumed that the first `less` pager is of a sufficient version but that is not necessarily the case. Instead, we now go through all `less` pagers and test each one separately. When we find one of the right version, we stop. If the user doesn't like this, they should set their first pager to the right `less` pager. --- lib/Pod/Perldoc.pm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index e1f2f80..a33dcf4 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -606,8 +606,10 @@ sub init_formatter_class_list { # We can only know if it's one of the detected pagers # (there could be others that would be tried) - if ( my ($less_bin) = grep /less/, $self->pagers ) { + if ( my @less_bins = grep /less/, $self->pagers ) { my $minimum = '346'; # added between 340 and 346 + + 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 =~ /^([^<>]+)/; @@ -618,6 +620,7 @@ sub init_formatter_class_list { and return $self->opt_o_with('term'); } } + } # No fallback listed here, which means we will use ToText # (provided above) From 639b5b28ecaaaadfe664741a00b5fbef05c6c744 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Fri, 15 Dec 2023 11:27:51 +0100 Subject: [PATCH 09/18] Move variable to constant --- lib/Pod/Perldoc.pm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index a33dcf4..dde9891 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -14,6 +14,8 @@ use vars qw($VERSION @Pagers $Bindir $Pod2man ); $VERSION = '3.28'; +sub MIN_GROFF_VERSION () { '1.20.1' } + #.......................................................................... BEGIN { # Make a DEBUG constant very first thing... @@ -594,11 +596,10 @@ sub init_formatter_class_list { # Only those will work propertly with ToMan # The rest is either ToTerm or ToMan again if ( my $roffer = $self->{'executables'}{'nroffer'} ) { - my $minimum_groff_version = '1.20.1'; - my $version_string = `$roffer -v`; + my $version_string = `$roffer -v`; my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; - $version ge $minimum_groff_version + $version ge MIN_GROFF_VERSION() and return $self->opt_o_with('man'); # groff is old, we need to check if our pager is less From 533953fd5ff23e694af092cf4b1c98266cf67483 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Sat, 16 Dec 2023 18:51:26 +0100 Subject: [PATCH 10/18] Add testing for pager guessing function: Much of the future improvements require making sure we get the right pager. To be able to do make the adjustments successfully, we need to set a baseline with this test. It tests environment variables, "-m" option, and OS options. It already exposes a few options that might be worth creating tickets for. --- t/pagers_guessing.t | 190 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 190 insertions(+) create mode 100644 t/pagers_guessing.t diff --git a/t/pagers_guessing.t b/t/pagers_guessing.t new file mode 100644 index 0000000..35dbaee --- /dev/null +++ b/t/pagers_guessing.t @@ -0,0 +1,190 @@ +use strict; +use warnings; +use Pod::Perldoc; +use Test::More 'tests' => 22; + +{ + + 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 }, ); + +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 _pagers_guessing { + + # TODO: This whole subroutine needs to be rewritten. It's semi-insane + # right now. + + my $self = shift; + + my @pagers; + push @pagers, $self->pagers; + $self->{'pagers'} = \@pagers; + + if ( $self->is_mswin32 ) { + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } elsif ( $self->is_vms ) { + push @pagers, qw( most more less type/page ); + } elsif ( $self->is_dos ) { + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } elsif ( $self->is_amigaos ) { + push @pagers, + qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); + unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; + } else { + if ( $self->is_os2 ) { + unshift @pagers, 'less', 'cmd /c more <'; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; + } + + if ( $self->is_cygwin ) { + if ( ( $pagers[0] eq 'less' ) || ( $pagers[0] eq '/usr/bin/less' ) ) { + unshift @pagers, '/usr/bin/less -isrR'; + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + } + + if ( $self->opt_m ) { + unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER}; + } else { + unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER}; + unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER}; + } + + $self->aside( "Pagers: ", ( join ", ", @pagers ) ); + + return; +} + From d05c2296eb17085d44beeff5c2fcfc744b183c23 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Sat, 16 Dec 2023 23:12:45 +0100 Subject: [PATCH 11/18] Guess pagers earlier: We are trying to determine the formatter class (ToTerm, ToMan, etc.) during `init()` but we only do the pager guessing (to figure out which pagers we have) much later when we want to run the paging. Moving the page guessing to the init point allows us to use the pager availability and version to determine the formatter. We also need to improve the detection of `less(1)` version and to do that, we need to collect all possible pagers first, which is done in `pagers_guessing()`. --- lib/Pod/Perldoc.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index dde9891..0f9223c 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -462,6 +462,8 @@ sub init { $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'} = [] }, ( @@ -652,7 +654,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; From a8f0d3701352d9345118a763ea4fcd84356b9331 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Sun, 17 Dec 2023 00:53:58 +0100 Subject: [PATCH 12/18] Add test for the less version detected: This change checks that the code for detecting the `less` version without getting confused by arguments or redirections. It tests every OS setup available, and checks whether it receives the correct binary (after cleaning up redirection and arguments), as well as the index of that binary, just so we know it's not the same binary each time (if "less" is repeated, for example). This regex has another character ("\s") that the original code doesn't, to prove that it's correct to add it. I also temporarily added a redirect to one of the "less" entries, and it showed that the redirection regex works (though it broke other tests, so I removed it before committing). --- t/pagers_guessing.t | 54 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 53 insertions(+), 1 deletion(-) diff --git a/t/pagers_guessing.t b/t/pagers_guessing.t index 35dbaee..417c9f7 100644 --- a/t/pagers_guessing.t +++ b/t/pagers_guessing.t @@ -1,7 +1,7 @@ use strict; use warnings; use Pod::Perldoc; -use Test::More 'tests' => 22; +use Test::More 'tests' => 23; { @@ -108,6 +108,8 @@ 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; @@ -138,6 +140,56 @@ sub test_with_env { } } +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', + ); +} + sub _pagers_guessing { # TODO: This whole subroutine needs to be rewritten. It's semi-insane From 0bd5b5a0e0a2195660f3e248391570ab05e36545 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Sun, 17 Dec 2023 01:09:26 +0100 Subject: [PATCH 13/18] Improve the detection of the less binary: The `less` binary might include arguments (for example, we support `/usr/bin/less -isrR` for Cygwin), so it's better to clean up the arguments before calling `--version`. Arguably, this isn't a bug, but it's better to separate the arguments from the `--version` call. --- lib/Pod/Perldoc.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 0f9223c..eae866d 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -615,7 +615,7 @@ sub init_formatter_class_list { 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 =~ /^([^<>]+)/; + my ($less_bin_clean) = $less_bin =~ /^([^<>\s]+)/; my $version_string = `$less_bin_clean --version`; my( $version ) = $version_string =~ /less (\d+)/; From fc61e82206923c1ac47b7aada5beb72e426dff88 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Sun, 17 Dec 2023 14:40:16 +0100 Subject: [PATCH 14/18] Use accurate semver check for ngroff --- lib/Pod/Perldoc.pm | 27 ++++++++++++++++++++++++++- t/semver_ge.t | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 1 deletion(-) create mode 100644 t/semver_ge.t diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index eae866d..277877e 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -601,7 +601,7 @@ sub init_formatter_class_list { my $version_string = `$roffer -v`; my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/; - $version ge MIN_GROFF_VERSION() + 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 @@ -701,6 +701,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 ); 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' +); From 2a69bf6bb4a3f106610bc107df87c8b44e36502b Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 20 Dec 2023 19:59:56 +0100 Subject: [PATCH 15/18] Cleanup superfluous subroutine in test: I originally copied it over for convenience. It should've have been committed and it's not being called. --- t/pagers_guessing.t | 50 --------------------------------------------- 1 file changed, 50 deletions(-) diff --git a/t/pagers_guessing.t b/t/pagers_guessing.t index 417c9f7..9715230 100644 --- a/t/pagers_guessing.t +++ b/t/pagers_guessing.t @@ -190,53 +190,3 @@ sub test_less_version { ); } -sub _pagers_guessing { - - # TODO: This whole subroutine needs to be rewritten. It's semi-insane - # right now. - - my $self = shift; - - my @pagers; - push @pagers, $self->pagers; - $self->{'pagers'} = \@pagers; - - if ( $self->is_mswin32 ) { - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } elsif ( $self->is_vms ) { - push @pagers, qw( most more less type/page ); - } elsif ( $self->is_dos ) { - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } elsif ( $self->is_amigaos ) { - push @pagers, - qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); - unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; - } else { - if ( $self->is_os2 ) { - unshift @pagers, 'less', 'cmd /c more <'; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; - } - - if ( $self->is_cygwin ) { - if ( ( $pagers[0] eq 'less' ) || ( $pagers[0] eq '/usr/bin/less' ) ) { - unshift @pagers, '/usr/bin/less -isrR'; - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } - } - - if ( $self->opt_m ) { - unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER}; - } else { - unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER}; - unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER}; - } - - $self->aside( "Pagers: ", ( join ", ", @pagers ) ); - - return; -} - From 950aa0ce0b7aac352a02b93efb946ac15387df75 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 20 Dec 2023 20:11:10 +0100 Subject: [PATCH 16/18] Move less version to constant --- lib/Pod/Perldoc.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 277877e..458f876 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -15,6 +15,7 @@ use vars qw($VERSION @Pagers $Bindir $Pod2man $VERSION = '3.28'; sub MIN_GROFF_VERSION () { '1.20.1' } +sub MIN_LESS_VERSION () { '346' } #.......................................................................... @@ -610,8 +611,6 @@ sub init_formatter_class_list { # (there could be others that would be tried) if ( my @less_bins = grep /less/, $self->pagers ) { - my $minimum = '346'; # added between 340 and 346 - foreach my $less_bin (@less_bins) { # The less binary can have shell redirection characters # So we're cleaning that up and everything afterwards @@ -619,7 +618,8 @@ sub init_formatter_class_list { my $version_string = `$less_bin_clean --version`; my( $version ) = $version_string =~ /less (\d+)/; - $version ge $minimum + # added between 340 and 346 + $version ge MIN_LESS_VERSION() and return $self->opt_o_with('term'); } } From 8f78f4bda568f3d3616235830efca70e6233d981 Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 20 Dec 2023 20:11:21 +0100 Subject: [PATCH 17/18] Verify we got less as a pager before adding -R to it: As Zefram pointed out in a ticket, the `/less/` regexp match here doesn't mean we didn't get a different pager with the string "less" in its name. By checking that we received a version, we're also checking a regexp match on the version call to return the result for "less" pager (because the response to `--version` includes "less VERSION_NUMBER"). This means that now pagers that have the string "less" in their name would not be tripped by it (unless they answer to `--version` with "less VERSION_NUMBER") and `less` binaries that have the string "less" but not only "less" would still work (like "lessng" if one would exist). Arguably, we might want to try the `--version` check on all pagers instead of ones that match `/less/` in their name, but... I'm not sure we should. --- lib/Pod/Perldoc.pm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 458f876..2fd669e 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -618,6 +618,12 @@ sub init_formatter_class_list { 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'); From c651c800162a91d5fe66ba4294c9a14653ecb8af Mon Sep 17 00:00:00 2001 From: Sawyer X Date: Wed, 20 Dec 2023 20:16:58 +0100 Subject: [PATCH 18/18] Whitespace --- lib/Pod/Perldoc.pm | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm index 2fd669e..92ce153 100644 --- a/lib/Pod/Perldoc.pm +++ b/lib/Pod/Perldoc.pm @@ -610,26 +610,26 @@ sub init_formatter_class_list { # 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'); + 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)