#!/usr/bin/perl
#============================================================= -*-perl-*-
#
# BackupPC_tarExtract: extract data from a dump
#
# DESCRIPTION
#
# AUTHOR
#   Craig Barratt  <cbarratt@users.sourceforge.net>
#
# COPYRIGHT
#   Copyright (C) 2001-2017  Craig Barratt
#
#   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 3 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, see <http://www.gnu.org/licenses/>.
#
#========================================================================
#
# Version 4.0.0, released 3 Mar 2017.
#
# See http://backuppc.sourceforge.net.
#
#========================================================================

use strict;
no  utf8;
use lib "/usr/share/backuppc/lib";
use Encode qw/from_to/;
use BackupPC::Lib;
use BackupPC::XS qw( :all );
use BackupPC::DirOps;

use Getopt::Std;
use File::Path;
use Data::Dumper;

use constant S_IFMT => 0170000;   # type of file

$SIG{BUS}  = \&confess;
$SIG{SEGV} = \&confess;

die("BackupPC::Lib->new failed\n") if ( !(my $bpc = BackupPC::Lib->new) );
my $TopDir = $bpc->TopDir();
my $BinDir = $bpc->BinDir();
my %Conf   = $bpc->Conf();

my %opts;
if ( !getopts("fph:s:", \%opts) || @ARGV > 0 ) {
    print <<EOF;
usage: $0 [options] files/directories...
  Required options:
     -h host           host where the tar file will be extracted
     -s shareName      share name where the tar file will be extracted

  Other options:
     -f                this is a full tar archive
     -p                inplace - don't put reverse deltas into 2nd most
                       recent backup
EOF
    exit(1);
}

select(STDOUT); $| = 1;

my $Full = $opts{f};
my $FileCnt        = 0;
my $FileCntPeriod  = 100;

print("$0: got Full = $Full\n");

if ( $opts{h} !~ /^([\w\.\s-]+)$/
        || $opts{h} =~ m{(^|/)\.\.(/|$)} ) {
    print("$0: bad host name '$opts{h}'\n");
    exit(1);
}
my $client = $opts{h};

if ( $opts{s} eq "" || $opts{s} =~ m{(^|/)\.\.(/|$)} ) {
    print("$0: bad share name '$opts{s}'\n");
    exit(1);
}
my $ShareNameUM = $opts{s};
my $ShareName = $bpc->fileNameEltMangle($ShareNameUM);

my $Abort = 0;
my $AbortReason;

#
# Re-read config file, so we can include the PC-specific config
#
if ( defined(my $error = $bpc->ConfigRead($client)) ) {
    print("BackupPC_tarExtract: Can't read PC's config file: $error\n");
    exit(1);
}
%Conf = $bpc->Conf();
BackupPC::XS::Lib::logLevelSet($Conf{XferLogLevel});

my @Backups = $bpc->BackupInfoRead($client);

my($lastBkupIdx, $lastBkupNum, $newBkupNum, $newBkupIdx);
my($Inode, $Inode0);

$newBkupIdx  = @Backups - 1;
$newBkupNum  = $Backups[$newBkupIdx]{num};
my $Compress = $Backups[$newBkupIdx]{compress};

#
# Cached attributes for the new backup and (if it exists)
# the previous one
#
my($AttrNew, $AttrOld);
my($DeltaNew, $DeltaOld);

$AttrNew  = BackupPC::XS::AttribCache::new($client, $newBkupNum, $ShareNameUM,
                                           $Backups[$newBkupIdx]{compress});
$DeltaNew = BackupPC::XS::DeltaRefCnt::new("$TopDir/pc/$client/$newBkupNum");
$AttrNew->setDeltaInfo($DeltaNew);

$Inode = $Inode0 = $Backups[$newBkupIdx]{inodeLast};

my $Inplace = $opts{p};
if ( !$Inplace ) {
    $lastBkupIdx = $newBkupIdx - 1;
    if ( $lastBkupIdx < 0 ) {
        print("BackupPC_tarExtract: must specify -p on first backup\n");
        exit(1);
    }
    $lastBkupNum = $Backups[$lastBkupIdx]{num};
    $AttrOld  = BackupPC::XS::AttribCache::new($client, $lastBkupNum, $ShareNameUM,
                                               $Backups[$lastBkupIdx]{compress});
    $DeltaOld = BackupPC::XS::DeltaRefCnt::new("$TopDir/pc/$client/$lastBkupNum");
    $AttrOld->setDeltaInfo($DeltaOld);
}

#
# This constant and the line of code below that uses it is borrowed
# from Archive::Tar.  Thanks to Calle Dybedahl and Stephen Zander.
# See www.cpan.org.
#
# Archive::Tar is Copyright 1997 Calle Dybedahl. All rights reserved.
#                 Copyright 1998 Stephen Zander. All rights reserved.
#
my $tar_unpack_header
    = 'Z100 A8 A8 A8 a12 A12 A8 A1 Z100 A6 A2 Z32 Z32 A8 A8 A155 x12';
my $tar_header_length = 512;

my $BufSize  = 1048576;     # 1MB or 2^20
my $MaxFiles = 20;
my $Errors   = 0;

