package PVE::Tools;
use strict;
-use POSIX;
+use warnings;
+use POSIX qw(EINTR);
use IO::Socket::INET;
use IO::Select;
use File::Basename;
use File::Path qw(make_path);
use IO::File;
+use IO::Dir;
use IPC::Open3;
use Fcntl qw(:DEFAULT :flock);
use base 'Exporter';
use URI::Escape;
use Encode;
-use Digest::SHA1;
+use Digest::SHA;
use Text::ParseWords;
use String::ShellQuote;
+use Time::HiRes qw(usleep gettimeofday tv_interval);
+
+# avoid warning when parsing long hex values with hex()
+no warnings 'portable'; # Support for 64-bit ints required
our @EXPORT_OK = qw(
+$IPV6RE
+$IPV4RE
lock_file
+lock_file_full
run_command
file_set_contents
file_get_contents
file_read_firstline
+dir_glob_regex
+dir_glob_foreach
split_list
template_replace
safe_print
mkdir $pvelogdir;
mkdir $pvetaskdir;
+my $IPV4OCTET = "(?:25[0-5]|(?:[1-9]|1[0-9]|2[0-4])?[0-9])";
+our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)";
+my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})";
+my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))";
+
+our $IPV6RE = "(?:" .
+ "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" .
+ "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" .
+ "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))";
+
sub run_with_timeout {
my ($timeout, $code, @param) = @_;
my $lock_handles = {};
-sub lock_file {
- my ($filename, $timeout, $code, @param) = @_;
+sub lock_file_full {
+ my ($filename, $timeout, $shared, $code, @param) = @_;
$timeout = 10 if !$timeout;
+ my $mode = $shared ? LOCK_SH : LOCK_EX;
+
my $lock_func = sub {
if (!$lock_handles->{$$}->{$filename}) {
$lock_handles->{$$}->{$filename} = new IO::File (">>$filename") ||
die "can't open file - $!\n";
}
- if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX|LOCK_NB)) {
+ if (!flock ($lock_handles->{$$}->{$filename}, $mode|LOCK_NB)) {
print STDERR "trying to aquire lock...";
- if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX)) {
+ my $success;
+ while(1) {
+ $success = flock($lock_handles->{$$}->{$filename}, $mode);
+ # try again on EINTR (see bug #273)
+ if ($success || ($! != EINTR)) {
+ last;
+ }
+ }
+ if (!$success) {
print STDERR " failed\n";
die "can't aquire lock - $!\n";
}
$err = $@;
}
- if ($lock_handles->{$$}->{$filename}) {
- my $fh = $lock_handles->{$$}->{$filename};
+ if (my $fh = $lock_handles->{$$}->{$filename}) {
$lock_handles->{$$}->{$filename} = undef;
close ($fh);
}
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) = @_;
my $fh = IO::File->new ($filename, "r");
return undef if !$fh;
my $res = <$fh>;
- chomp $res;
+ chomp $res if $res;
$fh->close;
return $res;
}
if (!ref($cmd)) {
$cmdstr = $cmd;
- $cmd = [ $cmd ];
+ if ($cmd =~ m/|/) {
+ # see 'man bash' for option pipefail
+ $cmd = [ '/bin/bash', '-c', "set -o pipefail && $cmd" ];
+ } else {
+ $cmd = [ $cmd ];
+ }
} else {
$cmdstr = cmd2string($cmd);
}
my $logfunc;
my $input;
my $output;
+ my $afterfork;
eval {
if ($p eq 'timeout') {
$timeout = $param{$p};
} elsif ($p eq 'umask') {
- umask($param{$p});
+ $old_umask = umask($param{$p});
} elsif ($p eq 'errmsg') {
$errmsg = $param{$p};
} elsif ($p eq 'input') {
$errfunc = $param{$p};
} elsif ($p eq 'logfunc') {
$logfunc = $param{$p};
+ } elsif ($p eq 'afterfork') {
+ $afterfork = $param{$p};
} else {
die "got unknown parameter '$p' for run_command\n";
}
local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
$oldtimeout = alarm($timeout) if $timeout;
+ &$afterfork() if $afterfork;
+
if (ref($writer)) {
print $writer $input if defined $input;
close $writer;
}
if ($errmsg) {
+ $err =~ s/^usermod:\s*// if $cmdstr =~ m|^(\S+/)?usermod\s|;
die "$errmsg: $err";
} else {
die "command '$cmdstr' failed: $err";
'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ],
- 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', 'intl' ],
- 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', 'intl' ],
+ 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', undef],
+ 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', undef ],
'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
#'et' => [], # Ethopia or Estonia ??
'fi' => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
'se' => ['Swedish', 'sv', 'qwerty/se-latin1.kmap.gz', 'se', 'nodeadkeys'],
#'th' => [],
- #'tr' => [],
+ 'tr' => ['Turkish', 'tr', 'qwerty/trq.kmap.gz', 'tr', undef],
};
my $kvmkeymaparray = [];
return $res;
}
-sub next_vnc_port {
+# Note: we use this to wait until vncterm/spiceterm is ready
+sub wait_for_vnc_port {
+ my ($port, $timeout) = @_;
+
+ $timeout = 5 if !$timeout;
+ my $sleeptime = 0;
+ my $starttime = [gettimeofday];
+ my $elapsed;
+
+ while (($elapsed = tv_interval($starttime)) < $timeout) {
+ if (my $fh = IO::File->new ("/proc/net/tcp", "r")) {
+ while (defined (my $line = <$fh>)) {
+ if ($line =~ m/^\s*\d+:\s+([0-9A-Fa-f]{8}):([0-9A-Fa-f]{4})\s/) {
+ if ($port == hex($2)) {
+ close($fh);
+ return 1;
+ }
+ }
+ }
+ close($fh);
+ }
+ $sleeptime += 100000 if $sleeptime < 1000000;
+ usleep($sleeptime);
+ }
+
+ return undef;
+}
+
+sub next_unused_port {
+ my ($range_start, $range_end) = @_;
+
+ # We use a file to register allocated ports.
+ # Those registrations expires after $expiretime.
+ # We use this to avoid race conditions between
+ # allocation and use of ports.
+
+ my $filename = "/var/tmp/pve-reserved-ports";
+
+ my $code = sub {
- for (my $p = 5900; $p < 6000; $p++) {
+ my $expiretime = 5;
+ my $ctime = time();
- my $sock = IO::Socket::INET->new (Listen => 5,
- LocalAddr => 'localhost',
- LocalPort => $p,
- ReuseAddr => 1,
- Proto => 0);
+ my $ports = {};
- if ($sock) {
- close ($sock);
- return $p;
+ if (my $fh = IO::File->new ($filename, "r")) {
+ while (my $line = <$fh>) {
+ if ($line =~ m/^(\d+)\s(\d+)$/) {
+ my ($port, $timestamp) = ($1, $2);
+ if (($timestamp + $expiretime) > $ctime) {
+ $ports->{$port} = $timestamp; # not expired
+ }
+ }
+ }
}
- }
+
+ my $newport;
+
+ for (my $p = $range_start; $p < $range_end; $p++) {
+ next if $ports->{$p}; # reserved
+
+ my $sock = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => '0.0.0.0',
+ LocalPort => $p,
+ ReuseAddr => 1,
+ Proto => 0);
+
+ if ($sock) {
+ close($sock);
+ $newport = $p;
+ $ports->{$p} = $ctime;
+ last;
+ }
+ }
+
+ my $data = "";
+ foreach my $p (keys %$ports) {
+ $data .= "$p $ports->{$p}\n";
+ }
+
+ file_set_contents($filename, $data);
- die "unable to find free vnc port";
-};
+ return $newport;
+ };
+
+ my $p = lock_file($filename, 10, $code);
+ die $@ if $@;
+
+ die "unable to find free port (${range_start}-${range_end})\n" if !$p;
+
+ return $p;
+}
+
+sub next_migrate_port {
+ return next_unused_port(60000, 60010);
+}
+
+sub next_vnc_port {
+ return next_unused_port(5900, 6000);
+}
+
+sub next_spice_port {
+ return next_unused_port(61000, 61099);
+}
# NOTE: NFS syscall can't be interrupted, so alarm does
# not work to provide timeouts.
sub upid_encode {
my $d = shift;
+ # Note: pstart can be > 32bit if uptime > 497 days, so this can result in
+ # more that 8 characters for pstart
return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
$d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
$d->{user});
my $filename;
# "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
- if ($upid =~ m/^UPID:([A-Za-z][[:alnum:]\-]*[[:alnum:]]+):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) {
+ # Note: allow up to 9 characters for pstart (work until 20 years uptime)
+ 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]+):$/) {
$res->{node} = $1;
- $res->{pid} = hex($2);
- $res->{pstart} = hex($3);
- $res->{starttime} = hex($4);
- $res->{type} = $5;
- $res->{id} = $6;
- $res->{user} = $7;
-
- my $subdir = substr($4, 7, 8);
+ $res->{pid} = hex($3);
+ $res->{pstart} = hex($4);
+ $res->{starttime} = hex($5);
+ $res->{type} = $6;
+ $res->{id} = $7;
+ $res->{user} = $8;
+
+ my $subdir = substr($5, 7, 8);
$filename = "$pvetaskdir/$subdir/$upid";
} else {
my ($task, $filename) = upid_decode($upid);
my $fh = IO::File->new($filename, "r");
return "unable to open file - $!" if !$fh;
- my $maxlen = 1024;
+ my $maxlen = 4096;
sysseek($fh, -$maxlen, 2);
my $readbuf = '';
my $br = sysread($fh, $readbuf, $maxlen);
sub random_ether_addr {
- my $rand = Digest::SHA1::sha1_hex(rand(), time());
+ my ($seconds, $microseconds) = gettimeofday;
+
+ my $rand = Digest::SHA::sha1_hex($$, rand(), $seconds, $microseconds);
my $mac = '';
for (my $i = 0; $i < 6; $i++) {
}
sub dump_logfile {
- my ($filename, $start, $limit) = @_;
+ my ($filename, $start, $limit, $filter) = @_;
my $lines = [];
my $count = 0;
$limit = 50 if !$limit;
my $line;
- while (defined($line = <$fh>)) {
- next if $count++ < $start;
- next if $limit <= 0;
- chomp $line;
- push @$lines, { n => $count, t => $line};
- $limit--;
+
+ if ($filter) {
+ # duplicate code, so that we do not slow down normal path
+ while (defined($line = <$fh>)) {
+ next if $line !~ m/$filter/;
+ next if $count++ < $start;
+ next if $limit <= 0;
+ chomp $line;
+ push @$lines, { n => $count, t => $line};
+ $limit--;
+ }
+ } else {
+ while (defined($line = <$fh>)) {
+ next if $count++ < $start;
+ next if $limit <= 0;
+ chomp $line;
+ push @$lines, { n => $count, t => $line};
+ $limit--;
+ }
}
close($fh);
return ($count, $lines);
}
+sub dir_glob_regex {
+ my ($dir, $regex) = @_;
+
+ my $dh = IO::Dir->new ($dir);
+ return wantarray ? () : undef if !$dh;
+
+ while (defined(my $tmp = $dh->read)) {
+ if (my @res = $tmp =~ m/^($regex)$/) {
+ $dh->close;
+ return wantarray ? @res : $tmp;
+ }
+ }
+ $dh->close;
+
+ return wantarray ? () : undef;
+}
+
+sub dir_glob_foreach {
+ my ($dir, $regex, $func) = @_;
+
+ my $dh = IO::Dir->new ($dir);
+ if (defined $dh) {
+ while (defined(my $tmp = $dh->read)) {
+ if (my @res = $tmp =~ m/^($regex)$/) {
+ &$func (@res);
+ }
+ }
+ }
+}
+
+sub assert_if_modified {
+ my ($digest1, $digest2) = @_;
+
+ if ($digest1 && $digest2 && ($digest1 ne $digest2)) {
+ die "detected modified configuration - file changed by other user? Try again.\n";
+ }
+}
+
+# Digest for short strings
+# like FNV32a, but we only return 31 bits (positive numbers)
+sub fnv31a {
+ my ($string) = @_;
+
+ my $hval = 0x811c9dc5;
+
+ foreach my $c (unpack('C*', $string)) {
+ $hval ^= $c;
+ $hval += (
+ (($hval << 1) ) +
+ (($hval << 4) ) +
+ (($hval << 7) ) +
+ (($hval << 8) ) +
+ (($hval << 24) ) );
+ $hval = $hval & 0xffffffff;
+ }
+ return $hval & 0x7fffffff;
+}
+
+sub fnv31a_hex { return sprintf("%X", fnv31a(@_)); }
+
1;
projects / pve-common.git / blobdiff