backuppc-deletefile : première correction...

[auf-serveur.git] / backuppc-deletefile / jLib.pm

#============================================================= -*-perl-*-
#
# BackupPC::jLib package
#
# DESCRIPTION
#
#   This library includes various supporting subroutines for use with BackupPC
#   functions used by BackupPC.
#   Some of the routines are variants/extensions of routines originally written
#   by Craig Barratt as part of the main BackupPC release.
#
# AUTHOR
#   Jeff Kosowsky
#
# COPYRIGHT
#   Copyright (C) 2008-2011  Jeff Kosowsky
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#========================================================================
#
# Version 0.4.0, released January 2011
#
#========================================================================

package BackupPC::jLib;

use strict;
use vars qw($VERSION);
$VERSION = '0.4.0';

use warnings;
use File::Copy;
use File::Path;
use File::Temp;
use Fcntl;  #Required for RW I/O masks

use BackupPC::Lib;
use BackupPC::Attrib;
use BackupPC::FileZIO;
use Data::Dumper;  #Just used for debugging...

no utf8;

use constant _128KB               => 131072;
use constant _1MB                 => 1048576;
use constant LINUX_BLOCK_SIZE     => 4096;
use constant TOO_BIG              => 2097152; # 1024*1024*2 (2MB)

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(
       %Conf $dryrun $errorcount
       LINUX_BLOCK_SIZE TOO_BIG
       printerr warnerr firstbyte
       zFile2MD5 zFile2FullMD5
       link_recursively_topool
       jfileNameUnmangle
       getattr read_attrib count_file_attribs
       get_bakinfo get_file_attrib get_attrib_value get_attrib_type
       write_attrib write_file_attrib
       attrib
       GetPoolLink jMakeFileLink
       poolname2number renumber_pool_chain delete_pool_file
       run_nightly
       jcompare zcompare zcompare2
       delete_files touch
       jcopy jlink junlink jmkdir jmkpath jmake_path jrename jrmtree);

#Global variables
our %Conf;
our $errorcount=0;
our $dryrun=1;  #global variable - set to 1 to be safe -- should be set to
				#0 in actual program files if you don't want a dry-run
                #None of the routines below will change/delete/write actual
                #file data if this flag is set. The goal is to do everything but
                #the final write to assist with debugging or cold feet :)

sub printerr
{
	print "ERROR: " . $_[0];
	$errorcount++;
}

sub warnerr
{
	$|++; # flush printbuffer first
	warn "ERROR: " . $_[0];
	$errorcount++;
}

# Returns the firstbyte of a file.
# If coding $coding undefined or 0, return as unpacked 2 char hexadecimal
# string. Otherwise, return as binary byte.
# Return -1 on error.
# Useful for checking the type of compressed file/checksum coding.
sub firstbyte {
	my ($file, $coding) = @_;
	my $fbyte='';
	sysopen(my $fh, $file, O_RDONLY) || return -1;
	$fbyte = -1 unless sysread($fh, $fbyte, 1) == 1;
	close($fh);
	if (! defined($coding) || $coding == 0) {
		$fbyte = unpack('H*',$fbyte); # Unpack as 2 char hexadecimal string
	}
	else {
		$fbyte = vec($fbyte, 0, 8);  # Return as binary byte
	}
	return $fbyte;
}

# Compute the MD5 digest of a compressed file. This is the compressed
# file version of the Lib.pm function File2MD5.
# For efficiency we don't use the whole file for big files
#   - for files <= 256K we use the file size and the whole file.
#   - for files <= 1M we use the file size, the first 128K and
#     the last 128K.
#   - for files > 1M, we use the file size, the first 128K and
#     the 8th 128K (ie: the 128K up to 1MB).
# See the documentation for a discussion of the tradeoffs in
# how much data we use and how many collisions we get.
#
# Returns the MD5 digest (a hex string) and the file size if suceeeds.
# (or "" and error code if fails).
# Note return for a zero size file is ("", 0).
#
# If $size < 0 then calculate size of file by fully decompressing
# If $size = 0 then first try to read corresponding attrib file
#    (if it exists), if doesn't work then calculate by fully decompressing
# IF $size >0 then use that as the size of the file
#
# If compreslvl is undefined then use the default compress level from 
# the config file

