#!/usr/bin/perl
#============================================================= -*-perl-*-
#
# BackupPC_tarExtract: extract data from a dump
#
# DESCRIPTION
#
# AUTHOR
#   Craig Barratt  <cbarratt@users.sourceforge.net>
#
# COPYRIGHT
#   Copyright (C) 2001-2020  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.4.0, released 20 Jun 2020.
#
# See http://backuppc.sourceforge.net.
#
#========================================================================

use strict;
no utf8;

use lib "__INSTALLDIR__/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("fPph: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
     -p              don't show progress
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($PaxHdrGlobal);

$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);

my $Inode = 1;
for ( my $i = 0 ; $i < @Backups ; $i++ ) {
    $Inode = $Backups[$i]{inodeLast} + 1 if ( $Inode <= $Backups[$i]{inodeLast} );
}
my $Inode0 = $Inode;

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 $FatalErrors = 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++;
            $FatalErrors++;
            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
    );
    my $paxHdr = {};

    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++;
            $FatalErrors++;
        }

        if ( $type eq "L" ) {
            $longName = TarRead($fh, $size) || return;

            # remove trailing NULL
            $paxHdr = {};
            $paxHdr->{path} = substr($longName, 0, $size - 1);
            TarFlush($fh, $size);
            next;
        } elsif ( $type eq "K" ) {
            $longLink = TarRead($fh, $size) || return;

            # remove trailing NULL
            $paxHdr->{linkpath} = substr($longLink, 0, $size - 1);
            TarFlush($fh, $size);
            next;
        } elsif ( $type eq "x" || $type eq "g" ) {
            my $paxStr = TarRead($fh, $size) || return;
            $paxHdr = {};
            while ( $paxStr =~ /(\d+) / ) {
                my $setting = substr($paxStr, 0, $1);
                $paxStr = substr($paxStr, $1);
                $setting =~ s/\n$//;
                if ( $setting =~ /\d+ (.*?)=(.*)/s ) {
                    $paxHdr->{$1} = $2;
                    print("Got pax header $1 -> $2\n") if ( $Conf{XferLogLevel} >= 6 );
                }
            }
            TarFlush($fh, $size);
            if ( $type eq "g" ) {
                $PaxHdrGlobal = $paxHdr;
                $paxHdr       = {};
            }
            next;
        }

        #
        # merge global headers if defined, then override extracted file meta data
        #
        $paxHdr   = {%$PaxHdrGlobal, %$paxHdr} if ( $PaxHdrGlobal );
        $name     = $paxHdr->{path}            if ( defined($paxHdr->{path}) );
        $linkname = $paxHdr->{linkpath}        if ( defined($paxHdr->{linkpath}) );
        $size     = $paxHdr->{size}            if ( defined($paxHdr->{size}) );
        $mtime    = $paxHdr->{mtime}           if ( defined($paxHdr->{mtime}) );
        $uid      = $paxHdr->{uid}             if ( defined($paxHdr->{uid}) );
        $gid      = $paxHdr->{gid}             if ( defined($paxHdr->{gid}) );
        $uname    = $paxHdr->{uname}           if ( defined($paxHdr->{uname}) );
        $gname    = $paxHdr->{gname}           if ( defined($paxHdr->{gname}) );

        printf("Got file '%s', mode 0%o, size %g, type %d\n", $name, $mode, $size, $type)
          if ( $Conf{XferLogLevel} >= 3 );

        #
        # 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));
        my $xattr = {};
        foreach my $name ( keys(%$paxHdr) ) {
            if ( $name =~ /^SCHILY\.xattr\.(.*)/s ) {
                $xattr->{$1} = $paxHdr->{$name};
            } elsif ( $name = "SCHILY.acl.access" ) {
                $xattr->{"user.gtar.%aacl"} = $paxHdr->{$name} if ( length($paxHdr->{$name}) );
                delete($paxHdr->{$name});
            } elsif ( $name = "SCHILY.acl.default" ) {
                $xattr->{"user.gtar.%dacl"} = $paxHdr->{$name} if ( length($paxHdr->{$name}) );
                delete($paxHdr->{$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,
            xattr      => $xattr,
        };
    }
}

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
        #
        if ( $AttrOld ) {
            $AttrOld->set($f->{name}, {type => BPC_FTYPE_DELETED});
            print("moveFileToOld: added $f->{name} as BPC_FTYPE_DELETED in old\n")
              if ( $Conf{XferLogLevel} >= 5 );
        }
        return;
    }
    print("moveFileToOld: $a->{name}, $f->{name}, links = $a->{nlinks}, type = $a->{type}\n")
      if ( $Conf{XferLogLevel} >= 5 );
    if ( $a->{type} != BPC_FTYPE_DIR ) {
        if ( $a->{nlinks} > 0 ) {
            if ( $AttrOld ) {
                if ( !$AttrOld->getInode($a->{inode}) ) {
                    #
                    # copy inode to old if it isn't already there
                    #
                    $AttrOld->setInode($a->{inode}, $a);
                    $DeltaOld->update($a->{compress}, $a->{digest}, 1);
                }
                #
                # copy to old - no need for refeence count update since
                # inode is already there
                #
                $AttrOld->set($f->{name}, $a, 1) if ( !$AttrOld->get($f->{name}) );
            }
            $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 ( $AttrOld && !$AttrOld->get($f->{name}) && $AttrOld->set($f->{name}, $a, 1) ) {
                $DeltaOld->update($a->{compress}, $a->{digest}, 1);
            }
        }
        $AttrNew->delete($f->{name});
    } else {
        if ( !$AttrOld || $AttrOld->get($f->{name}) ) {
            #
            # 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);
        } else {
            #
            # 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 );
            pathCreate($pathOld);
            $AttrNew->flush(0, $f->{name});
            if ( !rename($pathNew, $pathOld) ) {
                printf("moveFileToOld(..., %s: can't rename %s to %s ($!, %d, %d, %d)\n",
                    $f->{name}, $pathNew, $pathOld, -e $pathNew, -e $pathOld, -d $pathOld);
                $Errors++;
            } else {
                BackupPC::XS::DirOps::refCountAll($pathOld, $a->{compress}, -1, $DeltaNew);
                BackupPC::XS::DirOps::refCountAll($pathOld, $a->{compress}, 1,  $DeltaOld);
                copyInodes($f->{name});
                $AttrOld->set($f->{name}, $a, 1);
            }
        }
        $AttrNew->delete($f->{name});
    }
}

