Overwite LC_ALL instead of LANG
[pve-common.git] / data / PVE / Tools.pm
1 package PVE::Tools;
2
3 use strict;
4 use POSIX;
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 IPC::Open3;
11 use Fcntl qw(:DEFAULT :flock);
12 use base 'Exporter';
13 use URI::Escape;
14 use Encode;
15
16 our @EXPORT_OK = qw(
17 lock_file
18 run_command
19 file_set_contents
20 file_get_contents
21 file_read_firstline
22 split_list
23 template_replace
24 safe_print
25 trim
26 extract_param
27 );
28
29 my $pvelogdir = "/var/log/pve";
30 my $pvetaskdir = "$pvelogdir/tasks";
31
32 mkdir $pvelogdir;
33 mkdir $pvetaskdir;
34
35 # flock: we use one file handle per process, so lock file
36 # can be called multiple times and succeeds for the same process.
37
38 my $lock_handles = {};
39
40 sub lock_file {
41 my ($filename, $timeout, $code, @param) = @_;
42
43 my $res;
44
45 $timeout = 10 if !$timeout;
46
47 eval {
48
49 local $SIG{ALRM} = sub { die "got timeout (can't lock '$filename')\n"; };
50
51 alarm ($timeout);
52
53 if (!$lock_handles->{$$}->{$filename}) {
54 $lock_handles->{$$}->{$filename} = new IO::File (">>$filename") ||
55 die "can't open lock file '$filename' - $!\n";
56 }
57
58 if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX|LOCK_NB)) {
59 print STDERR "trying to aquire lock...";
60 if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX)) {
61 print STDERR " failed\n";
62 die "can't aquire lock for '$filename' - $!\n";
63 }
64 print STDERR " OK\n";
65 }
66 alarm (0);
67
68 $res = &$code(@param);
69 };
70
71 my $err = $@;
72
73 alarm (0);
74
75 if ($lock_handles->{$$}->{$filename}) {
76 my $fh = $lock_handles->{$$}->{$filename};
77 $lock_handles->{$$}->{$filename} = undef;
78 close ($fh);
79 }
80
81 if ($err) {
82 $@ = $err;
83 return undef;
84 }
85
86 $@ = undef;
87
88 return $res;
89 }
90
91 sub file_set_contents {
92 my ($filename, $data, $perm) = @_;
93
94 $perm = 0644 if !defined($perm);
95
96 my $tmpname = "$filename.tmp.$$";
97
98 eval {
99 my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm);
100 die "unable to open file '$tmpname' - $!\n" if !$fh;
101 die "unable to write '$tmpname' - $!\n" unless print $fh $data;
102 die "closing file '$tmpname' failed - $!\n" unless close $fh;
103 };
104 my $err = $@;
105
106 if ($err) {
107 unlink $tmpname;
108 die $err;
109 }
110
111 if (!rename($tmpname, $filename)) {
112 my $msg = "close (rename) atomic file '$filename' failed: $!\n";
113 unlink $tmpname;
114 die $msg;
115 }
116 }
117
118 sub file_get_contents {
119 my ($filename, $max) = @_;
120
121 my $fh = IO::File->new($filename, "r") ||
122 die "can't open '$filename' - $!\n";
123
124 my $content = safe_read_from($fh, $max);
125
126 close $fh;
127
128 return $content;
129 }
130
131 sub file_read_firstline {
132 my ($filename) = @_;
133
134 my $fh = IO::File->new ($filename, "r");
135 return undef if !$fh;
136 my $res = <$fh>;
137 chomp $res;
138 $fh->close;
139 return $res;
140 }
141
142 sub safe_read_from {
143 my ($fh, $max, $oneline) = @_;
144
145 $max = 32768 if !$max;
146
147 my $br = 0;
148 my $input = '';
149 my $count;
150 while ($count = sysread($fh, $input, 8192, $br)) {
151 $br += $count;
152 die "input too long - aborting\n" if $br > $max;
153 if ($oneline && $input =~ m/^(.*)\n/) {
154 $input = $1;
155 last;
156 }
157 }
158 die "unable to read input - $!\n" if !defined($count);
159
160 return $input;
161 }
162
163 sub run_command {
164 my ($cmd, %param) = @_;
165
166 my $old_umask;
167
168 $cmd = [ $cmd ] if !ref($cmd);
169
170 my $cmdstr = join (' ', @$cmd);
171
172 my $errmsg;
173 my $laststderr;
174 my $timeout;
175 my $oldtimeout;
176 my $pid;
177
178 eval {
179 my $reader = IO::File->new();
180 my $writer = IO::File->new();
181 my $error = IO::File->new();
182
183 my $input;
184 my $outfunc;
185 my $errfunc;
186
187 foreach my $p (keys %param) {
188 if ($p eq 'timeout') {
189 $timeout = $param{$p};
190 } elsif ($p eq 'umask') {
191 umask($param{$p});
192 } elsif ($p eq 'errmsg') {
193 $errmsg = $param{$p};
194 $errfunc = sub {
195 print STDERR "$laststderr\n" if $laststderr;
196 $laststderr = shift;
197 };
198 } elsif ($p eq 'input') {
199 $input = $param{$p};
200 } elsif ($p eq 'outfunc') {
201 $outfunc = $param{$p};
202 } elsif ($p eq 'errfunc') {
203 $errfunc = $param{$p};
204 } else {
205 die "got unknown parameter '$p' for run_command\n";
206 }
207 }
208
209 # try to avoid locale related issues/warnings
210 my $lang = $param{lang} || 'C';
211
212 my $orig_pid = $$;
213
214 eval {
215 local $ENV{LC_ALL} = $lang;
216
217 # suppress LVM warnings like: "File descriptor 3 left open";
218 local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1";
219
220 $pid = open3($writer, $reader, $error, @$cmd) || die $!;
221 };
222
223 my $err = $@;
224
225 # catch exec errors
226 if ($orig_pid != $$) {
227 warn "ERROR: $err";
228 POSIX::_exit (1);
229 kill ('KILL', $$);
230 }
231
232 die $err if $err;
233
234 local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
235 $oldtimeout = alarm($timeout) if $timeout;
236
237 print $writer $input if defined $input;
238 close $writer;
239
240 my $select = new IO::Select;
241 $select->add($reader);
242 $select->add($error);
243
244 my $outlog = '';
245 my $errlog = '';
246
247 my $starttime = time();
248
249 while ($select->count) {
250 my @handles = $select->can_read(1);
251
252 foreach my $h (@handles) {
253 my $buf = '';
254 my $count = sysread ($h, $buf, 4096);
255 if (!defined ($count)) {
256 my $err = $!;
257 kill (9, $pid);
258 waitpid ($pid, 0);
259 die $err;
260 }
261 $select->remove ($h) if !$count;
262 if ($h eq $reader) {
263 if ($outfunc) {
264 eval {
265 $outlog .= $buf;
266 while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
267 my $line = $1;
268 &$outfunc($line);
269 }
270 };
271 my $err = $@;
272 if ($err) {
273 kill (9, $pid);
274 waitpid ($pid, 0);
275 die $err;
276 }
277 } else {
278 print $buf;
279 *STDOUT->flush();
280 }
281 } elsif ($h eq $error) {
282 if ($errfunc) {
283 eval {
284 $errlog .= $buf;
285 while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
286 my $line = $1;
287 &$errfunc($line);
288 }
289 };
290 my $err = $@;
291 if ($err) {
292 kill (9, $pid);
293 waitpid ($pid, 0);
294 die $err;
295 }
296 } else {
297 print STDERR $buf;
298 *STDERR->flush();
299 }
300 }
301 }
302 }
303
304 &$outfunc($outlog) if $outfunc && $outlog;
305 &$errfunc($errlog) if $errfunc && $errlog;
306
307 waitpid ($pid, 0);
308
309 if ($? == -1) {
310 die "failed to execute\n";
311 } elsif (my $sig = ($? & 127)) {
312 die "got signal $sig\n";
313 } elsif (my $ec = ($? >> 8)) {
314 if ($errmsg && $laststderr) {
315 my $lerr = $laststderr;
316 $laststderr = undef;
317 die "$lerr\n";
318 }
319 die "exit code $ec\n";
320 }
321
322 alarm(0);
323 };
324
325 my $err = $@;
326
327 alarm(0);
328
329 print STDERR "$laststderr\n" if $laststderr;
330
331 umask ($old_umask) if defined($old_umask);
332
333 alarm($oldtimeout) if $oldtimeout;
334
335 if ($err) {
336 if ($pid && ($err eq "got timeout\n")) {
337 kill (9, $pid);
338 waitpid ($pid, 0);
339 die "command '$cmdstr' failed: $err";
340 }
341
342 if ($errmsg) {
343 die "$errmsg: $err";
344 } else {
345 die "command '$cmdstr' failed: $err";
346 }
347 }
348 }
349
350 sub split_list {
351 my $listtxt = shift || '';
352
353 $listtxt =~ s/[,;\0]/ /g;
354 $listtxt =~ s/^\s+//;
355
356 my @data = split (/\s+/, $listtxt);
357
358 return @data;
359 }
360
361 sub trim {
362 my $txt = shift;
363
364 return $txt if !defined($txt);
365
366 $txt =~ s/^\s+//;
367 $txt =~ s/\s+$//;
368
369 return $txt;
370 }
371
372 # simple uri templates like "/vms/{vmid}"
373 sub template_replace {
374 my ($tmpl, $data) = @_;
375
376 my $res = '';
377 while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) {
378 $res .= $1 if $1;
379 $res .= ($data->{$3} || '-') if $2;
380 }
381 return $res;
382 }
383
384 sub safe_print {
385 my ($filename, $fh, $data) = @_;
386
387 return if !$data;
388
389 my $res = print $fh $data;
390
391 die "write to '$filename' failed\n" if !$res;
392 }
393
394 sub debmirrors {
395
396 return {
397 'at' => 'ftp.at.debian.org',
398 'au' => 'ftp.au.debian.org',
399 'be' => 'ftp.be.debian.org',
400 'bg' => 'ftp.bg.debian.org',
401 'br' => 'ftp.br.debian.org',
402 'ca' => 'ftp.ca.debian.org',
403 'ch' => 'ftp.ch.debian.org',
404 'cl' => 'ftp.cl.debian.org',
405 'cz' => 'ftp.cz.debian.org',
406 'de' => 'ftp.de.debian.org',
407 'dk' => 'ftp.dk.debian.org',
408 'ee' => 'ftp.ee.debian.org',
409 'es' => 'ftp.es.debian.org',
410 'fi' => 'ftp.fi.debian.org',
411 'fr' => 'ftp.fr.debian.org',
412 'gr' => 'ftp.gr.debian.org',
413 'hk' => 'ftp.hk.debian.org',
414 'hr' => 'ftp.hr.debian.org',
415 'hu' => 'ftp.hu.debian.org',
416 'ie' => 'ftp.ie.debian.org',
417 'is' => 'ftp.is.debian.org',
418 'it' => 'ftp.it.debian.org',
419 'jp' => 'ftp.jp.debian.org',
420 'kr' => 'ftp.kr.debian.org',
421 'mx' => 'ftp.mx.debian.org',
422 'nl' => 'ftp.nl.debian.org',
423 'no' => 'ftp.no.debian.org',
424 'nz' => 'ftp.nz.debian.org',
425 'pl' => 'ftp.pl.debian.org',
426 'pt' => 'ftp.pt.debian.org',
427 'ro' => 'ftp.ro.debian.org',
428 'ru' => 'ftp.ru.debian.org',
429 'se' => 'ftp.se.debian.org',
430 'si' => 'ftp.si.debian.org',
431 'sk' => 'ftp.sk.debian.org',
432 'tr' => 'ftp.tr.debian.org',
433 'tw' => 'ftp.tw.debian.org',
434 'gb' => 'ftp.uk.debian.org',
435 'us' => 'ftp.us.debian.org',
436 };
437 }
438
439 sub kvmkeymaps {
440 return {
441 'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
442 'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
443 'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ],
444 'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', 'intl' ],
445 'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', 'intl' ],
446 'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
447 #'et' => [], # Ethopia or Estonia ??
448 'fi' => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
449 #'fo' => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'],
450 'fr' => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'],
451 'fr-be' => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'],
452 'fr-ca' => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'],
453 'fr-ch' => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'],
454 #'hr' => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2?
455 'hu' => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef],
456 'is' => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'],
457 'it' => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'],
458 'jp' => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef],
459 'lt' => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'],
460 #'lv' => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7?
461 'mk' => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'],
462 'nl' => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef],
463 #'nl-be' => ['Belgium-Dutch', 'nl-be', ?, ?, ?],
464 'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'],
465 'pl' => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef],
466 'pt' => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'],
467 'pt-br' => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'],
468 #'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know?
469 'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
470 #'sv' => [], Swedish ?
471 #'th' => [],
472 #'tr' => [],
473 };
474 }
475
476 sub extract_param {
477 my ($param, $key) = @_;
478
479 my $res = $param->{$key};
480 delete $param->{$key};
481
482 return $res;
483 }
484
485 sub next_vnc_port {
486
487 for (my $p = 5900; $p < 6000; $p++) {
488
489 my $sock = IO::Socket::INET->new (Listen => 5,
490 LocalAddr => 'localhost',
491 LocalPort => $p,
492 ReuseAddr => 1,
493 Proto => 0);
494
495 if ($sock) {
496 close ($sock);
497 return $p;
498 }
499 }
500
501 die "unable to find free vnc port";
502 };
503
504 # NOTE: NFS syscall can't be interrupted, so alarm does
505 # not work to provide timeouts.
506 # from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation"
507 # So the spawn external 'df' process instead of using
508 # Filesys::Df (which uses statfs syscall)
509 sub df {
510 my ($path, $timeout) = @_;
511
512 my $cmd = [ 'df', '-P', '-B', '1', $path];
513
514 my $res = {
515 total => 0,
516 used => 0,
517 avail => 0,
518 };
519
520 my $parser = sub {
521 my $line = shift;
522 if (my ($fsid, $total, $used, $avail) = $line =~
523 m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) {
524 $res = {
525 total => $total,
526 used => $used,
527 avail => $avail,
528 };
529 }
530 };
531 eval { run_command($cmd, timeout => $timeout, outfunc => $parser); };
532 warn $@ if $@;
533
534 return $res;
535 }
536
537 # UPID helper
538 # We use this to uniquely identify a process.
539 # An 'Unique Process ID' has the following format:
540 # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
541
542 sub upid_encode {
543 my $d = shift;
544
545 return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
546 $d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
547 $d->{user});
548 }
549
550 sub upid_decode {
551 my ($upid, $noerr) = @_;
552
553 my $res;
554 my $filename;
555
556 # "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
557 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]+):$/) {
558 $res->{node} = $1;
559 $res->{pid} = hex($2);
560 $res->{pstart} = hex($3);
561 $res->{starttime} = hex($4);
562 $res->{type} = $5;
563 $res->{id} = $6;
564 $res->{user} = $7;
565
566 my $subdir = substr($4, 7, 8);
567 $filename = "$pvetaskdir/$subdir/$upid";
568
569 } else {
570 return undef if $noerr;
571 die "unable to parse worker upid '$upid'\n";
572 }
573
574 return wantarray ? ($res, $filename) : $res;
575 }
576
577 sub upid_open {
578 my ($upid) = @_;
579
580 my ($task, $filename) = upid_decode($upid);
581
582 my $dirname = dirname($filename);
583 make_path($dirname);
584
585 my $wwwid = getpwnam('www-data') ||
586 die "getpwnam failed";
587
588 my $perm = 0640;
589
590 my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) ||
591 die "unable to create output file '$filename' - $!\n";
592 chown $wwwid, $outfh;
593
594 return $outfh;
595 };
596
597 sub upid_read_status {
598 my ($upid) = @_;
599
600 my ($task, $filename) = upid_decode($upid);
601 my $fh = IO::File->new($filename, "r");
602 return "unable to open file - $!" if !$fh;
603 my $maxlen = 1024;
604 sysseek($fh, -$maxlen, 2);
605 my $readbuf = '';
606 my $br = sysread($fh, $readbuf, $maxlen);
607 close($fh);
608 if ($br) {
609 return "unable to extract last line"
610 if $readbuf !~ m/\n?(.+)$/;
611 my $line = $1;
612 if ($line =~ m/^TASK OK$/) {
613 return 'OK';
614 } elsif ($line =~ m/^TASK ERROR: (.+)$/) {
615 return $1;
616 } else {
617 return "unexpected status";
618 }
619 }
620 return "unable to read tail (got $br bytes)";
621 }
622
623 # useful functions to store comments in config files
624 sub encode_text {
625 my ($text) = @_;
626
627 # all control and hi-bit characters, and ':'
628 my $unsafe = "^\x20-\x39\x3b-\x7e";
629 return uri_escape(Encode::encode("utf8", $text), $unsafe);
630 }
631
632 sub decode_text {
633 my ($data) = @_;
634
635 return Encode::decode("utf8", uri_unescape($data));
636 }
637
638
639 1;