cb66a106ff6900381a961c9ac486a30c3f8fb0ae
[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-2009  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.0beta0, released 5 April 2009.
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.0beta0',
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, $config);
368         return $mesg if ( defined($mesg) );
369         $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         #
1050         # skip <GROUP> and other non <ACTIVE> entries
1051         #
1052         next if ( /<\w{2}> - <GROUP>/i );
1053         next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
1054         $netBiosHostName ||= $1 if ( $2 eq "00" );  # host is first 00
1055         $netBiosUserName   = $1 if ( $2 eq "03" );  # user is last 03
1056     }
1057     if ( !defined($netBiosHostName) ) {
1058         print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
1059                         if ( $bpc->{verbose} );
1060         return;
1061     }
1062     $netBiosHostName = lc($netBiosHostName);
1063     $netBiosUserName = lc($netBiosUserName);
1064     print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
1065                . " user $netBiosUserName\n") if ( $bpc->{verbose} );
1066     return ($netBiosHostName, $netBiosUserName);
1067 }
1068
1069 #
1070 # Given a NetBios name lookup the IP address via NetBios.
1071 # In the case of a host returning multiple interfaces we
1072 # return the first IP address that matches the subnet mask.
1073 # If none match the subnet mask (or nmblookup doesn't print
1074 # the subnet mask) then just the first IP address is returned.
1075 #
1076 sub NetBiosHostIPFind
1077 {
1078     my($bpc, $host) = @_;
1079     my($netBiosHostName, $netBiosUserName);
1080     my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
1081
1082     #
1083     # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
1084     #
1085     if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
1086         print(STDERR "NetBiosHostIPFind: return $host because"
1087             . " \$Conf{NmbLookupFindHostCmd} is empty\n")
1088                 if ( $bpc->{verbose} );
1089         return $host;
1090     }
1091
1092     my $args = {
1093         nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
1094         host          => $host,
1095     };
1096     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
1097     foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
1098                                                               $args) ) ) {
1099         if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
1100             $subnet = $1;
1101             $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
1102         } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
1103             my $ip = $1;
1104             $firstIpAddr = $ip if ( !defined($firstIpAddr) );
1105             $ipAddr      = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
1106         }
1107     }
1108     $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
1109     if ( defined($ipAddr) ) {
1110         print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
1111                    . " host $host\n") if ( $bpc->{verbose} );
1112         return $ipAddr;
1113     } else {
1114         print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
1115                    . " host $host\n") if ( $bpc->{verbose} );
1116         return;
1117     }
1118 }
1119
1120 sub fileNameEltMangle
1121 {
1122     my($bpc, $name) = @_;
1123
1124     return "" if ( $name eq "" );
1125     $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
1126     return "f$name";
1127 }
1128
1129 #
1130 # We store files with every name preceded by "f".  This
1131 # avoids possible name conflicts with other information
1132 # we store in the same directories (eg: attribute info).
1133 # The process of turning a normal path into one with each
1134 # node prefixed with "f" is called mangling.
1135 #
1136 sub fileNameMangle
1137 {
1138     my($bpc, $name) = @_;
1139
1140     $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
1141     $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
1142     return $name;
1143 }
1144
1145 #
1146 # This undoes FileNameMangle
1147 #
1148 sub fileNameUnmangle
1149 {
1150     my($bpc, $name) = @_;
1151
1152     $name =~ s{/f}{/}g;
1153     $name =~ s{^f}{};
1154     $name =~ s{%(..)}{chr(hex($1))}eg;
1155     return $name;
1156 }
1157
1158 #
1159 # Escape shell meta-characters with backslashes.
1160 # This should be applied to each argument seperately, not an
1161 # entire shell command.
1162 #
1163 sub shellEscape
1164 {
1165     my($bpc, $cmd) = @_;
1166
1167     $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
1168     return $cmd;
1169 }
1170
1171 #
1172 # For printing exec commands (which don't use a shell) so they look like
1173 # a valid shell command this function should be called with the exec
1174 # args.  The shell command string is returned.
1175 #
1176 sub execCmd2ShellCmd
1177 {
1178     my($bpc, @args) = @_;
1179     my $str;
1180
1181     foreach my $a ( @args ) {
1182         $str .= " " if ( $str ne "" );
1183         $str .= $bpc->shellEscape($a);
1184     }
1185     return $str;
1186 }
1187
1188 #
1189 # Do a URI-style escape to protect/encode special characters
1190 #
1191 sub uriEsc
1192 {
1193     my($bpc, $s) = @_;
1194     $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
1195     return $s;
1196 }
1197
1198 #
1199 # Do a URI-style unescape to restore special characters
1200 #
1201 sub uriUnesc
1202 {
1203     my($bpc, $s) = @_;
1204     $s =~ s{%(..)}{chr(hex($1))}eg;
1205     return $s;
1206 }
1207
1208 #
1209 # Do variable substitution prior to execution of a command.
1210 #
1211 sub cmdVarSubstitute
1212 {
1213     my($bpc, $template, $vars) = @_;
1214     my(@cmd);
1215
1216     #
1217     # Return without any substitution if the first entry starts with "&",
1218     # indicating this is perl code.
1219     #
1220     if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1221         return $template;
1222     }
1223     if ( ref($template) ne "ARRAY" ) {
1224         #
1225         # Split at white space, except if escaped by \
1226         #
1227         $template = [split(/(?<!\\)\s+/, $template)];
1228         #
1229         # Remove the \ that escaped white space.
1230         #
1231         foreach ( @$template ) {
1232             s{\\(\s)}{$1}g;
1233         }
1234     }
1235     #
1236     # Merge variables into @cmd
1237     #
1238     foreach my $arg ( @$template ) {
1239         #
1240         # Replace $VAR with ${VAR} so that both types of variable
1241         # substitution are supported
1242         #
1243         $arg =~ s[\$(\w+)]{\${$1}}g;
1244         #
1245         # Replace scalar variables first
1246         #
1247         $arg =~ s[\${(\w+)}(\+?)]{
1248             exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1249                 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1250                 : "\${$1}$2"
1251         }eg;
1252         #
1253         # Now replicate any array arguments; this just works for just one
1254         # array var in each argument.
1255         #
1256         if ( $arg =~ m[(.*)\${(\w+)}(\+?)(.*)] && ref($vars->{$2}) eq "ARRAY" ) {
1257             my $pre  = $1;
1258             my $var  = $2;
1259             my $esc  = $3;
1260             my $post = $4;
1261             foreach my $v ( @{$vars->{$var}} ) {
1262                 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1263                 push(@cmd, "$pre$v$post");
1264             }
1265         } else {
1266             push(@cmd, $arg);
1267         }
1268     }
1269     return \@cmd;
1270 }
1271
1272 #
1273 # Exec or eval a command.  $cmd is either a string on an array ref.
1274 #
1275 # @args are optional arguments for the eval() case; they are not used
1276 # for exec().
1277 #
1278 sub cmdExecOrEval
1279 {
1280     my($bpc, $cmd, @args) = @_;
1281     
1282     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1283         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1284         print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1285                         if ( $bpc->{verbose} );
1286         eval($cmd);
1287         print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1288         exit(1);
1289     } else {
1290         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1291         print(STDERR "cmdExecOrEval: about to exec ",
1292               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1293                         if ( $bpc->{verbose} );
1294         alarm(0);
1295         $cmd = [map { m/(.*)/ } @$cmd];         # untaint
1296         #
1297         # force list-form of exec(), ie: no shell even for 1 arg
1298         #
1299         exec { $cmd->[0] } @$cmd;
1300         print(STDERR "Exec failed for @$cmd\n");
1301         exit(1);
1302     }
1303 }
1304
1305 #
1306 # System or eval a command.  $cmd is either a string on an array ref.
1307 # $stdoutCB is a callback for output generated by the command.  If it
1308 # is undef then output is returned.  If it is a code ref then the function
1309 # is called with each piece of output as an argument.  If it is a scalar
1310 # ref the output is appended to this variable.
1311 #
1312 # @args are optional arguments for the eval() case; they are not used
1313 # for system().
1314 #
1315 # Also, $? should be set when the CHILD pipe is closed.
1316 #
1317 sub cmdSystemOrEvalLong
1318 {
1319     my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_;
1320     my($pid, $out, $allOut);
1321     local(*CHILD);
1322     
1323     $? = 0;
1324     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1325         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1326         print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1327                         if ( $bpc->{verbose} );
1328         $out = eval($cmd);
1329         $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1330         &$stdoutCB($out)   if ( ref($stdoutCB) eq 'CODE' );
1331         print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1332                         if ( $bpc->{verbose} );
1333         return $out        if ( !defined($stdoutCB) );
1334         return;
1335     } else {
1336         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1337         print(STDERR "cmdSystemOrEval: about to system ",
1338               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1339                         if ( $bpc->{verbose} );
1340         if ( !defined($pid = open(CHILD, "-|")) ) {
1341             my $err = "Can't fork to run @$cmd\n";
1342             $? = 1;
1343             $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1344             &$stdoutCB($err)   if ( ref($stdoutCB) eq 'CODE' );
1345             return $err        if ( !defined($stdoutCB) );
1346             return;
1347         }
1348         binmode(CHILD);
1349         if ( !$pid ) {
1350             #
1351             # This is the child
1352             #
1353             close(STDERR);
1354             if ( $ignoreStderr ) {
1355                 open(STDERR, ">", "/dev/null");
1356             } else {
1357                 open(STDERR, ">&STDOUT");
1358             }
1359             alarm(0);
1360             $cmd = [map { m/(.*)/ } @$cmd];             # untaint
1361             #
1362             # force list-form of exec(), ie: no shell even for 1 arg
1363             #
1364             exec { $cmd->[0] } @$cmd;
1365             print(STDERR "Exec of @$cmd failed\n");
1366             exit(1);
1367         }
1368
1369         #
1370         # Notify caller of child's pid
1371         #
1372         &$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" );
1373
1374         #
1375         # The parent gathers the output from the child
1376         #
1377         while ( <CHILD> ) {
1378             $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1379             &$stdoutCB($_)   if ( ref($stdoutCB) eq 'CODE' );
1380             $out .= $_       if ( !defined($stdoutCB) );
1381             $allOut .= $_    if ( $bpc->{verbose} );
1382         }
1383         $? = 0;
1384         close(CHILD);
1385     }
1386     print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1387                         if ( $bpc->{verbose} );
1388     return $out;
1389 }
1390
1391 #
1392 # The shorter version that sets $ignoreStderr = 0, ie: merges stdout
1393 # and stderr together.
1394 #
1395 sub cmdSystemOrEval
1396 {
1397     my($bpc, $cmd, $stdoutCB, @args) = @_;
1398
1399     return $bpc->cmdSystemOrEvalLong($cmd, $stdoutCB, 0, undef, @args);
1400 }
1401
1402 #
1403 # Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}
1404 # to hashes and $conf->{$shareName} to an array.
1405 #
1406 sub backupFileConfFix
1407 {
1408     my($bpc, $conf, $shareName) = @_;
1409
1410     $conf->{$shareName} = [ $conf->{$shareName} ]
1411                     if ( ref($conf->{$shareName}) ne "ARRAY" );
1412     foreach my $param qw(BackupFilesOnly BackupFilesExclude) {
1413         next if ( !defined($conf->{$param}) );
1414         if ( ref($conf->{$param}) eq "HASH" ) {
1415             #
1416             # A "*" entry means wildcard - it is the default for
1417             # all shares.  Replicate the "*" entry for all shares,
1418             # but still allow override of specific entries.
1419             #
1420             next if ( !defined($conf->{$param}{"*"}) );
1421             $conf->{$param} = {
1422                                     map({ $_ => $conf->{$param}{"*"} }
1423                                             @{$conf->{$shareName}}),
1424                                     %{$conf->{$param}}
1425                               };
1426         } else {
1427             $conf->{$param} = [ $conf->{$param} ]
1428                                     if ( ref($conf->{$param}) ne "ARRAY" );
1429             $conf->{$param} = { map { $_ => $conf->{$param} }
1430                                     @{$conf->{$shareName}} };
1431         }
1432     }
1433 }
1434
1435 #
1436 # This is sort() compare function, used below.
1437 #
1438 # New client LOG names are LOG.MMYYYY.  Old style names are
1439 # LOG, LOG.0, LOG.1 etc.  Sort them so new names are
1440 # first, and newest to oldest.
1441 #
1442 sub compareLOGName
1443 {
1444     my $na = $1 if ( $a =~ /LOG\.(\d+)(\.z)?$/ );
1445     my $nb = $1 if ( $b =~ /LOG\.(\d+)(\.z)?$/ );
1446
1447     $na = -1 if ( !defined($na) );
1448     $nb = -1 if ( !defined($nb) );
1449
1450     if ( length($na) >= 5 && length($nb) >= 5 ) {
1451         #
1452         # Both new style: format is MMYYYY.  Bigger dates are
1453         # more recent.
1454         #
1455         my $ma = $2 * 12 + $1 if ( $na =~ /(\d+)(\d{4})/ );
1456         my $mb = $2 * 12 + $1 if ( $nb =~ /(\d+)(\d{4})/ );
1457         return $mb - $ma;
1458     } elsif ( length($na) >= 5 && length($nb) < 5 ) {
1459         return -1;
1460     } elsif ( length($na) < 5 && length($nb) >= 5 ) {
1461         return 1;
1462     } else {
1463         #
1464         # Both old style.  Smaller numbers are more recent.
1465         #
1466         return $na - $nb;
1467     }
1468 }
1469
1470 #
1471 # Returns list of paths to a clients's (or main) LOG files,
1472 # most recent first.
1473 #
1474 sub sortedPCLogFiles
1475 {
1476     my($bpc, $host) = @_;
1477
1478     my(@files, $dir);
1479
1480     if ( $host ne "" ) {
1481         $dir = "$bpc->{TopDir}/pc/$host";
1482     } else {
1483         $dir = "$bpc->{LogDir}";
1484     }
1485     if ( opendir(DIR, $dir) ) {
1486         foreach my $file ( readdir(DIR) ) {
1487             next if ( !-f "$dir/$file" );
1488             next if ( $file ne "LOG" && $file !~ /^LOG\.\d/ );
1489             push(@files, "$dir/$file");
1490         }
1491         closedir(DIR);
1492     }
1493     return sort compareLOGName @files;
1494 }
1495
1496 #
1497 # converts a glob-style pattern into a perl regular expression.
1498 #
1499 sub glob2re
1500 {
1501     my ( $bpc, $glob ) = @_;
1502     my ( $char, $subst );
1503
1504     # $escapeChars escapes characters with no special glob meaning but
1505     # have meaning in regexps.
1506     my $escapeChars = [ '.', '/', ];
1507
1508     # $charMap is where we implement the special meaning of glob
1509     # patterns and translate them to regexps.
1510     my $charMap = {
1511                     '?' => '[^/]',
1512                     '*' => '[^/]*', };
1513
1514     # multiple forward slashes are equivalent to one slash.  We should
1515     # never have to use this.
1516     $glob =~ s/\/+/\//;
1517
1518     foreach $char (@$escapeChars) {
1519         $glob =~ s/\Q$char\E/\\$char/g;
1520     }
1521
1522     while ( ( $char, $subst ) = each(%$charMap) ) {
1523         $glob =~ s/(?<!\\)\Q$char\E/$subst/g;
1524     }
1525
1526     return $glob;
1527 }
1528
1529 1;