—

              
package IO::Pager;
our $VERSION = "2.10"; #Untouched since 1.03
use 5.008; #At least, for decent perlio, and other modernisms
use strict;
use warnings;
use base qw( Tie::Handle );
use Env qw( PAGER );
use File::Spec;
use PerlIO;
use Symbol;
use overload '+' => "PID", bool=> "PID";
our $SIGPIPE;
#use Carp; $SIG{__WARN__} = sub{ print STDERR @_, Carp::longmess(),"\n\n"; };
sub find_pager {
  # Return the name (or path) of a pager that IO::Pager can use
  my $io_pager;
  #Permit explicit use of pure perl pager
  local $_ = 'IO::Pager::less';
  return $_ if (defined($_[0]) && ($_[0] eq $_)) or
      (defined($PAGER) && ($PAGER eq $_));
  # Use File::Which if available (strongly recommended)
  my $which = eval { require File::Which };
  # Look for pager in PAGER first
  if ($PAGER) {
    # Strip arguments e.g. 'less --quiet'
    my ($pager, @options) = (split ' ', $PAGER);
    $pager = _check_pagers([$pager], $which);
    $io_pager = join ' ', ($pager, @options) if defined $pager;
  }
  # Then search pager amongst usual suspects
  if (not defined $io_pager) {
    my @pagers = ('/etc/alternatives/pager',
                  '/usr/local/bin/less', '/usr/bin/less', '/usr/bin/more');
    $io_pager = _check_pagers(\@pagers, $which) 
  }
  # Then check PATH for other pagers
  if ( (not defined $io_pager) && $which ) {
    my @pagers = ('less', 'most', 'w3m', 'lv', 'pg', 'more');
    $io_pager = _check_pagers(\@pagers, $which );
  }
  # If all else fails, default to more (actually IO::Pager::less first)
  $io_pager ||= 'more';
  return $io_pager;
}
sub _check_pagers {
  my ($pagers, $which) = @_;
  # Return the first pager in the list that is usable. For each given pager, 
  # given a pager name, try to finds its full path with File::Which if possible.
  # Given a pager path, verify that it exists.
  my $io_pager = undef;
  for my $pager (@$pagers) {
    # Get full path
    my $loc;
    if ( $which && (not File::Spec->file_name_is_absolute($pager)) ) {
      $loc = File::Which::which($pager);
    } else {
      $loc = $pager;
    }
    # Test that full path is valid (some platforms don't do -x so we use -e)
    if ( defined($loc) && (-e $loc) ) {
      $io_pager = $loc;
      last;
    }
  }
  return $io_pager;
}
#Should have this as first block for clarity, but not with its use of a sub
BEGIN { # Set the $ENV{PAGER} to something reasonable
  our $oldPAGER = $PAGER || '';
  $PAGER = find_pager();
   
  if( ($PAGER =~ 'more' and $oldPAGER ne 'more') or
       $PAGER eq 'IO::Pager::less' ){
    my $io_pager = $PAGER;
    eval "use IO::Pager::less";
    $PAGER = $io_pager if $@ or not defined $PAGER;
  }
}
#Factory
sub open(*;$@) { # FH, [MODE], [CLASS]
  my $args = {procedural=>1};
  $args->{mode} = splice(@_, 1, 1) if scalar(@_) == 3;
  $args->{subclass} = pop if scalar(@_) == 2;
  &new(undef, @_, $args);
}
#Alternate entrance: drop class but leave FH, subclass
sub new(*;$@) { # FH, [MODE], [CLASS]
  shift;
  my %args;
  if( ref($_[-1]) eq 'HASH' ){
    %args = %{pop()};
    #warn "REMAINDER? (@_)", scalar @_;
    push(@_, $args{procedural});
  }
  elsif( defined($_[1]) ){
    $args{mode} = splice(@_, 1, 1) if $_[1] =~ /^:/;
    $args{subclass} = pop if exists($_[1]);
  }
  #Leave filehandle in @_ for pass by reference to allow gensym
  $args{subclass} ||= 'IO::Pager::Unbuffered';
  $args{subclass} =~ s/^(?!IO::Pager::)/IO::Pager::/;
  eval "require $args{subclass}" or die "Could not load $args{subclass}: $@\n";
  my $token = $args{subclass}->new(@_);
  if( defined($args{mode}) ){
    $args{mode} =~ s/^\|-//;
    $token->BINMODE($args{mode});
  }
  return $token;
}
sub _init{ # CLASS, [FH] ## Note reversal of order due to CLASS from new()
  #Assign by reference if empty scalar given as filehandle
  $_[1] = gensym() if !defined($_[1]);
  no strict 'refs';
  $_[1] ||= *{select()};
  # Are we on a TTY? STDOUT & STDERR are separately bound
  if ( defined( my $FHn = fileno($_[1]) ) ) {
    if ( $FHn == fileno(STDOUT) ) {
      die '!TTY' unless -t $_[1];
    }
    if ( $FHn == fileno(STDERR) ) {
      die '!TTY' unless -t $_[1];
    }
  }
  #XXX This allows us to have multiple pseudo-STDOUT
  #return 0 unless -t STDOUT;
  return ($_[0], $_[1]);
}
# Methods required for implementing a tied filehandle class
sub TIEHANDLE {
  my ($class, $tied_fh) = @_;
  unless ( $PAGER ){
    die "The PAGER environment variable is not defined, you may need to set it manually.";
  }
  my($real_fh, $child, $dupe_fh);
# XXX What about localized GLOBs?!
#  if( $tied_fh =~ /\*(?:\w+::)?STD(?:OUT|ERR)$/ ){
#      open($dupe_fh, '>&', $tied_fh) or warn "Unable to dupe $tied_fh";
#  }
  do{ no warnings; $child = CORE::open($real_fh, '|-', $PAGER) };
  if ( $child ){
    my @oLayers = PerlIO::get_layers($tied_fh, details=>1, output=>1);
    my $layers = '';
    for(my $i=0;$i<$#oLayers;$i+=3){
      #An extra base layer requires more keystrokes to exit
      next if $oLayers[$i] =~ /unix|stdio/ && !defined($oLayers[+1]);
      $layers .= ":$oLayers[$i]";
      $layers .=  '(' . ($oLayers[$i+1]) . ')' if defined($oLayers[$i+1]);
    }
    CORE::binmode($real_fh, $layers);
  }
  else{
    die "Could not pipe to PAGER ('$PAGER'): $!\n";
  }
  return bless {
                'real_fh' => $real_fh,
#               'dupe_fh' => $dupe_fh,
                'tied_fh' => "$tied_fh", #Avoid self-reference leak
                'child'   => $child,
                'pager'   => $PAGER,
               }, $class;
}
sub BINMODE {
  my ($self, $layer) = @_;
  if( $layer =~ /^:LOG\((>{0,2})(.*)\)$/ ){
    CORE::open($self->{LOG}, $1||'>', $2||"$$.log") or die $!;
  }
  else{
    CORE::binmode($self->{real_fh}, $layer||':raw');
  }
}
sub WNOHANG();
sub EOF {
  my $self = shift;
  unless( defined($SIGPIPE) ){
    eval 'use POSIX ":sys_wait_h";';
    $SIGPIPE = 0;
  }
  $SIG{PIPE} = sub { $SIGPIPE = 1 unless $ENV{IP_EOF};
                     CORE::close($self->{real_fh});
                     waitpid($self->{child}, WNOHANG);
                     CORE::open($self->{real_fh}, '>&1');
                     close($self->{LOG});
                   };
  return $SIGPIPE;
}
sub PRINT {
  my ($self, @args) = @_;
  CORE::print {$self->{LOG}} @args if exists($self->{LOG});
  CORE::print {$self->{real_fh}} @args or die "Could not print to PAGER: $!\n";
}
sub PRINTF {
  my ($self, $format, @args) = @_;
  $self->PRINT(sprintf($format, @args));
}
sub say {
  my ($self, @args) = @_;
  $args[-1] .= "\n";
  $self->PRINT(@args);
}
sub WRITE {
  my ($self, $scalar, $length, $offset) = @_;
  $self->PRINT(substr($scalar, $offset||0, $length));
}
sub TELL {
  #Buffered classes provide their own, and others may use this in another way
  return undef;
}
sub FILENO {
  CORE::fileno($_[0]->{real_fh});
}
sub CLOSE {
  my ($self) = @_;
  CORE::close($self->{real_fh});
#  untie($self->{tied_fh});
#  *{$self->{tied_fh}} = *{$self->{dupe_fh}};
}
{ no warnings 'once'; *DESTROY = \&CLOSE; }
#Non-IO methods
sub PID{
  my ($self) = @_;
  return $self->{child};
}
#Provide lowercase aliases for accessors
foreach my $method ( qw(BINMODE CLOSE EOF PRINT PRINTF TELL WRITE PID) ){
  no strict 'refs';
  *{lc($method)} = \&{$method};
}
1;
HideShow 330 lines of Pod
__END__
=pod
=head1 NAME
IO::Pager - Select a pager (possibly perl-based) & pipe it text if a TTY
=head1 SYNOPSIS
  # Select an appropriate pager and set the PAGER environment variable
  use IO::Pager;
  # TIMTOWTDI Object-oriented
  {
    # open()                           # Use all the defaults.
    my $object = new IO::Pager;
    # open FILEHANDLE                  # Unbuffered is default subclass
    my $object = new IO::Pager *STDOUT;
    # open FILEHANDLE,EXPR             # Specify subclass
    my $object = new IO::Pager *STDOUT,  'Unbuffered';
    # Direct subclass instantiation    # FH is optional
    use IO::Pager::Unbuffered;
    my $object = new IO::Pager::Unbuffered  *STDOUT;
    $object->print("OO shiny...\n") while 1;
    print "Some other text sent to STODUT, perhaps from a foreign routine."
    # $object passes out of scope and filehandle is automagically closed
  }
  # TIMTOWTDI Procedural
  {
    # open FILEHANDLE                    # Unbuffered is default subclass
    my $token = IO::Pager::open *STDOUT;
    # open FILEHANDLE,EXPR               # Specify subclass
    my $token = IO::Pager::open *STDOUT,  'Unbuffered';
    # open FILEHANDLE,MODE,EXPR          # En lieu of a separate binmode()
    my $token = IO::Pager::open *STDOUT, '|-:utf8', 'Unbuffered';
    print <<"  HEREDOC" ;
    ...
    A bunch of text later
    HEREDOC
    # $token passes out of scope and filehandle is automagically closed
  }
  {
    # You can also use scalar filehandles...
    my $token = IO::Pager::open(my $FH) or warn($!); XXX
    print $FH "No globs or barewords for us thanks!\n" while 1;
  }
