File Coverage

blib/lib/Paranoid/IO/Lockfile.pm

Criterion	Covered	Total	%
statement	64	64	100.0
branch	5	6	83.3
condition	1	3	33.3
subroutine	14	14	100.0
pod	4	4	100.0
total	88	91	96.7

# Paranoid::IO::Lockfile -- Paranoid Lockfile support
#
# $Id: lib/Paranoid/IO/Lockfile.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

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

package Paranoid::IO::Lockfile;

use 5.008;

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::IO;

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

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

use constant PRIV_UMASK => 0660;

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

sub plock {

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

    my $filename = shift;
    my $type     = shift;
    my $perms    = shift;
    my ( $rv, $fh );

    subPreamble( PDLEVEL1, '$;$$', $filename, $type, $perms );

    # Set the defaults
    $perms = PRIV_UMASK unless defined $perms;
    $type  = LOCK_EX    unless defined $type;

    # Open the file and apply the lock
    $fh = popen( $filename, O_RDWR | O_CREAT | O_EXCL, $perms )
        || popen( $filename, O_RDWR, $perms );
    $rv = pflock( $filename, $type ) if defined $fh;

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub pexclock {

    # Purpose:  Applies an exclusive lock
    # Returns:  True/false
    # Usage:    $rv = pexclock($filename);

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

    subPreamble( PDLEVEL1, '$;$', $filename, $mode );

    $rv = plock( $filename, LOCK_EX, $mode );

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub pshlock {

    # Purpose:  Applies a shared lock
    # Returns:  True/false
    # Usage:    $rv = pshlock($filename);

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

    subPreamble( PDLEVEL1, '$;$', $filename, $mode );

    $rv = plock( $filename, LOCK_SH, $mode );

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub punlock {

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

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

    subPreamble( PDLEVEL1, '$;$', $filename, $mode );

    $rv = plock( $filename, LOCK_UN, $mode );

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

1;

__END__