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, $noUserCheck) = @_;
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
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") ) {
190 while ( <BK_INFO> ) {
192 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
194 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
204 my($bpc, $host, @Backups) = @_;
205 local(*BK_INFO, *LOCK);
208 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
209 unlink("$bpc->{TopDir}/pc/$host/backups.old")
210 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
211 rename("$bpc->{TopDir}/pc/$host/backups",
212 "$bpc->{TopDir}/pc/$host/backups.old")
213 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
214 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
215 for ( $i = 0 ; $i < @Backups ; $i++ ) {
216 my %b = %{$Backups[$i]};
217 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
226 my($bpc, $host) = @_;
227 local(*RESTORE_INFO, *LOCK);
230 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
231 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
232 while ( <RESTORE_INFO> ) {
234 next if ( !/^(\d+.*)/ );
236 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
246 my($bpc, $host, @Restores) = @_;
247 local(*RESTORE_INFO, *LOCK);
250 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
251 unlink("$bpc->{TopDir}/pc/$host/restores.old")
252 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
253 rename("$bpc->{TopDir}/pc/$host/restores",
254 "$bpc->{TopDir}/pc/$host/restores.old")
255 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
256 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
257 for ( $i = 0 ; $i < @Restores ; $i++ ) {
258 my %b = %{$Restores[$i]};
259 printf(RESTORE_INFO "%s\n",
260 join("\t", @b{@{$bpc->{RestoreFields}}}));
269 my($bpc, $host) = @_;
270 my($ret, $mesg, $config, @configs);
273 push(@configs, "$bpc->{TopDir}/conf/config.pl");
274 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
275 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
276 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
277 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
278 foreach $config ( @configs ) {
280 if ( !defined($ret = do $config) && ($! || $@) ) {
281 $mesg = "Couldn't open $config: $!" if ( $! );
282 $mesg = "Couldn't execute $config: $@" if ( $@ );
283 $mesg =~ s/[\n\r]+//;
286 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
288 return if ( !defined($bpc->{Conf}{Language}) );
289 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
291 # Load any user-specified perl modules. This is for
292 # optional user-defined extensions.
294 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
295 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
296 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
297 eval("use $module;");
300 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
301 if ( !defined($ret = do $langFile) && ($! || $@) ) {
302 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
303 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
304 $mesg =~ s/[\n\r]+//;
307 $bpc->{Lang} = \%Lang;
312 # Return the mtime of the config file
317 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
321 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
322 # With no argument a ref to a hash of hosts is returned. Each
323 # hash contains fields as specified in the hosts file. With an
324 # argument a ref to a single hash is returned with information
325 # for just that host.
329 my($bpc, $host) = @_;
330 my(%hosts, @hdr, @fld);
333 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
334 print(STDERR $bpc->timeStamp,
335 "Can't open $bpc->{TopDir}/conf/hosts\n");
338 while ( <HOST_INFO> ) {
342 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
344 # Split on white space, except if preceded by \
345 # using zero-width negative look-behind assertion
346 # (always wanted to use one of those).
348 @fld = split(/(?<!\\)\s+/, $1);
356 if ( defined($host) ) {
357 next if ( lc($fld[0]) ne $host );
358 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
362 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
373 # Return the mtime of the hosts file
378 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
382 # Stripped down from File::Path. In particular we don't print
383 # many warnings and we try three times to delete each directory
384 # and file -- for some reason the original File::Path rmtree
385 # didn't always completely remove a directory tree on the NetApp.
387 # Warning: this routine changes the cwd.
391 my($bpc, $pwd, $roots) = @_;
394 if ( defined($roots) && length($roots) ) {
395 $roots = [$roots] unless ref $roots;
397 print "RmTreeQuiet: No root path(s) specified\n";
400 foreach $root (@{$roots}) {
401 $root = $1 if ( $root =~ m{(.*?)/*$} );
403 # Try first to simply unlink the file: this avoids an
404 # extra stat for every file. If it fails (which it
405 # will for directories), check if it is a directory and
408 if ( !unlink($root) ) {
410 my $d = DirHandle->new($root)
411 or print "Can't read $pwd/$root: $!";
414 @files = grep $_!~/^\.{1,2}$/, @files;
415 $bpc->RmTreeQuiet("$pwd/$root", \@files);
417 rmdir($root) || rmdir($root);
419 unlink($root) || unlink($root);
426 # Move a directory or file away for later deletion
430 my($bpc, $trashDir, $file) = @_;
433 return if ( !-e $file );
434 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
435 for ( $i = 0 ; $i < 1000 ; $i++ ) {
436 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
438 return if ( rename($file, $f) );
440 # shouldn't get here, but might if you tried to call this
441 # across file systems.... just remove the tree right now.
442 if ( $file =~ /(.*)\/([^\/]*)/ ) {
445 my($cwd) = Cwd::fastcwd();
446 $cwd = $1 if ( $cwd =~ /(.*)/ );
447 $bpc->RmTreeQuiet($d, $f);
448 chdir($cwd) if ( $cwd );
453 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
454 # did something, -1 if it failed to remove all the files.
458 my($bpc, $trashDir) = @_;
460 my($cwd) = Cwd::fastcwd();
462 $cwd = $1 if ( $cwd =~ /(.*)/ );
463 return if ( !-d $trashDir );
464 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
467 @files = grep $_!~/^\.{1,2}$/, @files;
468 return 0 if ( !@files );
469 $bpc->RmTreeQuiet($trashDir, \@files);
470 foreach my $f ( @files ) {
471 return -1 if ( -e $f );
473 chdir($cwd) if ( $cwd );
478 # Open a connection to the server. Returns an error string on failure.
479 # Returns undef on success.
483 my($bpc, $host, $port, $justConnect) = @_;
486 return if ( defined($bpc->{ServerFD}) );
488 # First try the unix-domain socket
490 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
491 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
492 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
493 my $err = "unix connect: $!";
496 my $proto = getprotobyname('tcp');
497 my $iaddr = inet_aton($host) || return "unknown host $host";
498 my $paddr = sockaddr_in($port, $iaddr);
500 socket(*FH, PF_INET, SOCK_STREAM, $proto)
501 || return "inet socket: $!";
502 connect(*FH, $paddr) || return "inet connect: $!";
507 my($oldFH) = select(*FH); $| = 1; select($oldFH);
508 $bpc->{ServerFD} = *FH;
509 return if ( $justConnect );
511 # Read the seed that we need for our MD5 message digest. See
514 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
515 $bpc->{ServerMesgCnt} = 0;
520 # Check that the server connection is still ok
526 return 0 if ( !defined($bpc->{ServerFD}) );
527 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
529 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
530 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
534 # Disconnect from the server
539 return if ( !defined($bpc->{ServerFD}) );
540 close($bpc->{ServerFD});
541 delete($bpc->{ServerFD});
545 # Sends a message to the server and returns with the reply.
547 # To avoid possible attacks via the TCP socket interface, every client
548 # message is protected by an MD5 digest. The MD5 digest includes four
550 # - a seed that is sent to us when we first connect
551 # - a sequence number that increments for each message
552 # - a shared secret that is stored in $Conf{ServerMesgSecret}
553 # - the message itself.
554 # The message is sent in plain text preceded by the MD5 digest. A
555 # snooper can see the plain-text seed sent by BackupPC and plain-text
556 # message, but cannot construct a valid MD5 digest since the secret in
557 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
558 # since the seed changes on a per-connection and per-message basis.
562 my($bpc, $mesg) = @_;
563 return if ( !defined(my $fh = $bpc->{ServerFD}) );
564 my $md5 = Digest::MD5->new;
565 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
566 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
567 print($fh $md5->b64digest . " $mesg\n");
568 $bpc->{ServerMesgCnt}++;
573 # Do initialization for child processes
579 open(STDERR, ">&STDOUT");
580 select(STDERR); $| = 1;
581 select(STDOUT); $| = 1;
582 $ENV{PATH} = $bpc->{Conf}{MyPath};
586 # Compute the MD5 digest of a file. For efficiency we don't
587 # use the whole file for big files:
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
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.
596 # Returns the MD5 digest (a hex string) and the file size.
600 my($bpc, $md5, $name) = @_;
601 my($data, $fileSize);
604 $fileSize = (stat($name))[7];
605 return ("", -1) if ( !-f _ );
606 $name = $1 if ( $name =~ /(.*)/ );
607 return ("", 0) if ( $fileSize == 0 );
608 return ("", -1) if ( !open(N, $name) );
610 $md5->add($fileSize);
611 if ( $fileSize > 262144 ) {
613 # read the first and last 131072 bytes of the file,
616 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
617 $md5->add($data) if ( sysread(N, $data, 131072) );
618 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
619 && sysread(N, $data, 131072) );
622 # read the whole file
624 $md5->add($data) if ( sysread(N, $data, $fileSize) );
627 return ($md5->hexdigest, $fileSize);
631 # Compute the MD5 digest of a buffer (string). For efficiency we don't
632 # use the whole string for big strings:
633 # - for files <= 256K we use the file size and the whole file.
634 # - for files <= 1M we use the file size, the first 128K and
636 # - for files > 1M, we use the file size, the first 128K and
637 # the 8th 128K (ie: the 128K up to 1MB).
638 # See the documentation for a discussion of the tradeoffs in
639 # how much data we use and how many collisions we get.
641 # Returns the MD5 digest (a hex string).
645 my($bpc, $md5, $fileSize, $dataRef) = @_;
648 $md5->add($fileSize);
649 if ( $fileSize > 262144 ) {
651 # add the first and last 131072 bytes of the string,
654 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
655 $md5->add(substr($$dataRef, 0, 131072));
656 $md5->add(substr($$dataRef, $seekPosn, 131072));
659 # add the whole string
661 $md5->add($$dataRef);
663 return $md5->hexdigest;
667 # Given an MD5 digest $d and a compress flag, return the full
672 my($bpc, $d, $compress, $poolDir) = @_;
674 return if ( $d !~ m{(.)(.)(.)(.*)} );
675 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
676 if ( !defined($poolDir) );
677 return "$poolDir/$1/$2/$3/$1$2$3$4";
681 # For each file, check if the file exists in $bpc->{TopDir}/pool.
682 # If so, remove the file and make a hardlink to the file in
683 # the pool. Otherwise, if the newFile flag is set, make a
684 # hardlink in the pool to the new file.
686 # Returns 0 if a link should be made to a new file (ie: when the file
687 # is a new file but the newFile flag is 0).
688 # Returns 1 if a link to an existing file is made,
689 # Returns 2 if a link to a new file is made (only if $newFile is set)
690 # Returns negative on error.
694 my($bpc, $name, $d, $newFile, $compress) = @_;
697 return -1 if ( !-f $name );
698 for ( $i = -1 ; ; $i++ ) {
699 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
700 $rawFile .= "_$i" if ( $i >= 0 );
702 if ( !compare($name, $rawFile) ) {
704 return -3 if ( !link($rawFile, $name) );
707 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
709 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
710 mkpath($newDir, 0, 0777) if ( !-d $newDir );
711 return -4 if ( !link($name, $rawFile) );
721 my($bpc, $host) = @_;
722 my($s, $pingCmd, $ret);
725 # Return success if the ping cmd is undefined or empty.
727 if ( $bpc->{Conf}{PingCmd} eq "" ) {
728 print("CheckHostAlive: return ok because \$Conf{PingCmd} is empty\n")
729 if ( $bpc->{verbose} );
734 pingPath => $bpc->{Conf}{PingPath},
737 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
740 # Do a first ping in case the PC needs to wakeup
742 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
744 print("CheckHostAlive: first ping failed ($?, $!)\n")
745 if ( $bpc->{verbose} );
750 # Do a second ping and get the round-trip time in msec
752 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
754 print("CheckHostAlive: second ping failed ($?, $!)\n")
755 if ( $bpc->{verbose} );
758 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
760 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
763 print("CheckHostAlive: can't extract round-trip time (not fatal)\n")
764 if ( $bpc->{verbose} );
767 print("CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
771 sub CheckFileSystemUsage
774 my($topDir) = $bpc->{TopDir};
777 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
779 dfPath => $bpc->{Conf}{DfPath},
780 topDir => $bpc->{TopDir},
782 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
783 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
784 return 0 if ( $? || $s !~ /(\d+)%/s );
789 # Given an IP address, return the host name and user name via
794 my($bpc, $host) = @_;
795 my($netBiosHostName, $netBiosUserName);
799 # Skip NetBios check if NmbLookupCmd is emtpy
801 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
802 print("NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
804 if ( $bpc->{verbose} );
805 return ($host, undef);
809 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
812 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
813 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
814 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
815 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
816 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
818 if ( !defined($netBiosHostName) ) {
819 print("NetBiosInfoGet: failed: can't parse return string\n")
820 if ( $bpc->{verbose} );
823 $netBiosHostName = lc($netBiosHostName);
824 $netBiosUserName = lc($netBiosUserName);
825 print("NetBiosInfoGet: success, returning host $netBiosHostName,"
826 . " user $netBiosUserName\n")
827 if ( $bpc->{verbose} );
828 return ($netBiosHostName, $netBiosUserName);
832 # Given a NetBios name lookup the IP address via NetBios.
833 # In the case of a host returning multiple interfaces we
834 # return the first IP address that matches the subnet mask.
835 # If none match the subnet mask (or nmblookup doesn't print
836 # the subnet mask) then just the first IP address is returned.
838 sub NetBiosHostIPFind
840 my($bpc, $host) = @_;
841 my($netBiosHostName, $netBiosUserName);
842 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
845 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
847 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
848 print("NetBiosHostIPFind: return $host because"
849 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
850 if ( $bpc->{verbose} );
855 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
858 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
859 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
861 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
863 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
864 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
866 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
867 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
870 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
871 if ( defined($ipAddr) ) {
872 print("NetBiosHostIPFind: found IP address $ipAddr for host $host\n")
873 if ( $bpc->{verbose} );
876 print("NetBiosHostIPFind: couldn't find IP address for host $host\n")
877 if ( $bpc->{verbose} );
882 sub fileNameEltMangle
884 my($bpc, $name) = @_;
886 return "" if ( $name eq "" );
887 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
892 # We store files with every name preceded by "f". This
893 # avoids possible name conflicts with other information
894 # we store in the same directories (eg: attribute info).
895 # The process of turning a normal path into one with each
896 # node prefixed with "f" is called mangling.
900 my($bpc, $name) = @_;
902 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
903 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
908 # This undoes FileNameMangle
912 my($bpc, $name) = @_;
916 $name =~ s{%(..)}{chr(hex($1))}eg;
921 # Escape shell meta-characters with backslashes.
922 # This should be applied to each argument seperately, not an
923 # entire shell command.
929 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
934 # For printing exec commands (which don't use a shell) so they look like
935 # a valid shell command this function should be called with the exec
936 # args. The shell command string is returned.
940 my($bpc, @args) = @_;
943 foreach my $a ( @args ) {
944 $str .= " " if ( $str ne "" );
945 $str .= $bpc->shellEscape($a);
951 # Do a URI-style escape to protect/encode special characters
956 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
961 # Do a URI-style unescape to restore special characters
966 $s =~ s{%(..)}{chr(hex($1))}eg;
971 # Do variable substitution prior to execution of a command.
975 my($bpc, $template, $vars) = @_;
979 # Return without any substitution if the first entry starts with "&",
980 # indicating this is perl code.
982 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
985 if ( ref($template) ne "ARRAY" ) {
987 # Split at white space, except if escaped by \
989 $template = [split(/(?<!\\)\s+/, $template)];
991 # Remove the \ that escaped white space.
993 foreach ( @$template ) {
998 # Merge variables into @tarClientCmd
1000 foreach my $arg ( @$template ) {
1002 # Replace scalar variables first
1004 $arg =~ s{\$(\w+)(\+?)}{
1005 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1006 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1010 # Now replicate any array arguments; this just works for just one
1011 # array var in each argument.
1013 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1018 foreach my $v ( @{$vars->{$var}} ) {
1019 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1020 push(@cmd, "$pre$v$post");
1030 # Exec or eval a command. $cmd is either a string on an array ref.
1032 # @args are optional arguments for the eval() case; they are not used
1037 my($bpc, $cmd, @args) = @_;
1039 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1040 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1041 print("cmdExecOrEval: about to eval perl code $cmd\n")
1042 if ( $bpc->{verbose} );
1044 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1047 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1048 print("cmdExecOrEval: about to exec ",
1049 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1050 if ( $bpc->{verbose} );
1052 print(STDERR "Exec failed for @$cmd\n");
1058 # System or eval a command. $cmd is either a string on an array ref.
1059 # $stdoutCB is a callback for output generated by the command. If it
1060 # is undef then output is returned. If it is a code ref then the function
1061 # is called with each piece of output as an argument. If it is a scalar
1062 # ref the output is appended to this variable.
1064 # @args are optional arguments for the eval() case; they are not used
1067 # Also, $? should be set when the CHILD pipe is closed.
1071 my($bpc, $cmd, $stdoutCB, @args) = @_;
1072 my($pid, $out, $allOut);
1075 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1076 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1077 print("cmdSystemOrEval: about to eval perl code $cmd\n")
1078 if ( $bpc->{verbose} );
1080 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1081 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1082 print("cmdSystemOrEval: finished: got output $out\n")
1083 if ( $bpc->{verbose} );
1084 return $out if ( !defined($stdoutCB) );
1087 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1088 print("cmdSystemOrEval: about to system ",
1089 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1090 if ( $bpc->{verbose} );
1091 if ( !defined($pid = open(CHILD, "-|")) ) {
1092 my $err = "Can't fork to run @$cmd\n";
1094 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1095 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1096 return $err if ( !defined($stdoutCB) );
1104 open(STDERR, ">&STDOUT");
1106 print("Exec of @$cmd failed\n");
1110 # The parent gathers the output from the child
1113 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1114 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1115 $out .= $_ if ( !defined($stdoutCB) );
1116 $allOut .= $_ if ( $bpc->{verbose} );
1121 print("cmdSystemOrEval: finished: got output $allOut\n")
1122 if ( $bpc->{verbose} );