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