sub zFile2MD5
{
    my($bpc, $md5, $name, $size, $compresslvl) = @_;
	
	my ($fh, $rsize, $filesize, $md5size);

	return ("", -1) unless -f $name;
	return ("", 0) if (stat(_))[7] == 0;  #Zero size file
	$compresslvl = $Conf{CompressLevel} unless defined $compresslvl;
	unless (defined ($fh = BackupPC::FileZIO->open($name, 0, $compresslvl))) {
		printerr "Can't open $name\n";
		return ("", -1);
	}

	my ($datafirst, $datalast);
	my @data;
	#First try to read up to the first 128K (131072 bytes)
	if ( ($md5size = $fh->read(\$datafirst, _128KB)) < 0 ) { #Fist 128K
		printerr "Can't read & decompress $name\n";
		return ("", -1);
	}

	if ($md5size == _128KB) { # If full read, continue reading up to 1st MB
		my $i=0;
		#Read in up to 1MB (_1MB), 128K at a time and alternate between 2 data buffers
		while ( ($rsize = $fh->read(\$data[(++$i)%2], _128KB)) == _128KB
				&&  ($md5size += $rsize) < _1MB ) {}
		$md5size +=$rsize if $rsize < _128KB; # Add back in partial read
	    $datalast = ($i > 1 ? 
					 substr($data[($i-1)%2], $rsize, _128KB-$rsize) : '')
			. substr($data[$i%2], 0 ,$rsize); #Last 128KB (up to 1MB)
    }
	if($md5size < _1MB) { #Already know the size because read it all (note don't do <=)
		$filesize = $md5size;
	} elsif($size > 0) {  #Use given size
		$filesize = $size;
	} elsif($compresslvl == 0) { #Not compressed, so: size = actual size
		$filesize = -s $name;
	}elsif($size == 0) { # Try to find size from attrib file
		$filesize = get_attrib_value($name, "size");
		if(!defined($filesize)) {
			warn "Can't read size of $name from attrib file so calculating manually\n";
		}
	}
	if(!defined($filesize)) { #No choice but continue reading to find size
		$filesize = $md5size;
		while (($rsize = $fh->read(\($data[0]), _128KB)) > 0) {
			$filesize +=$rsize;
        }
   }
   $fh->close();

   $md5->reset();
   $md5->add($filesize);
   $md5->add($datafirst);
   $md5->add($datalast) if defined($datalast);
   return ($md5->hexdigest, $filesize);
}

#Compute md5sum of the full data contents of a file.
#If the file is compressed, calculate the md5sum of the inflated
#version (using the zlib routines to uncompress the stream). Note this
#gives the md5sum of the FULL file -- not just the partial file md5sum
#above.
sub zFile2FullMD5
{
    my($bpc, $md5, $name, $compresslvl) = @_;

	my $fh;
	my $data;

	$compresslvl = $Conf{CompressLevel} unless defined $compresslvl;
	unless (defined ($fh = BackupPC::FileZIO->open($name, 0, $compresslvl))) {
		printerr "Can't open $name\n";
		return -1;
	}

	$md5->reset();	
	while ($fh->read(\$data, 65536) > 0) {
		$md5->add($data);
	}

    return $md5->hexdigest;
}


# Like MakeFileLink but for existing files where we don't have the
# digest available. So compute digest and call MakeFileLink after
# 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
# the pool.  Otherwise, if the newFile flag is set, make a
# hardlink in the pool to the new file.
#
# Returns 0 if a link should be made to a new file (ie: when the file
#    is a new file but the newFile flag is 0).
# Returns 1 if a link to an existing file is made,
# Returns 2 if a link to a new file is made (only if $newFile is set)
# Returns negative on error.
sub zMakeFileLink
{
    my($bpc, $md5, $name, $newFile, $compress) = @_;

	$compress = $Conf{CompressLevel} unless defined $compress;

	my ($d,$ret) = zFile2MD5($bpc, $md5, $name, 0, $compress);
	return -5 if $ret < 0;
	$bpc->MakeFileLink($name, $d, $newFile, $compress);
}


# Use the following to create a new file link ($copy) that links to
# the same pool file as the original ($orig) file does (or
# should). i.e. this doesn't assume that $orig is properly linked to
# the pool. This is computationally more costly than just making the
# link, but will avoid further corruption whereby you get archive
# files with multiple links to each other but no link to pool.

# First, check if $orig links to the pool and if not create a link
# via MakeFileLink.  Don't create a new pool entry if newFile is zero.
# If a link either already exists from the original to the pool or if
# one was successfully created, then simply link $copy to the same
# pool entry.  Otherwise, just copy (don't link) $orig to $copy
# and leave it unlinked to the pool.  

# Note that checking whether $orig is linked to the pool is
# cheaper than running MakeFileLink since we only need the md5sum
# checksum.
# Note we assume that the attrib entry for $orig (if it exists) is
# correct, since we use that as a shortcut to determine the filesize 
# (via zFile2MD5)
# Returns 1 if a link to an existing file is made,
# Returns 2 if a link to a new file is made (only if $newFile is set)
# Returns 0 if file was copied (either because MakeFileLink failed or 
#   because newFile=0 and no existing pool match
# Returns negative on error.
sub zCopyFileLink 
{
	my ($bpc, $orig, $copy, $newFile, $compress) = @_;
	my $ret=1;
	$compress = $Conf{CompressLevel} unless defined $compress;
	my $md5 = Digest::MD5->new;
	my ($md5sum, $md5ret) = zFile2MD5($bpc, $md5, $orig, 0, $compress);

    #If $orig is already properly linked to the pool (or linkable to pool after running 
	#MakeFileLink on $orig) and HardLinkMax is not exceeded, then just link to $orig.
	if($md5ret > 0) { #If valid md5sum and non-zero length file (so should be linked to pool)...
		if((GetPoolLinkMD5($bpc, $orig, $md5sum, $compress, 0) == 1 || #If pool link already exists
			($ret = $bpc->MakeFileLink($orig, $md5sum, $newFile, $compress))> 0) #or creatable by MakeFileLink
		   && (stat($orig))[3] < $bpc->{Conf}{HardLinkMax}) {     # AND (still) less than max links
			return $ret if link($orig, $copy); # Then link from copy to orig
		}
	}
	if(copy($orig, $copy) == 1) { #Otherwise first copy file then try to link the copy to pool
		if($md5ret > 0 && ($ret = $bpc->MakeFileLink($copy, $md5sum, $newFile, $compress))> 0) {
			return 2; #Link is to a new copy
		}
		printerr "Failed to link copied file to pool: $copy\n";	
		return 0; #Copy but not linked
	}
	die "Failed to link or copy file: $copy\n";	
	return -1;
}

