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.2, released 6 Oct 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/BackupPC2.0.2',
59 BinDir => $installDir || '/usr/local/BackupPC2.0.2',
60 LibDir => $installDir || '/usr/local/BackupPC2.0.2',
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 ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
709 && !compare($name, $rawFile) ) {
711 return -3 if ( !link($rawFile, $name) );
714 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
716 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
717 mkpath($newDir, 0, 0777) if ( !-d $newDir );
718 return -4 if ( !link($name, $rawFile) );
728 my($bpc, $host) = @_;
729 my($s, $pingCmd, $ret);
732 # Return success if the ping cmd is undefined or empty.
734 if ( $bpc->{Conf}{PingCmd} eq "" ) {
735 print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
736 . " is empty\n") if ( $bpc->{verbose} );
741 pingPath => $bpc->{Conf}{PingPath},
744 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
747 # Do a first ping in case the PC needs to wakeup
749 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
751 print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
752 if ( $bpc->{verbose} );
757 # Do a second ping and get the round-trip time in msec
759 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
761 print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
762 if ( $bpc->{verbose} );
765 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
767 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
770 print(STDERR "CheckHostAlive: can't extract round-trip time"
771 . " (not fatal)\n") if ( $bpc->{verbose} );
774 print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
778 sub CheckFileSystemUsage
781 my($topDir) = $bpc->{TopDir};
784 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
786 dfPath => $bpc->{Conf}{DfPath},
787 topDir => $bpc->{TopDir},
789 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
790 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
791 return 0 if ( $? || $s !~ /(\d+)%/s );
796 # Given an IP address, return the host name and user name via
801 my($bpc, $host) = @_;
802 my($netBiosHostName, $netBiosUserName);
806 # Skip NetBios check if NmbLookupCmd is emtpy
808 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
809 print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
810 . " is empty\n") 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(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
826 if ( $bpc->{verbose} );
829 $netBiosHostName = lc($netBiosHostName);
830 $netBiosUserName = lc($netBiosUserName);
831 print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
832 . " user $netBiosUserName\n") if ( $bpc->{verbose} );
833 return ($netBiosHostName, $netBiosUserName);
837 # Given a NetBios name lookup the IP address via NetBios.
838 # In the case of a host returning multiple interfaces we
839 # return the first IP address that matches the subnet mask.
840 # If none match the subnet mask (or nmblookup doesn't print
841 # the subnet mask) then just the first IP address is returned.
843 sub NetBiosHostIPFind
845 my($bpc, $host) = @_;
846 my($netBiosHostName, $netBiosUserName);
847 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
850 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
852 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
853 print(STDERR "NetBiosHostIPFind: return $host because"
854 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
855 if ( $bpc->{verbose} );
860 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
863 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
864 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
866 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
868 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
869 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
871 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
872 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
875 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
876 if ( defined($ipAddr) ) {
877 print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
878 . " host $host\n") if ( $bpc->{verbose} );
881 print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
882 . " host $host\n") if ( $bpc->{verbose} );
887 sub fileNameEltMangle
889 my($bpc, $name) = @_;
891 return "" if ( $name eq "" );
892 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
897 # We store files with every name preceded by "f". This
898 # avoids possible name conflicts with other information
899 # we store in the same directories (eg: attribute info).
900 # The process of turning a normal path into one with each
901 # node prefixed with "f" is called mangling.
905 my($bpc, $name) = @_;
907 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
908 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
913 # This undoes FileNameMangle
917 my($bpc, $name) = @_;
921 $name =~ s{%(..)}{chr(hex($1))}eg;
926 # Escape shell meta-characters with backslashes.
927 # This should be applied to each argument seperately, not an
928 # entire shell command.
934 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
939 # For printing exec commands (which don't use a shell) so they look like
940 # a valid shell command this function should be called with the exec
941 # args. The shell command string is returned.
945 my($bpc, @args) = @_;
948 foreach my $a ( @args ) {
949 $str .= " " if ( $str ne "" );
950 $str .= $bpc->shellEscape($a);
956 # Do a URI-style escape to protect/encode special characters
961 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
966 # Do a URI-style unescape to restore special characters
971 $s =~ s{%(..)}{chr(hex($1))}eg;
976 # Do variable substitution prior to execution of a command.
980 my($bpc, $template, $vars) = @_;
984 # Return without any substitution if the first entry starts with "&",
985 # indicating this is perl code.
987 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
990 if ( ref($template) ne "ARRAY" ) {
992 # Split at white space, except if escaped by \
994 $template = [split(/(?<!\\)\s+/, $template)];
996 # Remove the \ that escaped white space.
998 foreach ( @$template ) {
1003 # Merge variables into @tarClientCmd
1005 foreach my $arg ( @$template ) {
1007 # Replace scalar variables first
1009 $arg =~ s{\$(\w+)(\+?)}{
1010 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1011 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1015 # Now replicate any array arguments; this just works for just one
1016 # array var in each argument.
1018 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1023 foreach my $v ( @{$vars->{$var}} ) {
1024 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1025 push(@cmd, "$pre$v$post");
1035 # Exec or eval a command. $cmd is either a string on an array ref.
1037 # @args are optional arguments for the eval() case; they are not used
1042 my($bpc, $cmd, @args) = @_;
1044 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1045 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1046 print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1047 if ( $bpc->{verbose} );
1049 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1052 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1053 print(STDERR "cmdExecOrEval: about to exec ",
1054 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1055 if ( $bpc->{verbose} );
1056 exec(map { m/(.*)/ } @$cmd); # untaint
1057 print(STDERR "Exec failed for @$cmd\n");
1063 # System or eval a command. $cmd is either a string on an array ref.
1064 # $stdoutCB is a callback for output generated by the command. If it
1065 # is undef then output is returned. If it is a code ref then the function
1066 # is called with each piece of output as an argument. If it is a scalar
1067 # ref the output is appended to this variable.
1069 # @args are optional arguments for the eval() case; they are not used
1072 # Also, $? should be set when the CHILD pipe is closed.
1076 my($bpc, $cmd, $stdoutCB, @args) = @_;
1077 my($pid, $out, $allOut);
1080 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1081 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1082 print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1083 if ( $bpc->{verbose} );
1085 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1086 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1087 print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1088 if ( $bpc->{verbose} );
1089 return $out if ( !defined($stdoutCB) );
1092 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1093 print(STDERR "cmdSystemOrEval: about to system ",
1094 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1095 if ( $bpc->{verbose} );
1096 if ( !defined($pid = open(CHILD, "-|")) ) {
1097 my $err = "Can't fork to run @$cmd\n";
1099 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1100 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1101 return $err if ( !defined($stdoutCB) );
1110 open(STDERR, ">&STDOUT");
1111 exec(map { m/(.*)/ } @$cmd); # untaint
1112 print("Exec of @$cmd failed\n");
1116 # The parent gathers the output from the child
1119 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1120 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1121 $out .= $_ if ( !defined($stdoutCB) );
1122 $allOut .= $_ if ( $bpc->{verbose} );
1127 print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1128 if ( $bpc->{verbose} );