lib/BackupPC/Lib.pm

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