# Copy $source to $target, recursing down directory trees as
# needed. The 4th argument if non-zero, means (for files) use
# zCopyFileLink to make sure that everything is linked properly to the
# pool; otherwise, just do a simple link. The 5th argument $force,
# will erase a target directory if already present, otherwise an error
# is signalled. The final 6th argument is the CompressionLevel which
# can be left out and will the be calculated from
# bpc->Conf{CompressLevel}

# Note the recursion is set up so that the return is negative if
# error, positive if consistent with a valid pool link (i.e. zero
# length file or directories are consistent too), and zero if
# successful but not consistent with a valid pool.  The overall result
# is -1 if there is any error and otherwise the AND'ed result of the
# operations. That means if the overall result is positive then the
# whole tree is successfully linked to the pool, so the next time
# around we can use a simple linking (i.e $linkcheck=0).  Note $source
# and $target must be full paths from root.  Note: if files are not
# compressed properly then you won't be able to link them to pool.
sub link_recursively_topool
{
    my ($bpc, $source, $target, $linkcheck, $force, $compress) = @_;
	my $ret=1;
	die "Error: '$source' doesn't exist" unless -e $source;
	if (-e $target) {
		die "Error can't overwrite: $target (unless 'force' set)\n" unless $force;
		die "Error can't remove: $target ($!)\n"  unless rmtree($target, 0, 0);
	}
	if (-d $source) {
		die "Error: mkdir failed to create new directory: $target ($!)\n"
			unless jmkdir($target);
		opendir( my $dh, $source) || die "Error: Could not open dir $source ($!)\n";
		foreach my $elem (readdir($dh)) {
            next if /^\.\.?$/;     # skip dot files (. and ..)
			my $newsource = "$source/$elem";
			my $newtarget = "$target/$elem";
            my $newret = link_recursively_topool($bpc, $newsource, $newtarget, $linkcheck, $force, $compress);
			if ($newret < 0) { #Error so break out of loop & return
				closedir $dh;
				return -1 
			}
			$ret = 0 if $newret == 0; #note $ret stays at 1 only if no elements return -1 or 0
        }
		closedir $dh;
		return $ret;
	}
	elsif ($dryrun) {return 1} # Return before making changes to filesystem
	elsif ( ! -s $source) { # zero size
		copy($source, $target); #No link since zero size
	}
	elsif ($linkcheck) { #Makes sure first that source properly linked to pool
		return(zCopyFileLink($bpc, $source, $target, 1, $compress));
	}
	else {#Otherwise, OK to perform simple link to source
		return (link($source, $target) == 1 ? 1 : -1)
	}
}

sub get_bakinfo
{
	my ($bakinfofile, $entry) = @_;
	our %backupInfo = ();

	$bakinfofile .= "/backupInfo";
	warn "Can't read $bakinfofile\n" unless -f $bakinfofile;

	unless (my $ret = do $bakinfofile) { # Load  the backupInfo file
		if ($@) {
			warn "couldn't parse $bakinfofile: $@\n";
		}
		elsif (!defined $ret) {
			warn "couldn't do $bakinfofile: $!\n";
		}
		elsif (! $ret) {
			warn "couldn't run $bakinfofile\n";
		}
	}
	my $value = $backupInfo{$entry};
	warn "$bakinfofile is empty or missing entry for '$entry'\n"  
		unless defined $value;
	return $value;
}

# Note: getattr($attr) =$attr->{files} 
#       getattr($attr, $file) =$attr->{files}{$file}
#       getattr($attr, $file, $attribute)  =$attr->{files}{$file}{$attribute}

sub getattr
{
    my($attr, $fileName, $Attribute) = @_;
    return $attr->{files}{$fileName}{$Attribute} if ( defined($Attribute) );
    return $attr->{files}{$fileName} if ( defined($fileName) );
    return $attr->{files};
}


