data/PVE/Tools.pm

   1 package PVE::Tools;
   2
   3 use strict;
   4 use warnings;
   5 use POSIX qw(EINTR);
   6 use IO::Socket::INET;
   7 use IO::Select;
   8 use File::Basename;
   9 use File::Path qw(make_path);
  10 use IO::File;
  11 use IO::Dir;
  12 use IPC::Open3;
  13 use Fcntl qw(:DEFAULT :flock);
  14 use base 'Exporter';
  15 use URI::Escape;
  16 use Encode;
  17 use Digest::SHA;
  18 use Text::ParseWords;
  19 use String::ShellQuote;
  20 use Time::HiRes qw(usleep gettimeofday tv_interval);
  21
  22 # avoid warning when parsing long hex values with hex()
  23 no warnings 'portable'; # Support for 64-bit ints required
  24
  25 our @EXPORT_OK = qw(
  26 $IPV6RE
  27 $IPV4RE
  28 lock_file
  29 lock_file_full
  30 run_command
  31 file_set_contents
  32 file_get_contents
  33 file_read_firstline
  34 dir_glob_regex
  35 dir_glob_foreach
  36 split_list
  37 template_replace
  38 safe_print
  39 trim
  40 extract_param
  41 );
  42
  43 my $pvelogdir = "/var/log/pve";
  44 my $pvetaskdir = "$pvelogdir/tasks";
  45
  46 mkdir $pvelogdir;
  47 mkdir $pvetaskdir;
  48
  49 my $IPV4OCTET = "(?:25[0-5]|(?:[1-9]|1[0-9]|2[0-4])?[0-9])";
  50 our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)";
  51 my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})";
  52 my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))";
  53
  54 our $IPV6RE = "(?:" .
  55     "(?:(?:" .                             "(?:$IPV6H16:){6})$IPV6LS32)|" .
  56     "(?:(?:" .                           "::(?:$IPV6H16:){5})$IPV6LS32)|" .
  57     "(?:(?:(?:" .              "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" .
  58     "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" .
  59     "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" .
  60     "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" .
  61     "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" .           ")$IPV6LS32)|" .
  62     "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" .            ")$IPV6H16)|" .
  63     "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" .                    ")))";
  64
  65 sub run_with_timeout {
  66     my ($timeout, $code, @param) = @_;
  67
  68     die "got timeout\n" if $timeout <= 0;
  69
  70     my $prev_alarm;
  71
  72     my $sigcount = 0;
  73
  74     my $res;
  75
  76     local $SIG{ALRM} = sub { $sigcount++; }; # catch alarm outside eval
  77
  78     eval {
  79         local $SIG{ALRM} = sub { $sigcount++; die "got timeout\n"; };
  80         local $SIG{PIPE} = sub { $sigcount++; die "broken pipe\n" };
  81         local $SIG{__DIE__};   # see SA bug 4631
  82
  83         $prev_alarm = alarm($timeout);
  84
  85         $res = &$code(@param);
  86
  87         alarm(0); # avoid race conditions
  88     };
  89
  90     my $err = $@;
  91
  92     alarm($prev_alarm) if defined($prev_alarm);
  93
  94     die "unknown error" if $sigcount && !$err; # seems to happen sometimes
  95
  96     die $err if $err;
  97
  98     return $res;
  99 }
 100
 101 # flock: we use one file handle per process, so lock file
 102 # can be called multiple times and succeeds for the same process.
 103
 104 my $lock_handles =  {};
 105
 106 sub lock_file_full {
 107     my ($filename, $timeout, $shared, $code, @param) = @_;
 108
 109     $timeout = 10 if !$timeout;
 110
 111     my $mode = $shared ? LOCK_SH : LOCK_EX;
 112
 113     my $lock_func = sub {
 114         if (!$lock_handles->{$$}->{$filename}) {
 115             $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") ||
 116                 die "can't open file - $!\n";
 117         }
 118
 119         if (!flock ($lock_handles->{$$}->{$filename}, $mode|LOCK_NB)) {
 120             print STDERR "trying to aquire lock...";
 121             my $success;
 122             while(1) {
 123                 $success = flock($lock_handles->{$$}->{$filename}, $mode);
 124                 # try again on EINTR (see bug #273)
 125                 if ($success || ($! != EINTR)) {
 126                     last;
 127                 }
 128             }
 129             if (!$success) {
 130                 print STDERR " failed\n";
 131                 die "can't aquire lock - $!\n";
 132             }
 133             print STDERR " OK\n";
 134         }
 135     };
 136
 137     my $res;
 138
 139     eval { run_with_timeout($timeout, $lock_func); };
 140     my $err = $@;
 141     if ($err) {
 142         $err = "can't lock file '$filename' - $err";
 143     } else {
 144         eval { $res = &$code(@param) };
 145         $err = $@;
 146     }
 147
 148     if (my $fh = $lock_handles->{$$}->{$filename}) {
 149         $lock_handles->{$$}->{$filename} = undef;
 150         close ($fh);
 151     }
 152
 153     if ($err) {
 154         $@ = $err;
 155         return undef;
 156     }
 157
 158     $@ = undef;
 159
 160     return $res;
 161 }
 162
 163
 164 sub lock_file {
 165     my ($filename, $timeout, $code, @param) = @_;
 166
 167     return lock_file_full($filename, $timeout, 0, $code, @param);
 168 }
 169
 170 sub file_set_contents {
 171     my ($filename, $data, $perm)  = @_;
 172
 173     $perm = 0644 if !defined($perm);
 174
 175     my $tmpname = "$filename.tmp.$$";
 176
 177     eval {
 178         my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm);
 179         die "unable to open file '$tmpname' - $!\n" if !$fh;
 180         die "unable to write '$tmpname' - $!\n" unless print $fh $data;
 181         die "closing file '$tmpname' failed - $!\n" unless close $fh;
 182     };
 183     my $err = $@;
 184
 185     if ($err) {
 186         unlink $tmpname;
 187         die $err;
 188     }
 189
 190     if (!rename($tmpname, $filename)) {
 191         my $msg = "close (rename) atomic file '$filename' failed: $!\n";
 192         unlink $tmpname;
 193         die $msg;
 194     }
 195 }
 196
 197 sub file_get_contents {
 198     my ($filename, $max) = @_;
 199
 200     my $fh = IO::File->new($filename, "r") ||
 201         die "can't open '$filename' - $!\n";
 202
 203     my $content = safe_read_from($fh, $max);
 204
 205     close $fh;
 206
 207     return $content;
 208 }
 209
 210 sub file_read_firstline {
 211     my ($filename) = @_;
 212
 213     my $fh = IO::File->new ($filename, "r");
 214     return undef if !$fh;
 215     my $res = <$fh>;
 216     chomp $res if $res;
 217     $fh->close;
 218     return $res;
 219 }
 220
 221 sub safe_read_from {
 222     my ($fh, $max, $oneline) = @_;
 223
 224     $max = 32768 if !$max;
 225
 226     my $br = 0;
 227     my $input = '';
 228     my $count;
 229     while ($count = sysread($fh, $input, 8192, $br)) {
 230         $br += $count;
 231         die "input too long - aborting\n" if $br > $max;
 232         if ($oneline && $input =~ m/^(.*)\n/) {
 233             $input = $1;
 234             last;
 235         }
 236     }
 237     die "unable to read input - $!\n" if !defined($count);
 238
 239     return $input;
 240 }
 241
 242 sub run_command {
 243     my ($cmd, %param) = @_;
 244
 245     my $old_umask;
 246     my $cmdstr;
 247
 248     if (!ref($cmd)) {
 249         $cmdstr = $cmd;
 250         if ($cmd =~ m/|/) {
 251             # see 'man bash' for option pipefail
 252             $cmd = [ '/bin/bash', '-c', "set -o pipefail && $cmd" ];
 253         } else {
 254             $cmd = [ $cmd ];
 255         }
 256     } else {
 257         $cmdstr = cmd2string($cmd);
 258     }
 259
 260     my $errmsg;
 261     my $laststderr;
 262     my $timeout;
 263     my $oldtimeout;
 264     my $pid;
 265
 266     my $outfunc;
 267     my $errfunc;
 268     my $logfunc;
 269     my $input;
 270     my $output;
 271     my $afterfork;
 272
 273     eval {
 274
 275         foreach my $p (keys %param) {
 276             if ($p eq 'timeout') {
 277                 $timeout = $param{$p};
 278             } elsif ($p eq 'umask') {
 279                 $old_umask = umask($param{$p});
 280             } elsif ($p eq 'errmsg') {
 281                 $errmsg = $param{$p};
 282             } elsif ($p eq 'input') {
 283                 $input = $param{$p};
 284             } elsif ($p eq 'output') {
 285                 $output = $param{$p};
 286             } elsif ($p eq 'outfunc') {
 287                 $outfunc = $param{$p};
 288             } elsif ($p eq 'errfunc') {
 289                 $errfunc = $param{$p};
 290             } elsif ($p eq 'logfunc') {
 291                 $logfunc = $param{$p};
 292             } elsif ($p eq 'afterfork') {
 293                 $afterfork = $param{$p};
 294             } else {
 295                 die "got unknown parameter '$p' for run_command\n";
 296             }
 297         }
 298
 299         if ($errmsg) {
 300             my $origerrfunc = $errfunc;
 301             $errfunc = sub {
 302                 if ($laststderr) {
 303                     if ($origerrfunc) {
 304                         &$origerrfunc("$laststderr\n");
 305                     } else {
 306                         print STDERR "$laststderr\n" if $laststderr;
 307                     }
 308                 }
 309                 $laststderr = shift;
 310             };
 311         }
 312
 313         my $reader = $output && $output =~ m/^>&/ ? $output : IO::File->new();
 314         my $writer = $input && $input =~ m/^<&/ ? $input : IO::File->new();
 315         my $error  = IO::File->new();
 316
 317         # try to avoid locale related issues/warnings
 318         my $lang = $param{lang} || 'C';
 319
 320         my $orig_pid = $$;
 321
 322         eval {
 323             local $ENV{LC_ALL} = $lang;
 324
 325             # suppress LVM warnings like: "File descriptor 3 left open";
 326             local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1";
 327
 328             $pid = open3($writer, $reader, $error, @$cmd) || die $!;
 329
 330             # if we pipe fron STDIN, open3 closes STDIN, so we we
 331             # a perl warning "Filehandle STDIN reopened as GENXYZ .. "
 332             # as soon as we open a new file.
 333             # to avoid that we open /dev/null
 334             if (!ref($writer) && !defined(fileno(STDIN))) {
 335                 POSIX::close(0);
 336                 open(STDIN, "</dev/null");
 337             }
 338         };
 339
 340         my $err = $@;
 341
 342         # catch exec errors
 343         if ($orig_pid != $$) {
 344             warn "ERROR: $err";
 345             POSIX::_exit (1);
 346             kill ('KILL', $$);
 347         }
 348
 349         die $err if $err;
 350
 351         local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
 352         $oldtimeout = alarm($timeout) if $timeout;
 353
 354         &$afterfork() if $afterfork;
 355
 356         if (ref($writer)) {
 357             print $writer $input if defined $input;
 358             close $writer;
 359         }
 360
 361         my $select = new IO::Select;
 362         $select->add($reader) if ref($reader);
 363         $select->add($error);
 364
 365         my $outlog = '';
 366         my $errlog = '';
 367
 368         my $starttime = time();
 369
 370         while ($select->count) {
 371             my @handles = $select->can_read(1);
 372
 373             foreach my $h (@handles) {
 374                 my $buf = '';
 375                 my $count = sysread ($h, $buf, 4096);
 376                 if (!defined ($count)) {
 377                     my $err = $!;
 378                     kill (9, $pid);
 379                     waitpid ($pid, 0);
 380                     die $err;
 381                 }
 382                 $select->remove ($h) if !$count;
 383                 if ($h eq $reader) {
 384                     if ($outfunc || $logfunc) {
 385                         eval {
 386                             $outlog .= $buf;
 387                             while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 388                                 my $line = $1;
 389                                 &$outfunc($line) if $outfunc;
 390                                 &$logfunc($line) if $logfunc;
 391                             }
 392                         };
 393                         my $err = $@;
 394                         if ($err) {
 395                             kill (9, $pid);
 396                             waitpid ($pid, 0);
 397                             die $err;
 398                         }
 399                     } else {
 400                         print $buf;
 401                         *STDOUT->flush();
 402                     }
 403                 } elsif ($h eq $error) {
 404                     if ($errfunc || $logfunc) {
 405                         eval {
 406                             $errlog .= $buf;
 407                             while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
 408                                 my $line = $1;
 409                                 &$errfunc($line) if $errfunc;
 410                                 &$logfunc($line) if $logfunc;
 411                             }
 412                         };
 413                         my $err = $@;
 414                         if ($err) {
 415                             kill (9, $pid);
 416                             waitpid ($pid, 0);
 417                             die $err;
 418                         }
 419                     } else {
 420                         print STDERR $buf;
 421                         *STDERR->flush();
 422                     }
 423                 }
 424             }
 425         }
 426
 427         &$outfunc($outlog) if $outfunc && $outlog;
 428         &$logfunc($outlog) if $logfunc && $outlog;
 429
 430         &$errfunc($errlog) if $errfunc && $errlog;
 431         &$logfunc($errlog) if $logfunc && $errlog;
 432
 433         waitpid ($pid, 0);
 434
 435         if ($? == -1) {
 436             die "failed to execute\n";
 437         } elsif (my $sig = ($? & 127)) {
 438             die "got signal $sig\n";
 439         } elsif (my $ec = ($? >> 8)) {
 440             if (!($ec == 24 && ($cmdstr =~ m|^(\S+/)?rsync\s|))) {
 441                 if ($errmsg && $laststderr) {
 442                     my $lerr = $laststderr;
 443                     $laststderr = undef;
 444                     die "$lerr\n";
 445                 }
 446                 die "exit code $ec\n";
 447             }
 448         }
 449
 450         alarm(0);
 451     };
 452
 453     my $err = $@;
 454
 455     alarm(0);
 456
 457     if ($errmsg && $laststderr) {
 458         &$errfunc(undef); # flush laststderr
 459     }
 460
 461     umask ($old_umask) if defined($old_umask);
 462
 463     alarm($oldtimeout) if $oldtimeout;
 464
 465     if ($err) {
 466         if ($pid && ($err eq "got timeout\n")) {
 467             kill (9, $pid);
 468             waitpid ($pid, 0);
 469             die "command '$cmdstr' failed: $err";
 470         }
 471
 472         if ($errmsg) {
 473             $err =~ s/^usermod:\s*// if $cmdstr =~ m|^(\S+/)?usermod\s|;
 474             die "$errmsg: $err";
 475         } else {
 476             die "command '$cmdstr' failed: $err";
 477         }
 478     }
 479
 480     return undef;
 481 }
 482
 483 sub split_list {
 484     my $listtxt = shift || '';
 485
 486     return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
 487
 488     $listtxt =~ s/[,;]/ /g;
 489     $listtxt =~ s/^\s+//;
 490
 491     my @data = split (/\s+/, $listtxt);
 492
 493     return @data;
 494 }
 495
 496 sub trim {
 497     my $txt = shift;
 498
 499     return $txt if !defined($txt);
 500
 501     $txt =~ s/^\s+//;
 502     $txt =~ s/\s+$//;
 503
 504     return $txt;
 505 }
 506
 507 # simple uri templates like "/vms/{vmid}"
 508 sub template_replace {
 509     my ($tmpl, $data) = @_;
 510
 511     return $tmpl if !$tmpl;
 512
 513     my $res = '';
 514     while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) {
 515         $res .= $1 if $1;
 516         $res .= ($data->{$3} || '-') if $2;
 517     }
 518     return $res;
 519 }
 520
 521 sub safe_print {
 522     my ($filename, $fh, $data) = @_;
 523
 524     return if !$data;
 525
 526     my $res = print $fh $data;
 527
 528     die "write to '$filename' failed\n" if !$res;
 529 }
 530
 531 sub debmirrors {
 532
 533     return {
 534         'at' => 'ftp.at.debian.org',
 535         'au' => 'ftp.au.debian.org',
 536         'be' => 'ftp.be.debian.org',
 537         'bg' => 'ftp.bg.debian.org',
 538         'br' => 'ftp.br.debian.org',
 539         'ca' => 'ftp.ca.debian.org',
 540         'ch' => 'ftp.ch.debian.org',
 541         'cl' => 'ftp.cl.debian.org',
 542         'cz' => 'ftp.cz.debian.org',
 543         'de' => 'ftp.de.debian.org',
 544         'dk' => 'ftp.dk.debian.org',
 545         'ee' => 'ftp.ee.debian.org',
 546         'es' => 'ftp.es.debian.org',
 547         'fi' => 'ftp.fi.debian.org',
 548         'fr' => 'ftp.fr.debian.org',
 549         'gr' => 'ftp.gr.debian.org',
 550         'hk' => 'ftp.hk.debian.org',
 551         'hr' => 'ftp.hr.debian.org',
 552         'hu' => 'ftp.hu.debian.org',
 553         'ie' => 'ftp.ie.debian.org',
 554         'is' => 'ftp.is.debian.org',
 555         'it' => 'ftp.it.debian.org',
 556         'jp' => 'ftp.jp.debian.org',
 557         'kr' => 'ftp.kr.debian.org',
 558         'mx' => 'ftp.mx.debian.org',
 559         'nl' => 'ftp.nl.debian.org',
 560         'no' => 'ftp.no.debian.org',
 561         'nz' => 'ftp.nz.debian.org',
 562         'pl' => 'ftp.pl.debian.org',
 563         'pt' => 'ftp.pt.debian.org',
 564         'ro' => 'ftp.ro.debian.org',
 565         'ru' => 'ftp.ru.debian.org',
 566         'se' => 'ftp.se.debian.org',
 567         'si' => 'ftp.si.debian.org',
 568         'sk' => 'ftp.sk.debian.org',
 569         'tr' => 'ftp.tr.debian.org',
 570         'tw' => 'ftp.tw.debian.org',
 571         'gb' => 'ftp.uk.debian.org',
 572         'us' => 'ftp.us.debian.org',
 573     };
 574 }
 575
 576 my $keymaphash =  {
 577     'dk'     => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
 578     'de'     => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
 579     'de-ch'  => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz',  'ch', 'de_nodeadkeys' ],
 580     'en-gb'  => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', undef],
 581     'en-us'  => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz',  'us', undef ],
 582     'es'     => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
 583     #'et'     => [], # Ethopia or Estonia ??
 584     'fi'     => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
 585     #'fo'     => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'],
 586     'fr'     => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'],
 587     'fr-be'  => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'],
 588     'fr-ca'  => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'],
 589     'fr-ch'  => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'],
 590     #'hr'     => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2?
 591     'hu'     => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef],
 592     'is'     => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'],
 593     'it'     => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'],
 594     'jp'     => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef],
 595     'lt'     => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'],
 596     #'lv'     => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7?
 597     'mk'     => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'],
 598     'nl'     => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef],
 599     #'nl-be'  => ['Belgium-Dutch', 'nl-be', ?, ?, ?],
 600     'no'   => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'],
 601     'pl'     => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef],
 602     'pt'     => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'],
 603     'pt-br'  => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'],
 604     #'ru'     => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know?
 605     'si'     => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
 606     'se'     => ['Swedish', 'sv', 'qwerty/se-latin1.kmap.gz', 'se', 'nodeadkeys'],
 607     #'th'     => [],
 608     'tr'     => ['Turkish', 'tr', 'qwerty/trq.kmap.gz', 'tr', undef],
 609 };
 610
 611 my $kvmkeymaparray = [];
 612 foreach my $lc (keys %$keymaphash) {
 613     push @$kvmkeymaparray, $keymaphash->{$lc}->[1];
 614 }
 615
 616 sub kvmkeymaps {
 617     return $keymaphash;
 618 }
 619
 620 sub kvmkeymaplist {
 621     return $kvmkeymaparray;
 622 }
 623
 624 sub extract_param {
 625     my ($param, $key) = @_;
 626
 627     my $res = $param->{$key};
 628     delete $param->{$key};
 629
 630     return $res;
 631 }
 632
 633 # Note: we use this to wait until vncterm/spiceterm is ready
 634 sub wait_for_vnc_port {
 635     my ($port, $timeout) = @_;
 636
 637     $timeout = 5 if !$timeout;
 638     my $sleeptime = 0;
 639     my $starttime = [gettimeofday];
 640     my $elapsed;
 641
 642     while (($elapsed = tv_interval($starttime)) < $timeout) {
 643         if (my $fh = IO::File->new ("/proc/net/tcp", "r")) {
 644             while (defined (my $line = <$fh>)) {
 645                 if ($line =~ m/^\s*\d+:\s+([0-9A-Fa-f]{8}):([0-9A-Fa-f]{4})\s/) {
 646                     if ($port == hex($2)) {
 647                         close($fh);
 648                         return 1;
 649                     }
 650                 }
 651             }
 652             close($fh);
 653         }
 654         $sleeptime += 100000 if  $sleeptime < 1000000;
 655         usleep($sleeptime);
 656     }
 657
 658     return undef;
 659 }
 660
 661 sub next_unused_port {
 662     my ($range_start, $range_end) = @_;
 663
 664     # We use a file to register allocated ports.
 665     # Those registrations expires after $expiretime.
 666     # We use this to avoid race conditions between
 667     # allocation and use of ports.
 668
 669     my $filename = "/var/tmp/pve-reserved-ports";
 670
 671     my $code = sub {
 672
 673         my $expiretime = 5;
 674         my $ctime = time();
 675
 676         my $ports = {};
 677
 678         if (my $fh = IO::File->new ($filename, "r")) {
 679             while (my $line = <$fh>) {
 680                 if ($line =~ m/^(\d+)\s(\d+)$/) {
 681                     my ($port, $timestamp) = ($1, $2);
 682                     if (($timestamp + $expiretime) > $ctime) {
 683                         $ports->{$port} = $timestamp; # not expired
 684                     }
 685                 }
 686             }
 687         }
 688
 689         my $newport;
 690
 691         for (my $p = $range_start; $p < $range_end; $p++) {
 692             next if $ports->{$p}; # reserved
 693
 694             my $sock = IO::Socket::INET->new(Listen => 5,
 695                                              LocalAddr => 'localhost',
 696                                              LocalPort => $p,
 697                                              ReuseAddr => 1,
 698                                              Proto     => 0);
 699
 700             if ($sock) {
 701                 close($sock);
 702                 $newport = $p;
 703                 $ports->{$p} = $ctime;
 704                 last;
 705             }
 706         }
 707
 708         my $data = "";
 709         foreach my $p (keys %$ports) {
 710             $data .= "$p $ports->{$p}\n";
 711         }
 712
 713         file_set_contents($filename, $data);
 714
 715         return $newport;
 716     };
 717
 718     my $p = lock_file($filename, 10, $code);
 719     die $@ if $@;
 720
 721     die "unable to find free port (${range_start}-${range_end})\n" if !$p;
 722
 723     return $p;
 724 }
 725
 726 sub next_migrate_port {
 727     return next_unused_port(60000, 60010);
 728 }
 729
 730 sub next_vnc_port {
 731     return next_unused_port(5900, 6000);
 732 }
 733
 734 sub next_spice_port {
 735     return next_unused_port(61000, 61099);
 736 }
 737
 738 # NOTE: NFS syscall can't be interrupted, so alarm does
 739 # not work to provide timeouts.
 740 # from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation"
 741 # So the spawn external 'df' process instead of using
 742 # Filesys::Df (which uses statfs syscall)
 743 sub df {
 744     my ($path, $timeout) = @_;
 745
 746     my $cmd = [ 'df', '-P', '-B', '1', $path];
 747
 748     my $res = {
 749         total => 0,
 750         used => 0,
 751         avail => 0,
 752     };
 753
 754     my $parser = sub {
 755         my $line = shift;
 756         if (my ($fsid, $total, $used, $avail) = $line =~
 757             m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) {
 758             $res = {
 759                 total => $total,
 760                 used => $used,
 761                 avail => $avail,
 762             };
 763         }
 764     };
 765     eval { run_command($cmd, timeout => $timeout, outfunc => $parser); };
 766     warn $@ if $@;
 767
 768     return $res;
 769 }
 770
 771 # UPID helper
 772 # We use this to uniquely identify a process.
 773 # An 'Unique Process ID' has the following format:
 774 # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 775
 776 sub upid_encode {
 777     my $d = shift;
 778
 779     # Note: pstart can be > 32bit if uptime > 497 days, so this can result in
 780     # more that 8 characters for pstart
 781     return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
 782                    $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
 783                    $d->{user});
 784 }
 785
 786 sub upid_decode {
 787     my ($upid, $noerr) = @_;
 788
 789     my $res;
 790     my $filename;
 791
 792     # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
 793     # Note: allow up to 9 characters for pstart (work until 20 years uptime)
 794     if ($upid =~ m/^UPID:([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8,9}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) {
 795         $res->{node} = $1;
 796         $res->{pid} = hex($3);
 797         $res->{pstart} = hex($4);
 798         $res->{starttime} = hex($5);
 799         $res->{type} = $6;
 800         $res->{id} = $7;
 801         $res->{user} = $8;
 802
 803         my $subdir = substr($5, 7, 8);
 804         $filename = "$pvetaskdir/$subdir/$upid";
 805
 806     } else {
 807         return undef if $noerr;
 808         die "unable to parse worker upid '$upid'\n";
 809     }
 810
 811     return wantarray ? ($res, $filename) : $res;
 812 }
 813
 814 sub upid_open {
 815     my ($upid) = @_;
 816
 817     my ($task, $filename) = upid_decode($upid);
 818
 819     my $dirname = dirname($filename);
 820     make_path($dirname);
 821
 822     my $wwwid = getpwnam('www-data') ||
 823         die "getpwnam failed";
 824
 825     my $perm = 0640;
 826
 827     my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) ||
 828         die "unable to create output file '$filename' - $!\n";
 829     chown $wwwid, -1, $outfh;
 830
 831     return $outfh;
 832 };
 833
 834 sub upid_read_status {
 835     my ($upid) = @_;
 836
 837     my ($task, $filename) = upid_decode($upid);
 838     my $fh = IO::File->new($filename, "r");
 839     return "unable to open file - $!" if !$fh;
 840     my $maxlen = 4096;
 841     sysseek($fh, -$maxlen, 2);
 842     my $readbuf = '';
 843     my $br = sysread($fh, $readbuf, $maxlen);
 844     close($fh);
 845     if ($br) {
 846         return "unable to extract last line"
 847             if $readbuf !~ m/\n?(.+)$/;
 848         my $line = $1;
 849         if ($line =~ m/^TASK OK$/) {
 850             return 'OK';
 851         } elsif ($line =~ m/^TASK ERROR: (.+)$/) {
 852             return $1;
 853         } else {
 854             return "unexpected status";
 855         }
 856     }
 857     return "unable to read tail (got $br bytes)";
 858 }
 859
 860 # useful functions to store comments in config files
 861 sub encode_text {
 862     my ($text) = @_;
 863
 864     # all control and hi-bit characters, and ':'
 865     my $unsafe = "^\x20-\x39\x3b-\x7e";
 866     return uri_escape(Encode::encode("utf8", $text), $unsafe);
 867 }
 868
 869 sub decode_text {
 870     my ($data) = @_;
 871
 872     return Encode::decode("utf8", uri_unescape($data));
 873 }
 874
 875 sub decode_utf8_parameters {
 876     my ($param) = @_;
 877
 878     foreach my $p (qw(comment description firstname lastname)) {
 879         $param->{$p} = decode('utf8', $param->{$p}) if $param->{$p};
 880     }
 881
 882     return $param;
 883 }
 884
 885 sub random_ether_addr {
 886
 887     my ($seconds, $microseconds) = gettimeofday;
 888
 889     my $rand = Digest::SHA::sha1_hex($$, rand(), $seconds, $microseconds);
 890
 891     my $mac = '';
 892     for (my $i = 0; $i < 6; $i++) {
 893         my $ss = hex(substr($rand, $i*2, 2));
 894         if (!$i) {
 895             $ss &= 0xfe; # clear multicast
 896             $ss |= 2; # set local id
 897         }
 898         $ss = sprintf("%02X", $ss);
 899
 900         if (!$i) {
 901             $mac .= "$ss";
 902         } else {
 903             $mac .= ":$ss";
 904         }
 905     }
 906
 907     return $mac;
 908 }
 909
 910 sub shellquote {
 911     my $str = shift;
 912
 913     return String::ShellQuote::shell_quote($str);
 914 }
 915
 916 sub cmd2string {
 917     my ($cmd) = @_;
 918
 919     die "no arguments" if !$cmd;
 920
 921     return $cmd if !ref($cmd);
 922
 923     my @qa = ();
 924     foreach my $arg (@$cmd) { push @qa, shellquote($arg); }
 925
 926     return join (' ', @qa);
 927 }
 928
 929 # split an shell argument string into an array,
 930 sub split_args {
 931     my ($str) = @_;
 932
 933     return $str ? [ Text::ParseWords::shellwords($str) ] : [];
 934 }
 935
 936 sub dump_logfile {
 937     my ($filename, $start, $limit, $filter) = @_;
 938
 939     my $lines = [];
 940     my $count = 0;
 941
 942     my $fh = IO::File->new($filename, "r");
 943     if (!$fh) {
 944         $count++;
 945         push @$lines, { n => $count, t => "unable to open file - $!"};
 946         return ($count, $lines);
 947     }
 948
 949     $start = 0 if !$start;
 950     $limit = 50 if !$limit;
 951
 952     my $line;
 953
 954     if ($filter) {
 955         # duplicate code, so that we do not slow down normal path
 956         while (defined($line = <$fh>)) {
 957             next if $line !~ m/$filter/;
 958             next if $count++ < $start;
 959             next if $limit <= 0;
 960             chomp $line;
 961             push @$lines, { n => $count, t => $line};
 962             $limit--;
 963         }
 964     } else {
 965         while (defined($line = <$fh>)) {
 966             next if $count++ < $start;
 967             next if $limit <= 0;
 968             chomp $line;
 969             push @$lines, { n => $count, t => $line};
 970             $limit--;
 971         }
 972     }
 973
 974     close($fh);
 975
 976     # HACK: ExtJS store.guaranteeRange() does not like empty array
 977     # so we add a line
 978     if (!$count) {
 979         $count++;
 980         push @$lines, { n => $count, t => "no content"};
 981     }
 982
 983     return ($count, $lines);
 984 }
 985
 986 sub dir_glob_regex {
 987     my ($dir, $regex) = @_;
 988
 989     my $dh = IO::Dir->new ($dir);
 990     return wantarray ? () : undef if !$dh;
 991
 992     while (defined(my $tmp = $dh->read)) {
 993         if (my @res = $tmp =~ m/^($regex)$/) {
 994             $dh->close;
 995             return wantarray ? @res : $tmp;
 996         }
 997     }
 998     $dh->close;
 999
1000     return wantarray ? () : undef;
1001 }
1002
1003 sub dir_glob_foreach {
1004     my ($dir, $regex, $func) = @_;
1005
1006     my $dh = IO::Dir->new ($dir);
1007     if (defined $dh) {
1008         while (defined(my $tmp = $dh->read)) {
1009             if (my @res = $tmp =~ m/^($regex)$/) {
1010                 &$func (@res);
1011             }
1012         }
1013     }
1014 }
1015
1016 sub assert_if_modified {
1017     my ($digest1, $digest2) = @_;
1018
1019     if ($digest1 && $digest2 && ($digest1 ne $digest2)) {
1020         die "detected modified configuration - file changed by other user? Try again.\n";
1021     }
1022 }
1023
1024 # Digest for short strings
1025 # like FNV32a, but we only return 31 bits (positive numbers)
1026 sub fnv31a {
1027     my ($string) = @_;
1028
1029     my $hval = 0x811c9dc5;
1030
1031     foreach my $c (unpack('C*', $string)) {
1032         $hval ^= $c;
1033         $hval += (
1034             (($hval << 1) ) +
1035             (($hval << 4) ) +
1036             (($hval << 7) ) +
1037             (($hval << 8) ) +
1038             (($hval << 24) ) );
1039         $hval = $hval & 0xffffffff;
1040     }
1041     return $hval & 0x7fffffff;
1042 }
1043
1044 sub fnv31a_hex { return sprintf("%X", fnv31a(@_)); }
1045
1046 1;