1 |
#============================================================= -*-perl-*- |
2 |
# |
3 |
# BackupPC::Lib package |
4 |
# |
5 |
# DESCRIPTION |
6 |
# |
7 |
# This library defines a BackupPC::Lib class and a variety of utility |
8 |
# functions used by BackupPC. |
9 |
# |
10 |
# AUTHOR |
11 |
# Craig Barratt <cbarratt@users.sourceforge.net> |
12 |
# |
13 |
# COPYRIGHT |
14 |
# Copyright (C) 2001-2003 Craig Barratt |
15 |
# |
16 |
# This program is free software; you can redistribute it and/or modify |
17 |
# it under the terms of the GNU General Public License as published by |
18 |
# the Free Software Foundation; either version 2 of the License, or |
19 |
# (at your option) any later version. |
20 |
# |
21 |
# This program is distributed in the hope that it will be useful, |
22 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
23 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
24 |
# GNU General Public License for more details. |
25 |
# |
26 |
# You should have received a copy of the GNU General Public License |
27 |
# along with this program; if not, write to the Free Software |
28 |
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
29 |
# |
30 |
#======================================================================== |
31 |
# |
32 |
# Version 2.1.0, released 20 Jun 2004. |
33 |
# |
34 |
# See http://backuppc.sourceforge.net. |
35 |
# |
36 |
#======================================================================== |
37 |
|
38 |
package BackupPC::Lib; |
39 |
|
40 |
use strict; |
41 |
|
42 |
use vars qw(%Conf %Lang); |
43 |
use Fcntl qw/:flock/; |
44 |
use Carp; |
45 |
use DirHandle (); |
46 |
use File::Path; |
47 |
use File::Compare; |
48 |
use Socket; |
49 |
use Cwd; |
50 |
use Digest::MD5; |
51 |
use Config; |
52 |
|
53 |
sub new |
54 |
{ |
55 |
my $class = shift; |
56 |
my($topDir, $installDir, $noUserCheck) = @_; |
57 |
|
58 |
my $bpc = bless { |
59 |
TopDir => $topDir || '__TOPDIR__', |
60 |
BinDir => $installDir || '__INSTALLDIR__', |
61 |
LibDir => $installDir || '__INSTALLDIR__', |
62 |
Version => '2.1.0', |
63 |
BackupFields => [qw( |
64 |
num type startTime endTime |
65 |
nFiles size nFilesExist sizeExist nFilesNew sizeNew |
66 |
xferErrs xferBadFile xferBadShare tarErrs |
67 |
compress sizeExistComp sizeNewComp |
68 |
noFill fillFromNum mangle xferMethod level |
69 |
)], |
70 |
RestoreFields => [qw( |
71 |
num startTime endTime result errorMsg nFiles size |
72 |
tarCreateErrs xferErrs |
73 |
)], |
74 |
ArchiveFields => [qw( |
75 |
num startTime endTime result errorMsg |
76 |
)], |
77 |
}, $class; |
78 |
$bpc->{BinDir} .= "/bin"; |
79 |
$bpc->{LibDir} .= "/lib"; |
80 |
# |
81 |
# Clean up %ENV and setup other variables. |
82 |
# |
83 |
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; |
84 |
$bpc->{PoolDir} = "$bpc->{TopDir}/pool"; |
85 |
$bpc->{CPoolDir} = "$bpc->{TopDir}/cpool"; |
86 |
if ( defined(my $error = $bpc->ConfigRead()) ) { |
87 |
print(STDERR $error, "\n"); |
88 |
return; |
89 |
} |
90 |
# |
91 |
# Verify we are running as the correct user |
92 |
# |
93 |
if ( !$noUserCheck |
94 |
&& $bpc->{Conf}{BackupPCUserVerify} |
95 |
&& $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) { |
96 |
print(STDERR "Wrong user: my userid is $>, instead of $uid" |
97 |
. " ($bpc->{Conf}{BackupPCUser})\n"); |
98 |
return; |
99 |
} |
100 |
return $bpc; |
101 |
} |
102 |
|
103 |
sub TopDir |
104 |
{ |
105 |
my($bpc) = @_; |
106 |
return $bpc->{TopDir}; |
107 |
} |
108 |
|
109 |
sub BinDir |
110 |
{ |
111 |
my($bpc) = @_; |
112 |
return $bpc->{BinDir}; |
113 |
} |
114 |
|
115 |
sub Version |
116 |
{ |
117 |
my($bpc) = @_; |
118 |
return $bpc->{Version}; |
119 |
} |
120 |
|
121 |
sub Conf |
122 |
{ |
123 |
my($bpc) = @_; |
124 |
return %{$bpc->{Conf}}; |
125 |
} |
126 |
|
127 |
sub Lang |
128 |
{ |
129 |
my($bpc) = @_; |
130 |
return $bpc->{Lang}; |
131 |
} |
132 |
|
133 |
sub adminJob |
134 |
{ |
135 |
my($bpc, $num) = @_; |
136 |
return " admin " if ( !$num ); |
137 |
return " admin$num "; |
138 |
} |
139 |
|
140 |
sub isAdminJob |
141 |
{ |
142 |
my($bpc, $str) = @_; |
143 |
return $str =~ /^ admin/; |
144 |
} |
145 |
|
146 |
sub trashJob |
147 |
{ |
148 |
return " trashClean "; |
149 |
} |
150 |
|
151 |
sub ConfValue |
152 |
{ |
153 |
my($bpc, $param) = @_; |
154 |
|
155 |
return $bpc->{Conf}{$param}; |
156 |
} |
157 |
|
158 |
sub verbose |
159 |
{ |
160 |
my($bpc, $param) = @_; |
161 |
|
162 |
$bpc->{verbose} = $param if ( defined($param) ); |
163 |
return $bpc->{verbose}; |
164 |
} |
165 |
|
166 |
sub sigName2num |
167 |
{ |
168 |
my($bpc, $sig) = @_; |
169 |
|
170 |
if ( !defined($bpc->{SigName2Num}) ) { |
171 |
my $i = 0; |
172 |
foreach my $name ( split(' ', $Config{sig_name}) ) { |
173 |
$bpc->{SigName2Num}{$name} = $i; |
174 |
$i++; |
175 |
} |
176 |
} |
177 |
return $bpc->{SigName2Num}{$sig}; |
178 |
} |
179 |
|
180 |
# |
181 |
# Generate an ISO 8601 format timeStamp (but without the "T"). |
182 |
# See http://www.w3.org/TR/NOTE-datetime and |
183 |
# http://www.cl.cam.ac.uk/~mgk25/iso-time.html |
184 |
# |
185 |
sub timeStamp |
186 |
{ |
187 |
my($bpc, $t, $noPad) = @_; |
188 |
my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) |
189 |
= localtime($t || time); |
190 |
return sprintf("%04d-%02d-%02d %02d:%02d:%02d", |
191 |
$year + 1900, $mon + 1, $mday, $hour, $min, $sec) |
192 |
. ($noPad ? "" : " "); |
193 |
} |
194 |
|
195 |
sub BackupInfoRead |
196 |
{ |
197 |
my($bpc, $host) = @_; |
198 |
local(*BK_INFO, *LOCK); |
199 |
my(@Backups); |
200 |
|
201 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
202 |
if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) { |
203 |
binmode(BK_INFO); |
204 |
while ( <BK_INFO> ) { |
205 |
s/[\n\r]+//; |
206 |
next if ( !/^(\d+\t(incr|full|partial)[\d\t]*$)/ ); |
207 |
$_ = $1; |
208 |
@{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/); |
209 |
} |
210 |
close(BK_INFO); |
211 |
} |
212 |
close(LOCK); |
213 |
return @Backups; |
214 |
} |
215 |
|
216 |
sub BackupInfoWrite |
217 |
{ |
218 |
my($bpc, $host, @Backups) = @_; |
219 |
local(*BK_INFO, *LOCK); |
220 |
my($i); |
221 |
|
222 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
223 |
if ( -s "$bpc->{TopDir}/pc/$host/backups" ) { |
224 |
unlink("$bpc->{TopDir}/pc/$host/backups.old") |
225 |
if ( -f "$bpc->{TopDir}/pc/$host/backups.old" ); |
226 |
rename("$bpc->{TopDir}/pc/$host/backups", |
227 |
"$bpc->{TopDir}/pc/$host/backups.old") |
228 |
if ( -f "$bpc->{TopDir}/pc/$host/backups" ); |
229 |
} |
230 |
if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) { |
231 |
binmode(BK_INFO); |
232 |
for ( $i = 0 ; $i < @Backups ; $i++ ) { |
233 |
my %b = %{$Backups[$i]}; |
234 |
printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}})); |
235 |
} |
236 |
close(BK_INFO); |
237 |
} |
238 |
close(LOCK); |
239 |
} |
240 |
|
241 |
sub RestoreInfoRead |
242 |
{ |
243 |
my($bpc, $host) = @_; |
244 |
local(*RESTORE_INFO, *LOCK); |
245 |
my(@Restores); |
246 |
|
247 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
248 |
if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) { |
249 |
binmode(RESTORE_INFO); |
250 |
while ( <RESTORE_INFO> ) { |
251 |
s/[\n\r]+//; |
252 |
next if ( !/^(\d+.*)/ ); |
253 |
$_ = $1; |
254 |
@{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/); |
255 |
} |
256 |
close(RESTORE_INFO); |
257 |
} |
258 |
close(LOCK); |
259 |
return @Restores; |
260 |
} |
261 |
|
262 |
sub RestoreInfoWrite |
263 |
{ |
264 |
my($bpc, $host, @Restores) = @_; |
265 |
local(*RESTORE_INFO, *LOCK); |
266 |
my($i); |
267 |
|
268 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
269 |
if ( -s "$bpc->{TopDir}/pc/$host/restores" ) { |
270 |
unlink("$bpc->{TopDir}/pc/$host/restores.old") |
271 |
if ( -f "$bpc->{TopDir}/pc/$host/restores.old" ); |
272 |
rename("$bpc->{TopDir}/pc/$host/restores", |
273 |
"$bpc->{TopDir}/pc/$host/restores.old") |
274 |
if ( -f "$bpc->{TopDir}/pc/$host/restores" ); |
275 |
} |
276 |
if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) { |
277 |
binmode(RESTORE_INFO); |
278 |
for ( $i = 0 ; $i < @Restores ; $i++ ) { |
279 |
my %b = %{$Restores[$i]}; |
280 |
printf(RESTORE_INFO "%s\n", |
281 |
join("\t", @b{@{$bpc->{RestoreFields}}})); |
282 |
} |
283 |
close(RESTORE_INFO); |
284 |
} |
285 |
close(LOCK); |
286 |
} |
287 |
|
288 |
sub ArchiveInfoRead |
289 |
{ |
290 |
my($bpc, $host) = @_; |
291 |
local(*ARCHIVE_INFO, *LOCK); |
292 |
my(@Archives); |
293 |
|
294 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
295 |
if ( open(ARCHIVE_INFO, "$bpc->{TopDir}/pc/$host/archives") ) { |
296 |
binmode(ARCHIVE_INFO); |
297 |
while ( <ARCHIVE_INFO> ) { |
298 |
s/[\n\r]+//; |
299 |
next if ( !/^(\d+.*)/ ); |
300 |
$_ = $1; |
301 |
@{$Archives[@Archives]}{@{$bpc->{ArchiveFields}}} = split(/\t/); |
302 |
} |
303 |
close(ARCHIVE_INFO); |
304 |
} |
305 |
close(LOCK); |
306 |
return @Archives; |
307 |
} |
308 |
|
309 |
sub ArchiveInfoWrite |
310 |
{ |
311 |
my($bpc, $host, @Archives) = @_; |
312 |
local(*ARCHIVE_INFO, *LOCK); |
313 |
my($i); |
314 |
|
315 |
flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK"); |
316 |
if ( -s "$bpc->{TopDir}/pc/$host/archives" ) { |
317 |
unlink("$bpc->{TopDir}/pc/$host/archives.old") |
318 |
if ( -f "$bpc->{TopDir}/pc/$host/archives.old" ); |
319 |
rename("$bpc->{TopDir}/pc/$host/archives", |
320 |
"$bpc->{TopDir}/pc/$host/archives.old") |
321 |
if ( -f "$bpc->{TopDir}/pc/$host/archives" ); |
322 |
} |
323 |
if ( open(ARCHIVE_INFO, ">$bpc->{TopDir}/pc/$host/archives") ) { |
324 |
binmode(ARCHIVE_INFO); |
325 |
for ( $i = 0 ; $i < @Archives ; $i++ ) { |
326 |
my %b = %{$Archives[$i]}; |
327 |
printf(ARCHIVE_INFO "%s\n", |
328 |
join("\t", @b{@{$bpc->{ArchiveFields}}})); |
329 |
} |
330 |
close(ARCHIVE_INFO); |
331 |
} |
332 |
close(LOCK); |
333 |
} |
334 |
|
335 |
sub ConfigRead |
336 |
{ |
337 |
my($bpc, $host) = @_; |
338 |
my($ret, $mesg, $config, @configs); |
339 |
|
340 |
$bpc->{Conf} = (); |
341 |
push(@configs, "$bpc->{TopDir}/conf/config.pl"); |
342 |
push(@configs, "$bpc->{TopDir}/conf/$host.pl") |
343 |
if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" ); |
344 |
push(@configs, "$bpc->{TopDir}/pc/$host/config.pl") |
345 |
if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" ); |
346 |
foreach $config ( @configs ) { |
347 |
%Conf = (); |
348 |
if ( !defined($ret = do $config) && ($! || $@) ) { |
349 |
$mesg = "Couldn't open $config: $!" if ( $! ); |
350 |
$mesg = "Couldn't execute $config: $@" if ( $@ ); |
351 |
$mesg =~ s/[\n\r]+//; |
352 |
return $mesg; |
353 |
} |
354 |
%{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf ); |
355 |
} |
356 |
return if ( !defined($bpc->{Conf}{Language}) ); |
357 |
if ( defined($bpc->{Conf}{PerlModuleLoad}) ) { |
358 |
# |
359 |
# Load any user-specified perl modules. This is for |
360 |
# optional user-defined extensions. |
361 |
# |
362 |
$bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}] |
363 |
if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" ); |
364 |
foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) { |
365 |
eval("use $module;"); |
366 |
} |
367 |
} |
368 |
my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm"; |
369 |
if ( !defined($ret = do $langFile) && ($! || $@) ) { |
370 |
$mesg = "Couldn't open language file $langFile: $!" if ( $! ); |
371 |
$mesg = "Couldn't execute language file $langFile: $@" if ( $@ ); |
372 |
$mesg =~ s/[\n\r]+//; |
373 |
return $mesg; |
374 |
} |
375 |
$bpc->{Lang} = \%Lang; |
376 |
return; |
377 |
} |
378 |
|
379 |
# |
380 |
# Return the mtime of the config file |
381 |
# |
382 |
sub ConfigMTime |
383 |
{ |
384 |
my($bpc) = @_; |
385 |
return (stat("$bpc->{TopDir}/conf/config.pl"))[9]; |
386 |
} |
387 |
|
388 |
# |
389 |
# Returns information from the host file in $bpc->{TopDir}/conf/hosts. |
390 |
# With no argument a ref to a hash of hosts is returned. Each |
391 |
# hash contains fields as specified in the hosts file. With an |
392 |
# argument a ref to a single hash is returned with information |
393 |
# for just that host. |
394 |
# |
395 |
sub HostInfoRead |
396 |
{ |
397 |
my($bpc, $host) = @_; |
398 |
my(%hosts, @hdr, @fld); |
399 |
local(*HOST_INFO); |
400 |
|
401 |
if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) { |
402 |
print(STDERR $bpc->timeStamp, |
403 |
"Can't open $bpc->{TopDir}/conf/hosts\n"); |
404 |
return {}; |
405 |
} |
406 |
binmode(HOST_INFO); |
407 |
while ( <HOST_INFO> ) { |
408 |
s/[\n\r]+//; |
409 |
s/#.*//; |
410 |
s/\s+$//; |
411 |
next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ ); |
412 |
# |
413 |
# Split on white space, except if preceded by \ |
414 |
# using zero-width negative look-behind assertion |
415 |
# (always wanted to use one of those). |
416 |
# |
417 |
@fld = split(/(?<!\\)\s+/, $1); |
418 |
# |
419 |
# Remove any \ |
420 |
# |
421 |
foreach ( @fld ) { |
422 |
s{\\(\s)}{$1}g; |
423 |
} |
424 |
if ( @hdr ) { |
425 |
if ( defined($host) ) { |
426 |
next if ( lc($fld[0]) ne $host ); |
427 |
@{$hosts{lc($fld[0])}}{@hdr} = @fld; |
428 |
close(HOST_INFO); |
429 |
return \%hosts; |
430 |
} else { |
431 |
@{$hosts{lc($fld[0])}}{@hdr} = @fld; |
432 |
} |
433 |
} else { |
434 |
@hdr = @fld; |
435 |
} |
436 |
} |
437 |
close(HOST_INFO); |
438 |
return \%hosts; |
439 |
} |
440 |
|
441 |
# |
442 |
# Return the mtime of the hosts file |
443 |
# |
444 |
sub HostsMTime |
445 |
{ |
446 |
my($bpc) = @_; |
447 |
return (stat("$bpc->{TopDir}/conf/hosts"))[9]; |
448 |
} |
449 |
|
450 |
# |
451 |
# Stripped down from File::Path. In particular we don't print |
452 |
# many warnings and we try three times to delete each directory |
453 |
# and file -- for some reason the original File::Path rmtree |
454 |
# didn't always completely remove a directory tree on the NetApp. |
455 |
# |
456 |
# Warning: this routine changes the cwd. |
457 |
# |
458 |
sub RmTreeQuiet |
459 |
{ |
460 |
my($bpc, $pwd, $roots) = @_; |
461 |
my(@files, $root); |
462 |
|
463 |
if ( defined($roots) && length($roots) ) { |
464 |
$roots = [$roots] unless ref $roots; |
465 |
} else { |
466 |
print(STDERR "RmTreeQuiet: No root path(s) specified\n"); |
467 |
} |
468 |
chdir($pwd); |
469 |
foreach $root (@{$roots}) { |
470 |
$root = $1 if ( $root =~ m{(.*?)/*$} ); |
471 |
# |
472 |
# Try first to simply unlink the file: this avoids an |
473 |
# extra stat for every file. If it fails (which it |
474 |
# will for directories), check if it is a directory and |
475 |
# then recurse. |
476 |
# |
477 |
if ( !unlink($root) ) { |
478 |
if ( -d $root ) { |
479 |
my $d = DirHandle->new($root); |
480 |
if ( !defined($d) ) { |
481 |
print(STDERR "Can't read $pwd/$root: $!\n"); |
482 |
} else { |
483 |
@files = $d->read; |
484 |
$d->close; |
485 |
@files = grep $_!~/^\.{1,2}$/, @files; |
486 |
$bpc->RmTreeQuiet("$pwd/$root", \@files); |
487 |
chdir($pwd); |
488 |
rmdir($root) || rmdir($root); |
489 |
} |
490 |
} else { |
491 |
unlink($root) || unlink($root); |
492 |
} |
493 |
} |
494 |
} |
495 |
} |
496 |
|
497 |
# |
498 |
# Move a directory or file away for later deletion |
499 |
# |
500 |
sub RmTreeDefer |
501 |
{ |
502 |
my($bpc, $trashDir, $file) = @_; |
503 |
my($i, $f); |
504 |
|
505 |
return if ( !-e $file ); |
506 |
mkpath($trashDir, 0, 0777) if ( !-d $trashDir ); |
507 |
for ( $i = 0 ; $i < 1000 ; $i++ ) { |
508 |
$f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i); |
509 |
next if ( -e $f ); |
510 |
return if ( rename($file, $f) ); |
511 |
} |
512 |
# shouldn't get here, but might if you tried to call this |
513 |
# across file systems.... just remove the tree right now. |
514 |
if ( $file =~ /(.*)\/([^\/]*)/ ) { |
515 |
my($d) = $1; |
516 |
my($f) = $2; |
517 |
my($cwd) = Cwd::fastcwd(); |
518 |
$cwd = $1 if ( $cwd =~ /(.*)/ ); |
519 |
$bpc->RmTreeQuiet($d, $f); |
520 |
chdir($cwd) if ( $cwd ); |
521 |
} |
522 |
} |
523 |
|
524 |
# |
525 |
# Empty the trash directory. Returns 0 if it did nothing, 1 if it |
526 |
# did something, -1 if it failed to remove all the files. |
527 |
# |
528 |
sub RmTreeTrashEmpty |
529 |
{ |
530 |
my($bpc, $trashDir) = @_; |
531 |
my(@files); |
532 |
my($cwd) = Cwd::fastcwd(); |
533 |
|
534 |
$cwd = $1 if ( $cwd =~ /(.*)/ ); |
535 |
return if ( !-d $trashDir ); |
536 |
my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!"; |
537 |
@files = $d->read; |
538 |
$d->close; |
539 |
@files = grep $_!~/^\.{1,2}$/, @files; |
540 |
return 0 if ( !@files ); |
541 |
$bpc->RmTreeQuiet($trashDir, \@files); |
542 |
foreach my $f ( @files ) { |
543 |
return -1 if ( -e $f ); |
544 |
} |
545 |
chdir($cwd) if ( $cwd ); |
546 |
return 1; |
547 |
} |
548 |
|
549 |
# |
550 |
# Open a connection to the server. Returns an error string on failure. |
551 |
# Returns undef on success. |
552 |
# |
553 |
sub ServerConnect |
554 |
{ |
555 |
my($bpc, $host, $port, $justConnect) = @_; |
556 |
local(*FH); |
557 |
|
558 |
return if ( defined($bpc->{ServerFD}) ); |
559 |
# |
560 |
# First try the unix-domain socket |
561 |
# |
562 |
my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock"; |
563 |
socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!"; |
564 |
if ( !connect(*FH, sockaddr_un($sockFile)) ) { |
565 |
my $err = "unix connect: $!"; |
566 |
close(*FH); |
567 |
if ( $port > 0 ) { |
568 |
my $proto = getprotobyname('tcp'); |
569 |
my $iaddr = inet_aton($host) || return "unknown host $host"; |
570 |
my $paddr = sockaddr_in($port, $iaddr); |
571 |
|
572 |
socket(*FH, PF_INET, SOCK_STREAM, $proto) |
573 |
|| return "inet socket: $!"; |
574 |
connect(*FH, $paddr) || return "inet connect: $!"; |
575 |
} else { |
576 |
return $err; |
577 |
} |
578 |
} |
579 |
my($oldFH) = select(*FH); $| = 1; select($oldFH); |
580 |
$bpc->{ServerFD} = *FH; |
581 |
return if ( $justConnect ); |
582 |
# |
583 |
# Read the seed that we need for our MD5 message digest. See |
584 |
# ServerMesg below. |
585 |
# |
586 |
sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024); |
587 |
$bpc->{ServerMesgCnt} = 0; |
588 |
return; |
589 |
} |
590 |
|
591 |
# |
592 |
# Check that the server connection is still ok |
593 |
# |
594 |
sub ServerOK |
595 |
{ |
596 |
my($bpc) = @_; |
597 |
|
598 |
return 0 if ( !defined($bpc->{ServerFD}) ); |
599 |
vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1; |
600 |
my $ein = $FDread; |
601 |
return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 ); |
602 |
return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) ); |
603 |
} |
604 |
|
605 |
# |
606 |
# Disconnect from the server |
607 |
# |
608 |
sub ServerDisconnect |
609 |
{ |
610 |
my($bpc) = @_; |
611 |
return if ( !defined($bpc->{ServerFD}) ); |
612 |
close($bpc->{ServerFD}); |
613 |
delete($bpc->{ServerFD}); |
614 |
} |
615 |
|
616 |
# |
617 |
# Sends a message to the server and returns with the reply. |
618 |
# |
619 |
# To avoid possible attacks via the TCP socket interface, every client |
620 |
# message is protected by an MD5 digest. The MD5 digest includes four |
621 |
# items: |
622 |
# - a seed that is sent to us when we first connect |
623 |
# - a sequence number that increments for each message |
624 |
# - a shared secret that is stored in $Conf{ServerMesgSecret} |
625 |
# - the message itself. |
626 |
# The message is sent in plain text preceded by the MD5 digest. A |
627 |
# snooper can see the plain-text seed sent by BackupPC and plain-text |
628 |
# message, but cannot construct a valid MD5 digest since the secret in |
629 |
# $Conf{ServerMesgSecret} is unknown. A replay attack is not possible |
630 |
# since the seed changes on a per-connection and per-message basis. |
631 |
# |
632 |
sub ServerMesg |
633 |
{ |
634 |
my($bpc, $mesg) = @_; |
635 |
return if ( !defined(my $fh = $bpc->{ServerFD}) ); |
636 |
my $md5 = Digest::MD5->new; |
637 |
$md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt} |
638 |
. $bpc->{Conf}{ServerMesgSecret} . $mesg); |
639 |
print($fh $md5->b64digest . " $mesg\n"); |
640 |
$bpc->{ServerMesgCnt}++; |
641 |
return <$fh>; |
642 |
} |
643 |
|
644 |
# |
645 |
# Do initialization for child processes |
646 |
# |
647 |
sub ChildInit |
648 |
{ |
649 |
my($bpc) = @_; |
650 |
close(STDERR); |
651 |
open(STDERR, ">&STDOUT"); |
652 |
select(STDERR); $| = 1; |
653 |
select(STDOUT); $| = 1; |
654 |
$ENV{PATH} = $bpc->{Conf}{MyPath}; |
655 |
} |
656 |
|
657 |
# |
658 |
# Compute the MD5 digest of a file. For efficiency we don't |
659 |
# use the whole file for big files: |
660 |
# - for files <= 256K we use the file size and the whole file. |
661 |
# - for files <= 1M we use the file size, the first 128K and |
662 |
# the last 128K. |
663 |
# - for files > 1M, we use the file size, the first 128K and |
664 |
# the 8th 128K (ie: the 128K up to 1MB). |
665 |
# See the documentation for a discussion of the tradeoffs in |
666 |
# how much data we use and how many collisions we get. |
667 |
# |
668 |
# Returns the MD5 digest (a hex string) and the file size. |
669 |
# |
670 |
sub File2MD5 |
671 |
{ |
672 |
my($bpc, $md5, $name) = @_; |
673 |
my($data, $fileSize); |
674 |
local(*N); |
675 |
|
676 |
$fileSize = (stat($name))[7]; |
677 |
return ("", -1) if ( !-f _ ); |
678 |
$name = $1 if ( $name =~ /(.*)/ ); |
679 |
return ("", 0) if ( $fileSize == 0 ); |
680 |
return ("", -1) if ( !open(N, $name) ); |
681 |
binmode(N); |
682 |
$md5->reset(); |
683 |
$md5->add($fileSize); |
684 |
if ( $fileSize > 262144 ) { |
685 |
# |
686 |
# read the first and last 131072 bytes of the file, |
687 |
# up to 1MB. |
688 |
# |
689 |
my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072; |
690 |
$md5->add($data) if ( sysread(N, $data, 131072) ); |
691 |
$md5->add($data) if ( sysseek(N, $seekPosn, 0) |
692 |
&& sysread(N, $data, 131072) ); |
693 |
} else { |
694 |
# |
695 |
# read the whole file |
696 |
# |
697 |
$md5->add($data) if ( sysread(N, $data, $fileSize) ); |
698 |
} |
699 |
close(N); |
700 |
return ($md5->hexdigest, $fileSize); |
701 |
} |
702 |
|
703 |
# |
704 |
# Compute the MD5 digest of a buffer (string). For efficiency we don't |
705 |
# use the whole string for big strings: |
706 |
# - for files <= 256K we use the file size and the whole file. |
707 |
# - for files <= 1M we use the file size, the first 128K and |
708 |
# the last 128K. |
709 |
# - for files > 1M, we use the file size, the first 128K and |
710 |
# the 8th 128K (ie: the 128K up to 1MB). |
711 |
# See the documentation for a discussion of the tradeoffs in |
712 |
# how much data we use and how many collisions we get. |
713 |
# |
714 |
# Returns the MD5 digest (a hex string). |
715 |
# |
716 |
sub Buffer2MD5 |
717 |
{ |
718 |
my($bpc, $md5, $fileSize, $dataRef) = @_; |
719 |
|
720 |
$md5->reset(); |
721 |
$md5->add($fileSize); |
722 |
if ( $fileSize > 262144 ) { |
723 |
# |
724 |
# add the first and last 131072 bytes of the string, |
725 |
# up to 1MB. |
726 |
# |
727 |
my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072; |
728 |
$md5->add(substr($$dataRef, 0, 131072)); |
729 |
$md5->add(substr($$dataRef, $seekPosn, 131072)); |
730 |
} else { |
731 |
# |
732 |
# add the whole string |
733 |
# |
734 |
$md5->add($$dataRef); |
735 |
} |
736 |
return $md5->hexdigest; |
737 |
} |
738 |
|
739 |
# |
740 |
# Given an MD5 digest $d and a compress flag, return the full |
741 |
# path in the pool. |
742 |
# |
743 |
sub MD52Path |
744 |
{ |
745 |
my($bpc, $d, $compress, $poolDir) = @_; |
746 |
|
747 |
return if ( $d !~ m{(.)(.)(.)(.*)} ); |
748 |
$poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir}) |
749 |
if ( !defined($poolDir) ); |
750 |
return "$poolDir/$1/$2/$3/$1$2$3$4"; |
751 |
} |
752 |
|
753 |
# |
754 |
# For each file, check if the file exists in $bpc->{TopDir}/pool. |
755 |
# If so, remove the file and make a hardlink to the file in |
756 |
# the pool. Otherwise, if the newFile flag is set, make a |
757 |
# hardlink in the pool to the new file. |
758 |
# |
759 |
# Returns 0 if a link should be made to a new file (ie: when the file |
760 |
# is a new file but the newFile flag is 0). |
761 |
# Returns 1 if a link to an existing file is made, |
762 |
# Returns 2 if a link to a new file is made (only if $newFile is set) |
763 |
# Returns negative on error. |
764 |
# |
765 |
sub MakeFileLink |
766 |
{ |
767 |
my($bpc, $name, $d, $newFile, $compress) = @_; |
768 |
my($i, $rawFile); |
769 |
|
770 |
return -1 if ( !-f $name ); |
771 |
for ( $i = -1 ; ; $i++ ) { |
772 |
return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) ); |
773 |
$rawFile .= "_$i" if ( $i >= 0 ); |
774 |
if ( -f $rawFile ) { |
775 |
if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax} |
776 |
&& !compare($name, $rawFile) ) { |
777 |
unlink($name); |
778 |
return -3 if ( !link($rawFile, $name) ); |
779 |
return 1; |
780 |
} |
781 |
} elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) { |
782 |
my($newDir); |
783 |
($newDir = $rawFile) =~ s{(.*)/.*}{$1}; |
784 |
mkpath($newDir, 0, 0777) if ( !-d $newDir ); |
785 |
return -4 if ( !link($name, $rawFile) ); |
786 |
return 2; |
787 |
} else { |
788 |
return 0; |
789 |
} |
790 |
} |
791 |
} |
792 |
|
793 |
sub CheckHostAlive |
794 |
{ |
795 |
my($bpc, $host) = @_; |
796 |
my($s, $pingCmd, $ret); |
797 |
|
798 |
# |
799 |
# Return success if the ping cmd is undefined or empty. |
800 |
# |
801 |
if ( $bpc->{Conf}{PingCmd} eq "" ) { |
802 |
print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}" |
803 |
. " is empty\n") if ( $bpc->{verbose} ); |
804 |
return 0; |
805 |
} |
806 |
|
807 |
my $args = { |
808 |
pingPath => $bpc->{Conf}{PingPath}, |
809 |
host => $host, |
810 |
}; |
811 |
$pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args); |
812 |
|
813 |
# |
814 |
# Do a first ping in case the PC needs to wakeup |
815 |
# |
816 |
$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args); |
817 |
if ( $? ) { |
818 |
print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n") |
819 |
if ( $bpc->{verbose} ); |
820 |
return -1; |
821 |
} |
822 |
|
823 |
# |
824 |
# Do a second ping and get the round-trip time in msec |
825 |
# |
826 |
$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args); |
827 |
if ( $? ) { |
828 |
print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n") |
829 |
if ( $bpc->{verbose} ); |
830 |
return -1; |
831 |
} |
832 |
if ( $s =~ /time=([\d\.]+)\s*ms/i ) { |
833 |
$ret = $1; |
834 |
} elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) { |
835 |
$ret = $1/1000; |
836 |
} else { |
837 |
print(STDERR "CheckHostAlive: can't extract round-trip time" |
838 |
. " (not fatal)\n") if ( $bpc->{verbose} ); |
839 |
$ret = 0; |
840 |
} |
841 |
print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} ); |
842 |
return $ret; |
843 |
} |
844 |
|
845 |
sub CheckFileSystemUsage |
846 |
{ |
847 |
my($bpc) = @_; |
848 |
my($topDir) = $bpc->{TopDir}; |
849 |
my($s, $dfCmd); |
850 |
|
851 |
return 0 if ( $bpc->{Conf}{DfCmd} eq "" ); |
852 |
my $args = { |
853 |
dfPath => $bpc->{Conf}{DfPath}, |
854 |
topDir => $bpc->{TopDir}, |
855 |
}; |
856 |
$dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args); |
857 |
$s = $bpc->cmdSystemOrEval($dfCmd, undef, $args); |
858 |
return 0 if ( $? || $s !~ /(\d+)%/s ); |
859 |
return $1; |
860 |
} |
861 |
|
862 |
# |
863 |
# Given an IP address, return the host name and user name via |
864 |
# NetBios. |
865 |
# |
866 |
sub NetBiosInfoGet |
867 |
{ |
868 |
my($bpc, $host) = @_; |
869 |
my($netBiosHostName, $netBiosUserName); |
870 |
my($s, $nmbCmd); |
871 |
|
872 |
# |
873 |
# Skip NetBios check if NmbLookupCmd is emtpy |
874 |
# |
875 |
if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) { |
876 |
print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}" |
877 |
. " is empty\n") if ( $bpc->{verbose} ); |
878 |
return ($host, undef); |
879 |
} |
880 |
|
881 |
my $args = { |
882 |
nmbLookupPath => $bpc->{Conf}{NmbLookupPath}, |
883 |
host => $host, |
884 |
}; |
885 |
$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args); |
886 |
foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) { |
887 |
next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i ); |
888 |
$netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00 |
889 |
$netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03 |
890 |
} |
891 |
if ( !defined($netBiosHostName) ) { |
892 |
print(STDERR "NetBiosInfoGet: failed: can't parse return string\n") |
893 |
if ( $bpc->{verbose} ); |
894 |
return; |
895 |
} |
896 |
$netBiosHostName = lc($netBiosHostName); |
897 |
$netBiosUserName = lc($netBiosUserName); |
898 |
print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName," |
899 |
. " user $netBiosUserName\n") if ( $bpc->{verbose} ); |
900 |
return ($netBiosHostName, $netBiosUserName); |
901 |
} |
902 |
|
903 |
# |
904 |
# Given a NetBios name lookup the IP address via NetBios. |
905 |
# In the case of a host returning multiple interfaces we |
906 |
# return the first IP address that matches the subnet mask. |
907 |
# If none match the subnet mask (or nmblookup doesn't print |
908 |
# the subnet mask) then just the first IP address is returned. |
909 |
# |
910 |
sub NetBiosHostIPFind |
911 |
{ |
912 |
my($bpc, $host) = @_; |
913 |
my($netBiosHostName, $netBiosUserName); |
914 |
my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr); |
915 |
|
916 |
# |
917 |
# Skip NetBios lookup if NmbLookupFindHostCmd is emtpy |
918 |
# |
919 |
if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) { |
920 |
print(STDERR "NetBiosHostIPFind: return $host because" |
921 |
. " \$Conf{NmbLookupFindHostCmd} is empty\n") |
922 |
if ( $bpc->{verbose} ); |
923 |
return $host; |
924 |
} |
925 |
|
926 |
my $args = { |
927 |
nmbLookupPath => $bpc->{Conf}{NmbLookupPath}, |
928 |
host => $host, |
929 |
}; |
930 |
$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args); |
931 |
foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, |
932 |
$args) ) ) { |
933 |
if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) { |
934 |
$subnet = $1; |
935 |
$subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ ); |
936 |
} elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) { |
937 |
my $ip = $1; |
938 |
$firstIpAddr = $ip if ( !defined($firstIpAddr) ); |
939 |
$ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ ); |
940 |
} |
941 |
} |
942 |
$ipAddr = $firstIpAddr if ( !defined($ipAddr) ); |
943 |
if ( defined($ipAddr) ) { |
944 |
print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for" |
945 |
. " host $host\n") if ( $bpc->{verbose} ); |
946 |
return $ipAddr; |
947 |
} else { |
948 |
print(STDERR "NetBiosHostIPFind: couldn't find IP address for" |
949 |
. " host $host\n") if ( $bpc->{verbose} ); |
950 |
return; |
951 |
} |
952 |
} |
953 |
|
954 |
sub fileNameEltMangle |
955 |
{ |
956 |
my($bpc, $name) = @_; |
957 |
|
958 |
return "" if ( $name eq "" ); |
959 |
$name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg; |
960 |
return "f$name"; |
961 |
} |
962 |
|
963 |
# |
964 |
# We store files with every name preceded by "f". This |
965 |
# avoids possible name conflicts with other information |
966 |
# we store in the same directories (eg: attribute info). |
967 |
# The process of turning a normal path into one with each |
968 |
# node prefixed with "f" is called mangling. |
969 |
# |
970 |
sub fileNameMangle |
971 |
{ |
972 |
my($bpc, $name) = @_; |
973 |
|
974 |
$name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg; |
975 |
$name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg; |
976 |
return $name; |
977 |
} |
978 |
|
979 |
# |
980 |
# This undoes FileNameMangle |
981 |
# |
982 |
sub fileNameUnmangle |
983 |
{ |
984 |
my($bpc, $name) = @_; |
985 |
|
986 |
$name =~ s{/f}{/}g; |
987 |
$name =~ s{^f}{}; |
988 |
$name =~ s{%(..)}{chr(hex($1))}eg; |
989 |
return $name; |
990 |
} |
991 |
|
992 |
# |
993 |
# Escape shell meta-characters with backslashes. |
994 |
# This should be applied to each argument seperately, not an |
995 |
# entire shell command. |
996 |
# |
997 |
sub shellEscape |
998 |
{ |
999 |
my($bpc, $cmd) = @_; |
1000 |
|
1001 |
$cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g; |
1002 |
return $cmd; |
1003 |
} |
1004 |
|
1005 |
# |
1006 |
# For printing exec commands (which don't use a shell) so they look like |
1007 |
# a valid shell command this function should be called with the exec |
1008 |
# args. The shell command string is returned. |
1009 |
# |
1010 |
sub execCmd2ShellCmd |
1011 |
{ |
1012 |
my($bpc, @args) = @_; |
1013 |
my $str; |
1014 |
|
1015 |
foreach my $a ( @args ) { |
1016 |
$str .= " " if ( $str ne "" ); |
1017 |
$str .= $bpc->shellEscape($a); |
1018 |
} |
1019 |
return $str; |
1020 |
} |
1021 |
|
1022 |
# |
1023 |
# Do a URI-style escape to protect/encode special characters |
1024 |
# |
1025 |
sub uriEsc |
1026 |
{ |
1027 |
my($bpc, $s) = @_; |
1028 |
$s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg; |
1029 |
return $s; |
1030 |
} |
1031 |
|
1032 |
# |
1033 |
# Do a URI-style unescape to restore special characters |
1034 |
# |
1035 |
sub uriUnesc |
1036 |
{ |
1037 |
my($bpc, $s) = @_; |
1038 |
$s =~ s{%(..)}{chr(hex($1))}eg; |
1039 |
return $s; |
1040 |
} |
1041 |
|
1042 |
# |
1043 |
# Do variable substitution prior to execution of a command. |
1044 |
# |
1045 |
sub cmdVarSubstitute |
1046 |
{ |
1047 |
my($bpc, $template, $vars) = @_; |
1048 |
my(@cmd); |
1049 |
|
1050 |
# |
1051 |
# Return without any substitution if the first entry starts with "&", |
1052 |
# indicating this is perl code. |
1053 |
# |
1054 |
if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) { |
1055 |
return $template; |
1056 |
} |
1057 |
if ( ref($template) ne "ARRAY" ) { |
1058 |
# |
1059 |
# Split at white space, except if escaped by \ |
1060 |
# |
1061 |
$template = [split(/(?<!\\)\s+/, $template)]; |
1062 |
# |
1063 |
# Remove the \ that escaped white space. |
1064 |
# |
1065 |
foreach ( @$template ) { |
1066 |
s{\\(\s)}{$1}g; |
1067 |
} |
1068 |
} |
1069 |
# |
1070 |
# Merge variables into @tarClientCmd |
1071 |
# |
1072 |
foreach my $arg ( @$template ) { |
1073 |
# |
1074 |
# Replace scalar variables first |
1075 |
# |
1076 |
$arg =~ s{\$(\w+)(\+?)}{ |
1077 |
exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY" |
1078 |
? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1}) |
1079 |
: "\$$1$2" |
1080 |
}eg; |
1081 |
# |
1082 |
# Now replicate any array arguments; this just works for just one |
1083 |
# array var in each argument. |
1084 |
# |
1085 |
if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) { |
1086 |
my $pre = $1; |
1087 |
my $var = $2; |
1088 |
my $esc = $3; |
1089 |
my $post = $4; |
1090 |
foreach my $v ( @{$vars->{$var}} ) { |
1091 |
$v = $bpc->shellEscape($v) if ( $esc eq "+" ); |
1092 |
push(@cmd, "$pre$v$post"); |
1093 |
} |
1094 |
} else { |
1095 |
push(@cmd, $arg); |
1096 |
} |
1097 |
} |
1098 |
return \@cmd; |
1099 |
} |
1100 |
|
1101 |
# |
1102 |
# Exec or eval a command. $cmd is either a string on an array ref. |
1103 |
# |
1104 |
# @args are optional arguments for the eval() case; they are not used |
1105 |
# for exec(). |
1106 |
# |
1107 |
sub cmdExecOrEval |
1108 |
{ |
1109 |
my($bpc, $cmd, @args) = @_; |
1110 |
|
1111 |
if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) { |
1112 |
$cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" ); |
1113 |
print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n") |
1114 |
if ( $bpc->{verbose} ); |
1115 |
eval($cmd); |
1116 |
print(STDERR "Perl code fragment for exec shouldn't return!!\n"); |
1117 |
exit(1); |
1118 |
} else { |
1119 |
$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" ); |
1120 |
print(STDERR "cmdExecOrEval: about to exec ", |
1121 |
$bpc->execCmd2ShellCmd(@$cmd), "\n") |
1122 |
if ( $bpc->{verbose} ); |
1123 |
alarm(0); |
1124 |
$cmd = [map { m/(.*)/ } @$cmd]; # untaint |
1125 |
# |
1126 |
# force list-form of exec(), ie: no shell even for 1 arg |
1127 |
# |
1128 |
exec { $cmd->[0] } @$cmd; |
1129 |
print(STDERR "Exec failed for @$cmd\n"); |
1130 |
exit(1); |
1131 |
} |
1132 |
} |
1133 |
|
1134 |
# |
1135 |
# System or eval a command. $cmd is either a string on an array ref. |
1136 |
# $stdoutCB is a callback for output generated by the command. If it |
1137 |
# is undef then output is returned. If it is a code ref then the function |
1138 |
# is called with each piece of output as an argument. If it is a scalar |
1139 |
# ref the output is appended to this variable. |
1140 |
# |
1141 |
# @args are optional arguments for the eval() case; they are not used |
1142 |
# for system(). |
1143 |
# |
1144 |
# Also, $? should be set when the CHILD pipe is closed. |
1145 |
# |
1146 |
sub cmdSystemOrEvalLong |
1147 |
{ |
1148 |
my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_; |
1149 |
my($pid, $out, $allOut); |
1150 |
local(*CHILD); |
1151 |
|
1152 |
if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) { |
1153 |
$cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" ); |
1154 |
print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n") |
1155 |
if ( $bpc->{verbose} ); |
1156 |
$out = eval($cmd); |
1157 |
$$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' ); |
1158 |
&$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' ); |
1159 |
print(STDERR "cmdSystemOrEval: finished: got output $out\n") |
1160 |
if ( $bpc->{verbose} ); |
1161 |
return $out if ( !defined($stdoutCB) ); |
1162 |
return; |
1163 |
} else { |
1164 |
$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" ); |
1165 |
print(STDERR "cmdSystemOrEval: about to system ", |
1166 |
$bpc->execCmd2ShellCmd(@$cmd), "\n") |
1167 |
if ( $bpc->{verbose} ); |
1168 |
if ( !defined($pid = open(CHILD, "-|")) ) { |
1169 |
my $err = "Can't fork to run @$cmd\n"; |
1170 |
$? = 1; |
1171 |
$$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' ); |
1172 |
&$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' ); |
1173 |
return $err if ( !defined($stdoutCB) ); |
1174 |
return; |
1175 |
} |
1176 |
binmode(CHILD); |
1177 |
if ( !$pid ) { |
1178 |
# |
1179 |
# This is the child |
1180 |
# |
1181 |
close(STDERR); |
1182 |
if ( $ignoreStderr ) { |
1183 |
open(STDERR, ">", "/dev/null"); |
1184 |
} else { |
1185 |
open(STDERR, ">&STDOUT"); |
1186 |
} |
1187 |
alarm(0); |
1188 |
$cmd = [map { m/(.*)/ } @$cmd]; # untaint |
1189 |
# |
1190 |
# force list-form of exec(), ie: no shell even for 1 arg |
1191 |
# |
1192 |
exec { $cmd->[0] } @$cmd; |
1193 |
print(STDERR "Exec of @$cmd failed\n"); |
1194 |
exit(1); |
1195 |
} |
1196 |
|
1197 |
# |
1198 |
# Notify caller of child's pid |
1199 |
# |
1200 |
&$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" ); |
1201 |
|
1202 |
# |
1203 |
# The parent gathers the output from the child |
1204 |
# |
1205 |
while ( <CHILD> ) { |
1206 |
$$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' ); |
1207 |
&$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' ); |
1208 |
$out .= $_ if ( !defined($stdoutCB) ); |
1209 |
$allOut .= $_ if ( $bpc->{verbose} ); |
1210 |
} |
1211 |
$? = 0; |
1212 |
close(CHILD); |
1213 |
} |
1214 |
print(STDERR "cmdSystemOrEval: finished: got output $allOut\n") |
1215 |
if ( $bpc->{verbose} ); |
1216 |
return $out; |
1217 |
} |
1218 |
|
1219 |
# |
1220 |
# The shorter version that sets $ignoreStderr = 0, ie: merges stdout |
1221 |
# and stderr together. |
1222 |
# |
1223 |
sub cmdSystemOrEval |
1224 |
{ |
1225 |
my($bpc, $cmd, $stdoutCB, @args) = @_; |
1226 |
|
1227 |
return $bpc->cmdSystemOrEvalLong($cmd, $stdoutCB, 0, undef, @args); |
1228 |
} |
1229 |
|
1230 |
|
1231 |
# |
1232 |
# Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude} |
1233 |
# to hashes and $conf->{$shareName} to an array |
1234 |
# |
1235 |
sub backupFileConfFix |
1236 |
{ |
1237 |
my($bpc, $conf, $shareName) = @_; |
1238 |
|
1239 |
$conf->{$shareName} = [ $conf->{$shareName} ] |
1240 |
if ( ref($conf->{$shareName}) ne "ARRAY" ); |
1241 |
foreach my $param qw(BackupFilesOnly BackupFilesExclude) { |
1242 |
next if ( !defined($conf->{$param}) || ref($conf->{$param}) eq "HASH" ); |
1243 |
$conf->{$param} = [ $conf->{$param} ] |
1244 |
if ( ref($conf->{$param}) ne "ARRAY" ); |
1245 |
$conf->{$param} = { map { $_ => $conf->{$param} } @{$conf->{$shareName}} }; |
1246 |
} |
1247 |
} |
1248 |
|
1249 |
1; |