]>
git.proxmox.com Git - pve-client.git/blob - PVE/APIClient/Tools.pm
1 package PVE
::APIClient
::Tools
;
5 use POSIX
qw(EINTR EEXIST EOPNOTSUPP);
10 use Fcntl
qw(:DEFAULT :flock);
11 use Scalar
::Util
'weaken';
22 my $IPV4OCTET = "(?:25[0-5]|(?:2[0-4]|1[0-9]|[1-9])?[0-9])";
23 our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)";
24 my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})";
25 my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))";
28 "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" .
29 "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" .
30 "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" .
31 "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" .
32 "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" .
33 "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" .
34 "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" .
35 "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" .
36 "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))";
38 our $IPRE = "(?:$IPV4RE|$IPV6RE)";
40 sub run_with_timeout
{
41 my ($timeout, $code, @param) = @_;
43 die "got timeout\n" if $timeout <= 0;
45 my $prev_alarm = alarm 0; # suspend outer alarm early
52 local $SIG{ALRM
} = sub { $sigcount++; die "got timeout\n"; };
53 local $SIG{PIPE
} = sub { $sigcount++; die "broken pipe\n" };
54 local $SIG{__DIE__
}; # see SA bug 4631
58 eval { $res = &$code(@param); };
60 alarm(0); # avoid race conditions
69 # this shouldn't happen anymore?
70 die "unknown error" if $sigcount && !$err; # seems to happen sometimes
77 # flock: we use one file handle per process, so lock file
78 # can be nested multiple times and succeeds for the same process.
80 # Since this is the only way we lock now and we don't have the old
81 # 'lock(); code(); unlock();' pattern anymore we do not actually need to
82 # count how deep we're nesting. Therefore this hash now stores a weak reference
83 # to a boolean telling us whether we already have a lock.
85 my $lock_handles = {};
88 my ($filename, $timeout, $shared, $code, @param) = @_;
90 $timeout = 10 if !$timeout;
92 my $mode = $shared ? LOCK_SH
: LOCK_EX
;
94 my $lockhash = ($lock_handles->{$$} //= {});
96 # Returns a locked file handle.
97 my $get_locked_file = sub {
98 my $fh = IO
::File-
>new(">>$filename")
99 or die "can't open file - $!\n";
101 if (!flock($fh, $mode|LOCK_NB
)) {
102 print STDERR
"trying to acquire lock...\n";
105 $success = flock($fh, $mode);
106 # try again on EINTR (see bug #273)
107 if ($success || ($! != EINTR
)) {
112 print STDERR
" failed\n";
113 die "can't acquire lock '$filename' - $!\n";
115 print STDERR
" OK\n";
122 my $checkptr = $lockhash->{$filename};
123 my $check = 0; # This must not go out of scope before running the code.
124 my $local_fh; # This must stay local
125 if (!$checkptr || !$$checkptr) {
126 # We cannot create a weak reference in a single atomic step, so we first
127 # create a false-value, then create a reference to it, then weaken it,
128 # and after successfully locking the file we change the boolean value.
130 # The reason for this is that if an outer SIGALRM throws an exception
131 # between creating the reference and weakening it, a subsequent call to
132 # lock_file_full() will see a leftover full reference to a valid
133 # variable. This variable must be 0 in order for said call to attempt to
134 # lock the file anew.
136 # An externally triggered exception elsewhere in the code will cause the
137 # weak reference to become 'undef', and since the file handle is only
138 # stored in the local scope in $local_fh, the file will be closed by
139 # perl's cleanup routines as well.
141 # This still assumes that an IO::File handle can properly deal with such
142 # exceptions thrown during its own destruction, but that's up to perls
144 $lockhash->{$filename} = \
$check;
145 weaken
$lockhash->{$filename};
146 $local_fh = eval { run_with_timeout
($timeout, $get_locked_file) };
148 $@ = "can't lock file '$filename' - $@";
153 $res = eval { &$code(@param); };
160 my ($filename, $timeout, $code, @param) = @_;
162 return lock_file_full
($filename, $timeout, 0, $code, @param);
165 sub file_set_contents
{
166 my ($filename, $data, $perm) = @_;
168 $perm = 0644 if !defined($perm);
170 my $tmpname = "$filename.tmp.$$";
173 my ($fh, $tries) = (undef, 0);
174 while (!$fh && $tries++ < 3) {
175 $fh = IO
::File-
>new($tmpname, O_WRONLY
|O_CREAT
|O_EXCL
, $perm);
176 if (!$fh && $! == EEXIST
) {
177 unlink($tmpname) or die "unable to delete old temp file: $!\n";
180 die "unable to open file '$tmpname' - $!\n" if !$fh;
181 die "unable to write '$tmpname' - $!\n" unless print $fh $data;
182 die "closing file '$tmpname' failed - $!\n" unless close $fh;
191 if (!rename($tmpname, $filename)) {
192 my $msg = "close (rename) atomic file '$filename' failed: $!\n";
198 sub file_get_contents
{
199 my ($filename, $max) = @_;
201 my $fh = IO
::File-
>new($filename, "r") ||
202 die "can't open '$filename' - $!\n";
204 my $content = safe_read_from
($fh, $max, 0, $filename);
211 sub file_read_firstline
{
214 my $fh = IO
::File-
>new ($filename, "r");
215 return undef if !$fh;
223 my ($fh, $max, $oneline, $filename) = @_;
225 $max = 32768 if !$max;
227 my $subject = defined($filename) ?
"file '$filename'" : 'input';
232 while ($count = sysread($fh, $input, 8192, $br)) {
234 die "$subject too long - aborting\n" if $br > $max;
235 if ($oneline && $input =~ m/^(.*)\n/) {
240 die "unable to read $subject - $!\n" if !defined($count);
246 my $listtxt = shift || '';
248 return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
250 $listtxt =~ s/[,;]/ /g;
251 $listtxt =~ s/^\s+//;
253 my @data = split (/\s+/, $listtxt);
258 # split an shell argument string into an array,
262 return $str ?
[ Text
::ParseWords
::shellwords
($str) ] : [];
266 my ($param, $key) = @_;
268 my $res = $param->{$key};
269 delete $param->{$key};