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 return if ( !defined($self->{Conf}{Language}) );
259 my $langFile = "$self->{LibDir}/BackupPC/Lang/$self->{Conf}{Language}.pm";
260 if ( !defined($ret = do $langFile) && ($! || $@) ) {
261 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
262 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
263 $mesg =~ s/[\n\r]+//;
266 $self->{Lang} = \%Lang;
271 # Return the mtime of the config file
276 return (stat("$self->{TopDir}/conf/config.pl"))[9];
280 # Returns information from the host file in $self->{TopDir}/conf/hosts.
281 # With no argument a ref to a hash of hosts is returned. Each
282 # hash contains fields as specified in the hosts file. With an
283 # argument a ref to a single hash is returned with information
284 # for just that host.
288 my($self, $host) = @_;
289 my(%hosts, @hdr, @fld);
292 if ( !open(HOST_INFO, "$self->{TopDir}/conf/hosts") ) {
293 print(STDERR $self->timeStamp,
294 "Can't open $self->{TopDir}/conf/hosts\n");
297 while ( <HOST_INFO> ) {
301 next if ( /^\s*$/ || !/^([\w\.-]+\s+.*)/ );
302 @fld = split(/\s+/, $1);
304 if ( defined($host) ) {
305 next if ( lc($fld[0]) ne $host );
306 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
310 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
321 # Return the mtime of the hosts file
326 return (stat("$self->{TopDir}/conf/hosts"))[9];
330 # Stripped down from File::Path. In particular we don't print
331 # many warnings and we try three times to delete each directory
332 # and file -- for some reason the original File::Path rmtree
333 # didn't always completely remove a directory tree on the NetApp.
335 # Warning: this routine changes the cwd.
339 my($self, $pwd, $roots) = @_;
342 if ( defined($roots) && length($roots) ) {
343 $roots = [$roots] unless ref $roots;
345 print "RmTreeQuiet: No root path(s) specified\n";
348 foreach $root (@{$roots}) {
349 $root = $1 if ( $root =~ m{(.*?)/*$} );
351 # Try first to simply unlink the file: this avoids an
352 # extra stat for every file. If it fails (which it
353 # will for directories), check if it is a directory and
356 if ( !unlink($root) ) {
358 my $d = DirHandle->new($root)
359 or print "Can't read $pwd/$root: $!";
362 @files = grep $_!~/^\.{1,2}$/, @files;
363 $self->RmTreeQuiet("$pwd/$root", \@files);
365 rmdir($root) || rmdir($root);
367 unlink($root) || unlink($root);
374 # Move a directory or file away for later deletion
378 my($self, $trashDir, $file) = @_;
381 return if ( !-e $file );
382 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
383 for ( $i = 0 ; $i < 1000 ; $i++ ) {
384 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
386 return if ( rename($file, $f) );
388 # shouldn't get here, but might if you tried to call this
389 # across file systems.... just remove the tree right now.
390 if ( $file =~ /(.*)\/([^\/]*)/ ) {
393 my($cwd) = Cwd::fastcwd();
394 $self->RmTreeQuiet($d, $f);
395 chdir($cwd) if ( $cwd );
400 # Empty the trash directory. Returns 0 if it did nothing.
404 my($self, $trashDir) = @_;
406 my($cwd) = Cwd::fastcwd();
408 return if ( !-d $trashDir );
409 my $d = DirHandle->new($trashDir)
410 or carp "Can't read $trashDir: $!";
413 @files = grep $_!~/^\.{1,2}$/, @files;
414 return 0 if ( !@files );
415 $self->RmTreeQuiet($trashDir, \@files);
416 chdir($cwd) if ( $cwd );
421 # Open a connection to the server. Returns an error string on failure.
422 # Returns undef on success.
426 my($self, $host, $port, $justConnect) = @_;
429 return if ( defined($self->{ServerFD}) );
431 # First try the unix-domain socket
433 my $sockFile = "$self->{TopDir}/log/BackupPC.sock";
434 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
435 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
436 my $err = "unix connect: $!";
439 my $proto = getprotobyname('tcp');
440 my $iaddr = inet_aton($host) || return "unknown host $host";
441 my $paddr = sockaddr_in($port, $iaddr);
443 socket(*FH, PF_INET, SOCK_STREAM, $proto)
444 || return "inet socket: $!";
445 connect(*FH, $paddr) || return "inet connect: $!";
450 my($oldFH) = select(*FH); $| = 1; select($oldFH);
451 $self->{ServerFD} = *FH;
452 return if ( $justConnect );
454 # Read the seed that we need for our MD5 message digest. See
457 sysread($self->{ServerFD}, $self->{ServerSeed}, 1024);
458 $self->{ServerMesgCnt} = 0;
463 # Check that the server connection is still ok
469 return 0 if ( !defined($self->{ServerFD}) );
470 vec(my $FDread, fileno($self->{ServerFD}), 1) = 1;
472 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
473 return 1 if ( !vec($rout, fileno($self->{ServerFD}), 1) );
477 # Disconnect from the server
482 return if ( !defined($self->{ServerFD}) );
483 close($self->{ServerFD});
484 delete($self->{ServerFD});
488 # Sends a message to the server and returns with the reply.
490 # To avoid possible attacks via the TCP socket interface, every client
491 # message is protected by an MD5 digest. The MD5 digest includes four
493 # - a seed that is sent to us when we first connect
494 # - a sequence number that increments for each message
495 # - a shared secret that is stored in $Conf{ServerMesgSecret}
496 # - the message itself.
497 # The message is sent in plain text preceded by the MD5 digest. A
498 # snooper can see the plain-text seed sent by BackupPC and plain-text
499 # message, but cannot construct a valid MD5 digest since the secret in
500 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
501 # since the seed changes on a per-connection and per-message basis.
505 my($self, $mesg) = @_;
506 return if ( !defined(my $fh = $self->{ServerFD}) );
507 my $md5 = Digest::MD5->new;
508 $md5->add($self->{ServerSeed} . $self->{ServerMesgCnt}
509 . $self->{Conf}{ServerMesgSecret} . $mesg);
510 print($fh $md5->b64digest . " $mesg\n");
511 $self->{ServerMesgCnt}++;
516 # Do initialization for child processes
522 open(STDERR, ">&STDOUT");
523 select(STDERR); $| = 1;
524 select(STDOUT); $| = 1;
525 $ENV{PATH} = $self->{Conf}{MyPath};
529 # Compute the MD5 digest of a file. For efficiency we don't
530 # use the whole file for big files:
531 # - for files <= 256K we use the file size and the whole file.
532 # - for files <= 1M we use the file size, the first 128K and
534 # - for files > 1M, we use the file size, the first 128K and
535 # the 8th 128K (ie: the 128K up to 1MB).
536 # See the documentation for a discussion of the tradeoffs in
537 # how much data we use and how many collisions we get.
539 # Returns the MD5 digest (a hex string) and the file size.
543 my($self, $md5, $name) = @_;
544 my($data, $fileSize);
547 $fileSize = (stat($name))[7];
548 return ("", -1) if ( !-f _ );
549 $name = $1 if ( $name =~ /(.*)/ );
550 return ("", 0) if ( $fileSize == 0 );
551 return ("", -1) if ( !open(N, $name) );
553 $md5->add($fileSize);
554 if ( $fileSize > 262144 ) {
556 # read the first and last 131072 bytes of the file,
559 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
560 $md5->add($data) if ( sysread(N, $data, 131072) );
561 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
562 && sysread(N, $data, 131072) );
565 # read the whole file
567 $md5->add($data) if ( sysread(N, $data, $fileSize) );
570 return ($md5->hexdigest, $fileSize);
574 # Compute the MD5 digest of a buffer (string). For efficiency we don't
575 # use the whole string for big strings:
576 # - for files <= 256K we use the file size and the whole file.
577 # - for files <= 1M we use the file size, the first 128K and
579 # - for files > 1M, we use the file size, the first 128K and
580 # the 8th 128K (ie: the 128K up to 1MB).
581 # See the documentation for a discussion of the tradeoffs in
582 # how much data we use and how many collisions we get.
584 # Returns the MD5 digest (a hex string).
588 my($self, $md5, $fileSize, $dataRef) = @_;
591 $md5->add($fileSize);
592 if ( $fileSize > 262144 ) {
594 # add the first and last 131072 bytes of the string,
597 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
598 $md5->add(substr($$dataRef, 0, 131072));
599 $md5->add(substr($$dataRef, $seekPosn, 131072));
602 # add the whole string
604 $md5->add($$dataRef);
606 return $md5->hexdigest;
610 # Given an MD5 digest $d and a compress flag, return the full
615 my($self, $d, $compress, $poolDir) = @_;
617 return if ( $d !~ m{(.)(.)(.)(.*)} );
618 $poolDir = ($compress ? $self->{CPoolDir} : $self->{PoolDir})
619 if ( !defined($poolDir) );
620 return "$poolDir/$1/$2/$3/$1$2$3$4";
624 # For each file, check if the file exists in $self->{TopDir}/pool.
625 # If so, remove the file and make a hardlink to the file in
626 # the pool. Otherwise, if the newFile flag is set, make a
627 # hardlink in the pool to the new file.
629 # Returns 0 if a link should be made to a new file (ie: when the file
630 # is a new file but the newFile flag is 0).
631 # Returns 1 if a link to an existing file is made,
632 # Returns 2 if a link to a new file is made (only if $newFile is set)
633 # Returns negative on error.
637 my($self, $name, $d, $newFile, $compress) = @_;
640 return -1 if ( !-f $name );
641 for ( $i = -1 ; ; $i++ ) {
642 return -2 if ( !defined($rawFile = $self->MD52Path($d, $compress)) );
643 $rawFile .= "_$i" if ( $i >= 0 );
645 if ( !compare($name, $rawFile) ) {
647 return -3 if ( !link($rawFile, $name) );
650 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
652 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
653 mkpath($newDir, 0, 0777) if ( !-d $newDir );
654 return -4 if ( !link($name, $rawFile) );
664 my($self, $host) = @_;
667 $pingArgs = $self->{Conf}{PingArgs};
669 # Merge variables into $pingArgs
674 $pingArgs =~ s/\$(\w+)/defined($vars->{$1})
675 ? $self->shellEscape($vars->{$1})
678 # Do a first ping in case the PC needs to wakeup
680 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
683 # Do a second ping and get the round-trip time in msec
685 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
687 return $1 if ( $s !~ /time=([\d\.]+)\s*ms/ );
688 return $1/1000 if ( $s !~ /time=([\d\.]+)\s*usec/ );
692 sub CheckFileSystemUsage
695 my($topDir) = $self->{TopDir};
698 if ( $^O eq "solaris" ) {
699 $s = `$self->{Conf}{DfPath} -k $topDir 2>&1`;
700 return 0 if ( $? || $s !~ /(\d+)%/s );
702 } elsif ( $^O eq "sunos" ) {
703 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
704 return 0 if ( $? || $s !~ /(\d+)%/s );
706 } elsif ( $^O eq "linux" ) {
707 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
708 return 0 if ( $? || $s !~ /(\d+)%/s );
717 my($self, $host) = @_;
718 my($netBiosHostName, $netBiosUserName);
720 foreach ( split(/[\n\r]+/, `$self->{Conf}{NmbLookupPath} -A $host 2>&1`) ) {
721 next if ( !/([\w-]+)\s*<(\w{2})\> - .*<ACTIVE>/i );
722 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
723 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
725 return if ( !defined($netBiosHostName) );
726 return (lc($netBiosHostName), lc($netBiosUserName));
729 sub fileNameEltMangle
731 my($self, $name) = @_;
733 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
738 # We store files with every name preceded by "f". This
739 # avoids possible name conflicts with other information
740 # we store in the same directories (eg: attribute info).
741 # The process of turning a normal path into one with each
742 # node prefixed with "f" is called mangling.
746 my($self, $name) = @_;
748 $name =~ s{/([^/]+)}{"/" . $self->fileNameEltMangle($1)}eg;
749 $name =~ s{^([^/]+)}{$self->fileNameEltMangle($1)}eg;
754 # This undoes FileNameMangle
758 my($self, $name) = @_;
762 $name =~ s{%(..)}{chr(hex($1))}eg;
767 # Escape shell meta-characters with backslashes.
768 # This should be applied to each argument seperately, not an
769 # entire shell command.
773 my($self, $cmd) = @_;
775 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;