"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "lib/BackupPC/Lib.pm" between
BackupPC-4.3.2.tar.gz and BackupPC-4.4.0.tar.gz

About: BackupPC is a high-performance, enterprise-grade system for backing up Linux and WinXX PCs and laptops to a server’s disk (http/cgi user interface).

Lib.pm  (BackupPC-4.3.2)	:	Lib.pm  (BackupPC-4.4.0)
skipping to change at line 31		skipping to change at line 31
# This program is distributed in the hope that it will be useful,		# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of		# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the		# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.		# GNU General Public License for more details.
#		#
# You should have received a copy of the GNU General Public License		# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.		# along with this program. If not, see <http://www.gnu.org/licenses/>.
#		#
#========================================================================		#========================================================================
#		#
# Version 4.3.2, released 17 Feb 2020.		# Version 4.4.0, released 20 Jun 2020.
#		#
# See http://backuppc.sourceforge.net.		# See http://backuppc.sourceforge.net.
#		#
#========================================================================		#========================================================================
package BackupPC::Lib;		package BackupPC::Lib;
use strict;		use strict;
use vars qw(%Conf %Lang);		use vars qw(%Conf %Lang);
skipping to change at line 71		skipping to change at line 71
#		#
# Whether to use filesystem hierarchy standard for file layout.		# Whether to use filesystem hierarchy standard for file layout.
# If set, text config files are below /etc/BackupPC.		# If set, text config files are below /etc/BackupPC.
#		#
my $useFHS = 0;		my $useFHS = 0;
my $paths;		my $paths;
#		#
# Set defaults for $topDir and $installDir.		# Set defaults for $topDir and $installDir.
#		#
$topDir = '__TOPDIR__' if ( $topDir eq "" );		$topDir = '__TOPDIR__' if ( $topDir eq "" ); # updated by con
$installDir = '__INSTALLDIR__' if ( $installDir eq "" );		figure.pl
		$installDir = '__INSTALLDIR__' if ( $installDir eq "" ); # updated by con
		figure.pl
#		#
# Pick some initial defaults. For FHS the only critical		# Pick some initial defaults. For FHS the only critical
# path is the ConfDir, since we get everything else out		# path is the ConfDir, since we get everything else out
# of the main config file.		# of the main config file.
#		#
if ( $useFHS ) {		if ( $useFHS ) {
$paths = {		$paths = {
useFHS => $useFHS,		useFHS => $useFHS,
TopDir => $topDir,		TopDir => $topDir,
InstallDir => $installDir,		InstallDir => $installDir,
ConfDir => $confDir eq "" ? '__CONFDIR__' : $confDir,		ConfDir => $confDir eq "" ? '__CONFDIR__' : $confDir, # update d by configure.pl
LogDir => '/var/log/BackupPC',		LogDir => '/var/log/BackupPC',
RunDir => '/var/run/BackupPC',		RunDir => '/var/run/BackupPC',
};		};
} else {		} else {
$paths = {		$paths = {
useFHS => $useFHS,		useFHS => $useFHS,
TopDir => $topDir,		TopDir => $topDir,
InstallDir => $installDir,		InstallDir => $installDir,
ConfDir => $confDir eq "" ? "$topDir/conf" : $confDir,		ConfDir => $confDir eq "" ? "$topDir/conf" : $confDir,
LogDir => "$topDir/log",		LogDir => "$topDir/log",
RunDir => "$topDir/log",		RunDir => "$topDir/log",
};		};
}		}
my $bpc = bless {		my $bpc = bless {
%$paths,		%$paths,
Version => '4.3.2',		Version => '4.4.0' # updated by makeDist
}, $class;		}, $class;
$bpc->{storage} = BackupPC::Storage->new($paths);		$bpc->{storage} = BackupPC::Storage->new($paths);
#		#
# Clean up %ENV and setup other variables.		# Clean up %ENV and setup other variables.
#		#
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};		delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
if ( defined(my $error = $bpc->ConfigRead()) ) {		if ( defined(my $error = $bpc->ConfigRead()) ) {
print(STDERR $error, "\n");		print(STDERR $error, "\n");
skipping to change at line 123		skipping to change at line 123
}		}
#		#
# Update the paths based on the config file		# Update the paths based on the config file
#		#
foreach my $dir ( qw(TopDir ConfDir InstallDir LogDir RunDir) ) {		foreach my $dir ( qw(TopDir ConfDir InstallDir LogDir RunDir) ) {
next if ( $bpc->{Conf}{$dir} eq "" );		next if ( $bpc->{Conf}{$dir} eq "" );
$paths->{$dir} = $bpc->{$dir} = $bpc->{Conf}{$dir};		$paths->{$dir} = $bpc->{$dir} = $bpc->{Conf}{$dir};
}		}
$bpc->{storage}->setPaths($paths);		$bpc->{storage}->setPaths($paths);
$bpc->{PoolDir} = "$bpc->{TopDir}/pool";		$bpc->{PoolDir} = "$bpc->{TopDir}/pool";
$bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";		$bpc->{CPoolDir} = "$bpc->{TopDir}/cpool";
#		#
# Verify we are running as the correct user		# Verify we are running as the correct user
#		#
if ( !$noUserCheck		if ( !$noUserCheck
&& $bpc->{Conf}{BackupPCUserVerify}		&& $bpc->{Conf}{BackupPCUserVerify}
&& $> != (my $uid = getpwnam($bpc->{Conf}{BackupPCUser})) ) {		&& $> != (my $uid = getpwnam($bpc->{Conf}{BackupPCUser})) ) {
print(STDERR "$0: Wrong user: my userid is $>, instead of $uid"		print(STDERR "$0: Wrong user: my userid is $>, instead of $uid ($bpc->{C
. " ($bpc->{Conf}{BackupPCUser})\n");		onf}{BackupPCUser})\n");
print(STDERR "Please 'su [-m | -s shell] $bpc->{Conf}{BackupPCUser}' firs		print(STDERR "Please 'su [-m | -s shell] $bpc->{Conf}{BackupPCUser}' fir
t\n");		st\n");
return;		return;
}		}
BackupPC::XS::Lib::ConfInit($bpc->{TopDir}, $bpc->{Conf}{HardLinkMax}, $bpc-		BackupPC::XS::Lib::ConfInit(
>{Conf}{PoolV3Enabled}, $bpc->{Conf}{XferLogLevel});		$bpc->{TopDir},
		$bpc->{Conf}{HardLinkMax},
		$bpc->{Conf}{PoolV3Enabled},
		$bpc->{Conf}{XferLogLevel}
		);