=head1 DESCRIPTION
IO::Pager can be used to locate an available pager and set the I<PAGER>
environment variable (see L</NOTES>). It is also a factory for creating
I/O objects such as L<IO::Pager::Buffered> and L<IO::Pager::Unbuffered>.
IO::Pager subclasses are designed to programmatically decide whether
or not to pipe a filehandle's output to a program specified in I<PAGER>.
Subclasses may implement only the IO handle methods desired and inherit
the remainder of those outlined below from IO::Pager. For anything else,
YMMV. See the appropriate subclass for implementation specific details.
=head1 METHODS
=head2 new( FILEHANDLE, [MODE], [SUBCLASS] )
Almost identical to open, except that you will get an L<IO::Handle>
back if there's no TTY to allow for IO::Pager-agnostic programming.
=head2 open( FILEHANDLE, [MODE], [SUBCLASS] )
Instantiate a new IO::Pager, which will paginate output sent to
FILEHANDLE if interacting with a TTY.
Save the return value to check for errors, use as an object,
or for implict close of OO handles when the variable passes out of scope.
=over
=item FILEHANDLE
You may provide a glob or scalar.
Defaults to currently select()-ed F<FILEHANDLE>.
=item SUBCLASS
Specifies which variety of IO::Pager to create.
This accepts fully qualified packages I<IO::Pager::Buffered>,
or simply the third portion of the package name I<Buffered> for brevity.
Defaults to L<IO::Pager::Unbuffered>.
Returns false and sets I<$!> on failure, same as perl's C<open>.
=back
=head2 PID
Call this method on the token returned by C<open> to get the process
identifier for the child process i.e; pager; if you need to perform
some long term process management e.g; perl's C<waitpid>
You can also access the PID by numifying the instantiation token like so:
  my $child = $token+0;
