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


line stmt bran cond sub pod time code
1             package OptArgs2::Pager;
2 1     1   189186 use strict;
  1         6  
  1         24  
3 1     1   4 use warnings;
  1         2  
  1         18  
4 1     1   3 use Carp ();
  1         1  
  1         17  
5 1     1   885 use Exporter::Tidy other => [qw/page start_pager stop_pager/];
  1         13  
  1         5  
6 1     1   997 use File::Which;
  1         890  
  1         41  
7 1     1   485 use IO::Handle;
  1         5435  
  1         101  
8             use OptArgs2::Pager_CI {
9              
10             # User provided arguments
11             auto => { default => 1, },
12             encoding => { default => ':utf8', },
13             pager => { default => \&_build_pager, },
14              
15             # Attributes
16             fh => {
17             init_arg => undef,
18             is => 'rw',
19 0           default => sub { IO::Handle->new },
20             },
21             orig_fh => {
22             init_arg => undef,
23 0           default => sub { select },
24             },
25 1         15 pid => {
26             init_arg => undef,
27             is => 'rw',
28             init_arg => undef,
29             },
30 1     1   331 };
  1         2  
31              
32             our @CARP_NOT = (__PACKAGE__);
33              
34             sub _build_pager {
35 0     0     my $self = shift;
36              
37 0 0         if ( exists $ENV{PAGER} ) {
38 0 0         return unless length( $ENV{PAGER} );
39              
40             # Explicit pager defined
41 0           my ( $pager, @options ) = split ' ', $ENV{PAGER};
42 0           my $path = File::Which::which($pager);
43 0 0         Carp::croak("pager not found: $pager") unless $path;
44 0           return join( ' ', $path, @options );
45             }
46              
47             # Otherwise take the first from our own list
48 0           foreach my $pager (qw/pager less most w3m lv pg more/) {
49 0           my $path = File::Which::which($pager);
50 0 0         return $path if $path;
51             }
52              
53 0           Carp::croak("no suitable pager found");
54             }
55              
56             sub BUILD {
57 0     0 0   my $self = shift;
58 0           $self->open;
59 0 0         select $self->fh if $self->auto;
60             }
61              
62             sub open {
63 0     0 1   my $self = shift;
64              
65 0 0         return $self->fh if $self->fh->opened;
66              
67 0 0         if ( not -t $self->orig_fh ) {
68 0           $self->fh( $self->orig_fh );
69 0           return;
70             }
71              
72 0   0       my $pager = $self->pager || return;
73              
74 0   0       local $ENV{LESS} = $ENV{LESS} // '-FSXeR';
75 0 0 0       local $ENV{MORE} = $ENV{MORE} // '-FXer' unless $^O eq 'MSWin32';
76              
77 0 0         $self->pid( CORE::open( $self->fh, '|-', $pager ) )
78             or Carp::croak "Could not pipe to PAGER ('$pager'): $!\n";
79              
80 0 0         binmode( $self->fh, $self->encoding ? $self->encoding : () )
    0          
81             or Carp::cluck "Could not set bindmode: $!";
82              
83 0           $self->fh->autoflush(1);
84             }
85              
86             sub close {
87 0     0 1   my $self = shift;
88 0 0 0       return unless $self->fh && $self->fh->opened;
89              
90 0           select $self->orig_fh;
91 0 0         $self->fh->close if $self->fh ne $self->orig_fh;
92             }
93              
94             sub DESTROY {
95 0     0     my $self = shift;
96 0           $self->close;
97             }
98              
99             # Functions
100             my $pager;
101              
102             sub start_pager {
103 0   0 0 1   $pager //= __PACKAGE__->new(@_);
104 0           $pager->open;
105 0           select $pager->fh;
106             }
107              
108             sub stop_pager {
109 0   0 0 1   $pager // return;
110 0           $pager->close;
111 0           select( $pager->orig_fh );
112             }
113              
114             sub page {
115 0     0 1   my $text = shift;
116 0           my $close = not $pager;
117              
118 0   0       $pager //= __PACKAGE__->new( @_, auto => 0 );
119 0           $pager->open;
120 0           my $ok = $pager->fh->printflush($text);
121 0 0         $pager->close if $close;
122 0           $ok;
123             }
124              
125             1;
126              
127             __END__