* Added BackupPC::Xfer::Protocol as a common class for each Xfer
[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     mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
628     for ( $i = 0 ; $i < 1000 ; $i++ ) {
629         $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
630         next if ( -e $f );
631         return if ( rename($file, $f) );
632     }
633     # shouldn't get here, but might if you tried to call this
634     # across file systems.... just remove the tree right now.
635     if ( $file =~ /(.*)\/([^\/]*)/ ) {
636         my($d) = $1;
637         my($f) = $2;
638         my($cwd) = Cwd::fastcwd();
639         $cwd = $1 if ( $cwd =~ /(.*)/ );
640         $bpc->RmTreeQuiet($d, $f);
641         chdir($cwd) if ( $cwd );
642     }
643 }
644
645 #
646 # Empty the trash directory.  Returns 0 if it did nothing, 1 if it
647 # did something, -1 if it failed to remove all the files.
648 #
649 sub RmTreeTrashEmpty
650 {
651     my($bpc, $trashDir) = @_;
652     my(@files);
653     my($cwd) = Cwd::fastcwd();
654
655     $cwd = $1 if ( $cwd =~ /(.*)/ );
656     return if ( !-d $trashDir );
657     my $d = $bpc->dirReadNames($trashDir) or carp "Can't read $trashDir: $!";
658     @files = grep $_ !~ /^\.{1,2}$/, @$d;
659     return 0 if ( !@files );
660     $bpc->RmTreeQuiet($trashDir, \@files);
661     foreach my $f ( @files ) {
662         return -1 if ( -e $f );
663     }
664     chdir($cwd) if ( $cwd );
665     return 1;
666 }
667
668 #
669 # Open a connection to the server.  Returns an error string on failure.
670 # Returns undef on success.
671 #
672 sub ServerConnect
673 {
674     my($bpc, $host, $port, $justConnect) = @_;
675     local(*FH);
676
677     return if ( defined($bpc->{ServerFD}) );
678     #
679     # First try the unix-domain socket
680     #
681     my $sockFile = "$bpc->{LogDir}/BackupPC.sock";
682     socket(*FH, PF_UNIX, SOCK_STREAM, 0)     || return "unix socket: $!";
683     if ( !connect(*FH, sockaddr_un($sockFile)) ) {
684         my $err = "unix connect: $!";
685         close(*FH);
686         if ( $port > 0 ) {
687             my $proto = getprotobyname('tcp');
688             my $iaddr = inet_aton($host)     || return "unknown host $host";
689             my $paddr = sockaddr_in($port, $iaddr);
690
691             socket(*FH, PF_INET, SOCK_STREAM, $proto)
692                                              || return "inet socket: $!";
693             connect(*FH, $paddr)             || return "inet connect: $!";
694         } else {
695             return $err;
696         }
697     }
698     my($oldFH) = select(*FH); $| = 1; select($oldFH);
699     $bpc->{ServerFD} = *FH;
700     return if ( $justConnect );
701     #
702     # Read the seed that we need for our MD5 message digest.  See
703     # ServerMesg below.
704     #
705     sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
706     $bpc->{ServerMesgCnt} = 0;
707     return;
708 }
709
710 #
711 # Check that the server connection is still ok
712 #
713 sub ServerOK
714 {
715     my($bpc) = @_;
716
717     return 0 if ( !defined($bpc->{ServerFD}) );
718     vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
719     my $ein = $FDread;
720     return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
721     return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
722 }
723
724 #
725 # Disconnect from the server
726 #
727 sub ServerDisconnect
728 {
729     my($bpc) = @_;
730     return if ( !defined($bpc->{ServerFD}) );
731     close($bpc->{ServerFD});
732     delete($bpc->{ServerFD});
733 }
734
735 #
736 # Sends a message to the server and returns with the reply.
737 #
738 # To avoid possible attacks via the TCP socket interface, every client
739 # message is protected by an MD5 digest. The MD5 digest includes four
740 # items:
741 #   - a seed that is sent to us when we first connect
742 #   - a sequence number that increments for each message
743 #   - a shared secret that is stored in $Conf{ServerMesgSecret}
744 #   - the message itself.
745 # The message is sent in plain text preceded by the MD5 digest. A
746 # snooper can see the plain-text seed sent by BackupPC and plain-text
747 # message, but cannot construct a valid MD5 digest since the secret in
748 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
749 # since the seed changes on a per-connection and per-message basis.
750 #
751 sub ServerMesg
752 {
753     my($bpc, $mesg) = @_;
754     return if ( !defined(my $fh = $bpc->{ServerFD}) );
755     $mesg =~ s/\n/\\n/g;
756     $mesg =~ s/\r/\\r/g;
757     my $md5 = Digest::MD5->new;
758     $mesg = encode_utf8($mesg);
759     $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
760             . $bpc->{Conf}{ServerMesgSecret} . $mesg);
761     print($fh $md5->b64digest . " $mesg\n");
762     $bpc->{ServerMesgCnt}++;
763     return <$fh>;
764 }
765
766 #
767 # Do initialization for child processes
768 #
769 sub ChildInit
770 {
771     my($bpc) = @_;
772     close(STDERR);
773     open(STDERR, ">&STDOUT");
774     select(STDERR); $| = 1;
775     select(STDOUT); $| = 1;
776     $ENV{PATH} = $bpc->{Conf}{MyPath};
777 }
778
779 #
780 # Compute the MD5 digest of a file.  For efficiency we don't
781 # use the whole file for big files:
782 #   - for files <= 256K we use the file size and the whole file.
783 #   - for files <= 1M we use the file size, the first 128K and
784 #     the last 128K.
785 #   - for files > 1M, we use the file size, the first 128K and
786 #     the 8th 128K (ie: the 128K up to 1MB).
787 # See the documentation for a discussion of the tradeoffs in
788 # how much data we use and how many collisions we get.
789 #
790 # Returns the MD5 digest (a hex string) and the file size.
791 #
792 sub File2MD5
793 {
794     my($bpc, $md5, $name) = @_;
795     my($data, $fileSize);
796     local(*N);
797
798     $fileSize = (stat($name))[7];
799     return ("", -1) if ( !-f _ );
800     $name = $1 if ( $name =~ /(.*)/ );
801     return ("", 0) if ( $fileSize == 0 );
802     return ("", -1) if ( !open(N, $name) );
803     binmode(N);
804     $md5->reset();
805     $md5->add($fileSize);
806     if ( $fileSize > 262144 ) {
807         #
808         # read the first and last 131072 bytes of the file,
809         # up to 1MB.
810         #
811         my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
812         $md5->add($data) if ( sysread(N, $data, 131072) );
813         $md5->add($data) if ( sysseek(N, $seekPosn, 0)
814                                 && sysread(N, $data, 131072) );
815     } else {
816         #
817         # read the whole file
818         #
819         $md5->add($data) if ( sysread(N, $data, $fileSize) );
820     }
821     close(N);
822     return ($md5->hexdigest, $fileSize);
823 }
824
825 #
826 # Compute the MD5 digest of a buffer (string).  For efficiency we don't
827 # use the whole string for big strings:
828 #   - for files <= 256K we use the file size and the whole file.
829 #   - for files <= 1M we use the file size, the first 128K and
830 #     the last 128K.
831 #   - for files > 1M, we use the file size, the first 128K and
832 #     the 8th 128K (ie: the 128K up to 1MB).
833 # See the documentation for a discussion of the tradeoffs in
834 # how much data we use and how many collisions we get.
835 #
836 # Returns the MD5 digest (a hex string).
837 #
838 sub Buffer2MD5
839 {
840     my($bpc, $md5, $fileSize, $dataRef) = @_;
841
842     $md5->reset();
843     $md5->add($fileSize);
844     if ( $fileSize > 262144 ) {
845         #
846         # add the first and last 131072 bytes of the string,
847         # up to 1MB.
848         #
849         my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
850         $md5->add(substr($$dataRef, 0, 131072));
851         $md5->add(substr($$dataRef, $seekPosn, 131072));
852     } else {
853         #
854         # add the whole string
855         #
856         $md5->add($$dataRef);
857     }
858     return $md5->hexdigest;
859 }
860
861 #
862 # Given an MD5 digest $d and a compress flag, return the full
863 # path in the pool.
864 #
865 sub MD52Path
866 {
867     my($bpc, $d, $compress, $poolDir) = @_;
868
869     return if ( $d !~ m{(.)(.)(.)(.*)} );
870     $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
871                     if ( !defined($poolDir) );
872     return "$poolDir/$1/$2/$3/$1$2$3$4";
873 }
874
875 #
876 # For each file, check if the file exists in $bpc->{TopDir}/pool.
877 # If so, remove the file and make a hardlink to the file in
878 # the pool.  Otherwise, if the newFile flag is set, make a
879 # hardlink in the pool to the new file.
880 #
881 # Returns 0 if a link should be made to a new file (ie: when the file
882 #    is a new file but the newFile flag is 0).
883 # Returns 1 if a link to an existing file is made,
884 # Returns 2 if a link to a new file is made (only if $newFile is set)
885 # Returns negative on error.
886 #
887 sub MakeFileLink
888 {
889     my($bpc, $name, $d, $newFile, $compress) = @_;
890     my($i, $rawFile);
891
892     return -1 if ( !-f $name );
893     for ( $i = -1 ; ; $i++ ) {
894         return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
895         $rawFile .= "_$i" if ( $i >= 0 );
896         if ( -f $rawFile ) {
897             if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
898                     && !compare($name, $rawFile) ) {
899                 unlink($name);
900                 return -3 if ( !link($rawFile, $name) );
901                 return 1;
902             }
903         } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
904             my($newDir);
905             ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
906             mkpath($newDir, 0, 0777) if ( !-d $newDir );
907             return -4 if ( !link($name, $rawFile) );
908             return 2;
909         } else {
910             return 0;
911         }
912     }
913 }
914
915 #
916 # Tests if we can create a hardlink from a file in directory
917 # $newDir to a file in directory $targetDir.  A temporary
918 # file in $targetDir is created and an attempt to create a
919 # hardlink of the same name in $newDir is made.  The temporary
920 # files are removed.
921 #
922 # Like link(), returns true on success and false on failure.
923 #
924 sub HardlinkTest
925 {
926     my($bpc, $targetDir, $newDir) = @_;
927
928     my($targetFile, $newFile, $fd);
929     for ( my $i = 0 ; ; $i++ ) {
930         $targetFile = "$targetDir/.TestFileLink.$$.$i";
931         $newFile    = "$newDir/.TestFileLink.$$.$i";
932         last if ( !-e $targetFile && !-e $newFile );
933     }
934     return 0 if ( !open($fd, ">", $targetFile) );
935     close($fd);
936     my $ret = link($targetFile, $newFile);
937     unlink($targetFile);
938     unlink($newFile);
939     return $ret;
940 }
941
942 sub CheckHostAlive
943 {
944     my($bpc, $host) = @_;
945     my($s, $pingCmd, $ret);
946
947     #
948     # Return success if the ping cmd is undefined or empty.
949     #
950     if ( $bpc->{Conf}{PingCmd} eq "" ) {
951         print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
952                    . " is empty\n") if ( $bpc->{verbose} );
953         return 0;
954     }
955
956     my $args = {
957         pingPath => $bpc->{Conf}{PingPath},
958         host     => $host,
959     };
960     $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
961
962     #
963     # Do a first ping in case the PC needs to wakeup
964     #
965     $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
966     if ( $? ) {
967         print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
968                         if ( $bpc->{verbose} );
969         return -1;
970     }
971
972     #
973     # Do a second ping and get the round-trip time in msec
974     #
975     $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
976     if ( $? ) {
977         print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
978                         if ( $bpc->{verbose} );
979         return -1;
980     }
981     if ( $s =~ /rtt\s*min\/avg\/max\/mdev\s*=\s*[\d.]+\/([\d.]+)\/[\d.]+\/[\d.]+\s*(ms|usec)/i ) {
982         $ret = $1;
983         $ret /= 1000 if ( lc($2) eq "usec" );
984     } elsif ( $s =~ /time=([\d.]+)\s*(ms|usec)/i ) {
985         $ret = $1;
986         $ret /= 1000 if ( lc($2) eq "usec" );
987     } else {
988         print(STDERR "CheckHostAlive: can't extract round-trip time"
989                    . " (not fatal)\n") if ( $bpc->{verbose} );
990         $ret = 0;
991     }
992     print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
993     return $ret;
994 }
995
996 sub CheckFileSystemUsage
997 {
998     my($bpc) = @_;
999     my($topDir) = $bpc->{TopDir};
1000     my($s, $dfCmd);
1001
1002     return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
1003     my $args = {
1004         dfPath   => $bpc->{Conf}{DfPath},
1005         topDir   => $bpc->{TopDir},
1006     };
1007     $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
1008     $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
1009     return 0 if ( $? || $s !~ /(\d+)%/s );
1010     return $1;
1011 }
1012
1013 #
1014 # Given an IP address, return the host name and user name via
1015 # NetBios.
1016 #
1017 sub NetBiosInfoGet
1018 {
1019     my($bpc, $host) = @_;
1020     my($netBiosHostName, $netBiosUserName);
1021     my($s, $nmbCmd);
1022
1023     #
1024     # Skip NetBios check if NmbLookupCmd is emtpy
1025     #
1026     if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
1027         print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
1028                    . " is empty\n") if ( $bpc->{verbose} );
1029         return ($host, undef);
1030     }
1031
1032     my $args = {
1033         nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
1034         host          => $host,
1035     };
1036     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
1037     foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
1038         next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
1039         $netBiosHostName ||= $1 if ( $2 eq "00" );  # host is first 00
1040         $netBiosUserName   = $1 if ( $2 eq "03" );  # user is last 03
1041     }
1042     if ( !defined($netBiosHostName) ) {
1043         print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
1044                         if ( $bpc->{verbose} );
1045         return;
1046     }
1047     $netBiosHostName = lc($netBiosHostName);
1048     $netBiosUserName = lc($netBiosUserName);
1049     print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
1050                . " user $netBiosUserName\n") if ( $bpc->{verbose} );
1051     return ($netBiosHostName, $netBiosUserName);
1052 }
1053
1054 #
1055 # Given a NetBios name lookup the IP address via NetBios.
1056 # In the case of a host returning multiple interfaces we
1057 # return the first IP address that matches the subnet mask.
1058 # If none match the subnet mask (or nmblookup doesn't print
1059 # the subnet mask) then just the first IP address is returned.
1060 #
1061 sub NetBiosHostIPFind
1062 {
1063     my($bpc, $host) = @_;
1064     my($netBiosHostName, $netBiosUserName);
1065     my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
1066
1067     #
1068     # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
1069     #
1070     if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
1071         print(STDERR "NetBiosHostIPFind: return $host because"
1072             . " \$Conf{NmbLookupFindHostCmd} is empty\n")
1073                 if ( $bpc->{verbose} );
1074         return $host;
1075     }
1076
1077     my $args = {
1078         nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
1079         host          => $host,
1080     };
1081     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
1082     foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
1083                                                               $args) ) ) {
1084         if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
1085             $subnet = $1;
1086             $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
1087         } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
1088             my $ip = $1;
1089             $firstIpAddr = $ip if ( !defined($firstIpAddr) );
1090             $ipAddr      = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
1091         }
1092     }
1093     $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
1094     if ( defined($ipAddr) ) {
1095         print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
1096                    . " host $host\n") if ( $bpc->{verbose} );
1097         return $ipAddr;
1098     } else {
1099         print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
1100                    . " host $host\n") if ( $bpc->{verbose} );
1101         return;
1102     }
1103 }
1104
1105 sub fileNameEltMangle
1106 {
1107     my($bpc, $name) = @_;
1108
1109     return "" if ( $name eq "" );
1110     $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
1111     return "f$name";
1112 }
1113
1114 #
1115 # We store files with every name preceded by "f".  This
1116 # avoids possible name conflicts with other information
1117 # we store in the same directories (eg: attribute info).
1118 # The process of turning a normal path into one with each
1119 # node prefixed with "f" is called mangling.
1120 #
1121 sub fileNameMangle
1122 {
1123     my($bpc, $name) = @_;
1124
1125     $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
1126     $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
1127     return $name;
1128 }
1129
1130 #
1131 # This undoes FileNameMangle
1132 #
1133 sub fileNameUnmangle
1134 {
1135     my($bpc, $name) = @_;
1136
1137     $name =~ s{/f}{/}g;
1138     $name =~ s{^f}{};
1139     $name =~ s{%(..)}{chr(hex($1))}eg;
1140     return $name;
1141 }
1142
1143 #
1144 # Escape shell meta-characters with backslashes.
1145 # This should be applied to each argument seperately, not an
1146 # entire shell command.
1147 #
1148 sub shellEscape
1149 {
1150     my($bpc, $cmd) = @_;
1151
1152     $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
1153     return $cmd;
1154 }
1155
1156 #
1157 # For printing exec commands (which don't use a shell) so they look like
1158 # a valid shell command this function should be called with the exec
1159 # args.  The shell command string is returned.
1160 #
1161 sub execCmd2ShellCmd
1162 {
1163     my($bpc, @args) = @_;
1164     my $str;
1165
1166     foreach my $a ( @args ) {
1167         $str .= " " if ( $str ne "" );
1168         $str .= $bpc->shellEscape($a);
1169     }
1170     return $str;
1171 }
1172
1173 #
1174 # Do a URI-style escape to protect/encode special characters
1175 #
1176 sub uriEsc
1177 {
1178     my($bpc, $s) = @_;
1179     $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
1180     return $s;
1181 }
1182
1183 #
1184 # Do a URI-style unescape to restore special characters
1185 #
1186 sub uriUnesc
1187 {
1188     my($bpc, $s) = @_;
1189     $s =~ s{%(..)}{chr(hex($1))}eg;
1190     return $s;
1191 }
1192
1193 #
1194 # Do variable substitution prior to execution of a command.
1195 #
1196 sub cmdVarSubstitute
1197 {
1198     my($bpc, $template, $vars) = @_;
1199     my(@cmd);
1200
1201     #
1202     # Return without any substitution if the first entry starts with "&",
1203     # indicating this is perl code.
1204     #
1205     if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1206         return $template;
1207     }
1208     if ( ref($template) ne "ARRAY" ) {
1209         #
1210         # Split at white space, except if escaped by \
1211         #
1212         $template = [split(/(?<!\\)\s+/, $template)];
1213         #
1214         # Remove the \ that escaped white space.
1215         #
1216         foreach ( @$template ) {
1217             s{\\(\s)}{$1}g;
1218         }
1219     }
1220     #
1221     # Merge variables into @tarClientCmd
1222     #
1223     foreach my $arg ( @$template ) {
1224         #
1225         # Replace scalar variables first
1226         #
1227         $arg =~ s{\$(\w+)(\+?)}{
1228             exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1229                 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1230                 : "\$$1$2"
1231         }eg;
1232         #
1233         # Now replicate any array arguments; this just works for just one
1234         # array var in each argument.
1235         #
1236         if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1237             my $pre  = $1;
1238             my $var  = $2;
1239             my $esc  = $3;
1240             my $post = $4;
1241             foreach my $v ( @{$vars->{$var}} ) {
1242                 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1243                 push(@cmd, "$pre$v$post");
1244             }
1245         } else {
1246             push(@cmd, $arg);
1247         }
1248     }
1249     return \@cmd;
1250 }
1251
1252 #
1253 # Exec or eval a command.  $cmd is either a string on an array ref.
1254 #
1255 # @args are optional arguments for the eval() case; they are not used
1256 # for exec().
1257 #
1258 sub cmdExecOrEval
1259 {
1260     my($bpc, $cmd, @args) = @_;
1261     
1262     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1263         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1264         print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1265                         if ( $bpc->{verbose} );
1266         eval($cmd);
1267         print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1268         exit(1);
1269     } else {
1270         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1271         print(STDERR "cmdExecOrEval: about to exec ",
1272               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1273                         if ( $bpc->{verbose} );
1274         alarm(0);
1275         $cmd = [map { m/(.*)/ } @$cmd];         # untaint
1276         #
1277         # force list-form of exec(), ie: no shell even for 1 arg
1278         #
1279         exec { $cmd->[0] } @$cmd;
1280         print(STDERR "Exec failed for @$cmd\n");
1281         exit(1);
1282     }
1283 }
1284
1285 #
1286 # System or eval a command.  $cmd is either a string on an array ref.
1287 # $stdoutCB is a callback for output generated by the command.  If it
1288 # is undef then output is returned.  If it is a code ref then the function
1289 # is called with each piece of output as an argument.  If it is a scalar
1290 # ref the output is appended to this variable.
1291 #
1292 # @args are optional arguments for the eval() case; they are not used
1293 # for system().
1294 #
1295 # Also, $? should be set when the CHILD pipe is closed.
1296 #
1297 sub cmdSystemOrEvalLong
1298 {
1299     my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_;
1300     my($pid, $out, $allOut);
1301     local(*CHILD);
1302     
1303     $? = 0;
1304     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1305         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1306         print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1307                         if ( $bpc->{verbose} );
1308         $out = eval($cmd);
1309         $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1310         &$stdoutCB($out)   if ( ref($stdoutCB) eq 'CODE' );
1311         print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1312                         if ( $bpc->{verbose} );
1313         return $out        if ( !defined($stdoutCB) );
1314         return;
1315     } else {
1316         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1317         print(STDERR "cmdSystemOrEval: about to system ",
1318               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1319                         if ( $bpc->{verbose} );
1320         if ( !defined($pid = open(CHILD, "-|")) ) {
1321             my $err = "Can't fork to run @$cmd\n";
1322             $? = 1;
1323             $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1324             &$stdoutCB($err)   if ( ref($stdoutCB) eq 'CODE' );
1325             return $err        if ( !defined($stdoutCB) );
1326             return;
1327         }
1328         binmode(CHILD);
1329         if ( !$pid ) {
1330             #
1331             # This is the child
1332             #
1333             close(STDERR);
1334             if ( $ignoreStderr ) {
1335                 open(STDERR, ">", "/dev/null");
1336             } else {
1337                 open(STDERR, ">&STDOUT");
1338             }
1339             alarm(0);
1340             $cmd = [map { m/(.*)/ } @$cmd];             # untaint
1341             #
1342             # force list-form of exec(), ie: no shell even for 1 arg
1343             #
1344             exec { $cmd->[0] } @$cmd;
1345             print(STDERR "Exec of @$cmd failed\n");
1346             exit(1);
1347         }
1348
1349         #
1350         # Notify caller of child's pid
1351         #
1352         &$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" );
1353
1354         #
1355         # The parent gathers the output from the child
1356         #
1357         while ( <CHILD> ) {
1358             $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1359             &$stdoutCB($_)   if ( ref($stdoutCB) eq 'CODE' );
1360             $out .= $_       if ( !defined($stdoutCB) );
1361             $allOut .= $_    if ( $bpc->{verbose} );
1362         }
1363         $? = 0;
1364         close(CHILD);
1365     }
1366     print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1367                         if ( $bpc->{verbose} );
1368     return $out;
1369 }
1370
1371 #
1372 # The shorter version that sets $ignoreStderr = 0, ie: merges stdout
1373 # and stderr together.
1374 #
1375 sub cmdSystemOrEval
1376 {
1377     my($bpc, $cmd, $stdoutCB, @args) = @_;
1378
1379     return $bpc->cmdSystemOrEvalLong($cmd, $stdoutCB, 0, undef, @args);
1380 }
1381
1382 #
1383 # Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}
1384 # to hashes and $conf->{$shareName} to an array.
1385 #
1386 sub backupFileConfFix
1387 {
1388     my($bpc, $conf, $shareName) = @_;
1389
1390     $conf->{$shareName} = [ $conf->{$shareName} ]
1391                     if ( ref($conf->{$shareName}) ne "ARRAY" );
1392     foreach my $param qw(BackupFilesOnly BackupFilesExclude) {
1393         next if ( !defined($conf->{$param}) );
1394         if ( ref($conf->{$param}) eq "HASH" ) {
1395             #
1396             # A "*" entry means wildcard - it is the default for
1397             # all shares.  Replicate the "*" entry for all shares,
1398             # but still allow override of specific entries.
1399             #
1400             next if ( !defined($conf->{$param}{"*"}) );
1401             $conf->{$param} = {
1402                                     map({ $_ => $conf->{$param}{"*"} }
1403                                             @{$conf->{$shareName}}),
1404                                     %{$conf->{$param}}
1405                               };
1406         } else {
1407             $conf->{$param} = [ $conf->{$param} ]
1408                                     if ( ref($conf->{$param}) ne "ARRAY" );
1409             $conf->{$param} = { map { $_ => $conf->{$param} }
1410                                     @{$conf->{$shareName}} };
1411         }
1412     }
1413 }
1414
1415 #
1416 # This is sort() compare function, used below.
1417 #
1418 # New client LOG names are LOG.MMYYYY.  Old style names are
1419 # LOG, LOG.0, LOG.1 etc.  Sort them so new names are
1420 # first, and newest to oldest.
1421 #
1422 sub compareLOGName
1423 {
1424     my $na = $1 if ( $a =~ /LOG\.(\d+)(\.z)?$/ );
1425     my $nb = $1 if ( $b =~ /LOG\.(\d+)(\.z)?$/ );
1426
1427     $na = -1 if ( !defined($na) );
1428     $nb = -1 if ( !defined($nb) );
1429
1430     if ( length($na) >= 5 && length($nb) >= 5 ) {
1431         #
1432         # Both new style: format is MMYYYY.  Bigger dates are
1433         # more recent.
1434         #
1435         my $ma = $2 * 12 + $1 if ( $na =~ /(\d+)(\d{4})/ );
1436         my $mb = $2 * 12 + $1 if ( $nb =~ /(\d+)(\d{4})/ );
1437         return $mb - $ma;
1438     } elsif ( length($na) >= 5 && length($nb) < 5 ) {
1439         return -1;
1440     } elsif ( length($na) < 5 && length($nb) >= 5 ) {
1441         return 1;
1442     } else {
1443         #
1444         # Both old style.  Smaller numbers are more recent.
1445         #
1446         return $na - $nb;
1447     }
1448 }
1449
1450 #
1451 # Returns list of paths to a clients's (or main) LOG files,
1452 # most recent first.
1453 #
1454 sub sortedPCLogFiles
1455 {
1456     my($bpc, $host) = @_;
1457
1458     my(@files, $dir);
1459
1460     if ( $host ne "" ) {
1461         $dir = "$bpc->{TopDir}/pc/$host";
1462     } else {
1463         $dir = "$bpc->{LogDir}";
1464     }
1465     if ( opendir(DIR, $dir) ) {
1466         foreach my $file ( readdir(DIR) ) {
1467             next if ( !-f "$dir/$file" );
1468             next if ( $file ne "LOG" && $file !~ /^LOG\.\d/ );
1469             push(@files, "$dir/$file");
1470         }
1471         closedir(DIR);
1472     }
1473     return sort compareLOGName @files;
1474 }
1475
1476 #
1477 # converts a glob-style pattern into a perl regular expression.
1478 #
1479 sub glob2re
1480 {
1481     my ( $bpc, $glob ) = @_;
1482     my ( $char, $subst );
1483
1484     # $escapeChars escapes characters with no special glob meaning but
1485     # have meaning in regexps.
1486     my $escapeChars = [ '.', '/', ];
1487
1488     # $charMap is where we implement the special meaning of glob
1489     # patterns and translate them to regexps.
1490     my $charMap = {
1491                     '?' => '[^/]',
1492                     '*' => '[^/]*', };
1493
1494     # multiple forward slashes are equivalent to one slash.  We should
1495     # never have to use this.
1496     $glob =~ s/\/+/\//;
1497
1498     foreach $char (@$escapeChars) {
1499         $glob =~ s/\Q$char\E/\\$char/g;
1500     }
1501
1502     while ( ( $char, $subst ) = each(%$charMap) ) {
1503         $glob =~ s/(?<!\\)\Q$char\E/$subst/g;
1504     }
1505
1506     return $glob;
1507 }
1508
1509 1;