=head2 close( FILEHANDLE )
Explicitly close the filehandle, this stops any redirection of output
on FILEHANDLE that may have been warranted.
I<This does not default to the current filehandle>.
Alternatively, you may rely upon the implicit close of lexical handles
as they pass out of scope e.g;
  {
     IO::Pager::open local *RIBBIT;
     print RIBBIT "No toad sexing allowed";
     ...
  }
  #The filehandle is closed to additional output
  {
     my $token = new IO::Pager::Buffered;
     $token->print("I like trains");
     ...
  }
  #The string "I like trains" is flushed to the pager, and the handle closed
=head2 binmode( FILEHANDLE, [LAYER] )
Used to set the I/O layer a.k.a. discipline of a filehandle,
such as C<':utf8'> for UTF-8 encoding.
=head3 :LOG([>>FILE])
IO::Pager implements a pseudo-IO-layer for capturing output and sending it
to a file, similar to L<tee(1)>. Although it is limited to one file, this
feature is pure-perl and adds no dependencies.
You may indicate what file to store in parentheses, otherwise the default is
C<$$.log>. You may also use an implicit (no indicator) or explicit (I<E<gt>>)
indicator to overwrite an existing file, or an explicit (I<E<gt>E<gt>>) for
appending to a log file. For example:
    binmode(*STDOUT, ':LOG(clobber.log)');
    ...
    $STDOUT->binmode(':LOG(>>noclobber.log)');