#Reads in the attrib file for directory $_[1] and (optional alternative 
#attrib file name $_[2]) and #stores it in the hashref $_[0] passed to 
#the function
#Returns -1 and a blank $_[0] hash ref if attrib file doesn't exist 
#already (not necessarily an error)
#Dies if attrib file exists but can't be read in.
sub read_attrib
{ 
#Note: $_[0] = hash reference to attrib object
#SO DO NOT USE LOCAL VARIABLE FOR IT (i.e. don't do my $attr=$_[0]
	$_[0] = BackupPC::Attrib->new({ compress => $Conf{CompressLevel} });

#	unless (defined $_[1]) { #JJK: DEBUGGING
#		print "read_attrib: \$_[1] undefined\n";
#		print Dumper @_;
#	}
	return -1 unless -f attrib($_[1], $_[2]);
    #This is not necessarily an error because dir may be empty

	$_[0]->read($_[1],$_[2]) or
		die "Error: Cannot read attrib file: " . attrib($_[1],$_[2]) . "\n";

	return 1;
}

#Same as Lib.pm fileNameUnmangle but doesn't require
#unneccessary '$bpc'
sub jfileNameUnmangle {
    my($name) = @_;

    $name =~ s{/f}{/}g;
    $name =~ s{^f}{};
    $name =~ s{%(..)}{chr(hex($1))}eg;
    return $name;
}
	
sub count_file_attribs
{
	my ($attrib) = @_;
	return( scalar (keys (%{$attrib->get()})));
}

# Get attrib entry for $fullfilname. The corresponding hash is both returned and
# also fills the hash reference (optionally) passed via $fileattrib.
# If attrib file not present, return -1 (which may not be an error)
# Returns -2 if not a mangled file
# Dies if error
sub get_file_attrib
{
	my ($fullfilename, $fileattrib) = @_;
	$fullfilename =~ m{(.+)/(.+)};  #1=dir; $2=file
	return -2 unless defined $2;

	return -1 if read_attrib(my $attr, $1) < 0;

	%{$fileattrib} =  %{$attr->{files}{jfileNameUnmangle($2)}};
	#Note unmangling removes initial 'f' AND undoes char mapping
}

# Returns value of attrib $key for $fullfilename (full path)
# If not a mangled file or attrib file not present or there is not an
# entry for the specificed key for the given file, then return 'undef'
sub get_attrib_value
{
	my ($fullfilename, $key) = @_;
	$fullfilename =~ m{(.+)/(.+)};  #1=dir; $2=file

	return undef unless defined $2;
	return undef if read_attrib(my $attr, $1) < 0;
	return $attr->{files}{jfileNameUnmangle($2)}{$key}; 
    #Note this returns undefined if key not present
	#Note unmangling removes initial 'f' AND undoes char mapping
}

# Returns value of attrib type key for $fullfilename (full path)
# If attrib file present but filename not an entry, return -1 [not an error if file nonexistent]
# If no attrib file (but directory exists), return -2 [not an error if directory empty]
# If directory non-existent, return -3
# If attrib file present but not readble, return -4 [true error]
# Note there may an entry even if file non-existent (e.g. type 10 = delete)
sub get_attrib_type
{
	my ($fullfilename) = @_;
	$fullfilename =~ m{(.+)/(.+)};  #1=dir; $2=file

#	unless (defined $1) { #JJK: DEBUGGING
#		print "get_attrib_type: \$1 undefined\n";
#		print Dumper @_;
#	}

	return -3 unless -d $1;
	return -2 unless -f attrib($1);
	return -4 unless read_attrib(my $attr, $1) >= 0;
	my $type = $attr->{files}{jfileNameUnmangle($2)}{type};
	#Note unmangling removes initial 'f' AND undoes char mapping
	return (defined($type) ? $type : -1);
}

# 4th argument $poollink says whether to write to file (0) or link to
# pool (using MakeFileLink).
# 5th argument tells what to do if no files in $attrib 
# (0=return error, 1=delete attrib file and return success)
# 6th argument is an optional alternative name for the attrib file itself
# Note does an unlink first since if there are hard links, we don't want
# to modify them
# Returns positive if successful, 0 if not
# Specifically, 1 if linked to existing, 2 if linked to new, 
# 3 if written without linking, 4 if (empty) attrib file deleted

sub write_attrib
{
	my ($bpc, $attrib, $dir, $poollink, $delempty, $attfilename) = @_; 
	die "Error: Cannot write to directory: $dir\n" unless -w $dir;

#	unless (defined $dir) { #JJK: DEBUGGING
#		print "write_attrib: \$dir undefined";
#		print Dumper @_;
#	}

	my $attfilepath = attrib($dir, $attfilename);
	return 1 if $dryrun; #Return before writing changes
	die "Error: could not unlink old attrib file: $attfilepath\n"  
		if (-e $attfilepath && ! unlink($attfilepath)); #Delete old attrib file if exists cuz may be hard-linked
	return 4 if(count_file_attribs($attrib) == 0 && $delempty); #No attribs left so leave it unlinked
    die "Error: could not write to attrib file: $attfilepath\n"
		unless ($attrib->write($dir, $attfilename)) == 1; #First write a copy without linking
	my $ret=3;
	if ($poollink) {
		my $data = $attrib->writeData;
		my $md5 = Digest::MD5->new;
		my $digest;
		if(($digest = $bpc->Buffer2MD5($md5, length($data), \$data)) ne -1 
		   && ($ret = $bpc->MakeFileLink($attfilepath, $digest, 1, $Conf{CompressLevel})) <= 0) {
			printerr "Can't link attrib file to pool: $attfilepath ($ret)\n";
		}
	}
	return $ret;
}

