1 #============================================================= -*-perl-*-
3 # BackupPC::Lib package
7 # This library defines a BackupPC::Lib class and a variety of utility
8 # functions used by BackupPC.
11 # Craig Barratt <cbarratt@users.sourceforge.net>
14 # Copyright (C) 2001-2003 Craig Barratt
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.
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.
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
30 #========================================================================
32 # Version 2.1.0beta2, released 23 May 2004.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
56 my($topDir, $installDir, $noUserCheck) = @_;
59 TopDir => $topDir || '/data/BackupPC',
60 BinDir => $installDir || '/usr/local/BackupPC',
61 LibDir => $installDir || '/usr/local/BackupPC',
62 Version => '2.1.0beta2pl1',
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
71 num startTime endTime result errorMsg nFiles size
72 tarCreateErrs xferErrs
75 num startTime endTime result errorMsg
78 $bpc->{BinDir} .= "/bin";
79 $bpc->{LibDir} .= "/lib";
81 # Clean up %ENV and setup other variables.
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");
91 # Verify we are running as the correct user
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");
106 return $bpc->{TopDir};
112 return $bpc->{BinDir};
118 return $bpc->{Version};
124 return %{$bpc->{Conf}};
136 return " admin " if ( !$num );
137 return " admin$num ";
143 return $str =~ /^ admin/;
148 return " trashClean ";
153 my($bpc, $param) = @_;
155 return $bpc->{Conf}{$param};
160 my($bpc, $param) = @_;
162 $bpc->{verbose} = $param if ( defined($param) );
163 return $bpc->{verbose};
170 if ( !defined($bpc->{SigName2Num}) ) {
172 foreach my $name ( split(' ', $Config{sig_name}) ) {
173 $bpc->{SigName2Num}{$name} = $i;
177 return $bpc->{SigName2Num}{$sig};
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
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 ? "" : " ");
197 my($bpc, $host) = @_;
198 local(*BK_INFO, *LOCK);
201 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
202 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
204 while ( <BK_INFO> ) {
206 next if ( !/^(\d+\t(incr|full|partial)[\d\t]*$)/ );
208 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
218 my($bpc, $host, @Backups) = @_;
219 local(*BK_INFO, *LOCK);
222 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
223 unlink("$bpc->{TopDir}/pc/$host/backups.old")
224 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
225 rename("$bpc->{TopDir}/pc/$host/backups",
226 "$bpc->{TopDir}/pc/$host/backups.old")
227 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
228 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
230 for ( $i = 0 ; $i < @Backups ; $i++ ) {
231 my %b = %{$Backups[$i]};
232 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
241 my($bpc, $host) = @_;
242 local(*RESTORE_INFO, *LOCK);
245 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
246 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
247 binmode(RESTORE_INFO);
248 while ( <RESTORE_INFO> ) {
250 next if ( !/^(\d+.*)/ );
252 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
262 my($bpc, $host, @Restores) = @_;
263 local(*RESTORE_INFO, *LOCK);
266 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
267 unlink("$bpc->{TopDir}/pc/$host/restores.old")
268 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
269 rename("$bpc->{TopDir}/pc/$host/restores",
270 "$bpc->{TopDir}/pc/$host/restores.old")
271 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
272 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
273 binmode(RESTORE_INFO);
274 for ( $i = 0 ; $i < @Restores ; $i++ ) {
275 my %b = %{$Restores[$i]};
276 printf(RESTORE_INFO "%s\n",
277 join("\t", @b{@{$bpc->{RestoreFields}}}));
286 my($bpc, $host) = @_;
287 local(*ARCHIVE_INFO, *LOCK);
290 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
291 if ( open(ARCHIVE_INFO, "$bpc->{TopDir}/pc/$host/archives") ) {
292 binmode(ARCHIVE_INFO);
293 while ( <ARCHIVE_INFO> ) {
295 next if ( !/^(\d+.*)/ );
297 @{$Archives[@Archives]}{@{$bpc->{ArchiveFields}}} = split(/\t/);
307 my($bpc, $host, @Archives) = @_;
308 local(*ARCHIVE_INFO, *LOCK);
311 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
312 unlink("$bpc->{TopDir}/pc/$host/archives.old")
313 if ( -f "$bpc->{TopDir}/pc/$host/archives.old" );
314 rename("$bpc->{TopDir}/pc/$host/archives",
315 "$bpc->{TopDir}/pc/$host/archives.old")
316 if ( -f "$bpc->{TopDir}/pc/$host/archives" );
317 if ( open(ARCHIVE_INFO, ">$bpc->{TopDir}/pc/$host/archives") ) {
318 binmode(ARCHIVE_INFO);
319 for ( $i = 0 ; $i < @Archives ; $i++ ) {
320 my %b = %{$Archives[$i]};
321 printf(ARCHIVE_INFO "%s\n",
322 join("\t", @b{@{$bpc->{ArchiveFields}}}));
331 my($bpc, $host) = @_;
332 my($ret, $mesg, $config, @configs);
335 push(@configs, "$bpc->{TopDir}/conf/config.pl");
336 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
337 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
338 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
339 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
340 foreach $config ( @configs ) {
342 if ( !defined($ret = do $config) && ($! || $@) ) {
343 $mesg = "Couldn't open $config: $!" if ( $! );
344 $mesg = "Couldn't execute $config: $@" if ( $@ );
345 $mesg =~ s/[\n\r]+//;
348 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
350 return if ( !defined($bpc->{Conf}{Language}) );
351 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
353 # Load any user-specified perl modules. This is for
354 # optional user-defined extensions.
356 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
357 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
358 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
359 eval("use $module;");
362 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
363 if ( !defined($ret = do $langFile) && ($! || $@) ) {
364 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
365 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
366 $mesg =~ s/[\n\r]+//;
369 $bpc->{Lang} = \%Lang;
374 # Return the mtime of the config file
379 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
383 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
384 # With no argument a ref to a hash of hosts is returned. Each
385 # hash contains fields as specified in the hosts file. With an
386 # argument a ref to a single hash is returned with information
387 # for just that host.
391 my($bpc, $host) = @_;
392 my(%hosts, @hdr, @fld);
395 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
396 print(STDERR $bpc->timeStamp,
397 "Can't open $bpc->{TopDir}/conf/hosts\n");
401 while ( <HOST_INFO> ) {
405 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
407 # Split on white space, except if preceded by \
408 # using zero-width negative look-behind assertion
409 # (always wanted to use one of those).
411 @fld = split(/(?<!\\)\s+/, $1);
419 if ( defined($host) ) {
420 next if ( lc($fld[0]) ne $host );
421 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
425 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
436 # Return the mtime of the hosts file
441 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
445 # Stripped down from File::Path. In particular we don't print
446 # many warnings and we try three times to delete each directory
447 # and file -- for some reason the original File::Path rmtree
448 # didn't always completely remove a directory tree on the NetApp.
450 # Warning: this routine changes the cwd.
454 my($bpc, $pwd, $roots) = @_;
457 if ( defined($roots) && length($roots) ) {
458 $roots = [$roots] unless ref $roots;
460 print(STDERR "RmTreeQuiet: No root path(s) specified\n");
463 foreach $root (@{$roots}) {
464 $root = $1 if ( $root =~ m{(.*?)/*$} );
466 # Try first to simply unlink the file: this avoids an
467 # extra stat for every file. If it fails (which it
468 # will for directories), check if it is a directory and
471 if ( !unlink($root) ) {
473 my $d = DirHandle->new($root);
474 if ( !defined($d) ) {
475 print(STDERR "Can't read $pwd/$root: $!\n");
479 @files = grep $_!~/^\.{1,2}$/, @files;
480 $bpc->RmTreeQuiet("$pwd/$root", \@files);
482 rmdir($root) || rmdir($root);
485 unlink($root) || unlink($root);
492 # Move a directory or file away for later deletion
496 my($bpc, $trashDir, $file) = @_;
499 return if ( !-e $file );
500 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
501 for ( $i = 0 ; $i < 1000 ; $i++ ) {
502 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
504 return if ( rename($file, $f) );
506 # shouldn't get here, but might if you tried to call this
507 # across file systems.... just remove the tree right now.
508 if ( $file =~ /(.*)\/([^\/]*)/ ) {
511 my($cwd) = Cwd::fastcwd();
512 $cwd = $1 if ( $cwd =~ /(.*)/ );
513 $bpc->RmTreeQuiet($d, $f);
514 chdir($cwd) if ( $cwd );
519 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
520 # did something, -1 if it failed to remove all the files.
524 my($bpc, $trashDir) = @_;
526 my($cwd) = Cwd::fastcwd();
528 $cwd = $1 if ( $cwd =~ /(.*)/ );
529 return if ( !-d $trashDir );
530 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
533 @files = grep $_!~/^\.{1,2}$/, @files;
534 return 0 if ( !@files );
535 $bpc->RmTreeQuiet($trashDir, \@files);
536 foreach my $f ( @files ) {
537 return -1 if ( -e $f );
539 chdir($cwd) if ( $cwd );
544 # Open a connection to the server. Returns an error string on failure.
545 # Returns undef on success.
549 my($bpc, $host, $port, $justConnect) = @_;
552 return if ( defined($bpc->{ServerFD}) );
554 # First try the unix-domain socket
556 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
557 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
558 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
559 my $err = "unix connect: $!";
562 my $proto = getprotobyname('tcp');
563 my $iaddr = inet_aton($host) || return "unknown host $host";
564 my $paddr = sockaddr_in($port, $iaddr);
566 socket(*FH, PF_INET, SOCK_STREAM, $proto)
567 || return "inet socket: $!";
568 connect(*FH, $paddr) || return "inet connect: $!";
573 my($oldFH) = select(*FH); $| = 1; select($oldFH);
574 $bpc->{ServerFD} = *FH;
575 return if ( $justConnect );
577 # Read the seed that we need for our MD5 message digest. See
580 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
581 $bpc->{ServerMesgCnt} = 0;
586 # Check that the server connection is still ok
592 return 0 if ( !defined($bpc->{ServerFD}) );
593 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
595 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
596 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
600 # Disconnect from the server
605 return if ( !defined($bpc->{ServerFD}) );
606 close($bpc->{ServerFD});
607 delete($bpc->{ServerFD});
611 # Sends a message to the server and returns with the reply.
613 # To avoid possible attacks via the TCP socket interface, every client
614 # message is protected by an MD5 digest. The MD5 digest includes four
616 # - a seed that is sent to us when we first connect
617 # - a sequence number that increments for each message
618 # - a shared secret that is stored in $Conf{ServerMesgSecret}
619 # - the message itself.
620 # The message is sent in plain text preceded by the MD5 digest. A
621 # snooper can see the plain-text seed sent by BackupPC and plain-text
622 # message, but cannot construct a valid MD5 digest since the secret in
623 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
624 # since the seed changes on a per-connection and per-message basis.
628 my($bpc, $mesg) = @_;
629 return if ( !defined(my $fh = $bpc->{ServerFD}) );
630 my $md5 = Digest::MD5->new;
631 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
632 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
633 print($fh $md5->b64digest . " $mesg\n");
634 $bpc->{ServerMesgCnt}++;
639 # Do initialization for child processes
645 open(STDERR, ">&STDOUT");
646 select(STDERR); $| = 1;
647 select(STDOUT); $| = 1;
648 $ENV{PATH} = $bpc->{Conf}{MyPath};
652 # Compute the MD5 digest of a file. For efficiency we don't
653 # use the whole file for big files:
654 # - for files <= 256K we use the file size and the whole file.
655 # - for files <= 1M we use the file size, the first 128K and
657 # - for files > 1M, we use the file size, the first 128K and
658 # the 8th 128K (ie: the 128K up to 1MB).
659 # See the documentation for a discussion of the tradeoffs in
660 # how much data we use and how many collisions we get.
662 # Returns the MD5 digest (a hex string) and the file size.
666 my($bpc, $md5, $name) = @_;
667 my($data, $fileSize);
670 $fileSize = (stat($name))[7];
671 return ("", -1) if ( !-f _ );
672 $name = $1 if ( $name =~ /(.*)/ );
673 return ("", 0) if ( $fileSize == 0 );
674 return ("", -1) if ( !open(N, $name) );
677 $md5->add($fileSize);
678 if ( $fileSize > 262144 ) {
680 # read the first and last 131072 bytes of the file,
683 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
684 $md5->add($data) if ( sysread(N, $data, 131072) );
685 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
686 && sysread(N, $data, 131072) );
689 # read the whole file
691 $md5->add($data) if ( sysread(N, $data, $fileSize) );
694 return ($md5->hexdigest, $fileSize);
698 # Compute the MD5 digest of a buffer (string). For efficiency we don't
699 # use the whole string for big strings:
700 # - for files <= 256K we use the file size and the whole file.
701 # - for files <= 1M we use the file size, the first 128K and
703 # - for files > 1M, we use the file size, the first 128K and
704 # the 8th 128K (ie: the 128K up to 1MB).
705 # See the documentation for a discussion of the tradeoffs in
706 # how much data we use and how many collisions we get.
708 # Returns the MD5 digest (a hex string).
712 my($bpc, $md5, $fileSize, $dataRef) = @_;
715 $md5->add($fileSize);
716 if ( $fileSize > 262144 ) {
718 # add the first and last 131072 bytes of the string,
721 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
722 $md5->add(substr($$dataRef, 0, 131072));
723 $md5->add(substr($$dataRef, $seekPosn, 131072));
726 # add the whole string
728 $md5->add($$dataRef);
730 return $md5->hexdigest;
734 # Given an MD5 digest $d and a compress flag, return the full
739 my($bpc, $d, $compress, $poolDir) = @_;
741 return if ( $d !~ m{(.)(.)(.)(.*)} );
742 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
743 if ( !defined($poolDir) );
744 return "$poolDir/$1/$2/$3/$1$2$3$4";
748 # For each file, check if the file exists in $bpc->{TopDir}/pool.
749 # If so, remove the file and make a hardlink to the file in
750 # the pool. Otherwise, if the newFile flag is set, make a
751 # hardlink in the pool to the new file.
753 # Returns 0 if a link should be made to a new file (ie: when the file
754 # is a new file but the newFile flag is 0).
755 # Returns 1 if a link to an existing file is made,
756 # Returns 2 if a link to a new file is made (only if $newFile is set)
757 # Returns negative on error.
761 my($bpc, $name, $d, $newFile, $compress) = @_;
764 return -1 if ( !-f $name );
765 for ( $i = -1 ; ; $i++ ) {
766 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
767 $rawFile .= "_$i" if ( $i >= 0 );
769 if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
770 && !compare($name, $rawFile) ) {
772 return -3 if ( !link($rawFile, $name) );
775 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
777 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
778 mkpath($newDir, 0, 0777) if ( !-d $newDir );
779 return -4 if ( !link($name, $rawFile) );
789 my($bpc, $host) = @_;
790 my($s, $pingCmd, $ret);
793 # Return success if the ping cmd is undefined or empty.
795 if ( $bpc->{Conf}{PingCmd} eq "" ) {
796 print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
797 . " is empty\n") if ( $bpc->{verbose} );
802 pingPath => $bpc->{Conf}{PingPath},
805 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
808 # Do a first ping in case the PC needs to wakeup
810 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
812 print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
813 if ( $bpc->{verbose} );
818 # Do a second ping and get the round-trip time in msec
820 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
822 print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
823 if ( $bpc->{verbose} );
826 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
828 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
831 print(STDERR "CheckHostAlive: can't extract round-trip time"
832 . " (not fatal)\n") if ( $bpc->{verbose} );
835 print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
839 sub CheckFileSystemUsage
842 my($topDir) = $bpc->{TopDir};
845 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
847 dfPath => $bpc->{Conf}{DfPath},
848 topDir => $bpc->{TopDir},
850 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
851 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
852 return 0 if ( $? || $s !~ /(\d+)%/s );
857 # Given an IP address, return the host name and user name via
862 my($bpc, $host) = @_;
863 my($netBiosHostName, $netBiosUserName);
867 # Skip NetBios check if NmbLookupCmd is emtpy
869 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
870 print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
871 . " is empty\n") if ( $bpc->{verbose} );
872 return ($host, undef);
876 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
879 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
880 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
881 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
882 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
883 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
885 if ( !defined($netBiosHostName) ) {
886 print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
887 if ( $bpc->{verbose} );
890 $netBiosHostName = lc($netBiosHostName);
891 $netBiosUserName = lc($netBiosUserName);
892 print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
893 . " user $netBiosUserName\n") if ( $bpc->{verbose} );
894 return ($netBiosHostName, $netBiosUserName);
898 # Given a NetBios name lookup the IP address via NetBios.
899 # In the case of a host returning multiple interfaces we
900 # return the first IP address that matches the subnet mask.
901 # If none match the subnet mask (or nmblookup doesn't print
902 # the subnet mask) then just the first IP address is returned.
904 sub NetBiosHostIPFind
906 my($bpc, $host) = @_;
907 my($netBiosHostName, $netBiosUserName);
908 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
911 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
913 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
914 print(STDERR "NetBiosHostIPFind: return $host because"
915 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
916 if ( $bpc->{verbose} );
921 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
924 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
925 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
927 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
929 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
930 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
932 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
933 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
936 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
937 if ( defined($ipAddr) ) {
938 print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
939 . " host $host\n") if ( $bpc->{verbose} );
942 print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
943 . " host $host\n") if ( $bpc->{verbose} );
948 sub fileNameEltMangle
950 my($bpc, $name) = @_;
952 return "" if ( $name eq "" );
953 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
958 # We store files with every name preceded by "f". This
959 # avoids possible name conflicts with other information
960 # we store in the same directories (eg: attribute info).
961 # The process of turning a normal path into one with each
962 # node prefixed with "f" is called mangling.
966 my($bpc, $name) = @_;
968 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
969 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
974 # This undoes FileNameMangle
978 my($bpc, $name) = @_;
982 $name =~ s{%(..)}{chr(hex($1))}eg;
987 # Escape shell meta-characters with backslashes.
988 # This should be applied to each argument seperately, not an
989 # entire shell command.
995 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
1000 # For printing exec commands (which don't use a shell) so they look like
1001 # a valid shell command this function should be called with the exec
1002 # args. The shell command string is returned.
1004 sub execCmd2ShellCmd
1006 my($bpc, @args) = @_;
1009 foreach my $a ( @args ) {
1010 $str .= " " if ( $str ne "" );
1011 $str .= $bpc->shellEscape($a);
1017 # Do a URI-style escape to protect/encode special characters
1022 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
1027 # Do a URI-style unescape to restore special characters
1032 $s =~ s{%(..)}{chr(hex($1))}eg;
1037 # Do variable substitution prior to execution of a command.
1039 sub cmdVarSubstitute
1041 my($bpc, $template, $vars) = @_;
1045 # Return without any substitution if the first entry starts with "&",
1046 # indicating this is perl code.
1048 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1051 if ( ref($template) ne "ARRAY" ) {
1053 # Split at white space, except if escaped by \
1055 $template = [split(/(?<!\\)\s+/, $template)];
1057 # Remove the \ that escaped white space.
1059 foreach ( @$template ) {
1064 # Merge variables into @tarClientCmd
1066 foreach my $arg ( @$template ) {
1068 # Replace scalar variables first
1070 $arg =~ s{\$(\w+)(\+?)}{
1071 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1072 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1076 # Now replicate any array arguments; this just works for just one
1077 # array var in each argument.
1079 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1084 foreach my $v ( @{$vars->{$var}} ) {
1085 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1086 push(@cmd, "$pre$v$post");
1096 # Exec or eval a command. $cmd is either a string on an array ref.
1098 # @args are optional arguments for the eval() case; they are not used
1103 my($bpc, $cmd, @args) = @_;
1105 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1106 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1107 print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1108 if ( $bpc->{verbose} );
1110 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1113 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1114 print(STDERR "cmdExecOrEval: about to exec ",
1115 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1116 if ( $bpc->{verbose} );
1118 $cmd = [map { m/(.*)/ } @$cmd]; # untaint
1120 # force list-form of exec(), ie: no shell even for 1 arg
1122 exec { $cmd->[0] } @$cmd;
1123 print(STDERR "Exec failed for @$cmd\n");
1129 # System or eval a command. $cmd is either a string on an array ref.
1130 # $stdoutCB is a callback for output generated by the command. If it
1131 # is undef then output is returned. If it is a code ref then the function
1132 # is called with each piece of output as an argument. If it is a scalar
1133 # ref the output is appended to this variable.
1135 # @args are optional arguments for the eval() case; they are not used
1138 # Also, $? should be set when the CHILD pipe is closed.
1140 sub cmdSystemOrEvalLong
1142 my($bpc, $cmd, $stdoutCB, $ignoreStderr, @args) = @_;
1143 my($pid, $out, $allOut);
1146 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1147 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1148 print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1149 if ( $bpc->{verbose} );
1151 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1152 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1153 print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1154 if ( $bpc->{verbose} );
1155 return $out if ( !defined($stdoutCB) );
1158 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1159 print(STDERR "cmdSystemOrEval: about to system ",
1160 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1161 if ( $bpc->{verbose} );
1162 if ( !defined($pid = open(CHILD, "-|")) ) {
1163 my $err = "Can't fork to run @$cmd\n";
1165 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1166 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1167 return $err if ( !defined($stdoutCB) );
1176 if ( $ignoreStderr ) {
1177 open(STDERR, ">", "/dev/null");
1179 open(STDERR, ">&STDOUT");
1182 $cmd = [map { m/(.*)/ } @$cmd]; # untaint
1184 # force list-form of exec(), ie: no shell even for 1 arg
1186 exec { $cmd->[0] } @$cmd;
1187 print(STDERR "Exec of @$cmd failed\n");
1191 # The parent gathers the output from the child
1194 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1195 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1196 $out .= $_ if ( !defined($stdoutCB) );
1197 $allOut .= $_ if ( $bpc->{verbose} );
1202 print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1203 if ( $bpc->{verbose} );
1208 # The shorter version that sets $ignoreStderr = 0, ie: merges stdout
1209 # and stderr together.
1213 my($bpc, $cmd, $stdoutCB, @args) = @_;
1215 return $bpc->cmdSystemOrEvalLong($cmd, $stdoutCB, 0, @args);
1220 # Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}
1221 # to hashes and $conf->{$shareName} to an array
1223 sub backupFileConfFix
1225 my($bpc, $conf, $shareName) = @_;
1227 $conf->{$shareName} = [ $conf->{$shareName} ]
1228 if ( ref($conf->{$shareName}) ne "ARRAY" );
1229 foreach my $param qw(BackupFilesOnly BackupFilesExclude) {
1230 next if ( !defined($conf->{$param}) || ref($conf->{$param}) eq "HASH" );
1231 $conf->{$param} = [ $conf->{$param} ]
1232 if ( ref($conf->{$param}) ne "ARRAY" );
1233 $conf->{$param} = { map { $_ => $conf->{$param} } @{$conf->{$shareName}} };