InfoMagic Source Code 1993 July/THE_SOURCE_CODE_CD_ROM.iso/languages/perl/scripts-convex/lockem

Text File | 1991-06-07 | 4.7 KB | 203 lines

#!/usr/local/bin/perl

$editor = $ENV{'EDITOR'} || 'vi';

$atomic = 1; # unless reset by -w

while ($ARGV[0] =~ /^-(.+)/ && (($_ = $1), shift, 1)) {
    next if $_ eq ''; # options exhausted

    if (/^-$/) {
    push(@options, shift) while $ARGV[0] =~ /^-/;
    last;
    }

    s/b// && (++$nonblock,  redo);
    s/c// && (++$create, redo);
    s/s// && (++$ronly,  redo);
    s/w// && (($atomic = 0), redo);
    s/f// && (++$use_flock, redo);
    s/l// && (++$use_lockf, redo);
    s/e// && (($editor = $_ || shift),  next);

    print STDERR "unknown option: -$_\n";
    &usage;
}


&usage unless @ARGV;

$use_lockf++ unless $use_flock || $use_lockf;

&flock_init if $use_flock;
&lockf_init if $use_lockf;

$fh = 'FH000';

for (@ARGV) {
    local($locker);
    die "$0: $_ is a directory\n" if -d;
    $files{$_} = ++$fh;
    if (!open($fh, ($use_lockf ? "+<" : "<") . $_)) {
    if ($! =~ /no such file/i && $create) {
        warn "$0: creating $_\n";
        die "$0: cannot create $_: $!\n" unless open($fh, ">>$_");
    } else {
        warn "$0: cannot open $_: $!\n";
        &atomic;
        delete $files{$_};
        sleep 1;
        next;
    }
    }
    if (&slock($fh)) {
    if (! &lock($fh)) {
        warn "$_ disappeared" unless -e;
        &whosgot;
        &atomic;
    }
    }
    elsif (!$nonblock && ($! =~ /would block/i ||
    ($! =~ /permission/i && $use_lockf)))
    {
    &whosgot;
    print STDERR "waiting for ", ($ronly ? "shared" : "exclusive"),
         " lock on $_...";
    unless (&lock($fh)) {
        warn "$_ disappeared" unless -e;
        &whosgot;
        &atomic;
    }
    print STDERR "lock on $_ granted.\n";
    sleep 1;
    } else {
    &whosgot;
    &atomic;
    delete $files{$_};
    }
}

system $editor, @options, @ARGV;

for (keys %files) {
    unless (&unlock($files{$_})) {
    warn "$0: cannot unlock $_ ($files{$_}): $!\n";
    next;
    }
}

exit 0;

sub atomic {  # like quarks
  die "$0: use -w to continue without acquiring all locks\n" if $atomic;
}

sub usage {
    die <<EOM;
usage: $0 [-wbcsfl] [-e editor] [-- -editor_options] files
       -w: give warnings only if all locks can't be acquired
       -b: do NOT block until all locks acquired
       -c: create non-existent files
       -s: shared locks only (good for read-only files)
       -f: use flock
       -l: use lockf (default)
       -e editor: invoke program other than \$EDITOR
       --: end options to $0, rest will go to \$EDITOR
EOM
}

sub lockf_init {
    # require 'fcntl.ph';

    ($F_GETLK, $F_SETLK, $F_SETLKW) = (7..9);
    ($F_RDLCK, $F_WRLCK, $F_UNLCK) = (1..3);

    # struct flock definition
    $flock_t = 'ssLLss';

    # and its field names
    ( $L_TYPE,        # $F_RDLCK, $F_WRLCK, or $F_UNLCK
      $L_WHENCE,    # flag to choose starting offset
      $L_START,        # relative offset, in bytes
      $L_LEN,        # length, in bytes; 0 means lock to EOF
      $L_PID,        # returned with $F_GETLK
      $L_XXX )        # reserved for future use
      = (0..5);
}

sub flock_init {
    ($LOCK_SH, $LOCK_EX, $LOCK_NB, $LOCK_UN) = (1,2,4,8);
}

sub unlock {
    local($fh) = @_;
    local($return) = 1;
    if ($use_flock) {
    $return = flock($fh, $LOCK_UN);
    }
    if ($use_lockf && !$return) {
    local(@flock,$flock);
    $flock[$L_TYPE] = $F_UNLCK;
    $flock = pack($flock_t, @flock);
    &getlocker unless $return = fcntl($fh, $F_SETLK, $flock);
    }
    $return;
}

sub slock {  # safely lock a file if i can w/o blocking
    local($fh) = @_;
    local($return) = 1;

    if ($use_flock) {
    $return = flock($fh, $LOCK_NB | ($ronly ? $LOCK_SH : $LOCK_EX));
    }
    if ($use_lockf && $return) {
    local(@flock,$flock);
    $flock[$L_TYPE] = $ronly ? $F_RDLCK : $F_WRLCK;
    $flock = pack($flock_t, @flock);
    &getlocker unless $return = fcntl($fh, $F_SETLK, $flock);
    }
    $return;
}

sub lock {  # lock with blocking
    local($fh) = @_;
    local($return) = 1;
    if ($use_flock) {
    $return = flock($fh, $ronly ? $LOCK_SH : $LOCK_EX);
    }
    if ($use_lockf && $return) {
    local(@flock,$flock);
    $flock[$L_TYPE] = $ronly ? $F_RDLCK : $F_WRLCK;
    $flock = pack($flock_t, @flock);
    $return = fcntl($fh, $F_SETLKW, $flock);
    if (!$return && $! =~  /interrupt/i) { # broken kernel (^Z/fg)
        warn "$0: interrupted, trying again\n";
        $return = &lock($fh);
    }
    }
    $return;
}

sub getlocker {
    local(@flock,$flock);
    local($!); # save old errno
    $flock[$L_TYPE] = $ronly ? $F_RDLCK : $F_WRLCK;
    $flock = pack($flock_t, @flock);
    if (fcntl($fh, $F_GETLK, $flock)) {
    @flock = unpack($flock_t, $flock);
    $locker = ($flock[$L_TYPE] == $F_UNLCK ? 0 : $flock[$L_PID])
            || "some remote host";
    } else {
    warn "can't getlk: $!";
    }
}

sub whosgot {
    if ($use_lockf && $locker) {
    warn "$0: lock on $_ held by pid $locker\n";
    } else {
    warn "$0: cannot lock $_: $!\n";
    }
}