sub xattrEqual
{
    my($x1, $x2) = @_;

    return 1 if ( !defined($x1) && !defined($x2) );
    return 0 if ( !defined($x1) || !defined($x2) || scalar(keys(%$x1)) != scalar(keys(%$x2)) );
    foreach my $n ( keys(%$x1) ) {
        return 0 if ( !defined($x2->{$n}) || $x1->{$n} ne $x2->{$n} );
    }
    return 1;
}

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},
                    xattr    => $f->{xattr},
                    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++;
                    $FatalErrors++;
                }
                $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 );
            $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};
                $f->{xattr}  = $aTarget->{xattr};

                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
            && xattrEqual($a->{xattr}, $f->{xattr}) ) {
            #
            # 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,
                xattr    => $f->{xattr},
            }
        );
    }
    $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 attribute 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($FatalErrors ? 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) ) {
        next if ( $name eq "." || $name eq ".." );
        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 ) {
                print("dirCacheFlush($dir): skipping $d/$file since it has no attributes\n")
                  if ( $Conf{XferLogLevel} >= 5 );
                next;
            }
            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} >= 4 );

    my $attrAll = $AttrNew->getAll($dirName);
    $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) ) {
        next if ( $fileUM eq "." || $fileUM eq ".." );
        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") if ( !$opts{p} );
}