my $ExistFileCnt      = 0;
my $ExistFileSize     = 0;
my $ExistFileCompSize = 0;
my $NewFileCnt        = 0;
my $NewFileSize       = 0;
my $NewFileCompSize   = 0;
my $TarReadHdrCnt     = 0;

print("$0 starting... (XferLogLevel = $Conf{XferLogLevel})\n");

binmode(STDIN);
1 while ( !$Abort && TarReadFile(*STDIN) );
1 while ( !$Abort && sysread(STDIN, my $discard, 1024) );
dirCacheFlush();
$bpc->flushXSLibMesgs();

exitMesg();

sub TarRead
{
    my($fh, $totBytes) = @_;
    my($numBytes, $newBytes, $data);

    print("tarRead $totBytes\n") if ( $Conf{XferLogLevel} >= 9 );

    $data = "\0" x $totBytes;
    $! = 0;
    while ( $numBytes < $totBytes ) {
	return if ( $Abort );
        $newBytes = sysread($fh,
                        substr($data, $numBytes, $totBytes - $numBytes),
                        $totBytes - $numBytes);
        if ( $newBytes <= 0 ) {
	    return if ( $TarReadHdrCnt == 1 );	 # empty tar file ok
            print("Unexpected end of tar archive (tot = $totBytes,"
                   . " num = $numBytes, errno = $!, posn = " . sysseek($fh, 0, 1) . ")\n");
            $Abort = 1;
            $AbortReason = "Unexpected end of tar archive";
            $Errors++;
            return;
        }
        $numBytes += $newBytes;
    }
    return $data;
}

sub TarReadHeader
{
    my($fh) = @_;

    $TarReadHdrCnt++;
    return $1 if ( TarRead($fh, $tar_header_length) =~ /(.*)/s );
    return;
}

sub TarFlush
{
    my($fh, $size) = @_;

    if ( $size % $tar_header_length ) {
        TarRead($fh, $tar_header_length - ($size % $tar_header_length));
    }
}

