PVE/APIClient/Tools.pm

   1 package PVE::APIClient::Tools;
   2
   3 use strict;
   4 use warnings;
   5 use POSIX qw(EINTR EEXIST EOPNOTSUPP);
   6 use base 'Exporter';
   7
   8 use IO::File;
   9 use Text::ParseWords;
  10 use Fcntl qw(:DEFAULT :flock);
  11 use Scalar::Util 'weaken';
  12
  13 our @EXPORT_OK = qw(
  14 $IPV6RE
  15 $IPV4RE
  16 split_list
  17 file_set_contents
  18 file_get_contents
  19 extract_param
  20 );
  21
  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))";
  26
  27 our $IPV6RE = "(?:" .
  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)?::" .                    ")))";
  37
  38 our $IPRE = "(?:$IPV4RE|$IPV6RE)";
  39
  40 sub run_with_timeout {
  41     my ($timeout, $code, @param) = @_;
  42
  43     die "got timeout\n" if $timeout <= 0;
  44
  45     my $prev_alarm = alarm 0; # suspend outer alarm early
  46
  47     my $sigcount = 0;
  48
  49     my $res;
  50
  51     eval {
  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
  55
  56         alarm($timeout);
  57
  58         eval { $res = &$code(@param); };
  59
  60         alarm(0); # avoid race conditions
  61
  62         die $@ if $@;
  63     };
  64
  65     my $err = $@;
  66
  67     alarm $prev_alarm;
  68
  69     # this shouldn't happen anymore?
  70     die "unknown error" if $sigcount && !$err; # seems to happen sometimes
  71
  72     die $err if $err;
  73
  74     return $res;
  75 }
  76
  77 # flock: we use one file handle per process, so lock file
  78 # can be nested multiple times and succeeds for the same process.
  79 #
  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.
  84
  85 my $lock_handles =  {};
  86
  87 sub lock_file_full {
  88     my ($filename, $timeout, $shared, $code, @param) = @_;
  89
  90     $timeout = 10 if !$timeout;
  91
  92     my $mode = $shared ? LOCK_SH : LOCK_EX;
  93
  94     my $lockhash = ($lock_handles->{$$} //= {});
  95
  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";
 100
 101         if (!flock($fh, $mode|LOCK_NB)) {
 102             print STDERR "trying to acquire lock...\n";
 103             my $success;
 104             while(1) {
 105                 $success = flock($fh, $mode);
 106                 # try again on EINTR (see bug #273)
 107                 if ($success || ($! != EINTR)) {
 108                     last;
 109                 }
 110             }
 111             if (!$success) {
 112                 print STDERR " failed\n";
 113                 die "can't acquire lock '$filename' - $!\n";
 114             }
 115             print STDERR " OK\n";
 116         }
 117
 118         return $fh;
 119     };
 120
 121     my $res;
 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.
 129         #
 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.
 135         #
 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.
 140         #
 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
 143         # guts now.
 144         $lockhash->{$filename} = \$check;
 145         weaken $lockhash->{$filename};
 146         $local_fh = eval { run_with_timeout($timeout, $get_locked_file) };
 147         if ($@) {
 148             $@ = "can't lock file '$filename' - $@";
 149             return undef;
 150         }
 151         $check = 1;
 152     }
 153     $res = eval { &$code(@param); };
 154     return undef if $@;
 155     return $res;
 156 }
 157
 158
 159 sub lock_file {
 160     my ($filename, $timeout, $code, @param) = @_;
 161
 162     return lock_file_full($filename, $timeout, 0, $code, @param);
 163 }
 164
 165 sub file_set_contents {
 166     my ($filename, $data, $perm)  = @_;
 167
 168     $perm = 0644 if !defined($perm);
 169
 170     my $tmpname = "$filename.tmp.$$";
 171
 172     eval {
 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";
 178             }
 179         }
 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;
 183     };
 184     my $err = $@;
 185
 186     if ($err) {
 187         unlink $tmpname;
 188         die $err;
 189     }
 190
 191     if (!rename($tmpname, $filename)) {
 192         my $msg = "close (rename) atomic file '$filename' failed: $!\n";
 193         unlink $tmpname;
 194         die $msg;
 195     }
 196 }
 197
 198 sub file_get_contents {
 199     my ($filename, $max) = @_;
 200
 201     my $fh = IO::File->new($filename, "r") ||
 202         die "can't open '$filename' - $!\n";
 203
 204     my $content = safe_read_from($fh, $max, 0, $filename);
 205
 206     close $fh;
 207
 208     return $content;
 209 }
 210
 211 sub file_read_firstline {
 212     my ($filename) = @_;
 213
 214     my $fh = IO::File->new ($filename, "r");
 215     return undef if !$fh;
 216     my $res = <$fh>;
 217     chomp $res if $res;
 218     $fh->close;
 219     return $res;
 220 }
 221
 222 sub safe_read_from {
 223     my ($fh, $max, $oneline, $filename) = @_;
 224
 225     $max = 32768 if !$max;
 226
 227     my $subject = defined($filename) ? "file '$filename'" : 'input';
 228
 229     my $br = 0;
 230     my $input = '';
 231     my $count;
 232     while ($count = sysread($fh, $input, 8192, $br)) {
 233         $br += $count;
 234         die "$subject too long - aborting\n" if $br > $max;
 235         if ($oneline && $input =~ m/^(.*)\n/) {
 236             $input = $1;
 237             last;
 238         }
 239     }
 240     die "unable to read $subject - $!\n" if !defined($count);
 241
 242     return $input;
 243 }
 244
 245 sub split_list {
 246     my $listtxt = shift || '';
 247
 248     return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
 249
 250     $listtxt =~ s/[,;]/ /g;
 251     $listtxt =~ s/^\s+//;
 252
 253     my @data = split (/\s+/, $listtxt);
 254
 255     return @data;
 256 }
 257
 258 # split an shell argument string into an array,
 259 sub split_args {
 260     my ($str) = @_;
 261
 262     return $str ? [ Text::ParseWords::shellwords($str) ] : [];
 263 }
 264
 265 sub extract_param {
 266     my ($param, $key) = @_;
 267
 268     my $res = $param->{$key};
 269     delete $param->{$key};
 270
 271     return $res;
 272 }
 273
 274 1;