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.0beta1, released 30 Mar 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.0beta1',
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, $param) = @_;
140 $bpc->{verbose} = $param if ( defined($param) );
141 return $bpc->{verbose};
146 my($bpc, $t, $noPad) = @_;
147 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
148 = localtime($t || time);
151 return "$year/$mon/$mday " . sprintf("%02d:%02d:%02d", $hour, $min, $sec)
152 . ($noPad ? "" : " ");
156 # An ISO 8601-compliant version of timeStamp. Needed by the
157 # --newer-mtime argument to GNU tar in BackupPC::Xfer::Tar.
158 # Also see http://www.w3.org/TR/NOTE-datetime.
162 my($bpc, $t, $noPad) = @_;
163 my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
164 = localtime($t || time);
167 return sprintf("%04d-%02d-%02d ", $year, $mon, $mday)
168 . sprintf("%02d:%02d:%02d", $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") ) {
180 while ( <BK_INFO> ) {
182 next if ( !/^(\d+\t(incr|full)[\d\t]*$)/ );
184 @{$Backups[@Backups]}{@{$bpc->{BackupFields}}} = split(/\t/);
194 my($bpc, $host, @Backups) = @_;
195 local(*BK_INFO, *LOCK);
198 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
199 unlink("$bpc->{TopDir}/pc/$host/backups.old")
200 if ( -f "$bpc->{TopDir}/pc/$host/backups.old" );
201 rename("$bpc->{TopDir}/pc/$host/backups",
202 "$bpc->{TopDir}/pc/$host/backups.old")
203 if ( -f "$bpc->{TopDir}/pc/$host/backups" );
204 if ( open(BK_INFO, ">$bpc->{TopDir}/pc/$host/backups") ) {
205 for ( $i = 0 ; $i < @Backups ; $i++ ) {
206 my %b = %{$Backups[$i]};
207 printf(BK_INFO "%s\n", join("\t", @b{@{$bpc->{BackupFields}}}));
216 my($bpc, $host) = @_;
217 local(*RESTORE_INFO, *LOCK);
220 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
221 if ( open(RESTORE_INFO, "$bpc->{TopDir}/pc/$host/restores") ) {
222 while ( <RESTORE_INFO> ) {
224 next if ( !/^(\d+.*)/ );
226 @{$Restores[@Restores]}{@{$bpc->{RestoreFields}}} = split(/\t/);
236 my($bpc, $host, @Restores) = @_;
237 local(*RESTORE_INFO, *LOCK);
240 flock(LOCK, LOCK_EX) if open(LOCK, "$bpc->{TopDir}/pc/$host/LOCK");
241 unlink("$bpc->{TopDir}/pc/$host/restores.old")
242 if ( -f "$bpc->{TopDir}/pc/$host/restores.old" );
243 rename("$bpc->{TopDir}/pc/$host/restores",
244 "$bpc->{TopDir}/pc/$host/restores.old")
245 if ( -f "$bpc->{TopDir}/pc/$host/restores" );
246 if ( open(RESTORE_INFO, ">$bpc->{TopDir}/pc/$host/restores") ) {
247 for ( $i = 0 ; $i < @Restores ; $i++ ) {
248 my %b = %{$Restores[$i]};
249 printf(RESTORE_INFO "%s\n",
250 join("\t", @b{@{$bpc->{RestoreFields}}}));
259 my($bpc, $host) = @_;
260 my($ret, $mesg, $config, @configs);
263 push(@configs, "$bpc->{TopDir}/conf/config.pl");
264 push(@configs, "$bpc->{TopDir}/conf/$host.pl")
265 if ( $host ne "config" && -f "$bpc->{TopDir}/conf/$host.pl" );
266 push(@configs, "$bpc->{TopDir}/pc/$host/config.pl")
267 if ( defined($host) && -f "$bpc->{TopDir}/pc/$host/config.pl" );
268 foreach $config ( @configs ) {
270 if ( !defined($ret = do $config) && ($! || $@) ) {
271 $mesg = "Couldn't open $config: $!" if ( $! );
272 $mesg = "Couldn't execute $config: $@" if ( $@ );
273 $mesg =~ s/[\n\r]+//;
276 %{$bpc->{Conf}} = ( %{$bpc->{Conf} || {}}, %Conf );
278 return if ( !defined($bpc->{Conf}{Language}) );
279 if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
281 # Load any user-specified perl modules. This is for
282 # optional user-defined extensions.
284 $bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
285 if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
286 foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
287 eval("use $module;");
290 my $langFile = "$bpc->{LibDir}/BackupPC/Lang/$bpc->{Conf}{Language}.pm";
291 if ( !defined($ret = do $langFile) && ($! || $@) ) {
292 $mesg = "Couldn't open language file $langFile: $!" if ( $! );
293 $mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
294 $mesg =~ s/[\n\r]+//;
297 $bpc->{Lang} = \%Lang;
302 # Return the mtime of the config file
307 return (stat("$bpc->{TopDir}/conf/config.pl"))[9];
311 # Returns information from the host file in $bpc->{TopDir}/conf/hosts.
312 # With no argument a ref to a hash of hosts is returned. Each
313 # hash contains fields as specified in the hosts file. With an
314 # argument a ref to a single hash is returned with information
315 # for just that host.
319 my($bpc, $host) = @_;
320 my(%hosts, @hdr, @fld);
323 if ( !open(HOST_INFO, "$bpc->{TopDir}/conf/hosts") ) {
324 print(STDERR $bpc->timeStamp,
325 "Can't open $bpc->{TopDir}/conf/hosts\n");
328 while ( <HOST_INFO> ) {
332 next if ( /^\s*$/ || !/^([\w\.\\-]+\s+.*)/ );
334 # Split on white space, except if preceded by \
335 # using zero-width negative look-behind assertion
336 # (always wanted to use one of those).
338 @fld = split(/(?<!\\)\s+/, $1);
346 if ( defined($host) ) {
347 next if ( lc($fld[0]) ne $host );
348 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
352 @{$hosts{lc($fld[0])}}{@hdr} = @fld;
363 # Return the mtime of the hosts file
368 return (stat("$bpc->{TopDir}/conf/hosts"))[9];
372 # Stripped down from File::Path. In particular we don't print
373 # many warnings and we try three times to delete each directory
374 # and file -- for some reason the original File::Path rmtree
375 # didn't always completely remove a directory tree on the NetApp.
377 # Warning: this routine changes the cwd.
381 my($bpc, $pwd, $roots) = @_;
384 if ( defined($roots) && length($roots) ) {
385 $roots = [$roots] unless ref $roots;
387 print "RmTreeQuiet: No root path(s) specified\n";
390 foreach $root (@{$roots}) {
391 $root = $1 if ( $root =~ m{(.*?)/*$} );
393 # Try first to simply unlink the file: this avoids an
394 # extra stat for every file. If it fails (which it
395 # will for directories), check if it is a directory and
398 if ( !unlink($root) ) {
400 my $d = DirHandle->new($root)
401 or print "Can't read $pwd/$root: $!";
404 @files = grep $_!~/^\.{1,2}$/, @files;
405 $bpc->RmTreeQuiet("$pwd/$root", \@files);
407 rmdir($root) || rmdir($root);
409 unlink($root) || unlink($root);
416 # Move a directory or file away for later deletion
420 my($bpc, $trashDir, $file) = @_;
423 return if ( !-e $file );
424 mkpath($trashDir, 0, 0777) if ( !-d $trashDir );
425 for ( $i = 0 ; $i < 1000 ; $i++ ) {
426 $f = sprintf("%s/%d_%d_%d", $trashDir, time, $$, $i);
428 return if ( rename($file, $f) );
430 # shouldn't get here, but might if you tried to call this
431 # across file systems.... just remove the tree right now.
432 if ( $file =~ /(.*)\/([^\/]*)/ ) {
435 my($cwd) = Cwd::fastcwd();
436 $cwd = $1 if ( $cwd =~ /(.*)/ );
437 $bpc->RmTreeQuiet($d, $f);
438 chdir($cwd) if ( $cwd );
443 # Empty the trash directory. Returns 0 if it did nothing.
447 my($bpc, $trashDir) = @_;
449 my($cwd) = Cwd::fastcwd();
451 $cwd = $1 if ( $cwd =~ /(.*)/ );
452 return if ( !-d $trashDir );
453 my $d = DirHandle->new($trashDir)
454 or carp "Can't read $trashDir: $!";
457 @files = grep $_!~/^\.{1,2}$/, @files;
458 return 0 if ( !@files );
459 $bpc->RmTreeQuiet($trashDir, \@files);
460 chdir($cwd) if ( $cwd );
465 # Open a connection to the server. Returns an error string on failure.
466 # Returns undef on success.
470 my($bpc, $host, $port, $justConnect) = @_;
473 return if ( defined($bpc->{ServerFD}) );
475 # First try the unix-domain socket
477 my $sockFile = "$bpc->{TopDir}/log/BackupPC.sock";
478 socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
479 if ( !connect(*FH, sockaddr_un($sockFile)) ) {
480 my $err = "unix connect: $!";
483 my $proto = getprotobyname('tcp');
484 my $iaddr = inet_aton($host) || return "unknown host $host";
485 my $paddr = sockaddr_in($port, $iaddr);
487 socket(*FH, PF_INET, SOCK_STREAM, $proto)
488 || return "inet socket: $!";
489 connect(*FH, $paddr) || return "inet connect: $!";
494 my($oldFH) = select(*FH); $| = 1; select($oldFH);
495 $bpc->{ServerFD} = *FH;
496 return if ( $justConnect );
498 # Read the seed that we need for our MD5 message digest. See
501 sysread($bpc->{ServerFD}, $bpc->{ServerSeed}, 1024);
502 $bpc->{ServerMesgCnt} = 0;
507 # Check that the server connection is still ok
513 return 0 if ( !defined($bpc->{ServerFD}) );
514 vec(my $FDread, fileno($bpc->{ServerFD}), 1) = 1;
516 return 0 if ( select(my $rout = $FDread, undef, $ein, 0.0) < 0 );
517 return 1 if ( !vec($rout, fileno($bpc->{ServerFD}), 1) );
521 # Disconnect from the server
526 return if ( !defined($bpc->{ServerFD}) );
527 close($bpc->{ServerFD});
528 delete($bpc->{ServerFD});
532 # Sends a message to the server and returns with the reply.
534 # To avoid possible attacks via the TCP socket interface, every client
535 # message is protected by an MD5 digest. The MD5 digest includes four
537 # - a seed that is sent to us when we first connect
538 # - a sequence number that increments for each message
539 # - a shared secret that is stored in $Conf{ServerMesgSecret}
540 # - the message itself.
541 # The message is sent in plain text preceded by the MD5 digest. A
542 # snooper can see the plain-text seed sent by BackupPC and plain-text
543 # message, but cannot construct a valid MD5 digest since the secret in
544 # $Conf{ServerMesgSecret} is unknown. A replay attack is not possible
545 # since the seed changes on a per-connection and per-message basis.
549 my($bpc, $mesg) = @_;
550 return if ( !defined(my $fh = $bpc->{ServerFD}) );
551 my $md5 = Digest::MD5->new;
552 $md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}
553 . $bpc->{Conf}{ServerMesgSecret} . $mesg);
554 print($fh $md5->b64digest . " $mesg\n");
555 $bpc->{ServerMesgCnt}++;
560 # Do initialization for child processes
566 open(STDERR, ">&STDOUT");
567 select(STDERR); $| = 1;
568 select(STDOUT); $| = 1;
569 $ENV{PATH} = $bpc->{Conf}{MyPath};
573 # Compute the MD5 digest of a file. For efficiency we don't
574 # use the whole file for big files:
575 # - for files <= 256K we use the file size and the whole file.
576 # - for files <= 1M we use the file size, the first 128K and
578 # - for files > 1M, we use the file size, the first 128K and
579 # the 8th 128K (ie: the 128K up to 1MB).
580 # See the documentation for a discussion of the tradeoffs in
581 # how much data we use and how many collisions we get.
583 # Returns the MD5 digest (a hex string) and the file size.
587 my($bpc, $md5, $name) = @_;
588 my($data, $fileSize);
591 $fileSize = (stat($name))[7];
592 return ("", -1) if ( !-f _ );
593 $name = $1 if ( $name =~ /(.*)/ );
594 return ("", 0) if ( $fileSize == 0 );
595 return ("", -1) if ( !open(N, $name) );
597 $md5->add($fileSize);
598 if ( $fileSize > 262144 ) {
600 # read the first and last 131072 bytes of the file,
603 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
604 $md5->add($data) if ( sysread(N, $data, 131072) );
605 $md5->add($data) if ( sysseek(N, $seekPosn, 0)
606 && sysread(N, $data, 131072) );
609 # read the whole file
611 $md5->add($data) if ( sysread(N, $data, $fileSize) );
614 return ($md5->hexdigest, $fileSize);
618 # Compute the MD5 digest of a buffer (string). For efficiency we don't
619 # use the whole string for big strings:
620 # - for files <= 256K we use the file size and the whole file.
621 # - for files <= 1M we use the file size, the first 128K and
623 # - for files > 1M, we use the file size, the first 128K and
624 # the 8th 128K (ie: the 128K up to 1MB).
625 # See the documentation for a discussion of the tradeoffs in
626 # how much data we use and how many collisions we get.
628 # Returns the MD5 digest (a hex string).
632 my($bpc, $md5, $fileSize, $dataRef) = @_;
635 $md5->add($fileSize);
636 if ( $fileSize > 262144 ) {
638 # add the first and last 131072 bytes of the string,
641 my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
642 $md5->add(substr($$dataRef, 0, 131072));
643 $md5->add(substr($$dataRef, $seekPosn, 131072));
646 # add the whole string
648 $md5->add($$dataRef);
650 return $md5->hexdigest;
654 # Given an MD5 digest $d and a compress flag, return the full
659 my($bpc, $d, $compress, $poolDir) = @_;
661 return if ( $d !~ m{(.)(.)(.)(.*)} );
662 $poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
663 if ( !defined($poolDir) );
664 return "$poolDir/$1/$2/$3/$1$2$3$4";
668 # For each file, check if the file exists in $bpc->{TopDir}/pool.
669 # If so, remove the file and make a hardlink to the file in
670 # the pool. Otherwise, if the newFile flag is set, make a
671 # hardlink in the pool to the new file.
673 # Returns 0 if a link should be made to a new file (ie: when the file
674 # is a new file but the newFile flag is 0).
675 # Returns 1 if a link to an existing file is made,
676 # Returns 2 if a link to a new file is made (only if $newFile is set)
677 # Returns negative on error.
681 my($bpc, $name, $d, $newFile, $compress) = @_;
684 return -1 if ( !-f $name );
685 for ( $i = -1 ; ; $i++ ) {
686 return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
687 $rawFile .= "_$i" if ( $i >= 0 );
689 if ( !compare($name, $rawFile) ) {
691 return -3 if ( !link($rawFile, $name) );
694 } elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
696 ($newDir = $rawFile) =~ s{(.*)/.*}{$1};
697 mkpath($newDir, 0, 0777) if ( !-d $newDir );
698 return -4 if ( !link($name, $rawFile) );
708 my($bpc, $host) = @_;
709 my($s, $pingCmd, $ret);
712 # Return success if the ping cmd is undefined or empty.
714 if ( $bpc->{Conf}{PingCmd} eq "" ) {
715 print("CheckHostAlive: return ok because \$Conf{PingCmd} is empty\n")
716 if ( $bpc->{verbose} );
721 pingPath => $bpc->{Conf}{PingPath},
724 $pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
727 # Do a first ping in case the PC needs to wakeup
729 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
731 print("CheckHostAlive: first ping failed ($?, $!)\n")
732 if ( $bpc->{verbose} );
737 # Do a second ping and get the round-trip time in msec
739 $s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
741 print("CheckHostAlive: second ping failed ($?, $!)\n")
742 if ( $bpc->{verbose} );
745 if ( $s =~ /time=([\d\.]+)\s*ms/i ) {
747 } elsif ( $s =~ /time=([\d\.]+)\s*usec/i ) {
750 print("CheckHostAlive: can't extract round-trip time (not fatal)\n")
751 if ( $bpc->{verbose} );
754 print("CheckHostAlive: returning $ret\n") if ( $bpc->{verbose} );
758 sub CheckFileSystemUsage
761 my($topDir) = $bpc->{TopDir};
764 return 0 if ( $bpc->{Conf}{DfCmd} eq "" );
766 dfPath => $bpc->{Conf}{DfPath},
767 topDir => $bpc->{TopDir},
769 $dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{DfCmd}, $args);
770 $s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
771 return 0 if ( $? || $s !~ /(\d+)%/s );
776 # Given an IP address, return the host name and user name via
781 my($bpc, $host) = @_;
782 my($netBiosHostName, $netBiosUserName);
786 # Skip NetBios check if NmbLookupCmd is emtpy
788 if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
789 print("NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"
791 if ( $bpc->{verbose} );
792 return ($host, undef);
796 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
799 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
800 foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
801 next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
802 $netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
803 $netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
805 if ( !defined($netBiosHostName) ) {
806 print("NetBiosInfoGet: failed: can't parse return string\n")
807 if ( $bpc->{verbose} );
810 $netBiosHostName = lc($netBiosHostName);
811 $netBiosUserName = lc($netBiosUserName);
812 print("NetBiosInfoGet: success, returning host $netBiosHostName,"
813 . " user $netBiosUserName\n")
814 if ( $bpc->{verbose} );
815 return ($netBiosHostName, $netBiosUserName);
819 # Given a NetBios name lookup the IP address via NetBios.
820 # In the case of a host returning multiple interfaces we
821 # return the first IP address that matches the subnet mask.
822 # If none match the subnet mask (or nmblookup doesn't print
823 # the subnet mask) then just the first IP address is returned.
825 sub NetBiosHostIPFind
827 my($bpc, $host) = @_;
828 my($netBiosHostName, $netBiosUserName);
829 my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
832 # Skip NetBios lookup if NmbLookupFindHostCmd is emtpy
834 if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
835 print("NetBiosHostIPFind: return $host because"
836 . " \$Conf{NmbLookupFindHostCmd} is empty\n")
837 if ( $bpc->{verbose} );
842 nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
845 $nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
846 foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,
848 if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
850 $subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
851 } elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
853 $firstIpAddr = $ip if ( !defined($firstIpAddr) );
854 $ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
857 $ipAddr = $firstIpAddr if ( !defined($ipAddr) );
858 if ( defined($ipAddr) ) {
859 print("NetBiosHostIPFind: found IP address $ipAddr for host $host\n")
860 if ( $bpc->{verbose} );
863 print("NetBiosHostIPFind: couldn't find IP address for host $host\n")
864 if ( $bpc->{verbose} );
869 sub fileNameEltMangle
871 my($bpc, $name) = @_;
873 return "" if ( $name eq "" );
874 $name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
879 # We store files with every name preceded by "f". This
880 # avoids possible name conflicts with other information
881 # we store in the same directories (eg: attribute info).
882 # The process of turning a normal path into one with each
883 # node prefixed with "f" is called mangling.
887 my($bpc, $name) = @_;
889 $name =~ s{/([^/]+)}{"/" . $bpc->fileNameEltMangle($1)}eg;
890 $name =~ s{^([^/]+)}{$bpc->fileNameEltMangle($1)}eg;
895 # This undoes FileNameMangle
899 my($bpc, $name) = @_;
903 $name =~ s{%(..)}{chr(hex($1))}eg;
908 # Escape shell meta-characters with backslashes.
909 # This should be applied to each argument seperately, not an
910 # entire shell command.
916 $cmd =~ s/([][;&()<>{}|^\n\r\t *\$\\'"`?])/\\$1/g;
921 # For printing exec commands (which don't use a shell) so they look like
922 # a valid shell command this function should be called with the exec
923 # args. The shell command string is returned.
927 my($bpc, @args) = @_;
930 foreach my $a ( @args ) {
931 $str .= " " if ( $str ne "" );
932 $str .= $bpc->shellEscape($a);
938 # Do a URI-style escape to protect/encode special characters
943 $s =~ s{([^\w.\/-])}{sprintf("%%%02X", ord($1));}eg;
948 # Do a URI-style unescape to restore special characters
953 $s =~ s{%(..)}{chr(hex($1))}eg;
958 # Do variable substitution prior to execution of a command.
962 my($bpc, $template, $vars) = @_;
966 # Return without any substitution if the first entry starts with "&",
967 # indicating this is perl code.
969 if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
972 if ( ref($template) ne "ARRAY" ) {
974 # Split at white space, except if escaped by \
976 $template = [split(/(?<!\\)\s+/, $template)];
978 # Remove the \ that escaped white space.
980 foreach ( @$template ) {
985 # Merge variables into @tarClientCmd
987 foreach my $arg ( @$template ) {
989 # Replace scalar variables first
991 $arg =~ s{\$(\w+)(\+?)}{
992 exists($vars->{$1}) && ref($vars->{$1}) ne "ARRAY"
993 ? ($2 eq "+" ? $bpc->shellEscape($vars->{$1}) : $vars->{$1})
997 # Now replicate any array arguments; this just works for just one
998 # array var in each argument.
1000 if ( $arg =~ m{(.*)\$(\w+)(\+?)(.*)} && ref($vars->{$2}) eq "ARRAY" ) {
1005 foreach my $v ( @{$vars->{$var}} ) {
1006 $v = $bpc->shellEscape($v) if ( $esc eq "+" );
1007 push(@cmd, "$pre$v$post");
1017 # Exec or eval a command. $cmd is either a string on an array ref.
1019 # @args are optional arguments for the eval() case; they are not used
1024 my($bpc, $cmd, @args) = @_;
1026 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1027 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1028 print("cmdExecOrEval: about to eval perl code $cmd\n")
1029 if ( $bpc->{verbose} );
1031 print(STDERR "Perl code fragment for exec shouldn't return!!\n");
1034 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1035 print("cmdExecOrEval: about to exec ",
1036 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1037 if ( $bpc->{verbose} );
1039 print(STDERR "Exec failed for @$cmd\n");
1045 # System or eval a command. $cmd is either a string on an array ref.
1046 # $stdoutCB is a callback for output generated by the command. If it
1047 # is undef then output is returned. If it is a code ref then the function
1048 # is called with each piece of output as an argument. If it is a scalar
1049 # ref the output is appended to this variable.
1051 # @args are optional arguments for the eval() case; they are not used
1054 # Also, $? should be set when the CHILD pipe is closed.
1058 my($bpc, $cmd, $stdoutCB, @args) = @_;
1059 my($pid, $out, $allOut);
1062 if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
1063 $cmd = join(" ", $cmd) if ( ref($cmd) eq "ARRAY" );
1064 print("cmdSystemOrEval: about to eval perl code $cmd\n")
1065 if ( $bpc->{verbose} );
1067 $$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
1068 &$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );
1069 print("cmdSystemOrEval: finished: got output $out\n")
1070 if ( $bpc->{verbose} );
1071 return $out if ( !defined($stdoutCB) );
1074 $cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
1075 print("cmdSystemOrEval: about to system ",
1076 $bpc->execCmd2ShellCmd(@$cmd), "\n")
1077 if ( $bpc->{verbose} );
1078 if ( !defined($pid = open(CHILD, "-|")) ) {
1079 my $err = "Can't fork to run @$cmd\n";
1081 $$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
1082 &$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
1083 return $err if ( !defined($stdoutCB) );
1091 open(STDERR, ">&STDOUT");
1093 print("Exec of @$cmd failed\n");
1097 # The parent gathers the output from the child
1100 $$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
1101 &$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
1102 $out .= $_ if ( !defined($stdoutCB) );
1103 $allOut .= $_ if ( $bpc->{verbose} );
1108 print("cmdSystemOrEval: finished: got output $allOut\n")
1109 if ( $bpc->{verbose} );