From b8b2e694f1fa0f574b4b7349aa68c5659fbe0420 Mon Sep 17 00:00:00 2001
From: Dietmar Maurer <dietmar@proxmox.com>
Date: Fri, 15 Jun 2018 07:00:16 +0200
Subject: [PATCH] Tools.pm: copied lock_file_full from pve-common

---
 PVE/APIClient/Tools.pm | 127 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 127 insertions(+)

diff --git a/PVE/APIClient/Tools.pm b/PVE/APIClient/Tools.pm
index 754ecb5..034b4f3 100644
--- a/PVE/APIClient/Tools.pm
+++ b/PVE/APIClient/Tools.pm
@@ -7,6 +7,8 @@ use base 'Exporter';
 
 use IO::File;
 use Text::ParseWords;
+use Fcntl qw(:DEFAULT :flock);
+use Scalar::Util 'weaken';
 
 our @EXPORT_OK = qw(
 $IPV6RE
@@ -35,6 +37,131 @@ our $IPV6RE = "(?:" .
 
 our $IPRE = "(?:$IPV4RE|$IPV6RE)";
 
+sub run_with_timeout {
+    my ($timeout, $code, @param) = @_;
+
+    die "got timeout\n" if $timeout <= 0;
+
+    my $prev_alarm = alarm 0; # suspend outer alarm early
+
+    my $sigcount = 0;
+
+    my $res;
+
+    eval {
+	local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; };
+	local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" };
+	local $SIG{__DIE__};   # see SA bug 4631
+
+	alarm($timeout);
+
+	eval { $res = &$code(@param); };
+
+	alarm(0); # avoid race conditions
+
+	die $@ if $@;
+    };
+
+    my $err = $@;
+
+    alarm $prev_alarm;
+
+    # this shouldn't happen anymore?
+    die "unknown error" if $sigcount && !$err; # seems to happen sometimes
+
+    die $err if $err;
+
+    return $res;
+}
+
+# flock: we use one file handle per process, so lock file
+# can be nested multiple times and succeeds for the same process.
+#
+# Since this is the only way we lock now and we don't have the old
+# 'lock(); code(); unlock();' pattern anymore we do not actually need to
+# count how deep we're nesting. Therefore this hash now stores a weak reference
+# to a boolean telling us whether we already have a lock.
+
+my $lock_handles =  {};
+
+sub lock_file_full {
+    my ($filename, $timeout, $shared, $code, @param) = @_;
+
+    $timeout = 10 if !$timeout;
+
+    my $mode = $shared ? LOCK_SH : LOCK_EX;
+
+    my $lockhash = ($lock_handles->{$$} //= {});
+
+    # Returns a locked file handle.
+    my $get_locked_file = sub {
+	my $fh = IO::File->new(">>$filename")
+	    or die "can't open file - $!\n";
+
+	if (!flock($fh, $mode|LOCK_NB)) {
+	    print STDERR "trying to acquire lock...\n";
+	    my $success;
+	    while(1) {
+		$success = flock($fh, $mode);
+		# try again on EINTR (see bug #273)
+		if ($success || ($! != EINTR)) {
+		    last;
+		}
+	    }
+	    if (!$success) {
+		print STDERR " failed\n";
+		die "can't acquire lock '$filename' - $!\n";
+	    }
+	    print STDERR " OK\n";
+	}
+
+	return $fh;
+    };
+
+    my $res;
+    my $checkptr = $lockhash->{$filename};
+    my $check = 0; # This must not go out of scope before running the code.
+    my $local_fh; # This must stay local
+    if (!$checkptr || !$$checkptr) {
+	# We cannot create a weak reference in a single atomic step, so we first
+	# create a false-value, then create a reference to it, then weaken it,
+	# and after successfully locking the file we change the boolean value.
+	#
+	# The reason for this is that if an outer SIGALRM throws an exception
+	# between creating the reference and weakening it, a subsequent call to
+	# lock_file_full() will see a leftover full reference to a valid
+	# variable. This variable must be 0 in order for said call to attempt to
+	# lock the file anew.
+	#
+	# An externally triggered exception elsewhere in the code will cause the
+	# weak reference to become 'undef', and since the file handle is only
+	# stored in the local scope in $local_fh, the file will be closed by
+	# perl's cleanup routines as well.
+	#
+	# This still assumes that an IO::File handle can properly deal with such
+	# exceptions thrown during its own destruction, but that's up to perls
+	# guts now.
+	$lockhash->{$filename} = \$check;
+	weaken $lockhash->{$filename};
+	$local_fh = eval { run_with_timeout($timeout, $get_locked_file) };
+	if ($@) {
+	    $@ = "can't lock file '$filename' - $@";
+	    return undef;
+	}
+	$check = 1;
+    }
+    $res = eval { &$code(@param); };
+    return undef if $@;
+    return $res;
+}
+
+
+sub lock_file {
+    my ($filename, $timeout, $code, @param) = @_;
+
+    return lock_file_full($filename, $timeout, 0, $code, @param);
+}
+
 sub file_set_contents {
     my ($filename, $data, $perm)  = @_;
 
-- 
2.39.2