return $bpc;		return $bpc;
}		}
sub TopDir		sub TopDir
{		{
my($bpc) = @_;		my($bpc) = @_;
return $bpc->{TopDir};		return $bpc->{TopDir};
}		}
sub PoolDir		sub PoolDir
{		{
my($bpc, $compress) = @_;		my($bpc, $compress) = @_;
return $compress ? $bpc->{CPoolDir} : $bpc->{PoolDir}		return $compress ? $bpc->{CPoolDir} : $bpc->{PoolDir};
}		}
sub BinDir		sub BinDir
{		{
my($bpc) = @_;		my($bpc) = @_;
return "$bpc->{InstallDir}/bin";		return "$bpc->{InstallDir}/bin";
}		}
sub LogDir		sub LogDir
{		{
skipping to change at line 253		skipping to change at line 257
$bpc->{verbose} = $param if ( defined($param) );		$bpc->{verbose} = $param if ( defined($param) );
return $bpc->{verbose};		return $bpc->{verbose};
}		}
sub sigName2num		sub sigName2num
{		{
my($bpc, $sig) = @_;		my($bpc, $sig) = @_;
if ( !defined($bpc->{SigName2Num}) ) {		if ( !defined($bpc->{SigName2Num}) ) {
my $i = 0;		my $i = 0;
foreach my $name ( split(' ', $Config{sig_name}) ) {		foreach my $name ( split(' ', $Config{sig_name}) ) {
$bpc->{SigName2Num}{$name} = $i;		$bpc->{SigName2Num}{$name} = $i;
$i++;		$i++;
}		}
}		}
return $bpc->{SigName2Num}{$sig};		return $bpc->{SigName2Num}{$sig};
}		}
#		#
# Generate an ISO 8601 format timeStamp (but without the "T").		# Generate an ISO 8601 format timeStamp (but without the "T").
# See http://www.w3.org/TR/NOTE-datetime and		# See http://www.w3.org/TR/NOTE-datetime and
# http://www.cl.cam.ac.uk/~mgk25/iso-time.html		# http://www.cl.cam.ac.uk/~mgk25/iso-time.html
#		#
sub timeStamp		sub timeStamp
{		{
my($bpc, $t, $noPad) = @_;		my($bpc, $t, $noPad) = @_;
my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)		my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(
= localtime($t || time);		$t || time);
return sprintf("%04d-%02d-%02d %02d:%02d:%02d",		return
$year + 1900, $mon + 1, $mday, $hour, $min, $sec)		sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $h
. ($noPad ? "" : " ");		our, $min, $sec) . ($noPad ? "" : " ");
}		}
sub BackupInfoRead		sub BackupInfoRead
{		{
my($bpc, $host) = @_;		my($bpc, $host) = @_;
return $bpc->{storage}->BackupInfoRead($host);		return $bpc->{storage}->BackupInfoRead($host);
}		}
sub BackupInfoWrite		sub BackupInfoWrite
skipping to change at line 350		skipping to change at line 352
#		#
my($mesg, $config) = $bpc->{storage}->ConfigDataRead();		my($mesg, $config) = $bpc->{storage}->ConfigDataRead();
return $mesg if ( defined($mesg) );		return $mesg if ( defined($mesg) );
$bpc->{Conf} = $config;		$bpc->{Conf} = $config;
#		#
# Read host config file		# Read host config file
#		#
if ( $host ne "" ) {		if ( $host ne "" ) {
($mesg, $config) = $bpc->{storage}->ConfigDataRead($host, $config);		($mesg, $config) = $bpc->{storage}->ConfigDataRead($host, $config);
return $mesg if ( defined($mesg) );		return $mesg if ( defined($mesg) );
$bpc->{Conf} = $config;		$bpc->{Conf} = $config;
}		}
#		#
# Load optional perl modules		# Load optional perl modules
#		#
if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {		if ( defined($bpc->{Conf}{PerlModuleLoad}) ) {
#		#
# Load any user-specified perl modules. This is for		# Load any user-specified perl modules. This is for
# optional user-defined extensions.		# optional user-defined extensions.
#		#
$bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]		$bpc->{Conf}{PerlModuleLoad} = [$bpc->{Conf}{PerlModuleLoad}]
if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );		if ( ref($bpc->{Conf}{PerlModuleLoad}) ne "ARRAY" );
foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {		foreach my $module ( @{$bpc->{Conf}{PerlModuleLoad}} ) {
eval("use $module;");		eval("use $module;");
}		}
}		}
#		#
# Load language file		# Load language file
#		#
return "No language setting" if ( !defined($bpc->{Conf}{Language}) );		return "No language setting" if ( !defined($bpc->{Conf}{Language}) );
my $langFile = "$bpc->{InstallDir}/lib/BackupPC/Lang/$bpc->{Conf}{Language}. pm";		my $langFile = "$bpc->{InstallDir}/lib/BackupPC/Lang/$bpc->{Conf}{Language}. pm";
if ( !defined($ret = do $langFile) && ($! || $@) ) {		if ( !defined($ret = do $langFile) && ($! || $@) ) {
$mesg = "Couldn't open language file $langFile: $!" if ( $! );		$mesg = "Couldn't open language file $langFile: $!" if ( $! );
$mesg = "Couldn't execute language file $langFile: $@" if ( $@ );		$mesg = "Couldn't execute language file $langFile: $@" if ( $@ );
$mesg =~ s/[\n\r]+//;		$mesg =~ s/[\n\r]+//;
return $mesg;		return $mesg;
}		}
$bpc->{Lang} = \%Lang;		$bpc->{Lang} = \%Lang;
return;		return;
}		}
#		#
# Return the mtime of the config file		# Return the mtime of the config file
#		#
sub ConfigMTime		sub ConfigMTime
skipping to change at line 441		skipping to change at line 443
sub ServerConnect		sub ServerConnect
{		{
my($bpc, $host, $port, $justConnect) = @_;		my($bpc, $host, $port, $justConnect) = @_;
local(*FH);		local(*FH);
return if ( defined($bpc->{ServerFD}) );		return if ( defined($bpc->{ServerFD}) );
#		#
# First try the unix-domain socket		# First try the unix-domain socket
#		#
my $sockFile = "$bpc->{RunDir}/BackupPC.sock";		my $sockFile = "$bpc->{RunDir}/BackupPC.sock";
socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";		socket(*FH, PF_UNIX, SOCK_STREAM, 0) || return "unix socket: $!";
if ( !connect(*FH, sockaddr_un($sockFile)) ) {		if ( !connect(*FH, sockaddr_un($sockFile)) ) {
my $err = "unix connect to $sockFile: $!";		my $err = "unix connect to $sockFile: $!";
close(*FH);		close(*FH);
if ( $port > 0 ) {		if ( $port > 0 ) {
my $proto = getprotobyname('tcp');		my $proto = getprotobyname('tcp');
my $iaddr = inet_aton($host) || return "unknown host $host";		my $iaddr = inet_aton($host) || return "unknown host $host";
my $paddr = sockaddr_in($port, $iaddr);		my $paddr = sockaddr_in($port, $iaddr);
socket(*FH, PF_INET, SOCK_STREAM, $proto)		socket(*FH, PF_INET, SOCK_STREAM, $proto)
|| return "inet socket port $port:		|| return "inet socket port $port: $!";
$!";		connect(*FH, $paddr) || return "inet connect port $port: $!";
connect(*FH, $paddr) || return "inet connect port $port:
$!";
} else {		} else {
return $err;		return $err;
}		}
}		}
my($oldFH) = select(*FH); $| = 1; select($oldFH);		my($oldFH) = select(*FH); $| = 1; select($oldFH);
$bpc->{ServerFD} = *FH;		$bpc->{ServerFD} = *FH;
return if ( $justConnect );		return if ( $justConnect );
#		#
# Read the seed that we need for our MD5 message digest. See		# Read the seed that we need for our MD5 message digest. See
# ServerMesg below.		# ServerMesg below.
skipping to change at line 518		skipping to change at line 520
# since the seed changes on a per-connection and per-message basis.		# since the seed changes on a per-connection and per-message basis.
#		#
sub ServerMesg		sub ServerMesg
{		{
my($bpc, $mesg) = @_;		my($bpc, $mesg) = @_;
return if ( !defined(my $fh = $bpc->{ServerFD}) );		return if ( !defined(my $fh = $bpc->{ServerFD}) );
$mesg =~ s/\n/\\n/g;		$mesg =~ s/\n/\\n/g;
$mesg =~ s/\r/\\r/g;		$mesg =~ s/\r/\\r/g;
my $md5 = Digest::MD5->new;		my $md5 = Digest::MD5->new;
$mesg = encode_utf8($mesg);		$mesg = encode_utf8($mesg);
$md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt}		$md5->add($bpc->{ServerSeed} . $bpc->{ServerMesgCnt} . $bpc->{Conf}{ServerMe
. $bpc->{Conf}{ServerMesgSecret} . $mesg);		sgSecret} . $mesg);
print($fh $md5->b64digest . " $mesg\n");		print($fh $md5->b64digest . " $mesg\n");
$bpc->{ServerMesgCnt}++;		$bpc->{ServerMesgCnt}++;
return <$fh>;		return <$fh>;
}		}
#		#
# Do initialization for child processes		# Do initialization for child processes
#		#
sub ChildInit		sub ChildInit
{		{
skipping to change at line 600		skipping to change at line 601
# enabled, and also force the match in bpc_poolWrite_write to		# enabled, and also force the match in bpc_poolWrite_write to
# true.		# true.
#		#
# substr($d, 0, 16) = pack("H*", "d41d8cd98f00b204e9800998ecf8427e");		# substr($d, 0, 16) = pack("H*", "d41d8cd98f00b204e9800998ecf8427e");
#		#
return "/dev/null" if ( $d eq ZeroLengthMD5Digest );		return "/dev/null" if ( $d eq ZeroLengthMD5Digest );
my $b2 = vec($d, 0, 16);		my $b2 = vec($d, 0, 16);
$poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})		$poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
if ( !defined($poolDir) );		if ( !defined($poolDir) );
return sprintf("%s/%02x/%02x/%s", $poolDir,		return sprintf("%s/%02x/%02x/%s", $poolDir, ($b2 >> 8) & 0xfe, ($b2 >> 0) &
($b2 >> 8) & 0xfe,		0xfe, unpack("H*", $d));
($b2 >> 0) & 0xfe,
unpack("H*", $d));
}		}
#		#
# V4 digest extension for MD5 collisions.		# V4 digest extension for MD5 collisions.
#		#
# Take the digest and append $extCnt in binary, with leading		# Take the digest and append $extCnt in binary, with leading
# 0x0 removed. That means when $extCnt == 0, nothing is		# 0x0 removed. That means when $extCnt == 0, nothing is
# appended and the digest is the original 16 byte MD5 digest.		# appended and the digest is the original 16 byte MD5 digest.
#		#
# Example: when $extCnt == 1 then 0x01 is appended (1 more byte).		# Example: when $extCnt == 1 then 0x01 is appended (1 more byte).
# When $extCnt == 258 then 0x0102 is appended (2 more bytes).		# When $extCnt == 258 then 0x0102 is appended (2 more bytes).
#		#
sub digestConcat		sub digestConcat
{		{
my($bpc, $digest, $extCnt, $compress) = @_;		my($bpc, $digest, $extCnt, $compress) = @_;
$digest = substr($digest, 16) if ( length($digest) > 16 );		$digest = substr($digest, 16) if ( length($digest) > 16 );
my $ext = pack("N", $extCnt);		my $ext = pack("N", $extCnt);
$ext =~ s/^\x00+//;		$ext =~ s/^\x00+//;
my $thisDigest = $digest . $ext;		my $thisDigest = $digest . $ext;
my $poolName = $bpc->MD52Path($thisDigest, $compress);		my $poolName = $bpc->MD52Path($thisDigest, $compress);
return($thisDigest, $poolName);		return ($thisDigest, $poolName);
}		}
#		#
# Given a digest from digestConcat() return the extension value		# Given a digest from digestConcat() return the extension value
# as an integer		# as an integer
#		#
sub digestExtGet		sub digestExtGet
{		{
my($bpc, $digest) = @_;		my($bpc, $digest) = @_;
skipping to change at line 671		skipping to change at line 669
#		#
sub File2MD5_v3		sub File2MD5_v3
{		{
my($bpc, $md5, $name) = @_;		my($bpc, $md5, $name) = @_;
my($data, $fileSize);		my($data, $fileSize);
local(*N);		local(*N);
$fileSize = (stat($name))[7];		$fileSize = (stat($name))[7];
return ("", -1) if ( !-f _ );		return ("", -1) if ( !-f _ );
$name = $1 if ( $name =~ /(.*)/ );		$name = $1 if ( $name =~ /(.*)/ );
return ("", 0) if ( $fileSize == 0 );		return ("", 0) if ( $fileSize == 0 );
return ("", -1) if ( !open(N, $name) );		return ("", -1) if ( !open(N, $name) );
binmode(N);		binmode(N);
$md5->reset();		$md5->reset();
$md5->add($fileSize);		$md5->add($fileSize);
if ( $fileSize > 262144 ) {		if ( $fileSize > 262144 ) {
#		#
# read the first and last 131072 bytes of the file,		# read the first and last 131072 bytes of the file,
# up to 1MB.		# up to 1MB.
#		#
my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;		my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
$md5->add($data) if ( sysread(N, $data, 131072) );		$md5->add($data) if ( sysread(N, $data, 131072) );
$md5->add($data) if ( sysseek(N, $seekPosn, 0)		$md5->add($data) if ( sysseek(N, $seekPosn, 0) && sysread(N, $data, 1310
&& sysread(N, $data, 131072) );		72) );
} else {		} else {
#		#
# read the whole file		# read the whole file
#		#
$md5->add($data) if ( sysread(N, $data, $fileSize) );		$md5->add($data) if ( sysread(N, $data, $fileSize) );
}		}
close(N);		close(N);
return ($md5->hexdigest, $fileSize);		return ($md5->hexdigest, $fileSize);
}		}
skipping to change at line 722		skipping to change at line 720
my($bpc, $md5, $fileSize, $dataRef) = @_;		my($bpc, $md5, $fileSize, $dataRef) = @_;
$md5->reset();		$md5->reset();
$md5->add($fileSize);		$md5->add($fileSize);
if ( $fileSize > 262144 ) {		if ( $fileSize > 262144 ) {
#		#
# add the first and last 131072 bytes of the string,		# add the first and last 131072 bytes of the string,
# up to 1MB.		# up to 1MB.
#		#
my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;		my $seekPosn = ($fileSize > 1048576 ? 1048576 : $fileSize) - 131072;
$md5->add(substr($$dataRef, 0, 131072));		$md5->add(substr($$dataRef, 0, 131072));
$md5->add(substr($$dataRef, $seekPosn, 131072));		$md5->add(substr($$dataRef, $seekPosn, 131072));
} else {		} else {
#		#
# add the whole string		# add the whole string
#		#
$md5->add($$dataRef);		$md5->add($$dataRef);
}		}
return $md5->hexdigest;		return $md5->hexdigest;
}		}
skipping to change at line 747		skipping to change at line 745
#		#
# Given an MD5 digest $d and a compress flag, return the full		# Given an MD5 digest $d and a compress flag, return the full
# path in the pool.		# path in the pool.
#		#
sub MD52Path_v3		sub MD52Path_v3
{		{
my($bpc, $d, $compress, $poolDir) = @_;		my($bpc, $d, $compress, $poolDir) = @_;
return if ( $d !~ m{(.)(.)(.)(.*)} );		return if ( $d !~ m{(.)(.)(.)(.*)} );
$poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})		$poolDir = ($compress ? $bpc->{CPoolDir} : $bpc->{PoolDir})
if ( !defined($poolDir) );		if ( !defined($poolDir) );
return "$poolDir/$1/$2/$3/$1$2$3$4";		return "$poolDir/$1/$2/$3/$1$2$3$4";
}		}
#		#
# For each file, check if the file exists in $bpc->{TopDir}/pool.		# For each file, check if the file exists in $bpc->{TopDir}/pool.
# If so, remove the file and make a hardlink to the file in		# If so, remove the file and make a hardlink to the file in
# the pool. Otherwise, if the newFile flag is set, make a		# the pool. Otherwise, if the newFile flag is set, make a
# hardlink in the pool to the new file.		# hardlink in the pool to the new file.
#		#
# Returns 0 if a link should be made to a new file (ie: when the file		# Returns 0 if a link should be made to a new file (ie: when the file
skipping to change at line 773		skipping to change at line 771
sub MakeFileLink		sub MakeFileLink
{		{
my($bpc, $name, $d, $newFile, $compress) = @_;		my($bpc, $name, $d, $newFile, $compress) = @_;
my($i, $rawFile);		my($i, $rawFile);
return -1 if ( !-f $name );		return -1 if ( !-f $name );
for ( $i = -1 ; ; $i++ ) {		for ( $i = -1 ; ; $i++ ) {
return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );		return -2 if ( !defined($rawFile = $bpc->MD52Path($d, $compress)) );
$rawFile .= "_$i" if ( $i >= 0 );		$rawFile .= "_$i" if ( $i >= 0 );
if ( -f $rawFile ) {		if ( -f $rawFile ) {
if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax}		if ( (stat(_))[3] < $bpc->{Conf}{HardLinkMax} && !compare($name, $ra
&& !compare($name, $rawFile) ) {		wFile) ) {
unlink($name);		unlink($name);
return -3 if ( !link($rawFile, $name) );		return -3 if ( !link($rawFile, $name) );
return 1;		return 1;
}		}
} elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {		} elsif ( $newFile && -f $name && (stat($name))[3] == 1 ) {
my($newDir);		my($newDir);
($newDir = $rawFile) =~ s{(.*)/.*}{$1};		($newDir = $rawFile) =~ s{(.*)/.*}{$1};
if ( !-d $newDir ) {		if ( !-d $newDir ) {
eval { mkpath($newDir, 0, 0777) };		eval { mkpath($newDir, 0, 0777) };
return -5 if ( $@ );		return -5 if ( $@ );
skipping to change at line 830		skipping to change at line 827
sub CheckHostAlive		sub CheckHostAlive
{		{
my($bpc, $host) = @_;		my($bpc, $host) = @_;
my($s, $pingCmd, $ret);		my($s, $pingCmd, $ret);
#		#
# Return success if the ping cmd is undefined or empty.		# Return success if the ping cmd is undefined or empty.
#		#
if ( $bpc->{Conf}{PingCmd} eq "" ) {		if ( $bpc->{Conf}{PingCmd} eq "" ) {
print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd}"		print(STDERR "CheckHostAlive: return ok because \$Conf{PingCmd} is empty
. " is empty\n") if ( $bpc->{verbose} );		\n") if ( $bpc->{verbose} );
return 0;		return 0;
}		}
my $args = {		my $args = {
pingPath => $bpc->getPingPathByAddressType($host),		pingPath => $bpc->getPingPathByAddressType($host),
host => $host,		host => $host,
};		};
$pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);		$pingCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{PingCmd}, $args);
#		#
# Do a first ping in case the PC needs to wakeup		# Do a first ping in case the PC needs to wakeup
#		#
$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);		$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
if ( $? ) {		if ( $? ) {
my $str = $bpc->execCmd2ShellCmd(@$pingCmd);		my $str = $bpc->execCmd2ShellCmd(@$pingCmd);
print(STDERR "CheckHostAlive: first ping ($str) failed ($?, $!)\n")		print(STDERR "CheckHostAlive: first ping ($str) failed ($?, $!)\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
return -1;		return -1;
}		}
#		#
# Do a second ping and get the round-trip time in msec		# Do a second ping and get the round-trip time in msec
#		#
$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);		$s = $bpc->cmdSystemOrEval($pingCmd, undef, $args);
if ( $? ) {		if ( $? ) {
my $str = $bpc->execCmd2ShellCmd(@$pingCmd);		my $str = $bpc->execCmd2ShellCmd(@$pingCmd);
print(STDERR "CheckHostAlive: second ping ($str) failed ($?, $!)\n")		print(STDERR "CheckHostAlive: second ping ($str) failed ($?, $!)\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
return -1;		return -1;
}		}
if ( $s =~ /rtt\s*min\/avg\/max\/mdev\s*=\s*[\d.]+\/([\d.]+)\/[\d.]+\/[\d.]+ \s*(ms|usec)/i ) {		if ( $s =~ /rtt\s*min\/avg\/max\/mdev\s*=\s*[\d.]+\/([\d.]+)\/[\d.]+\/[\d.]+ \s*(ms|usec)/i ) {
$ret = $1;		$ret = $1;
$ret /= 1000 if ( lc($2) eq "usec" );		$ret /= 1000 if ( lc($2) eq "usec" );
} elsif ( $s =~ /time=([\d.]+)\s*(ms|usec)/i ) {		} elsif ( $s =~ /time=([\d.]+)\s*(ms|usec)/i ) {
$ret = $1;		$ret = $1;
$ret /= 1000 if ( lc($2) eq "usec" );		$ret /= 1000 if ( lc($2) eq "usec" );
} else {		} else {
print(STDERR "CheckHostAlive: can't extract round-trip time"		print(STDERR "CheckHostAlive: can't extract round-trip time (not fatal)\
. " (not fatal)\n") if ( $bpc->{verbose} );		n") if ( $bpc->{verbose} );
$ret = 0;		$ret = 0;
}		}
if ( $bpc->{verbose} ) {		if ( $bpc->{verbose} ) {
my $str = $bpc->execCmd2ShellCmd(@$pingCmd);		my $str = $bpc->execCmd2ShellCmd(@$pingCmd);
print(STDERR "CheckHostAlive: ran '$str'; returning $ret\n")		print(STDERR "CheckHostAlive: ran '$str'; returning $ret\n");
}		}
return $ret;		return $ret;
}		}
sub CheckFileSystemUsage		sub CheckFileSystemUsage
{		{
my($bpc, $inode) = @_;		my($bpc, $inode) = @_;
my($topDir) = $bpc->{TopDir};		my($topDir) = $bpc->{TopDir};
my($s, $dfCmd);		my($s, $dfCmd);
my $cmd = $inode ? "DfInodeUsageCmd" : "DfCmd";		my $cmd = $inode ? "DfInodeUsageCmd" : "DfCmd";
return 0 if ( $bpc->{Conf}{$cmd} eq "" );		return 0 if ( $bpc->{Conf}{$cmd} eq "" );
my $args = {		my $args = {
dfPath => $bpc->{Conf}{DfPath},		dfPath => $bpc->{Conf}{DfPath},
topDir => $bpc->{TopDir},		topDir => $bpc->{TopDir},
};		};
$dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{$cmd}, $args);		$dfCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{$cmd}, $args);
$s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);		$s = $bpc->cmdSystemOrEval($dfCmd, undef, $args);
return 0 if ( $? || $s !~ /(\d+)%/s );		return 0 if ( $? || $s !~ /(\d+)%/s );
return $1;		return $1;
}		}
#		#
# Given an IP address, return the host name and user name via		# Given an IP address, return the host name and user name via
# NetBios.		# NetBios.
#		#
sub NetBiosInfoGet		sub NetBiosInfoGet
{		{
my($bpc, $host) = @_;		my($bpc, $host) = @_;
my($netBiosHostName, $netBiosUserName);		my($netBiosHostName, $netBiosUserName);
my($s, $nmbCmd);		my($s, $nmbCmd);
#		#
# Skip NetBios check if NmbLookupCmd is empty		# Skip NetBios check if NmbLookupCmd is empty
#		#
if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {		if ( $bpc->{Conf}{NmbLookupCmd} eq "" ) {
print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}"		print(STDERR "NetBiosInfoGet: return $host because \$Conf{NmbLookupCmd}
. " is empty\n") if ( $bpc->{verbose} );		is empty\n")
return ($host, undef);		if ( $bpc->{verbose} );
		return ($host, undef);
}		}
my $args = {		my $args = {
nmbLookupPath => $bpc->{Conf}{NmbLookupPath},		nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
host => $host,		host => $host,
};		};
$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);		$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupCmd}, $args);
foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {		foreach ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $args)) ) {
#		#
# skip <GROUP> and other non <ACTIVE> entries		# skip <GROUP> and other non <ACTIVE> entries
#		#
next if ( /<\w{2}> - <GROUP>/i );		next if ( /<\w{2}> - <GROUP>/i );
next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );		next if ( !/^\s*([\w\s-]+?)\s*<(\w{2})\> - .*<ACTIVE>/i );
$netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00		$netBiosHostName ||= $1 if ( $2 eq "00" ); # host is first 00
$netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03		$netBiosUserName = $1 if ( $2 eq "03" ); # user is last 03
}		}
if ( !defined($netBiosHostName) ) {		if ( !defined($netBiosHostName) ) {
print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")		print(STDERR "NetBiosInfoGet: failed: can't parse return string\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
return;		return;
}		}
$netBiosHostName = lc($netBiosHostName);		$netBiosHostName = lc($netBiosHostName);
$netBiosUserName = lc($netBiosUserName);		$netBiosUserName = lc($netBiosUserName);
print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName,"		print(STDERR "NetBiosInfoGet: success, returning host $netBiosHostName, user
. " user $netBiosUserName\n") if ( $bpc->{verbose} );		$netBiosUserName\n")
		if ( $bpc->{verbose} );
