File Coverage

blib/lib/IO/LockedFile.pm

Criterion	Covered	Total	%
statement	83	103	80.5
branch	25	48	52.0
condition	9	18	50.0
subroutine	21	23	91.3
pod	12	12	100.0
total	150	204	73.5

package IO::LockedFile;

use strict;
use vars qw($VERSION @ISA);

$VERSION = 0.23;

use IO::File;
@ISA = ("IO::File"); # subclass of IO::File

use strict;
use Carp;

# Set default options
my %Options;
_set_option( __PACKAGE__, ( block     => 1,
                            lock      => 1,
                            scheme    => 'Flock',
                            _locked   => 0,
                            _writable => 0 ) );

###########################
# new
###########################
# the constructor
sub new {
    my $proto = shift;          # get the class name
    my $class = ref($proto) || $proto;
    my $self  = $class->SUPER::new(); # the object is also file handle

    # Grab our options (if they're there);
    my $options = {};
    $options = shift if ref($_[0]) eq 'HASH';

    if ( exists $options->{ scheme } ) {
        # User-specified scheme (may have to load it)
        $class = join( '::', __PACKAGE__, $options->{ scheme } );
        eval "require $class";
        croak "Unable to load $class: $@" if $@;
    }
    elsif ( $class eq __PACKAGE__ ) {
        # User didn't specify anything (or subclass), so do it for her
        $class .= '::' . get_scheme( $class );
    }

    bless ($self, $class);

    # Store our options
    $self->_set_option( %{ $options } );

    # if receives any parameters, call our open with those parameters
    if (@_) {
	$self->open(@_) or return undef;
    }

    return $self;
} # of new

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

    my $writable = 0;
    if ( scalar(@_) == 1 ) {
        # Perl mode. Look at first character

        # Quick sanity check. We can't lock a pipe
        if (( substr( $_[0],  0, 1 ) eq '|' ) ||
           ( substr( $_[0], -1, 1 ) eq '|' ) ) {
            croak "Cannot lock a pipe"
        }

        # OK, now look at first character
        $writable = substr( $_[0], 0, 1 ) eq '>';
    }
    elsif ( $_[1] =~ /^\d+$/ ) {
        # Numeric mode
        require Fcntl;
        $writable = ( ( $_[1] & O_APPEND ) ||
                      ( $_[1] & O_CREAT  ) ||
                      ( $_[1] & O_TRUNC  ) );
    }
    else {
        # POSIX mode (we know there were enough parameters since our
        # SUPER succeeded).
        $writable = ( $_[1] ne 'r' );
    }

    $self->_set_writable( $writable );
    # call open of the super class (IO::File) with the rest of the parameters
    $self->SUPER::open(@_) or return undef;

    if ( $self->should_lock() ) {
        $self->lock() or return undef;
    }

    return 1;
} # of open

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

    $self->_set_locked( 1 );
    return 1;
} # of lock

########################
# unlock
########################
sub unlock {
    my $self = shift;
    $self->_set_locked( 0 );
    return 1;
} # of unlock

########################
# close
########################
sub close {
    my $self = shift;
    # if the file was opened - unlock it
    $self->unlock() if ($self->opened() and $self->have_lock());
    $self->SUPER::close();
} # of close

#######################
# have_lock
#######################
sub have_lock {
    my $self = shift;
    return $self->_get_option( '_locked' );
} # of have_lock

#######################
# _set_locked
#######################
sub _set_locked {
    my ( $self, $value ) = @_;
    return $self->_set_option( '_locked', $value );
} # of _set_locked

#######################
# is_writable
#######################
sub is_writable {
    my $self = shift;
    return $self->_get_option( '_writable' );
} # of is_writable

#######################
# _set_writable
#######################
sub _set_writable {
    my ( $self, $value ) = @_;
    return $self->_set_option( '_writable', $value );
} # of _set_writable

#######################
# should_block
#######################
sub should_block {
    my $self = shift;
    return $self->_get_option( 'block' );
} # of should_block

#######################
# should_lock
#######################
sub should_lock {
    my $self = shift;
    return $self->_get_option( 'lock' );
} # of should_lock

#######################
# print
#######################
sub print {
    my ( $self, @args ) = @_;

    my $was_locked = $self->have_lock();

    if ( ! $was_locked ) {
	return 0 unless $self->lock();
    }
    my $rc = $self->SUPER::print( @args );
    $self->unlock unless $was_locked;

    return $rc;
} # of print

#######################
# truncate
#######################
sub truncate {
    my ( $self, @args ) = @_;

    my $was_locked = $self->have_lock();

    if ( ! $was_locked ) {
	return 0 unless $self->lock();
    }
    my $rc = $self->SUPER::truncate( @args );
    $self->unlock() unless $was_locked;

    return $rc;
} # of truncate

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

    return _get_option( $self, 'scheme' );
} # of get_scheme

#######################
# DESTROY
#######################
sub DESTROY {
    my $self = shift;
    # if the file was opened, close (and unlock) it
    $self->close;
} # of DESTROY

######################
# _get_option
######################
sub _get_option {
    my( $self, $key ) = @_;

    # Is the option set here?
    if ( exists $Options{ $self } && exists $Options{ $self }->{ $key } ) {
        return $Options{ $self }->{ $key }
    }
    # If we're an object, check out class
    elsif ( ref( $self ) ) {
        return _get_option( ref( $self ), $key );
    }
    # If we're a class other than this one, check defaults
    elsif ( $self ne __PACKAGE__ ) {
        return _get_option( __PACKAGE__, $key );
    }
    # It's nowhere. Probably a typo
    else {
        croak "Bad option fetch: $key\n";
    }
} # of _get_option

######################
# _set_option
######################
sub _set_option {
    my( $self, %hash ) = @_;

    while ( my( $key, $value ) = each %hash ) {
        $Options{ $self }->{ $key } = $value;
    }
} # of _set_option

######################
# import
######################
sub import {
    my $pkg = shift;
    my( %config );
    if ( @_ == 1 ) {
	$config{ scheme } = shift;
    }
    else {
	%config = @_;
    }

    my $scheme = $config{ scheme } || $pkg->get_scheme;

    my $class = __PACKAGE__ . "::$scheme";
    eval "require $class";
    croak "Unable to load $class: $@" if $@;

    $class->_set_option( %config );
} # of import

1;
__END__