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