# Write out $fileattrib for $file (without the mangle) to $dir/$attfilename (or
# to the default attribute file for $dir if $attfilename is undef)
# Reads in existing attrib file if pre-existing
# 4th argument $poollink says whether to write to file (0) or link to
# pool (using MakeFileLink).
# Returns positive if successful, 0 if not
# Specifically, 1 if linked to existing, 2 if linked to new,
# 3 if written without linking
sub write_file_attrib
{
    my ($bpc, $dir, $file, $fileattrib, $poollink, $attfilename) = @_; #Note $fileattrib is a hashref
	my $ret=0;

	read_attrib(my $attr, $dir, $attfilename); #Read in existing attrib file if it exists
	$ret = write_attrib($bpc, $attr, $dir, $poollink, 0, $attfilename) 
		if $attr->set($file, $fileattrib) > 0;

#	unless (defined $dir) { #JJK: DEBUGGING
#		print "write_file_attrib: \$dir undefined\n";
#		print Dumper @_;
#	}

	die "Error writing to '$file' entry to attrib file: " . attrib($dir, $attfilename) . "\n" unless $ret > 0;
	return $ret;
}

sub attrib
{
	return (defined($_[1]) ? "$_[0]/$_[1]" : "$_[0]/attrib");
}

# Modified version of MakeFileLink including:
# 1. Efficiency/clarity improvements
# 2. Calls GetPoolLink to find candidate link targets.
# 2. For non-compressed files, uses my improved jcompare comparison algorithm
# 3. For compressed files, uses zcompare2 which compares only the compressed
#    data sans first-byte header & potential rsync digest trailer. This allows
#    for matches even if one file has rsync digest and other does not
# 4. Moves file before unlinking in case subsequent link fails and needs to be 
#    undone
# 5. Added 6th input parameter to return pointer to the pool link name
# 6. Extended meaning of newFile flag
#      0 = Don't creat new pool file (as before)
#      1 = Create new pool file IF no other links to source file
#          (this was the previous behavior for whenever newFile was set)
#      >2 = Create new pool file EVEN if source file has more than one link
#          (this will by extension link other things linked to the source
#           also to the pool -- which means that the pool might not clean
#           if it links to things outside of the pc directory -- so 
#           use carefully
#  7. Includes 'j' versions of file routines to allow dryrun
#  8. Added check to see if already in pool and if so returns 3

# 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
# the pool.  Otherwise, if the newFile flag is set, make a
# hardlink in the pool to the new file.
#
# Returns 0 if a link should be made to a new file (ie: when the file
#    is a new file but the newFile flag is 0).
#    JJK: actually also if $name has nlinks >1 regardless of newFile flag
# Returns 1 if a link to an existing file is made,
# Returns 2 if a link to a new file is made (only if $newFile is set)
# Return 3 if first finds that already linked to ipool
# Returns negative on error.

sub jMakeFileLink
{
	my($bpc, $name, $d, $newFile, $compress, $linkptr) = @_;

	my $poollink;
	my $result=GetPoolLinkMD5($bpc, $name, $d, $compress, 1, \$poollink);
	$$linkptr = $poollink if defined($linkptr) && $result > 0;

	if($result == 1){ #Already linked to the pool
		return 3;
	}elsif($result == 2) { #Matches existing, linkable pool file
		my $tempname = mktemp("$name.XXXXXXXXXXXXXXXX");
		return -5 unless jrename($name, $tempname); #Temorarily save
		if(!jlink($poollink, $name)) { #Link pool to source
			jrename($tempname, $name); #Restore if can't link
			return -3;
		}
		junlink($tempname); #Safe to remove the original
		return 1;
	}elsif($result == 3) {
		if(defined($newFile) && #No link or match 
		   ($newFile > 1 || ($newFile == 1 && (stat($name))[3] == 1 ))) {
			$poollink =~ m|(.*)/|;
			jmkpath($1, 0, 0777) unless -d $1 ;
			return -4 unless jlink($name, $poollink);
			return 2;
		} else { #New link should have been made but told not to
			return 0;
		}
	}else {
		return -6; #Error from GetPoolLink call
	}
}

# GetPoolLink
# GetPoolLinkMD5
#Find the pool/cpool file corresponding to file $name.
#1. First iterates entire chain to see if *same inode* is present. I.e. if 
#   already linked to the pool. If so, it returns the first instance. 
#   Return = 1 and $Poolpathptr = name of the hard-linked match
#2. If $compareflg is set, then iterate through again this time looking for
#   file *content* matches (this is much slower). 
#   If so, it returns the first instance with Nlinks < HardLinkMax
#   Return = 2 and $Poolpathptr = name of the content match
#3. Finally, if not linked (and also not matched if $compareflg set)
#   Return=3 and $$poolpathptr = first empty chain
#Note: Return zero if zero size file
#      Return negative if error.
#Note: if chain has multiple copies of the file, then it returns the first linked
#match if present and if none and $compareflag set then the first content match
sub GetPoolLink
{
	my($bpc, $md5, $name, $compress, $compareflg, $poolpathptr) = @_;

	$compress = $bpc->{Conf}{CompressLevel} unless defined $compress;

	my ($md5sum , $ret) = defined($compress) && $compress > 0 ?
		zFile2MD5($bpc, $md5, $name, 0, $compress) : 
		$bpc->File2MD5($md5, $name);

	return 0 if $ret == 0; #Zero-sized file
	return -3 unless $ret >0;

	GetPoolLinkMD5($bpc, $name, $md5sum, $compress, $compareflg, $poolpathptr);
}

