IO-Pager-2.10/0000755400215440010010000000000013750640046014116 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/.proverc0000644400215440010010000000000212471375343015573 0ustar jpierceNMRGROUP+Group(513)-bIO-Pager-2.10/CHANGES0000644400215440010010000002001013750552772015112 0ustar jpierceNMRGROUP+Group(513)Revision history for Perl extension IO::Pager. 2.10 Nov ::Perl Alter tp local script installation for parallel make. RT#133651 ::Perl Add basic Windows support. RT#133663 ::Perl Add TOPT environment variable to tp. ::Perl Enable scrollbar in interactive test 16. 2.01 Nov 02 2020 ::Perl Fixed bug that left terminal in unclean state if exit at EOF was enabled. ::Perl Fixed jump to end of file shortcut to show last line on bottom of screen instead of top to provide more context. ::Perl Made scrollbar interactive using xterm control sequences. ::Perl Added scroll wheel support using xterm control sequences. 2.00 Nov 01 2020 Fix interactive tests 7 and 16 in bogus environments w/o PAGER. RT#13330 Add tp to local script installation. RT#133651 ::Perl Add suport for visible scrollbar. RT#133652 ::Perl Rename prompt() to status(), I18N{prompt} to I18N{minihelp}, and I18N{status} to I18N{prompt} ::Perl Fix long lines in absence of Text::Wrap ::Perl Consolidate dialog() ::Perl Add ability to open file interactively ::Perl Prevent jumping to invalid bookmark ::Perl Fix tp -j 1.03 Jun 13 2020 Fix destruction warnings in Buffered Fix version number in Unbuffered Fix undefined warnings in unrealistically spartan environments. ::Perl Add ability to save buffer to file ::Perl Add search wrapping ::Perl Add navigation for multi-file viewing in tp. ::Perl Add flush buffer command to complement --tail. ::Perl Actually publish v1.02 changes for tp, they were made to a copy of the file not included in the distribution ::Perl Add experimental/incomplete grep mode; grep is lost on backwards scroll or dialog ::Perl Fix pause behavior in tp. ::Perl Fix folding; Text::Wrap was loaded at the wrong time. ::Perl Fix P, ^b and M-v, and add a bunch more command aliases. ::Perl Add work around for use of +OCRNL TTY mode to prevent status bar ghosting when using Enter to downline ::Perl restore Esc+x input ::Perl Remove unused (debugging) code. 1.02 Sun Jun 07 2020 Fix warning for undefined PAGER RT#132658 Fix flipped operands for cmp_ok in test 11. Fix synthetic warning in test 9. Win32 path fixes (git pull #6) Remove deprecated POD content that some parsers carped about RT#131437 ::Perl Add --tail mode to tp ::Perl Implement reflow for toggleable line numbering and folding. ::Perl Add support for bookmarks. ::Perl Add and document environment variable + switch processing to tp. ::Perl Rename visualBeep to visuaBell, but keep visualBeep as an alias. ::Perl Rename done() to close(), but keep done() as an alias. ::Perl Remove some debugging status updates. ::Perl More fixes for interactive test 16. 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::Buffered 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 RT#14692. 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-2.10/eg/0000755400215440010010000000000013750640042014505 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/eg/fib0000755400215440010010000000151713550402125015173 0ustar jpierceNMRGROUP+Group(513)#!/usr/local/bin/perl use strict; use IO::Pager::Perl; use Term::ReadKey; my($m, $n)=(1,1); my $t = IO::Pager::Perl->new(pause=>"\cL", wrap=>1, pause=>"\cL", text=> ["1\n", sub{ ($m,$n)=($n,$m+$n); return "$m\n" } ] ); 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 NAME fib - display Fibanocci sequence via callback with a pure perl pager =head1 SEE ALSO L, L =head1 AUTHORS Jerrad Pierce jpierce@cpan.org =head1 LICENSE =cut IO-Pager-2.10/eg/foldable.txt0000644400215440010010000000416113550407660017025 0ustar jpierceNMRGROUP+Group(513)Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur? At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia deserunt mollitia animi, id est laborum et dolorum fuga. Et harum quidem rerum facilis est et expedita distinctio. Nam libero tempore, cum soluta nobis est eligendi optio cumque nihil impedit quo minus id quod maxime placeat facere possimus, omnis voluptas assumenda est, omnis dolor repellendus. Temporibus autem quibusdam et aut officiis debitis aut rerum necessitatibus saepe eveniet ut et voluptates repudiandae sint et molestiae non recusandae. Itaque earum rerum hic tenetur a sapiente delectus, ut aut reiciendis voluptatibus maiores alias consequatur aut perferendis doloribus asperiores repellat.IO-Pager-2.10/eg/pauses.txt0000644400215440010010000000114113544775637016567 0ustar jpierceNMRGROUP+Group(513)1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 25 Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. a b c d e f g h i j k l m n o p q r s t u v w x y z @ [ \ ] ^ _IO-Pager-2.10/lib/0000755400215440010010000000000013750640042014660 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/lib/IO/0000755400215440010010000000000013750640042015167 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/lib/IO/Pager/0000755400215440010010000000000013750640042016225 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/lib/IO/Pager/Buffered.pm0000644400215440010010000001275013671706001020312 0ustar jpierceNMRGROUP+Group(513)package IO::Pager::Buffered; our $VERSION = 1.04; #Untouched since 1.03 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}) && length($self->{buffer}); $self->{buffer}=''; $self->SUPER::CLOSE(); } { no warnings 'once'; *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 flush occurs. 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 flushed or closed. =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 open, 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-2.10/lib/IO/Pager/less.pm0000644400215440010010000001315213750554175017546 0ustar jpierceNMRGROUP+Group(513)package IO::Pager::less; our $VERSION = 2.00; #Untouched since 2.00 use strict; use warnings; use base qw( IO::Pager::Unbuffered ); BEGIN{ die "Windows is currently unsupported" if $^O =~ /MSWin32/; my $PAGER; #Required for test 16 our $BLIB; #local $ENV{PATHEXT} .= ";.PL" foreach my $lib ( @INC ){ $PAGER = File::Spec->catfile($lib, 'IO', 'Pager', 'tp'); if( -e $PAGER ){ #Required for test 16 $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; #XXX use Data::Dumper; print Dumper 'TIED: ', $$, $self; #XXX 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 flush { $_[0]->refresh(); } 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 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-2.10/lib/IO/Pager/Page.pm0000644400215440010010000000373213671706203017450 0ustar jpierceNMRGROUP+Group(513)package IO::Pager::Page; use strict; use warnings; our $VERSION = 1.04; #Untouched since 1.02 # 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}; } local $_= "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-2.10/lib/IO/Pager/Perl.pm0000755400215440010010000012056713750637751017520 0ustar jpierceNMRGROUP+Group(513)package IO::Pager::Perl; our $VERSION = '2.10'; #Untouched since 2.10 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} = \&close; #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 = @_; $ENV{TERM} = $ENV{TERM} || ''; $ENV{TERMCAP} = $ENV{TERMCAP} || ''; 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. $ENV{TERM} = 'vt100' if( $ENV{TERM} eq 'screen' && $ENV{TERMCAP} !~ /sf/ ); #Hack together Windows support. We could use Term::Screen(::Uni), #but that uses many layers of tie-ing, some of which could be inheritiance. #This way also reduces dependencies if( $^O =~ /MSWin/ ){ eval "use Win32::Console::ANSI;"; if( $@ ){ warn "Could not load Win32::Console::ANSI, falling back to dumb mode - $@"; } else{ $ENV{TERM} = 'WINANSI'; #Windows lacks vb as does the fallback Term::Cap vt220 entry, add our own #https://www.ibiblio.org/oswg/oswg-nightly/oswg/en_US.ISO_8859-1/articles/alessandro-rubini/visual-bell/visual-bell-howto.html#VISIBLEBELL $ENV{TERMCAP} = do{ undef $/; $_=; y/\n//d; $_ }; } } else{ #Try to enable mouse support print "\e[?1000;1006;1015h"; } #Speed is mostly useless except Term::Cap demands it my $t = Term::Cap->Tgetent({ OSPEED => $param{speed} }); my $dumb = eval{ $t->Trequire(qw/cm ce cl sf sr/) } ? 1 : 0; #CORE: cm=>cup, ce=>el, cl=>clear, sf=>ind, sr=>ri #EXTRA: md=>bold, me=>sgr0, mr=>rev, us=>smul, vb=>flash 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; if( defined( $param{text} ) ){ my $ref = ref( $param{text} ); if( $ref eq 'ARRAY' ){ die "Invalid text, must be string, code ref, or [string, code ref]" unless (scalar( @{$param{text}} ) ==2) and ref( $param{text}->[0] ) eq '' and ref( $param{text}->[1] ) eq 'CODE'; $text = $param{text}->[0]; $param{text} = $param{text}->[1] } elsif( $ref eq '' ){ $text = delete( $param{text} ); } } $param{visualBell} = delete($param{visualBeep}) if defined($param{visualBeep}) and not defined($param{visualBell}); 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 => '', #pause=>"\cL" #more raw => 0, statusCol => 0, squeeze=>0, visualBell => 0, fold => 0, _fileN => 1, _mark => {1=>0}, scrollBar => 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}={ prompt=> '', 404=> 'Not Found', top=> 'Top', bottom=> 'Bottom', minihelp=> "=help \000=down =back =quit", continue=> 'press any key to continue', searchwrap=> 'No more matches, next search will wrap', nowrap=> 'Text::Wrap unavailable, disabling folding', help=> < goto bottom left scroll left 1 tab\000 right scroll right 1 tab S-left scroll left 1/2 \000 S-right scroll right 1/2 m mark position \000 ' return to mark # line numbering \000 \\d+\\n jump to line \\d+ :n next file \000 :p previous file C toogle raw \000 S toggle folding EOH }; our %config; add_keys(\&help, 'h', 'H'); add_keys(\&close, 'q', 'Q', ':q', ':Q'); add_keys(\&refresh, 'r', "\cL", "\cR"); add_keys(\&next_match,'n', 'P'); add_keys(\&prev_match,'p', 'N'); add_keys(\&to_bott, '>', 'G', '$', "\e>", "\e[F", "\e0E", "\e0W", "\e[4~"); #M-> ? End End End add_keys(\&downpage, ' ', 'z', "\cV", , 'f', "\cF", "\e ", "\e[6~"); #M- PgDn add_keys(\&downpage, "\eOs") if $ENV{TERM} eq 'WINANSI'; add_keys(\&downhalf, 'd', "\cD"); add_keys(\&downline, 'e', 'j', 'J', "\cE", "\cN", "\e[B"); #down add_keys(\&downline_raw, "\n", "\r"); add_keys(\&upline, 'y', 'k', "\cY", "\cK", 'K', 'Y', "\cP", "\e[A"); #up add_keys(\&uphalf, 'u', "\cU"); add_keys(\&uppage, 'w', 'b', "\cB", "\ev", "\e[5~"); #M-v PgUp add_keys(\&uppage, "\eOy") if $ENV{TERM} eq 'WINANSI'; add_keys(\&to_top, '<', 'g', "\e<", "\e[H", "\e0", "\e[1~"); #M-< Home Home Home add_keys(\&next_file, ':n', "\e[1;4C"); add_keys(\&prev_file, ':p', "\e[1;4D"); add_keys(\&save_mark, 'm', "\e[2~"); #Ins add_keys(\&shift_left, "\e\[1;2D", "\e("); #S-left S-M-9 #Cannot have M-[ for left, \e[ conflicts with other codes add_keys(\&shift_right,"\e\[1;2C", "\e)"); #S-right S-M-0 # Home PgUp PgDn End Ins # terminfo khome kpp knp kend kich1 # eterm \E0y \E0q \E0s # rxvt \E[7~ \E[5~ \E[6~ \E[8~ \e[2~ # # xterm \EOH \E[5~ \E6~ \EOF \e[2~ # #nxterm \e[\C-@ \e[e #"\e\[1;3C"=> #M-left #"\e\[1;3D"=> #M-right $me->add_func(%config, "\e[<" => \&mouse, '/(\d+)/' => 1, #jump to line "\e[D" => \&tab_left, #left "\e[C" => \&tab_right, #right, '&' => \&grep, '/' => \&search, '?' => \&hcraes, "'" => \&goto_mark, '#' => \&toggle_num, #XXX Change toggle* to '-' initiated 'C' => \&toggle_raw, #input mode like : to mimic less? 'S' => \&toggle_fold, 'R' => \&flush_buffer, ':w'=> \&write_buffer, ':e'=> \&open_file, ); #Mise-en-place; prepare to cook some characters #\000-\010\013-\037/@A-HK-Z[\\]^_/ $me->{_raw}->{chr($_)} = chr(64+$_) foreach (0..8, 11..31); $me->{_end} = $me->{rows} - 1; $SIG{WINCH} = sub{ $me->resize() } unless $ENV{TERM} eq 'WINANSI'; $me->{cols}-- if $me->{scrollBar}; #Can we fold? eval "use Text::Wrap"; if( $@ ){ sub wrap{ join '', @_ } $me->{fold} = 0; } $me; } sub resize { my $me = shift; my %dims = get_size(); $dims{rows}--; $dims{cols}-- if $me->{scrollBar}; $me->{$_} = $dims{$_} foreach keys %dims; $me->{_end} = $me->{rows} - 1; if( $me->{fold} ){ $me->reflow(); #XXX Crude attempt to mintain position, #XXX only works if all rows folded same amount #$me->jump( int($me->{_cursor} * $me->{cols) / $dims{cols})-1 ); #XXX need to somehow use _lineNo instead? } else{ $me->refresh(); } $me->status(); $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( $ENV{TERM} eq 'WINANSI' ){ eval{ @dims{'rows','cols'} = Win32::Console::ANSI::Cursor() }; } elsif( `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->{fold} ){ #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; #Automark multi-file $me->{_mark}->{$1} = $i+$me->{_txtN} if defined($F[$i]) && $F[$i] =~ m%\cF\c]\cL\cE \[(\d+)/%; 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(); #XXX if $shown <= $me->{rows}; # + $me->{_cursor}; } sub reflow { my $me = shift; my($prevLine, @text) = 0; while( scalar @{$me->{_text}} ){ my $curLine = shift @{$me->{_lineNo}}; if( $curLine == $prevLine ){ $text[-1] .= ' ' . (shift @{$me->{_text}}||''); } else{ push @text, shift @{$me->{_text}}; } $prevLine = $curLine; } $me->{_lineNo}=[]; $me->{_txtN}=0; $me->add_text( join($/, @text) ); } #Capture errant method calls sub AUTOLOAD{ eval "use Carp"; my $me = shift; our $AUTOLOAD =~ s/.*:://; return if $AUTOLOAD eq 'DESTROY'; local $Text::Wrap::columns=int(.75*$me->{cols}); my $msg = wrap('', '', "$AUTOLOAD\n\n". Carp::longmess()); $me->beep(); $me->dialog("Unknown method $msg", 1); } #$input is pulled outside the subroutine to allow for Esc+x entry of M-x #after the deferring to host loop instead of using a TIGHT input loop my $input; sub more { my $me = shift; my %param = @_; $RT = $me->{RT} = $param{RT}; ReadMode 3; #cbreak $| = 1; if( $me->{_dumb} ){ $me->dumb_mode(); } else{ print $me->{NOR}; #INPUT LOOP, revised with inspiration from Term::Screen::getch() #my $input=''; #TIGHT while( 1 ){ $me->status(); # status line my $exit = undef; my $char = ReadKey($param{RT}); #Defer to host loop, obviating need for callbacks to implement tail #functionality and for cleaner startup (no preload on piped input) #next unless defined($char); #TIGHT return 1 unless defined($char); $me->{_I18N}{prompt} = $input .= $char; $me->status(); unless( ($input=~ /^\e/ and index($me->{_fncRE}, $input)>0 ) || $input =~ /^\d+/ || $input =~ /:+/ || defined($me->{_fnc}->{$input}) ){ $me->beep($input); $input =''; next; } if( $me->{_fnc}->{$input} ){ #Get mapped sub name # use B 'svref_2object'; # my $n = $me->{_fnc}->{$input}; # $n = svref_2object($n)->GV->NAME; $exit = $me->{_fnc}->{$input}->($me); $me->{_I18N}{prompt} = $input = ''; } #vi-style input elsif( $input =~ /^:/ ){ if( ($char eq "\cG") or ($input eq '::') ){ $me->{_I18N}{prompt} = $input = ''; $me->status(); return 1; } } #Line-number input; would love to use getln, but does not mix w/ status elsif( $me->{_fnc}->{'/(\d+)/'} and $input =~ /^\d+/ ){ if( $char eq "\cH" or ord($char)==127 ){ $input = substr($input, 0, -2, ''); } elsif( $char eq "\cG" ){ $input = ''; $exit = 1; } elsif( $char eq "\n" || $char eq "\r" ){ #Remove extraneous characters that could cause infinite error loop #XXX this prevents goofy RPN-like repeated commands $input =~ y/0-9//cd;# chomp($input); $exit = $input < $me->{_txtN} ? $me->jump($input) : $me->to_bott(); $input = ''; } $me->{_I18N}{prompt} = $input; $me->status(); } return 1 if $param{RT} && defined($exit); } } $me->close(); } *less = \&more; *page = \&more; #Avoid 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 visualBell) ){ *{$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_keys{ our %config; my $sub = shift; $config{$_} = $sub foreach @_; } sub add_func{ my $me = shift; my %param = @_; while( my($k, $v) = each %param ){ $me->{_fnc}{$k} = $v; } #XXX RegExp::Trie, List::RegExp? #quotemeta? $me->{_fncRE} = join '|', sort keys %{ $me->{_fnc} }; #$me->{_fncRE} = qr/^($me->{_fncRE})$/; } sub beep{ print "\a"; print $_[0]->{_term}->Tputs('vb') if $_[0]->{visualBell}; if( defined($_[1]) ){ $_[1] =~ s/\e/^[/; $_[1] =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge; #Cook $_[0]->dialog("Unrecognized command: $_[1]", 1); $_[0]->{_I18N}{prompt} = ''; $_[0]->status(); } } sub getln{ my $input; while(1){ my $l = ReadKey(); last if $l eq "\n" || $l eq "\r"; if( !defined($l)| $l eq "\e" || $l eq "\cG" ){ $input = ''; last; } elsif( $l eq "\b" || $l eq "\177" ){ print "\b \b" if $input ne ''; substr($input, -1, 1, ''); next; } print $l; $input .= $l; } return $input; } # display a minihelp, etc sub status{ my $me = shift; $me->{_txtN} ||= 0; my $end= $me->{_cursor} + $me->{rows}; my $pct = $me->{_txtN} > $end ? $end/($me->{_txtN}) : 1; #XXX unify with scrollbar: consistency and as private property 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}{prompt}; print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # bottom left print $me->{_term}->Tputs('ce'); # clear line my $minihelp = $me->{_I18N}{minihelp}; (my $pSansCodes = $p) =~ s/\e\[[\d;]*[a-zA-Z]//g; my $pN = $me->{cols} -1 -length($pSansCodes) -length($me->{_I18N}{minihelp}); $p .= ' ' x ($pN > 1 ? $pN : 1); $minihelp = $pN>2 ? $minihelp : do {$minihelp =~ s/\000.+//; $minihelp }; print $me->{REV}; # reverse video print $p," ", $minihelp; # status line print $me->{NOR}; # normal video } sub close{ ReadMode 0; print "\n\e[?1000l"; $| = $SP || 0; #Did we exit via signal or user? $RT ? die : return \"foo"; } { no warnings 'once'; *done = \&close; } # 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 max_width{ my $me = shift; my $width = 0; foreach (@_){ $width = length($_) if length($_) > $width }; return $width; } sub dialog{ my($me, $msg, $timeout) = @_; my @txt = defined($msg) ? split(/\n/, $msg) : (); my $w = $me->max_width(@txt); #Prepare dialog my $h = '+' . '='x($w+2) . '+'; my $d = join('', map { sprintf("%s| %- @{[$w+4]}s |\n", $me->{_term}->Tgoto('RI',0,4), $_) } $h, @txt, $h); print $me->{_term}->Tgoto('cm',0, 2), # move $me->{MENU}, # set color $d, # dialog $me->{NOR}; # normal color defined($timeout) ? sleep($timeout) : getc(); #Allow wipe of incomplete/paused output. local($me->{pause}); #XXX Use full refresh if _grep for simple accurate solution? # Fractional restoration instead of full refresh foreach my $n (2 .. scalar(@txt)+3){ print $me->{_term}->Tgoto('cm', 0, $n); # move print $me->{_term}->Tputs('ce'); # clear line $me->line($n); } } sub flush_buffer{ my $me = shift; $me->{_text} = []; $me->{_txtN} = 0; $me->{_lineNo}=[]; $me->refresh(); } # 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 #Skip cursor ahead to matching line if in grep mode if( $me->{_grep} && defined($me->{_text}->[$me->{_cursor}+$n]) ){ until( $me->{_text}->[$me->{_cursor}+$n] =~ m%$me->{_search}|\cF\c]\cL\cE \[\d+/% ){ $me->{_cursor}++; last if $me->{_cursor}+$me->{rows}+$n >= $me->{_txtN}; } } $me->line($n+$me->{_cursor}) if # XXX w/o cursor messy $me->{_cursor}+$me->{rows}+$n <= $me->{_txtN} # after menu & refresh } $me->scrollBar() if $me->{scrollBar}; } sub scrollBar{ my $me = shift; $me->{_pages} = $me->{_txtN}/$me->{rows}; $me->{_thumbW} = $me->{rows}/$me->{_pages}; $me->{_thumbT} = sprintf("%i", ($me->{_cursor} / $me->{_pages}) )+($me->{_cursor}>$me->{_txtN}/2); $me->{_thumbB} = sprintf("%i", $me->{_thumbT}+$me->{_thumbW}); #$me->dialog("cursor $me->{_cursor} top $me->{_thumbT} + width $me->{_thumbW}"); for my $n (0 .. $me->{rows} -1){ print $me->{_term}->Tgoto('cm', $me->{cols}+1, $n); print $n>=$me->{_thumbT} && $n<$me->{_thumbB} ? ' ' : "$me->{REV} $me->{NOR}"; } } sub mouse{ my $me = shift; my $input =''; $input .= ReadKey(0) until $input =~ /M$/i; my @args = split /;/, $input; if( $args[0] == 65 ){ $me->downhalf(); } elsif( $args[0] == 64 ){ $me->uphalf(); } elsif( $me->{scrollBar} && $args[1] == $me->{cols}+1 ){ if( chop $args[2] eq 'm'){ #mouse-up if( $me->{_thumbDrag} ){ $me->{_thumbDrag} = 0; my $pos; if( $args[2]==1 ){ $pos=0 } elsif( $args[2]==$me->{rows} ){ $pos= $me->{_txtN} - 2*$me->{rows}-1 } else{ $pos = sprintf("%i", $args[2] / $me->{rows} * $me->{_txtN}) } $me->jump($pos); } $me->uppage() if $args[2] < $me->{_thumbT}; $me->downpage() if $args[2] > $me->{_thumbB}; } elsif( $args[2]>=$me->{_thumbT} && $args[2]<=$me->{_thumbB} ){ #automagically M (mouse-down) $me->{_thumbDrag}=1; } } } sub line{ my $me = shift; my $n = shift; local $_ = $me->{_text}[$n]||''; # my $prev = $me->{_text}[$n-1]||''; #!! ORDER OF OPERATIONS ON OUTPUT PROCESSING AND DECORATION MATTERS # #Squeeze... this identifies lines, but just gives a blank line, still # code elsewhere iterates over rows and advances down screen... # we need to intervene in each of those instances and: # not progress another line of display then add another iteration # return if $me->{squeeze} && $_ eq '' && $prev eq ''; $me->{_curFile} = $1 if m%\cF\c]\cL\cE \[(\d+)/%; #Breaks? my $pausey = 1 if length($me->{pause}) && defined && /$me->{pause}/; #Crop if no folding my $len = length(); unless( $me->{fold} ){ $_ = ($len-$me->{_statCols}) < $me->{_left} ? '' : substr($_, $me->{_left}, $me->{cols}-$me->{_statCols}); if( $len - $me->{_left} > $me->{cols} ){ substr($_, -1, 1, "\$"); } } #Cook control characters unless( $me->{raw} ){ s/([\000-\010\013-\037])/$me->{REV}^$me->{_raw}->{$1}$me->{NOR}/g; } #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->{fold} ? ($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( $pausey ){ $me->{_end} = $n; #Advance past pause no warnings 'exiting'; last; } } sub down_lines{ my $me = shift; my $n = shift; my $t = $me->{_term}; LINE: for(1..$n){ if( $me->{_end} >= $me->{_txtN}-1 ){ $me->close() if $me->{eof} && ref($me->{text}) ne 'CODE'; if( ref($me->{text}) eq 'CODE' ){ $me->add_text( $me->{text}->() ); } else{ &beep; last; } } #Two blocks instead of an else to allow input callback if( $me->{_end} < $me->{_txtN}-1 ){ 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 #Skip cursor ahead to matching line if in grep mode if( $me->{_grep} && $me->{_end} < $me->{_txtN} ){ until( $me->{_text}->[$me->{_end}] =~ m%$me->{_search}|\cF\c]\cL\cE \[\d+/% ){ $me->dialog(#"$me->{_end} >= $me->{_txtN} #$me->{_cursor}\n". 'Pagination in grep mode does not work at this time.', 1); last LINE; # $me->{_end}++; $me->{_cursor}++; if( $me->{_end} >= $me->{_txtN} ){ $me->{cursor} = $me->{_end} = $me->{_txtN}; last; } } } $me->line( ++$me->{_end} ) if $me->{_end} <= $me->{_txtN}; $me->{_cursor}++; } } $me->refresh() if $ENV{TERM} eq 'WINANSI'; #XXX Windows scroll is lame $me->scrollBar() if $me->{scrollBar}; } sub downhalf { $_[0]->down_lines( $_[0]->{rows} / 2 ); } sub downpage { $_[0]->down_lines( $_[0]->{rows} ); #WTF?! add_text in tp's while-loop cannot be reached if there's #no delay here until something other than downpage is called?! select(undef, undef, undef, .1); #XXX WTF?! } sub downline { $_[0]->down_lines( 1 ); } #Term::ReadKey doesn't offer sufficiently fine control; we want CS8 but -OCRNL sub downline_raw { $_[0]->down_lines( 1 ); $_[0]->refresh(); } 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 #XXX Skip cursor back to matching line if in grep mode #Skip cursor back to matching line if in grep mode # if( $me->{_grep} && $me->{_cursor} > 0 ){ # until( $me->{_text}->[$me->{_end}] =~ # m%$me->{_search}|\cF\c]\cL\cE \[\d+/% ){ # $me->{_cursor}--; # if( $me->{_cursor} <= 0 ){ # $me->{cursor} = 0; # last; # } # } # } $me->line( --$me->{_cursor} ); $me->{_end}--; } } $me->refresh() if $ENV{TERM} eq 'WINANSI'; #XXX Windows scroll is lame print $me->{_term}->Tgoto('cm',0,$me->{rows}); # goto bottom $me->scrollBar() if $me->{scrollBar}; } 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; if( $me->{rows}>$me->{_txtN} ){ $me->jump( 0 ) } else{ $me->jump( $me->{_txtN}-1 ); $me->uppage() } } sub save_mark{ my $me = shift; $me->I18N('status', $me->{BLD}.'*Mark name?*'.$me->{NOR}.$me->{REV}); $me->status(); $me->{_term}->Tgoto('cm', #XXX I18N length('[tp] 100% Bottom Mark name?')+1, $me->{rows}); my $mark = ReadKey(); return if $mark eq "\cG"; next if $mark eq "'"; $me->{_mark}->{$mark} = $me->{_cursor}; $me->I18N('status', ''); $me->status(); } sub goto_mark{ my $me = shift; my $mark = ReadKey(); return if $mark eq "\cG" or not exists($me->{_mark}->{$mark}); my $jump = $me->{_mark}->{$mark}; if( $mark eq '^' ){ $jump = 0; } elsif( $mark eq '$' ){ $jump = $me->{_txtN} - $me->{rows}; } elsif( $mark eq '"' ){ my $marks = join("\n", map {"$_ = $me->{_mark}->{$_}"} sort keys %{ $me->{_mark} } ); $me->dialog($marks); return; } $me->{_mark}->{"'"} = $me->{_cursor}; $me->jump( $jump ); } sub prev_file{ $_[0]->next_file('anti') } sub next_file{ my $me = shift; my $mode = shift || ''; my $mark = $me->{_curFile} + ( $mode eq 'anti' ? -1 : 1 ); if( exists($me->{_mark}->{$mark}) ){ $me->{_mark}->{"'"} = $me->{_cursor}; $me->jump( $me->{_mark}->{$mark} ); } else{ $me->beep() } } sub jump{ my $me = shift; $me->{_cursor} = shift; $me->{_end} = $me->{_cursor} + $me->{rows}; # - 1; $me->refresh(); } sub tab_right{ my $me = shift; $me->{_left} += 8; $me->refresh(); } sub tab_left{ my $me = shift; $me->{_left} = 0 if ($me->{_left} -= 8) < 0; $me->refresh(); } sub shift_right{ my $me = shift; $me->{_left} += int($me->{cols}/2); $me->refresh(); } sub shift_left{ my $me = shift; $me->{_left} = 0 if ( $me->{_left} -= int($me->{cols}/2) ) < 0; $me->refresh(); } sub grep{ $_[0]->search(-1); } sub hcraes{ $_[0]->search(1); } sub search{ my $me = shift; my $mode = shift || 0; $me->{_hcraes} = $mode == 1; $me->{_grep} = $mode == -1; $me->{_searchWrap} = 0 unless $me->{_grep}; # 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 $mode ? ( $mode > 0 ? '?' : '&' ) : '/'; $me->{_search} = $me->getln() || ''; print $me->{NOR}; # normal color print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # move bottom print $me->{_term}->Tputs('ce'); # clear line if( $me->{_search} eq '' ){ $me->refresh(); return; } $me->{_search} = '(?i)'.$me->{_search} unless $me->{_search} ne lc($me->{_search}); $me->{_search} = $prev if $me->{_search} eq '/' && $prev; #Jump to first match 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}; } if( $me->{_searchWrap} ){ $me->{_searchWrap} = 0; $me->jump( $mode ? $me->{_txtN} : 0 ); } 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; } if( ($i == ($mode ? 0 : $me->{_txtN} )) && ($me->{_searchWrap} == 0) ){ $me->dialog($me->I18N('searchwrap'), 1); $me->{_searchWrap} = 1; return; } $matched ? $me->jump($i) : &beep; } sub toggle_num{ my $me = shift; $me->{lineNo} = not $me->{lineNo}; # $me->reflow(); $me->refresh(); } sub toggle_raw{ my $me = shift; $me->{raw} = not $me->{raw}; $me->reflow(); } sub toggle_fold{ my $me = shift; $me->{fold} = not $me->{fold}; $me->{_lineNo} = [1 .. $me->{_txtN}] if $me->{fold}; $me->reflow(); } sub write_buffer{ my $me = shift; print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # move bottom print $me->{_term}->Tputs('ce'); # clear line print "Save to: "; my $out = $me->{_search} = $me->getln(); if( ! -e $out && open(OUT, '>', $out) ){ print OUT join($/, @{$me->{_text}}); CORE::close(OUT); } else{ $me->dialog("ERROR: " . -e $out ? "File exists" : $!) } } sub open_file{ my $me = shift; print $me->{_term}->Tgoto('cm', 0, $me->{rows}); # move bottom print $me->{_term}->Tputs('ce'); # clear line print "Examine: "; my $file = $me->getln(); unless( -e $file ){ $me->dialog( sprintf("%s: $file", $me->{_I18N}{404}) ); return; } unless( open(IN, '<', $file) ){ $me->dialog($!); return; } my $N = $me->get_fileN(); $me->set_fileN($N+1); $me->add_text(sprintf("======== \cF\c]\cL\cE [%i/..] %s ========\n", $N, $file), ); } sub get_fileN{ $_[0]->{_fileN} } sub set_fileN{ $_[0]->{_fileN} = $_[1] } 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; __DATA__ WINANSI|vt220|Win32 Console based on DEC VT220 in vt100 emulation mode: am:mi:xn:xo: co#80:li#24: RA=\E[?7l:SA=\E[?7h: ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0: bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH: cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B: ei=\E[4l:ho=\E[H:im=\E[4h: is=\E[1;24r\E[24;1H: nd=\E[C: kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H: mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m: kb=\0177: r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8: sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I: ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: vb=\E7\E[?5h\E[?5l\E[?5h\E[?5l\E[?5h\E[?5l\E[?5h\E[?5l\E8: __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 expect using 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 L 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 L 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 Fold long lines with L. =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 =item B<--scrollbar> Display an interactive scrollbar in the right-most column. =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 visualBell set? $t->visualBell(); #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. =head3 Callback You can also pass a code reference to the I attribute of the constructor which will be called when reaching the "end of file"; consequently, it is not possible to set the I flag to exit at end of file if doing so. $t->new( text=>sub{ } ); #eof=>0 is implied Alternatively, you may supply a reference to a two element array. The first is an initial chunk of text to load, and the second the callback. #Fibonacci my($m, $n)=(1,1); $t->new( text=> ["1\n", sub{ ($m,$n)=($n,$m+$n); return "$n\n"} ] ); =head2 User Interface There are multiple special bookmarks (marks) that can be used in navigation. =over 4 =item ^ Beginning of file =item $ End of file =item ' Previous location =item " List user-created marks =back C will automatically create special numeric marks when it encounters a special character sequence, allowing the user to jump to predetermined points in the buffer. Sequence that match the following regular expression /\cF\c]\cL\cE \[(\d+)\// #e.g; ^F^]^L^E [3/4] will have marks matching $1 created that point at the line of the buffer the sequence occurs on. =head1 CUSTOMIZATION =head2 add_func 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 mappings are listed below, and lengthier descriptions are available in L. =head3 General =over =item &help - C or C =item &close - C or C or C<:q> or C<:Q> =item &refresh - C or C or C =item &flush_buffer - C =item &write_buffer - C<:w> =item &open_file - C<:e> =back =head3 Navigation =over =item &downline - C or C or C or C or C or C or C =item &downhalf - C or C =item &downpage - C C or C or C or C or C or C =item &uppage - C or C or C or C or C =item &uphalf - C or C =item &upline - C or C or C or C or C or C or C or C =item &to_bott - C or C<$> or C> or C> or C =item &to_top - C or C> or C> =item &tab_left - C =item &shift_left - C =item &tab_right - C =item &shift_right - C =item &next_file - C<:n> or C =item &prev_file - C<:p> or C =back And a special sequence of a number followed by enter analogous to: '/(\d+)/' => \&jump(\1) if the value for that key is true. =head3 Bookmarks =over =item &save_mark - C or C =item &goto_mark - C<'> =back =head3 Search =over =item &search - / =item &hcraes - ? =item &next_match - n or P =item &prev_match - p or N =item &grep - & =back =head3 Options =over =item &toggle_num - # =item &toggle_fold - S =item &toggle_raw - C =back =head2 I18N 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('minihelp', " help"); Current text elements available for customization are: 404 - search text not found dialog continue - text to display at the bottom of the help dialog help - help dialog text, a list of keys and their functions minihelp - basic instructions displayed at the bottom of the screen status - brief message to include in the status line top - start of file prompt bottom - end of file prompt searchwrap - message that pager is about to loop for more matches 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 a 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. I is not available on Windows. You will need to manually refresh your screen B<^L> if you resize the terminal in Windows to clean up the text however, this will not change the size of the pager itself. =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-2.10/lib/IO/Pager/tp0000755400215440010010000001744113750553361016614 0ustar jpierceNMRGROUP+Group(513)#!/usr/local/bin/perl use strict; use warnings; use IO::Pager::Perl; use Term::ReadKey; use Getopt::Long; use vars '$VERSION'; $VERSION = '2.10'; #Untouched since 2.10 my %Opts = (fold=>1); (my $LESS = $ENV{LESS} || '') =~ s/P.+(?:\$|$)//; $Opts{eof} = 1 if $LESS =~ /e/; $Opts{statusCol} = 1 if $LESS =~ /J/; $Opts{lineNo} = 1 if $LESS =~ /N/; $Opts{raw} = 1 if $LESS =~ /r/; $Opts{squeeze} = 1 if $LESS =~ /s/; $Opts{fold} = 0 if $LESS =~ /S/; $Opts{pause} = "\cL" if defined($ENV{MORE}) && $ENV{MORE} =~ /l/; @ARGV = (map('-'.$_, split(//, $ENV{TPOPT})), @ARGV) if defined($ENV{TPOPT}); my %Long; #Custom argument processing { no warnings 'uninitialized'; ($Long{jump} = (grep { /^\+\d+$/ } @ARGV)[-1]) =~ s/^\+//; ($Long{search} = (grep { /^\+\// } @ARGV)[-1]) =~ s%\+/=%%; } @ARGV = grep { $_ !~ /^[-+]\d+$|^\+\// } @ARGV; Getopt::Long::Configure("no_ignore_case"); GetOptions(\%Long, (map { "$_!" } split//, 'JSenrs'), # bare (map { "$_=s" } qw'j p cols'), # args ##rows 'f:s', qw/tail|$ scrollbar|[/ ); $Long{f} = "\cL" if defined($Long{f}) && $Long{f} eq ''; $Long{tail} = $Long{tail} && scalar(@ARGV) == 1 ? 1 : 0; $Opts{eof} = $Long{e} if defined($Long{e}); $Opts{statusCol} = $Long{J} if defined($Long{J}); $Opts{pause} = $Long{f} if defined($Long{f}); $Opts{lineNo} = $Long{n} if defined($Long{n}); $Opts{raw} = $Long{r} if defined($Long{r}); $Opts{squeeze} = $Long{s} if defined($Long{s}); #$Opts{rows} = $Long{rows} if defined($Long{rows}); $Opts{cols} = $Long{cols} if defined($Long{cols}); $Opts{fold} = not $Long{S} if defined($Long{S}); $Opts{jump} = ($Long{j}||$Long{jump}) if defined($Long{j})||defined($Long{jump}); $Opts{search} = $Long{p}||$Long{search} if defined($Long{p})||defined($Long{search}); $Opts{scrollBar} = $Long{scrollbar} if defined($Long{scrollbar}); #use Data::Dumper; print Dumper \%Opts; exit 0; my $t = IO::Pager::Perl->new(%Opts); my($PIPE, $FILE, @F, $prevsize); if( -t STDIN ){ if( scalar(@ARGV) == 1){ #Tail comes first because clobbers @ARGV if( $Long{tail} ){ open($FILE, '<', $ARGV[0]) or die $!; seek($FILE, 0, 2); $prevsize = tell($FILE) } @F = } else{ #Current multi-file implementation gives us continuous numbering #Dead-simple option slurs everything together # $t->add_text( ); my $i=1; foreach my $file ( @ARGV ){ my $err=''; open(FILE, '<', $file) or $err=$!; push @F, sprintf("======== \cF\c]\cL\cE [%i/%i] %s ========%s\n", $i++, $#ARGV+1, $file, $err), ; $F[-1] .= $/ unless $F[-1] =~ /\n$/; close(FILE); $t->set_fileN($i); } } $t->add_text(@F); } else{ #Separate piped input from keyboard input open($PIPE, '<&=STDIN' ) or die $!; close(STDIN); open(STDIN, '<', '/dev/tty') or die $!; } eval{ $t->jump($Opts{jump}) if $Opts{jump}; while( $t->more(RT=>.05) ){ my $X; if( defined($PIPE) ){ $t->add_text($X) if sysread($PIPE, $X, 1024); } elsif( $Long{tail} ){ my $cursize = -s $FILE; if( $cursize > $prevsize ){ $t->add_text($X) if sysread($FILE, $X, $cursize-$prevsize); $prevsize = $cursize; $t->scrollbar() if $t->{scrollBar}; } } } }; __END__ =pod =head1 NAME tp - a pure perl pager =head1 SYNOPSIS tp -[JSenrs] [-cols] [-f STR] [-j|+ #] [-p|+/ STR] [FILE]... =head1 OPTIONS =over 4 =item B<-e> Exit at end of file. =item B<-f STR> If defined, the pager will pause when the character sequence specified by STR is encountered in the input text. The default value when enabled is formfeed i.e; ^L; in order to mimic traditional behavior of L, but due to the pecularities of L> you need to use the -- argument separator in order to to trigger this e.g; tp -f -- foo #pauses on lines in foo with "^L" in them You might also supply a regular expression as STR e.g; tp -f '[ie]t' bar #pauses on lines in bar with "it" or "et" in them =item B<-J> Add a column with markers indicating which lines match a search expression. =item B<-n> Display line numbering. Toggleable at run time with I<#>. =item B<-r> Send raw 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 B<-s> Squeeze multiple blank lines into one. =item B<-S> Do not fold long lines. =item B<-[> or B<--scrollbar> Display an interactive scrollbar in the right-most column. =item B<-$> or B<--tail> Keep checking the displayed file for new content. Only available when paging a single file. =cut #=item B<-rows> Set the number of rows for the pager. If absent, the terminal is queried directly with L if loaded or C or C, and if these fail it defaults to 25. =pod =item B<--cols> Set the number of columns for the pager. If absent, the terminal is queried directly with L if loaded or C or C, and if these fail it defaults to 80. =back =head1 User Interface C is Control, C is Meta/Alt, C is Shift, and C<\d+> is a sequence of digits =head2 General =over =item help - C or C =item close - C or C or C<:q> or C<:Q> =item refresh - C or C or C =item flush buffer - C =item save buffer - C<:w> =item open file - C<:e> =back =head2 Navigation =over =item down one line - C or C or C or C or C or C or C =item down half page - C or C =item down one page - C C or C or C or C or C or C =item up one page - C or C or C or C or C =item up half page - C or C =item up one line - C or C or C or C or C or C or C or C =item to bottom - C or C<$> or C> or C> or C =item to top - C or C> or C> =item left one tab - C =item left half screen - C =item right one tab - C =item right half screen - C =item jump to line number - C<\d+> =item next file - C<:n> or C =item previous file - C<:p> or C =back =head3 Bookmarks =over =item Save mark - C or C =item Goto mark - C<'> =item Special mark: Beginning of file - C<^> =item Special mark: End of file - C<$> =item Special mark: Previous location - C<'> =item Special mark: List user-created marks - C<"> =item Special mark: C<\d> - Top of file \d when viewing multiple files =back =head2 Search =over =item forward - / =item backward - ? =item next match - n or P =item previous match - p or N =item grep (show only matching lines) - & =back =head1 Options =over =item toggle line-numbering - # =item toggle folding - S =item toggle raw/cooked output - C =back =head1 ENVIRONMENT tp checks the I, I, I, I and I variables. The I variable is used to set options explicitly for tp, by concatenating undecorated options together e.g; Sr for squished raw output. I and I are checked for options that tp supports, and if detected they are enabled. =head1 SEE ALSO L, L =head1 AUTHORS Jerrad Pierce jpierce@cpan.org =head1 LICENSE =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-2.10/lib/IO/Pager/Unbuffered.pm0000644400215440010010000000577213671706263020675 0ustar jpierceNMRGROUP+Group(513)package IO::Pager::Unbuffered; our $VERSION = 1.04; #Untouched since 1.02 use strict; use warnings; 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-2.10/lib/IO/Pager.pm0000644400215440010010000003640613750553401016576 0ustar jpierceNMRGROUP+Group(513)package IO::Pager; our $VERSION = "2.10"; #Untouched since 1.03 use 5.008; #At least, for decent perlio, and other modernisms use strict; use warnings; use base qw( Tie::Handle ); use Env qw( PAGER ); use File::Spec; use PerlIO; use Symbol; use overload '+' => "PID", bool=> "PID"; our $SIGPIPE; #use Carp; $SIG{__WARN__} = sub{ print STDERR @_, Carp::longmess(),"\n\n"; }; sub find_pager { # Return the name (or path) of a pager that IO::Pager can use my $io_pager; #Permit explicit use of pure perl pager local $_ = 'IO::Pager::less'; return $_ if (defined($_[0]) && ($_[0] eq $_)) or (defined($PAGER) && ($PAGER eq $_)); # Use File::Which if available (strongly recommended) my $which = eval { require File::Which }; # Look for pager in PAGER first if ($PAGER) { # Strip arguments e.g. 'less --quiet' my ($pager, @options) = (split ' ', $PAGER); $pager = _check_pagers([$pager], $which); $io_pager = join ' ', ($pager, @options) if defined $pager; } # Then search pager amongst usual suspects if (not defined $io_pager) { my @pagers = ('/etc/alternatives/pager', '/usr/local/bin/less', '/usr/bin/less', '/usr/bin/more'); $io_pager = _check_pagers(\@pagers, $which) } # Then check PATH for other pagers if ( (not defined $io_pager) && $which ) { my @pagers = ('less', 'most', 'w3m', 'lv', 'pg', 'more'); $io_pager = _check_pagers(\@pagers, $which ); } # If all else fails, default to more (actually IO::Pager::less first) $io_pager ||= 'more'; return $io_pager; } sub _check_pagers { my ($pagers, $which) = @_; # Return the first pager in the list that is usable. For each given pager, # given a pager name, try to finds its full path with File::Which if possible. # Given a pager path, verify that it exists. my $io_pager = undef; for my $pager (@$pagers) { # Get full path my $loc; if ( $which && (not File::Spec->file_name_is_absolute($pager)) ) { $loc = File::Which::which($pager); } else { $loc = $pager; } # Test that full path is valid (some platforms don't do -x so we use -e) if ( defined($loc) && (-e $loc) ) { $io_pager = $loc; last; } } return $io_pager; } #Should have this as first block for clarity, but not with its use of a sub BEGIN { # Set the $ENV{PAGER} to something reasonable our $oldPAGER = $PAGER || ''; $PAGER = find_pager(); if( ($PAGER =~ 'more' and $oldPAGER ne 'more') or $PAGER eq 'IO::Pager::less' ){ my $io_pager = $PAGER; eval "use IO::Pager::less"; $PAGER = $io_pager if $@ or not defined $PAGER; } } #Factory sub open(*;$@) { # FH, [MODE], [CLASS] my $args = {procedural=>1}; $args->{mode} = splice(@_, 1, 1) if scalar(@_) == 3; $args->{subclass} = pop if scalar(@_) == 2; &new(undef, @_, $args); } #Alternate entrance: drop class but leave FH, subclass sub new(*;$@) { # FH, [MODE], [CLASS] shift; my %args; if( ref($_[-1]) eq 'HASH' ){ %args = %{pop()}; #warn "REMAINDER? (@_)", scalar @_; push(@_, $args{procedural}); } elsif( defined($_[1]) ){ $args{mode} = splice(@_, 1, 1) if $_[1] =~ /^:/; $args{subclass} = pop if exists($_[1]); } #Leave filehandle in @_ for pass by reference to allow gensym $args{subclass} ||= 'IO::Pager::Unbuffered'; $args{subclass} =~ s/^(?!IO::Pager::)/IO::Pager::/; eval "require $args{subclass}" or die "Could not load $args{subclass}: $@\n"; my $token = $args{subclass}->new(@_); if( defined($args{mode}) ){ $args{mode} =~ s/^\|-//; $token->BINMODE($args{mode}); } return $token; } sub _init{ # CLASS, [FH] ## Note reversal of order due to CLASS from new() #Assign by reference if empty scalar given as filehandle $_[1] = gensym() if !defined($_[1]); no strict 'refs'; $_[1] ||= *{select()}; # Are we on a TTY? STDOUT & STDERR are separately bound if ( defined( my $FHn = fileno($_[1]) ) ) { if ( $FHn == fileno(STDOUT) ) { die '!TTY' unless -t $_[1]; } if ( $FHn == fileno(STDERR) ) { die '!TTY' unless -t $_[1]; } } #XXX This allows us to have multiple pseudo-STDOUT #return 0 unless -t STDOUT; return ($_[0], $_[1]); } # Methods required for implementing a tied filehandle class sub TIEHANDLE { my ($class, $tied_fh) = @_; unless ( $PAGER ){ die "The PAGER environment variable is not defined, you may need to set it manually."; } my($real_fh, $child, $dupe_fh); # XXX What about localized GLOBs?! # if( $tied_fh =~ /\*(?:\w+::)?STD(?:OUT|ERR)$/ ){ # open($dupe_fh, '>&', $tied_fh) or warn "Unable to dupe $tied_fh"; # } do{ no warnings; $child = CORE::open($real_fh, '|-', $PAGER) }; if ( $child ){ my @oLayers = PerlIO::get_layers($tied_fh, details=>1, output=>1); my $layers = ''; for(my $i=0;$i<$#oLayers;$i+=3){ #An extra base layer requires more keystrokes to exit next if $oLayers[$i] =~ /unix|stdio/ && !defined($oLayers[+1]); $layers .= ":$oLayers[$i]"; $layers .= '(' . ($oLayers[$i+1]) . ')' if defined($oLayers[$i+1]); } CORE::binmode($real_fh, $layers); } else{ die "Could not pipe to PAGER ('$PAGER'): $!\n"; } return bless { 'real_fh' => $real_fh, # 'dupe_fh' => $dupe_fh, 'tied_fh' => "$tied_fh", #Avoid self-reference leak 'child' => $child, 'pager' => $PAGER, }, $class; } sub BINMODE { my ($self, $layer) = @_; if( $layer =~ /^:LOG\((>{0,2})(.*)\)$/ ){ CORE::open($self->{LOG}, $1||'>', $2||"$$.log") or die $!; } else{ CORE::binmode($self->{real_fh}, $layer||':raw'); } } sub WNOHANG(); sub EOF { my $self = shift; unless( defined($SIGPIPE) ){ eval 'use POSIX ":sys_wait_h";'; $SIGPIPE = 0; } $SIG{PIPE} = sub { $SIGPIPE = 1 unless $ENV{IP_EOF}; CORE::close($self->{real_fh}); waitpid($self->{child}, WNOHANG); CORE::open($self->{real_fh}, '>&1'); close($self->{LOG}); }; return $SIGPIPE; } sub PRINT { my ($self, @args) = @_; CORE::print {$self->{LOG}} @args if exists($self->{LOG}); CORE::print {$self->{real_fh}} @args or die "Could not print to PAGER: $!\n"; } sub PRINTF { my ($self, $format, @args) = @_; $self->PRINT(sprintf($format, @args)); } sub say { my ($self, @args) = @_; $args[-1] .= "\n"; $self->PRINT(@args); } sub WRITE { my ($self, $scalar, $length, $offset) = @_; $self->PRINT(substr($scalar, $offset||0, $length)); } sub TELL { #Buffered classes provide their own, and others may use this in another way return undef; } sub FILENO { CORE::fileno($_[0]->{real_fh}); } sub CLOSE { my ($self) = @_; CORE::close($self->{real_fh}); # untie($self->{tied_fh}); # *{$self->{tied_fh}} = *{$self->{dupe_fh}}; } { no warnings 'once'; *DESTROY = \&CLOSE; } #Non-IO methods sub PID{ my ($self) = @_; return $self->{child}; } #Provide lowercase aliases for accessors foreach my $method ( qw(BINMODE CLOSE EOF PRINT PRINTF TELL WRITE PID) ){ no strict 'refs'; *{lc($method)} = \&{$method}; } 1; __END__ =pod =head1 NAME IO::Pager - Select a pager (possibly perl-based) & pipe it text if 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 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-2020 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-2.10/Makefile.PL0000644400215440010010000000264713750405520016075 0ustar jpierceNMRGROUP+Group(513)use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my @WINANSI = $^O =~ /MSWin/ ? ('Win32::Console::ANSI'=>0) : (); WriteMakefile( 'MIN_PERL_VERSION' => 5.8.0, '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, }, EXE_FILES => [ 'lib/IO/Pager/tp' ], META_MERGE => { "meta-spec" => { version => 2 }, runtime => { recommends => { @WINANSI # '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 ', ) : ()), ); IO-Pager-2.10/MANIFEST0000755400215440010010000000151213667227444015263 0ustar jpierceNMRGROUP+Group(513)CHANGES 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 eg/fib eg/foldable.txt eg/pauses.txt 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-2.10/META.json0000755400215440010010000000303713750640046015545 0ustar jpierceNMRGROUP+Group(513){ "abstract" : "Select a pager (possibly perl-based) & pipe it text if a TTY", "author" : [ "Jerrad Pierce , Florent Angly " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, 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", "perl" : "5.008000" } } }, "release_status" : "stable", "version" : "2.10", "x_runtime" : { "recommends" : { "Win32::Console::ANSI" : 0 } }, "x_serialization_backend" : "JSON::PP version 4.04" } IO-Pager-2.10/META.yml0000755400215440010010000000164413750640043015374 0ustar jpierceNMRGROUP+Group(513)--- abstract: 'Select a pager (possibly perl-based) & pipe it text if 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.44, 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' perl: '5.008000' version: '2.10' x_runtime: recommends: Win32::Console::ANSI: 0 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IO-Pager-2.10/README0000644400215440010010000000444413750406171015003 0ustar jpierceNMRGROUP+Group(513)IO::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 called tp. 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 Term::ReadKey is also require for IO::Pager::less, IO::Pager::Perl and tp. Win32::Console::ANSI, included in some distributions of Win32 perl like Strawberry is recommended on Windows for IO::Pager::less et al. to function. 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 IO::Pager::Perl - Jerrad Pierce & Jeff Weisberg, Perl Artistic License All Else - Copyright (C) 2003-2020 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-2.10/t/0000755400215440010010000000000013750640042014355 5ustar jpierceNMRGROUP+Group(513)IO-Pager-2.10/t/01-load.t0000644400215440010010000000043513077761440015711 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/02-which.t0000644400215440010010000000232713077761440016077 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/02-which_interactive.t0000644400215440010010000000070513077763111020467 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/03-bald_interactive.t0000644400215440010010000000200413077763176020275 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/04-buffered_interactive.t0000644400215440010010000000244713671036771021163 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/05-binmode_interactive.t0000644400215440010010000000202113671143275021001 0ustar jpierceNMRGROUP+Group(513)use 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'; print BOB "Unicode Z-inverted carat: \x{17D}\n"; #Ž print BOB "Unicode Copyright < Copyleft: \x{A9} < \x{2184}\x{20DD}\n"; #© < ↄ⃝ print BOB "Unicode camel: \x{1f42a}\n"; # 🐪 print 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-2.10/t/06-scalar_interactive.t0000644400215440010010000000133113077763250020636 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/07-oo_interactive.t0000644400215440010010000000230313747617517020017 0ustar jpierceNMRGROUP+Group(513)use strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test OO interface SKIP: { skip_interactive(); use blib; 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-2.10/t/08-redirect.pl0000644400215440010010000000465312021541465016747 0ustar jpierceNMRGROUP+Group(513)our $txt = <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/; my $blib = -e "blib" ? '-Mblib' : ''; system qq("$^X" $blib -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-2.10/t/09-open.t0000644400215440010010000000107513666747101015746 0ustar jpierceNMRGROUP+Group(513)use strict; use warnings; use File::Spec; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); 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-2.10/t/10-close_interactive.t0000644400215440010010000000244513357534232020475 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/11-redirect-oo.pl0000644400215440010010000000015513356650311017350 0ustar jpierceNMRGROUP+Group(513)use blib; use IO::Pager; our $txt; require './t/08-redirect.pl'; my $FH = new IO::Pager; $FH->print($txt); IO-Pager-2.10/t/11-redirect-oo.t0000644400215440010010000000174613666744353017225 0ustar jpierceNMRGROUP+Group(513)use 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($slurp, 'eq', $txt, '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-2.10/t/12-preservelayers_interactive.t0000644400215440010010000000127513077763312022447 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/13-eof_interactive.t0000644400215440010010000000074513077763320020146 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/14-tee_interactive.t0000644400215440010010000000150713356726126020153 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/15-log_interactive.t0000644400215440010010000000140313356732264020153 0ustar jpierceNMRGROUP+Group(513)use 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-2.10/t/16-PurePerl_interactive.t0000644400215440010010000000225413750574250021133 0ustar jpierceNMRGROUP+Group(513)use strict; use warnings; use Test::More 0.88; require './t/TestUtils.pm'; t::TestUtils->import(); # Test OO interface SKIP: { skip_interactive(); skip("Windows is currently unsupported") if $^O =~ /MSWin32/; use blib; $ENV{PERL5OPT} = '-Mblib'; $ENV{TPOPT} = '['; 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'; #XXX No longer needed with return of control to host loop instead of #XXX repeating input loop, but cannot hurt to preserve the instructions warn "\n\nCurrent IO::Pager::Less is suboptimal \e[7;5m*** Press Ctrl-L to refresh ***\e[0m\n\n\n"; #XX $BOB->{scrollBar}=1; $BOB->print("This pager is implemented in perl. Note the nifty scrollbar at right.\n") foreach 1..250; $BOB->print("\nEnd of text, try pressing 'Q' to exit.\n"); } select STDERR; my $A1 = prompt("\nDid you see 'This pager is implemented in perl' in a pager? [Yn]"); ok is_yes($A1), 'OO, factory instantiation'; my $A2 = prompt("\nDid the scrollbar update as you scrolled? [Yn]"); ok is_yes($A2), 'Scrollbar works.'; } done_testing; IO-Pager-2.10/t/TestUtils.pm0000644400215440010010000000321613544377576016701 0ustar jpierceNMRGROUP+Group(513)package 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-2.10/test.pl0000644400215440010010000000053413747622272015443 0ustar jpierceNMRGROUP+Group(513)use strict; use warnings; exit 0 unless scalar(@ARGV) && ($ARGV[0] eq 'interactive'); undef($ENV{LESS}); undef($ENV{PAGER}); $ENV{PERL5OPT} = '-Mblib'; 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-2.10/TODO0000644400215440010010000000635113750640007014610 0ustar jpierceNMRGROUP+Group(513)Important things here and in code flagged with XXX Ctrl-Home/End for top/bottom. -Pgup/PgDn (konsole) for file next/prev? 2.10 IPP Use alternate screen buffer? IPP MS Windows IPP scrolling commands are wonky, therefore we currently waste IPP cycles refreshing... but it works! Fix? IPP https://docs.microsoft.com/en-us/windows/console/console-virtual-terminal-sequences#viewport-positioning IPP more.com exits at EOF. Tests should be longer, or warn of this? IPP or set $ENV{PAGER}='IO::Pager::less' if $^O =~ /MSWin/ MakeMaker __VERSION__? 2.00 IPP Fix interaction with KDE konsole RT#133662 IPP Check xterm, rxvt, gde-term, etc. IPP Goofy term sizes (and WINCH) 1.03 IPP grep scrolling is borked IPP dialog, refresh if _grep instead of specific row refresh IPP modify calls to line() to pass row? keep a buffer of IPP {_row}->[$row]=$line? IPP use screen as buffer: scroll-up decrement cursor until match/top & emit Lesskey #command !! - toggle-option #switch toggle_* to this?! ! _ display-option \eu undo-hilite #toggle higlight of current search term F forw-forever #tail IPP Switch from Term::Cap to Term::TermInfo and get keycodes too? IPP $TT=Term::Terminfo->new(); $TT->str_capnames; $TT->getstr IPP bel,blink,bold,rev,smul[underline],sgr0[reset] IPP kcub1[left],kcuf1[right],kcuu1[up],kcud1[down],kLFT[S-left],kRIT[S-right] IPP kprv,knxt,khome,kend,kbs[backspace],kf1(help?),kich1(insert as mark?) 1.02 IPP Rearchitect around String::Tagged::Terminal? Term::Screen? IPP Move squeeze from input to logical display to allow runtime toggle? IPP Document line numbering impacts?! (perf, RAM...) IPP okay for jumping, awkward for x-ref file in an editor IPP WINCH reflow: keep cursor at same content? IPP Display filename in status line? 1.01 IPP ioctl() for cbreak to replace stty? May not be so cross-platform IPP Add Windows support? via Win32::Console or Win32::Console::ANSI or IPP Term::ANSIScreen or Win10 1511+ ENABLE_VIRTUAL_TERMINAL_PROCESSING & IPP TERM=vt100; also Term::Size::Win32 or Win32::Readch 1.00 IPP #Consolidate _cursor+{rows} and _end?? IPP Pause bugs IPP Left/right when paused causes vertical scrolling IPP (horiz. scroll trigeering a form forward, how to prevent?!) IPP Add more IO::Pager::Perl involved tests, scripted interaction? IPP read from pipe, file IPP navigation IPP search 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..399 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 IPP w/|w/o Term::ReadKey