File Coverage

blib/lib/IO/File/CompressOnClose.pm

Criterion	Covered	Total	%
statement	99	106	93.4
branch	58	64	90.6
condition	1	6	16.6
subroutine	14	15	93.3
pod	7	8	87.5
total	179	199	89.9

#
# $Id: CompressOnClose.pm,v 1.3 2003/12/28 15:29:05 james Exp $
#

=head1 NAME

IO::File::CompressOnClose - compress a file when done writing to it

=head1 SYNOPSIS

 use IO::File::CompressOnClose;
 my $io = IO::File::CompressOnClose->new('>foo');
 print $io "foo bar baz\n";
 $io->close;  # file will be compressed to foo.gz on unix or
              # foo.zip on Windows

To change compression schema to a class (which is expected to have
a C<< ->compress() >> class method):

 $io->compressor('Foo::Bar');

To change compression scheme to an arbitrary coderef:

 $io->compressor(\&coderef);

=cut

package IO::File::CompressOnClose;

use strict;
use warnings;

use vars        qw|@ISA $VERSION|;

@ISA          = qw|IO::File|;
$VERSION      = '0.11';

use Carp        qw|croak|;
use IO::File;

# default compression format by platform
my %platform_to_compressor = (
    dos     => 'IO::File::CompressOnClose::Zip',
    MSWin32 => 'IO::File::CompressOnClose::Zip',
    '*'     => 'IO::File::CompressOnClose::Gzip',
);

# open the file
sub open
{

    my $self = shift;
    my($file) = @_;

    # if we are the base class, set our compressor per our platform
    # otherwise compressing using whatever class we are
    if( ref $self eq __PACKAGE__ ) {
        $self->compressor( $platform_to_compressor{$^O} ||
                           $platform_to_compressor{'*'} );
    }
    else {
        $self->compressor( ref $self );
    }

    # default to removing the original file after compression
    $self->delete_after_compress(1);

    # figure out if the file was opened for write
    # (borrowed from IO::File::open)
    if( @_ > 1 ) {
        my $mode = $_[1];
        if( $mode =~ m/^\d+$/ ) {
            # we don't deal with numeric modes yet
            croak("numeric modes not supported by IO::File::CompressOnClose");
        }
        elsif( $mode =~ m/:/ ) {
            # nor do we deal with IO layers
            croak("io layers not supported by IO::File::CompressOnClose");
        }
        unless( IO::Handle::_open_mode_string($mode) =~ m/>/ ) {
            return $self->SUPER::open(@_);
        }
        $self->compress_on_close(1);
    }
    else {
        if( $file =~ m/>/ ) {
            $self->compress_on_close(1);
        }
    }

    # remove redirection characters from the filename
    $file =~ s/[<>]+//;

    # get the absolute path to the file
    if (! File::Spec->file_name_is_absolute($file)) {
        $file = File::Spec->rel2abs(File::Spec->curdir(),$file);
    }
    $self->filename( $file );

    # get our parent class to do the real open
    my $rc = $self->SUPER::open(@_);

    # if the file doesn't exist then we probably were given
    # something esoteric like >&1
    unless( -f $file ) {
        $self->compress_on_close(0);
        croak("'$file' does not exist after open");
    }

    return $rc;

}

# set the default compression scheme
sub _set_compressor
{

    my $self = shift;

    # set the compressor based upon our class
    $self->compressor( $platform_to_compressor{$^O} ||
                       $platform_to_compressor{'*'} );

    return $self;

}

# close and compress the file
sub close
{

    my $self = shift;

    # dispatch to our parent class to do the real close
    $self->SUPER::close(@_);

    # skip out if we've already been invoked
    return 1 if( $self->compressed );

    # skip out if we aren't supposed to compress
    return 1 unless( $self->compress_on_close );

    # make sure we have a valid compression class or func
    my $compressor = $self->compressor;
    if( ref $compressor eq 'CODE' ) {
        $compressor->($self->filename, $self->compress_to)
            && $self->compressed(1);
    }
    else {
        # load the compression class if it isn't already
        unless( UNIVERSAL::isa($compressor, 'UNIVERSAL') ) {
            eval "require $compressor";
            if( $@ ) {
                croak("could not load compression class $compressor: $@");
            }
        }
        # make sure it is a subclass
        unless( UNIVERSAL::isa($compressor, __PACKAGE__) ) {
            croak("$compressor is not a subclass of " . __PACKAGE__);
        }
        # make sure it can compress
        unless( UNIVERSAL::can($compressor, 'compress') ) {
            croak("$compressor cannot 'compress'");
        }
        # re-bless ourselves into the subclass
        bless $self, $compressor;

        # dispatch to the compress method
        $self->compress($self->filename, $self->compress_to)
            && $self->compressed(1);
    }

    # unlink the original file
    if( $self->delete_after_compress ) {
        unless( unlink($self->filename) ) {
            croak("cannot unlink ", $self->filename, " after compress: $!");
        }
    }

    return 1;

}


# make sure that our close is called on object destruction
sub DESTROY
{

    my $self = shift;
    if( $self->opened ) { $self->close }

}


# accessor methods
sub filename
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{filename};
    ${*$self}->{filename} = $newval if( @_ > 1 );
    return $oldval;

}

sub compress_to
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{compress_to};
    ${*$self}->{compress_to} = $newval if( @_ > 1 );
    return $oldval;

}

sub compressor
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{compressor};
    ${*$self}->{compressor} = $newval if( @_ > 1 );
    return $oldval;

}

sub compress_on_close
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{compress_on_close} ? 1 : 0;
    if( @_ > 1 ) {
        ${*$self}->{compress_on_close} = $newval ? 1 : 0;
    }
    return $oldval;

}

sub delete_after_compress
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{delete_after_compress} ? 1 : 0;
    if( @_ > 1 ) {
        ${*$self}->{delete_after_compress} = $newval ? 1 : 0;
    }
    return $oldval;

}

sub compressed
{

    my($self, $newval) = @_;
    my $oldval = ${*$self}->{compressed} ? 1 : 0;
    if( @_ > 1 ) {
        ${*$self}->{compressed} = $newval ? 1 : 0;
    }
    return $oldval;

}

# keep require happy
1;


__END__