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};
155 # Generate an ISO 8601 format timeStamp (but without the "T").
156 # See http://www.w3.org/TR/NOTE-datetime and
157 # http://www.cl.cam.ac.uk/~mgk25/iso-time.html
161 my($bpc, $t, $noPad) = @_;
162 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
163 = localtime($t || time);
164 return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
165 $year + 1900, $mon + 1, $mday, $hour, $min, $sec)
166 . ($noPad ? "" : " ");
171 my($bpc, $host) = @_;
172 local(*BK_INFO, *LOCK);
175 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
176 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
178 while ( <BK_INFO> ) {
180 next if ( !/^(\d+\t(incr|full|partial)[\d\t]*$)/ );
182 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
192 my($bpc, $host, @Backups) = @_;
193 local(*BK_INFO, *LOCK);
196 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
197 unlink("$bpc->{TopDir}/pc/$host/backups.old")
198 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
199 rename("$bpc->{TopDir}/pc/$host/backups",
200 "$bpc->{TopDir}/pc/$host/backups.old")
201 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
202 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
204 for ( $i = 0 ; $i < @Backups ; $i++ ) {
205 my %b = %{$Backups[$i]};
206 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
215 my($bpc, $host) = @_;
216 local(*RESTORE_INFO, *LOCK);
219 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
220 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
221 binmode(RESTORE_INFO);
222 while ( <RESTORE_INFO> ) {
224 next if ( !/^(\d+.*)/ );
226 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
236 my($bpc, $host, @Restores) = @_;
237 local(*RESTORE_INFO, *LOCK);
240 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
241 unlink("$bpc->{TopDir}/pc/$host/restores.old")
242 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
243 rename("$bpc->{TopDir}/pc/$host/restores",
244 "$bpc->{TopDir}/pc/$host/restores.old")
245 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
246 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
247 binmode(RESTORE_INFO);
248 for ( $i = 0 ; $i < @Restores ; $i++ ) {
249 my %b = %{$Restores[$i]};
250 printf(RESTORE_INFO "%s\n",
251 join("\t", @b{@{$bpc->{RestoreFields}}}));
260 my($bpc, $host) = @_;
261 my($ret, $mesg, $config, @configs);
264 push(@configs, "$bpc->{TopDir}/conf/config.pl");
265 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
266 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
267 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
268 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
269 foreach $config ( @configs ) {
271 if ( !defined($ret = do $config) && ($! || $@) ) {
272 $mesg = "Couldn't open $config: $!" if ( $! );
273 $mesg = "Couldn't execute $config: $@" if ( $@ );
274 $mesg =~ s/[\n\r]+//;
277 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
279 return if ( !defined($bpc->{Conf}{Language}) );
280 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
282 # Load any user-specified perl modules. This is for
283 # optional user-defined extensions.
285 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
286 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
287 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
288 eval("use $module;");
291 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
292 if ( !defined($ret = do $langFile) && ($! || $@) ) {
293 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
294 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
295 $mesg =~ s/[\n\r]+//;
298 $bpc->{Lang} = \%Lang;
303 # Return the mtime of the config file
308 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
312 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
313 # With no argument a ref to a hash of hosts is returned. Each
314 # hash contains fields as specified in the hosts file. With an
315 # argument a ref to a single hash is returned with information
316 # for just that host.
320 my($bpc, $host) = @_;
321 my(%hosts, @hdr, @fld);
324 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
325 print(STDERR $bpc->timeStamp,
326 "Can't open $bpc->{TopDir}/conf/hosts\n");
330 while ( <HOST_INFO> ) {
334 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
336 # Split on white space, except if preceded by \
337 # using zero-width negative look-behind assertion
338 # (always wanted to use one of those).
340 @fld = split(/(?<!\\)\s+/, $1);
348 if ( defined($host) ) {
349 next if ( lc($fld[0]) ne $host );
350 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
354 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
365 # Return the mtime of the hosts file
370 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
374 # Stripped down from File::Path. In particular we don't print
375 # many warnings and we try three times to delete each directory
376 # and file -- for some reason the original File::Path rmtree
377 # didn't always completely remove a directory tree on the NetApp.
379 # Warning: this routine changes the cwd.
383 my($bpc, $pwd, $roots) = @_;
386 if ( defined($roots) && length($roots) ) {
387 $roots = [$roots] unless ref $roots;
389 print "RmTreeQuiet: No root path(s) specified\n";
392 foreach $root (@{$roots}) {
393 $root = $1 if ( $root =~ m{(.*?)/*$} );
395 # Try first to simply unlink the file: this avoids an
396 # extra stat for every file. If it fails (which it
397 # will for directories), check if it is a directory and
400 if ( !unlink($root) ) {
402 my $d = DirHandle->new($root)
403 or print "Can't read $pwd/$root: $!";
406 @files = grep $_!~/^\.{1,2}$/, @files;
407 $bpc->RmTreeQuiet("$pwd/$root", \@files);
409 rmdir($root) || rmdir($root);
411 unlink($root) || unlink($root);
418 # Move a directory or file away for later deletion
422 my($bpc, $trashDir, $file) = @_;
425 return if ( !-e $file );
426 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
427 for ( $i = 0 ; $i < 1000 ; $i++ ) {
428 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
430 return if ( rename($file, $f) );
432 # shouldn't get here, but might if you tried to call this
433 # across file systems.... just remove the tree right now.
434 if ( $file =~ /(.*)\/([^\/]*)/ ) {
437 my($cwd) = Cwd::fastcwd();
438 $cwd = $1 if ( $cwd =~ /(.*)/ );
439 $bpc->RmTreeQuiet($d, $f);
440 chdir($cwd) if ( $cwd );
445 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
446 # did something, -1 if it failed to remove all the files.
450 my($bpc, $trashDir) = @_;
452 my($cwd) = Cwd::fastcwd();
454 $cwd = $1 if ( $cwd =~ /(.*)/ );
455 return if ( !-d $trashDir );
456 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
459 @files = grep $_!~/^\.{1,2}$/, @files;
460 return 0 if ( !@files );
461 $bpc->RmTreeQuiet($trashDir, \@files);
462 foreach my $f ( @files ) {
463 return -1 if ( -e $f );
465 chdir($cwd) if ( $cwd );
470 # Open a connection to the server. Returns an error string on failure.
471 # Returns undef on success.
475 my($bpc, $host, $port, $justConnect) = @_;
478 return if ( defined($bpc->{ServerFD}) );
480 # First try the unix-domain socket
482 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
483 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
484 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
485 my $err = "unix connect: $!";
488 my $proto = getprotobyname('tcp');
489 my $iaddr = inet_aton($host) || return "unknown host $host";
490 my $paddr = sockaddr_in($port, $iaddr);
492 socket(*FH, PF_INET, SOCK_STREAM, $proto)
493 || return "inet socket: $!";
494 connect(*FH, $paddr) || return "inet connect: $!";
499 my($oldFH) = select(*FH); $| = 1; select($oldFH);
500 $bpc->{ServerFD} = *FH;
501 return if ( $justConnect );
503 # Read the seed that we need for our MD5 message digest. See
506 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
507 $bpc->{ServerMesgCnt} = 0;
512 # Check that the server connection is still ok
518 return 0 if ( !defined($bpc->{ServerFD}) );
519 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
521 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
522 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
526 # Disconnect from the server
531 return if ( !defined($bpc->{ServerFD}) );
532 close($bpc->{ServerFD});
533 delete($bpc->{ServerFD});
537 # Sends a message to the server and returns with the reply.
539 # To avoid possible attacks via the TCP socket interface, every client
540 # message is protected by an MD5 digest. The MD5 digest includes four
542 # - a seed that is sent to us when we first connect
543 # - a sequence number that increments for each message
544 # - a shared secret that is stored in $Conf{ServerMesgSecret}
545 # - the message itself.
546 # The message is sent in plain text preceded by the MD5 digest. A
547 # snooper can see the plain-text seed sent by BackupPC and plain-text
548 # message, but cannot construct a valid MD5 digest since the secret in
549 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
550 # since the seed changes on a per-connection and per-message basis.
554 my($bpc, $mesg) = @_;
555 return if ( !defined(my $fh = $bpc->{ServerFD}) );
556 my $md5 = Digest::MD5->new;
557 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
558 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
559 print($fh $md5->b64digest . " $mesg\n");
560 $bpc->{ServerMesgCnt}++;
565 # Do initialization for child processes
571 open(STDERR, ">&STDOUT");
572 select(STDERR); $| = 1;
573 select(STDOUT); $| = 1;
574 $ENV{PATH} = $bpc->{Conf}{MyPath};
578 # Compute the MD5 digest of a file. For efficiency we don't
579 # use the whole file for big files:
580 # - for files <= 256K we use the file size and the whole file.
581 # - for files <= 1M we use the file size, the first 128K and
583 # - for files > 1M, we use the file size, the first 128K and
584 # the 8th 128K (ie: the 128K up to 1MB).
585 # See the documentation for a discussion of the tradeoffs in
586 # how much data we use and how many collisions we get.
588 # Returns the MD5 digest (a hex string) and the file size.
592 my($bpc, $md5, $name) = @_;
593 my($data, $fileSize);
596 $fileSize = (stat($name))[7];
597 return ("", -1) if ( !-f _ );
598 $name = $1 if ( $name =~ /(.*)/ );
599 return ("", 0) if ( $fileSize == 0 );
600 return ("", -1) if ( !open(N, $name) );
603 $md5->add($fileSize);
604 if ( $fileSize > 262144 ) {
606 # read the first and last 131072 bytes of the file,
609 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
610 $md5->add($data) if ( sysread(N, $data, 131072) );
611 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
612 && sysread(N, $data, 131072) );
615 # read the whole file
617 $md5->add($data) if ( sysread(N, $data, $fileSize) );
620 return ($md5->hexdigest, $fileSize);
624 # Compute the MD5 digest of a buffer (string). For efficiency we don't
625 # use the whole string for big strings:
626 # - for files <= 256K we use the file size and the whole file.
627 # - for files <= 1M we use the file size, the first 128K and
629 # - for files > 1M, we use the file size, the first 128K and
630 # the 8th 128K (ie: the 128K up to 1MB).
631 # See the documentation for a discussion of the tradeoffs in
632 # how much data we use and how many collisions we get.
634 # Returns the MD5 digest (a hex string).
638 my($bpc, $md5, $fileSize, $dataRef) = @_;
641 $md5->add($fileSize);
642 if ( $fileSize > 262144 ) {
644 # add the first and last 131072 bytes of the string,
647 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
648 $md5->add(substr($$dataRef, 0, 131072));
649 $md5->add(substr($$dataRef, $seekPosn, 131072));
652 # add the whole string
654 $md5->add($$dataRef);
656 return $md5->hexdigest;
660 # Given an MD5 digest $d and a compress flag, return the full
665 my($bpc, $d, $compress, $poolDir) = @_;
667 return if ( $d !~ m{(.)(.)(.)(.*)} );
668 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
669 if ( !defined($poolDir) );
670 return "$poolDir/$1/$2/$3/$1$2$3$4";
674 # For each file, check if the file exists in $bpc->{TopDir}/pool.
675 # If so, remove the file and make a hardlink to the file in
676 # the pool. Otherwise, if the newFile flag is set, make a
677 # hardlink in the pool to the new file.
679 # Returns 0 if a link should be made to a new file (ie: when the file
680 # is a new file but the newFile flag is 0).
681 # Returns 1 if a link to an existing file is made,
682 # Returns 2 if a link to a new file is made (only if $newFile is set)
683 # Returns negative on error.
687 my($bpc, $name, $d, $newFile, $compress) = @_;
690 return -1 if ( !-f $name );
691 for ( $i = -1 ; ; $i++ ) {
692 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
693 $rawFile .= "_$i" if ( $i >= 0 );
695 if ( !compare($name, $rawFile) ) {
697 return -3 if ( !link($rawFile, $name) );
700 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
702 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
703 mkpath($newDir, 0, 0777) if ( !-d $newDir );
704 return -4 if ( !link($name, $rawFile) );
714 my($bpc, $host) = @_;
715 my($s, $pingCmd, $ret);
718 # Return success if the ping cmd is undefined or empty.
720 if ( $bpc->{Conf}{PingCmd} eq "" ) {
721 print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
722 . " is empty\n") if ( $bpc->{verbose} );
727 pingPath => $bpc->{Conf}{PingPath},
730 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
733 # Do a first ping in case the PC needs to wakeup
735 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
737 print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
738 if ( $bpc->{verbose} );
743 # Do a second ping and get the round-trip time in msec
745 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
747 print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
748 if ( $bpc->{verbose} );
751 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
753 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
756 print(STDERR "CheckHostAlive: can't extract round-trip time"
757 . " (not fatal)\n") if ( $bpc->{verbose} );
760 print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
764 sub CheckFileSystemUsage
767 my($topDir) = $bpc->{TopDir};
770 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
772 dfPath => $bpc->{Conf}{DfPath},
773 topDir => $bpc->{TopDir},
775 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
776 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
777 return 0 if ( $? || $s !~ /(\d+)%/s );
782 # Given an IP address, return the host name and user name via
787 my($bpc, $host) = @_;
788 my($netBiosHostName, $netBiosUserName);
792 # Skip NetBios check if NmbLookupCmd is emtpy
794 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
795 print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
796 . " is empty\n") if ( $bpc->{verbose} );
797 return ($host, undef);
801 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
804 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
805 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
806 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
807 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
808 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
810 if ( !defined($netBiosHostName) ) {
811 print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
812 if ( $bpc->{verbose} );
815 $netBiosHostName = lc($netBiosHostName);
816 $netBiosUserName = lc($netBiosUserName);
817 print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
818 . " user $netBiosUserName\n") if ( $bpc->{verbose} );
819 return ($netBiosHostName, $netBiosUserName);
823 # Given a NetBios name lookup the IP address via NetBios.
824 # In the case of a host returning multiple interfaces we
825 # return the first IP address that matches the subnet mask.
826 # If none match the subnet mask (or nmblookup doesn't print
827 # the subnet mask) then just the first IP address is returned.
829 sub NetBiosHostIPFind
831 my($bpc, $host) = @_;
832 my($netBiosHostName, $netBiosUserName);
833 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
836 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
838 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
839 print(STDERR "NetBiosHostIPFind: return $host because"
840 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
841 if ( $bpc->{verbose} );
846 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
849 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
850 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
852 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
854 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
855 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
857 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
858 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
861 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
862 if ( defined($ipAddr) ) {
863 print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
864 . " host $host\n") if ( $bpc->{verbose} );
867 print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
868 . " host $host\n") if ( $bpc->{verbose} );
873 sub fileNameEltMangle
875 my($bpc, $name) = @_;
877 return "" if ( $name eq "" );
878 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
883 # We store files with every name preceded by "f". This
884 # avoids possible name conflicts with other information
885 # we store in the same directories (eg: attribute info).
886 # The process of turning a normal path into one with each
887 # node prefixed with "f" is called mangling.
891 my($bpc, $name) = @_;
893 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
894 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
899 # This undoes FileNameMangle
903 my($bpc, $name) = @_;
907 $name =~ s{%(..)}{chr(hex($1))}eg;
912 # Escape shell meta-characters with backslashes.
913 # This should be applied to each argument seperately, not an
914 # entire shell command.
920 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
925 # For printing exec commands (which don't use a shell) so they look like
926 # a valid shell command this function should be called with the exec
927 # args. The shell command string is returned.
931 my($bpc, @args) = @_;
934 foreach my $a ( @args ) {
935 $str .= " " if ( $str ne "" );
936 $str .= $bpc->shellEscape($a);
942 # Do a URI-style escape to protect/encode special characters
947 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
952 # Do a URI-style unescape to restore special characters
957 $s =~ s{%(..)}{chr(hex($1))}eg;
962 # Do variable substitution prior to execution of a command.
966 my($bpc, $template, $vars) = @_;
970 # Return without any substitution if the first entry starts with "&",
971 # indicating this is perl code.
973 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
976 if ( ref($template) ne "ARRAY" ) {
978 # Split at white space, except if escaped by \
980 $template = [split(/(?<!\\)\s+/, $template)];
982 # Remove the \ that escaped white space.
984 foreach ( @$template ) {
989 # Merge variables into @tarClientCmd
991 foreach my $arg ( @$template ) {
993 # Replace scalar variables first
995 $arg =~ s{\$(\w+)(\+?)}{
996 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
997 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1001 # Now replicate any array arguments; this just works for just one
1002 # array var in each argument.
1004 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1009 foreach my $v ( @{$vars->{$var}} ) {
1010 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1011 push(@cmd, "$pre$v$post");
1021 # Exec or eval a command. $cmd is either a string on an array ref.
1023 # @args are optional arguments for the eval() case; they are not used
1028 my($bpc, $cmd, @args) = @_;
1030 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1031 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1032 print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1033 if ( $bpc->{verbose} );
1035 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1038 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1039 print(STDERR "cmdExecOrEval: about to exec ",
1040 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1041 if ( $bpc->{verbose} );
1042 exec(map { m/(.*)/ } @$cmd); # untaint
1043 print(STDERR "Exec failed for @$cmd\n");
1049 # System or eval a command. $cmd is either a string on an array ref.
1050 # $stdoutCB is a callback for output generated by the command. If it
1051 # is undef then output is returned. If it is a code ref then the function
1052 # is called with each piece of output as an argument. If it is a scalar
1053 # ref the output is appended to this variable.
1055 # @args are optional arguments for the eval() case; they are not used
1058 # Also, $? should be set when the CHILD pipe is closed.
1062 my($bpc, $cmd, $stdoutCB, @args) = @_;
1063 my($pid, $out, $allOut);
1066 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1067 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1068 print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1069 if ( $bpc->{verbose} );
1071 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1072 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1073 print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1074 if ( $bpc->{verbose} );
1075 return $out if ( !defined($stdoutCB) );
1078 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1079 print(STDERR "cmdSystemOrEval: about to system ",
1080 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1081 if ( $bpc->{verbose} );
1082 if ( !defined($pid = open(CHILD, "-|")) ) {
1083 my $err = "Can't fork to run @$cmd\n";
1085 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1086 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1087 return $err if ( !defined($stdoutCB) );
1096 open(STDERR, ">&STDOUT");
1097 exec(map { m/(.*)/ } @$cmd); # untaint
1098 print("Exec of @$cmd failed\n");
1102 # The parent gathers the output from the child
1105 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1106 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1107 $out .= $_ if ( !defined($stdoutCB) );
1108 $allOut .= $_ if ( $bpc->{verbose} );
1113 print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1114 if ( $bpc->{verbose} );