data/PVE/Tools.pm

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