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 3 Feb 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, $param) = @_;
133 return $bpc->{Conf}{$param};
138 my($bpc, $t, $noPad) = @_;
139 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
140 = localtime($t || time);
143 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
144 . ($noPad ? "" : " ");
148 # An ISO 8601-compliant version of timeStamp. Needed by the
149 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
150 # Also see http://www.w3.org/TR/NOTE-datetime.
154 my($bpc, $t, $noPad) = @_;
155 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
156 = localtime($t || time);
159 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
160 . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
161 . ($noPad ? "" : " ");
166 my($bpc, $host) = @_;
167 local(*BK_INFO, *LOCK);
170 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
171 if ( open(BK_INFO, "$bpc->{TopDir}/pc/$host/backups") ) {
172 while ( <BK_INFO> ) {
174 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
176 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
186 my($bpc, $host, @Backups) = @_;
187 local(*BK_INFO, *LOCK);
190 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
191 unlink("$bpc->{TopDir}/pc/$host/backups.old")
192 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
193 rename("$bpc->{TopDir}/pc/$host/backups",
194 "$bpc->{TopDir}/pc/$host/backups.old")
195 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
196 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
197 for ( $i = 0 ; $i < @Backups ; $i++ ) {
198 my %b = %{$Backups[$i]};
199 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
208 my($bpc, $host) = @_;
209 local(*RESTORE_INFO, *LOCK);
212 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
213 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
214 while ( <RESTORE_INFO> ) {
216 next if ( !/^(\d+.*)/ );
218 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
228 my($bpc, $host, @Restores) = @_;
229 local(*RESTORE_INFO, *LOCK);
232 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
233 unlink("$bpc->{TopDir}/pc/$host/restores.old")
234 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
235 rename("$bpc->{TopDir}/pc/$host/restores",
236 "$bpc->{TopDir}/pc/$host/restores.old")
237 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
238 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
239 for ( $i = 0 ; $i < @Restores ; $i++ ) {
240 my %b = %{$Restores[$i]};
241 printf(RESTORE_INFO "%s\n",
242 join("\t", @b{@{$bpc->{RestoreFields}}}));
251 my($bpc, $host) = @_;
252 my($ret, $mesg, $config, @configs);
255 push(@configs, "$bpc->{TopDir}/conf/config.pl");
256 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
257 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
258 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
259 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
260 foreach $config ( @configs ) {
262 if ( !defined($ret = do $config) && ($! || $@) ) {
263 $mesg = "Couldn't open $config: $!" if ( $! );
264 $mesg = "Couldn't execute $config: $@" if ( $@ );
265 $mesg =~ s/[\n\r]+//;
268 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
270 return if ( !defined($bpc->{Conf}{Language}) );
271 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
273 # Load any user-specified perl modules. This is for
274 # optional user-defined extensions.
276 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
277 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
278 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
279 eval("use $module;");
282 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
283 if ( !defined($ret = do $langFile) && ($! || $@) ) {
284 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
285 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
286 $mesg =~ s/[\n\r]+//;
289 $bpc->{Lang} = \%Lang;
294 # Return the mtime of the config file
299 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
303 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
304 # With no argument a ref to a hash of hosts is returned. Each
305 # hash contains fields as specified in the hosts file. With an
306 # argument a ref to a single hash is returned with information
307 # for just that host.
311 my($bpc, $host) = @_;
312 my(%hosts, @hdr, @fld);
315 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
316 print(STDERR $bpc->timeStamp,
317 "Can't open $bpc->{TopDir}/conf/hosts\n");
320 while ( <HOST_INFO> ) {
324 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
326 # Split on white space, except if preceded by \
327 # using zero-width negative look-behind assertion
328 # (always wanted to use one of those).
330 @fld = split(/(?<!\\)\s+/, $1);
338 if ( defined($host) ) {
339 next if ( lc($fld[0]) ne $host );
340 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
344 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
355 # Return the mtime of the hosts file
360 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
364 # Stripped down from File::Path. In particular we don't print
365 # many warnings and we try three times to delete each directory
366 # and file -- for some reason the original File::Path rmtree
367 # didn't always completely remove a directory tree on the NetApp.
369 # Warning: this routine changes the cwd.
373 my($bpc, $pwd, $roots) = @_;
376 if ( defined($roots) && length($roots) ) {
377 $roots = [$roots] unless ref $roots;
379 print "RmTreeQuiet: No root path(s) specified\n";
382 foreach $root (@{$roots}) {
383 $root = $1 if ( $root =~ m{(.*?)/*$} );
385 # Try first to simply unlink the file: this avoids an
386 # extra stat for every file. If it fails (which it
387 # will for directories), check if it is a directory and
390 if ( !unlink($root) ) {
392 my $d = DirHandle->new($root)
393 or print "Can't read $pwd/$root: $!";
396 @files = grep $_!~/^\.{1,2}$/, @files;
397 $bpc->RmTreeQuiet("$pwd/$root", \@files);
399 rmdir($root) || rmdir($root);
401 unlink($root) || unlink($root);
408 # Move a directory or file away for later deletion
412 my($bpc, $trashDir, $file) = @_;
415 return if ( !-e $file );
416 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
417 for ( $i = 0 ; $i < 1000 ; $i++ ) {
418 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
420 return if ( rename($file, $f) );
422 # shouldn't get here, but might if you tried to call this
423 # across file systems.... just remove the tree right now.
424 if ( $file =~ /(.*)\/([^\/]*)/ ) {
427 my($cwd) = Cwd::fastcwd();
428 $cwd = $1 if ( $cwd =~ /(.*)/ );
429 $bpc->RmTreeQuiet($d, $f);
430 chdir($cwd) if ( $cwd );
435 # Empty the trash directory. Returns 0 if it did nothing.
439 my($bpc, $trashDir) = @_;
441 my($cwd) = Cwd::fastcwd();
443 $cwd = $1 if ( $cwd =~ /(.*)/ );
444 return if ( !-d $trashDir );
445 my $d = DirHandle->new($trashDir)
446 or carp "Can't read $trashDir: $!";
449 @files = grep $_!~/^\.{1,2}$/, @files;
450 return 0 if ( !@files );
451 $bpc->RmTreeQuiet($trashDir, \@files);
452 chdir($cwd) if ( $cwd );
457 # Open a connection to the server. Returns an error string on failure.
458 # Returns undef on success.
462 my($bpc, $host, $port, $justConnect) = @_;
465 return if ( defined($bpc->{ServerFD}) );
467 # First try the unix-domain socket
469 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
470 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
471 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
472 my $err = "unix connect: $!";
475 my $proto = getprotobyname('tcp');
476 my $iaddr = inet_aton($host) || return "unknown host $host";
477 my $paddr = sockaddr_in($port, $iaddr);
479 socket(*FH, PF_INET, SOCK_STREAM, $proto)
480 || return "inet socket: $!";
481 connect(*FH, $paddr) || return "inet connect: $!";
486 my($oldFH) = select(*FH); $| = 1; select($oldFH);
487 $bpc->{ServerFD} = *FH;
488 return if ( $justConnect );
490 # Read the seed that we need for our MD5 message digest. See
493 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
494 $bpc->{ServerMesgCnt} = 0;
499 # Check that the server connection is still ok
505 return 0 if ( !defined($bpc->{ServerFD}) );
506 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
508 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
509 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
513 # Disconnect from the server
518 return if ( !defined($bpc->{ServerFD}) );
519 close($bpc->{ServerFD});
520 delete($bpc->{ServerFD});
524 # Sends a message to the server and returns with the reply.
526 # To avoid possible attacks via the TCP socket interface, every client
527 # message is protected by an MD5 digest. The MD5 digest includes four
529 # - a seed that is sent to us when we first connect
530 # - a sequence number that increments for each message
531 # - a shared secret that is stored in $Conf{ServerMesgSecret}
532 # - the message itself.
533 # The message is sent in plain text preceded by the MD5 digest. A
534 # snooper can see the plain-text seed sent by BackupPC and plain-text
535 # message, but cannot construct a valid MD5 digest since the secret in
536 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
537 # since the seed changes on a per-connection and per-message basis.
541 my($bpc, $mesg) = @_;
542 return if ( !defined(my $fh = $bpc->{ServerFD}) );
543 my $md5 = Digest::MD5->new;
544 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
545 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
546 print($fh $md5->b64digest . " $mesg\n");
547 $bpc->{ServerMesgCnt}++;
552 # Do initialization for child processes
558 open(STDERR, ">&STDOUT");
559 select(STDERR); $| = 1;
560 select(STDOUT); $| = 1;
561 $ENV{PATH} = $bpc->{Conf}{MyPath};
565 # Compute the MD5 digest of a file. For efficiency we don't
566 # use the whole file for big files:
567 # - for files <= 256K we use the file size and the whole file.
568 # - for files <= 1M we use the file size, the first 128K and
570 # - for files > 1M, we use the file size, the first 128K and
571 # the 8th 128K (ie: the 128K up to 1MB).
572 # See the documentation for a discussion of the tradeoffs in
573 # how much data we use and how many collisions we get.
575 # Returns the MD5 digest (a hex string) and the file size.
579 my($bpc, $md5, $name) = @_;
580 my($data, $fileSize);
583 $fileSize = (stat($name))[7];
584 return ("", -1) if ( !-f _ );
585 $name = $1 if ( $name =~ /(.*)/ );
586 return ("", 0) if ( $fileSize == 0 );
587 return ("", -1) if ( !open(N, $name) );
589 $md5->add($fileSize);
590 if ( $fileSize > 262144 ) {
592 # read the first and last 131072 bytes of the file,
595 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
596 $md5->add($data) if ( sysread(N, $data, 131072) );
597 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
598 && sysread(N, $data, 131072) );
601 # read the whole file
603 $md5->add($data) if ( sysread(N, $data, $fileSize) );
606 return ($md5->hexdigest, $fileSize);
610 # Compute the MD5 digest of a buffer (string). For efficiency we don't
611 # use the whole string for big strings:
612 # - for files <= 256K we use the file size and the whole file.
613 # - for files <= 1M we use the file size, the first 128K and
615 # - for files > 1M, we use the file size, the first 128K and
616 # the 8th 128K (ie: the 128K up to 1MB).
617 # See the documentation for a discussion of the tradeoffs in
618 # how much data we use and how many collisions we get.
620 # Returns the MD5 digest (a hex string).
624 my($bpc, $md5, $fileSize, $dataRef) = @_;
627 $md5->add($fileSize);
628 if ( $fileSize > 262144 ) {
630 # add the first and last 131072 bytes of the string,
633 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
634 $md5->add(substr($$dataRef, 0, 131072));
635 $md5->add(substr($$dataRef, $seekPosn, 131072));
638 # add the whole string
640 $md5->add($$dataRef);
642 return $md5->hexdigest;
646 # Given an MD5 digest $d and a compress flag, return the full
651 my($bpc, $d, $compress, $poolDir) = @_;
653 return if ( $d !~ m{(.)(.)(.)(.*)} );
654 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
655 if ( !defined($poolDir) );
656 return "$poolDir/$1/$2/$3/$1$2$3$4";
660 # For each file, check if the file exists in $bpc->{TopDir}/pool.
661 # If so, remove the file and make a hardlink to the file in
662 # the pool. Otherwise, if the newFile flag is set, make a
663 # hardlink in the pool to the new file.
665 # Returns 0 if a link should be made to a new file (ie: when the file
666 # is a new file but the newFile flag is 0).
667 # Returns 1 if a link to an existing file is made,
668 # Returns 2 if a link to a new file is made (only if $newFile is set)
669 # Returns negative on error.
673 my($bpc, $name, $d, $newFile, $compress) = @_;
676 return -1 if ( !-f $name );
677 for ( $i = -1 ; ; $i++ ) {
678 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
679 $rawFile .= "_$i" if ( $i >= 0 );
681 if ( !compare($name, $rawFile) ) {
683 return -3 if ( !link($rawFile, $name) );
686 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
688 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
689 mkpath($newDir, 0, 0777) if ( !-d $newDir );
690 return -4 if ( !link($name, $rawFile) );
700 my($bpc, $host) = @_;
704 # Return success if the ping cmd is undefined or empty.
706 return 0 if ( $bpc->{Conf}{PingCmd} eq "" );
709 pingPath => $bpc->{Conf}{PingPath},
712 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
715 # Do a first ping in case the PC needs to wakeup
717 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
721 # Do a second ping and get the round-trip time in msec
723 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
725 return $1 if ( $s =~ /time=([\d\.]+)\s*ms/i );
726 return $1/1000 if ( $s =~ /time=([\d\.]+)\s*usec/i );
730 sub CheckFileSystemUsage
733 my($topDir) = $bpc->{TopDir};
736 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
738 dfPath => $bpc->{Conf}{DfPath},
739 topDir => $bpc->{TopDir},
741 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
742 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
743 return 0 if ( $? || $s !~ /(\d+)%/s );
748 # Given an IP address, return the host name and user name via
753 my($bpc, $host) = @_;
754 my($netBiosHostName, $netBiosUserName);
758 # Skip NetBios check if NmbLookupCmd is emtpy
760 return ($host, undef) if ( $bpc->{Conf}{NmbLookupCmd} eq "" );
763 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
766 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
767 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
768 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
769 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
770 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
772 return if ( !defined($netBiosHostName) );
773 return (lc($netBiosHostName), lc($netBiosUserName));
777 # Given a NetBios name lookup the IP address via NetBios.
779 sub NetBiosHostIPFind
781 my($bpc, $host) = @_;
782 my($netBiosHostName, $netBiosUserName);
786 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
788 return $host if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" );
791 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
794 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
795 my $resp = $bpc->cmdSystemOrEval($nmbCmd, undef, $args);
796 if ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/m ) {
803 sub fileNameEltMangle
805 my($bpc, $name) = @_;
807 return "" if ( $name eq "" );
808 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
813 # We store files with every name preceded by "f". This
814 # avoids possible name conflicts with other information
815 # we store in the same directories (eg: attribute info).
816 # The process of turning a normal path into one with each
817 # node prefixed with "f" is called mangling.
821 my($bpc, $name) = @_;
823 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
824 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
829 # This undoes FileNameMangle
833 my($bpc, $name) = @_;
837 $name =~ s{%(..)}{chr(hex($1))}eg;
842 # Escape shell meta-characters with backslashes.
843 # This should be applied to each argument seperately, not an
844 # entire shell command.
850 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
855 # For printing exec commands (which don't use a shell) so they look like
856 # a valid shell command this function should be called with the exec
857 # args. The shell command string is returned.
861 my($bpc, @args) = @_;
864 foreach my $a ( @args ) {
865 $str .= " " if ( $str ne "" );
866 $str .= $bpc->shellEscape($a);
872 # Do a URI-style escape to protect/encode special characters
877 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
882 # Do a URI-style unescape to restore special characters
887 $s =~ s{%(..)}{chr(hex($1))}eg;
892 # Do variable substitution prior to execution of a command.
896 my($bpc, $template, $vars) = @_;
900 # Return without any substitution if the first entry starts with "&",
901 # indicating this is perl code.
903 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
906 if ( ref($template) ne "ARRAY" ) {
908 # Split at white space, except if escaped by \
910 $template = [split(/(?<!\\)\s+/, $template)];
912 # Remove the \ that escaped white space.
914 foreach ( @$template ) {
919 # Merge variables into @tarClientCmd
921 foreach my $arg ( @$template ) {
923 # Replace scalar variables first
925 $arg =~ s{\$(\w+)(\+?)}{
926 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
927 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
931 # Now replicate any array arguments; this just works for just one
932 # array var in each argument.
934 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
939 foreach my $v ( @{$vars->{$var}} ) {
940 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
941 push(@cmd, "$pre$v$post");
951 # Exec or eval a command. $cmd is either a string on an array ref.
953 # @args are optional arguments for the eval() case; they are not used
958 my($bpc, $cmd, @args) = @_;
960 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
961 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
963 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
966 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
968 print(STDERR "Exec failed for @$cmd\n");
974 # System or eval a command. $cmd is either a string on an array ref.
975 # $stdoutCB is a callback for output generated by the command. If it
976 # is undef then output is returned. If it is a code ref then the function
977 # is called with each piece of output as an argument. If it is a scalar
978 # ref the output is appended to this variable.
980 # @args are optional arguments for the eval() case; they are not used
983 # Also, $? should be set when the CHILD pipe is closed.
987 my($bpc, $cmd, $stdoutCB, @args) = @_;
991 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
992 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
993 my $out = eval($cmd);
994 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
995 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
996 return $out if ( !defined($stdoutCB) );
999 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1000 if ( !defined($pid = open(CHILD, "-|")) ) {
1001 my $err = "Can't fork to run @$cmd\n";
1003 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1004 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1005 return $err if ( !defined($stdoutCB) );
1013 open(STDERR, ">&STDOUT");
1015 print("Exec of @$cmd failed\n");
1019 # The parent gathers the output from the child
1022 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1023 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1024 $out .= $_ if ( !defined($stdoutCB) );