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.0beta0, released 20 Mar 2004.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
56 my($topDir, $installDir, $noUserCheck) = @_;
59 TopDir => $topDir || '/data/BackupPC',
60 BinDir => $installDir || '/usr/local/BackupPC',
61 LibDir => $installDir || '/usr/local/BackupPC',
62 Version => '2.1.0beta0',
64 num type startTime endTime
65 nFiles size nFilesExist sizeExist nFilesNew sizeNew
66 xferErrs xferBadFile xferBadShare tarErrs
67 compress sizeExistComp sizeNewComp
68 noFill fillFromNum mangle xferMethod level
71 num startTime endTime result errorMsg nFiles size
72 tarCreateErrs xferErrs
75 num startTime endTime result errorMsg
78 $bpc->{BinDir} .= "/bin";
79 $bpc->{LibDir} .= "/lib";
81 # Clean up %ENV and setup other variables.
83 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
84 $bpc->{PoolDir} = "$bpc->{TopDir}/pool";
85 $bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
86 if ( defined(my $error = $bpc->ConfigRead()) ) {
87 print(STDERR $error, "\n");
91 # Verify we are running as the correct user
94 && $bpc->{Conf}{BackupPCUserVerify}
95 && $> != (my $uid = (getpwnam($bpc->{Conf}{BackupPCUser}))[2]) ) {
96 print(STDERR "Wrong user: my userid is $>, instead of $uid"
97 . " ($bpc->{Conf}{BackupPCUser})\n");
106 return $bpc->{TopDir};
112 return $bpc->{BinDir};
118 return $bpc->{Version};
124 return %{$bpc->{Conf}};
140 return " trashClean ";
145 my($bpc, $param) = @_;
147 return $bpc->{Conf}{$param};
152 my($bpc, $param) = @_;
154 $bpc->{verbose} = $param if ( defined($param) );
155 return $bpc->{verbose};
162 if ( !defined($bpc->{SigName2Num}) ) {
164 foreach my $name ( split(' ', $Config{sig_name}) ) {
165 $bpc->{SigName2Num}{$name} = $i;
169 return $bpc->{SigName2Num}{$sig};
173 # Generate an ISO 8601 format timeStamp (but without the "T").
174 # See http://www.w3.org/TR/NOTE-datetime and
175 # http://www.cl.cam.ac.uk/~mgk25/iso-time.html
179 my($bpc, $t, $noPad) = @_;
180 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
181 = localtime($t || time);
182 return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
183 $year + 1900, $mon + 1, $mday, $hour, $min, $sec)
184 . ($noPad ? "" : " ");
189 my($bpc, $host) = @_;
190 local(*BK_INFO, *LOCK);
193 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
194 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
196 while ( <BK_INFO> ) {
198 next if ( !/^(\d+\t(incr|full|partial)[\d\t]*$)/ );
200 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
210 my($bpc, $host, @Backups) = @_;
211 local(*BK_INFO, *LOCK);
214 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
215 unlink("$bpc->{TopDir}/pc/$host/backups.old")
216 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
217 rename("$bpc->{TopDir}/pc/$host/backups",
218 "$bpc->{TopDir}/pc/$host/backups.old")
219 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
220 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
222 for ( $i = 0 ; $i < @Backups ; $i++ ) {
223 my %b = %{$Backups[$i]};
224 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
233 my($bpc, $host) = @_;
234 local(*RESTORE_INFO, *LOCK);
237 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
238 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
239 binmode(RESTORE_INFO);
240 while ( <RESTORE_INFO> ) {
242 next if ( !/^(\d+.*)/ );
244 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
254 my($bpc, $host, @Restores) = @_;
255 local(*RESTORE_INFO, *LOCK);
258 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
259 unlink("$bpc->{TopDir}/pc/$host/restores.old")
260 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
261 rename("$bpc->{TopDir}/pc/$host/restores",
262 "$bpc->{TopDir}/pc/$host/restores.old")
263 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
264 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
265 binmode(RESTORE_INFO);
266 for ( $i = 0 ; $i < @Restores ; $i++ ) {
267 my %b = %{$Restores[$i]};
268 printf(RESTORE_INFO "%s\n",
269 join("\t", @b{@{$bpc->{RestoreFields}}}));
278 my($bpc, $host) = @_;
279 local(*ARCHIVE_INFO, *LOCK);
282 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
283 if ( open(ARCHIVE_INFO, "$bpc->{TopDir}/pc/$host/archives") ) {
284 binmode(ARCHIVE_INFO);
285 while ( <ARCHIVE_INFO> ) {
287 next if ( !/^(\d+.*)/ );
289 @{$Archives[@Archives]}{@{$bpc->{ArchiveFields}}} = split(/\t/);
299 my($bpc, $host, @Archives) = @_;
300 local(*ARCHIVE_INFO, *LOCK);
303 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
304 unlink("$bpc->{TopDir}/pc/$host/archives.old")
305 if ( -f "$bpc->{TopDir}/pc/$host/archives.old" );
306 rename("$bpc->{TopDir}/pc/$host/archives",
307 "$bpc->{TopDir}/pc/$host/archives.old")
308 if ( -f "$bpc->{TopDir}/pc/$host/archives" );
309 if ( open(ARCHIVE_INFO, ">$bpc->{TopDir}/pc/$host/archives") ) {
310 binmode(ARCHIVE_INFO);
311 for ( $i = 0 ; $i < @Archives ; $i++ ) {
312 my %b = %{$Archives[$i]};
313 printf(ARCHIVE_INFO "%s\n",
314 join("\t", @b{@{$bpc->{ArchiveFields}}}));
323 my($bpc, $host) = @_;
324 my($ret, $mesg, $config, @configs);
327 push(@configs, "$bpc->{TopDir}/conf/config.pl");
328 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
329 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
330 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
331 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
332 foreach $config ( @configs ) {
334 if ( !defined($ret = do $config) && ($! || $@) ) {
335 $mesg = "Couldn't open $config: $!" if ( $! );
336 $mesg = "Couldn't execute $config: $@" if ( $@ );
337 $mesg =~ s/[\n\r]+//;
340 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
342 return if ( !defined($bpc->{Conf}{Language}) );
343 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
345 # Load any user-specified perl modules. This is for
346 # optional user-defined extensions.
348 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
349 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
350 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
351 eval("use $module;");
354 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
355 if ( !defined($ret = do $langFile) && ($! || $@) ) {
356 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
357 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
358 $mesg =~ s/[\n\r]+//;
361 $bpc->{Lang} = \%Lang;
366 # Return the mtime of the config file
371 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
375 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
376 # With no argument a ref to a hash of hosts is returned. Each
377 # hash contains fields as specified in the hosts file. With an
378 # argument a ref to a single hash is returned with information
379 # for just that host.
383 my($bpc, $host) = @_;
384 my(%hosts, @hdr, @fld);
387 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
388 print(STDERR $bpc->timeStamp,
389 "Can't open $bpc->{TopDir}/conf/hosts\n");
393 while ( <HOST_INFO> ) {
397 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
399 # Split on white space, except if preceded by \
400 # using zero-width negative look-behind assertion
401 # (always wanted to use one of those).
403 @fld = split(/(?<!\\)\s+/, $1);
411 if ( defined($host) ) {
412 next if ( lc($fld[0]) ne $host );
413 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
417 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
428 # Return the mtime of the hosts file
433 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
437 # Stripped down from File::Path. In particular we don't print
438 # many warnings and we try three times to delete each directory
439 # and file -- for some reason the original File::Path rmtree
440 # didn't always completely remove a directory tree on the NetApp.
442 # Warning: this routine changes the cwd.
446 my($bpc, $pwd, $roots) = @_;
449 if ( defined($roots) && length($roots) ) {
450 $roots = [$roots] unless ref $roots;
452 print(STDERR "RmTreeQuiet: No root path(s) specified\n");
455 foreach $root (@{$roots}) {
456 $root = $1 if ( $root =~ m{(.*?)/*$} );
458 # Try first to simply unlink the file: this avoids an
459 # extra stat for every file. If it fails (which it
460 # will for directories), check if it is a directory and
463 if ( !unlink($root) ) {
465 my $d = DirHandle->new($root);
466 if ( !defined($d) ) {
467 print(STDERR "Can't read $pwd/$root: $!\n");
471 @files = grep $_!~/^\.{1,2}$/, @files;
472 $bpc->RmTreeQuiet("$pwd/$root", \@files);
474 rmdir($root) || rmdir($root);
477 unlink($root) || unlink($root);
484 # Move a directory or file away for later deletion
488 my($bpc, $trashDir, $file) = @_;
491 return if ( !-e $file );
492 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
493 for ( $i = 0 ; $i < 1000 ; $i++ ) {
494 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
496 return if ( rename($file, $f) );
498 # shouldn't get here, but might if you tried to call this
499 # across file systems.... just remove the tree right now.
500 if ( $file =~ /(.*)\/([^\/]*)/ ) {
503 my($cwd) = Cwd::fastcwd();
504 $cwd = $1 if ( $cwd =~ /(.*)/ );
505 $bpc->RmTreeQuiet($d, $f);
506 chdir($cwd) if ( $cwd );
511 # Empty the trash directory. Returns 0 if it did nothing, 1 if it
512 # did something, -1 if it failed to remove all the files.
516 my($bpc, $trashDir) = @_;
518 my($cwd) = Cwd::fastcwd();
520 $cwd = $1 if ( $cwd =~ /(.*)/ );
521 return if ( !-d $trashDir );
522 my $d = DirHandle->new($trashDir) or carp "Can't read $trashDir: $!";
525 @files = grep $_!~/^\.{1,2}$/, @files;
526 return 0 if ( !@files );
527 $bpc->RmTreeQuiet($trashDir, \@files);
528 foreach my $f ( @files ) {
529 return -1 if ( -e $f );
531 chdir($cwd) if ( $cwd );
536 # Open a connection to the server. Returns an error string on failure.
537 # Returns undef on success.
541 my($bpc, $host, $port, $justConnect) = @_;
544 return if ( defined($bpc->{ServerFD}) );
546 # First try the unix-domain socket
548 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
549 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
550 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
551 my $err = "unix connect: $!";
554 my $proto = getprotobyname('tcp');
555 my $iaddr = inet_aton($host) || return "unknown host $host";
556 my $paddr = sockaddr_in($port, $iaddr);
558 socket(*FH, PF_INET, SOCK_STREAM, $proto)
559 || return "inet socket: $!";
560 connect(*FH, $paddr) || return "inet connect: $!";
565 my($oldFH) = select(*FH); $| = 1; select($oldFH);
566 $bpc->{ServerFD} = *FH;
567 return if ( $justConnect );
569 # Read the seed that we need for our MD5 message digest. See
572 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
573 $bpc->{ServerMesgCnt} = 0;
578 # Check that the server connection is still ok
584 return 0 if ( !defined($bpc->{ServerFD}) );
585 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
587 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
588 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
592 # Disconnect from the server
597 return if ( !defined($bpc->{ServerFD}) );
598 close($bpc->{ServerFD});
599 delete($bpc->{ServerFD});
603 # Sends a message to the server and returns with the reply.
605 # To avoid possible attacks via the TCP socket interface, every client
606 # message is protected by an MD5 digest. The MD5 digest includes four
608 # - a seed that is sent to us when we first connect
609 # - a sequence number that increments for each message
610 # - a shared secret that is stored in $Conf{ServerMesgSecret}
611 # - the message itself.
612 # The message is sent in plain text preceded by the MD5 digest. A
613 # snooper can see the plain-text seed sent by BackupPC and plain-text
614 # message, but cannot construct a valid MD5 digest since the secret in
615 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
616 # since the seed changes on a per-connection and per-message basis.
620 my($bpc, $mesg) = @_;
621 return if ( !defined(my $fh = $bpc->{ServerFD}) );
622 my $md5 = Digest::MD5->new;
623 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
624 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
625 print($fh $md5->b64digest . " $mesg\n");
626 $bpc->{ServerMesgCnt}++;
631 # Do initialization for child processes
637 open(STDERR, ">&STDOUT");
638 select(STDERR); $| = 1;
639 select(STDOUT); $| = 1;
640 $ENV{PATH} = $bpc->{Conf}{MyPath};
644 # Compute the MD5 digest of a file. For efficiency we don't
645 # use the whole file for big files:
646 # - for files <= 256K we use the file size and the whole file.
647 # - for files <= 1M we use the file size, the first 128K and
649 # - for files > 1M, we use the file size, the first 128K and
650 # the 8th 128K (ie: the 128K up to 1MB).
651 # See the documentation for a discussion of the tradeoffs in
652 # how much data we use and how many collisions we get.
654 # Returns the MD5 digest (a hex string) and the file size.
658 my($bpc, $md5, $name) = @_;
659 my($data, $fileSize);
662 $fileSize = (stat($name))[7];
663 return ("", -1) if ( !-f _ );
664 $name = $1 if ( $name =~ /(.*)/ );
665 return ("", 0) if ( $fileSize == 0 );
666 return ("", -1) if ( !open(N, $name) );
669 $md5->add($fileSize);
670 if ( $fileSize > 262144 ) {
672 # read the first and last 131072 bytes of the file,
675 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
676 $md5->add($data) if ( sysread(N, $data, 131072) );
677 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
678 && sysread(N, $data, 131072) );
681 # read the whole file
683 $md5->add($data) if ( sysread(N, $data, $fileSize) );
686 return ($md5->hexdigest, $fileSize);
690 # Compute the MD5 digest of a buffer (string). For efficiency we don't
691 # use the whole string for big strings:
692 # - for files <= 256K we use the file size and the whole file.
693 # - for files <= 1M we use the file size, the first 128K and
695 # - for files > 1M, we use the file size, the first 128K and
696 # the 8th 128K (ie: the 128K up to 1MB).
697 # See the documentation for a discussion of the tradeoffs in
698 # how much data we use and how many collisions we get.
700 # Returns the MD5 digest (a hex string).
704 my($bpc, $md5, $fileSize, $dataRef) = @_;
707 $md5->add($fileSize);
708 if ( $fileSize > 262144 ) {
710 # add the first and last 131072 bytes of the string,
713 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
714 $md5->add(substr($$dataRef, 0, 131072));
715 $md5->add(substr($$dataRef, $seekPosn, 131072));
718 # add the whole string
720 $md5->add($$dataRef);
722 return $md5->hexdigest;
726 # Given an MD5 digest $d and a compress flag, return the full
731 my($bpc, $d, $compress, $poolDir) = @_;
733 return if ( $d !~ m{(.)(.)(.)(.*)} );
734 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
735 if ( !defined($poolDir) );
736 return "$poolDir/$1/$2/$3/$1$2$3$4";
740 # For each file, check if the file exists in $bpc->{TopDir}/pool.
741 # If so, remove the file and make a hardlink to the file in
742 # the pool. Otherwise, if the newFile flag is set, make a
743 # hardlink in the pool to the new file.
745 # Returns 0 if a link should be made to a new file (ie: when the file
746 # is a new file but the newFile flag is 0).
747 # Returns 1 if a link to an existing file is made,
748 # Returns 2 if a link to a new file is made (only if $newFile is set)
749 # Returns negative on error.
753 my($bpc, $name, $d, $newFile, $compress) = @_;
756 return -1 if ( !-f $name );
757 for ( $i = -1 ; ; $i++ ) {
758 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
759 $rawFile .= "_$i" if ( $i >= 0 );
761 if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}
762 && !compare($name, $rawFile) ) {
764 return -3 if ( !link($rawFile, $name) );
767 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
769 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
770 mkpath($newDir, 0, 0777) if ( !-d $newDir );
771 return -4 if ( !link($name, $rawFile) );
781 my($bpc, $host) = @_;
782 my($s, $pingCmd, $ret);
785 # Return success if the ping cmd is undefined or empty.
787 if ( $bpc->{Conf}{PingCmd} eq "" ) {
788 print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"
789 . " is empty\n") if ( $bpc->{verbose} );
794 pingPath => $bpc->{Conf}{PingPath},
797 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
800 # Do a first ping in case the PC needs to wakeup
802 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
804 print(STDERR "CheckHostAlive: first ping failed ($?, $!)\n")
805 if ( $bpc->{verbose} );
810 # Do a second ping and get the round-trip time in msec
812 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
814 print(STDERR "CheckHostAlive: second ping failed ($?, $!)\n")
815 if ( $bpc->{verbose} );
818 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
820 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
823 print(STDERR "CheckHostAlive: can't extract round-trip time"
824 . " (not fatal)\n") if ( $bpc->{verbose} );
827 print(STDERR "CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
831 sub CheckFileSystemUsage
834 my($topDir) = $bpc->{TopDir};
837 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
839 dfPath => $bpc->{Conf}{DfPath},
840 topDir => $bpc->{TopDir},
842 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
843 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
844 return 0 if ( $? || $s !~ /(\d+)%/s );
849 # Given an IP address, return the host name and user name via
854 my($bpc, $host) = @_;
855 my($netBiosHostName, $netBiosUserName);
859 # Skip NetBios check if NmbLookupCmd is emtpy
861 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
862 print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
863 . " is empty\n") if ( $bpc->{verbose} );
864 return ($host, undef);
868 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
871 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
872 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
873 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
874 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
875 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
877 if ( !defined($netBiosHostName) ) {
878 print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
879 if ( $bpc->{verbose} );
882 $netBiosHostName = lc($netBiosHostName);
883 $netBiosUserName = lc($netBiosUserName);
884 print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"
885 . " user $netBiosUserName\n") if ( $bpc->{verbose} );
886 return ($netBiosHostName, $netBiosUserName);
890 # Given a NetBios name lookup the IP address via NetBios.
891 # In the case of a host returning multiple interfaces we
892 # return the first IP address that matches the subnet mask.
893 # If none match the subnet mask (or nmblookup doesn't print
894 # the subnet mask) then just the first IP address is returned.
896 sub NetBiosHostIPFind
898 my($bpc, $host) = @_;
899 my($netBiosHostName, $netBiosUserName);
900 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
903 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
905 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
906 print(STDERR "NetBiosHostIPFind: return $host because"
907 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
908 if ( $bpc->{verbose} );
913 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
916 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
917 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
919 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
921 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
922 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
924 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
925 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
928 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
929 if ( defined($ipAddr) ) {
930 print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"
931 . " host $host\n") if ( $bpc->{verbose} );
934 print(STDERR "NetBiosHostIPFind: couldn't find IP address for"
935 . " host $host\n") if ( $bpc->{verbose} );
940 sub fileNameEltMangle
942 my($bpc, $name) = @_;
944 return "" if ( $name eq "" );
945 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
950 # We store files with every name preceded by "f". This
951 # avoids possible name conflicts with other information
952 # we store in the same directories (eg: attribute info).
953 # The process of turning a normal path into one with each
954 # node prefixed with "f" is called mangling.
958 my($bpc, $name) = @_;
960 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
961 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
966 # This undoes FileNameMangle
970 my($bpc, $name) = @_;
974 $name =~ s{%(..)}{chr(hex($1))}eg;
979 # Escape shell meta-characters with backslashes.
980 # This should be applied to each argument seperately, not an
981 # entire shell command.
987 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
992 # For printing exec commands (which don't use a shell) so they look like
993 # a valid shell command this function should be called with the exec
994 # args. The shell command string is returned.
998 my($bpc, @args) = @_;
1001 foreach my $a ( @args ) {
1002 $str .= " " if ( $str ne "" );
1003 $str .= $bpc->shellEscape($a);
1009 # Do a URI-style escape to protect/encode special characters
1014 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
1019 # Do a URI-style unescape to restore special characters
1024 $s =~ s{%(..)}{chr(hex($1))}eg;
1029 # Do variable substitution prior to execution of a command.
1031 sub cmdVarSubstitute
1033 my($bpc, $template, $vars) = @_;
1037 # Return without any substitution if the first entry starts with "&",
1038 # indicating this is perl code.
1040 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
1043 if ( ref($template) ne "ARRAY" ) {
1045 # Split at white space, except if escaped by \
1047 $template = [split(/(?<!\\)\s+/, $template)];
1049 # Remove the \ that escaped white space.
1051 foreach ( @$template ) {
1056 # Merge variables into @tarClientCmd
1058 foreach my $arg ( @$template ) {
1060 # Replace scalar variables first
1062 $arg =~ s{\$(\w+)(\+?)}{
1063 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
1064 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
1068 # Now replicate any array arguments; this just works for just one
1069 # array var in each argument.
1071 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1076 foreach my $v ( @{$vars->{$var}} ) {
1077 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1078 push(@cmd, "$pre$v$post");
1088 # Exec or eval a command. $cmd is either a string on an array ref.
1090 # @args are optional arguments for the eval() case; they are not used
1095 my($bpc, $cmd, @args) = @_;
1097 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1098 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1099 print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
1100 if ( $bpc->{verbose} );
1102 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1105 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1106 print(STDERR "cmdExecOrEval: about to exec ",
1107 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1108 if ( $bpc->{verbose} );
1110 $cmd = [map { m/(.*)/ } @$cmd]; # untaint
1112 # force list-form of exec(), ie: no shell even for 1 arg
1114 exec { $cmd->[0] } @$cmd;
1115 print(STDERR "Exec failed for @$cmd\n");
1121 # System or eval a command. $cmd is either a string on an array ref.
1122 # $stdoutCB is a callback for output generated by the command. If it
1123 # is undef then output is returned. If it is a code ref then the function
1124 # is called with each piece of output as an argument. If it is a scalar
1125 # ref the output is appended to this variable.
1127 # @args are optional arguments for the eval() case; they are not used
1130 # Also, $? should be set when the CHILD pipe is closed.
1134 my($bpc, $cmd, $stdoutCB, @args) = @_;
1135 my($pid, $out, $allOut);
1138 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1139 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1140 print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")
1141 if ( $bpc->{verbose} );
1143 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1144 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1145 print(STDERR "cmdSystemOrEval: finished: got output $out\n")
1146 if ( $bpc->{verbose} );
1147 return $out if ( !defined($stdoutCB) );
1150 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1151 print(STDERR "cmdSystemOrEval: about to system ",
1152 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1153 if ( $bpc->{verbose} );
1154 if ( !defined($pid = open(CHILD, "-|")) ) {
1155 my $err = "Can't fork to run @$cmd\n";
1157 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1158 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1159 return $err if ( !defined($stdoutCB) );
1168 open(STDERR, ">&STDOUT");
1170 $cmd = [map { m/(.*)/ } @$cmd]; # untaint
1172 # force list-form of exec(), ie: no shell even for 1 arg
1174 exec { $cmd->[0] } @$cmd;
1175 print(STDERR "Exec of @$cmd failed\n");
1179 # The parent gathers the output from the child
1182 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1183 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1184 $out .= $_ if ( !defined($stdoutCB) );
1185 $allOut .= $_ if ( $bpc->{verbose} );
1190 print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
1191 if ( $bpc->{verbose} );