1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
;#
;# Copyright (c) 1996, 1997
;# Ikuo Nakagawa. All rights reserved.
;#
;# $Id: shlock.pl,v 1.4 1997/05/22 08:40:02 ikuo Exp $
;#
;# Last update:
;# 1996/11/25 by Ikuo Nakagawa
;# Usage:
;# shlock($lockfile, $timeout);
;# ... $lockfile is the filename to put process id,
;# ... $timeout is the value shlock should wait for lock.
;# default value of $timeout is 10[sec].
;# History:
;# 1996/09/21 perl5.003_05 has a BUG of $! in numeric context.
;# 1996/05/25 Add timeout operation to &main::shlock.
;# 1996/02/24 First edition.
;#
package shlock;
;# I want to use `require POSIX', but it causes some troubles.
;# - failed when setting $SIG{__DIE__}.
;# - many functions will be overloaded by POSIX functions(?)
;# - constant() in ext/POSIX/POSIX.c clears errno.
$ESRCH = eval "require POSIX" ? &POSIX::ESRCH : 3;
;# $ESRCH = 3;
;#
sub main::shlock {
local($file, $tout) = @_;
local(*FILE, $temp, $res);
;# generate temporary filename
($temp = $file) =~ s,[^/]+$,LOCK.$$, || return undef;
;# check timeout value
$tout = 10 if $tout < 1;
;# make sure that temporary file does not exist
for (; -e $temp && $tout > 0; $tout--) {
unlink($temp) || sleep(1);
}
;# create temporary file with process id
$tout > 0
&& open(FILE, ">$temp")
&& (print FILE "$$\n")
&& close(FILE)
|| do { unlink($temp); return undef };
;# link it to target file
for (; !($res = link($temp, $file)) && $tout > 0; $tout--) {
last if open(FILE, $file)
&& chomp($pid = <FILE>)
&& close(FILE)
&& $pid =~ /^\d+$/
&& (kill(0, $pid) || $ESRCH != sprintf("%d", $!));
unlink($file) || sleep(1);
}
;# unlink temporary file
unlink($temp);
;# result - success if link succeeded
return $res;
}
;# success on this package
1;
|
