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