#!/bin/sh
# -*- perl -*-
# This code allows us to start perl from our path or an environment variable
# rather than hardcoding a path into the #! line.  It works from sh or csh.
(exit $?0) && eval 'exec ${QPERLQ-perl} -x $0 ${1+"$@"}'
if (! $?QPERLQ) setenv QPERLQ perl
exec $QPERLQ -x $0 $argv:q

#!/usr/local/bin/perl -w
#
# $Id: qsyncfs,v 1.25 1996/02/28 17:06:04 qjb Exp $
# $Source: /home/ejb/scripts/RCS/qsyncfs,v $
# $Author: qjb $
#
# Author: E. Jay Berkenbilt
#
# Synchronize one live file system with another.  See $help string for
# details.
#

# This script, as of revision 1.19, requires at least Perl version 5.001m.
require 5.001;
use strict;

my $whoami = ($0 =~ m,([^/]*)$,) ? $1 : $0;

####################################

package QStatbuf;
my $package = "QStatbuf";

# Field names
my $f_name = "name";
my $f_dev = "dev";
my $f_ino = "ino";
my $f_mode = "mode";
my $f_nlink = "nlink";
my $f_uid = "uid";
my $f_gid = "gid";
my $f_major = "major";
my $f_minor = "minor";
my $f_size = "size";
my $f_mtime = "mtime";
my $f_target = "target";
my $f_type = "type";

# Static variables
my $t_lnk = "lnk";
my $t_reg = "reg";
my $t_dir = "dir";
my $t_chr = "chr";
my $t_blk = "blk";
my $t_fifo = "fifo";
my $t_sock = "sock";

my $minor_bits = &get_minor_bits;

sub t_lnk
{
    $t_lnk;
}

sub t_reg
{
    $t_reg;
}

sub t_dir
{
    $t_dir;
}

sub t_chr
{
    $t_chr;
}

sub t_blk
{
    $t_blk;
}

sub t_fifo
{
    $t_fifo;
}

sub t_sock
{
    $t_sock;
}

sub get_minor_bits
{
    my @stat = stat("/dev/tty");
    my $minorbits = 8;
    if ((@stat) && ($stat[6] > (1 << 18)))
    {
	$minorbits = 18;
    }
    $minorbits;
}

sub new
{
    shift;
    my $rep = +{$package => {} };

    my ($name, $dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
	$t, $mtime, @t) = @_;
    @t = ();			# suppress warning about being used once
    $t = "";

    $rep->{$package}{$f_name} = $name;
    $rep->{$package}{$f_dev} = $dev;
    $rep->{$package}{$f_ino} = $ino;
    $rep->{$package}{$f_mode} = $mode & 07777;
    $rep->{$package}{$f_nlink} = $nlink;
    $rep->{$package}{$f_uid} = $uid;
    $rep->{$package}{$f_gid} = $gid;
    $rep->{$package}{$f_major} = $rdev >> $minor_bits;
    $rep->{$package}{$f_minor} = $rdev & ((1 << $minor_bits) - 1);
    $rep->{$package}{$f_size} = $size;
    $rep->{$package}{$f_mtime} = $mtime;

    lstat($name) || die "$package: INTERNAL ERROR: can't lstat $name in new\n";
    my $type = ((-l _) ? $t_lnk :
		(-d _) ? $t_dir :
		(-f _) ? $t_reg :		
		(-p _) ? $t_fifo :
		(-S _) ? $t_sock :
		(-b _) ? $t_blk :
		(-c _) ? $t_chr :
		"");

    $rep->{$package}{$f_type} = $type;
    $rep->{$package}{$f_target} = (($type eq $t_lnk) ? (readlink $name) : "");

    bless $rep;
}

sub type
{
    my $rep = shift;
    $rep->{$package}{$f_type};
}

sub isdir
{
    my $rep = shift;
    ($rep->type() eq $t_dir);
}

sub isreg
{
    my $rep = shift;
    ($rep->type() eq $t_reg);
}

sub islink
{
    my $rep = shift;
    ($rep->type() eq $t_lnk);
}

sub target
{
    my $rep = shift;
    $rep->{$package}{$f_target};
}

