File Coverage

blib/lib/OptArgs2/Pager.pm

Criterion	Covered	Total	%
statement	91	122	74.5
branch	19	54	35.1
condition	15	40	37.5
subroutine	19	24	79.1
pod	11	13	84.6
total	155	253	61.2

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;
### START Class::Inline ### v0.0.1 Wed Dec  3 10:44:51 2025
require Carp;
our ( @_CLASS, $_FIELDS, %_NEW );

sub new {
    my $class = shift;
    my $CLASS = ref $class || $class;
    $_NEW{$CLASS} //= do {
        my ( %seen, @new, @build );
        my @possible = ($CLASS);
        while (@possible) {
            my $c = shift @possible;
            no strict 'refs';
            push @new,   $c . '::_NEW'  if exists &{ $c . '::_NEW' };
            push @build, $c . '::BUILD' if exists &{ $c . '::BUILD' };
            $seen{$c}++;
            if ( exists &{ $c . '::DOES' } ) {
                push @possible, grep { not $seen{$_}++ } $c->DOES('*');
            }
            push @possible, grep { not $seen{$_}++ } @{ $c . '::ISA' };
        }
        [ [ reverse(@new) ], [ reverse(@build) ] ];
    };
    my $self = { @_ ? @_ > 1 ? @_ : %{ $_[0] } : () };
    bless $self, $CLASS;
    my $attrs = { map { ( $_ => 1 ) } keys %$self };
    map { $self->$_($attrs) } @{ $_NEW{$CLASS}->[0] };
    {
        local $Carp::CarpLevel = 3;
        Carp::carp("OptArgs2::Pager: unexpected argument '$_'") for keys %$attrs
    }
    map { $self->$_ } @{ $_NEW{$CLASS}->[1] };
    $self;
}

sub _NEW {
    CORE::state $fix_FIELDS = do {
        $_FIELDS = { @_CLASS > 1 ? @_CLASS : %{ $_CLASS[0] } };
        $_FIELDS = $_FIELDS->{'FIELDS'} if exists $_FIELDS->{'FIELDS'};
    };
    map { delete $_[1]->{$_} } 'auto', 'encoding', 'pager';
}

sub __RO {
    my ( undef, undef, undef, $sub ) = caller(1);
    Carp::confess("attribute $sub is read-only");
}
sub auto { __RO() if @_ > 1; $_[0]{'auto'} //= $_FIELDS->{'auto'}->{'default'} }

sub encoding {
    __RO() if @_ > 1;
    $_[0]{'encoding'} //= $_FIELDS->{'encoding'}->{'default'};
}

sub fh {
    if ( @_ > 1 ) { $_[0]{'fh'} = $_[1] }
    $_[0]{'fh'} //= $_FIELDS->{'fh'}->{'default'}->( $_[0] );
}

sub orig_fh {
    __RO() if @_ > 1;
    $_[0]{'orig_fh'} //= $_FIELDS->{'orig_fh'}->{'default'}->( $_[0] );
}

sub pager {
    __RO() if @_ > 1;
    $_[0]{'pager'} //= $_FIELDS->{'pager'}->{'default'}->( $_[0] );
}

sub pid {
    if ( @_ > 1 ) { $_[0]{'pid'} = $_[1] }
    $_[0]{'pid'} // undef;
}
@_CLASS = grep 1,    ### END Class::Inline ###
                     # 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 $VERSION  = 'v2.0.17';
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__