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