68056420bf11d8dedc28846ebc8ea2a20ac305a5
[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-2003  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 2.1.0, released 20 Jun 2004.
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 qw/:flock/;
45 use Carp;
46 use DirHandle ();
47 use File::Path;
48 use File::Compare;
49 use Socket;
50 use Cwd;
51 use Digest::MD5;
52 use Config;
53
54 sub new
55 {
56     my $class = shift;
57     my($topDir, $installDir, $confDir, $noUserCheck) = @_;
58
59     #
60     # Whether to use filesystem hierarchy standard for file layout.
61     # If set, text config files are below /etc/BackupPC.
62     #
63     my $useFSH = 0;
64     my $paths;
65
66     #
67     # Pick some initial defaults.  For FHS the only critical
68     # path is the ConfDir, since we get everything else out
69     # of the main config file.
70     #
71     if ( $useFSH ) {
72         $paths = {
73             useFSH  => $useFSH,
74             TopDir  => $topDir || '/data/BackupPC',
75             BinDir  => $installDir ? "$installDir/bin" : '/usr/local/BackupPC/bin',
76             LibDir  => $installDir ? "$installDir/lib" : '/usr/local/BackupPC/lib',
77             ConfDir => $confDir || '/etc/BackupPC',
78             LogDir  => $topDir     ? "$topDir/log" : '/var/log/BackupPC',
79         };
80     } else {
81         $paths = {
82             useFSH  => $useFSH,
83             TopDir  => $topDir || '/data/BackupPC',
84             BinDir  => $installDir ? "$installDir/bin" : '/usr/local/BackupPC/bin',
85             LibDir  => $installDir ? "$installDir/lib" : '/usr/local/BackupPC/lib',
86             ConfDir => $topDir     ? "$topDir/conf" : '/data/BackupPC/conf',
87             LogDir  => $topDir     ? "$topDir/log" : '/data/BackupPC/log',
88         };
89     }
90
91     my $bpc = bless {
92         %$paths,
93         Version => '2.1.0',
94     }, $class;
95
96     $bpc->{storage} = BackupPC::Storage->new($paths);
97
98     #
99     # Clean up %ENV and setup other variables.
100     #
101     delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
102     $bpc->{PoolDir}  = "$bpc->{TopDir}/pool";
103     $bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
104     if ( defined(my $error = $bpc->ConfigRead()) ) {
105         print(STDERR $error, "\n");
106         return;
107     }
108
109     #
110     # Update the paths based on the config file
111     #
112     foreach my $dir ( qw(TopDir BinDir LibDir ConfDir LogDir) ) {
113         next if ( !defined($bpc->{Conf}{$dir}) );
114         $paths->{$dir} = $bpc->{$dir} = $bpc->{Conf}{$dir};
115     }
116     $bpc->{storage}->setPaths($paths);
117
118     #
119     # Verify we are running as the correct user
120     #
121     if ( !$noUserCheck
122             && $bpc->{Conf}{BackupPCUserVerify}
123             && $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) {
124         print(STDERR "Wrong user: my userid is $>, instead of $uid"
125             . " ($bpc->{Conf}{BackupPCUser})\n");
126         return;
127     }
128     return $bpc;
129 }
130
131 sub TopDir
132 {
133     my($bpc) = @_;
134     return $bpc->{TopDir};
135 }
136
137 sub BinDir
138 {
139     my($bpc) = @_;
140     return $bpc->{BinDir};
141 }
142
143 sub LogDir
144 {
145     my($bpc) = @_;
146     return $bpc->{LogDir};
147 }
148
149 sub ConfDir
150 {
151     my($bpc) = @_;
152     return $bpc->{ConfDir};
153 }
154
155 sub LibDir
156 {
157     my($bpc) = @_;
158     return $bpc->{LibDir};
159 }
160
161 sub useFHS
162 {
163     my($bpc) = @_;
164     return $bpc->{useFHS};
165 }
166
167 sub Version
168 {
169     my($bpc) = @_;
170     return $bpc->{Version};
171 }
172
173 sub Conf
174 {
175     my($bpc) = @_;
176     return %{$bpc->{Conf}};
177 }
178
179 sub Lang
180 {
181     my($bpc) = @_;
182     return $bpc->{Lang};
183 }
184
185 sub adminJob
186 {
187     my($bpc, $num) = @_;
188     return " admin " if ( !$num );
189     return " admin$num ";
190 }
191
192 sub isAdminJob
193 {
194     my($bpc, $str) = @_;
195     return $str =~ /^ admin/;
196 }
197
198 sub trashJob
199 {
200     return " trashClean ";
201 }
202
203 sub ConfValue
204 {
205     my($bpc, $param) = @_;
206
207     return $bpc->{Conf}{$param};
208 }
209
210 sub verbose
211 {
212     my($bpc, $param) = @_;
213
214     $bpc->{verbose} = $param if ( defined($param) );
215     return $bpc->{verbose};
216 }
217
218 sub sigName2num
219 {
220     my($bpc, $sig) = @_;
221
222     if ( !defined($bpc->{SigName2Num}) ) {
223         my $i = 0;
224         foreach my $name ( split(' ', $Config{sig_name}) ) {
225             $bpc->{SigName2Num}{$name} = $i;
226             $i++;
227         }
228     }
229     return $bpc->{SigName2Num}{$sig};
230 }
231
232 #
233 # Generate an ISO 8601 format timeStamp (but without the "T").
234 # See http://www.w3.org/TR/NOTE-datetime and
235 # http://www.cl.cam.ac.uk/~mgk25/iso-time.html
236 #
237 sub timeStamp
238 {
239     my($bpc, $t, $noPad) = @_;
240     my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
241               = localtime($t || time);
242     return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
243                     $year + 1900, $mon + 1, $mday, $hour, $min, $sec)
244              . ($noPad ? "" : " ");
245 }
246
247 sub BackupInfoRead
248 {
249     my($bpc, $host) = @_;
250
251     return $bpc->{storage}->BackupInfoRead($host);
252 }
253
254 sub BackupInfoWrite
255 {
256     my($bpc, $host, @Backups) = @_;
257
258     return $bpc->{storage}->BackupInfoWrite($host, @Backups);
259 }
260
261 sub RestoreInfoRead
262 {
263     my($bpc, $host) = @_;
264
265     return $bpc->{storage}->RestoreInfoRead($host);
266 }
267
268 sub RestoreInfoWrite
269 {
270     my($bpc, $host, @Restores) = @_;
271
272     return $bpc->{storage}->RestoreInfoWrite($host, @Restores);
273 }
274
275 sub ArchiveInfoRead
276 {
277     my($bpc, $host) = @_;
278
279     return $bpc->{storage}->ArchiveInfoRead($host);
280 }
281
282 sub ArchiveInfoWrite
283 {
284     my($bpc, $host, @Archives) = @_;
285
286     return $bpc->{storage}->ArchiveInfoWrite($host, @Archives);
287 }
288
289 sub ConfigDataRead
290 {
291     my($bpc, $host) = @_;
292
293     return $bpc->{storage}->ConfigDataRead($host);
294 }
295
296 sub ConfigDataWrite
297 {
298     my($bpc, $host, $conf) = @_;
299
300     return $bpc->{storage}->ConfigDataWrite($host, $conf);
301 }
302
303 sub ConfigRead
304 {
305     my($bpc, $host) = @_;
306     my($ret);
307
308     #
309     # Read main config file
310     #
311     my($mesg, $config) = $bpc->{storage}->ConfigDataRead();
312     return $mesg if ( defined($mesg) );
313
314     $bpc->{Conf} = $config;
315
316     #
317     # Read host config file
318     #
319     if ( $host ne "" ) {
320         ($mesg, $config) = $bpc->{storage}->ConfigDataRead($host);
321         return $mesg if ( defined($mesg) );
322         $bpc->{Conf} = { %{$bpc->{Conf}}, %$config };
323     }
324
325     #
326     # Load optional perl modules
327     #
328     if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
329         #
330         # Load any user-specified perl modules.  This is for
331         # optional user-defined extensions.
332         #
333         $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
334                     if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
335         foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
336             eval("use $module;");
337         }
338     }
339
340     #
341     # Load language file
342     #
343     return "No language setting" if ( !defined($bpc->{Conf}{Language}) );
344     my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
345     if ( !defined($ret = do $langFile) && ($! || $@) ) {
346         $mesg = "Couldn't open language file $langFile: $!" if ( $! );
347         $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
348         $mesg =~ s/[\n\r]+//;
349         return $mesg;
350     }
351     $bpc->{Lang} = \%Lang;
352     return;
353 }
354
355 #
356 # Return the mtime of the config file
357 #
358 sub ConfigMTime
359 {
360     my($bpc) = @_;
361
362     return $bpc->{storage}->ConfigMTime();
363 }
364
365 #
366 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
367 # With no argument a ref to a hash of hosts is returned.  Each
368 # hash contains fields as specified in the hosts file.  With an
369 # argument a ref to a single hash is returned with information
370 # for just that host.
371 #
372 sub HostInfoRead
373 {
374     my($bpc, $host) = @_;
375
376     return $bpc->{storage}->HostInfoRead($host);
377 }
378
379 sub HostInfoWrite
380 {
381     my($bpc, $host) = @_;
382
383     return $bpc->{storage}->HostInfoWrite($host);
384 }
385
386 #
387 # Return the mtime of the hosts file
388 #
389 sub HostsMTime
390 {
391     my($bpc) = @_;
392
393     return $bpc->{storage}->HostsMTime();
394 }
395
396 #
397 # Stripped down from File::Path.  In particular we don't print
398 # many warnings and we try three times to delete each directory
399 # and file -- for some reason the original File::Path rmtree
400 # didn't always completely remove a directory tree on the NetApp.
401 #
402 # Warning: this routine changes the cwd.
403 #
404 sub RmTreeQuiet
405 {
406     my($bpc, $pwd, $roots) = @_;
407     my(@files, $root);
408
409     if ( defined($roots) && length($roots) ) {
410       $roots = [$roots] unless ref $roots;
411     } else {
412       print(STDERR "RmTreeQuiet: No root path(s) specified\n");
413     }
414     chdir($pwd);
415     foreach $root (@{$roots}) {
416         $root = $1 if ( $root =~ m{(.*?)/*$} );
417         #
418         # Try first to simply unlink the file: this avoids an
419         # extra stat for every file.  If it fails (which it
420         # will for directories), check if it is a directory and
421         # then recurse.
422         #
423         if ( !unlink($root) ) {
424             if ( -d $root ) {
425                 my $d = DirHandle->new($root);
426                 if ( !defined($d) ) {
427                     print(STDERR "Can't read $pwd/$root: $!\n");
428                 } else {
429                     @files = $d->read;
430                     $d->close;
431                     @files = grep $_!~/^\.{1,2}$/, @files;
432                     $bpc->RmTreeQuiet("$pwd/$root", \@files);
433                     chdir($pwd);
434                     rmdir($root) || rmdir($root);
435                 }
436             } else {
437                 unlink($root) || unlink($root);
438             }
439         }
440     }
441 }
442
443 #
444 # Move a directory or file away for later deletion
445 #
446 sub RmTreeDefer
447 {
448     my($bpc, $trashDir, $file) = @_;
449     my($i, $f);
450
451     return if ( !-e $file );
452     mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
453     for ( $i = 0 ; $i < 1000 ; $i++ ) {
454         $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
455         next if ( -e $f );
456         return if ( rename($file, $f) );
457     }
458     # shouldn't get here, but might if you tried to call this
459     # across file systems.... just remove the tree right now.
460     if ( $file =~ /(.*)\/([^\/]*)/ ) {
461         my($d) = $1;
462         my($f) = $2;
463         my($cwd) = Cwd::fastcwd();
464         $cwd = $1 if ( $cwd =~ /(.*)/ );
465         $bpc->RmTreeQuiet($d, $f);
466         chdir($cwd) if ( $cwd );
467     }
468 }
469
470 #
471 # Empty the trash directory.  Returns 0 if it did nothing, 1 if it
472 # did something, -1 if it failed to remove all the files.
473 #
474 sub RmTreeTrashEmpty
475 {
476     my($bpc, $trashDir) = @_;
477     my(@files);
478     my($cwd) = Cwd::fastcwd();
479
480     $cwd = $1 if ( $cwd =~ /(.*)/ );
481     return if ( !-d $trashDir );
482     my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
483     @files = $d->read;
484     $d->close;
485     @files = grep $_!~/^\.{1,2}$/, @files;
486     return 0 if ( !@files );
487     $bpc->RmTreeQuiet($trashDir, \@files);
488     foreach my $f ( @files ) {
489         return -1 if ( -e $f );
490     }
491     chdir($cwd) if ( $cwd );
492     return 1;
493 }
494
495 #
496 # Open a connection to the server.  Returns an error string on failure.
497 # Returns undef on success.
498 #
499 sub ServerConnect
500 {
501     my($bpc, $host, $port, $justConnect) = @_;
502     local(*FH);
503
504     return if ( defined($bpc->{ServerFD}) );
505     #
506     # First try the unix-domain socket
507     #
508     my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
509     socket(*FH, PF_UNIX, SOCK_STREAM, 0)     || return "unix socket: $!";
510     if ( !connect(*FH, sockaddr_un($sockFile)) ) {
511         my $err = "unix connect: $!";
512         close(*FH);
513         if ( $port > 0 ) {
514             my $proto = getprotobyname('tcp');
515             my $iaddr = inet_aton($host)     || return "unknown host $host";
516             my $paddr = sockaddr_in($port, $iaddr);
517
518             socket(*FH, PF_INET, SOCK_STREAM, $proto)
519                                              || return "inet socket: $!";
520             connect(*FH, $paddr)             || return "inet connect: $!";
521         } else {
522             return $err;
523         }
524     }
525     my($oldFH) = select(*FH); $| = 1; select($oldFH);
526     $bpc->{ServerFD} = *FH;
527     return if ( $justConnect );
528     #
529     # Read the seed that we need for our MD5 message digest.  See
530     # ServerMesg below.
531     #
532     sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
533     $bpc->{ServerMesgCnt} = 0;
534     return;
535 }
536
537 #
538 # Check that the server connection is still ok
539 #
540 sub ServerOK
541 {
542     my($bpc) = @_;
543
544     return 0 if ( !defined($bpc->{ServerFD}) );
545     vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
546     my $ein = $FDread;
547     return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
548     return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
549 }
550
551 #
552 # Disconnect from the server
553 #
554 sub ServerDisconnect
555 {
556     my($bpc) = @_;
557     return if ( !defined($bpc->{ServerFD}) );
558     close($bpc->{ServerFD});
559     delete($bpc->{ServerFD});
560 }
561
562 #
563 # Sends a message to the server and returns with the reply.
564 #
565 # To avoid possible attacks via the TCP socket interface, every client
566 # message is protected by an MD5 digest. The MD5 digest includes four
567 # items:
568 #   - a seed that is sent to us when we first connect
569 #   - a sequence number that increments for each message
570 #   - a shared secret that is stored in $Conf{ServerMesgSecret}
571 #   - the message itself.
572 # The message is sent in plain text preceded by the MD5 digest. A
573 # snooper can see the plain-text seed sent by BackupPC and plain-text
574 # message, but cannot construct a valid MD5 digest since the secret in
575 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
576 # since the seed changes on a per-connection and per-message basis.
577 #
578 sub ServerMesg
579 {
580     my($bpc, $mesg) = @_;
581     return if ( !defined(my $fh = $bpc->{ServerFD}) );
582     my $md5 = Digest::MD5->new;
583     $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
584             . $bpc->{Conf}{ServerMesgSecret} . $mesg);
585     print($fh $md5->b64digest . " $mesg\n");
586     $bpc->{ServerMesgCnt}++;
587     return <$fh>;
588 }
589
590 #
591 # Do initialization for child processes
592 #
593 sub ChildInit
594 {
595     my($bpc) = @_;
596     close(STDERR);
597     open(STDERR, ">&STDOUT");
598     select(STDERR); $| = 1;
599     select(STDOUT); $| = 1;
600     $ENV{PATH} = $bpc->{Conf}{MyPath};
601 }
602
603 #
604 # Compute the MD5 digest of a file.  For efficiency we don't
605 # use the whole file for big files:
606 #   - for files <= 256K we use the file size and the whole file.
607 #   - for files <= 1M we use the file size, the first 128K and
608 #     the last 128K.
609 #   - for files > 1M, we use the file size, the first 128K and
610 #     the 8th 128K (ie: the 128K up to 1MB).
611 # See the documentation for a discussion of the tradeoffs in
612 # how much data we use and how many collisions we get.
613 #
614 # Returns the MD5 digest (a hex string) and the file size.
615 #
616 sub File2MD5
617 {
618     my($bpc, $md5, $name) = @_;
619     my($data, $fileSize);
620     local(*N);
621
622     $fileSize = (stat($name))[7];
623     return ("", -1) if ( !-f _ );
624     $name = $1 if ( $name =~ /(.*)/ );
625     return ("", 0) if ( $fileSize == 0 );
626     return ("", -1) if ( !open(N, $name) );
627     binmode(N);
628     $md5->reset();
629     $md5->add($fileSize);
630     if ( $fileSize > 262144 ) {
631         #
632         # read the first and last 131072 bytes of the file,
633         # up to 1MB.
634         #
635         my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
636         $md5->add($data) if ( sysread(N, $data, 131072) );
637         $md5->add($data) if ( sysseek(N, $seekPosn, 0)
638                                 && sysread(N, $data, 131072) );
639     } else {
640         #
641         # read the whole file
642         #
643         $md5->add($data) if ( sysread(N, $data, $fileSize) );
644     }
645     close(N);
646     return ($md5->hexdigest, $fileSize);
647 }
648
649 #
650 # Compute the MD5 digest of a buffer (string).  For efficiency we don't
651 # use the whole string for big strings:
652 #   - for files <= 256K we use the file size and the whole file.
653 #   - for files <= 1M we use the file size, the first 128K and
654 #     the last 128K.
655 #   - for files > 1M, we use the file size, the first 128K and
656 #     the 8th 128K (ie: the 128K up to 1MB).
657 # See the documentation for a discussion of the tradeoffs in
658 # how much data we use and how many collisions we get.
659 #
660 # Returns the MD5 digest (a hex string).
661 #
662 sub Buffer2MD5
663 {
664     my($bpc, $md5, $fileSize, $dataRef) = @_;
665
666     $md5->reset();
667     $md5->add($fileSize);
668     if ( $fileSize > 262144 ) {
669         #
670         # add the first and last 131072 bytes of the string,
671         # up to 1MB.
672         #
673         my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
674         $md5->add(substr($$dataRef, 0, 131072));
675         $md5->add(substr($$dataRef, $seekPosn, 131072));
676     } else {
677         #
678         # add the whole string
679         #
680         $md5->add($$dataRef);
681     }
682     return $md5->hexdigest;
683 }
684
685 #
686 # Given an MD5 digest $d and a compress flag, return the full
687 # path in the pool.
688 #
689 sub MD52Path
690 {
691     my($bpc, $d, $compress, $poolDir) = @_;
692
693     return if ( $d !~ m{(.)(.)(.)(.*)} );
694     $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
695                     if ( !defined($poolDir) );
696     return "$poolDir/$1/$2/$3/$1$2$3$4";
697 }
698
699 #
700 # For each file, check if the file exists in $bpc->{TopDir}/pool.
701 # If so, remove the file and make a hardlink to the file in
702 # the pool.  Otherwise, if the newFile flag is set, make a
703 # hardlink in the pool to the new file.
704 #
705 # Returns 0 if a link should be made to a new file (ie: when the file
706 #    is a new file but the newFile flag is 0).
707 # Returns 1 if a link to an existing file is made,
708 # Returns 2 if a link to a new file is made (only if $newFile is set)
709 # Returns negative on error.
710 #
711 sub MakeFileLink
712 {
713     my($bpc, $name, $d, $newFile, $compress) = @_;
714     my($i, $rawFile);
715
716     return -1 if ( !-f $name );
717     for ( $i = -1 ; ; $i++ ) {
718         return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
719         $rawFile .= "_$i" if ( $i >= 0 );
720         if ( -f $rawFile ) {
721             if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
722                     && !compare($name, $rawFile) ) {
723                 unlink($name);
724                 return -3 if ( !link($rawFile, $name) );
725                 return 1;
726             }
727         } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
728             my($newDir);
729             ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
730             mkpath($newDir, 0, 0777) if ( !-d $newDir );
731             return -4 if ( !link($name, $rawFile) );
732             return 2;
733         } else {
734             return 0;
735         }
736     }
737 }
738
739 sub CheckHostAlive
740 {
741     my($bpc, $host) = @_;
742     my($s, $pingCmd, $ret);
743
744     #
745     # Return success if the ping cmd is undefined or empty.
746     #
747     if ( $bpc->{Conf}{PingCmd} eq "" ) {
748         print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
749                    . " is empty\n") if ( $bpc->{verbose} );
750         return 0;
751     }
752
753     my $args = {
754         pingPath => $bpc->{Conf}{PingPath},
755         host     => $host,
756     };
757     $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
758
759     #
760     # Do a first ping in case the PC needs to wakeup
761     #
762     $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
763     if ( $? ) {
764         print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
765                         if ( $bpc->{verbose} );
766         return -1;
767     }
768
769     #
770     # Do a second ping and get the round-trip time in msec
771     #
772     $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
773     if ( $? ) {
774         print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
775                         if ( $bpc->{verbose} );
776         return -1;
777     }
778     if ( $s =~ /rtt\s*min\/avg\/max\/mdev\s*=\s*[\d.]+\/([\d.]+)\/[\d.]+\/[\d.]+\s*(ms|usec)/i ) {
779         $ret = $1;
780         $ret /= 1000 if ( lc($2) eq "usec" );
781     } elsif ( $s =~ /time=([\d.]+)\s*(ms|usec)/i ) {
782         $ret = $1;
783         $ret /= 1000 if ( lc($2) eq "usec" );
784     } else {
785         print(STDERR "CheckHostAlive: can't extract round-trip time"
786                    . " (not fatal)\n") if ( $bpc->{verbose} );
787         $ret = 0;
788     }
789     print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
790     return $ret;
791 }
792
793 sub CheckFileSystemUsage
794 {
795     my($bpc) = @_;
796     my($topDir) = $bpc->{TopDir};
797     my($s, $dfCmd);
798
799     return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
800     my $args = {
801         dfPath   => $bpc->{Conf}{DfPath},
802         topDir   => $bpc->{TopDir},
803     };
804     $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
805     $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
806     return 0 if ( $? || $s !~ /(\d+)%/s );
807     return $1;
808 }
809
810 #
811 # Given an IP address, return the host name and user name via
812 # NetBios.
813 #
814 sub NetBiosInfoGet
815 {
816     my($bpc, $host) = @_;
817     my($netBiosHostName, $netBiosUserName);
818     my($s, $nmbCmd);
819
820     #
821     # Skip NetBios check if NmbLookupCmd is emtpy
822     #
823     if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
824         print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
825                    . " is empty\n") if ( $bpc->{verbose} );
826         return ($host, undef);
827     }
828
829     my $args = {
830         nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
831         host          => $host,
832     };
833     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
834     foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
835         next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
836         $netBiosHostName ||= $1 if ( $2 eq "00" );  # host is first 00
837         $netBiosUserName   = $1 if ( $2 eq "03" );  # user is last 03
838     }
839     if ( !defined($netBiosHostName) ) {
840         print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
841                         if ( $bpc->{verbose} );
842         return;
843     }
844     $netBiosHostName = lc($netBiosHostName);
845     $netBiosUserName = lc($netBiosUserName);
846     print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
847                . " user $netBiosUserName\n") if ( $bpc->{verbose} );
848     return ($netBiosHostName, $netBiosUserName);
849 }
850
851 #
852 # Given a NetBios name lookup the IP address via NetBios.
853 # In the case of a host returning multiple interfaces we
854 # return the first IP address that matches the subnet mask.
855 # If none match the subnet mask (or nmblookup doesn't print
856 # the subnet mask) then just the first IP address is returned.
857 #
858 sub NetBiosHostIPFind
859 {
860     my($bpc, $host) = @_;
861     my($netBiosHostName, $netBiosUserName);
862     my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
863
864     #
865     # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
866     #
867     if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
868         print(STDERR "NetBiosHostIPFind: return $host because"
869             . " \$Conf{NmbLookupFindHostCmd} is empty\n")
870                 if ( $bpc->{verbose} );
871         return $host;
872     }
873
874     my $args = {
875         nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
876         host          => $host,
877     };
878     $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
879     foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
880                                                               $args) ) ) {
881         if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
882             $subnet = $1;
883             $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
884         } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
885             my $ip = $1;
886             $firstIpAddr = $ip if ( !defined($firstIpAddr) );
887             $ipAddr      = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
888         }
889     }
890     $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
891     if ( defined($ipAddr) ) {
892         print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
893                    . " host $host\n") if ( $bpc->{verbose} );
894         return $ipAddr;
895     } else {
896         print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
897                    . " host $host\n") if ( $bpc->{verbose} );
898         return;
899     }
900 }
901
902 sub fileNameEltMangle
903 {
904     my($bpc, $name) = @_;
905
906     return "" if ( $name eq "" );
907     $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
908     return "f$name";
909 }
910
911 #
912 # We store files with every name preceded by "f".  This
913 # avoids possible name conflicts with other information
914 # we store in the same directories (eg: attribute info).
915 # The process of turning a normal path into one with each
916 # node prefixed with "f" is called mangling.
917 #
918 sub fileNameMangle
919 {
920     my($bpc, $name) = @_;
921
922     $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
923     $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
924     return $name;
925 }
926
927 #
928 # This undoes FileNameMangle
929 #
930 sub fileNameUnmangle
931 {
932     my($bpc, $name) = @_;
933
934     $name =~ s{/f}{/}g;
935     $name =~ s{^f}{};
936     $name =~ s{%(..)}{chr(hex($1))}eg;
937     return $name;
938 }
939
940 #
941 # Escape shell meta-characters with backslashes.
942 # This should be applied to each argument seperately, not an
943 # entire shell command.
944 #
945 sub shellEscape
946 {
947     my($bpc, $cmd) = @_;
948
949     $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
950     return $cmd;
951 }
952
953 #
954 # For printing exec commands (which don't use a shell) so they look like
955 # a valid shell command this function should be called with the exec
956 # args.  The shell command string is returned.
957 #
958 sub execCmd2ShellCmd
959 {
960     my($bpc, @args) = @_;
961     my $str;
962
963     foreach my $a ( @args ) {
964         $str .= " " if ( $str ne "" );
965         $str .= $bpc->shellEscape($a);
966     }
967     return $str;
968 }
969
970 #
971 # Do a URI-style escape to protect/encode special characters
972 #
973 sub uriEsc
974 {
975     my($bpc, $s) = @_;
976     $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
977     return $s;
978 }
979
980 #
981 # Do a URI-style unescape to restore special characters
982 #
983 sub uriUnesc
984 {
985     my($bpc, $s) = @_;
986     $s =~ s{%(..)}{chr(hex($1))}eg;
987     return $s;
988 }
989
990 #
991 # Do variable substitution prior to execution of a command.
992 #
993 sub cmdVarSubstitute
994 {
995     my($bpc, $template, $vars) = @_;
996     my(@cmd);
997
998     #
999     # Return without any substitution if the first entry starts with "&",
1000     # indicating this is perl code.
1001     #
1002     if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1003         return $template;
1004     }
1005     if ( ref($template) ne "ARRAY" ) {
1006         #
1007         # Split at white space, except if escaped by \
1008         #
1009         $template = [split(/(?<!\\)\s+/, $template)];
1010         #
1011         # Remove the \ that escaped white space.
1012         #
1013         foreach ( @$template ) {
1014             s{\\(\s)}{$1}g;
1015         }
1016     }
1017     #
1018     # Merge variables into @tarClientCmd
1019     #
1020     foreach my $arg ( @$template ) {
1021         #
1022         # Replace scalar variables first
1023         #
1024         $arg =~ s{\$(\w+)(\+?)}{
1025             exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1026                 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1027                 : "\$$1$2"
1028         }eg;
1029         #
1030         # Now replicate any array arguments; this just works for just one
1031         # array var in each argument.
1032         #
1033         if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1034             my $pre  = $1;
1035             my $var  = $2;
1036             my $esc  = $3;
1037             my $post = $4;
1038             foreach my $v ( @{$vars->{$var}} ) {
1039                 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1040                 push(@cmd, "$pre$v$post");
1041             }
1042         } else {
1043             push(@cmd, $arg);
1044         }
1045     }
1046     return \@cmd;
1047 }
1048
1049 #
1050 # Exec or eval a command.  $cmd is either a string on an array ref.
1051 #
1052 # @args are optional arguments for the eval() case; they are not used
1053 # for exec().
1054 #
1055 sub cmdExecOrEval
1056 {
1057     my($bpc, $cmd, @args) = @_;
1058     
1059     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1060         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1061         print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1062                         if ( $bpc->{verbose} );
1063         eval($cmd);
1064         print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1065         exit(1);
1066     } else {
1067         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1068         print(STDERR "cmdExecOrEval: about to exec ",
1069               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1070                         if ( $bpc->{verbose} );
1071         alarm(0);
1072         $cmd = [map { m/(.*)/ } @$cmd];         # untaint
1073         #
1074         # force list-form of exec(), ie: no shell even for 1 arg
1075         #
1076         exec { $cmd->[0] } @$cmd;
1077         print(STDERR "Exec failed for @$cmd\n");
1078         exit(1);
1079     }
1080 }
1081
1082 #
1083 # System or eval a command.  $cmd is either a string on an array ref.
1084 # $stdoutCB is a callback for output generated by the command.  If it
1085 # is undef then output is returned.  If it is a code ref then the function
1086 # is called with each piece of output as an argument.  If it is a scalar
1087 # ref the output is appended to this variable.
1088 #
1089 # @args are optional arguments for the eval() case; they are not used
1090 # for system().
1091 #
1092 # Also, $? should be set when the CHILD pipe is closed.
1093 #
1094 sub cmdSystemOrEvalLong
1095 {
1096     my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_;
1097     my($pid, $out, $allOut);
1098     local(*CHILD);
1099     
1100     if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1101         $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1102         print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1103                         if ( $bpc->{verbose} );
1104         $out = eval($cmd);
1105         $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1106         &$stdoutCB($out)   if ( ref($stdoutCB) eq 'CODE' );
1107         print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1108                         if ( $bpc->{verbose} );
1109         return $out        if ( !defined($stdoutCB) );
1110         return;
1111     } else {
1112         $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1113         print(STDERR "cmdSystemOrEval: about to system ",
1114               $bpc->execCmd2ShellCmd(@$cmd), "\n")
1115                         if ( $bpc->{verbose} );
1116         if ( !defined($pid = open(CHILD, "-|")) ) {
1117             my $err = "Can't fork to run @$cmd\n";
1118             $? = 1;
1119             $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1120             &$stdoutCB($err)   if ( ref($stdoutCB) eq 'CODE' );
1121             return $err        if ( !defined($stdoutCB) );
1122             return;
1123         }
1124         binmode(CHILD);
1125         if ( !$pid ) {
1126             #
1127             # This is the child
1128             #
1129             close(STDERR);
1130             if ( $ignoreStderr ) {
1131                 open(STDERR, ">", "/dev/null");
1132             } else {
1133                 open(STDERR, ">&STDOUT");
1134             }
1135             alarm(0);
1136             $cmd = [map { m/(.*)/ } @$cmd];             # untaint
1137             #
1138             # force list-form of exec(), ie: no shell even for 1 arg
1139             #
1140             exec { $cmd->[0] } @$cmd;
1141             print(STDERR "Exec of @$cmd failed\n");
1142             exit(1);
1143         }
1144
1145         #
1146         # Notify caller of child's pid
1147         #
1148         &$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" );
1149
1150         #
1151         # The parent gathers the output from the child
1152         #
1153         while ( <CHILD> ) {
1154             $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1155             &$stdoutCB($_)   if ( ref($stdoutCB) eq 'CODE' );
1156             $out .= $_       if ( !defined($stdoutCB) );
1157             $allOut .= $_    if ( $bpc->{verbose} );
1158         }
1159         $? = 0;
1160         close(CHILD);
1161     }
1162     print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1163                         if ( $bpc->{verbose} );
1164     return $out;
1165 }
1166
1167 #
1168 # The shorter version that sets $ignoreStderr = 0, ie: merges stdout
1169 # and stderr together.
1170 #
1171 sub cmdSystemOrEval
1172 {
1173     my($bpc, $cmd, $stdoutCB, @args) = @_;
1174
1175     return $bpc->cmdSystemOrEvalLong($cmd, $stdoutCB, 0, undef, @args);
1176 }
1177
1178 #
1179 # Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}
1180 # to hashes and $conf->{$shareName} to an array.
1181 #
1182 sub backupFileConfFix
1183 {
1184     my($bpc, $conf, $shareName) = @_;
1185
1186     $conf->{$shareName} = [ $conf->{$shareName} ]
1187                     if ( ref($conf->{$shareName}) ne "ARRAY" );
1188     foreach my $param qw(BackupFilesOnly BackupFilesExclude) {
1189         next if ( !defined($conf->{$param}) );
1190         if ( ref($conf->{$param}) eq "HASH" ) {
1191             #
1192             # A "*" entry means wildcard - it is the default for
1193             # all shares.  Replicate the "*" entry for all shares,
1194             # but still allow override of specific entries.
1195             #
1196             next if ( !defined($conf->{$param}{"*"}) );
1197             $conf->{$param} = {
1198                                     map({ $_ => $conf->{$param}{"*"} }
1199                                             @{$conf->{$shareName}}),
1200                                     %{$conf->{$param}}
1201                               };
1202         } else {
1203             $conf->{$param} = [ $conf->{$param} ]
1204                                     if ( ref($conf->{$param}) ne "ARRAY" );
1205             $conf->{$param} = { map { $_ => $conf->{$param} }
1206                                     @{$conf->{$shareName}} };
1207         }
1208     }
1209 }
1210
1211 1;