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