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