return ($netBiosHostName, $netBiosUserName);		return ($netBiosHostName, $netBiosUserName);
}		}
#		#
# Given a NetBios name lookup the IP address via NetBios.		# Given a NetBios name lookup the IP address via NetBios.
# In the case of a host returning multiple interfaces we		# In the case of a host returning multiple interfaces we
# return the first IP address that matches the subnet mask.		# return the first IP address that matches the subnet mask.
# If none match the subnet mask (or nmblookup doesn't print		# If none match the subnet mask (or nmblookup doesn't print
# the subnet mask) then just the first IP address is returned.		# the subnet mask) then just the first IP address is returned.
#		#
sub NetBiosHostIPFind		sub NetBiosHostIPFind
{		{
my($bpc, $host) = @_;		my($bpc, $host) = @_;
my($netBiosHostName, $netBiosUserName);		my($netBiosHostName, $netBiosUserName);
my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);		my($s, $nmbCmd, $subnet, $ipAddr, $firstIpAddr);
#		#
# Skip NetBios lookup if NmbLookupFindHostCmd is empty		# Skip NetBios lookup if NmbLookupFindHostCmd is empty
#		#
if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {		if ( $bpc->{Conf}{NmbLookupFindHostCmd} eq "" ) {
print(STDERR "NetBiosHostIPFind: return $host because"		print(STDERR "NetBiosHostIPFind: return $host because \$Conf{NmbLookupFi
. " \$Conf{NmbLookupFindHostCmd} is empty\n")		ndHostCmd} is empty\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
return $host;		return $host;
}		}
my $args = {		my $args = {
nmbLookupPath => $bpc->{Conf}{NmbLookupPath},		nmbLookupPath => $bpc->{Conf}{NmbLookupPath},
host => $host,		host => $host,
};		};
$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);		$nmbCmd = $bpc->cmdVarSubstitute($bpc->{Conf}{NmbLookupFindHostCmd}, $args);
foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef,		foreach my $resp ( split(/[\n\r]+/, $bpc->cmdSystemOrEval($nmbCmd, undef, $a
$args) ) ) {		rgs)) ) {
if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {		if ( $resp =~ /querying\s+\Q$host\E\s+on\s+(\d+\.\d+\.\d+\.\d+)/i ) {
$subnet = $1;		$subnet = $1;
$subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );		$subnet = $1 if ( $subnet =~ /^(.*?)(\.255)+$/ );
} elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {		} elsif ( $resp =~ /^\s*(\d+\.\d+\.\d+\.\d+)\s+\Q$host/ ) {
my $ip = $1;		my $ip = $1;
$firstIpAddr = $ip if ( !defined($firstIpAddr) );		$firstIpAddr = $ip if ( !defined($firstIpAddr) );
$ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );		$ipAddr = $ip if ( !defined($ipAddr) && $ip =~ /^\Q$subnet/ );
}		}
}		}
$ipAddr = $firstIpAddr if ( !defined($ipAddr) );		$ipAddr = $firstIpAddr if ( !defined($ipAddr) );
if ( defined($ipAddr) ) {		if ( defined($ipAddr) ) {
print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for"		print(STDERR "NetBiosHostIPFind: found IP address $ipAddr for host $host
. " host $host\n") if ( $bpc->{verbose} );		\n") if ( $bpc->{verbose} );
return $ipAddr;		return $ipAddr;
} else {		} else {
print(STDERR "NetBiosHostIPFind: couldn't find IP address for"		print(STDERR "NetBiosHostIPFind: couldn't find IP address for" . " host
. " host $host\n") if ( $bpc->{verbose} );		$host\n") if ( $bpc->{verbose} );
return;		return;
}		}
}		}
sub fileNameEltMangle		sub fileNameEltMangle
{		{
my($bpc, $name) = @_;		my($bpc, $name) = @_;
return "" if ( $name eq "" );		return "" if ( $name eq "" );
$name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;		$name =~ s{([%/\n\r])}{sprintf("%%%02x", ord($1))}eg;
return "f$name";		return "f$name";
skipping to change at line 1056		skipping to change at line 1047
# For printing exec commands (which don't use a shell) so they look like		# For printing exec commands (which don't use a shell) so they look like
# a valid shell command this function should be called with the exec		# a valid shell command this function should be called with the exec
# args. The shell command string is returned.		# args. The shell command string is returned.
#		#
sub execCmd2ShellCmd		sub execCmd2ShellCmd
{		{
my($bpc, @args) = @_;		my($bpc, @args) = @_;
my $str;		my $str;
foreach my $a ( @args ) {		foreach my $a ( @args ) {
$str .= " " if ( $str ne "" );		$str .= " " if ( $str ne "" );
$str .= $bpc->shellEscape($a);		$str .= $bpc->shellEscape($a);
}		}
return $str;		return $str;
}		}
#		#
# Do a URI-style escape to protect/encode special characters		# Do a URI-style escape to protect/encode special characters
#		#
sub uriEsc		sub uriEsc
{		{
my($bpc, $s) = @_;		my($bpc, $s) = @_;
skipping to change at line 1098		skipping to change at line 1089
my(@cmd);		my(@cmd);
#		#
# Return without any substitution if the first entry starts with "&",		# Return without any substitution if the first entry starts with "&",
# indicating this is perl code.		# indicating this is perl code.
#		#
if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {		if ( (ref($template) eq "ARRAY" ? $template->[0] : $template) =~ /^\&/ ) {
return ref($template) eq "ARRAY" ? $template : [$template];		return ref($template) eq "ARRAY" ? $template : [$template];
}		}
if ( ref($template) ne "ARRAY" ) {		if ( ref($template) ne "ARRAY" ) {
#		#
# Split at white space, except if escaped by \		# Split at white space, except if escaped by \
#		#
$template = [split(/(?<!\\)\s+/, $template)];		$template = [split(/(?<!\\)\s+/, $template)];
#		#
# Remove the \ that escaped white space.		# Remove the \ that escaped white space.
#		#
foreach ( @$template ) {		foreach ( @$template ) {
s{\\(\s)}{$1}g;		s{\\(\s)}{$1}g;
}		}
}		}
#		#
# Merge variables into @cmd		# Merge variables into @cmd
#		#
foreach my $arg ( @$template ) {		foreach my $arg ( @$template ) {
#		#
# Replace $VAR with ${VAR} so that both types of variable		# Replace $VAR with ${VAR} so that both types of variable
skipping to change at line 1158		skipping to change at line 1149
#		#
# @args are optional arguments for the eval() case; they are not used		# @args are optional arguments for the eval() case; they are not used
# for exec().		# for exec().
#		#
sub cmdExecOrEval		sub cmdExecOrEval
{		{
my($bpc, $cmd, @args) = @_;		my($bpc, $cmd, @args) = @_;
if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {		if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
$cmd = join(" ", @$cmd) if ( ref($cmd) eq "ARRAY" );		$cmd = join(" ", @$cmd) if ( ref($cmd) eq "ARRAY" );
print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")		print(STDERR "cmdExecOrEval: about to eval perl code $cmd\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
eval($cmd);		eval($cmd);
print(STDERR "Perl code fragment for exec shouldn't return!!\n");		print(STDERR "Perl code fragment for exec shouldn't return!!\n");
POSIX::_exit(1);		POSIX::_exit(1);
} else {		} else {
$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );		$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
print(STDERR "cmdExecOrEval: about to exec ",		print(STDERR "cmdExecOrEval: about to exec ", $bpc->execCmd2ShellCmd(@$c
$bpc->execCmd2ShellCmd(@$cmd), "\n")		md), "\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
alarm(0);		alarm(0);
$cmd = [map { m/(.*)/ } @$cmd]; # untaint		$cmd = [map {m/(.*)/} @$cmd]; # untaint
#		#
# force list-form of exec(), ie: no shell even for 1 arg		# force list-form of exec(), ie: no she
#		ll even for 1 arg
exec { $cmd->[0] } @$cmd;		#
		exec {$cmd->[0]} @$cmd;
print(STDERR "Exec failed for @$cmd\n");		print(STDERR "Exec failed for @$cmd\n");
POSIX::_exit(1);		POSIX::_exit(1);
}		}
}		}
#		#
# System or eval a command. $cmd is either a string on an array ref.		# System or eval a command. $cmd is either a string on an array ref.
# $stdoutCB is a callback for output generated by the command. If it		# $stdoutCB is a callback for output generated by the command. If it
# is undef then output is returned. If it is a code ref then the function		# is undef then output is returned. If it is a code ref then the function
# is called with each piece of output as an argument. If it is a scalar		# is called with each piece of output as an argument. If it is a scalar
skipping to change at line 1200		skipping to change at line 1190
#		#
sub cmdSystemOrEvalLong		sub cmdSystemOrEvalLong
{		{
my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_;		my($bpc, $cmd, $stdoutCB, $ignoreStderr, $pidHandlerCB, @args) = @_;
my($pid, $out, $allOut);		my($pid, $out, $allOut);
local(*CHILD);		local(*CHILD);
$? = 0;		$? = 0;
if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {		if ( (ref($cmd) eq "ARRAY" ? $cmd->[0] : $cmd) =~ /^\&/ ) {
$cmd = join(" ", @$cmd) if ( ref($cmd) eq "ARRAY" );		$cmd = join(" ", @$cmd) if ( ref($cmd) eq "ARRAY" );
print(STDERR "cmdSystemOrEval: about to eval perl code $cmd\n")		print("cmdSystemOrEval: about to eval perl code $cmd\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
$out = eval($cmd);		$out = eval($cmd);
$$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );		$$stdoutCB .= $out if ( ref($stdoutCB) eq 'SCALAR' );
&$stdoutCB($out) if ( ref($stdoutCB) eq 'CODE' );		if ( ref($stdoutCB) eq 'CODE' ) {
#print(STDERR "cmdSystemOrEval: finished: got output $out\n")		if ( $out !~ /\n$/ ) {
# if ( $bpc->{verbose} );		if ( $@ ) {
return $out if ( !defined($stdoutCB) );		&$stdoutCB("Eval return value: $out; perl error $@\n");
return;		} else {
		&$stdoutCB("Eval return value: $out\n");
		}
		} else {
		&$stdoutCB($out);
		}
		}
		#print(STDERR "cmdSystemOrEval: finished: got output $out\n")
		# if ( $bpc->{verbose} );
		return $out if ( !defined($stdoutCB) );
		return;
} else {		} else {
$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );		$cmd = [split(/\s+/, $cmd)] if ( ref($cmd) ne "ARRAY" );
print(STDERR "cmdSystemOrEval: about to system ",		print(STDERR "cmdSystemOrEval: about to system ", $bpc->execCmd2ShellCmd
$bpc->execCmd2ShellCmd(@$cmd), "\n")		(@$cmd), "\n")
if ( $bpc->{verbose} );		if ( $bpc->{verbose} );
if ( !defined($pid = open(CHILD, "-|")) ) {		if ( !defined($pid = open(CHILD, "-|")) ) {
my $err = "Can't fork to run @$cmd\n";		my $err = "Can't fork to run @$cmd\n";
$? = 1;		$? = 1;
$$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );		$$stdoutCB .= $err if ( ref($stdoutCB) eq 'SCALAR' );
&$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );		&$stdoutCB($err) if ( ref($stdoutCB) eq 'CODE' );
return $err if ( !defined($stdoutCB) );		return $err if ( !defined($stdoutCB) );
return;		return;
}		}
if ( !$pid ) {		if ( !$pid ) {
#		#
# This is the child		# This is the child
#		#
close(STDERR);		close(STDERR);
if ( $ignoreStderr ) {		if ( $ignoreStderr ) {
open(STDERR, ">", "/dev/null");		open(STDERR, ">", "/dev/null");
} else {		} else {
open(STDERR, ">&STDOUT");		open(STDERR, ">&STDOUT");
}		}
alarm(0);		alarm(0);
$cmd = [map { m/(.*)/ } @$cmd]; # untaint		$cmd = [map {m/(.*)/} @$cmd]; # untaint
#
# force list-form of exec(), ie: no shell even for 1 arg		#
#		# force list-form of exec(), ie: no shell even for 1 arg
exec { $cmd->[0] } @$cmd;		#
		exec {$cmd->[0]} @$cmd;
print(STDERR "Exec of @$cmd failed\n");		print(STDERR "Exec of @$cmd failed\n");
POSIX::_exit(1);		POSIX::_exit(1);
}		}
#		#
# Notify caller of child's pid		# Notify caller of child's pid
#		#
&$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" );		&$pidHandlerCB($pid) if ( ref($pidHandlerCB) eq "CODE" );
#		#
# The parent gathers the output from the child		# The parent gathers the output from the child
#		#
binmode(CHILD);		binmode(CHILD);
while ( <CHILD> ) {		while ( <CHILD> ) {
$$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );		$$stdoutCB .= $_ if ( ref($stdoutCB) eq 'SCALAR' );
&$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );		&$stdoutCB($_) if ( ref($stdoutCB) eq 'CODE' );
$out .= $_ if ( !defined($stdoutCB) );		$out .= $_ if ( !defined($stdoutCB) );
$allOut .= $_ if ( $bpc->{verbose} );		$allOut .= $_ if ( $bpc->{verbose} );
}		}
$? = 0;		$? = 0;
close(CHILD);		close(CHILD);
}		}
#print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")		#print(STDERR "cmdSystemOrEval: finished: got output $allOut\n")
# if ( $bpc->{verbose} );		# if ( $bpc->{verbose} );
return $out;		return $out;
}		}
#		#
# The shorter version that sets $ignoreStderr = 0, ie: merges stdout		# The shorter version that sets $ignoreStderr = 0, ie: merges stdout
# and stderr together.		# and stderr together.
#		#
skipping to change at line 1284		skipping to change at line 1284
}		}
#		#
# Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}		# Promotes $conf->{BackupFilesOnly}, $conf->{BackupFilesExclude}
# to hashes and $conf->{$shareName} to an array.		# to hashes and $conf->{$shareName} to an array.
#		#
sub backupFileConfFix		sub backupFileConfFix
{		{
my($bpc, $conf, $shareName) = @_;		my($bpc, $conf, $shareName) = @_;
$conf->{$shareName} = [ $conf->{$shareName} ]		$conf->{$shareName} = [$conf->{$shareName}]
if ( ref($conf->{$shareName}) ne "ARRAY" );		if ( ref($conf->{$shareName}) ne "ARRAY" );
foreach my $param ( qw(BackupFilesOnly BackupFilesExclude) ) {		foreach my $param ( qw(BackupFilesOnly BackupFilesExclude) ) {
next if ( !defined($conf->{$param}) );		next if ( !defined($conf->{$param}) );
if ( ref($conf->{$param}) eq "HASH" ) {		if ( ref($conf->{$param}) eq "HASH" ) {
#		#
# A "*" entry means wildcard - it is the default for		# A "*" entry means wildcard - it is the default for
# all shares. Replicate the "*" entry for all shares,		# all shares. Replicate the "*" entry for all shares,
# but still allow override of specific entries.		# but still allow override of specific entries.
#		#
next if ( !defined($conf->{$param}{"*"}) );		next if ( !defined($conf->{$param}{"*"}) );
$conf->{$param} = {		$conf->{$param} = {map({ $_ => $conf->{$param}{"*"} } @{$conf->{$sha
map({ $_ => $conf->{$param}{"*"} }		reName}}), %{$conf->{$param}}};
@{$conf->{$shareName}}),
%{$conf->{$param}}
};
} else {		} else {
$conf->{$param} = [ $conf->{$param} ]		$conf->{$param} = [$conf->{$param}]
if ( ref($conf->{$param}) ne "ARRAY" );		if ( ref($conf->{$param}) ne "ARRAY" );
$conf->{$param} = { map { $_ => $conf->{$param} }		$conf->{$param} = {map { $_ => $conf->{$param} } @{$conf->{$shareNam
@{$conf->{$shareName}} };		e}}};
}		}
}		}
}		}
#		#
# This is sort() compare function, used below.		# This is sort() compare function, used below.
#		#
# New client LOG names are LOG.MMYYYY. Old style names are		# New client LOG names are LOG.MMYYYY. Old style names are
# LOG, LOG.0, LOG.1 etc. Sort them so new names are		# LOG, LOG.0, LOG.1 etc. Sort them so new names are
# first, and newest to oldest.		# first, and newest to oldest.
skipping to change at line 1377		skipping to change at line 1372
return sort compareLOGName @files;		return sort compareLOGName @files;
}		}
#		#
# Opens a writeable file handle to the per-client's LOG file.		# Opens a writeable file handle to the per-client's LOG file.
# Also ages LOG files if the LOG file is new		# Also ages LOG files if the LOG file is new
#		#
sub openPCLogFile		sub openPCLogFile
{		{
my($bpc, $client) = @_;		my($bpc, $client) = @_;
my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);		my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime( time);
my $logPath = sprintf("%s/pc/%s/LOG.%02d%04d", $bpc->{TopDir}, $client, $mon + 1, $year + 1900);		my $logPath = sprintf("%s/pc/%s/LOG.%02d%04d", $bpc->{TopDir}, $client, $mon + 1, $year + 1900);
my $logFd;		my $logFd;
if ( !-f $logPath ) {		if ( !-f $logPath ) {
#		#
# Compress and prune old log files		# Compress and prune old log files
#		#
my $lastLog = $bpc->{Conf}{MaxOldPerPCLogFiles} - 1;		my $lastLog = $bpc->{Conf}{MaxOldPerPCLogFiles} - 1;
foreach my $file ( $bpc->sortedPCLogFiles($client) ) {		foreach my $file ( $bpc->sortedPCLogFiles($client) ) {
if ( $lastLog <= 0 ) {		if ( $lastLog <= 0 ) {
unlink($file);		unlink($file);
next;		next;
}		}
$lastLog--;		$lastLog--;
next if ( $file =~ /\.z$/ || !$bpc->{Conf}{CompressLevel} );		next if ( $file =~ /\.z$/ || !$bpc->{Conf}{CompressLevel} );
BackupPC::XS::compressCopy($file,		BackupPC::XS::compressCopy($file, "$file.z", undef, $bpc->{Conf}{Com
"$file.z",		pressLevel}, 1);
undef,
$bpc->{Conf}{CompressLevel}, 1);
}		}
}		}
open($logFd, ">>", $logPath);		open($logFd, ">>", $logPath);
return ($logFd, $logPath);		return ($logFd, $logPath);
}		}
#		#
# converts a glob-style pattern into a perl regular expression.		# converts a glob-style pattern into a perl regular expression.
#		#
sub glob2re		sub glob2re
{		{
my ( $bpc, $glob ) = @_;		my($bpc, $glob) = @_;
my ( $char, $subst );		my($char, $subst);
# $escapeChars escapes characters with no special glob meaning but		# $escapeChars escapes characters with no special glob meaning but
# have meaning in regexps.		# have meaning in regexps.
my $escapeChars = [ '.', '/', ];		my $escapeChars = ['.', '/'];
# $charMap is where we implement the special meaning of glob		# $charMap is where we implement the special meaning of glob
# patterns and translate them to regexps.		# patterns and translate them to regexps.
my $charMap = {		my $charMap = {
'?' => '[^/]',		'?' => '[^/]',
'*' => '[^/]*', };		'*' => '[^/]*',
		};
# multiple forward slashes are equivalent to one slash. We should		# multiple forward slashes are equivalent to one slash. We should
# never have to use this.		# never have to use this.
$glob =~ s/\/+/\//;		$glob =~ s/\/+/\//;
foreach $char (@$escapeChars) {		foreach $char ( @$escapeChars ) {
$glob =~ s/\Q$char\E/\\$char/g;		$glob =~ s/\Q$char\E/\\$char/g;
}		}
while ( ( $char, $subst ) = each(%$charMap) ) {		while ( ($char, $subst) = each(%$charMap) ) {
$glob =~ s/(?<!\\)\Q$char\E/$subst/g;		$glob =~ s/(?<!\\)\Q$char\E/$subst/g;
}		}
return $glob;		return $glob;
}		}
sub flushXSLibMesgs()		sub flushXSLibMesgs()
{		{
my $msg = BackupPC::XS::Lib::logMsgGet();		my $msg = BackupPC::XS::Lib::logMsgGet();
return if ( !defined($msg) );		return if ( !defined($msg) );
End of changes. 67 change blocks.
207 lines changed or deleted		220 lines changed or added

---