sub name
{
    my $rep = shift;
    $rep->{$package}{$f_name};
}

sub major
{
    my $rep = shift;
    $rep->{$package}{$f_major};
}

sub minor
{
    my $rep = shift;
    $rep->{$package}{$f_minor};
}

sub uid
{
    my $rep = shift;
    $rep->{$package}{$f_uid};
}

sub gid
{
    my $rep = shift;
    $rep->{$package}{$f_gid};
}

sub mtime
{
    my $rep = shift;
    $rep->{$package}{$f_mtime};
}

sub size
{
    my $rep = shift;
    $rep->{$package}{$f_size};
}

sub mode
{
    my $rep = shift;
    $rep->{$package}{$f_mode};
}

sub nlink
{
    my $rep = shift;
    $rep->{$package}{$f_nlink};
}

sub dev
{
    my $rep = shift;
    $rep->{$package}{$f_dev};
}

sub idev
{
    my $rep = shift;
    $rep->{$package}{$f_ino} . "/" . $rep->{$package}{$f_dev};
}

sub same
{
    my ($lhs, $rhs) = @_;
    my $type = $lhs->type();
    my $result = 0;
    if ($type ne $rhs->type())
    {
	$result = 0;
    }
    elsif ($type eq $t_lnk)
    {
	$result = ($lhs->target() eq $rhs->target());
    }
    elsif ($type eq $t_reg)
    {
	$result = (($lhs->size() == $rhs->size()) &&
		   ($lhs->mtime() == $rhs->mtime()));
    }
    elsif ($type eq $t_dir)
    {
	$result = 1;
    }
    elsif (($type eq $t_chr) || ($type eq $t_blk))
    {
	$result = (($lhs->major() == $rhs->major()) &&
		   ($lhs->minor() == $rhs->minor()));
    }
    elsif (($type eq $t_fifo) || ($type eq $t_sock))
    {
	$result = 1;
    }
    else
    {
	die "$package: INTERNAL ERROR: unhandled type in same\n";
    }

    $result;
}

sub identical
{
    my ($lhs, $rhs) = @_;
    (($lhs->{$package}{$f_dev} == $rhs->{$package}{$f_dev}) &&
     ($lhs->{$package}{$f_ino} == $rhs->{$package}{$f_ino}));
}

####################################

package main;

my $help = "Usage: $whoami src dest [options]

  -exceptions file	file contains a list of EXCEPTIONS, one file
			per line.  // is comment character (since it
			can't appear in a path name).  Blank lines are
			ignored.  All files must be valid exception
			filenames.
  -except filename	filename is considered to be an exception.  It
			must be specified as a relative path or as a
			special filename of the form */component.  In
			this case, all files with component as the
			last component are exceptions.  (Useful for
			core files).
  -xdev			do not cross over device boundaries
  -n			do nothing -- just print what you would do
  -v			print more verbose information
  -vv			print much more verbose information
  -vvv			print even more verbose information
  -no-ownerships	do not synchronize ownerships
  -rename-check suffix	If specified, if src/file does not match
			dest/file, but src/file.old does, if
			dest/file.old does not match src/file.old,
			rename dest/file to dest/file.old.  This
			checking is done recursively so that that
			dest.old could potentially be renamed to
			dest.old.old before dest is renamed to
			dest.old.

    OR

$whoami { --help | -h | --version | -V }
";