sub GetPoolLinkMD5
{
	my($bpc, $name, $md5sum, $compress, $compareflg, $poolpathptr) = @_;
	my($poolbase, $i);

	return -1 unless -f $name;
	my $inode = (stat(_))[1];  #Uses stat from -f
	return 0 if (stat(_))[7] == 0; #Zero-size (though shouldn't really happen since
                                   #md5sum input not defined for zero sized files

	$compress = $bpc->{Conf}{CompressLevel} unless defined $compress;

	return -2 unless 
		defined($poolbase = $bpc->MD52Path($md5sum, $compress));

	#1st iteration looking for matching inode
	$$poolpathptr = $poolbase;
	for($i=0; -f $$poolpathptr; $i++) { #Look for linked copy (inode match)
		return 1 if ((stat(_))[1] == $inode);
		$$poolpathptr = $poolbase . '_' . $i; #Iterate
	}

	return 3 unless $compareflg; #No inode match

	#Optional 2nd iteration looking for matching content
	my $compare = defined($compress) && $compress > 0 ? \&zcompare2 : \&jcompare;
	$$poolpathptr = $poolbase;
	for(my $j=0; $j<$i; $j++ ) { #Look for content match
		return 2 if (stat($$poolpathptr))[3] < $bpc->{Conf}{HardLinkMax} &&
			!$compare->($name, $$poolpathptr);
		$$poolpathptr = $poolbase . '_' . $j; #Iterate
	}
	# No matching existing pool entry - $$poolpathptr is first empty chain element
	return 3;
}

#Convert pool name to constant length string consisting
#of 32 hex digits for the base plus 6 (left) zero padded digits for
#the chain suffix (suffixes are incremented by 1 so that no suffix 
#records as 0). Note this accomodates chains up to 10^6 long.
#Use a number bigger than 6 if you have longer chains
#Useful if you want to order (e.g., sort) pool file names numerically
sub poolname2number
{
	$_[0] =~ m|(.*/)?([^_]*)(_(.*))?|;
	my $suffix = defined($4) ? $4+1 : 0;
	return sprintf("%s%06s", $2, $suffix)
}

# Renumber pool chain holes starting at $firsthole and continue up the chain 
# to fill up # to $maxgap holes (which need not be contiguous).
# If $maxgap is not specified it defaults to 1 (sufficient to cover one 
# deletion - i.e. hole -- which may be $file itself)
# If $firsthole exists, it is an error. Use delete_pool_file instead,
# if you want to delete first before renumbering.
# Return 1 on success; Negative on failure
sub renumber_pool_chain
{
	my ($firsthole, $maxholes) = @_;
	
	$maxholes = 1 unless defined $maxholes;
	
	my ($base, $sufx);
	if($firsthole =~ m|(.*_)([0-9]+)|) {
		$base = $1;
		$sufx = $2;
	}else{
		$base = $firsthole . "_";
		$sufx = -1; #Corresponds to no suffix
	}

	my $nextsufx = $sufx+1;
	my $nextfile = $base .  $nextsufx;
	while($nextsufx - $sufx <= $maxholes) {
		if(-e $nextfile) { #Non-hole so move/renumber
			if(-e $firsthole || ! jrename($nextfile, $firsthole)) {
				warn "Error: Couldn't rename pool file: $nextfile --> $firsthole\n";
				return -2;
			}
#			print "Renumbering: $nextfile --> $firsthole\n";
			$firsthole = $base . (++$sufx); #Move hole up the chain
		}
		$nextfile = $base . (++$nextsufx);
	}
	return 1;
}

# Delete pool file (if it exists) and regardless renumber 
# chain to fill hole left by file. Fill up to $maxholes
# above $file (including the hole left by $file) where
# $maxholes defaults to 1.
# If $file doesn't exist, then it just fills the hole
# left by $file.
# Return 1 on success; Negative on failure
sub delete_pool_file
{
	my ($file, $maxholes) = @_;

	if(-e $file && !junlink($file)) { #Try to delete if exists
		warn "Error: Couldn't unlink pool file: $file\n";
		return -3;
	}
	return(renumber_pool_chain($file,$maxholes)); #Returns -1/-2 on fail
}

# Run BackupPC_nightly
sub run_nightly
{
	my ($bpc) = @_;
    my $err = $bpc->ServerConnect($Conf{ServerHost}, $Conf{ServerPort});
    if ($err) {
        printerr "BackupPC_nightly: can't connect to server ($err)...\n";
        return($err);
    }
    if ((my $reply = $bpc->ServerMesg("BackupPC_nightly run")) eq "ok\n" ) {
        $bpc->ServerMesg("log $0: called for BackupPC_nightly run...");
        print "BackupPC_nightly scheduled to run...\n";
        return 0;
    }
    else {
        printerr "BackupPC_nightly ($reply)...\n";
        return $reply;
    }
}


