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;
57 TopDir => $topDir || '__TOPDIR__',
58 BinDir => '__INSTALLDIR__/bin',
61 num type startTime endTime
62 nFiles size nFilesExist sizeExist nFilesNew sizeNew
63 xferErrs xferBadFile xferBadShare tarErrs
64 compress sizeExistComp sizeNewComp
65 noFill fillFromNum mangle
68 num startTime endTime result errorMsg nFiles size
69 tarCreateErrs xferErrs
73 # Clean up %ENV and setup other variables.
75 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
76 $self->{PoolDir} = "$self->{TopDir}/pool";
77 $self->{CPoolDir} = "$self->{TopDir}/cpool";
78 if ( defined(my $error = $self->ConfigRead()) ) {
79 print(STDERR $error, "\n");
88 return $self->{TopDir};
94 return $self->{BinDir};
100 return $self->{Version};
106 return %{$self->{Conf}};
116 return " trashClean ";
121 my($self, $t, $noPad) = @_;
122 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
123 = localtime($t || time);
126 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
127 . ($noPad ? "" : " ");
131 # An ISO 8601-compliant version of timeStamp. Needed by the
132 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
133 # Also see http://www.w3.org/TR/NOTE-datetime.
137 my($self, $t, $noPad) = @_;
138 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
139 = localtime($t || time);
142 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
143 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
144 . ($noPad ? "" : " ");
149 my($self, $host) = @_;
150 local(*BK_INFO, *LOCK);
153 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
154 if ( open(BK_INFO, "$self->{TopDir}/pc/$host/backups") ) {
155 while ( <BK_INFO> ) {
157 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
159 @{$Backups[@Backups]}{@{$self->{BackupFields}}} = split(/\t/);
169 my($self, $host, @Backups) = @_;
170 local(*BK_INFO, *LOCK);
173 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
174 unlink("$self->{TopDir}/pc/$host/backups.old")
175 if ( -f "$self->{TopDir}/pc/$host/backups.old" );
176 rename("$self->{TopDir}/pc/$host/backups",
177 "$self->{TopDir}/pc/$host/backups.old")
178 if ( -f "$self->{TopDir}/pc/$host/backups" );
179 if ( open(BK_INFO, ">$self->{TopDir}/pc/$host/backups") ) {
180 for ( $i = 0 ; $i < @Backups ; $i++ ) {
181 my %b = %{$Backups[$i]};
182 printf(BK_INFO "%s\n", join("\t", @b{@{$self->{BackupFields}}}));
191 my($self, $host) = @_;
192 local(*RESTORE_INFO, *LOCK);
195 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
196 if ( open(RESTORE_INFO, "$self->{TopDir}/pc/$host/restores") ) {
197 while ( <RESTORE_INFO> ) {
199 next if ( !/^(\d+.*)/ );
201 @{$Restores[@Restores]}{@{$self->{RestoreFields}}} = split(/\t/);
211 my($self, $host, @Restores) = @_;
212 local(*RESTORE_INFO, *LOCK);
215 flock(LOCK, LOCK_EX) if open(LOCK, "$self->{TopDir}/pc/$host/LOCK");
216 unlink("$self->{TopDir}/pc/$host/restores.old")
217 if ( -f "$self->{TopDir}/pc/$host/restores.old" );
218 rename("$self->{TopDir}/pc/$host/restores",
219 "$self->{TopDir}/pc/$host/restores.old")
220 if ( -f "$self->{TopDir}/pc/$host/restores" );
221 if ( open(RESTORE_INFO, ">$self->{TopDir}/pc/$host/restores") ) {
222 for ( $i = 0 ; $i < @Restores ; $i++ ) {
223 my %b = %{$Restores[$i]};
224 printf(RESTORE_INFO "%s\n",
225 join("\t", @b{@{$self->{RestoreFields}}}));
234 my($self, $host) = @_;
235 my($ret, $mesg, $config, @configs);
238 push(@configs, "$self->{TopDir}/conf/config.pl");
239 push(@configs, "$self->{TopDir}/pc/$host/config.pl")
240 if ( defined($host) && -f "$self->{TopDir}/pc/$host/config.pl" );
241 foreach $config ( @configs ) {
243 if ( !defined($ret = do $config) && ($! || $@) ) {
244 $mesg = "Couldn't open $config: $!" if ( $! );
245 $mesg = "Couldn't execute $config: $@" if ( $@ );
246 $mesg =~ s/[\n\r]+//;
249 %{$self->{Conf}} = ( %{$self->{Conf} || {}}, %Conf );
255 # Return the mtime of the config file
260 return (stat("$self->{TopDir}/conf/config.pl"))[9];
264 # Returns information from the host file in $self->{TopDir}/conf/hosts.
265 # With no argument a ref to a hash of hosts is returned. Each
266 # hash contains fields as specified in the hosts file. With an
267 # argument a ref to a single hash is returned with information
268 # for just that host.
272 my($self, $host) = @_;
273 my(%hosts, @hdr, @fld);
276 if ( !open(HOST_INFO, "$self->{TopDir}/conf/hosts") ) {
277 print(STDERR $self->timeStamp,
278 "Can't open $self->{TopDir}/conf/hosts\n");
281 while ( <HOST_INFO> ) {
284 next if ( /^\s*$/ || !/^([\w\.-]+\s+.*)/ );
285 @fld = split(/\s+/, $1);
287 if ( defined($host) ) {
288 next if ( lc($fld[0]) ne $host );
289 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
292 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
303 # Return the mtime of the hosts file
308 return (stat("$self->{TopDir}/conf/hosts"))[9];
312 # Stripped down from File::Path. In particular we don't print
313 # many warnings and we try three times to delete each directory
314 # and file -- for some reason the original File::Path rmtree
315 # didn't always completely remove a directory tree on the NetApp.
317 # Warning: this routine changes the cwd.
321 my($self, $pwd, $roots) = @_;
324 if ( defined($roots) && length($roots) ) {
325 $roots = [$roots] unless ref $roots;
327 print "RmTreeQuiet: No root path(s) specified\n";
330 foreach $root (@{$roots}) {
331 $root = $1 if ( $root =~ m{(.*?)/*$} );
333 # Try first to simply unlink the file: this avoids an
334 # extra stat for every file. If it fails (which it
335 # will for directories), check if it is a directory and
338 if ( !unlink($root) ) {
340 my $d = DirHandle->new($root)
341 or print "Can't read $pwd/$root: $!";
344 @files = grep $_!~/^\.{1,2}$/, @files;
345 $self->RmTreeQuiet("$pwd/$root", \@files);
347 rmdir($root) || rmdir($root);
349 unlink($root) || unlink($root);
356 # Move a directory or file away for later deletion
360 my($self, $trashDir, $file) = @_;
363 return if ( !-e $file );
364 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
365 for ( $i = 0 ; $i < 1000 ; $i++ ) {
366 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
368 return if ( rename($file, $f) );
370 # shouldn't get here, but might if you tried to call this
371 # across file systems.... just remove the tree right now.
372 if ( $file =~ /(.*)\/([^\/]*)/ ) {
375 my($cwd) = Cwd::fastcwd();
376 $self->RmTreeQuiet($d, $f);
377 chdir($cwd) if ( $cwd );
382 # Empty the trash directory. Returns 0 if it did nothing.
386 my($self, $trashDir) = @_;
388 my($cwd) = Cwd::fastcwd();
390 return if ( !-d $trashDir );
391 my $d = DirHandle->new($trashDir)
392 or carp "Can't read $trashDir: $!";
395 @files = grep $_!~/^\.{1,2}$/, @files;
396 return 0 if ( !@files );
397 $self->RmTreeQuiet($trashDir, \@files);
398 chdir($cwd) if ( $cwd );
403 # Open a connection to the server. Returns an error string on failure.
404 # Returns undef on success.
408 my($self, $host, $port, $justConnect) = @_;
411 return if ( defined($self->{ServerFD}) );
413 # First try the unix-domain socket
415 my $sockFile = "$self->{TopDir}/log/BackupPC.sock";
416 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
417 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
418 my $err = "unix connect: $!";
421 my $proto = getprotobyname('tcp');
422 my $iaddr = inet_aton($host) || return "unknown host $host";
423 my $paddr = sockaddr_in($port, $iaddr);
425 socket(*FH, PF_INET, SOCK_STREAM, $proto)
426 || return "inet socket: $!";
427 connect(*FH, $paddr) || return "inet connect: $!";
432 my($oldFH) = select(*FH); $| = 1; select($oldFH);
433 $self->{ServerFD} = *FH;
434 return if ( $justConnect );
436 # Read the seed that we need for our MD5 message digest. See
439 sysread($self->{ServerFD}, $self->{ServerSeed}, 1024);
440 $self->{ServerMesgCnt} = 0;
445 # Check that the server connection is still ok
451 return 0 if ( !defined($self->{ServerFD}) );
452 vec(my $FDread, fileno($self->{ServerFD}), 1) = 1;
454 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
455 return 1 if ( !vec($rout, fileno($self->{ServerFD}), 1) );
459 # Disconnect from the server
464 return if ( !defined($self->{ServerFD}) );
465 close($self->{ServerFD});
466 delete($self->{ServerFD});
470 # Sends a message to the server and returns with the reply.
472 # To avoid possible attacks via the TCP socket interface, every client
473 # message is protected by an MD5 digest. The MD5 digest includes four
475 # - a seed that is sent to us when we first connect
476 # - a sequence number that increments for each message
477 # - a shared secret that is stored in $Conf{ServerMesgSecret}
478 # - the message itself.
479 # The message is sent in plain text preceded by the MD5 digest. A
480 # snooper can see the plain-text seed sent by BackupPC and plain-text
481 # message, but cannot construct a valid MD5 digest since the secret in
482 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
483 # since the seed changes on a per-connection and per-message basis.
487 my($self, $mesg) = @_;
488 return if ( !defined(my $fh = $self->{ServerFD}) );
489 my $md5 = Digest::MD5->new;
490 $md5->add($self->{ServerSeed} . $self->{ServerMesgCnt}
491 . $self->{Conf}{ServerMesgSecret} . $mesg);
492 print($fh $md5->b64digest . " $mesg\n");
493 $self->{ServerMesgCnt}++;
498 # Do initialization for child processes
504 open(STDERR, ">&STDOUT");
505 select(STDERR); $| = 1;
506 select(STDOUT); $| = 1;
507 $ENV{PATH} = $self->{Conf}{MyPath};
511 # Compute the MD5 digest of a file. For efficiency we don't
512 # use the whole file for big files:
513 # - for files <= 256K we use the file size and the whole file.
514 # - for files <= 1M we use the file size, the first 128K and
516 # - for files > 1M, we use the file size, the first 128K and
517 # the 8th 128K (ie: the 128K up to 1MB).
518 # See the documentation for a discussion of the tradeoffs in
519 # how much data we use and how many collisions we get.
521 # Returns the MD5 digest (a hex string) and the file size.
525 my($self, $md5, $name) = @_;
526 my($data, $fileSize);
529 $fileSize = (stat($name))[7];
530 return ("", -1) if ( !-f _ );
531 $name = $1 if ( $name =~ /(.*)/ );
532 return ("", 0) if ( $fileSize == 0 );
533 return ("", -1) if ( !open(N, $name) );
535 $md5->add($fileSize);
536 if ( $fileSize > 262144 ) {
538 # read the first and last 131072 bytes of the file,
541 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
542 $md5->add($data) if ( sysread(N, $data, 131072) );
543 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
544 && sysread(N, $data, 131072) );
547 # read the whole file
549 $md5->add($data) if ( sysread(N, $data, $fileSize) );
552 return ($md5->hexdigest, $fileSize);
556 # Compute the MD5 digest of a buffer (string). For efficiency we don't
557 # use the whole string for big strings:
558 # - for files <= 256K we use the file size and the whole file.
559 # - for files <= 1M we use the file size, the first 128K and
561 # - for files > 1M, we use the file size, the first 128K and
562 # the 8th 128K (ie: the 128K up to 1MB).
563 # See the documentation for a discussion of the tradeoffs in
564 # how much data we use and how many collisions we get.
566 # Returns the MD5 digest (a hex string).
570 my($self, $md5, $fileSize, $dataRef) = @_;
573 $md5->add($fileSize);
574 if ( $fileSize > 262144 ) {
576 # add the first and last 131072 bytes of the string,
579 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
580 $md5->add(substr($$dataRef, 0, 131072));
581 $md5->add(substr($$dataRef, $seekPosn, 131072));
584 # add the whole string
586 $md5->add($$dataRef);
588 return $md5->hexdigest;
592 # Given an MD5 digest $d and a compress flag, return the full
597 my($self, $d, $compress, $poolDir) = @_;
599 return if ( $d !~ m{(.)(.)(.)(.*)} );
600 $poolDir = ($compress ? $self->{CPoolDir} : $self->{PoolDir})
601 if ( !defined($poolDir) );
602 return "$poolDir/$1/$2/$3/$1$2$3$4";
606 # For each file, check if the file exists in $self->{TopDir}/pool.
607 # If so, remove the file and make a hardlink to the file in
608 # the pool. Otherwise, if the newFile flag is set, make a
609 # hardlink in the pool to the new file.
611 # Returns 0 if a link should be made to a new file (ie: when the file
612 # is a new file but the newFile flag is 0).
613 # Returns 1 if a link to an existing file is made,
614 # Returns 2 if a link to a new file is made (only if $newFile is set)
615 # Returns negative on error.
619 my($self, $name, $d, $newFile, $compress) = @_;
622 return -1 if ( !-f $name );
623 for ( $i = -1 ; ; $i++ ) {
624 return -2 if ( !defined($rawFile = $self->MD52Path($d, $compress)) );
625 $rawFile .= "_$i" if ( $i >= 0 );
627 if ( !compare($name, $rawFile) ) {
629 return -3 if ( !link($rawFile, $name) );
632 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
634 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
635 mkpath($newDir, 0, 0777) if ( !-d $newDir );
636 return -4 if ( !link($name, $rawFile) );
646 my($self, $host) = @_;
649 $pingArgs = $self->{Conf}{PingArgs};
651 # Merge variables into $pingArgs
656 $pingArgs =~ s/\$(\w+)/defined($vars->{$1})
657 ? $self->shellEscape($vars->{$1})
660 # Do a first ping in case the PC needs to wakeup
662 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
665 # Do a second ping and get the round-trip time in msec
667 $s = `$self->{Conf}{PingPath} $pingArgs 2>&1`;
669 return $1 if ( $s !~ /time=([\d\.]+)\s*ms/ );
670 return $1/1000 if ( $s !~ /time=([\d\.]+)\s*usec/ );
674 sub CheckFileSystemUsage
677 my($topDir) = $self->{TopDir};
680 if ( $^O eq "solaris" ) {
681 $s = `$self->{Conf}{DfPath} -k $topDir 2>&1`;
682 return 0 if ( $? || $s !~ /(\d+)%/s );
684 } elsif ( $^O eq "sunos" ) {
685 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
686 return 0 if ( $? || $s !~ /(\d+)%/s );
688 } elsif ( $^O eq "linux" ) {
689 $s = `$self->{Conf}{DfPath} $topDir 2>&1`;
690 return 0 if ( $? || $s !~ /(\d+)%/s );
699 my($self, $host) = @_;
700 my($netBiosHostName, $netBiosUserName);
702 foreach ( split(/[\n\r]+/, `$self->{Conf}{NmbLookupPath} -A $host 2>&1`) ) {
703 next if ( !/([\w-]+)\s*<(\w{2})\> - .*<ACTIVE>/i );
704 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
705 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
707 return if ( !defined($netBiosHostName) );
708 return (lc($netBiosHostName), lc($netBiosUserName));
711 sub fileNameEltMangle
713 my($self, $name) = @_;
715 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
720 # We store files with every name preceded by "f". This
721 # avoids possible name conflicts with other information
722 # we store in the same directories (eg: attribute info).
723 # The process of turning a normal path into one with each
724 # node prefixed with "f" is called mangling.
728 my($self, $name) = @_;
730 $name =~ s{/([^/]+)}{"/" . $self->fileNameEltMangle($1)}eg;
731 $name =~ s{^([^/]+)}{$self->fileNameEltMangle($1)}eg;
736 # This undoes FileNameMangle
740 my($self, $name) = @_;
744 $name =~ s{%(..)}{chr(hex($1))}eg;
749 # Escape shell meta-characters with backslashes.
750 # This should be applied to each argument seperately, not an
751 # entire shell command.
755 my($self, $cmd) = @_;
757 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;