File Coverage

blib/lib/IO/InnerFile.pm

Criterion	Covered	Total	%
statement	65	111	58.5
branch	20	40	50.0
condition	2	6	33.3
subroutine	12	34	35.2
pod	21	21	100.0
total	120	212	56.6

package IO::InnerFile;

use strict;
use warnings;
use Symbol;

our $VERSION = '2.113';

sub new {
   my ($class, $fh, $start, $lg) = @_;
   $start = 0 if (!$start or ($start < 0));
   $lg    = 0 if (!$lg    or ($lg    < 0));

   ### Create the underlying "object":
   my $a = {
      FH 	=> 	$fh,
      CRPOS 	=> 	0,
      START	=>	$start,
      LG	=>	$lg,
   };

   ### Create a new filehandle tied to this object:
   $fh = gensym;
   tie(*$fh, $class, $a);
   return bless($fh, $class);
}

sub TIEHANDLE {
   my ($class, $data) = @_;
   return bless($data, $class);
}

sub DESTROY {
   my ($self) = @_;
   $self->close() if (ref($self) eq 'SCALAR');
}

sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
sub get_length { tied(${$_[0]})->{LG}; }
sub add_length { tied(${$_[0]})->{LG} += $_[1]; }

sub set_start  { tied(${$_[0]})->{START} = $_[1]; }
sub get_start  { tied(${$_[0]})->{START}; }
sub set_end    { tied(${$_[0]})->{LG} =  $_[1] - tied(${$_[0]})->{START}; }
sub get_end    { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }

sub write    { shift->WRITE(@_) }
sub print    { shift->PRINT(@_) }
sub printf   { shift->PRINTF(@_) }
sub flush    { "0 but true"; }
sub fileno   { }
sub binmode  { 1; }
sub getc     { return GETC(tied(${$_[0]}) ); }
sub read     { return READ(     tied(${$_[0]}), @_[1,2,3] ); }
sub readline { return READLINE( tied(${$_[0]}) ); }

sub getline  { return READLINE( tied(${$_[0]}) ); }
sub close    { return CLOSE(tied(${$_[0]}) ); }

sub seek {
   my ($self, $ofs, $whence) = @_;
   $self = tied( $$self );

   $self->{CRPOS} = $ofs if ($whence == 0);
   $self->{CRPOS}+= $ofs if ($whence == 1);
   $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);

   $self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
   $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
   return 1;
}

sub tell {
    return tied(${$_[0]})->{CRPOS};
}

sub WRITE  {
    die "inner files can only open for reading\n";
}

sub PRINT  {
    die "inner files can only open for reading\n";
}

sub PRINTF {
    die "inner files can only open for reading\n";
}

sub GETC   {
    my ($self) = @_;
    return 0 if ($self->{CRPOS} >= $self->{LG});

    my $data;

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    my $lg = $self->{FH}->read($data, 1);
    $self->{CRPOS} += $lg;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    $self->{LG} = $self->{CRPOS} unless ($lg);
    return ($lg ? $data : undef);
}

sub READ   {
    my ($self, $undefined, $lg, $ofs) = @_;
    $undefined = undef;

    return 0 if ($self->{CRPOS} >= $self->{LG});
    $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
    return 0 unless ($lg);

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    $lg = $self->{FH}->read($_[1], $lg, $_[3] );
    $self->{CRPOS} += $lg;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    $self->{LG} = $self->{CRPOS} unless ($lg);
    return $lg;
}

sub READLINE {
    my ($self) = @_;
    return $self->_readline_helper() unless wantarray;
    my @arr;
    while(defined(my $line = $self->_readline_helper())) {
	    push(@arr, $line);
    }
    return @arr;
}

sub _readline_helper {
    my ($self) = @_;
    return undef if ($self->{CRPOS} >= $self->{LG});

    # Handle slurp mode (CPAN ticket #72710)
    if (! defined($/)) {
	    my $text;
	    $self->READ($text, $self->{LG} - $self->{CRPOS});
	    return $text;
    }

    ### Save and seek...
    my $old_pos = $self->{FH}->tell;
    $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);

    ### ...read...
    my $text = $self->{FH}->getline;

    ### ...and restore:
    $self->{FH}->seek($old_pos, 0);

    #### If we detected a new EOF ...
    unless (defined $text) {
       $self->{LG} = $self->{CRPOS};
       return undef;
    }

    my $lg=length($text);

    $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
    $self->{CRPOS} += $lg;

    return substr($text, 0,$lg);
}

sub CLOSE { %{$_[0]}=(); }



1;
__END__