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.0_CVS, released 18 Jan 2003.
34 # See http://backuppc.sourceforge.net.
36 #========================================================================
38 package BackupPC::Lib;
42 use vars qw(%Conf %Lang);
55 my($topDir, $installDir) = @_;
58 TopDir => $topDir || '/data/BackupPC',
59 BinDir => $installDir || '/usr/local/BackupPC',
60 LibDir => $installDir || '/usr/local/BackupPC',
61 Version => '2.0.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");
92 return $bpc->{TopDir};
98 return $bpc->{BinDir};
104 return $bpc->{Version};
110 return %{$bpc->{Conf}};
126 return " trashClean ";
131 my($bpc, $t, $noPad) = @_;
132 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
133 = localtime($t || time);
136 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
137 . ($noPad ? "" : " ");
141 # An ISO 8601-compliant version of timeStamp. Needed by the
142 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
143 # Also see http://www.w3.org/TR/NOTE-datetime.
147 my($bpc, $t, $noPad) = @_;
148 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
149 = localtime($t || time);
152 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
153 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
154 . ($noPad ? "" : " ");
159 my($bpc, $host) = @_;
160 local(*BK_INFO, *LOCK);
163 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
164 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
165 while ( <BK_INFO> ) {
167 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
169 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
179 my($bpc, $host, @Backups) = @_;
180 local(*BK_INFO, *LOCK);
183 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
184 unlink("$bpc->{TopDir}/pc/$host/backups.old")
185 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
186 rename("$bpc->{TopDir}/pc/$host/backups",
187 "$bpc->{TopDir}/pc/$host/backups.old")
188 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
189 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
190 for ( $i = 0 ; $i < @Backups ; $i++ ) {
191 my %b = %{$Backups[$i]};
192 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
201 my($bpc, $host) = @_;
202 local(*RESTORE_INFO, *LOCK);
205 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
206 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
207 while ( <RESTORE_INFO> ) {
209 next if ( !/^(\d+.*)/ );
211 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
221 my($bpc, $host, @Restores) = @_;
222 local(*RESTORE_INFO, *LOCK);
225 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
226 unlink("$bpc->{TopDir}/pc/$host/restores.old")
227 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
228 rename("$bpc->{TopDir}/pc/$host/restores",
229 "$bpc->{TopDir}/pc/$host/restores.old")
230 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
231 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
232 for ( $i = 0 ; $i < @Restores ; $i++ ) {
233 my %b = %{$Restores[$i]};
234 printf(RESTORE_INFO "%s\n",
235 join("\t", @b{@{$bpc->{RestoreFields}}}));
244 my($bpc, $host) = @_;
245 my($ret, $mesg, $config, @configs);
248 push(@configs, "$bpc->{TopDir}/conf/config.pl");
249 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
250 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
251 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
252 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
253 foreach $config ( @configs ) {
255 if ( !defined($ret = do $config) && ($! || $@) ) {
256 $mesg = "Couldn't open $config: $!" if ( $! );
257 $mesg = "Couldn't execute $config: $@" if ( $@ );
258 $mesg =~ s/[\n\r]+//;
261 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
263 return if ( !defined($bpc->{Conf}{Language}) );
264 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
266 # Load any user-specified perl modules. This is for
267 # optional user-defined extensions.
269 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
270 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
271 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
272 eval("use $module;");
275 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
276 if ( !defined($ret = do $langFile) && ($! || $@) ) {
277 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
278 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
279 $mesg =~ s/[\n\r]+//;
282 $bpc->{Lang} = \%Lang;
287 # Return the mtime of the config file
292 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
296 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
297 # With no argument a ref to a hash of hosts is returned. Each
298 # hash contains fields as specified in the hosts file. With an
299 # argument a ref to a single hash is returned with information
300 # for just that host.
304 my($bpc, $host) = @_;
305 my(%hosts, @hdr, @fld);
308 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
309 print(STDERR $bpc->timeStamp,
310 "Can't open $bpc->{TopDir}/conf/hosts\n");
313 while ( <HOST_INFO> ) {
317 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
319 # Split on white space, except if preceded by \
320 # using zero-width negative look-behind assertion
321 # (always wanted to use one of those).
323 @fld = split(/(?<!\\)\s+/, $1);
331 if ( defined($host) ) {
332 next if ( lc($fld[0]) ne $host );
333 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
337 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
348 # Return the mtime of the hosts file
353 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
357 # Stripped down from File::Path. In particular we don't print
358 # many warnings and we try three times to delete each directory
359 # and file -- for some reason the original File::Path rmtree
360 # didn't always completely remove a directory tree on the NetApp.
362 # Warning: this routine changes the cwd.
366 my($bpc, $pwd, $roots) = @_;
369 if ( defined($roots) && length($roots) ) {
370 $roots = [$roots] unless ref $roots;
372 print "RmTreeQuiet: No root path(s) specified\n";
375 foreach $root (@{$roots}) {
376 $root = $1 if ( $root =~ m{(.*?)/*$} );
378 # Try first to simply unlink the file: this avoids an
379 # extra stat for every file. If it fails (which it
380 # will for directories), check if it is a directory and
383 if ( !unlink($root) ) {
385 my $d = DirHandle->new($root)
386 or print "Can't read $pwd/$root: $!";
389 @files = grep $_!~/^\.{1,2}$/, @files;
390 $bpc->RmTreeQuiet("$pwd/$root", \@files);
392 rmdir($root) || rmdir($root);
394 unlink($root) || unlink($root);
401 # Move a directory or file away for later deletion
405 my($bpc, $trashDir, $file) = @_;
408 return if ( !-e $file );
409 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
410 for ( $i = 0 ; $i < 1000 ; $i++ ) {
411 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
413 return if ( rename($file, $f) );
415 # shouldn't get here, but might if you tried to call this
416 # across file systems.... just remove the tree right now.
417 if ( $file =~ /(.*)\/([^\/]*)/ ) {
420 my($cwd) = Cwd::fastcwd();
421 $cwd = $1 if ( $cwd =~ /(.*)/ );
422 $bpc->RmTreeQuiet($d, $f);
423 chdir($cwd) if ( $cwd );
428 # Empty the trash directory. Returns 0 if it did nothing.
432 my($bpc, $trashDir) = @_;
434 my($cwd) = Cwd::fastcwd();
436 $cwd = $1 if ( $cwd =~ /(.*)/ );
437 return if ( !-d $trashDir );
438 my $d = DirHandle->new($trashDir)
439 or carp "Can't read $trashDir: $!";
442 @files = grep $_!~/^\.{1,2}$/, @files;
443 return 0 if ( !@files );
444 $bpc->RmTreeQuiet($trashDir, \@files);
445 chdir($cwd) if ( $cwd );
450 # Open a connection to the server. Returns an error string on failure.
451 # Returns undef on success.
455 my($bpc, $host, $port, $justConnect) = @_;
458 return if ( defined($bpc->{ServerFD}) );
460 # First try the unix-domain socket
462 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
463 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
464 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
465 my $err = "unix connect: $!";
468 my $proto = getprotobyname('tcp');
469 my $iaddr = inet_aton($host) || return "unknown host $host";
470 my $paddr = sockaddr_in($port, $iaddr);
472 socket(*FH, PF_INET, SOCK_STREAM, $proto)
473 || return "inet socket: $!";
474 connect(*FH, $paddr) || return "inet connect: $!";
479 my($oldFH) = select(*FH); $| = 1; select($oldFH);
480 $bpc->{ServerFD} = *FH;
481 return if ( $justConnect );
483 # Read the seed that we need for our MD5 message digest. See
486 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
487 $bpc->{ServerMesgCnt} = 0;
492 # Check that the server connection is still ok
498 return 0 if ( !defined($bpc->{ServerFD}) );
499 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
501 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
502 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
506 # Disconnect from the server
511 return if ( !defined($bpc->{ServerFD}) );
512 close($bpc->{ServerFD});
513 delete($bpc->{ServerFD});
517 # Sends a message to the server and returns with the reply.
519 # To avoid possible attacks via the TCP socket interface, every client
520 # message is protected by an MD5 digest. The MD5 digest includes four
522 # - a seed that is sent to us when we first connect
523 # - a sequence number that increments for each message
524 # - a shared secret that is stored in $Conf{ServerMesgSecret}
525 # - the message itself.
526 # The message is sent in plain text preceded by the MD5 digest. A
527 # snooper can see the plain-text seed sent by BackupPC and plain-text
528 # message, but cannot construct a valid MD5 digest since the secret in
529 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
530 # since the seed changes on a per-connection and per-message basis.
534 my($bpc, $mesg) = @_;
535 return if ( !defined(my $fh = $bpc->{ServerFD}) );
536 my $md5 = Digest::MD5->new;
537 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
538 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
539 print($fh $md5->b64digest . " $mesg\n");
540 $bpc->{ServerMesgCnt}++;
545 # Do initialization for child processes
551 open(STDERR, ">&STDOUT");
552 select(STDERR); $| = 1;
553 select(STDOUT); $| = 1;
554 $ENV{PATH} = $bpc->{Conf}{MyPath};
558 # Compute the MD5 digest of a file. For efficiency we don't
559 # use the whole file for big files:
560 # - for files <= 256K we use the file size and the whole file.
561 # - for files <= 1M we use the file size, the first 128K and
563 # - for files > 1M, we use the file size, the first 128K and
564 # the 8th 128K (ie: the 128K up to 1MB).
565 # See the documentation for a discussion of the tradeoffs in
566 # how much data we use and how many collisions we get.
568 # Returns the MD5 digest (a hex string) and the file size.
572 my($bpc, $md5, $name) = @_;
573 my($data, $fileSize);
576 $fileSize = (stat($name))[7];
577 return ("", -1) if ( !-f _ );
578 $name = $1 if ( $name =~ /(.*)/ );
579 return ("", 0) if ( $fileSize == 0 );
580 return ("", -1) if ( !open(N, $name) );
582 $md5->add($fileSize);
583 if ( $fileSize > 262144 ) {
585 # read the first and last 131072 bytes of the file,
588 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
589 $md5->add($data) if ( sysread(N, $data, 131072) );
590 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
591 && sysread(N, $data, 131072) );
594 # read the whole file
596 $md5->add($data) if ( sysread(N, $data, $fileSize) );
599 return ($md5->hexdigest, $fileSize);
603 # Compute the MD5 digest of a buffer (string). For efficiency we don't
604 # use the whole string for big strings:
605 # - for files <= 256K we use the file size and the whole file.
606 # - for files <= 1M we use the file size, the first 128K and
608 # - for files > 1M, we use the file size, the first 128K and
609 # the 8th 128K (ie: the 128K up to 1MB).
610 # See the documentation for a discussion of the tradeoffs in
611 # how much data we use and how many collisions we get.
613 # Returns the MD5 digest (a hex string).
617 my($bpc, $md5, $fileSize, $dataRef) = @_;
620 $md5->add($fileSize);
621 if ( $fileSize > 262144 ) {
623 # add the first and last 131072 bytes of the string,
626 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
627 $md5->add(substr($$dataRef, 0, 131072));
628 $md5->add(substr($$dataRef, $seekPosn, 131072));
631 # add the whole string
633 $md5->add($$dataRef);
635 return $md5->hexdigest;
639 # Given an MD5 digest $d and a compress flag, return the full
644 my($bpc, $d, $compress, $poolDir) = @_;
646 return if ( $d !~ m{(.)(.)(.)(.*)} );
647 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
648 if ( !defined($poolDir) );
649 return "$poolDir/$1/$2/$3/$1$2$3$4";
653 # For each file, check if the file exists in $bpc->{TopDir}/pool.
654 # If so, remove the file and make a hardlink to the file in
655 # the pool. Otherwise, if the newFile flag is set, make a
656 # hardlink in the pool to the new file.
658 # Returns 0 if a link should be made to a new file (ie: when the file
659 # is a new file but the newFile flag is 0).
660 # Returns 1 if a link to an existing file is made,
661 # Returns 2 if a link to a new file is made (only if $newFile is set)
662 # Returns negative on error.
666 my($bpc, $name, $d, $newFile, $compress) = @_;
669 return -1 if ( !-f $name );
670 for ( $i = -1 ; ; $i++ ) {
671 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
672 $rawFile .= "_$i" if ( $i >= 0 );
674 if ( !compare($name, $rawFile) ) {
676 return -3 if ( !link($rawFile, $name) );
679 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
681 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
682 mkpath($newDir, 0, 0777) if ( !-d $newDir );
683 return -4 if ( !link($name, $rawFile) );
693 my($bpc, $host) = @_;
697 pingPath => $bpc->{Conf}{PingPath},
700 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
703 # Do a first ping in case the PC needs to wakeup
705 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
709 # Do a second ping and get the round-trip time in msec
711 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
713 return $1 if ( $s =~ /time=([\d\.]+)\s*ms/i );
714 return $1/1000 if ( $s =~ /time=([\d\.]+)\s*usec/i );
718 sub CheckFileSystemUsage
721 my($topDir) = $bpc->{TopDir};
725 dfPath => $bpc->{Conf}{DfPath},
726 topDir => $bpc->{TopDir},
728 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
729 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
730 return 0 if ( $? || $s !~ /(\d+)%/s );
735 # Given an IP address, return the host name and user name via
740 my($bpc, $host) = @_;
741 my($netBiosHostName, $netBiosUserName);
745 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
748 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
749 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
750 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
751 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
752 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
754 return if ( !defined($netBiosHostName) );
755 return (lc($netBiosHostName), lc($netBiosUserName));
759 # Given a NetBios name lookup the IP address via NetBios.
761 sub NetBiosHostIPFind
763 my($bpc, $host) = @_;
764 my($netBiosHostName, $netBiosUserName);
768 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
771 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
772 my $resp = $bpc->cmdSystemOrEval($nmbCmd, undef, $args);
773 if ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/m ) {
780 sub fileNameEltMangle
782 my($bpc, $name) = @_;
784 return "" if ( $name eq "" );
785 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
790 # We store files with every name preceded by "f". This
791 # avoids possible name conflicts with other information
792 # we store in the same directories (eg: attribute info).
793 # The process of turning a normal path into one with each
794 # node prefixed with "f" is called mangling.
798 my($bpc, $name) = @_;
800 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
801 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
806 # This undoes FileNameMangle
810 my($bpc, $name) = @_;
814 $name =~ s{%(..)}{chr(hex($1))}eg;
819 # Escape shell meta-characters with backslashes.
820 # This should be applied to each argument seperately, not an
821 # entire shell command.
827 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
832 # For printing exec commands (which don't use a shell) so they look like
833 # a valid shell command this function should be called with the exec
834 # args. The shell command string is returned.
838 my($bpc, @args) = @_;
841 foreach my $a ( @args ) {
842 $str .= " " if ( $str ne "" );
843 $str .= $bpc->shellEscape($a);
849 # Do a URI-style escape to protect/encode special characters
854 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
859 # Do a URI-style unescape to restore special characters
864 $s =~ s{%(..)}{chr(hex($1))}eg;
869 # Do variable substitution prior to execution of a command.
873 my($bpc, $template, $vars) = @_;
877 # Return without any substitution if the first entry starts with "&",
878 # indicating this is perl code.
880 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
883 if ( ref($template) ne "ARRAY" ) {
885 # Split at white space, except if escaped by \
887 $template = [split(/(?<!\\)\s+/, $template)];
889 # Remove the \ that escaped white space.
891 foreach ( @$template ) {
896 # Merge variables into @tarClientCmd
898 foreach my $arg ( @$template ) {
900 # Replace scalar variables first
902 $arg =~ s{\$(\w+)(\+?)}{
903 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
904 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
908 # Now replicate any array arguments; this just works for just one
909 # array var in each argument.
911 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
916 foreach my $v ( @{$vars->{$var}} ) {
917 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
918 push(@cmd, "$pre$v$post");
928 # Exec or eval a command. $cmd is either a string on an array ref.
930 # @args are optional arguments for the eval() case; they are not used
935 my($bpc, $cmd, @args) = @_;
937 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
938 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
941 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
947 # System or eval a command. $cmd is either a string on an array ref.
948 # $stdoutCB is a callback for output generated by the command. If it
949 # is undef then output is returned. If it is a code ref then the function
950 # is called with each piece of output as an argument. If it is a scalar
951 # ref the output is appended to this variable.
953 # @args are optional arguments for the eval() case; they are not used
956 # Also, $? should be set when the CHILD pipe is closed.
960 my($bpc, $cmd, $stdoutCB, @args) = @_;
964 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
965 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
966 my $out = eval($cmd);
967 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
968 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
969 return $out if ( !defined($stdoutCB) );
972 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
973 if ( !defined($pid = open(CHILD, "-|")) ) {
974 my $err = "Can't fork to run @$cmd\n";
976 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
977 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
978 return $err if ( !defined($stdoutCB) );
986 open(STDERR, ">&STDOUT");
988 print("Exec of @$cmd failed\n");
992 # The parent gathers the output from the child
995 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
996 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
997 $out .= $_ if ( !defined($stdoutCB) );