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