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 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.0.0beta2, released 13 Apr 2003.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
55 my($topDir, $installDir) = @_;
58 TopDir => $topDir || '/data/BackupPC',
59 BinDir => $installDir || '/usr/local/BackupPC',
60 LibDir => $installDir || '/usr/local/BackupPC',
61 Version => '2.0.0beta2',
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
89 if ( $bpc->{Conf}{BackupPCUserVerify}
90 && $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) {
91 print("Wrong user: my userid is $>, instead of $uid"
92 . " ($bpc->{Conf}{BackupPCUser})\n");
101 return $bpc->{TopDir};
107 return $bpc->{BinDir};
113 return $bpc->{Version};
119 return %{$bpc->{Conf}};
135 return " trashClean ";
140 my($bpc, $param) = @_;
142 return $bpc->{Conf}{$param};
147 my($bpc, $param) = @_;
149 $bpc->{verbose} = $param if ( defined($param) );
150 return $bpc->{verbose};
155 my($bpc, $t, $noPad) = @_;
156 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
157 = localtime($t || time);
160 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
161 . ($noPad ? "" : " ");
165 # An ISO 8601-compliant version of timeStamp. Needed by the
166 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
167 # Also see http://www.w3.org/TR/NOTE-datetime.
171 my($bpc, $t, $noPad) = @_;
172 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
173 = localtime($t || time);
176 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
177 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
178 . ($noPad ? "" : " ");
183 my($bpc, $host) = @_;
184 local(*BK_INFO, *LOCK);
187 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
188 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
189 while ( <BK_INFO> ) {
191 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
193 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
203 my($bpc, $host, @Backups) = @_;
204 local(*BK_INFO, *LOCK);
207 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
208 unlink("$bpc->{TopDir}/pc/$host/backups.old")
209 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
210 rename("$bpc->{TopDir}/pc/$host/backups",
211 "$bpc->{TopDir}/pc/$host/backups.old")
212 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
213 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
214 for ( $i = 0 ; $i < @Backups ; $i++ ) {
215 my %b = %{$Backups[$i]};
216 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
225 my($bpc, $host) = @_;
226 local(*RESTORE_INFO, *LOCK);
229 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
230 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
231 while ( <RESTORE_INFO> ) {
233 next if ( !/^(\d+.*)/ );
235 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
245 my($bpc, $host, @Restores) = @_;
246 local(*RESTORE_INFO, *LOCK);
249 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
250 unlink("$bpc->{TopDir}/pc/$host/restores.old")
251 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
252 rename("$bpc->{TopDir}/pc/$host/restores",
253 "$bpc->{TopDir}/pc/$host/restores.old")
254 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
255 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
256 for ( $i = 0 ; $i < @Restores ; $i++ ) {
257 my %b = %{$Restores[$i]};
258 printf(RESTORE_INFO "%s\n",
259 join("\t", @b{@{$bpc->{RestoreFields}}}));
268 my($bpc, $host) = @_;
269 my($ret, $mesg, $config, @configs);
272 push(@configs, "$bpc->{TopDir}/conf/config.pl");
273 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
274 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
275 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
276 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
277 foreach $config ( @configs ) {
279 if ( !defined($ret = do $config) && ($! || $@) ) {
280 $mesg = "Couldn't open $config: $!" if ( $! );
281 $mesg = "Couldn't execute $config: $@" if ( $@ );
282 $mesg =~ s/[\n\r]+//;
285 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
287 return if ( !defined($bpc->{Conf}{Language}) );
288 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
290 # Load any user-specified perl modules. This is for
291 # optional user-defined extensions.
293 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
294 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
295 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
296 eval("use $module;");
299 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
300 if ( !defined($ret = do $langFile) && ($! || $@) ) {
301 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
302 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
303 $mesg =~ s/[\n\r]+//;
306 $bpc->{Lang} = \%Lang;
311 # Return the mtime of the config file
316 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
320 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
321 # With no argument a ref to a hash of hosts is returned. Each
322 # hash contains fields as specified in the hosts file. With an
323 # argument a ref to a single hash is returned with information
324 # for just that host.
328 my($bpc, $host) = @_;
329 my(%hosts, @hdr, @fld);
332 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
333 print(STDERR $bpc->timeStamp,
334 "Can't open $bpc->{TopDir}/conf/hosts\n");
337 while ( <HOST_INFO> ) {
341 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
343 # Split on white space, except if preceded by \
344 # using zero-width negative look-behind assertion
345 # (always wanted to use one of those).
347 @fld = split(/(?<!\\)\s+/, $1);
355 if ( defined($host) ) {
356 next if ( lc($fld[0]) ne $host );
357 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
361 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
372 # Return the mtime of the hosts file
377 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
381 # Stripped down from File::Path. In particular we don't print
382 # many warnings and we try three times to delete each directory
383 # and file -- for some reason the original File::Path rmtree
384 # didn't always completely remove a directory tree on the NetApp.
386 # Warning: this routine changes the cwd.
390 my($bpc, $pwd, $roots) = @_;
393 if ( defined($roots) && length($roots) ) {
394 $roots = [$roots] unless ref $roots;
396 print "RmTreeQuiet: No root path(s) specified\n";
399 foreach $root (@{$roots}) {
400 $root = $1 if ( $root =~ m{(.*?)/*$} );
402 # Try first to simply unlink the file: this avoids an
403 # extra stat for every file. If it fails (which it
404 # will for directories), check if it is a directory and
407 if ( !unlink($root) ) {
409 my $d = DirHandle->new($root)
410 or print "Can't read $pwd/$root: $!";
413 @files = grep $_!~/^\.{1,2}$/, @files;
414 $bpc->RmTreeQuiet("$pwd/$root", \@files);
416 rmdir($root) || rmdir($root);
418 unlink($root) || unlink($root);
425 # Move a directory or file away for later deletion
429 my($bpc, $trashDir, $file) = @_;
432 return if ( !-e $file );
433 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
434 for ( $i = 0 ; $i < 1000 ; $i++ ) {
435 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
437 return if ( rename($file, $f) );
439 # shouldn't get here, but might if you tried to call this
440 # across file systems.... just remove the tree right now.
441 if ( $file =~ /(.*)\/([^\/]*)/ ) {
444 my($cwd) = Cwd::fastcwd();
445 $cwd = $1 if ( $cwd =~ /(.*)/ );
446 $bpc->RmTreeQuiet($d, $f);
447 chdir($cwd) if ( $cwd );
452 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
453 # did something, -1 if it failed to remove all the files.
457 my($bpc, $trashDir) = @_;
459 my($cwd) = Cwd::fastcwd();
461 $cwd = $1 if ( $cwd =~ /(.*)/ );
462 return if ( !-d $trashDir );
463 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
466 @files = grep $_!~/^\.{1,2}$/, @files;
467 return 0 if ( !@files );
468 $bpc->RmTreeQuiet($trashDir, \@files);
469 foreach my $f ( @files ) {
470 return -1 if ( -e $f );
472 chdir($cwd) if ( $cwd );
477 # Open a connection to the server. Returns an error string on failure.
478 # Returns undef on success.
482 my($bpc, $host, $port, $justConnect) = @_;
485 return if ( defined($bpc->{ServerFD}) );
487 # First try the unix-domain socket
489 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
490 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
491 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
492 my $err = "unix connect: $!";
495 my $proto = getprotobyname('tcp');
496 my $iaddr = inet_aton($host) || return "unknown host $host";
497 my $paddr = sockaddr_in($port, $iaddr);
499 socket(*FH, PF_INET, SOCK_STREAM, $proto)
500 || return "inet socket: $!";
501 connect(*FH, $paddr) || return "inet connect: $!";
506 my($oldFH) = select(*FH); $| = 1; select($oldFH);
507 $bpc->{ServerFD} = *FH;
508 return if ( $justConnect );
510 # Read the seed that we need for our MD5 message digest. See
513 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
514 $bpc->{ServerMesgCnt} = 0;
519 # Check that the server connection is still ok
525 return 0 if ( !defined($bpc->{ServerFD}) );
526 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
528 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
529 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
533 # Disconnect from the server
538 return if ( !defined($bpc->{ServerFD}) );
539 close($bpc->{ServerFD});
540 delete($bpc->{ServerFD});
544 # Sends a message to the server and returns with the reply.
546 # To avoid possible attacks via the TCP socket interface, every client
547 # message is protected by an MD5 digest. The MD5 digest includes four
549 # - a seed that is sent to us when we first connect
550 # - a sequence number that increments for each message
551 # - a shared secret that is stored in $Conf{ServerMesgSecret}
552 # - the message itself.
553 # The message is sent in plain text preceded by the MD5 digest. A
554 # snooper can see the plain-text seed sent by BackupPC and plain-text
555 # message, but cannot construct a valid MD5 digest since the secret in
556 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
557 # since the seed changes on a per-connection and per-message basis.
561 my($bpc, $mesg) = @_;
562 return if ( !defined(my $fh = $bpc->{ServerFD}) );
563 my $md5 = Digest::MD5->new;
564 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
565 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
566 print($fh $md5->b64digest . " $mesg\n");
567 $bpc->{ServerMesgCnt}++;
572 # Do initialization for child processes
578 open(STDERR, ">&STDOUT");
579 select(STDERR); $| = 1;
580 select(STDOUT); $| = 1;
581 $ENV{PATH} = $bpc->{Conf}{MyPath};
585 # Compute the MD5 digest of a file. For efficiency we don't
586 # use the whole file for big files:
587 # - for files <= 256K we use the file size and the whole file.
588 # - for files <= 1M we use the file size, the first 128K and
590 # - for files > 1M, we use the file size, the first 128K and
591 # the 8th 128K (ie: the 128K up to 1MB).
592 # See the documentation for a discussion of the tradeoffs in
593 # how much data we use and how many collisions we get.
595 # Returns the MD5 digest (a hex string) and the file size.
599 my($bpc, $md5, $name) = @_;
600 my($data, $fileSize);
603 $fileSize = (stat($name))[7];
604 return ("", -1) if ( !-f _ );
605 $name = $1 if ( $name =~ /(.*)/ );
606 return ("", 0) if ( $fileSize == 0 );
607 return ("", -1) if ( !open(N, $name) );
609 $md5->add($fileSize);
610 if ( $fileSize > 262144 ) {
612 # read the first and last 131072 bytes of the file,
615 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
616 $md5->add($data) if ( sysread(N, $data, 131072) );
617 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
618 && sysread(N, $data, 131072) );
621 # read the whole file
623 $md5->add($data) if ( sysread(N, $data, $fileSize) );
626 return ($md5->hexdigest, $fileSize);
630 # Compute the MD5 digest of a buffer (string). For efficiency we don't
631 # use the whole string for big strings:
632 # - for files <= 256K we use the file size and the whole file.
633 # - for files <= 1M we use the file size, the first 128K and
635 # - for files > 1M, we use the file size, the first 128K and
636 # the 8th 128K (ie: the 128K up to 1MB).
637 # See the documentation for a discussion of the tradeoffs in
638 # how much data we use and how many collisions we get.
640 # Returns the MD5 digest (a hex string).
644 my($bpc, $md5, $fileSize, $dataRef) = @_;
647 $md5->add($fileSize);
648 if ( $fileSize > 262144 ) {
650 # add the first and last 131072 bytes of the string,
653 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
654 $md5->add(substr($$dataRef, 0, 131072));
655 $md5->add(substr($$dataRef, $seekPosn, 131072));
658 # add the whole string
660 $md5->add($$dataRef);
662 return $md5->hexdigest;
666 # Given an MD5 digest $d and a compress flag, return the full
671 my($bpc, $d, $compress, $poolDir) = @_;
673 return if ( $d !~ m{(.)(.)(.)(.*)} );
674 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
675 if ( !defined($poolDir) );
676 return "$poolDir/$1/$2/$3/$1$2$3$4";
680 # For each file, check if the file exists in $bpc->{TopDir}/pool.
681 # If so, remove the file and make a hardlink to the file in
682 # the pool. Otherwise, if the newFile flag is set, make a
683 # hardlink in the pool to the new file.
685 # Returns 0 if a link should be made to a new file (ie: when the file
686 # is a new file but the newFile flag is 0).
687 # Returns 1 if a link to an existing file is made,
688 # Returns 2 if a link to a new file is made (only if $newFile is set)
689 # Returns negative on error.
693 my($bpc, $name, $d, $newFile, $compress) = @_;
696 return -1 if ( !-f $name );
697 for ( $i = -1 ; ; $i++ ) {
698 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
699 $rawFile .= "_$i" if ( $i >= 0 );
701 if ( !compare($name, $rawFile) ) {
703 return -3 if ( !link($rawFile, $name) );
706 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
708 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
709 mkpath($newDir, 0, 0777) if ( !-d $newDir );
710 return -4 if ( !link($name, $rawFile) );
720 my($bpc, $host) = @_;
721 my($s, $pingCmd, $ret);
724 # Return success if the ping cmd is undefined or empty.
726 if ( $bpc->{Conf}{PingCmd} eq "" ) {
727 print("CheckHostAlive: return ok because \$Conf{PingCmd} is empty\n")
728 if ( $bpc->{verbose} );
733 pingPath => $bpc->{Conf}{PingPath},
736 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
739 # Do a first ping in case the PC needs to wakeup
741 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
743 print("CheckHostAlive: first ping failed ($?, $!)\n")
744 if ( $bpc->{verbose} );
749 # Do a second ping and get the round-trip time in msec
751 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
753 print("CheckHostAlive: second ping failed ($?, $!)\n")
754 if ( $bpc->{verbose} );
757 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
759 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
762 print("CheckHostAlive: can't extract round-trip time (not fatal)\n")
763 if ( $bpc->{verbose} );
766 print("CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
770 sub CheckFileSystemUsage
773 my($topDir) = $bpc->{TopDir};
776 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
778 dfPath => $bpc->{Conf}{DfPath},
779 topDir => $bpc->{TopDir},
781 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
782 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
783 return 0 if ( $? || $s !~ /(\d+)%/s );
788 # Given an IP address, return the host name and user name via
793 my($bpc, $host) = @_;
794 my($netBiosHostName, $netBiosUserName);
798 # Skip NetBios check if NmbLookupCmd is emtpy
800 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
801 print("NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
803 if ( $bpc->{verbose} );
804 return ($host, undef);
808 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
811 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
812 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
813 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
814 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
815 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
817 if ( !defined($netBiosHostName) ) {
818 print("NetBiosInfoGet: failed: can't parse return string\n")
819 if ( $bpc->{verbose} );
822 $netBiosHostName = lc($netBiosHostName);
823 $netBiosUserName = lc($netBiosUserName);
824 print("NetBiosInfoGet: success, returning host $netBiosHostName,"
825 . " user $netBiosUserName\n")
826 if ( $bpc->{verbose} );
827 return ($netBiosHostName, $netBiosUserName);
831 # Given a NetBios name lookup the IP address via NetBios.
832 # In the case of a host returning multiple interfaces we
833 # return the first IP address that matches the subnet mask.
834 # If none match the subnet mask (or nmblookup doesn't print
835 # the subnet mask) then just the first IP address is returned.
837 sub NetBiosHostIPFind
839 my($bpc, $host) = @_;
840 my($netBiosHostName, $netBiosUserName);
841 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
844 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
846 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
847 print("NetBiosHostIPFind: return $host because"
848 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
849 if ( $bpc->{verbose} );
854 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
857 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
858 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
860 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
862 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
863 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
865 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
866 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
869 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
870 if ( defined($ipAddr) ) {
871 print("NetBiosHostIPFind: found IP address $ipAddr for host $host\n")
872 if ( $bpc->{verbose} );
875 print("NetBiosHostIPFind: couldn't find IP address for host $host\n")
876 if ( $bpc->{verbose} );
881 sub fileNameEltMangle
883 my($bpc, $name) = @_;
885 return "" if ( $name eq "" );
886 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
891 # We store files with every name preceded by "f". This
892 # avoids possible name conflicts with other information
893 # we store in the same directories (eg: attribute info).
894 # The process of turning a normal path into one with each
895 # node prefixed with "f" is called mangling.
899 my($bpc, $name) = @_;
901 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
902 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
907 # This undoes FileNameMangle
911 my($bpc, $name) = @_;
915 $name =~ s{%(..)}{chr(hex($1))}eg;
920 # Escape shell meta-characters with backslashes.
921 # This should be applied to each argument seperately, not an
922 # entire shell command.
928 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
933 # For printing exec commands (which don't use a shell) so they look like
934 # a valid shell command this function should be called with the exec
935 # args. The shell command string is returned.
939 my($bpc, @args) = @_;
942 foreach my $a ( @args ) {
943 $str .= " " if ( $str ne "" );
944 $str .= $bpc->shellEscape($a);
950 # Do a URI-style escape to protect/encode special characters
955 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
960 # Do a URI-style unescape to restore special characters
965 $s =~ s{%(..)}{chr(hex($1))}eg;
970 # Do variable substitution prior to execution of a command.
974 my($bpc, $template, $vars) = @_;
978 # Return without any substitution if the first entry starts with "&",
979 # indicating this is perl code.
981 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
984 if ( ref($template) ne "ARRAY" ) {
986 # Split at white space, except if escaped by \
988 $template = [split(/(?<!\\)\s+/, $template)];
990 # Remove the \ that escaped white space.
992 foreach ( @$template ) {
997 # Merge variables into @tarClientCmd
999 foreach my $arg ( @$template ) {
1001 # Replace scalar variables first
1003 $arg =~ s{\$(\w+)(\+?)}{
1004 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1005 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1009 # Now replicate any array arguments; this just works for just one
1010 # array var in each argument.
1012 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1017 foreach my $v ( @{$vars->{$var}} ) {
1018 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1019 push(@cmd, "$pre$v$post");
1029 # Exec or eval a command. $cmd is either a string on an array ref.
1031 # @args are optional arguments for the eval() case; they are not used
1036 my($bpc, $cmd, @args) = @_;
1038 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1039 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1040 print("cmdExecOrEval: about to eval perl code $cmd\n")
1041 if ( $bpc->{verbose} );
1043 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1046 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1047 print("cmdExecOrEval: about to exec ",
1048 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1049 if ( $bpc->{verbose} );
1051 print(STDERR "Exec failed for @$cmd\n");
1057 # System or eval a command. $cmd is either a string on an array ref.
1058 # $stdoutCB is a callback for output generated by the command. If it
1059 # is undef then output is returned. If it is a code ref then the function
1060 # is called with each piece of output as an argument. If it is a scalar
1061 # ref the output is appended to this variable.
1063 # @args are optional arguments for the eval() case; they are not used
1066 # Also, $? should be set when the CHILD pipe is closed.
1070 my($bpc, $cmd, $stdoutCB, @args) = @_;
1071 my($pid, $out, $allOut);
1074 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1075 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1076 print("cmdSystemOrEval: about to eval perl code $cmd\n")
1077 if ( $bpc->{verbose} );
1079 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1080 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1081 print("cmdSystemOrEval: finished: got output $out\n")
1082 if ( $bpc->{verbose} );
1083 return $out if ( !defined($stdoutCB) );
1086 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1087 print("cmdSystemOrEval: about to system ",
1088 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1089 if ( $bpc->{verbose} );
1090 if ( !defined($pid = open(CHILD, "-|")) ) {
1091 my $err = "Can't fork to run @$cmd\n";
1093 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1094 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1095 return $err if ( !defined($stdoutCB) );
1103 open(STDERR, ">&STDOUT");
1105 print("Exec of @$cmd failed\n");
1109 # The parent gathers the output from the child
1112 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1113 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1114 $out .= $_ if ( !defined($stdoutCB) );
1115 $allOut .= $_ if ( $bpc->{verbose} );
1120 print("cmdSystemOrEval: finished: got output $allOut\n")
1121 if ( $bpc->{verbose} );