File Coverage

blib/lib/OptArgs2/Pager.pm

Criterion	Covered	Total	%
statement	21	67	31.3
branch	0	28	0.0
condition	0	17	0.0
subroutine	7	15	46.6
pod	5	6	83.3
total	33	133	24.8

package OptArgs2::Pager;
use strict;
use warnings;
use Carp ();
use Exporter::Tidy other => [qw/page start_pager stop_pager/];
use File::Which;
use IO::Handle;
use OptArgs2::Pager_CI {

    # User provided arguments
    auto     => { default => 1, },
    encoding => { default => ':utf8', },
    pager    => { default => \&_build_pager, },

    # Attributes
    fh => {
        init_arg => undef,
        is       => 'rw',
        default  => sub { IO::Handle->new },
    },
    orig_fh => {
        init_arg => undef,
        default  => sub { select },
    },
    pid => {
        init_arg => undef,
        is       => 'rw',
        init_arg => undef,
    },
};

our @CARP_NOT = (__PACKAGE__);

sub _build_pager {
    my $self = shift;

    if ( exists $ENV{PAGER} ) {
        return unless length( $ENV{PAGER} );

        # Explicit pager defined
        my ( $pager, @options ) = split ' ', $ENV{PAGER};
        my $path = File::Which::which($pager);
        Carp::croak("pager not found: $pager") unless $path;
        return join( ' ', $path, @options );
    }

    # Otherwise take the first from our own list
    foreach my $pager (qw/pager less most w3m lv pg more/) {
        my $path = File::Which::which($pager);
        return $path if $path;
    }

    Carp::croak("no suitable pager found");
}

sub BUILD {
    my $self = shift;
    $self->open;
    select $self->fh if $self->auto;
}

sub open {
    my $self = shift;

    return $self->fh if $self->fh->opened;

    if ( not -t $self->orig_fh ) {
        $self->fh( $self->orig_fh );
        return;
    }

    my $pager = $self->pager || return;

    local $ENV{LESS} = $ENV{LESS} // '-FSXeR';
    local $ENV{MORE} = $ENV{MORE} // '-FXer' unless $^O eq 'MSWin32';

    $self->pid( CORE::open( $self->fh, '|-', $pager ) )
      or Carp::croak "Could not pipe to PAGER ('$pager'): $!\n";

    binmode( $self->fh, $self->encoding ? $self->encoding : () )
      or Carp::cluck "Could not set bindmode: $!";

    $self->fh->autoflush(1);
}

sub close {
    my $self = shift;
    return unless $self->fh && $self->fh->opened;

    select $self->orig_fh;
    $self->fh->close if $self->fh ne $self->orig_fh;
}

sub DESTROY {
    my $self = shift;
    $self->close;
}

# Functions
my $pager;

sub start_pager {
    $pager //= __PACKAGE__->new(@_);
    $pager->open;
    select $pager->fh;
}

sub stop_pager {
    $pager // return;
    $pager->close;
    select( $pager->orig_fh );
}

sub page {
    my $text  = shift;
    my $close = not $pager;

    $pager //= __PACKAGE__->new( @_, auto => 0 );
    $pager->open;
    my $ok = $pager->fh->printflush($text);
    $pager->close if $close;
    $ok;
}

1;

__END__