# <@LICENSE>
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements. See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to you under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License. You may obtain a copy of the License at:
#
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# </@LICENSE>
package
Mail::SpamAssassin::Locker::Win32;
use
strict;
use
warnings;
# use bytes;
use
Fcntl;
use
Mail::SpamAssassin;
use
File::Spec;
use
Time::Local;
our
@ISA
=
qw(Mail::SpamAssassin::Locker)
;
###########################################################################
sub
new {
my
$class
=
shift
;
my
$self
=
$class
->SUPER::new(
@_
);
$self
;
}
###########################################################################
sub
safe_lock {
my
(
$self
,
$path
,
$max_retries
,
$mode
) =
@_
;
my
@stat
;
$max_retries
||= 30;
# $mode is ignored on win32
my
$lock_file
=
"$path.lock"
;
if
(-e
$lock_file
&& -M
$lock_file
> (LOCK_MAX_AGE / 86400)) {
dbg(
"locker: safe_lock: breaking stale lock: $lock_file"
);
unlink
(
$lock_file
)
or
warn
"locker: safe_lock: unlink of lock file $lock_file failed: $!\n"
;
}
for
(
my
$retries
= 0;
$retries
<
$max_retries
;
$retries
++) {
if
(
$retries
> 0) {
sleep
(1);
# TODO: $self->jittery_one_second_sleep();?
}
dbg(
"locker: safe_lock: trying to get lock on $path with $retries retries"
);
if
(!
defined
sysopen
(LOCKFILE,
$lock_file
, O_RDWR|O_CREAT|O_EXCL)) {
dbg(
"locker: safe_lock: failed to create lock tmpfile $lock_file: $!"
);
}
else
{
dbg(
"locker: safe_lock: link to $lock_file: sysopen ok"
);
close
(LOCKFILE) or
warn
"error closing a lock file: $!"
;
return
1;
}
my
@stat
=
stat
(
$lock_file
);
@stat
or dbg(
"locker: error accessing $lock_file: $!"
);
# check age of lockfile ctime
my
$age
= (
$#stat
< 11 ?
undef
:
$stat
[10]);
if
((!
defined
(
$age
) &&
$retries
>
$max_retries
/ 2) ||
(
defined
(
$age
) && (
time
-
$age
> LOCK_MAX_AGE)))
{
dbg(
"locker: safe_lock: breaking stale lock: $lock_file"
);
unlink
(
$lock_file
)
or
warn
"locker: safe_lock: unlink of lock file $lock_file failed: $!\n"
;
}
}
return
0;
}
###########################################################################
sub
safe_unlock {
my
(
$self
,
$path
) =
@_
;
unlink
(
"$path.lock"
)
or
warn
"locker: safe_unlock: unlink failed: $path.lock\n"
;
dbg(
"locker: safe_unlock: unlink $path.lock"
);
}
###########################################################################
sub
refresh_lock {
my
(
$self
,
$path
) =
@_
;
return
unless
$path
;
# this could arguably read the lock and make sure the same process
# owns it, but this shouldn't, in theory, be an issue.
utime
time
,
time
,
"$path.lock"
;
dbg(
"locker: refresh_lock: refresh $path.lock"
);
}
###########################################################################
1;