# Rewrite of compare function (in File::Compare) since it messes up on
# weird filenames with spaces and things (since it combines the "<"
# and the filename in a single string). Also streamline the code by
# getting rid of of extra fluff and removing code for comparing text
# files while we are at. The basic algorithm remains the classic one
# for comparing 2 raw files.
# Returns 0 if equal, 1 if not equal. And negative if error.
sub jcompare {
    my ($file1,$file2,$size) = @_;
	my ($fh1open, $fh2open, $fh1size);
	my $ret=0;

    local (*FH1, *FH2);
	unless (($fh1open = open(FH1, "<", $file1)) &&
			($fh2open = open(FH2, "<", $file2))) {
		$ret = -1;
		goto compare_return;
	}
	binmode FH1;
	binmode FH2;
	if (($fh1size = -s FH1) != (-s FH2)) {
		$ret=1;
		goto compare_return;
	}

	unless (defined($size) && $size > 0) {
	    $size = $fh1size;
	    $size = LINUX_BLOCK_SIZE if $size < LINUX_BLOCK_SIZE;
	    $size = TOO_BIG if $size > TOO_BIG;
	}

	my $data1 = my $data2 = '';
	my ($r1,$r2);
	while(defined($r1 = read(FH1,$data1,$size)) && $r1 > 0) {
	    unless (defined($r2 = read(FH2,$data2,$r1)) && $r2 == $r1
				&& $data2 eq $data1) {
			$ret=1;
			goto compare_return;
	    }
	}
	$ret=1  if defined($r2 = read(FH2,$data2,LINUX_BLOCK_SIZE)) && $r2 > 0;
	$ret =-2 if $r1 < 0 || $r2 < 0; # Error on read

  compare_return:
	close(FH1) if $fh1open;
	close(FH2) if $fh2open;
	return $ret;
}

# Version of compare for BackupPC compressed files. Compares inflated
# (uncompressed) versions of files. The BackupPC::FileZIO subroutine
# is used to read in the files instead of just raw open & read.  Note
# this version of compare is relatively slow since you must use zlib
# to decompress the streams that are being compared. Also, there is no
# shortcut to just first compare the filesize since the size is not
# known until you finish reading the file.
sub zcompare {
	my ($file1, $file2, $compress)=@_;
	my ($fh1, $fh2);
	my $ret=0;

	$compress =1 unless defined $compress;
	unless ((defined ($fh1 = BackupPC::FileZIO->open($file1, 0, $compress))) &&
			(defined ($fh2 = BackupPC::FileZIO->open($file2, 0, $compress)))) {
		$ret = -1;
		goto zcompare_return;
	}
	my $data1 = my $data2 = '';
	my ($r1, $r2);
	while ( ($r1 = $fh1->read(\$data1, 65536)) > 0 ) {
		unless ((($r2 = $fh2->read(\$data2, $r1)) == $r1)
				&& $data1 eq $data2) {
			$ret=1;
			goto zcompare_return;
		}
	}
	$ret =1 if ($r2 = $fh2->read(\$data2, LINUX_BLOCK_SIZE)) > 0; #see if anything left...
	$ret =-1 if $r1 < 0 || $r2 < 0; # Error on read

  zcompare_return:
	$fh1->close() if defined $fh1;
	$fh2->close() if defined $fh2;
	return $ret;
}

