IO-Pager-1.01/0000755000076400007640000000000013547206642013017 5ustar belg4mitbelg4mitIO-Pager-1.01/test.pl0000644000076400007640000000045513105633457014335 0ustar belg4mitbelg4mituse strict; use warnings; exit 0 unless scalar(@ARGV) && ($ARGV[0] eq 'interactive'); undef($ENV{LESS}); my @fail; for (sort glob "t/*interactive.t") { print "Running $_...\n"; push @fail, $_ if system($^X, '-Mblib', $_); } print scalar @fail ? "\nSome tests failed: @fail\n" : "\nSuccess!\n"; IO-Pager-1.01/META.yml0000664000076400007640000000156613547206642014302 0ustar belg4mitbelg4mit--- abstract: 'Select a pager and pipe text to it if destination is a TTY' author: - 'Jerrad Pierce , Florent Angly ' build_requires: Config: '0' Env: '0' Exporter: '0' File::Temp: '0' Test::More: '0.88' bignum: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: IO-Pager no_index: directory: - t - inc requires: Env: '0' File::Spec: '0' File::Which: '0' IO::Handle: '0' PerlIO: '0' SelectSaver: '0' Symbol: '0' Term::ReadKey: '0' Text::Wrap: '0' Tie::Handle: '0' base: '0' version: '1.01' x_runtime: recommends: {} x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IO-Pager-1.01/.proverc0000644000076400007640000000000212471375343014470 0ustar belg4mitbelg4mit-bIO-Pager-1.01/META.json0000664000076400007640000000272413547206642014447 0ustar belg4mitbelg4mit{ "abstract" : "Select a pager and pipe text to it if destination is a TTY", "author" : [ "Jerrad Pierce , Florent Angly " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "IO-Pager", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Config" : "0", "Env" : "0", "Exporter" : "0", "File::Temp" : "0", "Test::More" : "0.88", "bignum" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Env" : "0", "File::Spec" : "0", "File::Which" : "0", "IO::Handle" : "0", "PerlIO" : "0", "SelectSaver" : "0", "Symbol" : "0", "Term::ReadKey" : "0", "Text::Wrap" : "0", "Tie::Handle" : "0", "base" : "0" } } }, "release_status" : "stable", "version" : "1.01", "x_runtime" : { "recommends" : {} }, "x_serialization_backend" : "JSON::PP version 2.97001" } IO-Pager-1.01/MANIFEST0000644000076400007640000000144513547201660014147 0ustar belg4mitbelg4mitCHANGES Makefile.PL MANIFEST lib/IO/Pager.pm lib/IO/Pager/Buffered.pm lib/IO/Pager/Page.pm lib/IO/Pager/Unbuffered.pm lib/IO/Pager/less.pm lib/IO/Pager/Perl.pm lib/IO/Pager/tp README TODO .proverc test.pl t/01-load.t t/02-which.t t/02-which_interactive.t t/03-bald_interactive.t t/04-buffered_interactive.t t/05-binmode_interactive.t t/06-scalar_interactive.t t/07-oo_interactive.t t/08-redirect.pl t/08-redirect.t t/09-open.t t/10-close_interactive.t t/11-redirect-oo.pl t/11-redirect-oo.t t/12-preservelayers_interactive.t t/13-eof_interactive.t t/14-tee_interactive.t t/15-log_interactive.t t/16-PurePerl_interactive.t t/TestUtils.pm META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IO-Pager-1.01/TODO0000644000076400007640000000515713547206073013515 0ustar belg4mitbelg4mitImportant things here and in code flagged with XXX 1.01 IPP Add windows support via Win32::Console and Term::Size::Win32? 1.00 IPP Togglable wrap? ...with reflow IPP remap left & right scroll to beep? iff unchanged lineNo IPP Squeeze IPP Proper logical line numbering? IPP Togglable? ...with reflow IPP #Consolidate _cursor+{rows} and _end?? IPP _end IPP !! line =$n pause ... then what?! IPP down_lines IPP _cursor+rows !!detect EOF!! IPP !! if {pause} and _end < {rows}-1 skip IPP line(_cursor++ +{rows}) IPP up_lines {end}-- NOOP, just keeping up IPP jump _cursor+{rows} NOOP, just keeping up IPP search _cursor+{rows} NOOP, just keeping up IPP _cursor+{rows} NOOP, just keeping up IPP Pause bugs IPP extra scroll forwards required after backed up over pauses IPP Left/right when paused causes vertical scrolling IPP (horiz. scroll trigeering a form forward, how to prevent?!) IPP We get an extra chunk of output after menu closing IPP Add mark ability? IPP m _mark{getc()} = _cursor IPP ' jump(_mark{getc()}) #special I<^> and I<$>, I<'>? IPP Add more IO::Pager::Perl involved tests, scripted interaction? IPP read from pipe, file IPP navigation IPP search IPP $0 as name in status line? IPP Wrap up tp for PerlTools? 0.43 Can we make Pager::less into a self-contained forking implementation? Current forking design yields: Failed to create PAGER FH at 16-PurePerl_interactive.t line 16 stty: standard input: Inappropriate ioctl for device stty: standard input: Inappropriate ioctl for device print() on unopened filehandle STDOUT at Term/Pager.pm line 330 print() on unopened filehandle STDOUT at Term/Pager.pm line 395 print() on unopened filehandle STDOUT at Term/Pager.pm line 396 print() on unopened filehandle STDOUT at Term/Pager.pm line 397 print() on unopened filehandle STDOUT at Term/Pager.pm line 398 print() on unopened filehandle STDOUT at Term/Pager.pm line 399 Fix IO::Pager and IO::Pager::less PODs (remove cuts) 0.40 Push previous versions to github Functional fork for Term::Pager Test functionality w/|w/o Term::ReadKey As explicit and implicit PAGER make pipes & pager object parent event loop/interact child worker 0.35 Odd failure of test 11 under tcsh and win-bash because *reference* has extra trailing newline. 0.20 "Fix" multi-pseudo-STDOUT disabled in 09-open.t implementation? Alter tests to cover all invocation schemes, and document location of each in matrix OR use table-driven tests? new/open each class scalar vs. glob vs. OO (non-)fully qualified subclass name 0.02 Implement IO::Pager::Callback, just because it sounds cool? IO-Pager-1.01/lib/0000755000076400007640000000000013547206642013565 5ustar belg4mitbelg4mitIO-Pager-1.01/lib/IO/0000755000076400007640000000000013547206642014074 5ustar belg4mitbelg4mitIO-Pager-1.01/lib/IO/Pager/0000755000076400007640000000000013547206642015132 5ustar belg4mitbelg4mitIO-Pager-1.01/lib/IO/Pager/Buffered.pm0000644000076400007640000001263513360416765017223 0ustar belg4mitbelg4mitpackage IO::Pager::Buffered; our $VERSION = 0.42; use strict; use base qw( IO::Pager ); use SelectSaver; sub new(;$) { # [FH], procedural my($class, $tied_fh); eval { ($class, $tied_fh) = &IO::Pager::_init }; #We're not on a TTY so... if( defined($class) && $class eq '0' or $@ =~ '!TTY' ){ #...leave filehandle alone if procedural return $_[1] if defined($_[2]) && $_[2] eq 'procedural'; #...fall back to IO::Handle for transparent OO programming eval "require IO::Handle" or die $@; return IO::Handle->new_from_fd(fileno($_[1]), 'w'); } $!=$@, return 0 if $@ =~ 'pipe'; tie *$tied_fh, $class, $tied_fh or return 0; } #Punt to base, preserving FH ($_[0]) for pass by reference to gensym sub open(;$) { # [FH] # IO::Pager::open($_[0], 'IO::Pager::Buffered'); &new('IO::Pager::Buffered', $_[0], 'procedural'); } # Overload IO::Pager methods sub PRINT { my ($self, @args) = @_; $self->{buffer} .= join($,||'', @args); } sub CLOSE { my ($self) = @_; # Print buffer and close using IO::Pager's methods $self->SUPER::PRINT($self->{buffer}) if exists $self->{buffer}; $self->SUPER::CLOSE(); } *DESTROY = \&CLOSE; sub TELL { # Return the size of the buffer my ($self) = @_; use bytes; return exists($self->{buffer}) ? length($self->{buffer}) : 0; } sub flush(;*) { my ($self) = @_; if( exists $self->{buffer} ){ my $saver = SelectSaver->new($self->{real_fh}); local $|=1; ($_, $self->{buffer}) = ( $self->{buffer}, ''); $self->SUPER::PRINT($_); } } 1; __END__ =pod =head1 NAME IO::Pager::Buffered - Pipe deferred output to PAGER if destination is a TTY =head1 SYNOPSIS use IO::Pager::Buffered; { local $token = IO::Pager::Buffered::open local *STDOUT; print <<" HEREDOC" ; ... A bunch of text later HEREDOC } { # You can also use scalar filehandles... my $token = IO::Pager::Buffered::open($FH) or warn($!); print $FH "No globs or barewords for us thanks!\n" while 1; } { # ...or an object interface my $token = new IO::Pager::Buffered; $token->print("OO shiny...\n") while 1; } =head1 DESCRIPTION IO::Pager subclasses are designed to programmatically decide whether or not to pipe a filehandle's output to a program specified in I; determined and set by IO::Pager at runtime if not yet defined. This subclass buffers all output for display until execution returns to the parent scope or a manual L occurs.L<*|/close> If this is not what you want look at another subclass such as L. While probably not common, this may be useful in some cases, such as buffering all output to STDOUT while the process occurs so that warnings on STDERR are more visible, then displaying the less urgent output from STDOUT after. Or, alternately, letting output to STDOUT slide by and defer warnings for later perusal. =head1 METHODS Class-specific method specifics below, others are inherited from IO::Pager. =head2 open( [FILEHANDLE] ) Instantiate a new IO::Pager to paginate FILEHANDLE if necessary. I. Output does not occur until the filehandle is Led or Ld. =head2 new( [FILEHANDLE] ) Almost identical to open, except that you will get an L back if there's no TTY to allow for IO::Pager agnostic programming. =head2 close( FILEHANDLE ) Flushes the buffer to the pager and closes the filehandle for writing. Normally, when using a lexically or locally scoped variable to hold the token supplied by L, explicit calls to close are unnecessary. However, if you are using IO::Pager::Buffered with an unlocalized STDOUT or STDERR you close the filehandle to display the buffered content or wait for global garbage cleaning upon program termination. Alternatively, you might prefer to use a non-core filehandle with IO::Pager, and call L to make it the default for output. =head2 tell( FILEHANDLE ) Returns the size of the buffer in bytes. =head2 flush( FILEHANDLE ) Immediately flushes the contents of the buffer. If the last print did not end with a newline, the text from the preceding newline to the end of the buffer will be flushed but is unlikely to display until a newline is printed and flushed. =head1 CAVEATS If you mix buffered and unbuffered operations the output order is unspecified, and will probably differ for a TTY vs. a file. See L. I<$,> is used see L. 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, L, L, =head1 AUTHOR Jerrad Pierce Florent Angly This module was inspired by Monte Mitzelfelt's IO::Page 0.02 =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2018 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 IO-Pager-1.01/lib/IO/Pager/Perl.pm0000755000076400007640000006143213547206165016403 0ustar belg4mitbelg4mitpackage IO::Pager::Perl; our $VERSION = '1.01'; use strict; use warnings; use Term::Cap; #Signal handling, only needs to be set once, and does not have access to object my($SP, $RT) = $|; local $SIG{INT} = local $SIG{QUIT} = \&done; #Stubs for ReadKey functions that we fill in with code refs if it's not loaded sub ReadMode; sub ReadKey; sub new { my $class = shift; my %param = @_; local $ENV{TERM} = $ENV{TERM}; my %dims = get_size(cols =>$param{cols} ||80, rows =>$param{rows} ||25, speed=>$param{speed}||38400); $dims{rows}--; #screen is vt100 compatible but does not list sf?! #No matter, it's only used for workaround mode. if( $ENV{TERM} eq 'screen' && $ENV{TERMCAP} !~ /sf/ ){ $ENV{TERM} = 'vt100'; } #cm=>cup, ce=>el, cl=>clear, sf=>ind, sr=>ri #md=>bold, me=>sgr0, mr=>rev, us=>smul #Speed is mostly useless except Term::Cap expects it? my $t = Term::Cap->Tgetent({ OSPEED => $param{speed} }); eval{ $t->Trequire(qw/cm ce cl sf sr/) }; my $dumb = $@ ? 1 : 0; my %primitives = ( # if the entries don't exist, nothing bad will happen BLD => $t->Tputs('md'), # Bold ULN => $t->Tputs('us'), # Underscore REV => $t->Tputs('mr'), # Reverse NOR => $t->Tputs('me'), # Normal ); my $text = delete($param{text}) if defined($param{text}); my $me = bless { # default values _cursor => 0, _end => 0, _left => 0, _term => $t, _dumb => $dumb, _txtN => 0, _search => '', _statCols => 0, _lineNo=>[0], lineNo => 0, pause => 0, #pause=>"\cL" #more raw => 0, statusCol => 0, squeeze=>0, visualBeep=>0, wrap=>0, %dims, # if the termcap entries don't exist, nothing bad will happen %primitives, #UI Composites MENU => $primitives{BLD}.$primitives{REV}, # popup menus HILT => $primitives{BLD}.$primitives{ULN}, # search entry SRCH => $primitives{BLD}.$primitives{ULN}, # search entry # user supplied values override %param, }, $class; $me->add_text($text) if defined $text; $me->{_I18N}={ status=> '', 404=> 'Not Found', top=> 'Top', bottom=> 'Bottom', prompt=> "=help \000=down =back =quit", continue=> 'press any key to continue', help=> <<'EOH' q quit \000 h help r C-l refresh \000 / search \000 ? search backwards n P next match \000 p N previous match space C-v page down \000 b M-v page up enter line down \000 y line up d half page down \000 u half page up g < goto top \000 G > goto bottom <- scroll left \000 -> scroll right # Line numbering \000 \d+\n jump to line \d+ EOH }; $me->{_fnc} = { 'q' => \&done, 'h' => \&help, '/' => \&search, '?' => \&hcraes, 'n' => \&next_match, 'P' => \&prev_match, 'p' => \&prev_match, 'N' => \&prev_match, 'r' => \&refresh, "\cL" => \&refresh, ' ' => \&downpage, "\cC" => \&downpage, "\n"=> \&downline, "\e[B" => \&downline, 'd' => \&downhalf, 'u' => \&uphalf, 'b' => \&uppage, "\ev" => \&uppage, 'y' => \&upline, "\e[A" => \&upline, '<' => \&to_top, '>' => \&to_bott, '$' => \&to_bott, "\e[D" => \&move_left, "\e[C" => \&move_right, '#' => \&toggle_numbering, '/(\d+)/'=>1 #jump to line }; $me->{_end} = $me->{rows} - 1; $SIG{WINCH} = sub{ $me->resize() }; $me; } sub resize { my $me = shift; my %dims = get_size(); $dims{rows}--; $me->{$_} = $dims{$_} foreach keys %dims; $me->{_end} = $me->{rows} - 1; $me->refresh(); $me->prompt(); $me->{WINCH}->() if ref($me->{WINCH}) eq 'CODE'; } sub get_size { my %dims = @_; if( defined($Term::ReadKey::VERSION) ){ Term::ReadKey->import(); local $SIG{__WARN__} = sub{}; my @Tsize = Term::ReadKey::GetTerminalSize(*STDOUT); @dims{'rows','cols'} = @Tsize[1,0]; $dims{speed} ||= (Term::ReadKey::GetSpeed())[1]; } else{ *ReadMode = sub{ if( $_[0] == 3 ){ system('stty -icanon -echo min 1'); } elsif( $_[0] == 0 ){ system('stty icanon echo'); } }; *ReadKey = sub{ getc() }; #Can we get better defaults? if( `stty` =~ /speed/ ){ @dims{'rows','cols'} = ($1-1,$2-1) if `stty size` =~ /^(\d+)\s+(\d+)$/; $dims{speed} = $1 if `stty speed` =~ /^(\d+)$/; } else{ $dims{rows} = `tput lines` || $dims{rows}; $dims{cols} = `tput cols` || $dims{cols}; } } return %dims; } sub add_text { return unless defined($_[1]); my $me = shift; #Stringify local $_ = join('', @_); #Terminated? my $LF = do{ chomp(local $_=$_) }; #Squeeze #XXX handle with logical lines display? s/\n{2,}/\n\n/g if $me->{squeeze}; #Split on new lines, preserving internal blanks my @F = split(/\n/, $_, -1); if( $me->{wrap} ){ #Two expressions to avoid lame single-use warning local $Text::Wrap::columns; $Text::Wrap::columns = $me->{cols} - ( $me->{_statCols} = ($me->{lineNo} ? 9 : $me->{statusCol} ? 1 : 0) ); my $lines = scalar(@F); my $extraSum=0; for( my $i=0; $i<$lines; $i++ ){ $me->{_lineNo}->[$i+$me->{_txtN}] = $me->{_txtN}+$i+1-$extraSum; if( defined($F[$i]) && length($F[$i]) > $me->{cols} ){ my @G = split/\n/, wrap('', '', $F[$i]); my $extras = scalar(@G); splice(@F, $i, 1, @G); #Repeat real line number for logical folded lines $me->{_lineNo}->[$i+$me->{_txtN}+$_] = $me->{_txtN}+$i+1-$extraSum foreach 1..$extras-1; $i += $extras-1; $lines += $extras; $extraSum+=$extras-1; } } } #Remove the extra record from the trailing new line pop @F if $LF; #Handle partial lines in case sysread is used further up the stack push(@F, undef) unless $LF; if( $me->{_txtN} && !defined($me->{_text}->[-1]) ){ pop @{$me->{_text}}; $me->{_text}->[-1] .= shift @F; } #Store text, and refresh screen if content would fit in window my $shown = $me->{_txtN}; push @{$me->{_text}}, @F; $me->{_txtN} = @{ $me->{_text} }; #-1; $me->refresh() if $shown <= $me->{rows}; } sub more { my $me = shift; my %param = @_; $RT = $me->{RT} = $param{RT}; if( $me->{wrap} ){ eval "use Text::Wrap"; $me->dialog("Text::Wrap unavailable, disabling wrap mode\n\n$@") if $@; } if( $@ or not $me->{wrap} ){ sub wrap {@_} } ReadMode 3; #cbreak $| = 1; if( $me->{_dumb} ){ $me->dumb_mode(); } else{ print $me->{NOR}; while( 1 ){ $me->prompt(); # status line my $exit; my $q = ReadKey($param{RT}); # Catch arrow keys. NOTE: Escape would enter this too #...requiring an extra input if no ReadKey if( defined($q) and ord($q) == 27 ){ $q.=ReadKey(0); $q.=ReadKey(0) if $q eq "\e["; } if( defined($q) and $q =~ /\d/ and $me->{_fnc}->{'/(\d+)/'} ){ $me->{_I18N}{status} = $q; $me->prompt(); while( defined($_ = ReadKey(0)) ){ last unless /\d/; $q .= $_; $me->{_I18N}{status} = $q; $me->prompt(); } #Commit on enter, anything else aborts if( $_ eq "\n" ){ $q<$me->{_txtN} ? $me->jump($q) : $me->to_bott(); } $me->{_I18N}{status} = ''; next; } if( defined $q ){ my $f = $me->{_fnc}->{$q} || \&beep; # $me->{_I18N}{status} = $q; #input debugging $exit = ref($f->($me)); } return 1 if $param{RT} or $exit; } } $me->done(); } *less = \&more; *page = \&more; #Avid lame single-use warning my $foo = \&less; $foo = \&page; #ACCESSORS sub I18N { my($me, $msg, $text) = @_; $me->{_I18N}{$msg} = $text if defined($text); $me->{_I18N}{$msg}; } BEGIN{ #Install generic accessors no strict 'refs'; foreach my $method ( qw(eof lineNo pause raw statusCol visualBeep) ){ *{$method} = sub{ $_[0]->{$method}=$_[1] if defined($_[1]); $_[0]->{$method} } } foreach my $method ( qw(rows cols speed fold squeeze) ){ *{$method} = sub{ $_[0]->{$method}} } } #HELPERS sub add_func { my $me = shift; my %param = @_; while( my($k, $v) = each %param ){ $me->{_fnc}{$k} = $v; } } sub beep { print "\a"; print $_[0]->{_term}->Tputs('vb') if $_[0]->{visualBeep}; } # display a prompt, etc sub prompt { my $me = shift; $me->{_txtN} ||= 0; my $end= $me->{_cursor} + $me->{rows}; my $pct = $me->{_txtN} > $end ? $end/($me->{_txtN}) : 1; my $pos = $me->{_cursor} ? ($pct==1 ? $me->{_I18N}{bottom} : 'L'.$me->{_cursor}) : $me->{_I18N}{top}; $pos .= 'C'.$me->{_left} if $me->{_left}; my $p = sprintf "[tp] %d%% %s %s", 100*$pct, $pos, $me->{_I18N}{status}; print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # bottom left print $me->{_term}->Tputs('ce'); # clear line my $prompt = $me->{_I18N}{prompt}; my $pN = $me->{cols} - 2 - length($p) - length($me->{_I18N}{prompt}); $p .= ' ' x ($pN > 1 ? $pN : 1); $prompt = $pN>2 ? $prompt : do {$prompt =~ s/\000.+//; $prompt }; print $me->{REV}; # reverse video print $p," ", $prompt; # status line print $me->{NOR}; # normal video } sub done { ReadMode 0; print "\n"; $| = $SP || 0; #Did we exit via signal or prompt? $RT ? die : return \"foo"; } # provide help to user sub help { my $me = shift; my $help = $me->{_I18N}{help}; my $cont = $me->{_I18N}{continue}; if( $me->max_width( split/\n/, $help ) > $me->{cols} ){ #Split help in half horizontally for narrow dispays my $help2 = $help; $help2 =~ s/\000.*//mg; $help =~ s/.*\000//mg; my $padding = $me->max_width($cont) / 2; $me->dialog( $help2 . "\n" . (' 'x$padding) . $cont ); } else{ $help =~ y/\000//d; } my $padding = $me->max_width($cont) / 2; $me->dialog( $help . "\n" . (' 'x$padding) . $cont ); } sub dialog { my($me, $msg, $timeout) = @_; $msg = defined($msg) ? $msg : ''; $timeout = defined($timeout) ? $timeout : 0; $me->disp_menu( $me->box_text($msg) ); $timeout ? sleep($timeout) : getc(); $me->remove_menu(); } sub max_width { my $me = shift; my $width = 0; foreach (@_){ $width = length($_) if length($_) > $width }; return $width; } # put a box around some text sub box_text { my $me = shift; my @txt = split(/\n/, $_[0]); my $width = $me->max_width(@txt); my $b = '+' . '=' x ($width + 2) . '+'; my $o = join('', map { "| $_" . (' 'x($width-length($_))) ." |\n" } @txt); "$b\n$o$b\n"; } # display a popup menu (or other text) sub disp_menu { my $me = shift; my $menu = shift; $me->{_menuRows} = @{[split /\n/, $menu]}; print $me->{_term}->Tgoto('cm',0,$me->{rows} - $me->{_menuRows}); # move print $me->{MENU}; # set color my $x = $me->{_term}->Tgoto('RI',0,4); # 4 transparent spaces $menu =~ s/^\s*/$x/gm; print $menu; print $me->{NOR}; # normal color } # remove popup and repaint sub remove_menu { my $me = shift; #XXX now fails if at bottom of text my $s = $me->{rows} - $me->{_menuRows}; #Allow wipe of incomplete/paused output. #XXX "Bug" in that we get an extra chunk of output after menu closing my $pause = $me->{pause}; $me->{pause} = ''; $me->I18N('status', $s."..".$me->rows()); $me->prompt(); # Fractional restoration instead of full refresh foreach my $n ($s .. $me->{rows}){ print $me->{_term}->Tgoto('cm', 0, $n); # move print $me->{_term}->Tputs('ce'); # clear line $me->line($n); } #Reset pause $me->{pause} = $pause; } # refresh screen sub refresh { my $me = shift; print $me->{_term}->Tputs('cl'); # home, clear for my $n (0 .. $me->{rows} -1){ print $me->{_term}->Tgoto('cm', 0, $n); # move print $me->{_term}->Tputs('ce'); # clear line $me->line($n+$me->{_cursor}); # XXX w/o cursor messy # after menu & refresh } } sub line { my $me = shift; my $n = shift; local $_ = $me->{_text}[$n]||''; #!! ORDER OF OPERATIONS ON OUTPUT PROCESSING AND DECORATION MATTERS #Breaks? my $pause =1 if length($me->{pause}) && defined && /$me->{pause}/; #Crop if no folding my $len = length(); unless( $me->{wrap} ){ $_ = ($len-$me->{_statCols}) < $me->{_left} ? '' : substr($_, $me->{_statCols} + $me->{_left},$me->{cols}-$me->{_statCols}); if( $len - $me->{_left} > $me->{cols} ){ substr($_, -1, 1, "\$"); } } #Cook control characters unless( $me->{raw} ){ #XXX Specially protect escape sequences, so we can wrap controls in REV? s/(?=[\000-\010\013-\037])/^/g; tr/\000-\010\013-\037/@A-HK-Z[\\]^_/; } #Search my $matched = (s/($me->{_search})/$me->{SRCH}$1$me->{NOR}/g) if $me->{_search} ne ''; #Line numbering & search status my $info = $me->{statusCol} && !$me->{lineNo} ? ($matched ? '*' : ' ') :''; $info = sprintf("% 8s", $me->{wrap} ? ($me->{_lineNo}->[$n]||-1) : (defined($me->{_text}[$n]) ? $n+1 : '') ) if $me->{lineNo}; $_ = ($me->{statusCol} && $matched ? $me->{REV} : ''). $info. ($me->{statusCol} && $matched ? $me->{NOR} : ''). ($me->{lineNo} ? ' ' : ''). $_; print; if( $pause ){ $me->{_end} = $n; #Advance past pause no warnings 'exiting'; last; } } sub down_lines { my $me = shift; my $n = shift; my $t = $me->{_term}; for (1 .. $n){ if( $me->{_end} >= $me->{_txtN}-1 ){ exit if $me->{eof}; &beep; last; } else{ if( length($me->{pause}) && $me->{_end} < $me->{rows}-1 ){ print $t->Tgoto('cm', 0, $me->{_end}+1 ); } # move else{ # why? because some terminals have bugs... print $t->Tgoto('cm', 0, $me->{rows} ); # move print $t->Tputs('sf'); # scroll print $t->Tgoto('cm', 0, $me->{rows} - 1); # move } print $t->Tputs('ce'); # clear line $me->line( ++$me->{_end} ); $me->{_cursor}++; } } } sub downhalf { $_[0]->down_lines( $_[0]->{rows} / 2 ); } sub downpage { $_[0]->down_lines( $_[0]->{rows} ); } sub downline { $_[0]->down_lines( 1 ); } sub up_lines { my $me = shift; my $n = shift; for (1 .. $n){ if( $me->{_cursor} <= 0 ){ &beep; last; }else{ print $me->{_term}->Tgoto('cm',0,0); # move print $me->{_term}->Tputs('sr'); # scroll back $me->line( --$me->{_cursor} ); $me->{_end}--; } } print $me->{_term}->Tgoto('cm',0,$me->{rows}); # goto bottom } sub uppage { $_[0]->up_lines( $_[0]->{rows} ); } sub upline { $_[0]->up_lines( 1 ); } sub uphalf { $_[0]->up_lines( $_[0]->{rows} / 2 ); } sub to_top { $_[0]->jump(0); } sub to_bott { my $me = shift; $me->jump( $me->{rows}>$me->{_txtN} ? 0 : $me->{_txtN}-$me->{rows} ); } sub jump { my $me = shift; $me->{_cursor} = shift; $me->{_end} = $me->{_cursor} + $me->{rows}; # - 1; $me->refresh(); } sub move_right { my $me = shift; $me->{_left} += 8; $me->refresh(); } sub move_left { my $me = shift; $me->{_left} -= 8; $me->{_left} = 0 if $me->{_left} < 0; $me->refresh(); } sub hcraes{ $_[0]->search(1); } sub search { my $me = shift; $me->{_hcraes} = shift || 0; # get pattern (my($prev), $me->{_search}) = ($me->{_search}, ''); print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # move bottom print $me->{_term}->Tputs('ce'); # clear line print $me->{HILT}; # set color print $me->{_hcraes} ? '?' : '/'; while(1){ my $l = ReadKey(); last if $l eq "\n" || $l eq "\r"; if( $l eq "\e" || !defined($l) ){ $me->{_search} = ''; last; } if( $l eq "\b" || $l eq "\177" ){ #Why not octothorpe? || $l eq '#' ){ print "\b \b" if $me->{_search} ne ''; substr($me->{_search}, -1, 1, ''); next; } print $l; $me->{_search} .= $l; } print $me->{NOR}; # normal color print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # move bottom print $me->{_term}->Tputs('ce'); # clear line return if $me->{_search} eq ''; $me->{_search} = '(?i)'.$me->{_search} unless $me->{_search} ne lc($me->{_search}); $me->{_search} = $prev if $me->{_search} eq '/' && $prev; for my $n ( $me->{_cursor} .. $me->{_txtN} -1){ #XXX why offset needed? next unless $me->{_text}[$n] =~ /$me->{_search}/i; $me->{_cursor} = $n; $me->{_cursor} = 0 if $me->{_txtN} < $me->{rows}; # - 1; $me->{_end} = $me->{_cursor} + $me->{rows}; # - 1; #Special jump if match is on last screen if( $me->{_cursor} + $me->{rows} > $me->{_txtN} - 1 && $me->{_cursor} ){ my $x = $me->{_cursor} + $me->{rows} - $me->{_txtN}; $x = $me->{_cursor} if $x > $me->{_cursor}; $me->{_cursor} -= $x; $me->{_end} -= $x; } $me->refresh(); return; } # not found &beep; $me->dialog($me->{_I18N}{404}, 1); return; } sub prev_match{ $_[0]->next_match('anti'); } sub next_match{ my $me = shift; return unless defined($me->{_txtN}) and defined($me->{_search}); my $mode=shift; if( defined($mode) and $mode ='anti' ){ $mode = not $me->{_hcraes}; } else{ $mode = $me->{_hcraes}; } my $i = $mode ? ($me->{_cursor}||0)-1 : ($me->{_cursor})+1; my $matched=0; for( ; $mode ? $i>0 : $i< $me->{_txtN}; $mode ? $i-- : $i++ ){ $matched = $me->{_text}[$i] =~ /$me->{_search}/; last if $matched; } $matched ? $me->jump($i) : &beep; } sub toggle_numbering{ my $me = shift; $me->{lineNo} = not $me->{lineNo}; $me->refresh(); } sub dumb_mode { my $me = shift; my $end = 0; while(1){ for my $i (1 .. $me->{rows} ){ last if $end >= $me->{_txtN}; print $me->{_text}[$end++], "\n"; } print "--more [dumb]-- quit"; my $a = getc(); print "\b \b"x15; return if $a eq 'q'; return if $end >= $me->{_txtN}; } } 1; __END__ =pod =head1 NAME IO::Pager::Perl - Page text a screenful at a time, like more or less =head1 SYNOPSIS use Term:ReadKey; #Optional, but recommended use IO::Pager::Perl; my $t = IO::Pager::Perl->new( rows => 25, cols => 80 ); $t->add_text( $text ); $t->more(); =head1 DESCRIPTION This is a module for paging through text one screenful at a time. It supports the features you expectcusing the shortcuts you expect. IO::Pager::Perl is an enhanced fork of L. =head1 USAGE =head2 Create the Pager $t = IO::Pager::Perl->new( option => value, ... ); If no options are specified, sensible default values will be used. The following options are recognized, and shown with the default value: =over 4 =item I =E25? The number of rows on your terminal. The terminal is queried directly with Term::ReadKey if loaded or C or C, and if these fail it defaults to 25. =item I =E80? The number of columns on your terminal. The terminal is queried directly with Term::ReadKey if loaded or C or C, and if these fail it defaults to 80. =item I =E38400? The speed (baud rate) of your terminal. The terminal is queried directly with Term::ReadKey if loaded or C, and if these fail it defaults to a sensible value. =item I =E0 Exit at end of file. =item I =E1 Wrap long lines. =item I =E0 If true, line numbering is added to the output. =item I =E0 If defined, the pager will pause when the this character sequence is encountered in the input text. Set to ^L i.e; "\cL" to mimic traditional behavior of L. =item I =E0 Pass control characters from input unadulterated to the terminal. By default, chracters other than tab and newline will be converted to caret notation e.g; ^@ for null or ^L for form feed. =item I =E0 Collapse multiple blank lines into one. =item I =E0 Add a column with markers indicating which row match a search expression. =item I =E0 Flash the screen when beeping. =back =head3 Accessors There are accessors for all of the above properties, however those for rows, cols, speed, fold and squeeze are read only. #Is visualBeep set? $t->visualBeep(); #Enable line numbering $t->lineNo(1); =head2 Adding Text You will need some text to page through. You can specify text as as a parameter to the constructor: text => $text Or even add text later: $t->add_text( $text ); If you wish to continuously add text to the pager, you must setup your own event loop, and indicate to C that it should relinquish control e.g; eval{ while( $t->more(RT=>.05) ){ ... $t->add_text("More text to page"); } }; The eval block captures the exception thrown upon termination of the pager so that your own program may continue. The I parameter indicates that you wish to provide content in real time. This value is also passed to L as the maximum blocking time per keypress and should be between 0 and 1, with larger values trading greater interface responsiveness for slight delays in output. A value of -1 may also be used to request non-blocking polls, but likely will not behave as you would hope. NOTE: If Term::ReadKey is not loaded but RT is true, screen updates will only occur on keypress. =head2 Adding Functionality and Internationalization (I18N) It is possible to extend the features of IO::Pager::Perl by supplying the C method with a hash of character keys and callback values to be invoked upon matching keypress; where \c? represents Control-? and \e? represents Alt-? The existing pairings are: 'h' => \&help, 'q' => \&done, 'r' => \&refresh, #also "\cL" "\n"=> \&downline, #also "\e[B" ' ' => \&downpage, #also "\cv" 'd' => \&downhalf, 'b' => \&uppage, #also "\ev" 'y' => \&upline, #also "\e[A" 'u' => \&uphalf, 'g' => \&to_top, #also '<' 'G' => \&to_bott, #also '>' '/' => \&search, '?' => \&hcraes, #reverse search 'n' => \&next_match, #also 'P' 'p' => \&prev_match, #also 'N' "\e[D" => \&move_left, "\e[C" => \&move_right, '#' => \&toggle_numbering, And a special sequence of a number followed by enter analogous to: '/(\d+)/' => \&jump(\1) if the value for that key is true. The C method may be particularly useful when enhancing the pager. It accepts a string to display, and an optional timeout to sleep for before the dialog is cleared. If the timeout is missing or 0, the dialog remains until a key is pressed. my $t = IO::Pager::Perl->new(); $t->add_text("Text to display"); $t->add_func('!'=>\&boo); $t->more(); sub boo{ my $self = shift; $self->dialog("BOO!", 1); } Should you add additional functionality to your pager, you will likely want to change the contents of the help dialog or possibly the status line. Use the C method to replace the default text or save text for your own interface. #Get the default help text my $help = $t->I18N('help'); #Minimal status line $t->I18N('prompt', " help"); Current text elements available for customization are: 404 - search text not found dialog bottom - prompt line end of file indicator continue - text to display at the bottom of the help dialog help - help dialog text, a list of keys and their functions prompt - displayed at the bottom of the screen status - brief message to include in the status line top - prompt line start of file indicator I is intended for sharing short messages not worthy of a dialog e.g; when debugging. You will need to call the C method after setting it to refresh the status line of the display, then void I and call C again to clear the message. =head3 Scalability The help text will be split in two horizontally on a null character if the text is wider than the display, and shown in two sequential dialogs. Similarly, the status text will be cropped at a null character for narrow displays. =head1 CAVEATS =head2 UN*X This modules currently only works in UN*X-like environment. =head2 Performance For simplicity, the current implementation loads the entire message to view at once; thus not requiring a distinction between piped contents and files. This may require significant memory for large files. =head2 Termcap This module uses Termcap, which has been deprecated the Open Group, and may not be supported by your operating system for much longer. If the termcap entry for your ancient esoteric terminal is wrong or incomplete, this module may either fill your screen with unintelligible gibberish, or drop back to a feature-free mode. Eventually, support for Terminfo may also be added. =head2 Signals IO::Pager::Perl sets a global signal handler for I, this is the only way it can effectively detect and accommodate changes in terminal size. If you also need notification of this signal, the handler will trigger any callback assigned to the I attribute of the C method. =head1 ENVIRONMENT IO::Pager::Perl checks the I and I variables. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHORS Jerrad Pierce jpierce@cpan.org Jeff Weisberg - http://www.tcp4me.com =head1 LICENSE This software may be copied and distributed under the terms found in the Perl "Artistic License". A copy of the "Artistic License" may be found in the standard Perl distribution. =cut IO-Pager-1.01/lib/IO/Pager/Unbuffered.pm0000644000076400007640000000572613360425621017560 0ustar belg4mitbelg4mitpackage IO::Pager::Unbuffered; our $VERSION = 0.42; use strict; use base qw( IO::Pager ); use SelectSaver; sub new(;$) { # [FH], procedural my($class, $tied_fh); eval { ($class, $tied_fh) = &IO::Pager::_init }; #We're not on a TTY so... if( defined($class) && $class eq '0' or $@ =~ '!TTY' ){ #...leave filehandle alone if procedural return $_[1] if defined($_[2]) && $_[2] eq 'procedural'; #...fall back to IO::Handle for transparent OO programming eval "require IO::Handle" or die $@; return IO::Handle->new_from_fd(fileno($_[1]), 'w'); } $!=$@, return 0 if $@ =~ 'pipe'; my $self = tie *$tied_fh, $class, $tied_fh or return 0; { # Truly unbuffered my $saver = SelectSaver->new($self->{real_fh}); $|=1; } return $self; } #Punt to base, preserving FH ($_[0]) for pass by reference to gensym sub open(;$) { # [FH] # IO::Pager::open($_[0], 'IO::Pager::Unbuffered'); &new('IO::Pager::procedural', $_[0], 'procedural'); } 1; __END__ =pod =head1 NAME IO::Pager::Unbuffered - Pipe output to PAGER if destination is a TTY =head1 SYNOPSIS use IO::Pager::Unbuffered; { local $STDOUT = IO::Pager::Unbuffered::open *STDOUT; print <<" HEREDOC" ; ... A bunch of text later HEREDOC } { # You can also use scalar filehandles... my $token = IO::Pager::Unbuffered::open($FH) or warn($!); print $FH "No globs or barewords for us thanks!\n" while 1; } { # ...or an object interface my $token = new IO::Pager::Unbuffered; $token->print("OO shiny...\n") while 1; } =head1 DESCRIPTION IO::Pager subclasses are designed to programmatically decide whether or not to pipe a filehandle's output to a program specified in I; determined and set by IO::Pager at runtime if not yet defined. See L for method details. =head1 METHODS All methods are inherited from IO::Pager; except for instantiation. =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, L, L, =head1 AUTHOR Jerrad Pierce Florent Angly This module was inspired by Monte Mitzelfelt's IO::Page 0.02 Significant proddage provided by Tye McQueen. =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2018 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 IO-Pager-1.01/lib/IO/Pager/less.pm0000644000076400007640000001311413547206335016435 0ustar belg4mitbelg4mitpackage IO::Pager::less; our $VERSION = 1.01; use strict; use base qw( IO::Pager::Unbuffered ); BEGIN{ die "Windows is currently unsupported" if $^O =~ /MSWin32/; my $PAGER; our $BLIB; #local $ENV{PATHEXT} .= ";.PL" foreach my $lib ( @INC ){ $PAGER = File::Spec->catfile($lib, 'IO', 'Pager', 'tp'); if( -e $PAGER ){ $ENV{PAGER} = $^X.($BLIB?' -Mblib ':' ').$PAGER; last; } } } 1; __DATA__ package IO::Pager::less; our $VERSION = 1.00; use strict; use base qw( IO::Pager ); use SelectSaver; use IO::Pager::Perl; our %CFG; sub new(;$) { # [FH], procedural my($class, $tied_fh); eval { ($class, $tied_fh) = &IO::Pager::_init }; #We're not on a TTY so... if( defined($class) && $class eq '0' or $@ =~ '!TTY' ){ #...leave filehandle alone if procedural return $_[1] if defined($_[2]) && $_[2] eq 'procedural'; #...fall back to IO::Handle for transparent OO programming eval "require IO::Handle" or die $@; return IO::Handle->new_from_fd(fileno($_[1]), 'w'); } $!=$@, return 0 if $@ =~ 'pipe'; my $self = tie *$tied_fh, $class, $tied_fh or return 0; use Data::Dumper; print Dumper 'TIED: ', $$, $self; CORE::print {$self->{real_fh}} "BOO!"; { # Truly unbuffered my $saver = SelectSaver->new($self->{real_fh}); $|=1; } return $self; } #Punt to base, preserving FH ($_[0]) for pass by reference to gensym sub open(;$) { # [FH] &new('IO::Pager::procedural', $_[0], 'procedural'); } sub PRINT { my ($self, @args) = @_; CORE::print {$self->{LOG}} @args if exists($self->{LOG}); CORE::syswrite({$self->{real_fh}}, join('', @args) ) or die "Could not print to PAGER: $!\n"; } sub _pipe_to_fork ($) { pipe(my $READ, my $WRITE=shift) or die; { # Unbuffer! my $saver = SelectSaver->new($WRITE); $|=1; } warn "$READ $WRITE"; #XXX my $pid = fork(); die "fork() failed: $!" unless defined $pid; #Parent is reader to maintain STDIN/STDOUT if( $pid ){ warn "Parent: $$, Child: $pid"; close $WRITE; my $tmp; sysread($READ, $tmp, 1024); warn 'WTF? ', $tmp; open(STDIN, "<&=" . fileno($READ)) or die $!; } else{ syswrite($WRITE, "MUAHAHAHA\n"); #XXX close $READ; } $pid; } sub TIEHANDLE { my ($class, $tied_fh) = @_; my($real_fh, $child); #Parent is interface, child does work if( $child = _pipe_to_fork( $real_fh=Symbol::gensym() ) ){ my $t = IO::Pager::Perl->new(); #Customize interfaces foreach my $key ( keys(%CFG) ){ $t->add_func($key, $CFG{$key}) if $key; } while( eval{ $t->more(RT=>.05) } ){ my $tmp; $t->add_text($tmp) if sysread($real_fh, $tmp, 1024); } #XXX exit or die?! SIGPIPE?! } else{ my $X = bless { 'real_fh' => $real_fh, 'tied_fh' => "$tied_fh", #Avoid self-reference leak 'child' => $child, #XXX Actually, we want the parent?! 'pager' => 'IO::Pager::less', #XXX tp }, $class; use Data::Dumper; warn Dumper ['BLESSED: ', $$, $X]; return $X; } } 1; __END__ =pod =head1 NAME IO::Pager::less - No pager? Pipe output to Perl-based pager a TTY =head1 SYNOPSIS =cut #!!! CURRENT IMPLEMENTATION REQUIRES Term::ReadKey ##Required if you want unbuffered output use Term::ReadKey; { #!!! NOT AVAILABLE WITH CURRENT IMPLEMENTATION #Configure extra shortcuts, add an embedded shell %IO::Pager::less::CFG = ( '!' => sub{ "REPL implementation" } ); =pod { #Can be instantiated functionally or OO, same as other sub-classes. my $token = new IO::Pager::less; $token->print("Pure perl goodness...\n") while 1; } =head1 DESCRIPTION IO::Pager::less is a simple, extensible, perl-based pager. =cut If you want behavior similar to IO::Pager::Buffer do not load Term::ReadKey, and output will be buffered between keypresses. =pod See L for method details. =cut = head1 CONFIGURATION I<%IO::Pager::less::CFG> elements are passed to Term::Pager's add_func method. The hash keys are single key shortcut definitions, and values a callback to be invoked when said key is pressed e.g; #Forego default left-right scrolling for more less-like seeking %IO::Pager::less::CFG = ( '<' => \&Term::Pager::to_top, #not move_left '>' => \&Term::Pager::to_bottom #not move_right ); Because IO::Pager::less forks, the callback functions must exist prior to instantiation of the IO::Pager object to work properly. =pod =head1 METHODS All methods are inherited from IO::Pager; except for instantiation and print. =cut = 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 =pod =head1 SEE ALSO L, L, L, L, =head1 AUTHOR Jerrad Pierce Florent Angly This module was inspired by Monte Mitzelfelt's IO::Page 0.02 Significant proddage provided by Tye McQueen. =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2018 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 IO-Pager-1.01/lib/IO/Pager/Page.pm0000644000076400007640000000364013357534450016347 0ustar belg4mitbelg4mitpackage IO::Pager::Page; our $VERSION = 0.32; # The meat BEGIN { # Do nothing in Perl compile mode return if $^C; # Find a pager use IO::Pager; # Pipe stdout to it new IO::Pager *STDOUT, 'IO::Pager::Unbuffered'; } # Gravy sub import { my ($self, %opt) = @_; $SIG{PIPE} = 'IGNORE' if $opt{hush}; } "Badee badee badee that's all folks!"; __END__ =pod =head1 NAME IO::Pager::Page - Emulate IO::Page, pipe STDOUT to a pager if STDOUT is a TTY =head1 SYNOPSIS Pipes STDOUT to a pager if STDOUT is a TTY =head1 DESCRIPTION IO::Pager was designed to programmatically decide whether or not to point the STDOUT file handle into a pipe to program specified in the I environment variable or one of a standard list of pagers. =head1 USAGE BEGIN { use IO::Pager::Page; # use I::P::P first, just in case another module sends output to STDOUT } print< foible resulting from the user exiting the pager prematurely, load IO::Pager::Page like so: use IO::Pager::Page hush=>1; =head1 SEE ALSO L, L, L, L =head1 AUTHOR Jerrad Pierce Florent Angly This module inspired by Monte Mitzelfelt's IO::Page 0.02 =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2015 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 IO-Pager-1.01/lib/IO/Pager/tp0000755000076400007640000000130013546751631015477 0ustar belg4mitbelg4mit#!/usr/local/bin/perl use strict; use IO::Pager::Perl; use Term::ReadKey; my $t = IO::Pager::Perl->new(pause=>"\cL", wrap=>1, pause=>"\cL"); my($PIPE, @F); if( -t STDIN ){ @F = } else{ #Separate piped input from keyboard input open($PIPE, '<&=STDIN' ) or die $!; close(STDIN); open(STDIN, '<', '/dev/tty') or die $!; } eval{ while( $t->more(RT=>.05) ){ my $X; defined($PIPE) ? do{ $t->add_text($X) if sysread($PIPE, $X, 1024) } : $t->add_text( splice(@F, 0, $t->rows()) ); } }; __END__ =pod =head1 SEE ALSO =head1 NAME tp - a pure perl pager =head1 SEE ALSO L, L =head1 AUTHORS Jerrad Pierce jpierce@cpan.org =head1 LICENSE =cut IO-Pager-1.01/lib/IO/Pager.pm0000644000076400007640000003630113547206202015463 0ustar belg4mitbelg4mitpackage IO::Pager; our $VERSION = "1.01"; #Untouched since 1.00 use 5.008; #At least, for decent perlio, and other modernisms use strict; use base qw( Tie::Handle ); use Env qw( PAGER ); use File::Spec; use PerlIO; use Symbol; use overload '+' => "PID", bool=> "PID"; our $SIGPIPE; my $oldPAGER = $PAGER; 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 $_[0] eq $_ or $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 $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"; # } if ( $child = CORE::open($real_fh, '|-', $PAGER) ){ 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}}; } *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__ =pod =head1 NAME IO::Pager - Select a pager and pipe text to it if destination is 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 environment variable (see L). It is also a factory for creating I/O objects such as L and L. IO::Pager subclasses are designed to programmatically decide whether or not to pipe a filehandle's output to a program specified in I. 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 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. =item SUBCLASS Specifies which variety of IO::Pager to create. This accepts fully qualified packages I, or simply the third portion of the package name I for brevity. Defaults to L. Returns false and sets I<$!> on failure, same as perl's C. =back =head2 PID Call this method on the token returned by C 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 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. 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. 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>) indicator to overwrite an existing file, or an explicit (IE>) 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 like so: binmode(*STDOUT, ":tee(TH)"); #OR $STDOUT->binmode(':tee(TH)'); =head2 eof( FILEHANDLE ) Used in the eval-until-eof idiom below, I 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, 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 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, 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 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 for more information. =back =head1 FILES IO::Pager may fall back to these binaries in order if I is not executable. =over =item /etc/alternatives/pager =item /usr/local/bin/less =item /usr/bin/less =item L as C via L =item /usr/bin/more =back See L for more information. =head1 NOTES The algorithm for determining which pager to use is as follows: =over =item 1. Defer to I If the I 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. =item 3. File::Which If File::Which is available, use the first pager possible amongst C, C, C, C, C and L. =item 4. Term::Pager via IO::Pager::Perl =cut If instantiating an IO::Pager object and Term::Pager version 1.5 or greater is available, L will be used. =pod You may also set $ENV{PAGER} to Term::Pager to select this extensible, pure perl pager for display. =item 5. more Set I to C, and cross our fingers. =back Steps 1, 3 and 5 rely upon the I 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, L, L, L, L, L =head1 AUTHOR Jerrad Pierce Florent Angly This module was inspired by Monte Mitzelfelt's IO::Page 0.02 =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2019 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 IO-Pager-1.01/CHANGES0000644000076400007640000001256213547205267014022 0ustar belg4mitbelg4mitRevision history for Perl extension IO::Pager. 1.01 Tue Oct 08 2019 Add less.pm to MANIFEST Fix interactive test 16 1.00 Mon Oct 07 2019 Fork Term::Pager to IO::Pager::Perl, with many new features. NOTE: This is a breaking change from 0.43 & 0.44. What was IO::Pager::Perl in those versions is now IO::Pager::less i.e; a shim for pager-less systems to use the pure perl pager implementation in IO::Pager::Perl. Update bloody version number transclusions. RT#130643 0.44 Mon Sep 30 2019 Remove debugging calls mistakenly left in code. RT#130595 Skip testing on dumb "terminal" setups. RT#130596 Add (unexposed) code for less -J search line highlighting, and more form feed break to tp (IO::Pager::Perl). 0.43 Sun Sep 29 2019 Roll out a suboptimal but functional IO::Pager::Perl, fixing RT#130461 and RT#130565 0.42 Thu Sep 05 2019 Disambiguate tee open. RT#127551 Stringify version. RT#127342 Add bignum dependency RT#130319 Add support for eventual Term::Pager v1.5 Update META files. 0.40 Mon Oct 08 2018 And a tee(1)-like feature via binmode(). Fix some interactive tests; 07 and 10. Document potentially surprising behaviors in IO::Pager::Buffered. One more bloody RT#121450; missed 11-redirect-oo.pl 0.39 Sat May 13 2017 Rename t.pl to test.pl and alter behavior to address RT#120618 i.e; MakeMaker's "helpfulness"; alternative is explicitly list all PM in module. More bloody RT#121450 0.38 Tue May 11 2017 0.37 Tue Apr 25 2017 Fix tests for Perl 5.26 removal of . from @INC RT#121450 (Patching for unreleased perl is a PITA) 0.36 Mon Feb 29 2016 Fix Use of uninitialized value at IO/Pager.pm line 98 Remove dubgging statement. Add some additional reporting to interactive tests. Specify minimum Test::More version. 0.35 Fri Jan 01 2016 Update test 11 for Windows; okay in CMD, PowerShell and MSYS but tcsh and win-bash both fail. Add .travis.yml 0.34 Wed Feb 25 2015 Fix version error in Makefile. Fix a bug in 3-arg open introduced by fix for 1-arg in 0.33. 0.33 Wed Feb 25 2005 Fix "Warning: unable to close filehandle $real_fh properly." Fixed FILEHANDLE only open(). 0.32 Tue Feb 24 2005 Add 3-arg open support. Add eof() mechanism for semi-elegant signal handling. Update documentation. Undef $ENV{LESS} in interactive tests in case -E is set. Robustify t/11 for Win32 RT#79950 0.31 Sat Apr 06 2013 Add missing IO::Handle fallback for ::Unbuffered RT#82351 Bogus fix for Windoze automatic line-ending failure of t/11 RT#79950, improvements welcomed. 0.30 Tue Sep 04 2012 Implement feature request #RT78270 to include support for say() Preserve layers of passed hilehandle on instantiation. Fixed tests under Win32 & cygwin RT#75181 Swap IO::Pager:new and ::open, alter subclass::open to remove unnecessary level of subroutine calls Return IO::Handle objects when not connected to a TTY for transparent use of IO::Pager when programming OO. NOTE: This is broken, see ::less in TODO 0.24 Sat Feb 18 2012 Fixed RT#74691, tests fail if CPANTS folk don't have a perl in PATH! Add PID method & token overload to access pager process identifier. Remove semi-circular reference in object to fix implicit close(). 0.20 Sat Feb 11 2012 Fixed RT#74691, add File::Which as dependency / skip test if missing Fixed non-TTY/redirection behavior and added corresponding test Improve buffering sistuation in both ::Buffered and ::Unbuffered Auto-gensym scalar filehandles like perl's open Add OO interface Add alternate pagers 'lv', 'pg', and system default '/etc/alternatives/pager' RT#74519 Add tests for initialization failure conditions (9-open.t) 0.16 Fri Feb 3 2012 Require 5.8.0 or better Removed Perl warning 'Use of tie on a handle without * is deprecated'. No interactive questions during 'make test' RT#66718 Better handling of missing PAGER. Look for more pagers: 'most' and 'w3m' RT#74519 Documentation clean-up, light refactoring, more error checks. Do not run IO::Pager::Page automatically when in Perl compile mode. 0.10 Unreleased Added support for encodings via binmode() RT#67930 Test: encoding, handle (glob, scalar, OO), interactive... 0.07 Unreleased Rewrote to support scalar filehandles per user request and IO::Handle style OO support came along for the ride. Fixed several mis-coded segments that did not affect operation. Added C in IO::Pager::Unbuffered to check size of buffered output. Pager open error now sets $! instead of issuing a warning, to more closely emulate the C experience. Check return value as before. Neglected to update $VERSION in last release. Touched up the documentation. 0.06 Wed Sep 21 2005 Fixed a stupid leftover using =~ for assignment that some perls ignored RT14692. Fixed other nits in t.pl and documentation. 0.05 Thu Jul 17 20:01:55 EDT 2003 Touched up documentation. Added IO::Pager::Page, a clone of IO::Page "Broken pipe" foible and all. Fixed a bug in pager selection algorithm, it failed if you did not have File::Which. It is now back to being only strongly recommended as opposed to required. 0.04 Wed Jul 16 18:53:58 EDT 2003 Removed a stupid debug message from IO::Pager::new. Improved PAGER selection algorithm. Touched up documentation. Added some tests. 0.03 Tue Jul 15 23:11:12 2003 Forked from IO::Page. 0.02 Tue Jul 15 23:11:12 2003 original version; created by h2xs 1.22 with options -X -n IO::Pager. IO-Pager-1.01/t/0000755000076400007640000000000013547206642013262 5ustar belg4mitbelg4mitIO-Pager-1.01/t/08-redirect.t0000644000076400007640000000135613105625447015500 0ustar belg4mitbelg4mituse strict; use warnings; use File::Temp; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); #Disable warnings for awkard test file mechanism required by Windows my(undef, $tempname) = do{ $^W=0; File::Temp::tempfile(OPEN=>0)}; END{ close(TMP); unlink $tempname or die "Could not unlink '$tempname': $!" } #Print the heredoc in 08-redirect.pl to temp file via redirection my $q = q[']; $q = q["] if $^O =~ /MSWin32/; system qq($^X -Mblib -MIO::Pager::Page -e $q require q[./t/08-redirect.pl]; print \$txt $q >$tempname); open(TMP, $tempname) or die "Could not open tmpfile: $!\n"; my $slurp = do{ undef $/; }; our $txt; require './t/08-redirect.pl'; ok($txt eq $slurp, 'Redirection (IO::Pager::Page)'); done_testing; IO-Pager-1.01/t/04-buffered_interactive.t0000644000076400007640000000244713077763231020056 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test buffered paging SKIP: { skip_interactive(); require IO::Pager; diag "\n". "Reading is fun! Here is some text: ABCDEFGHIJKLMNOPQRSTUVWXYZ\n". "This text should be displayed directly on screen, not within a pager.\n". "\n"; select STDERR; my $A = prompt("\nWas the text displayed directly on screen? [Yn]"); ok is_yes($A), 'Diagnostic'; { my $BOB = new IO::Pager *BOB, 'IO::Pager::Buffered'; isa_ok $BOB, 'IO::Pager::Buffered'; isa_ok $BOB, 'Tie::Handle'; for (1..10) { printf BOB "Line %06i, buffer [%06i] @ %s\n", $_, tell(BOB), scalar localtime; } print BOB "Sleeping for 2 seconds...\n"; # IO::Pager::Buffered::flush(*BOB); $BOB->flush(); sleep 2; for (reverse 1..10) { printf BOB "Line %06i, buffer [%06i] @ %s\n", $_, tell(BOB), scalar localtime; } printf BOB "\nEnd of text, try pressing 'Q' to exit. @%s\n", scalar localtime; close BOB; } $A = prompt("\nWas the text displayed in a pager? [Yn]"); ok is_yes($A), 'Buffered glob filehandle'; $A = prompt("\nWas there a pause between the two blocks of text? [Yn]"); ok is_yes($A), 'Flush buffered filehandle'; } done_testing; IO-Pager-1.01/t/13-eof_interactive.t0000644000076400007640000000074513077763320017043 0ustar belg4mitbelg4mituse strict; use warnings; use File::Temp; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use bignum; use IO::Pager::Page; SKIP: { skip_interactive(); $a=1; $b=1; eval{ print $a, "\n"; #Fibonacci is the golden ratio ($a,$b)=($b,$a+$b); } until( eof(*STDOUT) ); print "Pager closed, wrapping up.\n"; my $A = prompt("\nWere things wrapped up after you quit the pager? [Yn]"); ok is_yes($A), 'Signal handling EOF'; } done_testing; IO-Pager-1.01/t/02-which.t0000644000076400007640000000232713077761440014774 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use Env qw( PAGER ); use IO::Pager; my $pager; # Find anything that looks like a pager, unspecified $PAGER = undef; $pager = IO::Pager::find_pager(); ok $pager, 'Undefined PAGER'; # Find anything that looks like a pager 2, this is redundant $PAGER = ''; $pager = IO::Pager::find_pager(); ok $pager, 'Blank PAGER'; # Find anything that looks like a pager 3, bad initial setting $PAGER = 'asdfghjk666'; $pager = IO::Pager::find_pager(); isnt $pager, 'asdfghjk666', 'PAGER does not exist'; # Perl is sure to be present, pretend it's a pager specified w/ absolute path $PAGER = perl_path(); $pager = IO::Pager::find_pager(); is $pager, perl_path(), 'PAGER referred by its full-path'; # Perl is sure to be present, pretend it's a pager specified w/o path SKIP: { skip_no_file_which(); $PAGER = perl_exe(); skip_not_in_path($PAGER); $pager = IO::Pager::find_pager(); like $pager, qr/perl/i, 'PAGER is referred by its executable name'; } # Verify that options set in the PAGER variable are preserved $PAGER = perl_path().' -w'; $pager = IO::Pager::find_pager(); is $pager, perl_path().' -w', 'PAGER with options'; done_testing; IO-Pager-1.01/t/07-oo_interactive.t0000644000076400007640000000226713357533050016707 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test OO interface SKIP: { skip_interactive(); require IO::Pager; require IO::Pager::Buffered; { # my $BOB = new IO::Pager::Buffered or die "Failed to create PAGER FH $!"; my $BOB = new IO::Pager local *STDOUT, 'Buffered' or die "Failed to create PAGER FH $!"; isa_ok $BOB, 'IO::Pager::Buffered'; $BOB->print("OO factory filehandle\n") foreach 1..25; $BOB->print("\nEnd of text, try pressing 'Q' to exit.\n"); } select STDERR; my $A1 = prompt("\nDid you see 'OO factory filehandle' in your pager? [Yn]"); ok is_yes($A1), 'OO, factory instantiation'; require IO::Pager::Unbuffered; { my $BOB = new IO::Pager::Unbuffered or die "Failed to create PAGER FH $!"; isa_ok $BOB, 'IO::Pager::Unbuffered'; $BOB->say("OO subclass filehandle") foreach 1..25; $BOB->say("\nEnd of text, try pressing 'Q' to exit."); #XXX Close required because pager is not terminated on DESTROY $BOB->close(); } my $A2 = prompt("\nDid you see 'OO subclass filehandle' in your pager? [Yn]"); ok is_yes($A2), 'OO, subclass instantiation'; } done_testing; IO-Pager-1.01/t/11-redirect-oo.t0000644000076400007640000000174613544377733016121 0ustar belg4mitbelg4mituse strict; use warnings; use File::Temp; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); #Disable warnings for awkard test file mechanism required by Windows my(undef, $tempname) = do{ $^W=0; File::Temp::tempfile(OPEN=>0)}; END{ close(TMP); unlink $tempname or die "Could not unlink '$tempname': $!" } #Print the heredoc in 11-redirect.pl to temp file via redirection system qq($^X t/11-redirect-oo.pl >$tempname); open(TMP, $tempname) or die "Could not open tmpfile: $!\n"; my $slurp = do{ undef $/; }; TODO:{ local $TODO = ''; #Special case for CMD & PowerShell lameness, see diag below if( $^O =~ /MSWin32/ ){ $slurp =~ s/\n\n\z/\n/m; } SKIP:{ skip_no_tty(); our $txt; require './t/08-redirect.pl'; cmp_ok($txt, 'eq', $slurp, 'Redirection with OO') || $^O =~ /MSWin32/ && diag("If this test fails on Windows and all others pass, things are probably good. CMD appends an extra newline to redirected output."); } } done_testing; IO-Pager-1.01/t/TestUtils.pm0000644000076400007640000000321613544377576015576 0ustar belg4mitbelg4mitpackage t::TestUtils; use strict; use warnings; use Config; use Test::More; use Env qw( HARNESS_ACTIVE ); BEGIN { use ExtUtils::MakeMaker qw( prompt ); use base qw( Exporter ); our @EXPORT = qw{ skip_interactive skip_old_perl skip_no_file_which skip_no_tty skip_not_in_path is_no is_yes perl_exe perl_path prompt }; } sub skip_interactive { skip "!! Run 'perl -Mblib test.pl interactive' to perform interactive tests/demonstrations of the module's abilities.", 1 if $HARNESS_ACTIVE; } sub skip_old_perl { skip "Layers requires Perl 5.8.0 or better.", 1 if $] < 5.008; } sub skip_no_file_which { skip "This test requires File::Which.", 1 if not eval { require File::Which }; } sub skip_no_tty { skip "/dev/tty cannot be opened.", 1 if not open(my $fh, '<', '/dev/tty'); close $fh; } sub skip_not_in_path { # Test that the specified executable can be found in the PATH environment # variable using File::Which. my $exe = shift; my $loc = File::Which::which($exe); skip "Executable '$exe' is not in PATH.", 1 if not defined $loc; } sub is_yes { my ($val) = @_; return ($val =~ /^y(?:es)?/i || $val eq ''); } sub is_no { my ($val) = @_; return ($val =~ /^n(?:o)?/i || $val eq ''); } sub perl_exe { # Find the Perl executable name my $this_perl = $^X; $this_perl = (File::Spec->splitpath( $this_perl ))[-1]; return $this_perl; } sub perl_path { # Find the Perl full-path (taken from the perlvar documentation) my $this_perl = $^X; if ($^O ne 'VMS') { $this_perl .= $Config{_exe} unless $this_perl =~ m/$Config{_exe}$/i; } return $this_perl; } 1; IO-Pager-1.01/t/15-log_interactive.t0000644000076400007640000000140313356732264017050 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use bignum; use IO::Pager; SKIP: { skip_interactive(); local $STDOUT = new IO::Pager *STDOUT; eval{ require PerlIO::Util }; skip("Could not load PerlIO::Tee") if $@; binmode(*STDOUT, ":LOG()"); $a=2308; $b=4261; print my $LOG ="Exit your pager after a bit\n"; eval{ $LOG .= "$a\n"; print $a, "\n"; #Brady numbers also the golden ratio ($a,$b)=($b,$a+$b); select(undef, undef, undef, 0.15); } until( eof(*STDOUT)); print "Pager closed, checking log.\n"; open(LOG, "$$.log") or die "Missing $$.log: $!"; my $TEE = join('', ); cmp_ok($LOG, 'eq', $TEE, ':LOG pseudo-layer'); } done_testing; END{ unlink("$$.log") } IO-Pager-1.01/t/01-load.t0000644000076400007640000000043513077761440014606 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test that all modules load properly BEGIN { use_ok('IO::Pager'); use_ok('IO::Pager::Unbuffered'); use_ok('IO::Pager::Buffered'); use_ok('IO::Pager::Page'); }; done_testing; IO-Pager-1.01/t/06-scalar_interactive.t0000644000076400007640000000133113077763250017533 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test unbuffered paging SKIP: { skip_interactive(); require IO::Pager; { my $BOB; local $STDOUT = IO::Pager::open($BOB, 'IO::Pager::Buffered'); is ref($BOB), 'GLOB', 'Gensym'; isa_ok $STDOUT, 'IO::Pager::Buffered'; isa_ok $STDOUT, 'Tie::Handle'; eval { my $i = 0; for (1..20) { printf($BOB "%06i There is more than one to do it.\n", $_); } printf $BOB "\nEnd of text, try pressing 'Q' to exit.\n", $_; }; close($BOB); } my $A = prompt("\nWas the text displayed in a pager? [Yn]"); ok is_yes($A), 'Buffered scalar filehandle'; } done_testing; IO-Pager-1.01/t/09-open.t0000644000076400007640000000120513077761440014634 0ustar belg4mitbelg4mituse strict; use warnings; use File::Spec; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); no warnings; $^W = 0; #Avoid: Can't exec "/dev/null": Permission denied use IO::Pager; SKIP: { skip("Skipping because Windows has to be different^Wdifficult", 1) if $^O =~ /MSWin32|cygwin/; undef $ENV{PAGER}; eval{ my $token = new IO::Pager }; like($@, qr/The PAGER environment variable is not defined/, 'PAGER undefined since find_pager()'); $ENV{PAGER} = File::Spec->devnull(); eval{ my $token = new IO::Pager or die $!}; like($@, qr/Could not pipe to PAGER/, 'Could not create pipe'); } done_testing; IO-Pager-1.01/t/03-bald_interactive.t0000644000076400007640000000200413077763176017172 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test unbuffered paging SKIP: { skip_interactive(); require IO::Pager; diag "\n". "Reading is fun! Here is some text: ABCDEFGHIJKLMNOPQRSTUVWXYZ\n". "This text should be displayed directly on screen, not within a pager.\n". "\n"; select STDERR; my $A = prompt("\nWas the text displayed directly on screen? [Yn]"); ok is_yes($A), 'Diagnostic'; { local $STDOUT = new IO::Pager *BOB; # IO::Pager::Unbuffered by default isa_ok $STDOUT, 'IO::Pager::Unbuffered'; isa_ok $STDOUT, 'Tie::Handle'; eval { my $i = 0; $SIG{PIPE} = sub{ "Work complete" }; while (1) { printf BOB "%06i Printing text in a pager. Exit at any time, usually by pressing 'Q'.\n", $i++; sleep 1 unless $i%400; } }; close BOB; } $A = prompt("\nWas the text displayed in a pager? [Yn]"); ok is_yes($A), 'Unbuffered glob filehandle'; } done_testing; IO-Pager-1.01/t/02-which_interactive.t0000644000076400007640000000070513077763111017364 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use Env qw( PAGER ); # Test that a reasonable pager can be found SKIP: { skip_interactive(); diag "Current PAGER: '".($PAGER||'')."'\n"; require IO::Pager; diag "PAGER set by IO::Pager: '".($PAGER||'')."'\n"; select STDERR; my $A = prompt("\nIs this reasonable? [Yn]"); ok is_yes($A), 'Found a reasonable pager'; } done_testing; IO-Pager-1.01/t/08-redirect.pl0000644000076400007640000000465312021541465015644 0ustar belg4mitbelg4mitour $txt = <print($txt); IO-Pager-1.01/t/12-preservelayers_interactive.t0000644000076400007640000000127513077763312021344 0ustar belg4mitbelg4mituse strict; use warnings; use File::Temp; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use 5.6.0; use utf8; use IO::Pager; SKIP: { skip_interactive(); my $fileno = fileno(STDOUT); { binmode(*STDOUT, ':encoding(UTF-8)'); my $pager = IO::Pager->new(*STDOUT); $pager->say('Bonzai Bjørn'); $pager->say("$/End of text, try pressing 'Q' to exit."); $pager->close(); } #Reinstate some order CORE::open(*BOB, ">&=$fileno"); binmode(*BOB, ':encoding(UTF-8)'); select(BOB); my $A = prompt("\nDid you see 'Bonzai Bjørn' in your pager? Note the crossed o in the second word [Yn]"); ok is_yes($A), 'layer preservation'; } done_testing; IO-Pager-1.01/t/10-close_interactive.t0000644000076400007640000000244513357534232017372 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use IO::Pager; SKIP: { skip_interactive(); my $A; PAUSE: { my $token = new IO::Pager local *RIBBIT, 'Buffered'; isa_ok $token, 'IO::Pager::Buffered'; my $PID = $token->PID; $token->print("Pager child '$token->{pager}' is PID $PID\n"); $token->print("\nEnd of text, try pressing 'Q' to exit.\n"); is $PID, $token->{child}, "PID($PID)"; sleep 1; } $A = prompt("\nWas there a pause before the text appeared? [Ynr] (r-epeat)"); goto PAUSE if $A eq 'r'; ok is_yes($A), 'Implicit close of buffered OO filehandle'; { IO::Pager::open local *RIBBIT, 'Buffered'; print RIBBIT "No toad sexing allowed"; print RIBBIT "\nEnd of text, try pressing 'Q' to exit.\n" } $A = prompt("\nIs toad sexing allowed? (And posted before commentary on trains) [yN]"); goto PAUSE if $A eq 'r'; ok is_no($A), 'Implicit close of buffered glob filehandle'; #Possible future test, but meanwhile is here to ensure proper destruction, #since the output of this block would appear before above if no implicit close { new IO::Pager *MARY; print MARY "I like trains\n"; print MARY "\nEnd of text, try pressing 'Q' to exit.\n"; close(MARY); } } done_testing; IO-Pager-1.01/t/16-PurePerl_interactive.t0000644000076400007640000000225713547206574020040 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); BEGIN{ $IO::Pager::less::BLIB = $IO::Pager::less::BLIB = 1; } # Test OO interface SKIP: { skip_interactive(); skip("Windows is currently unsupported") if $^O =~ /MSWin32/; require IO::Pager; require IO::Pager::less; { my $BOB = new IO::Pager local *STDOUT, 'less' or die "Failed to create PAGER FH $!"; isa_ok $BOB, 'IO::Pager::less'; $BOB->print("OO factory filehandle\n") foreach 1..25; $BOB->print("\nEnd of text, try pressing 'Q' to exit.\n"); } select STDERR; my $A1 = prompt("\nDid you see 'OO factory filehandle' in your pager? [Yn]"); ok is_yes($A1), 'OO, factory instantiation'; { my $BOB = new IO::Pager::less or die "Failed to create PAGER FH $!"; isa_ok $BOB, 'IO::Pager::less'; $BOB->say("OO subclass filehandle") foreach 1..25; $BOB->say("\nEnd of text, try pressing 'Q' to exit."); #XXX Close required because pager is not terminated on DESTROY $BOB->close(); } my $A2 = prompt("\nDid you see 'OO subclass filehandle' in your pager? [Yn]"); ok is_yes($A2), 'OO, subclass instantiation'; } done_testing; IO-Pager-1.01/t/14-tee_interactive.t0000644000076400007640000000150713356726126017050 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); use bignum; use IO::Pager; SKIP: { skip_interactive(); local $STDOUT = new IO::Pager *STDOUT; eval{ require PerlIO::Util }; skip("Could not load PerlIO::Tee") if $@; binmode(*STDOUT, ":tee($$.log)"); #Equivalent to #$STDOUT->binmode(":tee($$.log)"); $a=2308; $b=4261; print my $LOG ="Exit your pager after a bit\n"; eval{ $LOG .= "$a\n"; print $a, "\n"; #Brady numbers also the golden ratio ($a,$b)=($b,$a+$b); select(undef, undef, undef, 0.15); } until( eof(*STDOUT)); print "Pager closed, checking log.\n"; open(LOG, "$$.log") or die "Missing $$.log: $!"; my $TEE = join('', ); cmp_ok($LOG, 'eq', $TEE, 'PerlIO::tee test passed'); } done_testing; END{ unlink("$$.log") } IO-Pager-1.01/t/05-binmode_interactive.t0000644000076400007640000000203113077763240017677 0ustar belg4mitbelg4mituse strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test paging binary content SKIP: { skip_interactive(); skip_old_perl(); require IO::Pager; my $warnings; eval { # Promote warnings to errors so we can catch them local $SIG{__WARN__} = sub { $warnings .= shift }; # Stream unicode in a pager local $STDOUT = new IO::Pager *BOB, ':utf8', 'IO::Pager::Buffered'; printf BOB "Unicode Z-inverted carat: \x{17D}\n"; #Ž printf BOB "Unicode Copyright < Copyleft: \x{A9} < \x{2184}\x{20DD}\n"; #© < ↄ⃝ printf BOB "Unicode camel: \x{1f42a}\n", $_; # 🐪 printf BOB "\nEnd of text, try pressing 'Q' to exit.\n"; close BOB; }; is $warnings, undef, 'No wide character warnings'; binmode STDOUT, ":utf8"; my $A = prompt("\nWere Unicode characters like \x{17D} and \x{A9},\nor perhaps a bytecode placeholder such as displayed in the pager? [Yn]"); ok is_yes($A), 'Binmode layer selection / pager Unicode support'; } done_testing; IO-Pager-1.01/README0000644000076400007640000000374513546752563013717 0ustar belg4mitbelg4mitIO::Pager & IO::Pager::Perl ===================== IO::Pager - Select a pager and pipe text to it if destination is a TTY IO::Pager::Perl - A pure perl pager engine IO::Pager::Perl is used in the IO::Pager::less IO::Pager subclass, but is also a free-standing library ready to be incorporated into other code. IO::Pager is lightweight and can be used to locate an available pager and set the PAGER environment variable sanely or as a factory for creating objects defined elsewhere such as IO::Pager::Buffered, IO::Pager::Unbuffered, and IO::Pager::less which provides a pure perl pager. IO::Pager subclasses are designed to programmatically decide whether or not to pipe a filehandle's output to a program specified in PAGER. Subclasses may inherit from IO::Pager, and implement the IO handle methods desired. INSTALLATION To install this module type the following: perl Makefile.PL make # Run non-interactive tests make test # Run interactive tests perl -Mblib test.pl interactive make install DEPENDENCIES Multiple core modules are used: base, Env, File::Spec, File::Which, IO::Handle, PerlIO, SelectSaver, Symbol, Text::Wrap, Tie::Handle Test::More is used during the installation procedure. PORTABILITY IO::Pager is intended to be as portable as possible, I've tested it on numerous platform and perl version combinations. Most work fine though you may run into quirks, it tends to be happiest under perl built with perlio not stdio. COPYRIGHT AND LICENSE Copyright (C) 2003-2019 Jerrad Pierce * Thou shalt not claim ownership of unmodified materials. * Thou shalt not claim whole ownership of modified materials. * Thou shalt grant the indemnity of the provider of materials. * Thou shalt use and dispense freely without other restrictions. 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. IO-Pager-1.01/Makefile.PL0000644000076400007640000000245513546121247014773 0ustar belg4mitbelg4mituse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'IO::Pager', 'VERSION_FROM' => 'lib/IO/Pager.pm', # finds $VERSION 'BUILD_REQUIRES' => { 'Test::More' => 0.88, 'Config' => 0, 'Env' => 0, 'Exporter' => 0, 'File::Temp' => 0, 'bignum' => 0, }, 'PREREQ_PM' => { 'base' => 0, 'Env' => 0, 'File::Spec' => 0, 'File::Which' => 0, 'IO::Handle' => 0, 'PerlIO' => 0, 'SelectSaver' => 0, 'Symbol' => 0, 'Term::ReadKey' => 0, 'Text::Wrap' => 0, 'Tie::Handle' => 0, }, META_MERGE => { "meta-spec" => { version => 2 }, runtime => { recommends => { # #Since Term::Pager is unmodern # 'Term::ReadKey' => 0, }, }, }, ($] >= 5.005 ? # Add these new keywords supported since 5.005 ( ABSTRACT_FROM => 'lib/IO/Pager.pm', # retrieve abstract from module AUTHOR => 'Jerrad Pierce , Florent Angly ', ) : ()), );