File Coverage

blib/lib/IO/Pager/Buffered.pm
Criterion Covered Total %
statement 15 39 38.4
branch 0 16 0.0
condition 0 14 0.0
subroutine 5 11 45.4
pod 3 3 100.0
total 23 83 27.7


line stmt bran cond sub pod time code
1             package IO::Pager::Buffered;
2             our $VERSION = 1.04; #Untouched since 1.03
3              
4 1     1   932 use strict;
  1         2  
  1         33  
5 1     1   8 use base qw( IO::Pager );
  1         15  
  1         90  
6 1     1   6 use SelectSaver;
  1         2  
  1         359  
7              
8              
9             sub new(;$) { # [FH], procedural
10 0     0 1   my($class, $tied_fh);
11              
12 0           eval { ($class, $tied_fh) = &IO::Pager::_init };
  0            
13             #We're not on a TTY so...
14 0 0 0       if( defined($class) && $class eq '0' or $@ =~ '!TTY' ){
      0        
15             #...leave filehandle alone if procedural
16 0 0 0       return $_[1] if defined($_[2]) && $_[2] eq 'procedural';
17              
18             #...fall back to IO::Handle for transparent OO programming
19 0 0         eval "require IO::Handle" or die $@;
20 0           return IO::Handle->new_from_fd(fileno($_[1]), 'w');
21             }
22 0 0         $!=$@, return 0 if $@ =~ 'pipe';
23              
24 0 0         tie *$tied_fh, $class, $tied_fh or return 0;
25             }
26              
27             #Punt to base, preserving FH ($_[0]) for pass by reference to gensym
28             sub open(;$) { # [FH]
29             # IO::Pager::open($_[0], 'IO::Pager::Buffered');
30 0     0 1   &new('IO::Pager::Buffered', $_[0], 'procedural');
31             }
32              
33              
34             # Overload IO::Pager methods
35              
36             sub PRINT {
37 0     0     my ($self, @args) = @_;
38 0   0       $self->{buffer} .= join($,||'', @args);
39             }
40              
41              
42             sub CLOSE {
43 0     0     my ($self) = @_;
44             # Print buffer and close using IO::Pager's methods
45             $self->SUPER::PRINT($self->{buffer}) if
46 0 0 0       exists($self->{buffer}) && length($self->{buffer});
47 0           $self->{buffer}='';
48 0           $self->SUPER::CLOSE();
49             }
50              
51 1     1   8 { no warnings 'once'; *DESTROY = \&CLOSE; }
  1         2  
  1         116  
52              
53             sub TELL {
54             # Return the size of the buffer
55 0     0     my ($self) = @_;
56 1     1   583 use bytes;
  1         15  
  1         5  
57 0 0         return exists($self->{buffer}) ? length($self->{buffer}) : 0;
58             }
59              
60              
61             sub flush(;*) {
62 0     0 1   my ($self) = @_;
63 0 0         if( exists $self->{buffer} ){
64 0           my $saver = SelectSaver->new($self->{real_fh});
65 0           local $|=1;
66 0           ($_, $self->{buffer}) = ( $self->{buffer}, '');
67 0           $self->SUPER::PRINT($_);
68             }
69             }
70              
71              
72             1;
73              
74             __END__