&help if ((@ARGV == 1) && (($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")));
if ((@ARGV == 1) && (($ARGV[0] eq "-V") || ($ARGV[0] eq "--version")))
{
    print "$whoami version 0.4\n";
    exit 0;
}

&usage if (@ARGV < 2);

my $no_action = 0;
my $verbose = 0;
my $xdev = 0;
my $topdev = 0;
my $found = 0;
my $no_ownerships = 0;
my $no_chown_links = &no_chown_links;
my $rename_check_suffix = "";
my %hardlinks = ();
my @errors = ();

$SIG{'USR1'} = $SIG{'QUIT'} = \&inc_verbose;
my %save_sig = %SIG;
my $arg = "";
my @exceptions = ();
my %exceptions = ();
my ($src, $dest) = ("", "");

while (@ARGV)
{
    $arg = shift(@ARGV);
    if ($arg eq "-n")
    {
	$no_action = 1;
    }
    elsif ($arg eq "-v")
    {
	$verbose = 1;
    }
    elsif ($arg eq "-vv")
    {
	$verbose = 2;
    }
    elsif ($arg eq "-vvv")
    {
	$verbose = 3;
    }
    elsif ($arg eq "-no-ownerships")
    {
	$no_ownerships = 1;
    }
    elsif ($arg eq "-except")
    {
	&usage if (@ARGV < 1);
	push(@exceptions, shift(@ARGV));
    }
    elsif ($arg eq "-exceptions")
    {
	&usage if (@ARGV < 1);
	push(@exceptions, &read_exceptions(shift(@ARGV)));
    }
    elsif ($arg eq "-xdev")
    {
	$xdev = 1;
    }
    elsif ($arg eq "-rename-check")
    {
	&usage if (@ARGV < 1);
	$rename_check_suffix = shift(@ARGV);
    }
    else
    {
	&usage if $found;
	&usage if (@ARGV < 1);
	($src, $dest) = ($arg, shift(@ARGV));
	$found = 1;
    }
}

$src =~ s,/$,, unless ($src eq "/");
$dest =~ s,/$,, unless ($dest eq "/");

&validate;
umask 077;			# protect files being copied
&synchronize("", "", $src, $dest);
&fix_hardlinks($src, $dest);

if (scalar(@errors) && $verbose)
{
    # Error messages may have been obscured by diagnostic messages
    warn "$whoami: ERROR Summary:\n";
    for (@errors)
    {
	warn "   $_";
    }
}
exit (scalar(@errors) ? 2 : 0);


sub no_chown_links
{
    my $t = ",,qs_tmp.$$";
    my $r = 1;
    (symlink "-does-not-exist-", $t  and
     chown 1, 1, $t  and
     chown 2, 2, $t  and
     $r = 0);
    unlink $t;
    $r;
}

sub synchronize
{
    my ($relsrc, $reldest, $src, $dest) = @_;
    my (%src, %dest);
    my ($i, @dirs);

    print "$whoami: scanning $src\n" if $verbose > 1;

    &get_dir_entries($relsrc, $src, \%src);
    &get_dir_entries($reldest, $dest, \%dest);

    # Remove all files in dest but not in src
    my @dest_only = &filter_from(\%dest, \%src);

    # Remove all files that exist in destination but not in source.
    foreach $i (@dest_only)
    {
	# Second argument to remove is a source file name for
	# rename checking -- it is not removed.
	&remove(&concat_paths($dest, $i), &concat_paths($src, $i), \%dest);
    }

    foreach $i (sort keys %src)
    {
	print "$whoami: checking " . $src{$i}->name() . "\n" if $verbose > 2;
	# If $dest{$i} exists, $desti is $dest{$i}->name(), but $dest{$i}
	# may not exist.
	my $desti = &concat_paths($dest, $i);
	if (exists $dest{$i})
	{
	    # If the file exists in both the source and the destination...
	    if ($dest{$i}->identical($src{$i}))
	    {
		# If the two files are IDENTICAL (same device and inode),
		# do nothing.
	    }
	    else
	    {
		# Otherwise, reconcile
		&reconcile($src{$i}, $dest{$i}, \%dest);
	    }
	}
	else
	{
	    # If a file exists in the source but not in the destination,
	    # copy it.
	    &copy($src{$i}, $desti);
	}

	if ($src{$i}->isdir())
	{
	    # Don't consider this directory's contents if it is a
	    # mountpoint and xdev was specified.
	    if ((! $xdev) ||
		($src{$i}->dev() == $topdev))
	    {
		push(@dirs, $i);
	    }
	}

	if ($src{$i}->isreg() && ($src{$i}->nlink() > 1))
	{
	    my $n = $src{$i}->name();
	    my $id = $src{$i}->idev();
	    if (! exists($hardlinks{$id}))
	    {
		$hardlinks{$id} = +();
	    }
	    push(@{$hardlinks{$id}}, $n);
	}
    }

    foreach $i (@dirs)
    {
	&synchronize(&concat_paths($relsrc, $i),
		     &concat_paths($reldest, $i),
		     &concat_paths($src, $i),
		     &concat_paths($dest, $i));
    }

    &reconcile_dir($src, $dest);
}

sub fix_hardlinks
{
    my ($src, $dest) = @_;
    my (@same, $k, $i, $target);

    $src .= "/" unless $src eq "/";
    $dest .= "/" unless $dest eq "/";

    foreach $k (keys %hardlinks)
    {
	@same = @{$hardlinks{$k}};
	map { s/^$src/$dest/ } @same;
	$target = shift(@same);
	foreach $i (@same)
	{
	    &make_hardlink($target, $i);
	}
    }
}

sub concat_paths
{
    my ($base, $ext) = @_;
    if ($base eq "")
    {
	$ext;
    }
    elsif ($base eq "/")
    {
	$base . $ext;
    }
    else
    {
	"$base/$ext";
    }
}

sub copy
{
    my ($srcbuf, $destname) = @_;
    my $type;
    $type = $srcbuf->type();

    if ($type eq &QStatbuf::t_lnk())
    {
	&make_symlink($srcbuf->target(), $destname);
    }
    elsif ($type eq &QStatbuf::t_reg())
    {
	eval
	{
	    &sparse_copy($srcbuf, $destname);
	};
	if ($@)
	{
	    &error("copy " . $srcbuf->name() .
		   " to $destname failed: $@");
	    return;
	}
    }
    elsif ($type eq &QStatbuf::t_dir())
    {
	&make_directory($destname);
    }
    elsif ($type eq &QStatbuf::t_chr())
    {
	&make_node($destname, "c", $srcbuf->major(), $srcbuf->minor());
    }
    elsif ($type eq &QStatbuf::t_blk())
    {
	&make_node($destname, "b", $srcbuf->major(), $srcbuf->minor());
    }
    elsif ($type eq &QStatbuf::t_fifo())
    {
	&make_fifo($destname);
    }
    elsif ($type eq &QStatbuf::t_sock())
    {
	print "$whoami: ignoring socket " . $srcbuf->name() . "\n" if $verbose;
	return;
    }
    else
    {
	die "$whoami: INTERNAL ERROR: unhandled type in copy\n";
    }

    &chown($srcbuf->uid(), $srcbuf->gid(), $destname, 1) unless $no_ownerships;
    &utime($srcbuf->mtime(), $destname)
	if ($srcbuf->isreg() || $srcbuf->isdir());
    &chmod($srcbuf->mode(), $destname, 1)
	if (! $srcbuf->islink());
}

sub reconcile
{
    my ($srcbuf, $destbuf, $destref) = @_;
    if (! $srcbuf->same($destbuf))
    {
	# Second argument to remove is a source file name for
	# rename checking -- it is not removed.
	&remove($destbuf->name(), $srcbuf->name(), $destref);
	&copy($srcbuf, $destbuf->name());
    }
    else
    {
	&reconcile_modes($srcbuf, $destbuf);
    }
}

sub reconcile_dir
{
    my ($src, $dest) = @_;
    my @t;
    if (! (@t = lstat($src)))
    {
	&error("can't stat $src; ignoring\n");
	return;
    }
    my $srcbuf = new QStatbuf($src, @t);

    if (! (@t = lstat($dest)))
    {
	&error("can't stat $dest; ignoring\n");
	return;
    }
    my $destbuf = new QStatbuf($dest, lstat($dest));

    &reconcile_modes($srcbuf, $destbuf);
}

sub reconcile_modes
{
    my ($srcbuf, $destbuf) = @_;
    my $dest = $destbuf->name();

    if ((! $no_ownerships) &&
	(($srcbuf->uid() != $destbuf->uid()) ||
	 ($srcbuf->gid() != $destbuf->gid())))
    {
	my ($uid, $gid) = ($srcbuf->uid(), $srcbuf->gid);
	&chown($uid, $gid, $dest, 0);
    }

    if (($srcbuf->mtime() != $destbuf->mtime()) &&
	($srcbuf->isreg() || $srcbuf->isdir()))
    {
	&utime($srcbuf->mtime(), $dest);
    }

    # other operations such as chown may have killed setuid/setgid bits.
    # Do the chmod but only say you're doing it if it previously needed
    # changing.
    my $silent = 1;
    if (($srcbuf->mode() != $destbuf->mode()) &&
	(! $destbuf->islink()))
    {
	$silent = 0;
    }
    &chmod($srcbuf->mode(), $dest, $silent);
}

sub get_dir_entries
{
    my ($reldir, $dir, $hashref) = splice(@_, 0, 3);
    my @entries = ();
    my %result = ();
    my ($i, @stat);

    if (! opendir(DIR, "$dir"))
    {
	&error("can't read entires of $dir: $!; ignoring\n");
	return ();
    }
    @entries = readdir(DIR);
    closedir(DIR);

    shift @entries if ($entries[0] eq ".");
    shift @entries if ($entries[0] eq "..");

    foreach $i (@entries)
    {
	my $diri = &concat_paths($dir, $i);
	next if exists $exceptions{&concat_paths($reldir, $i)};
	next if exists $exceptions{"*/$i"};
	if (@stat = lstat($diri))
	{
	    $result{$i} = new QStatbuf($diri, @stat);
	}
	else
	{
	    &error("lstat ". $diri . " failed: $!; ignoring\n");
	    return ();
	}
    }

    %$hashref = %result;
}

# Remove keys from first hash that don't appear in second hash.  Return
# list of removed keys.  (Values are not saved.)
sub filter_from
{
    my ($destref, $srcref) = @_;
    my %dest_only = %$destref;
    my @dest_only = ();
    my $i;

    foreach $i (keys %$srcref)
    {
	delete $dest_only{$i} if exists $dest_only{$i};
    }
    @dest_only = sort keys %dest_only;
    for (@dest_only)
    {
	delete $$destref{$_};
    }
    @dest_only;
}

sub validate
{
    my $error = 0;
    die "$whoami: $src does not exist\n" if (! -e $src);
    die "$whoami: $src must be a directory\n" if (! -d $src);
    die "$whoami: $dest does not exist\n" if (! -e $dest);
    die "$whoami: $dest must be a directory\n" if (! -d $dest);
    for (@exceptions)
    {
	if (m,^/,)
	{
	    $error = 1;
	    print "$whoami: $_ is not a valid exception.\n";
	}
    }
    die "$whoami: all exceptions must be relative pathnames\n" if ($error);

    %exceptions = ();
    for (@exceptions)
    {
	$exceptions{$_} = 1;
    }

    if ($xdev)
    {
	my @t = stat($src) or
	    die "$whoami: INTERNAL ERROR: stat $src failed: !$\n";
	$topdev = $t[0];
    }
}

sub read_exceptions
{
    my ($file) = @_;
    my @list = ();

    open(EXCEPTIONS, "<$file") || die "$whoami: can't read $file: $!\n";
    while (<EXCEPTIONS>)
    {
	chop;
	s,//.*$,,;
	s/\s+$//;
	s/^\s+//;
	next if ($_ eq "");
	push(@list, $_);
    }
    close(EXCEPTIONS);

    @list;
}

# File system manipluation functions

sub remove
{
    my ($file, $srcfile, $destref) = @_;
    my $lastcomp = ($file =~ m,([^/]*)$,) ? $1 : $file;
    my $rename = 0;
    my $newfile = "$file.$rename_check_suffix";
    my $checkfile = "$srcfile.$rename_check_suffix";

    if ($rename_check_suffix ne "")
    {
	# If we are checking for rename, see whether this file would
	# match a file in the source directory if it were renamed.
	if (-e $checkfile)
	{
	    my @t = lstat($checkfile) or
		die "$whoami: INTERNAL ERROR in remove: " .
		    "can't lstat file we just checked\n";
	    my $checkbuf = new QStatbuf($checkfile, @t);
	    @t = lstat($file) or
		die "$whoami: INTERNAL ERROR in remove: " .
		    "can't lstat file we are removing\n";
	    my $buf = new QStatbuf($file, @t);
	    if ($checkbuf->same($buf))
	    {
		$rename = 1;
		&reconcile_modes($checkbuf, $buf);
	    }
	}
    }
    if ($rename)
    {
	print "$whoami: renaming $file to $newfile\n" if $verbose;
	return if $no_action;
	&remove($newfile, $checkfile, $destref) if -e $newfile;
	if (rename $file, $newfile)
	{
	    delete $destref->{$lastcomp} if exists $destref->{$lastcomp};
	    $destref->{"$lastcomp.$rename_check_suffix"} =
		new QStatbuf($newfile, (lstat $newfile));
	}
	else
	{
	    &error("rename of $file to $newfile failed: $!\n");
	}
    }
    else
    {
	if ((-d $file) && (! -l $file))
	{
	    print "$whoami: recursively removing $file\n" if $verbose;
	}
	else
	{
	    print "$whoami: removing $file\n" if $verbose;
	}
	return if $no_action;
	if (&rm($file))
	{
	    delete $destref->{$lastcomp} if exists $destref->{$lastcomp};
	}
	else
	{
	    &error("removal of $file failed: $!\n");
	}
    }
}

sub rm
{
    # Internal routine to be called by remove.
    my $file = shift;

    # This routine returns the status of the last unlink or rmdir.
    # Make sure no statements follow either in the logic below.
    if ((-d $file) && (! -l $file))
    {
	if (opendir(D, $file))
	{
	    my @entries;
	    @entries = readdir(D);
	    shift(@entries) if $entries[0] eq ".";
	    shift(@entries) if $entries[0] eq "..";
	    closedir(D);
	    for (@entries)
	    {
		&rm("$file/$_");
	    }
	    rmdir $file;
	}
    }
    else
    {
	unlink $file;
    }
}

sub make_symlink
{
    my ($old, $new) = @_;
    print "$whoami: linking $new -> $old\n" if $verbose;
    return if ($no_action);
    symlink $old, $new or &error("symlink $old $new failed\n");
}

sub make_hardlink
{
    my ($old, $new) = @_;

    return if (&identical_files($old, $new));

    print "$whoami: making $old and $new hard links\n" if $verbose;
    return if ($no_action);

    # To reduce likelihood of having to recopy file, try linking to
    # another file in this directory and renaming.

    my $t = $new . ",,qs_tmp.$$";
    unlink $t;
    if (link $old, $t)
    {
	if (unlink $new)
	{
	    if (! rename $t, $new)
	    {
		&error("WARNING: can't rename $t to $new; " .
		       "leaving file in $t\n");
	    }
	}
	else
	{
	    &error("can't remove original; leaving copy\n");
	    unlink $t;
	}
    }
    else
    {
	&error("link failed; leaving copy\n");
    }
}

sub identical_files
{
    my ($f1, $f2) = @_;
    my @stat1 = ();
    my @stat2 = ();

    return 0 unless (@stat1 = stat($f1));
    return 0 unless (@stat2 = stat($f2));
    (($stat1[0] == $stat2[0]) && ($stat1[1] == $stat2[1]));
}

sub make_directory
{
    my ($dest) = @_;
    print "$whoami: making directory $dest\n" if $verbose;
    return if ($no_action);
    mkdir $dest, 0700 or &error("mkdir $dest failed\n");
}

sub make_node
{
    my ($dest, $type, $major, $minor) = @_;
    print "$whoami: making node $dest $type $major $minor\n" if $verbose;
    return if ($no_action);
    (system("mknod $dest $type $major $minor") == 0) or
	&error("mknod $dest $type $major $minor failed\n");
}

sub make_fifo
{
    my ($dest) = @_;
    print "$whoami: making fifo $dest\n" if $verbose;
    return if ($no_action);
    (system("mknod $dest p") == 0) or
	&error("mknod $dest p failed\n");
}

sub chown
{
    my ($uid, $gid, $dest, $silent) = @_;
    return if ($no_action);
    return if ($no_ownerships);
    return if ($no_chown_links && (-l $dest));
    print "$whoami: changing ownership of $dest to $uid.$gid\n"
	if ($verbose && (! $silent));
    chown $uid, $gid, $dest or
	&error("chown $uid.$gid $dest failed\n");
}

sub utime
{
    my ($mtime, $dest) = @_;
    return if ($no_action);
    return if (-l $dest);
    utime time, $mtime, $dest or
	&error("utime $mtime $dest failed\n");
}

sub chmod
{
    my ($mode, $dest, $silent) = @_;
    return if ($no_action);
    return if (-l $dest);
    printf("$whoami: changing mode of $dest to %04o\n", $mode)
	if ($verbose && (! $silent));
    chmod $mode, $dest or
	&error("chmod " . sprintf("%04o", $mode) . " $dest failed\n");
}

sub sparse_copy
{
    my ($srcbuf, $dest) = @_;
    my $src = $srcbuf->name();
    print "$whoami: copying $src to $dest\n" if $verbose;
    return if ($no_action);

    local(*SRC, *DEST);
    my $blocksize = 512;
    my $nulls = "\000" x $blocksize;
    my ($i, $buf);

    die "$whoami: $dest exists\n" if (-e $dest);
    die "$whoami: $src does not exist\n" if (! -e $src);
    die "$whoami: $src is not a plain file\n" if (! -f $src);

    open(SRC, "<$src") || die "$whoami: can't open $src to read: $!\n";
    open(DEST, ">$dest") || die "$whoami: can't open $dest to write: $!\n";

    my $size = $srcbuf->size();

    if ($size > 0)
    {
	# Read all but the last block
	my $blocks = int(($size - 1) / $blocksize);
	my $so_far = 0;
	for ($i = 0; $i < $blocks; $i++)
	{
	    $buf = &safe_read($src, *SRC, $blocksize, $so_far);

	    if ($buf eq $nulls)
	    {
		seek(DEST, $so_far + $blocksize, 0);
	    }
	    else
	    {
		&safe_write($dest, *DEST, $buf, $blocksize, $so_far);
	    }
	    $so_far += $blocksize;
	}
	$buf = &safe_read($src, *SRC, $size - $so_far, $so_far);
	&safe_write($dest, *DEST, $buf, $size - $so_far, $so_far);
    }

    close(SRC);
    close(DEST) || die "$whoami: failed to close $dest\n";
}

sub safe_read
{
    my ($name, $fhglob, $blocksize, $so_far) = @_;
    local(*FH) = $fhglob;
    my ($len, $buf) = (0, "");
    ($len = sysread(FH, $buf, $blocksize)) ||
	die "$whoami: sysread from $name failed\n";
    die "$whoami: read only $len instead of $blocksize bytes\n" .
	"   ($so_far had been read so far)\n" if ($len != $blocksize);
    $buf;
}

sub safe_write
{
    my ($name, $fhglob, $buf, $blocksize, $so_far) = @_;
    local(*FH) = $fhglob;
    my $len;
    ($len = syswrite(FH, $buf, $blocksize)) ||
	die "$whoami: syswrite to $name failed\n";
    die "$whoami: wrote only $blocksize instead of $len bytes\n" .
	"   ($so_far had been written so far)\n" if ($len != $blocksize);
}

# Misc functions

sub inc_verbose
{
    $verbose++;
    $verbose = 0 if $verbose == 4;
    print "$whoami: verbosity level is now $verbose\n";
    %SIG = %save_sig;
}

sub help
{
    print $help;
    exit 0;
}

sub usage
{
    print STDERR $help;
    exit 1;
}

sub error
{
    my $msg = shift;
    warn "$whoami: $msg";
    push(@errors, $msg);
}

sub test
{
    # Test scenario:
    #
    # Create directory containing plain files with different
    # protections, symbolic links, subdirectories, and fifos.
    # Copy to destination directory.
    # Make sure at least one file is a hardlink to another file in a
    # different directory.
    # Make sure at least one file is not readable.
    # Make sure at least one subdirectory is not searchable.
    # Do a chmod
    # Change what a link points to
    # Make sure there are situations where the source and dest files
    # are of different types.
    # Make sure a recursive directory removal occurs.
    #
    # Rename tests:
    # Rename a regular file.
    # Rename a file.old and then rename a file.
    # Rename a file that is a hardlink to another file.
    # Rename a directory.
    # Rename a symbolic link.
    # Rename and chmod a file.
}