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 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 1.5.0, released 2 Aug 2002.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
57 TopDir => $topDir || '/data/BackupPC',
58 BinDir => '/usr/local/BackupPC/bin',
59 LibDir => '/usr/local/BackupPC/lib',
62 num type startTime endTime
63 nFiles size nFilesExist sizeExist nFilesNew sizeNew
64 xferErrs xferBadFile xferBadShare tarErrs
65 compress sizeExistComp sizeNewComp
66 noFill fillFromNum mangle
69 num startTime endTime result errorMsg nFiles size
70 tarCreateErrs xferErrs
74 # Clean up %ENV and setup other variables.
76 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
77 $self->{PoolDir} = "$self->{TopDir}/pool";
78 $self->{CPoolDir} = "$self->{TopDir}/cpool";
79 if ( defined(my $error = $self->ConfigRead()) ) {
80 print(STDERR $error, "\n");
89 return $self->{TopDir};
95 return $self->{BinDir};
101 return $self->{Version};
107 return %{$self->{Conf}};
113 return $self->{Lang};
123 return " trashClean ";
128 my($self, $t, $noPad) = @_;
129 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
130 = localtime($t || time);
133 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
134 . ($noPad ? "" : " ");
138 # An ISO 8601-compliant version of timeStamp. Needed by the
139 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
140 # Also see http://www.w3.org/TR/NOTE-datetime.
144 my($self, $t, $noPad) = @_;
145 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
146 = localtime($t || time);
149 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
150 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
151 . ($noPad ? "" : " ");
156 my($self, $host) = @_;
157 local(*BK_INFO, *LOCK);
160 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
161 if ( open(BK_INFO, "$self->{TopDir}/pc/$host/backups") ) {
162 while ( <BK_INFO> ) {
164 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
166 @{$Backups[@Backups]}{@{$self->{BackupFields}}} = split(/\t/);
176 my($self, $host, @Backups) = @_;
177 local(*BK_INFO, *LOCK);
180 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
181 unlink("$self->{TopDir}/pc/$host/backups.old")
182 if ( -f "$self->{TopDir}/pc/$host/backups.old" );
183 rename("$self->{TopDir}/pc/$host/backups",
184 "$self->{TopDir}/pc/$host/backups.old")
185 if ( -f "$self->{TopDir}/pc/$host/backups" );
186 if ( open(BK_INFO, ">$self->{TopDir}/pc/$host/backups") ) {
187 for ( $i = 0 ; $i < @Backups ; $i++ ) {
188 my %b = %{$Backups[$i]};
189 printf(BK_INFO "%s\n", join("\t", @b{@{$self->{BackupFields}}}));
198 my($self, $host) = @_;
199 local(*RESTORE_INFO, *LOCK);
202 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
203 if ( open(RESTORE_INFO, "$self->{TopDir}/pc/$host/restores") ) {
204 while ( <RESTORE_INFO> ) {
206 next if ( !/^(\d+.*)/ );
208 @{$Restores[@Restores]}{@{$self->{RestoreFields}}} = split(/\t/);
218 my($self, $host, @Restores) = @_;
219 local(*RESTORE_INFO, *LOCK);
222 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
223 unlink("$self->{TopDir}/pc/$host/restores.old")
224 if ( -f "$self->{TopDir}/pc/$host/restores.old" );
225 rename("$self->{TopDir}/pc/$host/restores",
226 "$self->{TopDir}/pc/$host/restores.old")
227 if ( -f "$self->{TopDir}/pc/$host/restores" );
228 if ( open(RESTORE_INFO, ">$self->{TopDir}/pc/$host/restores") ) {
229 for ( $i = 0 ; $i < @Restores ; $i++ ) {
230 my %b = %{$Restores[$i]};
231 printf(RESTORE_INFO "%s\n",
232 join("\t", @b{@{$self->{RestoreFields}}}));
241 my($self, $host) = @_;
242 my($ret, $mesg, $config, @configs);
245 push(@configs, "$self->{TopDir}/conf/config.pl");
246 push(@configs, "$self->{TopDir}/pc/$host/config.pl")
247 if ( defined($host) && -f "$self->{TopDir}/pc/$host/config.pl" );
248 foreach $config ( @configs ) {
250 if ( !defined($ret = do $config) && ($! || $@) ) {
251 $mesg = "Couldn't open $config: $!" if ( $! );
252 $mesg = "Couldn't execute $config: $@" if ( $@ );
253 $mesg =~ s/[\n\r]+//;
256 %{$self->{Conf}} = ( %{$self->{Conf} || {}}, %Conf );
258 my $langFile = "$self->{LibDir}/BackupPC/Lang/$self->{Conf}{Language}.pm";
259 if ( !defined($ret = do $langFile) && ($! || $@) ) {
260 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
261 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
262 $mesg =~ s/[\n\r]+//;
265 $self->{Lang} = \%Lang;
270 # Return the mtime of the config file
275 return (stat("$self->{TopDir}/conf/config.pl"))[9];
279 # Returns information from the host file in $self->{TopDir}/conf/hosts.
280 # With no argument a ref to a hash of hosts is returned. Each
281 # hash contains fields as specified in the hosts file. With an
282 # argument a ref to a single hash is returned with information
283 # for just that host.
287 my($self, $host) = @_;
288 my(%hosts, @hdr, @fld);
291 if ( !open(HOST_INFO, "$self->{TopDir}/conf/hosts") ) {
292 print(STDERR $self->timeStamp,
293 "Can't open $self->{TopDir}/conf/hosts\n");
296 while ( <HOST_INFO> ) {
300 next if ( /^\s*$/ || !/^([\w\.-]+\s+.*)/ );
301 @fld = split(/\s+/, $1);
303 if ( defined($host) ) {
304 next if ( lc($fld[0]) ne $host );
305 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
309 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
320 # Return the mtime of the hosts file
325 return (stat("$self->{TopDir}/conf/hosts"))[9];
329 # Stripped down from File::Path. In particular we don't print
330 # many warnings and we try three times to delete each directory
331 # and file -- for some reason the original File::Path rmtree
332 # didn't always completely remove a directory tree on the NetApp.
334 # Warning: this routine changes the cwd.
338 my($self, $pwd, $roots) = @_;
341 if ( defined($roots) && length($roots) ) {
342 $roots = [$roots] unless ref $roots;
344 print "RmTreeQuiet: No root path(s) specified\n";
347 foreach $root (@{$roots}) {
348 $root = $1 if ( $root =~ m{(.*?)/*$} );
350 # Try first to simply unlink the file: this avoids an
351 # extra stat for every file. If it fails (which it
352 # will for directories), check if it is a directory and
355 if ( !unlink($root) ) {
357 my $d = DirHandle->new($root)
358 or print "Can't read $pwd/$root: $!";
361 @files = grep $_!~/^\.{1,2}$/, @files;
362 $self->RmTreeQuiet("$pwd/$root", \@files);
364 rmdir($root) || rmdir($root);
366 unlink($root) || unlink($root);
373 # Move a directory or file away for later deletion
377 my($self, $trashDir, $file) = @_;
380 return if ( !-e $file );
381 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
382 for ( $i = 0 ; $i < 1000 ; $i++ ) {
383 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
385 return if ( rename($file, $f) );
387 # shouldn't get here, but might if you tried to call this
388 # across file systems.... just remove the tree right now.
389 if ( $file =~ /(.*)\/([^\/]*)/ ) {
392 my($cwd) = Cwd::fastcwd();
393 $self->RmTreeQuiet($d, $f);
394 chdir($cwd) if ( $cwd );
399 # Empty the trash directory. Returns 0 if it did nothing.
403 my($self, $trashDir) = @_;
405 my($cwd) = Cwd::fastcwd();
407 return if ( !-d $trashDir );
408 my $d = DirHandle->new($trashDir)
409 or carp "Can't read $trashDir: $!";
412 @files = grep $_!~/^\.{1,2}$/, @files;
413 return 0 if ( !@files );
414 $self->RmTreeQuiet($trashDir, \@files);
415 chdir($cwd) if ( $cwd );
420 # Open a connection to the server. Returns an error string on failure.
421 # Returns undef on success.
425 my($self, $host, $port, $justConnect) = @_;
428 return if ( defined($self->{ServerFD}) );
430 # First try the unix-domain socket
432 my $sockFile = "$self->{TopDir}/log/BackupPC.sock";
433 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
434 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
435 my $err = "unix connect: $!";
438 my $proto = getprotobyname('tcp');
439 my $iaddr = inet_aton($host) || return "unknown host $host";
440 my $paddr = sockaddr_in($port, $iaddr);
442 socket(*FH, PF_INET, SOCK_STREAM, $proto)
443 || return "inet socket: $!";
444 connect(*FH, $paddr) || return "inet connect: $!";
449 my($oldFH) = select(*FH); $| = 1; select($oldFH);
450 $self->{ServerFD} = *FH;
451 return if ( $justConnect );
453 # Read the seed that we need for our MD5 message digest. See
456 sysread($self->{ServerFD}, $self->{ServerSeed}, 1024);
457 $self->{ServerMesgCnt} = 0;
462 # Check that the server connection is still ok
468 return 0 if ( !defined($self->{ServerFD}) );
469 vec(my $FDread, fileno($self->{ServerFD}), 1) = 1;
471 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
472 return 1 if ( !vec($rout, fileno($self->{ServerFD}), 1) );
476 # Disconnect from the server
481 return if ( !defined($self->{ServerFD}) );
482 close($self->{ServerFD});
483 delete($self->{ServerFD});
487 # Sends a message to the server and returns with the reply.
489 # To avoid possible attacks via the TCP socket interface, every client
490 # message is protected by an MD5 digest. The MD5 digest includes four
492 # - a seed that is sent to us when we first connect
493 # - a sequence number that increments for each message
494 # - a shared secret that is stored in $Conf{ServerMesgSecret}
495 # - the message itself.
496 # The message is sent in plain text preceded by the MD5 digest. A
497 # snooper can see the plain-text seed sent by BackupPC and plain-text
498 # message, but cannot construct a valid MD5 digest since the secret in
499 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
500 # since the seed changes on a per-connection and per-message basis.
504 my($self, $mesg) = @_;
505 return if ( !defined(my $fh = $self->{ServerFD}) );
506 my $md5 = Digest::MD5->new;
507 $md5->add($self->{ServerSeed} . $self->{ServerMesgCnt}
508 . $self->{Conf}{ServerMesgSecret} . $mesg);
509 print($fh $md5->b64digest . " $mesg\n");
510 $self->{ServerMesgCnt}++;
515 # Do initialization for child processes
521 open(STDERR, ">&STDOUT");
522 select(STDERR); $| = 1;
523 select(STDOUT); $| = 1;
524 $ENV{PATH} = $self->{Conf}{MyPath};
528 # Compute the MD5 digest of a file. For efficiency we don't
529 # use the whole file for big files:
530 # - for files <= 256K we use the file size and the whole file.
531 # - for files <= 1M we use the file size, the first 128K and
533 # - for files > 1M, we use the file size, the first 128K and
534 # the 8th 128K (ie: the 128K up to 1MB).
535 # See the documentation for a discussion of the tradeoffs in
536 # how much data we use and how many collisions we get.
538 # Returns the MD5 digest (a hex string) and the file size.
542 my($self, $md5, $name) = @_;
543 my($data, $fileSize);
546 $fileSize = (stat($name))[7];
547 return ("", -1) if ( !-f _ );
548 $name = $1 if ( $name =~ /(.*)/ );
549 return ("", 0) if ( $fileSize == 0 );
550 return ("", -1) if ( !open(N, $name) );
552 $md5->add($fileSize);
553 if ( $fileSize > 262144 ) {
555 # read the first and last 131072 bytes of the file,
558 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
559 $md5->add($data) if ( sysread(N, $data, 131072) );
560 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
561 && sysread(N, $data, 131072) );
564 # read the whole file
566 $md5->add($data) if ( sysread(N, $data, $fileSize) );
569 return ($md5->hexdigest, $fileSize);
573 # Compute the MD5 digest of a buffer (string). For efficiency we don't
574 # use the whole string for big strings:
575 # - for files <= 256K we use the file size and the whole file.
576 # - for files <= 1M we use the file size, the first 128K and
578 # - for files > 1M, we use the file size, the first 128K and
579 # the 8th 128K (ie: the 128K up to 1MB).
580 # See the documentation for a discussion of the tradeoffs in
581 # how much data we use and how many collisions we get.
583 # Returns the MD5 digest (a hex string).
587 my($self, $md5, $fileSize, $dataRef) = @_;
590 $md5->add($fileSize);
591 if ( $fileSize > 262144 ) {
593 # add the first and last 131072 bytes of the string,
596 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
597 $md5->add(substr($$dataRef, 0, 131072));
598 $md5->add(substr($$dataRef, $seekPosn, 131072));
601 # add the whole string
603 $md5->add($$dataRef);
605 return $md5->hexdigest;
609 # Given an MD5 digest $d and a compress flag, return the full
614 my($self, $d, $compress, $poolDir) = @_;
616 return if ( $d !~ m{(.)(.)(.)(.*)} );
617 $poolDir = ($compress ? $self->{CPoolDir} : $self->{PoolDir})
618 if ( !defined($poolDir) );
619 return "$poolDir/$1/$2/$3/$1$2$3$4";
623 # For each file, check if the file exists in $self->{TopDir}/pool.
624 # If so, remove the file and make a hardlink to the file in
625 # the pool. Otherwise, if the newFile flag is set, make a
626 # hardlink in the pool to the new file.
628 # Returns 0 if a link should be made to a new file (ie: when the file
629 # is a new file but the newFile flag is 0).
630 # Returns 1 if a link to an existing file is made,
631 # Returns 2 if a link to a new file is made (only if $newFile is set)
632 # Returns negative on error.
636 my($self, $name, $d, $newFile, $compress) = @_;
639 return -1 if ( !-f $name );
640 for ( $i = -1 ; ; $i++ ) {
641 return -2 if ( !defined($rawFile = $self->MD52Path($d, $compress)) );
642 $rawFile .= "_$i" if ( $i >= 0 );
644 if ( !compare($name, $rawFile) ) {
646 return -3 if ( !link($rawFile, $name) );
649 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
651 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
652 mkpath($newDir, 0, 0777) if ( !-d $newDir );
653 return -4 if ( !link($name, $rawFile) );
663 my($self, $host) = @_;
666 $pingArgs = $self->{Conf}{PingArgs};
668 # Merge variables into $pingArgs
673 $pingArgs =~ s/\$(\w+)/defined($vars->{$1})
674 ? $self->shellEscape($vars->{$1})
677 # Do a first ping in case the PC needs to wakeup
679 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
682 # Do a second ping and get the round-trip time in msec
684 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
686 return $1 if ( $s !~ /time=([\d\.]+)\s*ms/ );
687 return $1/1000 if ( $s !~ /time=([\d\.]+)\s*usec/ );
691 sub CheckFileSystemUsage
694 my($topDir) = $self->{TopDir};
697 if ( $^O eq "solaris" ) {
698 $s = `$self->{Conf}{DfPath} -k $topDir 2>&1`;
699 return 0 if ( $? || $s !~ /(\d+)%/s );
701 } elsif ( $^O eq "sunos" ) {
702 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
703 return 0 if ( $? || $s !~ /(\d+)%/s );
705 } elsif ( $^O eq "linux" ) {
706 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
707 return 0 if ( $? || $s !~ /(\d+)%/s );
716 my($self, $host) = @_;
717 my($netBiosHostName, $netBiosUserName);
719 foreach ( split(/[\n\r]+/, `$self->{Conf}{NmbLookupPath} -A $host 2>&1`) ) {
720 next if ( !/([\w-]+)\s*<(\w{2})\> - .*<ACTIVE>/i );
721 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
722 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
724 return if ( !defined($netBiosHostName) );
725 return (lc($netBiosHostName), lc($netBiosUserName));
728 sub fileNameEltMangle
730 my($self, $name) = @_;
732 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
737 # We store files with every name preceded by "f". This
738 # avoids possible name conflicts with other information
739 # we store in the same directories (eg: attribute info).
740 # The process of turning a normal path into one with each
741 # node prefixed with "f" is called mangling.
745 my($self, $name) = @_;
747 $name =~ s{/([^/]+)}{"/" . $self->fileNameEltMangle($1)}eg;
748 $name =~ s{^([^/]+)}{$self->fileNameEltMangle($1)}eg;
753 # This undoes FileNameMangle
757 my($self, $name) = @_;
761 $name =~ s{%(..)}{chr(hex($1))}eg;
766 # Escape shell meta-characters with backslashes.
767 # This should be applied to each argument seperately, not an
768 # entire shell command.
772 my($self, $cmd) = @_;
774 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;