sub TarReadFileInfo
{
    my($fh) = @_;
    my($head, $longName, $longLink);
    my($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
       $linkname, $magic, $version, $uname, $gname, $devmajor,
       $devminor, $prefix);

    while ( 1 ) {
        $head = TarReadHeader($fh);
        return if ( $Abort || $head eq ""
			   || $head eq "\0" x $tar_header_length );
        ($name,		# string
            $mode,	# octal number
            $uid,	# octal number
            $gid,	# octal number
            $size,	# octal number
            $mtime,	# octal number
            $chksum,	# octal number
            $type,	# character
            $linkname,	# string
            $magic,	# string
            $version,	# two bytes
            $uname,	# string
            $gname,	# string
            $devmajor,	# octal number
            $devminor,	# octal number
            $prefix) = unpack($tar_unpack_header, $head);

        $mode     = oct $mode;
        $uid      = oct $uid;
        $gid      = oct $gid;
	if ( ord($size) == 128 ) {
	    #
	    # GNU tar extension: for >=8GB files the size is stored
	    # in big endian binary.
	    #
	    $size = 65536 * 65536 * unpack("N", substr($size, 4, 4))
				  + unpack("N", substr($size, 8, 4));
	} else {
	    #
	    # We used to have a patch here for smbclient 2.2.x.  For file
	    # sizes between 2 and 4GB it sent the wrong size.  But since
	    # samba 3.0.0 has been released we no longer support this
	    # patch since valid files could have sizes that start with
	    # 6 or 7 in octal (eg: 6-8GB files).
	    #
	    # $size =~ s/^6/2/;       # fix bug in smbclient for >=2GB files
	    # $size =~ s/^7/3/;       # fix bug in smbclient for >=2GB files
	    #
	    # To avoid integer overflow in case we are in the 4GB - 8GB
	    # range, we do the conversion in two parts.
	    #
            if ( $size =~ /([0-9]{9,})/ ) {
                my $len = length($1);
                $size = oct(substr($1, 0, $len - 8)) * (1 << 24)
                      + oct(substr($1, $len - 8));
            } else {
                $size = oct($size);
            }
	}
        $mtime    = oct $mtime;
        $chksum   = oct $chksum;
        $devmajor = oct $devmajor;
        $devminor = oct $devminor;
        $name     = "$prefix/$name" if $prefix;
        $prefix   = "";
        substr ($head, 148, 8) = "        ";
        if (unpack ("%16C*", $head) != $chksum) {
           print("$name: checksum error at " . sysseek($fh, 0, 1) , "\n");
           $Errors++;
        }
        if ( $type eq "L" ) {
            $longName = TarRead($fh, $size) || return;
            # remove trailing NULL
            $longName = substr($longName, 0, $size - 1);
            TarFlush($fh, $size);
            next;
        } elsif ( $type eq "K" ) {
            $longLink = TarRead($fh, $size) || return;
            # remove trailing NULL
            $longLink = substr($longLink, 0, $size - 1);
            TarFlush($fh, $size);
            next;
        }
        printf("Got file '%s', mode 0%o, size %g, type %d\n",
                $name, $mode, $size, $type) if ( $Conf{XferLogLevel} >= 3 );
        $name     = $longName if ( defined($longName) );
        $linkname = $longLink if ( defined($longLink) );

        #
        # Map client charset encodings to utf8
        #
        # printf("File %s (hex: %s)\n", $name, unpack("H*", $name));
        if ( $Conf{ClientCharset} ne "" ) {
            from_to($name, $Conf{ClientCharset}, "utf8");
            from_to($linkname, $Conf{ClientCharset}, "utf8");
        }
        # printf("File now %s (hex: %s)\n", $name, unpack("H*", $name));

        $name     =~ s{^\./+}{};
        $name     =~ s{/+\.?$}{};
        $name     =~ s{//+}{/}g;
        return {
            name       => $name,
            mangleName => $bpc->fileNameMangle($name),
            mode       => $mode,
            uid        => $uid,
            gid        => $gid,
            size       => $size,
            mtime      => $mtime,
            type       => $type,
            linkname   => $linkname,
            devmajor   => $devmajor,
            devminor   => $devminor,
        };
    }
}

sub fileReadAll
{
    my($a, $f) = @_;

    return "" if ( $a->{size} == 0 );
    my $f = BackupPC::XS::FileZIO::open($a->{poolPath}, 0, $a->{compress});
    if ( !defined($f) ) {
        print("fileReadAll: Unable to open file $a->{poolPath} (for $f->{name})\n");
        $Errors++;
        return;
    }
    my $data;
    my $outData = "";
    while ( $f->read(\$data, $BufSize) > 0 ) {
        $outData .= $data;
    }
    $f->close;
    return $outData;
}

#
# Move $a to old; the new file $f will replace $a
#
sub moveFileToOld
{
    my($a, $f) = @_;

    if ( !$a || keys(%$a) == 0 ) {
        #
        # A new file will be created, so add delete attribute to old
        #
        $AttrOld->set($f->{name}, { type => BPC_FTYPE_DELETED }) if ( $AttrOld );
        return;
    }
    print("moveFileToOld: $a->{name}, $f->{name}, links = $a->{nlinks}, type = $a->{type})\n")
                                        if ( $Conf{XferLogLevel} >= 5 );
    if ( !$AttrOld || $AttrOld->get($f->{name}) ) {
        if ( $a->{nlinks} > 0 ) {
            $a->{nlinks}--;
            if ( $a->{nlinks} <= 0 ) {
                $AttrNew->deleteInode($a->{inode});
                $DeltaNew->update($a->{compress}, $a->{digest}, -1);
            } else {
                $AttrNew->setInode($a->{inode}, $a);
            }
        } else {
            $DeltaNew->update($a->{compress}, $a->{digest}, -1)
                                            if ( length($a->{digest}) );
        }
        $AttrNew->delete($f->{name});
        if ( $a->{type} == BPC_FTYPE_DIR ) {
            #
            # Delete the directory tree, including updating reference counts
            #
            my $pathNew = $AttrNew->getFullMangledPath($f->{name});
            print("moveFileToOld(..., $f->{name}): deleting $pathNew\n")
                                         if ( $Conf{XferLogLevel} >= 3 );
            BackupPC::DirOps::RmTreeQuiet($bpc, $pathNew, $a->{compress}, $DeltaNew, $AttrNew);
        }
        return;
    }

    if ( $a->{nlinks} > 0 ) {
        #
        # only write the inode if it doesn't exist in old;
        # in that case, increase the pool reference count
        #
        if ( $AttrOld->set($f->{name}, $a, 1) ) {
            $DeltaOld->update($a->{compress}, $a->{digest}, 1);
        }
    } else {
        $AttrOld->set($f->{name}, $a);
        $DeltaOld->update($a->{compress}, $a->{digest}, 1);
    }
    $AttrNew->delete($f->{name});
    $DeltaNew->update($a->{compress}, $a->{digest}, -1);
    if ( $a->{type} == BPC_FTYPE_DIR ) {
        #
        # For a directory we need to move it to old, and copy
        # any inodes that are referenced below this directory.
        # Also update the reference counts for the moved files.
        #
        my $pathNew = $AttrNew->getFullMangledPath($f->{name});
        my $pathOld = $AttrOld->getFullMangledPath($f->{name});
        print("moveFileToOld(..., $f->{name}): renaming $pathNew to $pathOld\n")
                                 if ( $Conf{XferLogLevel} >= 3 );
        $AttrNew->flush(0, $f->{name});
        BackupPC::XS::DirOps::refCountAll($pathNew, $a->{compress}, -1, $DeltaNew);
        BackupPC::XS::DirOps::refCountAll($pathNew, $a->{compress},  1, $DeltaOld);
        copyInodes($f->{name});
        pathCreate($pathOld);
        if ( !rename($pathNew, $pathOld) ) {
            print("moveFileToOld(..., $f->{name}): can't rename $pathNew to $pathOld\n");
            $Errors++;
        }
    }
}

sub TarReadFile
{
    my($fh) = @_;
    my $f = TarReadFileInfo($fh) || return;
    my($file, $exist, $digest);

    my $a       = $AttrNew->get($f->{name});
    my $aOld    = $AttrOld->get($f->{name}) if ( $AttrOld );
    my $same    = 0;

    printProgress() if ( ($FileCnt % $FileCntPeriod) == 0 );
    $FileCnt++;

    $a->{poolPath} = $bpc->MD52Path($a->{digest}, $a->{compress}) if ( length($a->{digest}) );
    dirCacheNewFile($f->{name});
    if ( $f->{type} == BPC_FTYPE_DIR ) {
        #
        # Directory
        #
        dirCacheNewDir($f->{name});
        my $pathNew = $AttrNew->getFullMangledPath($f->{name});
        if ( -d $pathNew ) {
            logFileAction("same", $f) if ( $Conf{XferLogLevel} >= 1 );
            $same = 1;
        } else {
            if ( -e $pathNew ) {
                print("TarReadFile: $pathNew ($f->{name}) isn't a directory... renaming and recreating\n")
                                             if ( defined($a) && $Conf{XferLogLevel} >= 4 );
            } else {
                print("TarReadFile: creating directory $pathNew ($f->{name})\n")
                                             if ( defined($a) && $Conf{XferLogLevel} >= 3 );
            }
            moveFileToOld($a, $f);
            logFileAction("new", $f) if ( $Conf{XferLogLevel} >= 1 );
            #
            # make sure all the parent directories exist and have directory attribs
            #
            pathCreate($pathNew, 1);
            my $name = $f->{name};
            $name = "/$name" if ( $name !~ m{^/} );
            while ( length($name) > 1 ) {
                if ( $name =~ m{/} ) {
                    $name =~ s{(.*)/.*}{$1};
                } else {
                    $name = "/";
                }
                my $a = $AttrNew->get($name);
                last if ( defined($a) && $a->{type} == BPC_FTYPE_DIR );
                print("TarReadFile: adding BPC_FTYPE_DIR attrib entry for $name\n")
                                             if ( $Conf{XferLogLevel} >= 3 );
                dirCacheNewDir($name);
                my $fNew = {
                                name     => $name,
                                type     => BPC_FTYPE_DIR,
                                mode     => $f->{mode},
                                uid      => $f->{uid},
                                gid      => $f->{gid},
                                size     => 0,
                                mtime    => $f->{mtime},
                                inode    => $Inode++,
                                nlinks   => 0,
                                compress => $Compress,
                           };
                $AttrNew->set($name, $fNew);
                moveFileToOld($a, $fNew);
            }
        }
    } elsif ( $f->{type} == BPC_FTYPE_FILE ) {
        #
        # Regular file
        #
        #
        # Write the file
        #
        my($nRead);
        #print("Reading $f->{name}, $f->{size} bytes, type $f->{type}\n");
        my $poolWrite = BackupPC::XS::PoolWrite::new($Compress);
        while ( $nRead < $f->{size} ) {
            my $thisRead = $f->{size} - $nRead < $BufSize
                                ? $f->{size} - $nRead : $BufSize;
            my $data = TarRead($fh, $thisRead);
            if ( $data eq "" ) {
                if ( !$Abort ) {
                    print("Unexpected end of tar archive during read\n");
                    $AbortReason = "Unexpected end of tar archive";
                    $Errors++;
                }
                $Abort = 1;
                print("Removing partial file $f->{name}\n")
                                 if ( $Conf{XferLogLevel} >= 1 );
                $AttrNew->delete($f->{name});
                return;
            }
            $poolWrite->write(\$data);
            $nRead += $thisRead;
        }
        ($exist, $digest) = processClose($poolWrite, $f->{size});
        if ( $a->{digest} eq $digest ) {
            logFileAction("same", $f) if ( $Conf{XferLogLevel} >= 1 );
            $ExistFileCnt++;
            $ExistFileSize     += $f->{size};
            $ExistFileCompSize += -s $a->{poolPath} if ( -f $a->{poolPath} );
            $same = 1 if ( $a->{nlinks} == 0 );
        }
        if ( !$same ) {
            moveFileToOld($a, $f);
            logFileAction($exist ? "pool" : "new", $f) if ( $Conf{XferLogLevel} >= 1 );
        }
        TarFlush($fh, $f->{size});
    } elsif ( $f->{type} == BPC_FTYPE_HARDLINK ) {
        #
        # Hardlink to another file.  GNU tar is clever about files
	# that are hardlinks to each other.  The first link will be
	# sent as a regular file.  The additional links will be sent
	# as this type.
        #
        # We promote the file to a hardlink by marking both as files
        # that have hardlinks (nlinks >= 2).
        #
        my($dir, $target);

        #
        # link targets are relative to the top-level share
        #
        $target = $f->{linkname};
        $target =~ s{^\./+}{};
        $target =~ s{/+\.?$}{};
        $target =~ s{//+}{/}g;
        my $aTarget = $AttrNew->get($target);

        $aTarget->{poolPath} = $bpc->MD52Path($aTarget->{digest}, $aTarget->{compress}) if ( length($aTarget->{digest}) );
        if ( $aTarget ) {
            if ( $aTarget->{nlinks} == 0 ) {
                #
                # Promote the target to a hardlink.
                #
                moveFileToOld($aTarget, {name => $target});
                moveFileToOld($a, $f);
                $aTarget->{nlinks} = 2;
                $AttrNew->set($target,    $aTarget);
                $AttrNew->set($f->{name}, $aTarget);
                $DeltaNew->update($aTarget->{compress}, $aTarget->{digest}, 1)
                                                    if ( length($aTarget->{digest}) );
                logFileAction("link", $f)
                            if ( $Conf{XferLogLevel} >= 1 );
                $NewFileCnt++;
                $NewFileSize     += $f->{size};
                $NewFileCompSize += -s $aTarget->{poolPath}
                                        if ( -f $aTarget->{poolPath} );
            } else {
                #
                # Copy the target attributes
                #
                $f->{type}   = $aTarget->{type};
                $f->{mode}   = $aTarget->{mode};
                $f->{uid}    = $aTarget->{uid};
                $f->{gid}    = $aTarget->{gid};
                $f->{size}   = $aTarget->{size};
                $f->{mtime}  = $aTarget->{mtime};
                $f->{inode}  = $aTarget->{inode};
                $f->{nlinks} = $aTarget->{nlinks};
                $f->{digest} = $aTarget->{digest};
                if ( defined($a)
                  && $a->{type}   == $f->{type}
                  && $a->{mode}   == $f->{mode}
                  && $a->{uid}    == $f->{uid}
                  && $a->{gid}    == $f->{gid}
                  && $a->{size}   == $f->{size}
                  && $a->{mtime}  == $f->{mtime}
                  && $a->{inode}  == $f->{inode}
                  && $a->{nlinks} == $f->{nlinks}
                  && $a->{digest} eq $f->{digest} ) {
                    #
                    # already linked
                    #
                    $same = 1;
                    logFileAction("same", $f)
                                if ( $Conf{XferLogLevel} >= 1 );
                } else {
                    #
                    # make a new link
                    #
                    logFileAction("linkU", $f)
                                if ( $Conf{XferLogLevel} >= 1 );
                    moveFileToOld($a, $f);
                    #
                    # Save the old inode, since the number of links will
                    # be increased
                    #
                    if ( $AttrOld && !$AttrOld->getInode($aTarget->{inode}) ) {
                        $AttrOld->setInode($aTarget->{inode}, $aTarget);
                        $DeltaOld->update($aTarget->{compress}, $aTarget->{digest}, 1);
                    }
                    $f->{nlinks}++;
                    $AttrNew->set($f->{name}, $f);
                }
                $ExistFileCnt++;
                $ExistFileSize     += $f->{size};
                $ExistFileCompSize += -s $aTarget->{poolPath}
                                        if ( -f $aTarget->{poolPath} );
            }
        } else {
            print("Can't find hardlink target $target for $f->{name}\n");
            $Errors++;
        }
        return 1;
    } elsif ( $f->{type} == BPC_FTYPE_SYMLINK ) {
        #
        # Symbolic link: write the value of the link to a plain file,
        # that we pool as usual (ie: we don't create a symlink).
        # The attributes remember the original file type.
        # We also change the size to reflect the size of the link
        # contents.
        #
        $f->{size} = length($f->{linkname});
        if ( $a && $a->{type} == BPC_FTYPE_SYMLINK ) {
            #
            # Check if it is the same
            #
            my $oldLink = fileReadAll($a, $f);
            if ( $oldLink eq $f->{linkname} ) {
                logFileAction("same", $f) if ( $Conf{XferLogLevel} >= 1 );
                $digest = $a->{digest};
                $ExistFileCnt++;
                $ExistFileSize     += $f->{size};
                $ExistFileCompSize += -s $a->{poolPath}
                                          if ( -f $a->{poolPath} );
                $same = 1;
            }
        }
        if ( !$same ) {
            moveFileToOld($a, $f);
            my $poolWrite = BackupPC::XS::PoolWrite::new($Compress);
            $poolWrite->write(\$f->{linkname});
            ($exist, $digest) = processClose($poolWrite, $f->{size});
            logFileAction($exist ? "pool" : "new", $f) if ( $Conf{XferLogLevel} >= 1 );
        }
    } elsif ( $f->{type} == BPC_FTYPE_CHARDEV
           || $f->{type} == BPC_FTYPE_BLOCKDEV
           || $f->{type} == BPC_FTYPE_FIFO ) {
        #
        # Special files: for char and block special we write the
        # major and minor numbers to a plain file, that we pool
        # as usual.  For a pipe file we create an empty file.
        # The attributes remember the original file type.
        #
        my $data;
        if ( $f->{type} == BPC_FTYPE_FIFO ) {
            $data = "";
        } else {
            $data = "$f->{devmajor},$f->{devminor}";
        }
        if ( $a && $a->{type} == $f->{type} ) {
            #
            # Check if it is the same
            #
            my $oldData = fileReadAll($a, $f);
            if ( $oldData eq $data ) {
                logFileAction("same", $f) if ( $Conf{XferLogLevel} >= 1 );
                $digest = $a->{digest};
                $ExistFileCnt++;
                $same = 1;
            }
        }
        if ( !$same ) {
            moveFileToOld($a, $f);
            my $poolWrite = BackupPC::XS::PoolWrite::new($Compress);
            $poolWrite->write(\$data);
            $f->{size} = length($data);
            ($exist, $digest) = processClose($poolWrite, $f->{size}, 0, 1);
            logFileAction($exist ? "pool" : "new", $f) if ( $Conf{XferLogLevel} >= 1 );
        }
    } else {
        print("Got unknown type $f->{type} for $f->{name}\n")
                                 if ( $Conf{XferLogLevel} >= 1 );
	$Errors++;
    }

    $bpc->flushXSLibMesgs();
    #
    # If the file was the same, we have to check the attributes to see if they
    # are the same too.  If the file is newly written, we just write the
    # new attributes.
    #
    my $attribSet = 1;
    my $newCompress = $Compress;
    $newCompress = $a->{compress} if ( $a && defined($a->{compress}) );

    printf("File %s: old digest %s, new digest %s\n", $f->{name}, unpack("H*", $a->{digest}), unpack("H*", $digest))
                                    if ( $a && $Conf{XferLogLevel} >= 5 );

    if ( $same && $a ) {
        if ( $a->{type}   == $f->{type}
          && $a->{mode}   == $f->{mode}
          && $a->{uid}    == $f->{uid}
          && $a->{gid}    == $f->{gid}
          && $a->{size}   == $f->{size}
          && $a->{mtime}  == $f->{mtime}
          && $a->{digest} eq $digest ) {
            #
            # same contents, same attributes, so no need to rewrite
            #
            $attribSet = 0;
        } else {
            #
            # same contents, different attributes, so copy to old and
            # we will write the new attributes below
            #
            if ( $AttrOld && !$AttrOld->get($f->{name}) ) {
                if ( $AttrOld->set($f->{name}, $a, 1) ) {
                    $DeltaOld->update($newCompress, $digest, 1);
                }
            }
            $f->{inode}  = $a->{inode};
            $f->{nlinks} = $a->{nlinks};
        }
    } else {
        #
        # file is new or changed; update ref counts
        #
        $DeltaNew->update($newCompress, $digest, 1)
                                                if ( $digest ne "" );
    }

    if ( $attribSet ) {
        my $newInode = $f->{inode};
        $newInode = $Inode++ if ( !defined($newInode) );
        my $nlinks = 0;
        $nlinks = $f->{nlinks} if ( defined($f->{nlinks}) );
        $AttrNew->set($f->{name}, {
                        type     => $f->{type},
                        mode     => $f->{mode},
                        uid      => $f->{uid},
                        gid      => $f->{gid},
                        size     => $f->{size},
                        mtime    => $f->{mtime},
                        inode    => $newInode,
                        nlinks   => $nlinks,
                        compress => $newCompress,
                        digest   => $digest,
                   });
    }
    $bpc->flushXSLibMesgs();
    return 1;
}

sub processClose
{
    my($poolWrite, $origSize, $noStats, $noSizeStats) = @_;
    my($exists, $digest, $outSize, $errs) = $poolWrite->close;

    $Errors += $errs;
    if ( !$noStats ) {
        if ( $exists ) {
            $ExistFileCnt++;
            if ( !$noSizeStats ) {
                $ExistFileSize     += $origSize;
                $ExistFileCompSize += $outSize;
            }
        } else {
            $NewFileCnt++;
            if ( !$noSizeStats ) {
                $NewFileSize       += $origSize;
                $NewFileCompSize   += $outSize;
            }
        }
    }
    return ($exists && $origSize > 0, $digest);
}

#
# Generate a log file message for a completed file
#
sub logFileAction
{
    my($action, $f) = @_;
    my $owner = "$f->{uid}/$f->{gid}";
    my $name = $f->{name};
    $name = "." if ( $name eq "" );
    $name .= " -> " . $f->{linkname} if ( length($f->{linkname}) );
    my $type  = (("", "p", "c", "", "d", "", "b", "", "", "", "l", "", "s"))
		    [($f->{mode} & S_IFMT) >> 12];
    $type = "h" if ( $f->{type} == BPC_FTYPE_HARDLINK );
    $bpc->flushXSLibMesgs();

    printf("  %-6s %1s%4o %9s %11.0f %s\n",
				$action,
				$type,
				$f->{mode} & 07777,
				$owner,
				$f->{size},
				$name);
}

#
# Create the parent directory of $fullPath (if necessary).
# If $noStrip != 0 then $fullPath is the directory to create,
# rather than the parent.
#
sub pathCreate
{
    my($fullPath, $noStrip) = @_;

    #
    # Get parent directory of $fullPath
    #
    print("pathCreate: fullPath = $fullPath\n")  if ( $Conf{XferLogLevel} >= 6 );
    $fullPath =~ s{/[^/]*$}{} if ( !$noStrip );
    return 0 if ( -d $fullPath );
    unlink($fullPath) if ( -e $fullPath );
    eval { mkpath($fullPath, 0, 0777) };
    if ( $@ ) {
        print("Can't create $fullPath\n");
        $Errors++;
        return -1;
    }
    return 0;
}

sub catch_signal
{
    my $sigName = shift;

    #
    # The first time we receive a signal we try to gracefully
    # abort the backup.  This allows us to keep a partial dump
    # with the in-progress file deleted and attribute caches
    # flushed to disk etc.
    #
    if ( !$Abort ) {
        print("BackupPC_tarExtract: got signal $sigName\n");
	$Abort++;
	$AbortReason = "received signal $sigName";
        $bpc->flushXSLibMesgs();
	return;
    }

    #
    # This is a second signal: time to clean up.
    #
    print("BackupPC_tarExtract: quitting on second signal $sigName\n");
    exitMesg();
}

sub exitMesg
{
    #
    # Flush out remaining attributes.
    #
    if ( $AttrNew ) {
        #
        # Make sure the top-level share has an attibute entry.
        # Normally that is added when any directory appears in the archive.
        # But if the archive only has files, we'll never add entries for
        # the parent directories.
        #
        if ( !$AttrNew->get("/") ) {
            print("adding top-level attrib for share $ShareNameUM\n")
                                 if ( $Conf{XferLogLevel} >= 4 );
            my $fNew = {
                        name     => $ShareNameUM,
                        type     => BPC_FTYPE_DIR,
                        mode     => 0775,
                        uid      => 0,
                        gid      => 0,
                        size     => 0,
                        mtime    => time(),
                        inode    => $Inode++,
                        nlinks   => 0,
                        compress => $Compress,
                   };
            $AttrNew->set("/", $fNew);
        }

        $AttrNew->flush(1);
        $bpc->flushXSLibMesgs();
    }
    if ( $AttrOld ) {
        $AttrOld->flush(1);
        $bpc->flushXSLibMesgs();
    }

    if ( $Conf{XferLogLevel} >= 6 ) {
        print("RefCnt Deltas for new #$newBkupNum:\n");
        $DeltaNew->print();
        if ( $DeltaOld ) {
            print("RefCnt Deltas for old #$lastBkupNum\n");
            $DeltaOld->print();
        }
    }
    $DeltaNew->flush();
    $DeltaOld->flush() if ( $DeltaOld );

    if ( $Abort ) {
        print("BackupPC_tarExtact aborting ($AbortReason)\n");
    }

    #
    # Report results to BackupPC_dump
    #
    my $TotalFileCnt  = $ExistFileCnt  + $NewFileCnt;
    my $TotalFileSize = $ExistFileSize + $NewFileSize;
    $bpc->flushXSLibMesgs();
    $Errors += BackupPC::XS::Lib::logErrorCntGet();
    printProgress();
    print("Done: $Errors errors,"
        . " $ExistFileCnt filesExist, $ExistFileSize sizeExist, $ExistFileCompSize sizeExistComp,"
        . " $TotalFileCnt filesTotal, $TotalFileSize sizeTotal,"
        . " $NewFileCnt filesNew, $NewFileSize sizeNew, $NewFileCompSize sizeNewComp, $Inode inodeLast\n");
    exit($Errors ? 1 : 0);
}

#######################################################################
# For full backups we need to remember which files are in each
# directory so that we can delete any files that didn't get sent
# in the archive.
#######################################################################

my %DirCache;

#
# Called each time we encounter a new directory.
# If it's the first time we have seen this directory
# then we cache all the files currently
#
# Does nothing if this isn't a Full backup
#
sub dirCacheNewDir
{
    my($dir) = @_;

    return if ( !$Full );

    $dir =~ s{/+$}{};
    $dir =~ s{^/+}{};
    $dir = "/$dir";
    return if ( defined($DirCache{$dir}) );

    print("dirCacheNewDir: populating dir = $dir\n")
                     if ( $Conf{XferLogLevel} >= 4 );

    my $all = $AttrNew->getAll($dir);
    $bpc->flushXSLibMesgs();
    foreach my $name ( keys(%$all) ) {
        print("dirCacheNewDir: populating dir = $dir with $name\n")
                     if ( $Conf{XferLogLevel} >= 4 );
        $DirCache{$dir}{$name} = 1;
    }
    dirCacheFlush($dir);
    $bpc->flushXSLibMesgs();
}

#
# Called each time we encounter a new file
#
# Does nothing if this isn't a Full backup.
#
sub dirCacheNewFile
{
    my($path) = @_;
    my($dir, $file);

    return if ( !$Full );

    if ( $path =~ m{(.*/)/*(.*)} ) {
        $dir  = $1;
        $file = $2;
    } else {
        $dir  = "";
        $file = $path;
    }
    $dir =~ s{/+$}{};
    $dir =~ s{^/+}{};
    $dir = "/$dir";
    print("dirCacheNewFile: path = $path: dir = $dir, file = $file\n")
                     if ( $Conf{XferLogLevel} >= 5 );
    dirCacheNewDir($dir) if ( !defined($DirCache{$dir}) );
    delete($DirCache{$dir}{$file});
}

#
# Called to flush directories whose path is disjoint
# from the given directory.  When a directory is flushed
# we delete any files that were not encountered during the
# extract.  This is how we update deleted files.
#
# If called with $dir == undef then all the remaining
# directories are flushed.
#
# Does nothing if this isn't a Full backup.
#
sub dirCacheFlush
{
    my($dir) = @_;

    return if ( !$Full );

    foreach my $d ( keys(%DirCache) ) {
        next if ( defined($dir) && ($dir =~ m{^\Q$d/} || $d eq "/" || $dir eq $d) );
        print("dirCacheFlush($dir): flushing $d\n") if ( $Conf{XferLogLevel} >= 5 );
        foreach my $file ( keys(%{$DirCache{$d}}) ) {
            my $name = "$d/$file";
            my $a = $AttrNew->get($name);
            if ( $a && $a->{inode} >= $Inode0 ) {
                #
                # shouldn't happen - but if it's a new file then
                # don't delete it
                #
                print("dirCacheFlush($dir): skipping $d/$file ($a->{inode} vs $Inode0)\n")
                                                    if ( $Conf{XferLogLevel} >= 5 );
                next;
            }
            #
            # this file didn't appear in the new full tar archive,
            # so move it to old.
            #
            $name =~ s{//+}{/}g;
            $name =~ s{^\.?/+}{};
            logFileAction("delete", { %$a, name => $name }) if ( $Conf{XferLogLevel} >= 1 );
            if ( $a->{nlinks} > 0 ) {
                my $aOld = $AttrOld->getInode($a->{inode}) if ( $AttrOld );

                if ( !$aOld && $AttrOld ) {
                    #
                    # copy the inode to old
                    #
                    print("dirCacheFlush(): unlink($name) -> setting old inode (nlinks = $a->{nlinks})\n")
                                                    if ( $Conf{XferLogLevel} >= 3 );
                    $AttrOld->setInode($a->{inode}, $a);
                    $DeltaOld->update($a->{compress}, $a->{digest}, 1);
                }
                #
                # If this file is older than this backup, then move it
                # to old (don't update the inode).
                #
                if ( $a && $a->{inode} < $Inode0 && $AttrOld && !$AttrOld->get($name) ) {
                    print("dirCacheFlush(): unlink($name) -> setting old file (nlinks = $a->{nlinks})\n")
                                                    if ( $Conf{XferLogLevel} >= 3 );
                    $AttrOld->set($name, $a, 1);
                }

                #
                # now reduce the number of links and update the inode;
                # ref count is handled above.
                #
                $a->{nlinks}--;
                if ( $a->{nlinks} <= 0 ) {
                    $AttrNew->deleteInode($a->{inode});
                    $DeltaNew->update($a->{compress}, $a->{digest}, -1);
                } else {
                    $AttrNew->setInode($a->{inode}, $a);
                }
                $AttrNew->delete($name);
            } else {
                moveFileToOld($a, {name => $name}) if ( $a );
            }
            $bpc->flushXSLibMesgs();
        }
        delete($DirCache{$d});
    }
}

sub copyInodes
{
    my($dirName) = @_;

    return if ( !defined($AttrOld) );

    my $dirPath  = $AttrNew->getFullMangledPath($dirName);

    print("copyInodes: dirName = $dirName, dirPath = $dirPath\n") if ( $Conf{XferLogLevel} >= 3 );

    my $attrAll = $AttrNew->getAll($dirName);
    print("copyInodes: finished getAll()\n");
    $bpc->flushXSLibMesgs();

    #
    # Add non-attrib directories (ie: directories that were created
    # to store attributes in deeper directories), since these
    # directories may not appear in the attrib file at this level.
    #
    if ( defined(my $entries = BackupPC::DirOps::dirRead($bpc, $dirPath)) ) {
        foreach my $e ( @$entries ) {
            next if ( $e->{name} eq "."
                   || $e->{name} eq ".."
                   || $e->{name} eq "inode"
                   || !-d "$dirPath/$e->{name}" );
            my $fileUM = $bpc->fileNameUnmangle($e->{name});
            next if ( $attrAll && defined($attrAll->{$fileUM}) );
            $attrAll->{$fileUM} = {
                type     => BPC_FTYPE_DIR,
                noAttrib => 1,
            };
        }
    }

    foreach my $fileUM ( keys(%$attrAll) ) {
        my $a = $attrAll->{$fileUM};
        if ( $a->{type} == BPC_FTYPE_DIR ) {
            #
            # recurse into this directory
            #
            copyInodes("$dirName/$fileUM");
            next;
        }
        print("copyInodes($dirName): $fileUM has inode=$a->{inode}, links = $a->{nlinks}\n") if ( $Conf{XferLogLevel} >= 6 );
        next if ( $a->{nlinks} == 0 );
        #
        # Copy the inode if it doesn't exist in old and increment the
        # digest reference count.
        my $aInode = $AttrNew->getInode($a->{inode});
        if ( !defined($AttrOld->getInode($a->{inode})) ) {
            print("copyInodes($dirName): $fileUM moving inode $a->{inode} to old\n") if ( $Conf{XferLogLevel} >= 5 );
            $AttrOld->setInode($a->{inode}, $aInode);
            $DeltaOld->update($Compress, $aInode->{digest}, 1);
        }

        #
        # Also decrement the inode reference count in new.
        #
        $aInode->{nlinks}--;
        if ( $aInode->{nlinks} == 0 ) {
            $AttrNew->deleteInode($a->{inode});
            print("copyInodes($dirName): $fileUM deleting inode $a->{inode} in new\n") if ( $Conf{XferLogLevel} >= 5 );
            $DeltaNew->update($aInode->{compress}, $aInode->{digest}, -1);
        } else {
            $AttrNew->setInode($a->{inode}, $aInode);
        }
        $bpc->flushXSLibMesgs();
    }
}

sub printProgress
{
    print("__bpc_progress_fileCnt__ $FileCnt\n");
}
