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 num startTime endTime result errorMsg
77 $bpc->{BinDir} .= "/bin";
78 $bpc->{LibDir} .= "/lib";
80 # Clean up %ENV and setup other variables.
82 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
83 $bpc->{PoolDir} = "$bpc->{TopDir}/pool";
84 $bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
85 if ( defined(my $error = $bpc->ConfigRead()) ) {
86 print(STDERR $error, "\n");
90 # Verify we are running as the correct user
93 && $bpc->{Conf}{BackupPCUserVerify}
94 && $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) {
95 print("Wrong user: my userid is $>, instead of $uid"
96 . " ($bpc->{Conf}{BackupPCUser})\n");
105 return $bpc->{TopDir};
111 return $bpc->{BinDir};
117 return $bpc->{Version};
123 return %{$bpc->{Conf}};
139 return " trashClean ";
144 my($bpc, $param) = @_;
146 return $bpc->{Conf}{$param};
151 my($bpc, $param) = @_;
153 $bpc->{verbose} = $param if ( defined($param) );
154 return $bpc->{verbose};
158 # Generate an ISO 8601 format timeStamp (but without the "T").
159 # See http://www.w3.org/TR/NOTE-datetime and
160 # http://www.cl.cam.ac.uk/~mgk25/iso-time.html
164 my($bpc, $t, $noPad) = @_;
165 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
166 = localtime($t || time);
167 return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
168 $year + 1900, $mon + 1, $mday, $hour, $min, $sec)
169 . ($noPad ? "" : " ");
174 my($bpc, $host) = @_;
175 local(*BK_INFO, *LOCK);
178 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
179 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
181 while ( <BK_INFO> ) {
183 next if ( !/^(\d+\t(incr|full|partial)[\d\t]*$)/ );
185 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
195 my($bpc, $host, @Backups) = @_;
196 local(*BK_INFO, *LOCK);
199 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
200 unlink("$bpc->{TopDir}/pc/$host/backups.old")
201 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
202 rename("$bpc->{TopDir}/pc/$host/backups",
203 "$bpc->{TopDir}/pc/$host/backups.old")
204 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
205 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
207 for ( $i = 0 ; $i < @Backups ; $i++ ) {
208 my %b = %{$Backups[$i]};
209 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
218 my($bpc, $host) = @_;
219 local(*RESTORE_INFO, *LOCK);
222 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
223 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
224 binmode(RESTORE_INFO);
225 while ( <RESTORE_INFO> ) {
227 next if ( !/^(\d+.*)/ );
229 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
239 my($bpc, $host, @Restores) = @_;
240 local(*RESTORE_INFO, *LOCK);
243 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
244 unlink("$bpc->{TopDir}/pc/$host/restores.old")
245 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
246 rename("$bpc->{TopDir}/pc/$host/restores",
247 "$bpc->{TopDir}/pc/$host/restores.old")
248 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
249 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
250 binmode(RESTORE_INFO);
251 for ( $i = 0 ; $i < @Restores ; $i++ ) {
252 my %b = %{$Restores[$i]};
253 printf(RESTORE_INFO "%s\n",
254 join("\t", @b{@{$bpc->{RestoreFields}}}));
263 my($bpc, $host) = @_;
264 local(*ARCHIVE_INFO, *LOCK);
267 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
268 if ( open(ARCHIVE_INFO, "$bpc->{TopDir}/pc/$host/archives") ) {
269 binmode(ARCHIVE_INFO);
270 while ( <ARCHIVE_INFO> ) {
272 next if ( !/^(\d+.*)/ );
274 @{$Archives[@Archives]}{@{$bpc->{ArchiveFields}}} = split(/\t/);
284 my($bpc, $host, @Archives) = @_;
285 local(*ARCHIVE_INFO, *LOCK);
288 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
289 unlink("$bpc->{TopDir}/pc/$host/archives.old")
290 if ( -f "$bpc->{TopDir}/pc/$host/archives.old" );
291 rename("$bpc->{TopDir}/pc/$host/archives",
292 "$bpc->{TopDir}/pc/$host/archives.old")
293 if ( -f "$bpc->{TopDir}/pc/$host/archives" );
294 if ( open(ARCHIVE_INFO, ">$bpc->{TopDir}/pc/$host/archives") ) {
295 binmode(ARCHIVE_INFO);
296 for ( $i = 0 ; $i < @Archives ; $i++ ) {
297 my %b = %{$Archives[$i]};
298 printf(ARCHIVE_INFO "%s\n",
299 join("\t", @b{@{$bpc->{ArchiveFields}}}));
308 my($bpc, $host) = @_;
309 my($ret, $mesg, $config, @configs);
312 push(@configs, "$bpc->{TopDir}/conf/config.pl");
313 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
314 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
315 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
316 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
317 foreach $config ( @configs ) {
319 if ( !defined($ret = do $config) && ($! || $@) ) {
320 $mesg = "Couldn't open $config: $!" if ( $! );
321 $mesg = "Couldn't execute $config: $@" if ( $@ );
322 $mesg =~ s/[\n\r]+//;
325 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
327 return if ( !defined($bpc->{Conf}{Language}) );
328 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
330 # Load any user-specified perl modules. This is for
331 # optional user-defined extensions.
333 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
334 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
335 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
336 eval("use $module;");
339 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
340 if ( !defined($ret = do $langFile) && ($! || $@) ) {
341 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
342 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
343 $mesg =~ s/[\n\r]+//;
346 $bpc->{Lang} = \%Lang;
351 # Return the mtime of the config file
356 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
360 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
361 # With no argument a ref to a hash of hosts is returned. Each
362 # hash contains fields as specified in the hosts file. With an
363 # argument a ref to a single hash is returned with information
364 # for just that host.
368 my($bpc, $host) = @_;
369 my(%hosts, @hdr, @fld);
372 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
373 print(STDERR $bpc->timeStamp,
374 "Can't open $bpc->{TopDir}/conf/hosts\n");
378 while ( <HOST_INFO> ) {
382 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
384 # Split on white space, except if preceded by \
385 # using zero-width negative look-behind assertion
386 # (always wanted to use one of those).
388 @fld = split(/(?<!\\)\s+/, $1);
396 if ( defined($host) ) {
397 next if ( lc($fld[0]) ne $host );
398 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
402 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
413 # Return the mtime of the hosts file
418 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
422 # Stripped down from File::Path. In particular we don't print
423 # many warnings and we try three times to delete each directory
424 # and file -- for some reason the original File::Path rmtree
425 # didn't always completely remove a directory tree on the NetApp.
427 # Warning: this routine changes the cwd.
431 my($bpc, $pwd, $roots) = @_;
434 if ( defined($roots) && length($roots) ) {
435 $roots = [$roots] unless ref $roots;
437 print "RmTreeQuiet: No root path(s) specified\n";
440 foreach $root (@{$roots}) {
441 $root = $1 if ( $root =~ m{(.*?)/*$} );
443 # Try first to simply unlink the file: this avoids an
444 # extra stat for every file. If it fails (which it
445 # will for directories), check if it is a directory and
448 if ( !unlink($root) ) {
450 my $d = DirHandle->new($root)
451 or print "Can't read $pwd/$root: $!";
454 @files = grep $_!~/^\.{1,2}$/, @files;
455 $bpc->RmTreeQuiet("$pwd/$root", \@files);
457 rmdir($root) || rmdir($root);
459 unlink($root) || unlink($root);
466 # Move a directory or file away for later deletion
470 my($bpc, $trashDir, $file) = @_;
473 return if ( !-e $file );
474 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
475 for ( $i = 0 ; $i < 1000 ; $i++ ) {
476 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
478 return if ( rename($file, $f) );
480 # shouldn't get here, but might if you tried to call this
481 # across file systems.... just remove the tree right now.
482 if ( $file =~ /(.*)\/([^\/]*)/ ) {
485 my($cwd) = Cwd::fastcwd();
486 $cwd = $1 if ( $cwd =~ /(.*)/ );
487 $bpc->RmTreeQuiet($d, $f);
488 chdir($cwd) if ( $cwd );
493 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
494 # did something, -1 if it failed to remove all the files.
498 my($bpc, $trashDir) = @_;
500 my($cwd) = Cwd::fastcwd();
502 $cwd = $1 if ( $cwd =~ /(.*)/ );
503 return if ( !-d $trashDir );
504 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
507 @files = grep $_!~/^\.{1,2}$/, @files;
508 return 0 if ( !@files );
509 $bpc->RmTreeQuiet($trashDir, \@files);
510 foreach my $f ( @files ) {
511 return -1 if ( -e $f );
513 chdir($cwd) if ( $cwd );
518 # Open a connection to the server. Returns an error string on failure.
519 # Returns undef on success.
523 my($bpc, $host, $port, $justConnect) = @_;
526 return if ( defined($bpc->{ServerFD}) );
528 # First try the unix-domain socket
530 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
531 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
532 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
533 my $err = "unix connect: $!";
536 my $proto = getprotobyname('tcp');
537 my $iaddr = inet_aton($host) || return "unknown host $host";
538 my $paddr = sockaddr_in($port, $iaddr);
540 socket(*FH, PF_INET, SOCK_STREAM, $proto)
541 || return "inet socket: $!";
542 connect(*FH, $paddr) || return "inet connect: $!";
547 my($oldFH) = select(*FH); $| = 1; select($oldFH);
548 $bpc->{ServerFD} = *FH;
549 return if ( $justConnect );
551 # Read the seed that we need for our MD5 message digest. See
554 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
555 $bpc->{ServerMesgCnt} = 0;
560 # Check that the server connection is still ok
566 return 0 if ( !defined($bpc->{ServerFD}) );
567 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
569 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
570 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
574 # Disconnect from the server
579 return if ( !defined($bpc->{ServerFD}) );
580 close($bpc->{ServerFD});
581 delete($bpc->{ServerFD});
585 # Sends a message to the server and returns with the reply.
587 # To avoid possible attacks via the TCP socket interface, every client
588 # message is protected by an MD5 digest. The MD5 digest includes four
590 # - a seed that is sent to us when we first connect
591 # - a sequence number that increments for each message
592 # - a shared secret that is stored in $Conf{ServerMesgSecret}
593 # - the message itself.
594 # The message is sent in plain text preceded by the MD5 digest. A
595 # snooper can see the plain-text seed sent by BackupPC and plain-text
596 # message, but cannot construct a valid MD5 digest since the secret in
597 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
598 # since the seed changes on a per-connection and per-message basis.
602 my($bpc, $mesg) = @_;
603 return if ( !defined(my $fh = $bpc->{ServerFD}) );
604 my $md5 = Digest::MD5->new;
605 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
606 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
607 print($fh $md5->b64digest . " $mesg\n");
608 $bpc->{ServerMesgCnt}++;
613 # Do initialization for child processes
619 open(STDERR, ">&STDOUT");
620 select(STDERR); $| = 1;
621 select(STDOUT); $| = 1;
622 $ENV{PATH} = $bpc->{Conf}{MyPath};
626 # Compute the MD5 digest of a file. For efficiency we don't
627 # use the whole file for big files:
628 # - for files <= 256K we use the file size and the whole file.
629 # - for files <= 1M we use the file size, the first 128K and
631 # - for files > 1M, we use the file size, the first 128K and
632 # the 8th 128K (ie: the 128K up to 1MB).
633 # See the documentation for a discussion of the tradeoffs in
634 # how much data we use and how many collisions we get.
636 # Returns the MD5 digest (a hex string) and the file size.
640 my($bpc, $md5, $name) = @_;
641 my($data, $fileSize);
644 $fileSize = (stat($name))[7];
645 return ("", -1) if ( !-f _ );
646 $name = $1 if ( $name =~ /(.*)/ );
647 return ("", 0) if ( $fileSize == 0 );
648 return ("", -1) if ( !open(N, $name) );
651 $md5->add($fileSize);
652 if ( $fileSize > 262144 ) {
654 # read the first and last 131072 bytes of the file,
657 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
658 $md5->add($data) if ( sysread(N, $data, 131072) );
659 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
660 && sysread(N, $data, 131072) );
663 # read the whole file
665 $md5->add($data) if ( sysread(N, $data, $fileSize) );
668 return ($md5->hexdigest, $fileSize);
672 # Compute the MD5 digest of a buffer (string). For efficiency we don't
673 # use the whole string for big strings:
674 # - for files <= 256K we use the file size and the whole file.
675 # - for files <= 1M we use the file size, the first 128K and
677 # - for files > 1M, we use the file size, the first 128K and
678 # the 8th 128K (ie: the 128K up to 1MB).
679 # See the documentation for a discussion of the tradeoffs in
680 # how much data we use and how many collisions we get.
682 # Returns the MD5 digest (a hex string).
686 my($bpc, $md5, $fileSize, $dataRef) = @_;
689 $md5->add($fileSize);
690 if ( $fileSize > 262144 ) {
692 # add the first and last 131072 bytes of the string,
695 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
696 $md5->add(substr($$dataRef, 0, 131072));
697 $md5->add(substr($$dataRef, $seekPosn, 131072));
700 # add the whole string
702 $md5->add($$dataRef);
704 return $md5->hexdigest;
708 # Given an MD5 digest $d and a compress flag, return the full
713 my($bpc, $d, $compress, $poolDir) = @_;
715 return if ( $d !~ m{(.)(.)(.)(.*)} );
716 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
717 if ( !defined($poolDir) );
718 return "$poolDir/$1/$2/$3/$1$2$3$4";
722 # For each file, check if the file exists in $bpc->{TopDir}/pool.
723 # If so, remove the file and make a hardlink to the file in
724 # the pool. Otherwise, if the newFile flag is set, make a
725 # hardlink in the pool to the new file.
727 # Returns 0 if a link should be made to a new file (ie: when the file
728 # is a new file but the newFile flag is 0).
729 # Returns 1 if a link to an existing file is made,
730 # Returns 2 if a link to a new file is made (only if $newFile is set)
731 # Returns negative on error.
735 my($bpc, $name, $d, $newFile, $compress) = @_;
738 return -1 if ( !-f $name );
739 for ( $i = -1 ; ; $i++ ) {
740 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
741 $rawFile .= "_$i" if ( $i >= 0 );
743 if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
744 && !compare($name, $rawFile) ) {
746 return -3 if ( !link($rawFile, $name) );
749 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
751 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
752 mkpath($newDir, 0, 0777) if ( !-d $newDir );
753 return -4 if ( !link($name, $rawFile) );
763 my($bpc, $host) = @_;
764 my($s, $pingCmd, $ret);
767 # Return success if the ping cmd is undefined or empty.
769 if ( $bpc->{Conf}{PingCmd} eq "" ) {
770 print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
771 . " is empty\n") if ( $bpc->{verbose} );
776 pingPath => $bpc->{Conf}{PingPath},
779 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
782 # Do a first ping in case the PC needs to wakeup
784 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
786 print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
787 if ( $bpc->{verbose} );
792 # Do a second ping and get the round-trip time in msec
794 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
796 print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
797 if ( $bpc->{verbose} );
800 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
802 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
805 print(STDERR "CheckHostAlive: can't extract round-trip time"
806 . " (not fatal)\n") if ( $bpc->{verbose} );
809 print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
813 sub CheckFileSystemUsage
816 my($topDir) = $bpc->{TopDir};
819 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
821 dfPath => $bpc->{Conf}{DfPath},
822 topDir => $bpc->{TopDir},
824 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
825 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
826 return 0 if ( $? || $s !~ /(\d+)%/s );
831 # Given an IP address, return the host name and user name via
836 my($bpc, $host) = @_;
837 my($netBiosHostName, $netBiosUserName);
841 # Skip NetBios check if NmbLookupCmd is emtpy
843 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
844 print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
845 . " is empty\n") if ( $bpc->{verbose} );
846 return ($host, undef);
850 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
853 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
854 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
855 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
856 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
857 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
859 if ( !defined($netBiosHostName) ) {
860 print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
861 if ( $bpc->{verbose} );
864 $netBiosHostName = lc($netBiosHostName);
865 $netBiosUserName = lc($netBiosUserName);
866 print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
867 . " user $netBiosUserName\n") if ( $bpc->{verbose} );
868 return ($netBiosHostName, $netBiosUserName);
872 # Given a NetBios name lookup the IP address via NetBios.
873 # In the case of a host returning multiple interfaces we
874 # return the first IP address that matches the subnet mask.
875 # If none match the subnet mask (or nmblookup doesn't print
876 # the subnet mask) then just the first IP address is returned.
878 sub NetBiosHostIPFind
880 my($bpc, $host) = @_;
881 my($netBiosHostName, $netBiosUserName);
882 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
885 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
887 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
888 print(STDERR "NetBiosHostIPFind: return $host because"
889 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
890 if ( $bpc->{verbose} );
895 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
898 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
899 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
901 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
903 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
904 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
906 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
907 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
910 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
911 if ( defined($ipAddr) ) {
912 print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
913 . " host $host\n") if ( $bpc->{verbose} );
916 print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
917 . " host $host\n") if ( $bpc->{verbose} );
922 sub fileNameEltMangle
924 my($bpc, $name) = @_;
926 return "" if ( $name eq "" );
927 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
932 # We store files with every name preceded by "f". This
933 # avoids possible name conflicts with other information
934 # we store in the same directories (eg: attribute info).
935 # The process of turning a normal path into one with each
936 # node prefixed with "f" is called mangling.
940 my($bpc, $name) = @_;
942 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
943 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
948 # This undoes FileNameMangle
952 my($bpc, $name) = @_;
956 $name =~ s{%(..)}{chr(hex($1))}eg;
961 # Escape shell meta-characters with backslashes.
962 # This should be applied to each argument seperately, not an
963 # entire shell command.
969 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
974 # For printing exec commands (which don't use a shell) so they look like
975 # a valid shell command this function should be called with the exec
976 # args. The shell command string is returned.
980 my($bpc, @args) = @_;
983 foreach my $a ( @args ) {
984 $str .= " " if ( $str ne "" );
985 $str .= $bpc->shellEscape($a);
991 # Do a URI-style escape to protect/encode special characters
996 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
1001 # Do a URI-style unescape to restore special characters
1006 $s =~ s{%(..)}{chr(hex($1))}eg;
1011 # Do variable substitution prior to execution of a command.
1013 sub cmdVarSubstitute
1015 my($bpc, $template, $vars) = @_;
1019 # Return without any substitution if the first entry starts with "&",
1020 # indicating this is perl code.
1022 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1025 if ( ref($template) ne "ARRAY" ) {
1027 # Split at white space, except if escaped by \
1029 $template = [split(/(?<!\\)\s+/, $template)];
1031 # Remove the \ that escaped white space.
1033 foreach ( @$template ) {
1038 # Merge variables into @tarClientCmd
1040 foreach my $arg ( @$template ) {
1042 # Replace scalar variables first
1044 $arg =~ s{\$(\w+)(\+?)}{
1045 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1046 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1050 # Now replicate any array arguments; this just works for just one
1051 # array var in each argument.
1053 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1058 foreach my $v ( @{$vars->{$var}} ) {
1059 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1060 push(@cmd, "$pre$v$post");
1070 # Exec or eval a command. $cmd is either a string on an array ref.
1072 # @args are optional arguments for the eval() case; they are not used
1077 my($bpc, $cmd, @args) = @_;
1079 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1080 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1081 print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1082 if ( $bpc->{verbose} );
1084 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1087 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1088 print(STDERR "cmdExecOrEval: about to exec ",
1089 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1090 if ( $bpc->{verbose} );
1091 exec(map { m/(.*)/ } @$cmd); # untaint
1092 print(STDERR "Exec failed for @$cmd\n");
1098 # System or eval a command. $cmd is either a string on an array ref.
1099 # $stdoutCB is a callback for output generated by the command. If it
1100 # is undef then output is returned. If it is a code ref then the function
1101 # is called with each piece of output as an argument. If it is a scalar
1102 # ref the output is appended to this variable.
1104 # @args are optional arguments for the eval() case; they are not used
1107 # Also, $? should be set when the CHILD pipe is closed.
1111 my($bpc, $cmd, $stdoutCB, @args) = @_;
1112 my($pid, $out, $allOut);
1115 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1116 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1117 print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1118 if ( $bpc->{verbose} );
1120 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1121 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1122 print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1123 if ( $bpc->{verbose} );
1124 return $out if ( !defined($stdoutCB) );
1127 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1128 print(STDERR "cmdSystemOrEval: about to system ",
1129 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1130 if ( $bpc->{verbose} );
1131 if ( !defined($pid = open(CHILD, "-|")) ) {
1132 my $err = "Can't fork to run @$cmd\n";
1134 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1135 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1136 return $err if ( !defined($stdoutCB) );
1145 open(STDERR, ">&STDOUT");
1146 exec(map { m/(.*)/ } @$cmd); # untaint
1147 print("Exec of @$cmd failed\n");
1151 # The parent gathers the output from the child
1154 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1155 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1156 $out .= $_ if ( !defined($stdoutCB) );
1157 $allOut .= $_ if ( $bpc->{verbose} );
1162 print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1163 if ( $bpc->{verbose} );