Paranoid::Lockfile - Paranoid Lockfile support

  use Paranoid::Lockfile;

  $rv = plock($lockfile);
  $rv = punlock($lockfile);
  $rv = pcloseLockfile($lockfile);

  $rv = plock($filename);

  $rv = punlock($filename);

  $rv = pcloseLockfile($filename);

# Paranoid::Lockfile -- Paranoid Lockfile support
#
# (c) 2005, Arthur Corliss <corliss@digitalmages.com>
#
# $Id: Lockfile.pm,v 0.62 2009/03/17 23:54:56 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Lockfile;

use 5.006;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Fcntl qw(:flock O_RDWR O_CREAT O_EXCL);
use Paranoid;
use Paranoid::Debug qw(:all);
use Paranoid::Filesystem;
use Carp;

($VERSION) = ( q$Revision: 0.62 $ =~ /(\d+(?:\.(\d+))+)/sm );

@EXPORT      = qw(plock punlock pcloseLockfile);
@EXPORT_OK   = qw(plock punlock pcloseLockfile);
%EXPORT_TAGS = ( all => [qw(plock punlock pcloseLockfile)], );

#####################################################################
#
# Module code follows
#
#####################################################################

{

    # file descriptor stash
    my %fd;

    sub _clearLocks {

        # Purpose:  Cleanly closes all lockfiles
        # Returns:  True/false
        # Usage:    $rv = _clearLocks();

        my ( $frv, $rv );

        pdebug( 'entering', PDLEVEL2 );
        pIn();

        $frv = 1;
        foreach ( keys %fd ) {
            $rv = pcloseLockfile($_);
            $frv = 0 unless $rv;
            pdebug( "$_ rv: $rv", PDLEVEL3 );
        }

        pOut();
        pdebug( "leaving w/rv: $frv", PDLEVEL2 );

        return $frv;
    }

    sub plock ($;$$) {

        # Purpose:  Opens and locks the specified file.
        # Returns:  True/false
        # Usage:    $rv = plock( $filename );
        # Usage:    $rv = plock( $filename, $lockType, $fileMode );

        my $filename = shift;
        my $type     = shift;
        my $mode     = shift;
        my $targ     = defined $type ? $type : 'undef';
        my $marg     = defined $mode ? $mode : 'undef';
        my $rv       = 0;
        my $fd;

        # Validate arguments
        croak 'Mandatory first argument must be a defined filename'
            unless defined $filename && length $filename > 0;
        croak 'Optional second argument must be a valid lock type'
            unless !defined $type
                || ( defined $type && $type =~ /^(?:write|shared)$/sm );

        pdebug( "entering w/($filename)($targ)($marg)", PDLEVEL1 );
        pIn();

        # Get the filehandle if it's already open
        if ( exists $fd{$filename} ) {
            $fd = $fd{$filename};

            # Open a new filehandle
        } else {

            # Set the default perms if needed
            $mode = 0600 unless defined $mode;

           # To avoid race conditions with multiple files opening (and
           # overwriting) the same file, and hence doing flocks on descriptors
           # with a different # (f#*&ing lock isn't working!) we attempt to do
           # an exclusive open first.  If that fails, then we do reopen to get
           # a filehandle to the (possibly) newly created file.
            sysopen( $fd, $filename, O_RDWR | O_CREAT | O_EXCL, $mode )
                || sysopen( $fd, $filename, O_RDWR );

            # Store the new filehandle
            $fd{$filename} = $fd if defined $fd;
        }

        # Flock it
        if ( defined $fd ) {

            # Assign the lock type according to $type
            $type = 'write' unless defined $type;
            $type = $type eq 'write' ? LOCK_EX : LOCK_SH;
            $rv = 1;
            flock $fd, $type;
        }

        pOut();
        pdebug( "leaving w/rv: $rv", PDLEVEL1 );

        return $rv;
    }

    sub punlock ($) {

        # Purpose:  Removes any existing locks on the file
        # Returns:  True/false
        # Usage:    $rv = punlock();

        my $filename = shift;
        my $rv       = 1;

        # Validate arguments
        croak 'Mandatory first argument must be a defined filename'
            unless defined $filename && length $filename > 0;

        pdebug( "entering w/($filename)", PDLEVEL1 );
        pIn();

        $rv = flock $fd{$filename}, LOCK_UN if exists $fd{$filename};

        pOut();
        pdebug( "leaving w/rv: $rv", PDLEVEL1 );

        return $rv;
    }

    sub pcloseLockfile ($) {

        # Purpose:  Unlocks and closes the passed filename
        # Returns:  True/false
        # Usage:    $rv = pcloseLockfile( $filename );

        my $filename = shift;
        my $rv       = 1;

        # Validate arguments
        croak 'Mandatory first argument must be a defined filename'
            unless defined $filename && length $filename > 0;

        pdebug( "entering w/($filename)", PDLEVEL1 );
        pIn();

        if ( exists $fd{$filename} ) {
            flock $fd{$filename}, LOCK_UN;
            $rv = close $fd{$filename};
            delete $fd{$filename} if $rv;
        }

        pOut();
        pdebug( "leaving w/rv: $rv", PDLEVEL1 );

        return $rv;
    }
}

END {
    _clearLocks();
}

1;

__END__