File Coverage

blib/lib/Tie/Gzip.pm

Criterion	Covered	Total	%
statement	29	201	14.4
branch	3	96	3.1
condition	0	24	0.0
subroutine	9	21	42.8
pod			n/a
total	41	342	11.9

#!perl
#
# Documentation, copyright and license is at the end of this file.
#
package Tie::Gzip;

use 5.001;
use strict;
use warnings;
use warnings::register;

use vars qw($VERSION $DATE $FILE);
$VERSION = '1.15';
$DATE = '2004/04/16';
$FILE = __FILE__;

use File::Spec;

######
#  Started with CPAN::Tarzip::TIEHANDLE which
#  still retains a faint resemblence.
#
sub TIEHANDLE
{

     my($class, @args) = @_;

     #########
     # create new object of $class
     #
     # If there is ref($class) than $class
     # is an object whose class is ref($class).
     #
     $class = ref($class) if ref($class);
     my $self = bless {}, $class;

     ######
     # Parse the last argument as options if it is a reference.
     #
     my $options = {};
     if( ref($args[-1]) ) {
          $options = pop @args;
          if(ref($options) eq 'ARRAY') {
              my %options = @{$options};
              $options = \%options;
          }
     }
     $self->{options} = $options;


     #####################
     # If the Compress::Zlib package is not defined,
     # load it.
     #
     my $package = 'Compress::Zlib::';
     File::Package->load_package('Compress::Zlib') unless(defined %$package);
     $self->{gz_package} = defined %$package;

     if( $self->{gz_package} ) {
         Compress::Zlib->import( qw(&gzopen $gzerrno Z_STREAM_END) );
     }

     else {

         $options->{read_pipe} = 'gzip --decompress --stdout {}' unless $options->{read_pipe};
         $options->{write_pipe} = 'gzip --stdout > {}' unless $options->{write_pipe};
     }

     $options->{read_pipe} .= ' |' if $options->{read_pipe} && $options->{read_pipe} !~ /\|/;
     $options->{write_pipe} = '| ' . $options->{write_pipe} if $options->{write_pipe} && $options->{write_pipe} !~ /\|/;

     ######
     # Open the gzip file
     #
     return $self->OPEN( @args ) if( @args );

     $self;

}


######
#  Lifted from CPAN::Tarzip::TIEHANDLE in the
#  CPAN.pm module
#
#  A tied object can be used to close current file
#  and open another file.
#
sub OPEN
{

     ######
     # Make a copy so change without impacting
     # the using variables.
     #
     my ($self, $mode, $file) = @_;

     $self->CLOSE;

     unless (defined $file) {
         $file = $mode;
         $file =~ s/^\s*([<>+|]+)\s*//;
         $mode = $1;
     }
     my $options = $self->{options};

     if( $mode eq '<' ) {

         if ($self->{gz_package} && !$options->{read_pipe}) {
             my $gz = gzopen($file,'rb');
             unless($gz) {
                 warn( "gzopen($file,'rb') failed\n") ;
                 $self->CLOSE;
                 return undef;
             }
             $self -> {GZ} = $gz;
         }

         else {

             my $pipe = $options->{read_pipe};
             $pipe =~ s/{}/$file/g;

             ###############
             # Some perls will return a glob and a warning
             # for certain pipe errors such as the command
             # not a recognized command
             #
             my $success = open PIPE, $pipe;
             $! = 0;    ### MAS ###
             if($! || !$success) {
                 warn "Could not pipe $pipe: $!\n";
                 $self->CLOSE;
                 return undef;
             }
             binmode PIPE;
             $self-> {FH} = \*PIPE;

         }

         ######
         # The existance of $self->{file} means the file is open
         # for business.
         #
         $self->{eof} = 0;
         $self->{file} = $file;
         $self->{mode} = $mode;

     }

     elsif ($mode eq '>' ) {

         if ($self->{gz_package} && !$options->{write_pipe}) {
             my $gz = gzopen($file,'wb');
             unless($gz) {
                 warn( "gzopen($file,'rb') failed\n") ;
                 $self->CLOSE;
                 return undef;
             }
             $self -> {GZ} = $gz;
         }

         else {
             my $pipe = $options->{write_pipe};
             $pipe =~ s/{}/$file/g;

             ###############
             # Some perls will return a glob and a warning
             # for certain pipe errors such as the command
             # not a recognized command
             #
             my $success = open PIPE, $pipe;
             $! = 0;    ### MAS ###
             if($! || !$success) {
                 warn "Could not pipe $pipe: $!\n";
                 $self->CLOSE;
                 return undef;
             }
             binmode PIPE;
             $self-> {FH} = \*PIPE;
         }
         $self->{tell} = 0;
         $self->{eof} = 0;
         $self->{file} = $file;
         $self->{mode} = $mode;

     }

     else {
         warn( "Opening file $file with $mode not allowed\n");
         return undef;
     }
     $self->{file_abs} = File::Spec->rel2abs( $self->{file} ) if $self->{file};

     $self;

}



