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