File Coverage

blib/lib/IO/Pager.pm

Criterion	Covered	Total	%
statement	92	150	61.3
branch	29	66	43.9
condition	16	48	33.3
subroutine	19	31	61.2
pod	3	5	60.0
total	159	300	53.0

package IO::Pager;
our $VERSION = "2.00"; #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;

__END__