#####
# Started with the CPAN::Tarzip::READLINE in the
# CPAN.pm module
#
sub READLINE
{
    my($self) = @_;

    my $line = undef;
    my $bytesread = -1;
    if (defined $self->{GZ}) {
        $bytesread = $self->{GZ}->gzreadline($line);
    }

    elsif (defined $self->{FH}) {
        my $fh = $self->{FH};
        $line = <$fh>;
        $bytesread = $line ? length($line) : 0;
    }

    if ($bytesread <= 0) {
        $self->{eof} = 1;
        return undef;
    }
    $self->{tell} += $bytesread;

    $line;

}


#####
# Started with the CPAN::Tarzip::READ in the
# CPAN.pm module
#
sub READ
{

    my($self, undef, $length, $offset) = @_;

    if(defined $offset) {
        warn "read with offset not implemented\n";
        return undef;
    }

    my $bytes_read = 0;
    my $bufref = \$_[1];
    if (defined $self->{GZ}) {
        $bytes_read =  $self->{GZ}->gzread($$bufref,$length);
    }

    elsif(defined $self->{FH}) {
        my $fh = $self->{FH};
        $bytes_read = read($fh,$$bufref,$length);
    }

    $self->{tell} += $bytes_read;
    $bytes_read;

}



#####
#
#
sub GETC
{

    my($self) = @_;

    my $c;

    my $bytes_read = 0;
    if (defined $self->{GZ}) {
        $bytes_read =  $self->{GZ}->gzread($c, 1);
    }

    elsif(defined $self->{FH}) {
        my $fh = $self->{FH};
        $c = getc($fh);
        $bytes_read = length($c);
    }

    $self->{tell} += $bytes_read;
    $c;

}




#####
#
#
sub PRINT
{
    my $self = shift;

    my $buf = join(defined $, ? $, : '',@_);
    $buf .= $\ if defined $\;

    my $bytes_written = 0;
    if (defined $self->{GZ}) {
        $bytes_written =  $self->{GZ}->gzwrite($buf);
    }

    elsif(defined $self->{FH}) {
        my $fh = $self->{FH};
        return undef unless $bytes_written = print $fh $buf;

    }

    $self->{tell} += $bytes_written;
    $bytes_written;

}



#####
#
#
sub PRINTF
{
    my $self = shift;
    $self->PRINT (sprintf(shift,@_));
}



#####
#
#
sub WRITE
{
    my($self, $buf, $length, $offset) = @_;

    if(defined $offset) {
        warn "read with offset not implemented\n";
        return undef;
    }

    my $bytes_written = 0;
    $buf = substr($buf,0,$length);
    if (defined $self->{GZ}) {
        $bytes_written =  $self->{GZ}->gzwrite($buf);
    }

    elsif(defined $self->{FH}) {
        my $fh = $self->{FH};
        $bytes_written = print $fh $buf;
    }

    $self->{tell} += $bytes_written;
    $bytes_written;

}





#####
# Started with CPAN::Tarzip::DESTROY, CPAN::Tarzip::gtest
#
sub CLOSE
{

    my($self) = @_;

    return 1 unless $self->{file};

    my $success = 1;
    if ($self->{GZ}) {
        my $gz = $self->{GZ};
        my $err = $gz->gzerror();
        $gz->gzclose();
        if ($self->{mode} eq '<' ) {
            $success = !$err || $err == Z_STREAM_END();
            if($success && $self->{tell} == -s $self->{file_abs}) {
                 $success = 0;
                $err =  "Uncompressed file\n";
            }
        }
        warn("success: $success\n\terr: $err") unless $success;
    }

    else {
        my $fh = $self->{FH};
        $success = close $fh if defined $fh;
        warn("success: 0\n\terr: $!") unless $success;
    }

    $self->{file} = '';
    $self->{mode} = '';
    $self->{FH} = undef;
    $self->{GZ} = undef;
    $self->{tell} = 0;
    $self->{eof} = 0;

    $success;
}


#####
#
#
sub DESTROY
{
    CLOSE( @_ );

}


#####
#
#
sub SEEK
{
    my ($self, $offset, $whence) = @_;

    if($whence ne 1) {
        warn "Whence of $whence not allowed.\n";
        return undef;
    }
    if($offset < 0) {
        warn "Negative offset of $offset not allowed.\n";
        return undef;
    }

    my $buffer;
    $self->READ( $buffer, $offset);

}



#####
#
#
sub TELL
{
    my $self = shift;
    $self->{tell};
}


#####
#
#
sub EOF
{
    my $self = shift;
    $self->{eof};
}


######
#
#
sub BINMODE
{

    my ($self, $disc) = @_;

    my $binmode =  ':raw';
    if (exists $self->{FH}) {
        my $fh = $self->{FH};
        $binmode =  binmode $fh;
    }
    $binmode;

}


######
#
#
sub FILENO
{
    my $self = shift;

    my $fileno =  undef;
    if (exists $self->{FH}) {
        my $fh = $self->{FH};
        $fileno =  fileno $fh;
    }

    $fileno;
}


1


__END__