1 #============================================================= -*-perl-*-
3 # BackupPC::Lib package
7 # This library defines a BackupPC::Lib class and a variety of utility
8 # functions used by BackupPC.
11 # Craig Barratt <cbarratt@users.sourceforge.net>
14 # Copyright (C) 2001-2003 Craig Barratt
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.
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.
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
30 #========================================================================
32 # Version 2.1.0_CVS, released 3 Jul 2003.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
55 my($topDir, $installDir, $noUserCheck) = @_;
58 TopDir => $topDir || '/data/BackupPC',
59 BinDir => $installDir || '/usr/local/BackupPC',
60 LibDir => $installDir || '/usr/local/BackupPC',
61 Version => '2.1.0_CVS',
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
70 num startTime endTime result errorMsg nFiles size
71 tarCreateErrs xferErrs
74 $bpc->{BinDir} .= "/bin";
75 $bpc->{LibDir} .= "/lib";
77 # Clean up %ENV and setup other variables.
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");
87 # Verify we are running as the correct user
90 && $bpc->{Conf}{BackupPCUserVerify}
91 && $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) {
92 print("Wrong user: my userid is $>, instead of $uid"
93 . " ($bpc->{Conf}{BackupPCUser})\n");
102 return $bpc->{TopDir};
108 return $bpc->{BinDir};
114 return $bpc->{Version};
120 return %{$bpc->{Conf}};
136 return " trashClean ";
141 my($bpc, $param) = @_;
143 return $bpc->{Conf}{$param};
148 my($bpc, $param) = @_;
150 $bpc->{verbose} = $param if ( defined($param) );
151 return $bpc->{verbose};
156 my($bpc, $t, $noPad) = @_;
157 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
158 = localtime($t || time);
161 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
162 . ($noPad ? "" : " ");
166 # An ISO 8601-compliant version of timeStamp. Needed by the
167 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
168 # Also see http://www.w3.org/TR/NOTE-datetime.
172 my($bpc, $t, $noPad) = @_;
173 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
174 = localtime($t || time);
177 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
178 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
179 . ($noPad ? "" : " ");
184 my($bpc, $host) = @_;
185 local(*BK_INFO, *LOCK);
188 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
189 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
191 while ( <BK_INFO> ) {
193 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
195 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
205 my($bpc, $host, @Backups) = @_;
206 local(*BK_INFO, *LOCK);
209 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
210 unlink("$bpc->{TopDir}/pc/$host/backups.old")
211 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
212 rename("$bpc->{TopDir}/pc/$host/backups",
213 "$bpc->{TopDir}/pc/$host/backups.old")
214 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
215 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
217 for ( $i = 0 ; $i < @Backups ; $i++ ) {
218 my %b = %{$Backups[$i]};
219 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
228 my($bpc, $host) = @_;
229 local(*RESTORE_INFO, *LOCK);
232 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
233 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
234 binmode(RESTORE_INFO);
235 while ( <RESTORE_INFO> ) {
237 next if ( !/^(\d+.*)/ );
239 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
249 my($bpc, $host, @Restores) = @_;
250 local(*RESTORE_INFO, *LOCK);
253 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
254 unlink("$bpc->{TopDir}/pc/$host/restores.old")
255 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
256 rename("$bpc->{TopDir}/pc/$host/restores",
257 "$bpc->{TopDir}/pc/$host/restores.old")
258 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
259 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
260 binmode(RESTORE_INFO);
261 for ( $i = 0 ; $i < @Restores ; $i++ ) {
262 my %b = %{$Restores[$i]};
263 printf(RESTORE_INFO "%s\n",
264 join("\t", @b{@{$bpc->{RestoreFields}}}));
273 my($bpc, $host) = @_;
274 my($ret, $mesg, $config, @configs);
277 push(@configs, "$bpc->{TopDir}/conf/config.pl");
278 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
279 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
280 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
281 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
282 foreach $config ( @configs ) {
284 if ( !defined($ret = do $config) && ($! || $@) ) {
285 $mesg = "Couldn't open $config: $!" if ( $! );
286 $mesg = "Couldn't execute $config: $@" if ( $@ );
287 $mesg =~ s/[\n\r]+//;
290 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
292 return if ( !defined($bpc->{Conf}{Language}) );
293 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
295 # Load any user-specified perl modules. This is for
296 # optional user-defined extensions.
298 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
299 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
300 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
301 eval("use $module;");
304 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
305 if ( !defined($ret = do $langFile) && ($! || $@) ) {
306 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
307 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
308 $mesg =~ s/[\n\r]+//;
311 $bpc->{Lang} = \%Lang;
316 # Return the mtime of the config file
321 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
325 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
326 # With no argument a ref to a hash of hosts is returned. Each
327 # hash contains fields as specified in the hosts file. With an
328 # argument a ref to a single hash is returned with information
329 # for just that host.
333 my($bpc, $host) = @_;
334 my(%hosts, @hdr, @fld);
337 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
338 print(STDERR $bpc->timeStamp,
339 "Can't open $bpc->{TopDir}/conf/hosts\n");
343 while ( <HOST_INFO> ) {
347 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
349 # Split on white space, except if preceded by \
350 # using zero-width negative look-behind assertion
351 # (always wanted to use one of those).
353 @fld = split(/(?<!\\)\s+/, $1);
361 if ( defined($host) ) {
362 next if ( lc($fld[0]) ne $host );
363 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
367 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
378 # Return the mtime of the hosts file
383 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
387 # Stripped down from File::Path. In particular we don't print
388 # many warnings and we try three times to delete each directory
389 # and file -- for some reason the original File::Path rmtree
390 # didn't always completely remove a directory tree on the NetApp.
392 # Warning: this routine changes the cwd.
396 my($bpc, $pwd, $roots) = @_;
399 if ( defined($roots) && length($roots) ) {
400 $roots = [$roots] unless ref $roots;
402 print "RmTreeQuiet: No root path(s) specified\n";
405 foreach $root (@{$roots}) {
406 $root = $1 if ( $root =~ m{(.*?)/*$} );
408 # Try first to simply unlink the file: this avoids an
409 # extra stat for every file. If it fails (which it
410 # will for directories), check if it is a directory and
413 if ( !unlink($root) ) {
415 my $d = DirHandle->new($root)
416 or print "Can't read $pwd/$root: $!";
419 @files = grep $_!~/^\.{1,2}$/, @files;
420 $bpc->RmTreeQuiet("$pwd/$root", \@files);
422 rmdir($root) || rmdir($root);
424 unlink($root) || unlink($root);
431 # Move a directory or file away for later deletion
435 my($bpc, $trashDir, $file) = @_;
438 return if ( !-e $file );
439 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
440 for ( $i = 0 ; $i < 1000 ; $i++ ) {
441 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
443 return if ( rename($file, $f) );
445 # shouldn't get here, but might if you tried to call this
446 # across file systems.... just remove the tree right now.
447 if ( $file =~ /(.*)\/([^\/]*)/ ) {
450 my($cwd) = Cwd::fastcwd();
451 $cwd = $1 if ( $cwd =~ /(.*)/ );
452 $bpc->RmTreeQuiet($d, $f);
453 chdir($cwd) if ( $cwd );
458 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
459 # did something, -1 if it failed to remove all the files.
463 my($bpc, $trashDir) = @_;
465 my($cwd) = Cwd::fastcwd();
467 $cwd = $1 if ( $cwd =~ /(.*)/ );
468 return if ( !-d $trashDir );
469 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
472 @files = grep $_!~/^\.{1,2}$/, @files;
473 return 0 if ( !@files );
474 $bpc->RmTreeQuiet($trashDir, \@files);
475 foreach my $f ( @files ) {
476 return -1 if ( -e $f );
478 chdir($cwd) if ( $cwd );
483 # Open a connection to the server. Returns an error string on failure.
484 # Returns undef on success.
488 my($bpc, $host, $port, $justConnect) = @_;
491 return if ( defined($bpc->{ServerFD}) );
493 # First try the unix-domain socket
495 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
496 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
497 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
498 my $err = "unix connect: $!";
501 my $proto = getprotobyname('tcp');
502 my $iaddr = inet_aton($host) || return "unknown host $host";
503 my $paddr = sockaddr_in($port, $iaddr);
505 socket(*FH, PF_INET, SOCK_STREAM, $proto)
506 || return "inet socket: $!";
507 connect(*FH, $paddr) || return "inet connect: $!";
512 my($oldFH) = select(*FH); $| = 1; select($oldFH);
513 $bpc->{ServerFD} = *FH;
514 return if ( $justConnect );
516 # Read the seed that we need for our MD5 message digest. See
519 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
520 $bpc->{ServerMesgCnt} = 0;
525 # Check that the server connection is still ok
531 return 0 if ( !defined($bpc->{ServerFD}) );
532 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
534 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
535 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
539 # Disconnect from the server
544 return if ( !defined($bpc->{ServerFD}) );
545 close($bpc->{ServerFD});
546 delete($bpc->{ServerFD});
550 # Sends a message to the server and returns with the reply.
552 # To avoid possible attacks via the TCP socket interface, every client
553 # message is protected by an MD5 digest. The MD5 digest includes four
555 # - a seed that is sent to us when we first connect
556 # - a sequence number that increments for each message
557 # - a shared secret that is stored in $Conf{ServerMesgSecret}
558 # - the message itself.
559 # The message is sent in plain text preceded by the MD5 digest. A
560 # snooper can see the plain-text seed sent by BackupPC and plain-text
561 # message, but cannot construct a valid MD5 digest since the secret in
562 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
563 # since the seed changes on a per-connection and per-message basis.
567 my($bpc, $mesg) = @_;
568 return if ( !defined(my $fh = $bpc->{ServerFD}) );
569 my $md5 = Digest::MD5->new;
570 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
571 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
572 print($fh $md5->b64digest . " $mesg\n");
573 $bpc->{ServerMesgCnt}++;
578 # Do initialization for child processes
584 open(STDERR, ">&STDOUT");
585 select(STDERR); $| = 1;
586 select(STDOUT); $| = 1;
587 $ENV{PATH} = $bpc->{Conf}{MyPath};
591 # Compute the MD5 digest of a file. For efficiency we don't
592 # use the whole file for big files:
593 # - for files <= 256K we use the file size and the whole file.
594 # - for files <= 1M we use the file size, the first 128K and
596 # - for files > 1M, we use the file size, the first 128K and
597 # the 8th 128K (ie: the 128K up to 1MB).
598 # See the documentation for a discussion of the tradeoffs in
599 # how much data we use and how many collisions we get.
601 # Returns the MD5 digest (a hex string) and the file size.
605 my($bpc, $md5, $name) = @_;
606 my($data, $fileSize);
609 $fileSize = (stat($name))[7];
610 return ("", -1) if ( !-f _ );
611 $name = $1 if ( $name =~ /(.*)/ );
612 return ("", 0) if ( $fileSize == 0 );
613 return ("", -1) if ( !open(N, $name) );
616 $md5->add($fileSize);
617 if ( $fileSize > 262144 ) {
619 # read the first and last 131072 bytes of the file,
622 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
623 $md5->add($data) if ( sysread(N, $data, 131072) );
624 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
625 && sysread(N, $data, 131072) );
628 # read the whole file
630 $md5->add($data) if ( sysread(N, $data, $fileSize) );
633 return ($md5->hexdigest, $fileSize);
637 # Compute the MD5 digest of a buffer (string). For efficiency we don't
638 # use the whole string for big strings:
639 # - for files <= 256K we use the file size and the whole file.
640 # - for files <= 1M we use the file size, the first 128K and
642 # - for files > 1M, we use the file size, the first 128K and
643 # the 8th 128K (ie: the 128K up to 1MB).
644 # See the documentation for a discussion of the tradeoffs in
645 # how much data we use and how many collisions we get.
647 # Returns the MD5 digest (a hex string).
651 my($bpc, $md5, $fileSize, $dataRef) = @_;
654 $md5->add($fileSize);
655 if ( $fileSize > 262144 ) {
657 # add the first and last 131072 bytes of the string,
660 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
661 $md5->add(substr($$dataRef, 0, 131072));
662 $md5->add(substr($$dataRef, $seekPosn, 131072));
665 # add the whole string
667 $md5->add($$dataRef);
669 return $md5->hexdigest;
673 # Given an MD5 digest $d and a compress flag, return the full
678 my($bpc, $d, $compress, $poolDir) = @_;
680 return if ( $d !~ m{(.)(.)(.)(.*)} );
681 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
682 if ( !defined($poolDir) );
683 return "$poolDir/$1/$2/$3/$1$2$3$4";
687 # For each file, check if the file exists in $bpc->{TopDir}/pool.
688 # If so, remove the file and make a hardlink to the file in
689 # the pool. Otherwise, if the newFile flag is set, make a
690 # hardlink in the pool to the new file.
692 # Returns 0 if a link should be made to a new file (ie: when the file
693 # is a new file but the newFile flag is 0).
694 # Returns 1 if a link to an existing file is made,
695 # Returns 2 if a link to a new file is made (only if $newFile is set)
696 # Returns negative on error.
700 my($bpc, $name, $d, $newFile, $compress) = @_;
703 return -1 if ( !-f $name );
704 for ( $i = -1 ; ; $i++ ) {
705 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
706 $rawFile .= "_$i" if ( $i >= 0 );
708 if ( !compare($name, $rawFile) ) {
710 return -3 if ( !link($rawFile, $name) );
713 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
715 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
716 mkpath($newDir, 0, 0777) if ( !-d $newDir );
717 return -4 if ( !link($name, $rawFile) );
727 my($bpc, $host) = @_;
728 my($s, $pingCmd, $ret);
731 # Return success if the ping cmd is undefined or empty.
733 if ( $bpc->{Conf}{PingCmd} eq "" ) {
734 print("CheckHostAlive: return ok because \$Conf{PingCmd} is empty\n")
735 if ( $bpc->{verbose} );
740 pingPath => $bpc->{Conf}{PingPath},
743 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
746 # Do a first ping in case the PC needs to wakeup
748 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
750 print("CheckHostAlive: first ping failed ($?, $!)\n")
751 if ( $bpc->{verbose} );
756 # Do a second ping and get the round-trip time in msec
758 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
760 print("CheckHostAlive: second ping failed ($?, $!)\n")
761 if ( $bpc->{verbose} );
764 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
766 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
769 print("CheckHostAlive: can't extract round-trip time (not fatal)\n")
770 if ( $bpc->{verbose} );
773 print("CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
777 sub CheckFileSystemUsage
780 my($topDir) = $bpc->{TopDir};
783 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
785 dfPath => $bpc->{Conf}{DfPath},
786 topDir => $bpc->{TopDir},
788 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
789 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
790 return 0 if ( $? || $s !~ /(\d+)%/s );
795 # Given an IP address, return the host name and user name via
800 my($bpc, $host) = @_;
801 my($netBiosHostName, $netBiosUserName);
805 # Skip NetBios check if NmbLookupCmd is emtpy
807 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
808 print("NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
810 if ( $bpc->{verbose} );
811 return ($host, undef);
815 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
818 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
819 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
820 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
821 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
822 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
824 if ( !defined($netBiosHostName) ) {
825 print("NetBiosInfoGet: failed: can't parse return string\n")
826 if ( $bpc->{verbose} );
829 $netBiosHostName = lc($netBiosHostName);
830 $netBiosUserName = lc($netBiosUserName);
831 print("NetBiosInfoGet: success, returning host $netBiosHostName,"
832 . " user $netBiosUserName\n")
833 if ( $bpc->{verbose} );
834 return ($netBiosHostName, $netBiosUserName);
838 # Given a NetBios name lookup the IP address via NetBios.
839 # In the case of a host returning multiple interfaces we
840 # return the first IP address that matches the subnet mask.
841 # If none match the subnet mask (or nmblookup doesn't print
842 # the subnet mask) then just the first IP address is returned.
844 sub NetBiosHostIPFind
846 my($bpc, $host) = @_;
847 my($netBiosHostName, $netBiosUserName);
848 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
851 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
853 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
854 print("NetBiosHostIPFind: return $host because"
855 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
856 if ( $bpc->{verbose} );
861 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
864 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
865 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
867 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
869 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
870 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
872 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
873 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
876 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
877 if ( defined($ipAddr) ) {
878 print("NetBiosHostIPFind: found IP address $ipAddr for host $host\n")
879 if ( $bpc->{verbose} );
882 print("NetBiosHostIPFind: couldn't find IP address for host $host\n")
883 if ( $bpc->{verbose} );
888 sub fileNameEltMangle
890 my($bpc, $name) = @_;
892 return "" if ( $name eq "" );
893 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
898 # We store files with every name preceded by "f". This
899 # avoids possible name conflicts with other information
900 # we store in the same directories (eg: attribute info).
901 # The process of turning a normal path into one with each
902 # node prefixed with "f" is called mangling.
906 my($bpc, $name) = @_;
908 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
909 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
914 # This undoes FileNameMangle
918 my($bpc, $name) = @_;
922 $name =~ s{%(..)}{chr(hex($1))}eg;
927 # Escape shell meta-characters with backslashes.
928 # This should be applied to each argument seperately, not an
929 # entire shell command.
935 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
940 # For printing exec commands (which don't use a shell) so they look like
941 # a valid shell command this function should be called with the exec
942 # args. The shell command string is returned.
946 my($bpc, @args) = @_;
949 foreach my $a ( @args ) {
950 $str .= " " if ( $str ne "" );
951 $str .= $bpc->shellEscape($a);
957 # Do a URI-style escape to protect/encode special characters
962 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
967 # Do a URI-style unescape to restore special characters
972 $s =~ s{%(..)}{chr(hex($1))}eg;
977 # Do variable substitution prior to execution of a command.
981 my($bpc, $template, $vars) = @_;
985 # Return without any substitution if the first entry starts with "&",
986 # indicating this is perl code.
988 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
991 if ( ref($template) ne "ARRAY" ) {
993 # Split at white space, except if escaped by \
995 $template = [split(/(?<!\\)\s+/, $template)];
997 # Remove the \ that escaped white space.
999 foreach ( @$template ) {
1004 # Merge variables into @tarClientCmd
1006 foreach my $arg ( @$template ) {
1008 # Replace scalar variables first
1010 $arg =~ s{\$(\w+)(\+?)}{
1011 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1012 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1016 # Now replicate any array arguments; this just works for just one
1017 # array var in each argument.
1019 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1024 foreach my $v ( @{$vars->{$var}} ) {
1025 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1026 push(@cmd, "$pre$v$post");
1036 # Exec or eval a command. $cmd is either a string on an array ref.
1038 # @args are optional arguments for the eval() case; they are not used
1043 my($bpc, $cmd, @args) = @_;
1045 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1046 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1047 print("cmdExecOrEval: about to eval perl code $cmd\n")
1048 if ( $bpc->{verbose} );
1050 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1053 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1054 print("cmdExecOrEval: about to exec ",
1055 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1056 if ( $bpc->{verbose} );
1057 exec(map { m/(.*)/ } @$cmd); # untaint
1058 print(STDERR "Exec failed for @$cmd\n");
1064 # System or eval a command. $cmd is either a string on an array ref.
1065 # $stdoutCB is a callback for output generated by the command. If it
1066 # is undef then output is returned. If it is a code ref then the function
1067 # is called with each piece of output as an argument. If it is a scalar
1068 # ref the output is appended to this variable.
1070 # @args are optional arguments for the eval() case; they are not used
1073 # Also, $? should be set when the CHILD pipe is closed.
1077 my($bpc, $cmd, $stdoutCB, @args) = @_;
1078 my($pid, $out, $allOut);
1081 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1082 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1083 print("cmdSystemOrEval: about to eval perl code $cmd\n")
1084 if ( $bpc->{verbose} );
1086 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1087 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1088 print("cmdSystemOrEval: finished: got output $out\n")
1089 if ( $bpc->{verbose} );
1090 return $out if ( !defined($stdoutCB) );
1093 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1094 print("cmdSystemOrEval: about to system ",
1095 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1096 if ( $bpc->{verbose} );
1097 if ( !defined($pid = open(CHILD, "-|")) ) {
1098 my $err = "Can't fork to run @$cmd\n";
1100 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1101 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1102 return $err if ( !defined($stdoutCB) );
1111 open(STDERR, ">&STDOUT");
1112 exec(map { m/(.*)/ } @$cmd); # untaint
1113 print("Exec of @$cmd failed\n");
1117 # The parent gathers the output from the child
1120 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1121 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1122 $out .= $_ if ( !defined($stdoutCB) );
1123 $allOut .= $_ if ( $bpc->{verbose} );
1128 print("cmdSystemOrEval: finished: got output $allOut\n")
1129 if ( $bpc->{verbose} );