# Second alternative version that combines the raw speed of jcompare
# with the ability to compare compressed files in zcompare.  This
# routine effectively should compare two compressed files just as fast
# as the raw jcompare. The compare algorithm strips off the first byte
# header and the appended rsync checksum digest info and then does a
# raw compare on the intervening raw compressed data. Since no zlib
# inflation (decompression) is done it should be faster than the
# zcompare algorithm which requires inflation. Also since zlib
# compression is well-defined and lossless for any given compression
# level and block size, the inflated versions are identical if and
# only if the deflated (compressed) versions are identical, once the
# header (first byte) and trailers (rsync digest) are stripped
# off. Note that only the data between the header and trailers have
# this uniqe mapping. Indeed, since BackupPC only adds the checksum
# the second time a file is needed, it is possible that the compressed
# value will change with time (even though the underlying data is
# unchanged) due to differences in the envelope. Note, to some extent
# this approach assumes that the appended digest info is correct (at
# least to the extent of properly indicating the block count and hence
# compressed data size that will be compared)
sub zcompare2 {
    my ($file1,$file2,$size) = @_;
	my ($fh1, $fh2, $fh1open, $fh2open);
	my $Too_Big = 1024 * 1024 * 2;
	my $ret=0;
	
	unless (($fh1open = open($fh1, "<", $file1)) &&
			($fh2open = open($fh2, "<", $file2))) {
		$ret = -1;
		goto zcompare2_return;
	}
	binmode $fh1;
	binmode $fh2;
	
	my $fh1size = -s $fh1;
	my $fh2size = -s $fh2;

	my $data1 = my $data2 = '';
	unless (read($fh1, $data1, 1) == 1 &&  # Read first byte
			read($fh2, $data2, 1) == 1) {
		$ret = -1;
		goto zcompare2_return;
	}
	if (vec($data1, 0, 8) == 0xd6 || vec($data1, 0, 8) == 0xd7) {
		return -2 unless ( defined(seek($fh1, -8, 2)) ); 
		return -3 unless ( read($fh1, $data1, 4) == 4 );
		$fh1size -= 20 * unpack("V", $data1) + 49;
		# [0xb3 separator byte] + 20 * NUM_BLOCKS + DIGEST_FILE(32) + DIGEST_INFO (16)
		# where each of NUM_BLOCKS is a 20 byte Block digest consisting of 4 bytes of
		# Adler32 and the full 16 byte (128bit) MD4 file digest (checksum).
		# DIGEST_FILE is 2 copies of the full 16 byte (128bit) MD4 digest 
		# (one for protocol <=26 and the second for protocol >=27)
		# DIGEST_INFO is metadata consisting of a pack("VVVV") encoding of the
		# block size (should be 2048), the checksum seed, length of the
		# block digest (NUM_BLOCKS), and the magic number (0x5fe3c289).
		# Each is a 4 byte integer.
	}

	if (vec($data2, 0, 8) == 0xd6 || vec($data2, 0, 8) == 0xd7) {
		return -2 unless ( defined(seek($fh2, -8, 2)) ); 
		return -3 unless ( read($fh2, $data2, 4) == 4 );
		$fh2size -= 20 * unpack("V", $data2) + 49;
	}

	if ($fh1size != $fh2size) {
		$ret=1;
		goto zcompare2_return;
	}

	seek($fh1,1,0) ; #skip first byte
	seek($fh2,1,0) ; #skip first byte


	my $bytesleft=--$fh1size; #Reduce by one since skipping first byte
	$size = $fh1size unless defined($size) && $size > 0 && $size < $fh1size;
	$size = $Too_Big if $size > $Too_Big;

	my ($r1,$r2);
	while(defined($r1 = read($fh1,$data1,$size))
		  && $r1 > 0) {
	    unless (defined($r2 = read($fh2,$data2,$r1))
				&& $data2 eq $data1) { #No need to test if $r1==$r2 since should be same size
			$ret=1;        #Plus if it doesn't, it will be picked up in the $data2 eq $data1 line
			goto zcompare2_return;
	    }
		$bytesleft -=$r1;
		$size = $bytesleft if $bytesleft < $size;
	} 
	$ret=1  if defined($r2 = read($fh2,$data2,$size)) && $r2 > 0;
    #Note: The above line should rarely be executed since both files same size
	$ret =-2 if $r1 < 0 || $r2 < 0; # Error on read

  zcompare2_return:
	close($fh1) if $fh1open;
	close($fh2) if $fh2open;
	return $ret;
}

#Routine to remove files (unlink) or directories (rmtree)
# $fullfilename is full path name to file or directory
# Returns number of files deleted in the listref $dirfileref if defined;
sub delete_files
{
	my ($fullfilename, $dirfileref) = @_;
	my $listdeleted = defined($dirfileref);
	my $ret = -1;
	my $output;
	die "Error: '$fullfilename' doesn't exist or not writeable\n" 
		unless  -w $fullfilename;
	if(-f $fullfilename) {
		$ret = junlink($fullfilename);
	}
	elsif(-d $fullfilename) {
		$$dirfileref = "" if $listdeleted;
		open(local *STDOUT, '>', $dirfileref) #redirect standard out to capture output of rmtree
			if $listdeleted;
		$ret = jrmtree($fullfilename, $listdeleted, 1);
	}
	return $ret;
}

#Touch command (modified version of Unix notion)
#First argument is the (full)filepath Second argument if defined means
#file is only created if not existent but access and modification
#times not changed if already existent.
#Returns 1 on success, -1 on error;
sub touch
{
	unless (-e $_[0]) { #Create if non-existent
		return -1 unless defined(sysopen(my $fh, $_[0], O_CREAT));
		close $fh;
	}
	my $time = time();
	utime($time, $time, $_[0]) unless defined $_[1];
	return 1;
}

#Simple wrappers to protect when just doing dry runs
sub jcopy
{
	return 1 if $dryrun;
	copy @_;
}

sub jlink
{
	return 1 if $dryrun;
	link $_[0], $_[1];
}

sub junlink
{
	return 1 if $dryrun;
	unlink @_;
}

sub jmkdir
{
	return 1 if $dryrun;
	mkdir @_;
}

sub jmkpath
{
    return 1 if $dryrun;
    mkpath @_;
}

sub jmake_path
{
    return 1 if $dryrun;
    mkpath @_;
}

sub jrename
{
	return 1 if $dryrun;
	rename $_[0], $_[1];
}

sub jrmtree
{
	return 1 if $dryrun;
	rmtree @_;
}

1;