For full tee-style support, use L<PerlIO::Util> like so:
    binmode(*STDOUT, ":tee(TH)");
    #OR
    $STDOUT->binmode(':tee(TH)');
=head2 eof( FILEHANDLE )
Used in the eval-until-eof idiom below, I<IO::Pager> will handle broken pipes
from deceased children for you in one of two ways. If I<$ENV{IP_EOF}> is
false then program flow will pass out of the loop on I<SIGPIPE>, this is the
default. If the variable is true, then the program continues running with
output for the previously paged filehandle directed to the I<STDOUT> stream;
more accurately, the filehandle is reopened to file descriptor 1.
  use IO::Pager::Page; #or whichever you prefer;
  ...
  eval{
    say "Producing prodigious portions of product";
    ...
  } until( eof(*STDOUT) );
  print "Cleaning up after our child before terminating."
If using eof() with L<less>, especially when IP_EOF is set, you may want to
use the I<--no-init> option by setting I<$ENV{IP_EOF}='X'> to prevent the
paged output from being erased when the pager exits.
=head2 fileno( FILEHANDLE )
Return the filehandle number of the write-only pipe to the pager.
=head2 print( FILEHANDLE LIST )
print() to the filehandle.
=head2 printf( FILEHANDLE FORMAT, LIST )
printf() to the filehandle.
=head2 syswrite( FILEHANDLE, SCALAR, [LENGTH], [OFFSET] )
syswrite() to the filehandle.
=head1 ENVIRONMENT
=over
=item IP_EOF
Controls IO:Pager behavior when C<eof> is used.
=item PAGER
The location of the default pager.
=item PATH
If the location in PAGER is not absolute, PATH may be searched.
See L</NOTES> for more information.
=back
=head1 FILES
IO::Pager may fall back to these binaries in order if I<PAGER> is not
executable.
=over
=item /etc/alternatives/pager
=item /usr/local/bin/less
=item /usr/bin/less
=item L<IO::Pager::Perl> as C<tp> via L<IO::Pager::less>
=item /usr/bin/more
=back
See L</NOTES> for more information.
=head1 NOTES
The algorithm for determining which pager to use is as follows:
=over
=item 1. Defer to I<PAGER>
If the I<PAGER> environment variable is set, use the pager it identifies,
unless this pager is not available.
=item 2. Usual suspects
Try the standard, hardcoded paths in L</FILES>.
=item 3. File::Which
If File::Which is available, use the first pager possible amongst
C<less>, C<most>, C<w3m>, C<lv>, C<pg> and L<more>.
=item 4. Term::Pager via IO::Pager::Perl
You may also set $ENV{PAGER} to
Term::Pager to select this extensible, pure perl pager for display.
=item 5. more
Set I<PAGER> to C<more>, and cross our fingers.
=back
Steps 1, 3 and 5 rely upon the I<PATH> environment variable.
=head1 CAVEATS
You probably want to do something with SIGPIPE eg;
  eval {
    local $SIG{PIPE} = sub { die };
    local $STDOUT = IO::Pager::open(*STDOUT);
    while (1) {
      # Do something
    }
  }
  # Do something else
=head1 SEE ALSO
L<IO::Pager::Buffered>, L<IO::Pager::Unbuffered>, L<I::Pager::Perl>,
L<IO::Pager::Page>, L<IO::Page>, L<Meta::Tool::Less>
=head1 AUTHOR
Jerrad Pierce <jpierce@cpan.org>
Florent Angly <florent.angly@gmail.com>
This module was inspired by Monte Mitzelfelt's IO::Page 0.02
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2003-2020 Jerrad Pierce
=over
=item * Thou shalt not claim ownership of unmodified materials.
=item * Thou shalt not claim whole ownership of modified materials.
=item * Thou shalt grant the indemnity of the provider of materials.
=item * Thou shalt use and dispense freely without other restrictions.
=back
Or, if you prefer:
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.0 or,
at your option, any later version of Perl 5 you may have available.
=cut