lock.pl for BSD and Linux

[Michael Chaney]

I'm not sure if I've sent this along before, so here it is.

Here's the lock.pl that I use for FreeBSD, works with Linux also.  With
some minor modifications, it should be trivial to make it work with any
Unix system out there.

Michael
--
Michael Darrin Chaney
mdchaney at michaelchaney.com
http://www.michaelchaney.com/
-------------- next part --------------
#   MailScanner - SMTP E-Mail Virus Scanner
#   Copyright (C) 2001  Julian Field
#
#   $Id: lock.pl,v 1.4 2001/08/10 12:53:44 jkf Exp $
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#   The author, Julian Field, can be contacted by email at
#      Jules at JulianField.net
#   or by paper mail at
#      Julian Field
#      Dept of Electronics & Computer Science
#      University of Southampton
#      Southampton
#      SO17 1BJ
#      United Kingdom
#

# Provide functions to deal with opening + locking spool files

package Lock;

use strict;
use Fcntl qw(:DEFAULT :flock);
use POSIX qw(:unistd_h :errno_h);

# Open and lock a file.
#
# Pass in a filehandle, a filespec (including ">", "<", or
# whatever on the front), and (optionally) the type of lock
# you want - "r" or "s" for shared/read lock, or pretty much
# anything else (but "w" or "x" really) for exclusive/write
# lock.
#
# Lock type used (flock or fcntl/lockf/posix) depends on
# config. If you're using posix locks, then don't try asking
# for a write-lock on a file opened for reading - it'll fail
# with EBADF (Bad file descriptor).
#
sub openlock {
    my ($fh, $fn, $rw) = @_;

    my ($locktype,$struct_flock);

    $locktype = ($Config::LockType)?
      $Config::LockType : $MTA::LockType;

    defined $rw or $rw = ((substr($fn,0,1) eq '>')?"w":"r");
    $rw =~ /^[rs]/i or $rw = 'w';

    unless (open($fh, $fn)) {
        Log::InfoLog("Could not open file $fn: %s", $!);
        return 0;
    }

    if ($locktype =~ /posix/i) {
        # HORRIBLY HARDWIRED
        # would like to "use File::lockf" but that would make
        # installation harder.
        #
        # I guess the pack() is not too bad so long as most parms
        # are zero ;)
        #
        # I've seen sslls, ssllll and all sorts used there...
        # ...not too sure what the best most portable way is :(
        #
        Log::DebugLog("Using fcntl() to lock $fn");
        #$struct_flock =  pack('ssx32',($rw eq 'w' ? F_WRLCK : F_RDLCK),0);
        $struct_flock =  struct_flock(($rw eq 'w' ? F_WRLCK : F_RDLCK),SEEK_SET,0,0,0);
        fcntl($fh, F_SETLK, $struct_flock) and return 1;
    }
    elsif ($locktype =~ /flock/i) {
        Log::DebugLog("Using flock() to lock $fn");
        flock($fh, ($rw eq 'w' ? LOCK_EX : LOCK_SH) + LOCK_NB) and return 1;
    }
    else {
        Log::DebugLog("Not locking spool file $fn");
        return 1;
    }

    print "Couldn't lock $fn: $!\n";

    close ($fh);

    Log::DebugLog("Failed to lock $fn: %s", $!);

    return 0;
}


sub unlockclose {
    my ($fh) = @_;

    my $locktype;

    $locktype = ($Config::LockType)?
      $Config::LockType : $MTA::LockType;

    if ($locktype =~ /posix/i) {
        #fcntl($fh, &F_SETLK, pack('sslls',&F_UNLCK,0,0,0,0));
        fcntl($fh, F_SETLK, struct_flock(F_UNLCK,0,0,0,0));
    }
    elsif ($locktype =~ /flock/i) {
        flock($fh, LOCK_UN);
    }
# else {
#   default - do nothing, as we didn't lock it in the first place
# }

    close ($fh);
    return 1;
}

BEGIN {
        my $FLOCK_STRUCT = 'S s L L I';
        sub linux_flock {
                if (wantarray) {
                        my ($type, $whence, $start, $len, $pid) =
                                unpack($FLOCK_STRUCT, $_[0]);
                        return ($type, $whence, $start, $len, $pid);
                } else {
                        my ($type, $whence, $start, $len, $pid) = @_;
                        return pack($FLOCK_STRUCT,
                                        $type, $whence, $start, $len, $pid);
                }
        }
}

BEGIN {
# XXX: should be Q not LL
        my $FLOCK_STRUCT = 'LL LL L l s';

        sub bsd_flock {
                if (wantarray) {
                        my ($xxstart, $start, $xxlen, $len, $pid, $type, $whence) =
                                unpack($FLOCK_STRUCT, $_[0]);
                        return ($type, $whence, $start, $len, $pid);
                } else {
                        my ($type, $whence, $start, $len, $pid) = @_;
                        my ($xxstart, $xxlen) = (0,0);
                        return pack($FLOCK_STRUCT,
                                        $xxstart, $start, $xxlen, $len, $pid, $type, $whence);
                }
        }
}

BEGIN {
        for ($^O) {
                if    (/bsd/)   { *struct_flock = \&bsd_flock       }
                elsif (/linux/) { *struct_flock = \&linux_flock    }
                else {
                        die "unknown operating system: $!";
                }
        }
}


1;