pmirror

#! /usr/local/system/perl/bin/perl

# https://github.molgen.mpg.de/mariux64/mxtools

#--------------------------------------------------------------
# My::Escaper helper class
# static methods needed be My::FileInfo and main

package My::Escaper;
use strict;
use warnings;

our @ISA=qw(Exporter);
our @EXPORT=qw(fn_escape fn_unescape);

#
# My::FileInfo helper class.
#
#
sub fn_escape
{
	my ($fn)=@_;
	$fn=~s/([[:^graph:]\\])/'\x'.sprintf('%02x',ord($1))/ge;
	return $fn;
}
sub fn_unescape
{
	my ($fn)=@_;
	$fn=~s/\\x([0-9a-f]{0,2})/chr(hex($1))/gie;
	return $fn;
}

#--------------------------------------------------------------
package My::FileInfo;
use strict;
use warnings;
import My::Escaper;

use Class::Struct (map {$_=>'$'} qw(name dev ino type perm nlink uid gid rdev size mtime target)) ;
use Fcntl ':mode';

#
# internal storage:
#
#     0     1      2      3      4     5     6      7      8       9   10    11
# [ name , dev , ino , type , perm ,nlink , uid , gid , rdev , size , mtime  target ]

#
# index file format:
#
# 0    1 2    3   4    5     6     7
# F path perm uid gid size   mtime hardlink
# D path perm uid gid -      mtime -
# L path perm uid gid target mtime hardlink
# B path perm uid gid rdev   mtime hardlink
# C path perm uid gid rdev   mtime hardlink
# P path perm uid gid -      mtime hardlink
# S path perm uid gid -      mtime hardlink

sub name_escaped
{
	my ($self)=shift;
	return fn_escape($self->name);
}

sub fileid
{
	my ($self)=shift;
	return($self->dev.'.'.$self->ino);
}

sub export_index
{
	my ($self)=@_;
	my $type=$self->type;
	return (
		$type,
		fn_escape($self->name),
		$self->perm,
		$self->uid,
		$self->gid,
		(
			$type eq 'F' ? $self->size :
			$type eq 'L' ? fn_escape($self->target) :
			$type eq 'B' || $type eq 'C' ? $self->rdev :
			'-'
		),
		$self->mtime,
	);
}

sub import_index
{
	my ($class,@F)=@_;
	my $type=$F[0];
	return bless [
		fn_unescape($F[1]),		# name
		0,0,		# dev,ino
		$type,		# type
		$F[2],		# perm
		0,		# nlink
		$F[3],$F[4],	# uid,gid
		($type eq 'B' || $type eq 'C' ? $F[5] : 0),	# rdev
		($type eq 'F' ? $F[5] : 0 ),			# size
		$F[6],	# mtime
		($type eq 'L' ? fn_unescape($F[5]) : ''),	# target

	],
	$class;
}

sub lstat
{
	my ($class,$filename)=@_;
	my $target;
	my @f;

	no warnings 'newline';
	unless (@f=lstat $filename) {
		$!==2 and return undef;		# ENOENT
		$!==20 and return undef;		# ENOTDIR
		die "$filename: $!\n";
	}
	if (-l _) {
		defined ($target=readlink($filename)) or die "$filename: $!\n";
	}
	my $type =
		S_ISREG($f[2])  ? 'F' :
		S_ISDIR($f[2])  ? 'D' :
		S_ISLNK($f[2])  ? 'L' :
		S_ISBLK($f[2])  ? 'B' :
		S_ISCHR($f[2])  ? 'C' :
		S_ISFIFO($f[2]) ? 'P' :
		S_ISSOCK($f[2]) ? 'S' :
		die ("$filename: unsupported file type\n");
	return bless [
		$filename,		# name
		@f[0,1],		# dev,ino
		$type,			# type
		S_IMODE($f[2]),		# perm
		@f[3..7],		# nlink,uid,gid,rdev,size
		$f[9],			# mtime
		($type eq 'L' ? $target : '')	# target
	],
	$class;
}

#--------------------------------------------------------------
package main;
use strict;
use warnings;

use File::FnMatch ':fnmatch';
use Getopt::Long;
use Sys::Hostname;
use IO::File;
use IO::Socket::INET;
use Fcntl qw(:mode O_NOATIME);
import My::Escaper;

use Time::HiRes;
use IO::Pipe;

BEGIN
{
	$ENV{PATH} = '/usr/local/bin:/sbin:/bin:'.($ENV{PATH}||'');	# for AXP to use gtar/mount
}

# options

our ($debug,$quiet,$fileop_noop,$fileop_debug,$delete);
our ($slave_mode,$local_slave,$slave_unprivileged,
	$lockident,$safety,$identity_file,$mkdir_slave,
	$reduce,$force_status,$bandwidth,$allowremotefs,
	$ssh_opt , $cksum , $nice , $unix_socket, $unix_socket_name,
	$noatime);

# globals

our ($in,$out);		# partner communication channel	# command channel
our $data;		# data channel

our (
	%HARDLINK,	# ( 'dev.inode' => first-filename-save , ... )  cache for indexer
	%LOCAL_DEV,	# ( 'dev' => path , ... ) 			non-nfs filesystems for indexer

	%CLEAN,		# files (possible directories) to be deleted after install, because not on master
	@CLEAN_DIRS	# for installer: directories, which we moved out of the way (.delete_me)
);

our @EXCEPTS;
our $bw_column = 0;
sub is_excepted
{
	my ($fn)=@_;
	for my $pat (@EXCEPTS) {
		if (fnmatch($pat,$fn,FNM_PATHNAME|FNM_PERIOD)) {
			return 1;
		}
	}
	return 0;
}

sub cache_local_fs
{

	#/dev/sdb on /amd/afk/1 type xfs (rw,noatime)
	#OneFS on /ifs (efs, NFS exported, local, noatime, noexec)

	for (`mount`) {
		m"(.+) on (/.*) type (\S+)" ||  m"(.+) on (/.*) \(([^,)]+),";
		my ($fs,$path,$type)=($1,$2,$3);
		next unless $type && $type =~ /^(advfs|ufs|ext\d+|reiserfs|xfs|fuseblk|vfat|efs|tmpfs|btrfs)$/;
		my @F = lstat($path) or next;
		$LOCAL_DEV{$F[0]}=$path;
	}
}

#---------------------------- lchown / mknod

our ($machine,$SYS_lchown,$SYS_mknod,$lmtime_sub);
chomp($machine=`uname -m`);
if ($machine eq 'i686') {
	$SYS_lchown=198;		# __NR_lchown32  in /usr/include/asm/unistd.h
	$SYS_mknod=14;			# __NR_mknod
} elsif ($machine eq 'x86_64') {
	$SYS_lchown=94;			# __NR_lchown in /usr/include/asm-x86_64/unistd.h
	$SYS_mknod=133;			# __NR_mknod
} elsif ($machine eq 'alpha') {
	$SYS_lchown=208;		# SYS_lchown in /usr/include/syscall.h
	$SYS_mknod=14;			# SYS_mknod
} elsif ($machine eq 'amd64') {
	$SYS_lchown=254;		# SYS_lchown in /usr/include/syscall.h
	$SYS_mknod=14; 			# SYS_mknod
} else {
	warn "unknown machine type $machine: symlink ownership can't be set.\n";
	warn "unknown machine type $machine: named pipes,character and block devices can't be created\n";
}

if ($machine eq 'x86_64') {
	our $SYS_utimensat=280;		     # /usr/include/asm/unistd_64.h
	our $AT_FDCWD=-100;			     # /usr/include/fcntl.h
	our $UTIME_OMIT=(1<<30)-2;	     # /usr/include/bits/stat.h
	our $AT_SYMLINK_NOFOLLOW=0x100;  # /usr/include/fcntl.h

	$lmtime_sub=sub {
		my ($path,$mtime)=@_;
		my $tsa=pack 'qqqq',0,$UTIME_OMIT,$mtime,0;
		syscall($SYS_utimensat,$AT_FDCWD,$path,$tsa,$AT_SYMLINK_NOFOLLOW) and die "$path: $!\n";
	}
} else {
	$lmtime_sub=sub {
		my ($path,$mtime)=@_;
		warn "$path: don't known how to change symlink mtime on target architecture\n";
	}
}

sub lchown
{
	my ($uid,$gid,$path)=@_;
	$SYS_lchown or die "$path: unknown machine type $machine: symlink ownership can't be set.\n";
	return syscall($SYS_lchown,$path,$uid+0,$gid+0)==0;
}

sub mknod
{
	my ($path,$mode,$rdev)=@_;
	$SYS_mknod or die "$path: unknown machine type $machine: named pipes,character and block devices can't be created\n";
	return syscall($SYS_mknod,$path,$mode+0,$rdev+0)==0;
}

#---------------------------- file op helper

sub fileop_mknod
{
	my ($path,$type,$rdev)=@_;
	defined $rdev or $rdev=0;
	$fileop_debug and warn sprintf("fileop: mknod %s %s %s\n",$path,$type,$rdev);
	$fileop_noop and return;
	my $mode=
		$type eq 'P' ? S_IFIFO :
		$type eq 'C' ? S_IFCHR :
		$type eq 'B' ? S_IFBLK :
		die ("$path: fileop_mknod() call for unexpected file type $type\n");
	mknod($path,$mode,$rdev) or die "$path: $!\n";
}

sub fileop_lchown
{
	my ($uid,$gid,$path)=@_;
	$slave_unprivileged and return;
	$fileop_debug and warn "fileop: lchown $uid:$gid $path\n";
	$fileop_noop and return;
	lchown($uid,$gid,$path) or die "$path: $!\n";
}

sub fileop_chown
{
	my ($uid,$gid,$path)=@_;
	$slave_unprivileged and return;
	$fileop_debug and warn "fileop: chown $uid:$gid $path\n";
	$fileop_noop and return;
	chown $uid,$gid,$path or die "$path: $!\n";
}

sub fileop_chmod
{
	my ($mode,$path)=@_;
	$fileop_debug and warn sprintf("fileop: chmod 0%03o %s\n",$mode,$path);
	$fileop_noop and return;
	chmod $mode,$path or die "$path: $!\n";
}

sub fileop_mkdir
{
	my ($path)=@_;
	$fileop_debug and warn ("fileop: mkdir $path\n");
	$fileop_noop and return;
	mkdir $path or die "$path: $!\n";
}

sub fileop_cp
{
	my ($from,$to)=@_;
	$fileop_debug and warn "fileop: cp -p $from $to\n";
	$fileop_noop and return;

	my @f=stat($from) or die "$from: $!\n";
	my $in=new IO::File $from,O_RDONLY or die "$from: $!\n";
	my $out=new IO::File $to,O_CREAT|O_EXCL|O_WRONLY or die "$to: $!\n";
	if ($IO::File::VERSION >= 1.13) {
		$in->binmode;
		$out->binmode;
	}
	my $buf;
	while ($in->sysread($buf,10240)) {
		$out->syswrite($buf) or die "$out: $!\n";
	}
	close $in;
	close $out;
	unless ($slave_unprivileged) {
		chown (@f[4,5],$to) or die "$to: $!\n";
	}
	chmod (S_IMODE($f[2]),$to) or die "$to: $!\n";
	utime (@f[8,9],$to) or die "$to: $!\n";
}

sub fileop_mv
{
	my ($from,$to)=@_;
	$fileop_debug and warn "fileop: mv $from $to\n";
	$fileop_noop and return;
	rename($from,$to) or die "$from: $!\n";
}

sub fileop_rm
{
	my ($path)=@_;
	$fileop_debug and warn "fileop: rm $path\n";
	$fileop_noop and return;
	unlink($path) or die "$path: $!\n";
}

sub fileop_rmdir_recurse
{
	my ($path)=@_;
	$fileop_debug and warn "fileop: rm -r $path\n";
	$fileop_noop and return;
	system 'rm','-rf',$path and exit 1;
}

sub fileop_symlink
{
	my ($from,$to)=@_;
	$fileop_debug and warn "fileop: ln -s $from $to\n";
	$fileop_noop and return;
	symlink($from,$to) or die "$to: $!\n";
}

sub fileop_ln_or_cp
{
	my ($from,$to)=@_;
	$fileop_debug and warn "fileop: ln_or_cp $from $to\n";
	$fileop_noop and return;
	unless (link $from,$to) {
		fileop_cp($from,$to);
	}
}

sub fileop_lmtime {
	my ($mtime,$path)=@_;
	$fileop_debug and warn "lmtime $mtime $path\n";
	$fileop_noop and return;
	$lmtime_sub->($path,$mtime);
}

sub size
{
	my $s = shift;
	my $n = shift;
	defined($n) or $n = 1;

	my @T=();
	for (my $f = 4; $f >= 0; $f--) {
		my $t = int($s/(1024**$f));
		push @T, ($t > 0) ? $t : 0; # TB/GB/MB/Kb/B
		$s -= $t*(1024**$f);
	}
	my @L;
	for my $x ('TB','GB','MB','kB','B') {
		my $y = shift @T;
		if ($y != 0) {
			if (defined($n)) {
				$n--;
				last if ($n < 0);
			}
			push @L,"$y $x";
		}
	}
	return join(' ',@L);
}

#--------------------------------------------

sub receive_bytes
{
	my ($io,$bufref,$len)=@_;
	my $index=0;
	while($len) {
		my $l = $io->sysread($$bufref,$len,$index);
		$l or return $l;
		$len-=$l;
		$index+=$l;
	}
	return $_[2];	# orig $len
}

sub receive_record
{
	my ($io,$bufref)=@_;
	my $len_buf;
	my $l;
	$l=receive_bytes($io,\$len_buf,2);
	defined $l or die "$!";
	$l or die "peer disconnected\n";
	my $len=unpack('n',$len_buf);
	$len or return 0;
	return receive_bytes($io,$bufref,$len)
}

sub writebuf {
	my ($fh,$buf,$len)=@_;
	my $pos=0;
	while (1) {
		my $sts=syswrite($fh,$buf,$len,$pos);
		defined $sts or return undef;
		$sts==$len and return $_[2];
		# this is extremly unlikely (only seen when strace connects)
		$pos+=$sts;
		$len-=$sts
	}
}

sub send_file
{
	my ($filename)=@_;
	my $data_buf;
	my $len;

	my $fh=IO::File->new($filename, O_RDONLY + ($noatime ? O_NOATIME : 0) );
	unless (defined $fh) {
		# one reason to get here is that the file was deleted after it has been offered to
		# and requested by the client.

		if ($!==2) {	# ENOENT
			warn "$filename: file has been removed on master after client requested it. aborting transfer\n";
			$len=0;
			$out->syswrite(pack('n',0),2);
			return;
		}
		die "$filename: $!\n";
	}

	defined $fh or die "$filename: $!\n";

        my $duration = 0;
	my $size = ($fh->stat())[7];

	if ($bandwidth && !$quiet) {
		$duration = Time::HiRes::time();
		my $oc = 8 + length($filename);
		if ( $oc > $bw_column ) {
			$bw_column = $oc + 1.0;
		}
		$bw_column -= 0.02;
		printf STDERR " %*s ",int($bw_column-$oc)+7,size($size,1);
	}
	while(1) {
		$len=$fh->sysread($data_buf,10240,2);
		defined $len or die "$filename: $!\n";
		substr($data_buf,0,2)=pack('n',$len);
		writebuf($out,$data_buf,$len+2) or die "$filename: $!\n";
		$len or last;
	}
	if ($bandwidth && !$quiet) {
		$duration = Time::HiRes::time() - $duration + 0.00001; # prevent div by zero
		printf STDERR " in %5.2fs %7s/s",$duration,size($size/$duration,1);
	}
}

sub receive_file
{
	my ($filename,$expected_size,$perm)=@_;
	my $fh;
	$fh=IO::File->new($filename,O_WRONLY|O_CREAT,$perm);
	defined $fh or die "$filename: $!\n";
	while(1) {
		my $data_buf;
		my $l;

		$l=receive_record($in,\$data_buf);
		defined $l or die "receive $filename: $!\n";
		$l or last;
		$l=$fh->syswrite($data_buf);
		defined $l or die "$filename: $!\n";
		$expected_size-=$l;
	}
	$fh->sync();
	if ($expected_size>0) {
		warn "master sent less file data than expected\n";
	} elsif ($expected_size<0) {
		warn "master sent more file data than expected\n";
	}
}

#--------------------------------------------

sub cksum {
	my ($filename)=@_;
	open my $p,'-|','cksum',$filename or die "$!\n";
	my $out=<$p>;
	close $p;
	$? and exit 1;
	my ($sum)=$out=~/(^\S+)/;
	return $sum;
}

sub master
{
	my ($master_path,$slave_user,$slave,$slave_path)=@_;

	chdir $master_path or die "$master_path: $!\n";

	cache_local_fs();

	if ($safety) {
		my $safety_file="$master_path/.PMIRROR_ENABLED";
		-e $safety_file or die "safety file $safety_file not found. Terminating\n";
	}

	if ($lockident) {
		use Fcntl (':flock');
		my $lockfilename='/var/lock/pmirror.'.$lockident.'.lock';
		our $lock_handle=IO::File->new($lockfilename,O_CREAT|O_WRONLY,0777);
		defined $lock_handle or die "$lockfilename: $!\n";
		flock($lock_handle,LOCK_EX|LOCK_NB) or die (($!==11 || $!==35) ? "mirror $lockident already running\n" : "$lockfilename: $!\n");
	}

	unless ($allowremotefs) {
		my $st=My::FileInfo->lstat('.');
		$st or die "$master_path : $!\n";
		exists $LOCAL_DEV{$st->dev} or die "$master_path: remote filesystem\n";
	}

	my $master_to_slave = new IO::Pipe;	# from us to remote slave
	my $slave_to_master = new IO::Pipe;	# from remote slave to us

	defined (my $pid=fork) or die "$0: $!\n";
	unless ($pid) {
		$master_to_slave->reader;
		$slave_to_master->writer;
		open STDIN, '<&',$master_to_slave or die "$!";
		open STDOUT,'>&',$slave_to_master or die "$!";

		$master_to_slave->close;
		$slave_to_master->close;

		my @remote_opts;

		$quiet and push @remote_opts,'--quiet';
		$fileop_noop and push @remote_opts,'--noop';
		$fileop_debug and push @remote_opts,'--fileop_debug';
		$debug and push @remote_opts,'--debug';
		push @remote_opts,$delete ? '--delete' : '--nodelete';
		$mkdir_slave and push @remote_opts,'--mkdir';
		$reduce and push @remote_opts,'--reduce';
		$force_status and push @remote_opts,'--force_status';
		$bandwidth and push @remote_opts,'--bandwidth';
		$allowremotefs and push @remote_opts,'--allowremotefs';
		$cksum and push @remote_opts,'--cksum';
		$nice and push @remote_opts,'--nice';
		$unix_socket_name and push @remote_opts,'--socket-name',$unix_socket_name;

		($slave_unprivileged or ($slave_user ne 'root')) and push @remote_opts,'--unprivileged';

		my @l;
		if ($slave) {
			@l= (
				'ssh',
				$identity_file ? ('-i',$identity_file) : (),
				,'-x',
				'-l',$slave_user,
				'-oFallBackToRsh=no','-oStrictHostKeyChecking=no',
				$unix_socket_name ? ('-L',"$unix_socket_name:$unix_socket_name") : (),
				$ssh_opt ? $ssh_opt : (),
				$slave,
				'/usr/local/bin/pmirror','--slave',@remote_opts,$slave_path
				# '/project/admin/pdist/pmirror2','--slave',@remote_opts,$slave_path
			);
		} else {
			@l=('/usr/local/bin/pmirror','--slave','--local-slave',@remote_opts,$slave_path)
			# @l=('/project/admin/pdist/pmirror2','--slave','--local-slave',@remote_opts,$slave_path)

		}

		$debug and warn "executing @l\n";
		$unix_socket_name and -e $unix_socket_name and unlink($unix_socket_name);
		exec @l;
		die "ssh: exec failed: $!\n";
	}
	$master_to_slave->writer;
	$slave_to_master->reader;

	$in=$slave_to_master;
	$out=$master_to_slave;
	$out->autoflush;

	local($, , $\)=(' ',"\n");

	if ($slave) {
		my $s_data;
		$_=$in->getline;
		defined $_ or die "client disconnected\n";
		if ($unix_socket_name) {
			/^LISTEN (\S+)$/ or die "protocol error; expected 'LISTEN path' got '$_'\n";
			$debug and warn "connecting to slave data port via $unix_socket_name\n";
			$s_data=new IO::Socket::UNIX (Peer=>$unix_socket_name) or die "connect to slave data port: $!\n";
			unlink($unix_socket_name);
		} else {
			/^LISTEN (\d+)$/ or die "protocol error; expected 'LISTEN port' got '$_'\n";
			my $port=$1;
			$debug and warn "connecting to slave data port at $slave:$port\n";
			$s_data=new IO::Socket::INET (PeerHost=>$slave,PeerPort=>$port,Proto=>'tcp') or die "connect to slave data port: $!\n";
		}
		($in,$out)=($s_data,$s_data);
	}

	for (@EXCEPTS) {
		$out->print('!',fn_escape($_));
	}

	my @TODO='.';
	while (@TODO) {
		my $filename=shift @TODO;
		next if is_excepted($filename);
		my $st=My::FileInfo->lstat($filename);
		unless ($st) {
			warn "$filename : $!\n";
			next;
		}
		if ( !exists $LOCAL_DEV{$st->dev} && !$allowremotefs && !($st->dev == -1 && $st->type eq 'P')) {  # osf bug: pipes show -1 as dev
			warn "$filename : remote filesystem\n";
			next;
		}
		if ($st->type eq 'D' && $filename =~ /\/(package|project|confidential|home|scratch|src)\/[^\/]+\.DELETEME$/ ) {
			next;
		}
		my $hardlink='-';
		if ($st->type ne 'D' && $st->nlink>1) {
			my $tag=$st->dev.'.'.$st->ino;
			if (exists $HARDLINK{$tag}) {
				$hardlink=$HARDLINK{$tag}
			} else {
				$HARDLINK{$tag}=$st->name_escaped
			}
		}
		my $sum= $cksum && $st->type eq 'F' ? cksum($filename) : '-';
		$out->print($st->export_index,$hardlink,$sum);
		if ($st->type eq 'F') {
			my $reply=$in->getline;
			defined $reply or die "client disconnected\n";
			chomp($reply);
			if ($reply eq 'SEND') {
				if ($bandwidth && !$quiet) {
					# note: we have $\ set, so use printf, not print
					printf STDERR 'sending %s',$filename;
					send_file($filename);
					printf STDERR "\n";
				} else {
					$quiet or warn "sending $filename\n";
					send_file($filename);
				}
			} elsif ($reply eq 'CONTINUE') {
				;
			} else {
				die "unexpected client reply: $reply\n";
			}
		} elsif ($st->type eq 'D') {
			my $dir;
			unless (opendir $dir,$filename) {
				next if $!==2 || $!==20;         # ENOENT,ENOTDIR
				die "$filename: $!\n";
			}
			unshift @TODO,map("$filename/$_",sort grep !/^\.\.?$/,readdir $dir)
		}
	}
	$out->print('%','complete');	# end tag, because truncated indices can be quite destructive

	$in->close;
	$out->close;
	waitpid $pid,0;
}

#--------------------------------------------

sub add_clean_dir
{
	my ($dir)=@_;
	opendir DIR,$dir or die "$dir: $!\n";
	while (defined (my $file=readdir DIR)) {
		my $path="$dir/$file";
		$CLEAN{$path} = 1 unless ($file eq '.' || $file eq '..' || is_excepted($path));
	}
	closedir DIR;
}

sub check_perm
{
	my ($st_is,$st_want)=@_;
	my $path=$st_is->name;
	$st_is->type eq '-' || $st_is->type eq 'L' and die "internal error";
	if ($st_is->uid != $st_want->uid || $st_is->gid != $st_want->gid) {
		($quiet || $slave_unprivileged) or warn "chown ".$st_want->uid.':'.$st_want->gid." $path\n";
		fileop_chown($st_want->uid,$st_want->gid,$path);
	}
	if ($st_want->perm != $st_is->perm) {
		$quiet or warn sprintf("chmod %03o %s\n",$st_want->perm,$path);
		fileop_chmod($st_want->perm,$path);
	}
}

sub make_dir
{
	my ($path,$mode,$uid,$gid)=@_;
	$quiet or warn sprintf ("mkdir %s owner %d:%d mode 0%03o\n",$path,$uid,$gid,$mode);
	fileop_mkdir($path);
	fileop_chown($uid,$gid,$path);
	fileop_chmod($mode,$path);
}

sub out_of_the_way
{
	my ($st)=@_;

	$st->type eq '-' and return;

	if ($st->type eq 'D') {
		my $path=$st->name;
		my $deleteme="$path.deleteme";
		fileop_mv($path,$deleteme);
		push @CLEAN_DIRS,$deleteme;
	} else {
		fileop_rm($st->name);
	}
}

#--------------------------------------------

sub tmpfilename				# './bla/lall/troeoet/lalala.txt' -> './bla/lall/troeoet/pmirror.1234.tmp'
{
	my ($path)=@_;
	my ($name)=$path=~m"([^/]+)$" or die "$path: bad pathname\n";
	return substr($path,0,-length($name)).'pmirror.'.$$.'.tmp';
}

sub slave
{
	$in=\*STDIN;
	$out=\*STDOUT;
	$out->autoflush;

	our $hostname=hostname;

	our @DIR_MTIME_QUEUE;		# ( name , mtime , name , mtime , ... )

	$SIG{__WARN__} = sub { warn $hostname.': '.$_[0] };
	$SIG{__DIE__}  = sub { die  $hostname.': '.$_[0] };

	local($, , $\)=(' ',"\n");

	my ($slave_path)=@_;
	if ($mkdir_slave && !$fileop_noop) {
		system 'mkdir','-p',$slave_path and exit 1;
	}
	chdir $slave_path or die "$slave_path: $!\n";

	unless ($local_slave) {
		my $s_listen;
		if ($unix_socket_name) {
			-e $unix_socket_name && unlink($unix_socket_name);
			$s_listen=IO::Socket::UNIX->new(Listen=>1,Local=>$unix_socket_name) or die "$unix_socket_name: $!\n";
			$out->print("LISTEN $unix_socket_name");
		} else {
			$s_listen=IO::Socket::INET->new(Listen=>1) or die "$0: $!\n";
			my $port=$s_listen->sockport;
			$out->print("LISTEN $port");
		}

		my $s_data = $s_listen->accept;
		my $err=$!;
		$unix_socket_name and unlink($unix_socket_name);
		defined $s_data or die "$err\n";

		($in,$out)=($s_data,$s_data);
	}

	my $reduce_saved_fileop_noop=$fileop_noop;
	$reduce and $fileop_noop=1;

	umask 0;		# don't let umask get in our way.

	my $crc_missmatch=0;

INDEX_RECORD:
	while (defined ($_=$in->getline)) {
		my @F=split ' ';

		$F[0] eq '%' and last;
		if ($F[0] eq '!') {
			push @EXCEPTS,fn_unescape($F[1]);
			next;
		}

		my $st_want=My::FileInfo->import_index(@F);
		my $filename=$st_want->name;

		if (is_excepted($filename)) {
			$st_want->type eq 'F' and $out->print ('CONTINUE');
			next;
		}
		delete $CLEAN{$filename};

		my $st_is=My::FileInfo->lstat($filename);

		if ($st_want->type eq 'D') {
			if ($st_is && $st_is->type eq 'D') {
				check_perm($st_is,$st_want);
				$delete and add_clean_dir($filename);
			} else {
				$st_is and fileop_rm($filename);
				make_dir($filename,$st_want->perm,$st_want->uid,$st_want->gid)
			}
			push @DIR_MTIME_QUEUE,$filename,$st_want->mtime;
		} else {
			my $hardlink=fn_unescape($F[7]);
			my $sum=$F[8];

			if ($hardlink ne '-') {
				my $st_src=My::FileInfo->lstat($hardlink);

				unless ($st_src) {
					$fileop_noop or warn "hardlink source $hardlink: $!\n";
					$st_want->type eq 'F' and $out->print('CONTINUE');
					next;
				}

				if ( !$st_is || $st_is->dev!=$st_src->dev || $st_is->ino != $st_src->ino) {
					$st_is and out_of_the_way($st_is);
					$quiet or warn "ln $hardlink $filename\n";
					fileop_ln_or_cp($hardlink,$filename)
				}
				$st_want->type eq 'F' and $out->print('CONTINUE');
			} elsif ($st_want->type eq 'F') {
				if (!$st_is || $st_is->type ne 'F' || $st_is->size != $st_want->size || $st_is->mtime != $st_want->mtime) {
					unless ($fileop_noop) {
						my $tmpfile=tmpfilename($filename);
						my $tmp_perm=$slave_unprivileged ? $st_want->perm : 0;
						if ($slave_unprivileged && -e $tmpfile) {
							unlink $tmpfile or die "$tmpfile: $!\n";
						}
						if ($st_want->size) {
							$out->print('SEND');
							$fileop_debug and warn "fileop: receiving $tmpfile\n";
							receive_file($tmpfile,$st_want->size,$tmp_perm);
						} else {
							$out->print('CONTINUE');
							$quiet or warn "creating empty $filename\n";
							$fileop_debug and warn "fileop: creating $tmpfile\n";
							IO::File->new($tmpfile,O_WRONLY|O_CREAT,$tmp_perm) or die "$tmpfile: $!\n";
						}
						unless ($slave_unprivileged) {
							fileop_chown($st_want->uid,$st_want->gid,$tmpfile);
							fileop_chmod($st_want->perm,$tmpfile);
						}
						$st_is and $st_is->type eq 'D' and out_of_the_way($st_is);
						fileop_mv($tmpfile,$filename);
						utime($st_want->mtime,$st_want->mtime,$filename);
					} else {
						$quiet or warn "mirror $filename\n";
						$out->print('CONTINUE');
					}
				} else {
					unless ($reduce) {
						if ($cksum) {
							my $is_sum=cksum($filename);
							if ($is_sum != $sum) {
								warn "$filename: CRC missmatch\n";
								$crc_missmatch++;
							}
						}
						check_perm($st_is,$st_want);
					}
					$out->print('CONTINUE');
				}
			} elsif ($st_want->type eq 'L') {
				if (!$st_is || $st_is->type ne 'L' || $st_is->target ne $st_want->target) {
					$st_is and out_of_the_way($st_is);
					$quiet or warn "ln -s ".$st_want->target." $filename\n";
					fileop_symlink($st_want->target,$filename);
					fileop_lchown($st_want->uid,$st_want->gid,$filename);
					fileop_lmtime($st_want->mtime,$filename);
				} else {
					if (!$slave_unprivileged && ($st_is->uid != $st_want->uid || $st_is->gid != $st_want->gid)) {
						$quiet or warn "lchown ".$st_want->uid.':'.$st_want->gid." $filename\n";
						fileop_lchown($st_want->uid,$st_want->gid,$filename);
					}
					if ($st_is->mtime != $st_want->mtime) {
						$quiet or warn "set mtime of $filename\n";
						fileop_lmtime($st_want->mtime,$filename);
					}
				}
			} elsif ($st_want->type eq 'P') {
				if (!$st_is || $st_is->type ne 'P') {
					$st_is and out_of_the_way($st_is);
					$quiet or warn "mknod $filename P\n";
					fileop_mknod($filename,'P');
					fileop_chown($st_want->uid,$st_want->gid,$filename);
					fileop_chmod($st_want->perm,$filename);
				} else {
					check_perm($st_is,$st_want);
				}
			} elsif ($st_want->type eq 'S') {
				warn "$filename: is a socket (ignored)\n";
			} elsif ($st_want->type eq 'C' || $st_want->type eq 'B') {
				if (!$st_is || $st_is->type ne $st_want->type || $st_is->rdev != $st_want->rdev) {
					$st_is and out_of_the_way($st_is);
					$quiet or warn "mknod $filename ",$st_want->type,"\n";
					fileop_mknod($filename,$st_want->type,$st_want->rdev);
					fileop_chown($st_want->uid,$st_want->gid,$filename);
					fileop_chmod($st_want->perm,$filename);
				} else {
					check_perm($st_is,$st_want);
				}
			} else {
				warn "$filename: type ".$st_want->type."  not yet implemented\n";
			}
		}
	}
	defined $_ or die "unexpected EOF from master\n";	# emergency exit

	$reduce and $fileop_noop=$reduce_saved_fileop_noop;
	if ($delete) {
		$debug and warn "cleanup\n";

		for my $path (keys %CLEAN) {
			lstat $path or die "$path: $!\n";
			if (-e _) {
				if (-d _) {
					$quiet or warn "rm -r $path\n";
					fileop_rmdir_recurse($path);
				} else {
					$quiet or warn "rm $path\n";
					fileop_rm($path);
				}
			}
		}

		for my $path (@CLEAN_DIRS) {
			if (-e $path) {
				$quiet or warn "rm -r $path\n";
				fileop_rmdir_recurse($path);
			}
		}
	}
	$reduce and exit;

	for (my $i=0;$i<@DIR_MTIME_QUEUE;$i+=2) {
		my ($fn,$mtime)=($DIR_MTIME_QUEUE[$i],$DIR_MTIME_QUEUE[$i+1]);
		if (my @f=lstat $fn) {
			S_ISDIR($f[2]) or next;	# no longer a directory
			$f[9]==$mtime and next;	# mtime is okay
			$quiet or warn "fix directory mtime of $fn ",$f[9],' -> ',$mtime,"\n";
			unless ($fileop_noop) {
				utime($mtime,$mtime,$fn) or warn "$fn: $!\n";
			}
		} else {
			warn "$fn: $!\n" unless $fileop_noop;
		}
	}

	if ($crc_missmatch) {
		die "completed with $crc_missmatch CRC errors\n";
	}

	if ( !$fileop_noop && ($force_status || -e '.PMIRROR_STATUS')) {
		my $t=time;
		open L,'>','.PMIRROR_STATUS' or die ".PMIRROR_STATUS: $!\n";
		print L 'OK',$t,scalar(localtime($t));
		close L;
	}
}

#--------------------------------------------

use constant USAGE => <<"__EOF__";

usage: $0 [options] path [node:]path
       $0 --slave [--local-slave] [--socket-name path] path [options]

 options:
   --noop               dont change anything
   --quiet              don't say anything
   --fileop_debug       log every file operation
   --delete             delete files on client which are not on server
   --debug              log some debugging info
   --lock IDENT         get exclusive lock on /var/lock/IDENT or die (not for slave)
   --safety		check existance of /path/.PMIRROR_ENABLE
   --identity_file FILE use this identity file for ssh
   --mkdir              create directory on target
   --exclude path       exclude path ( use pattern "./name1/name" only) , max be specified multiple times
   --reduce		do not create new data on mirror ( but do remove obsolete data with --delete) ...
   --force_status	force creation of .PMIRROR_STATUS on target
   --bandwidth          bandwidth
   --allowremotefs      allow mirror over remote fs
   --ssh-opt OPT        additional ssh option
   --cksum		compare existing files with CRC checksum
   --unprivileged       do not attempt to set file ownership, even if root
   --nice		EXPERIMENTAL nice
   --unix-socket        EXPERIMENTAL establish data channel over ssh via AF unix sockets
   --socket-name PATH   EXPERIMENTAL use PATH as name for AF unix sockets
   --noatime            don't touch atime on sender

__EOF__

use constant OPTIONS => (
	'slave'	          => \$slave_mode,
	'local-slave'     => \$local_slave,
	'unprivileged'    => \$slave_unprivileged,
	'noop'            => \$fileop_noop,
	'quiet'		  => \$quiet,

	'fileop_debug'    => \$fileop_debug,
	'delete!'         => \$delete,

	'debug'		  => \$debug,
	'lock=s'          => \$lockident,
	'safety'	  => \$safety,
	'identity_file=s' => \$identity_file,
	'mkdir'  	  => \$mkdir_slave,
	'exclude=s'	  => \@EXCEPTS,
	'reduce'	  => \$reduce,
	'force_status'	  => \$force_status,
	'bandwidth'	  => \$bandwidth,
	'allowremotefs'	  => \$allowremotefs,
	'ssh-opt=s'       => \$ssh_opt,
	'cksum'           => \$cksum,
	'nice'            => \$nice,
	'unix-socket'     => \$unix_socket,
	'socket-name=s'   => \$unix_socket_name,
	'noatime'         => \$noatime,
);

if ($ENV{SSH_ORIGINAL_COMMAND}) {
	($_,@ARGV)=split ' ',$ENV{SSH_ORIGINAL_COMMAND};
}

GetOptions(OPTIONS) or die USAGE;
if ($noatime && $cksum) {
	die "$0: --cksum together with --noatime not implemented\n";
}

if ($nice) {
	system "ionice -c idle -p $$ 2>/dev/null"
}

if ($slave_mode) {
	@ARGV==1 or die USAGE;
	my ($slave_path)=@ARGV;
	slave($slave_path);
} else {
	@ARGV==2 or die USAGE;
	my ($master_path,$target)=@ARGV;

	# excludes only work with a full path

	push @EXCEPTS,'./quota.group';
	push @EXCEPTS,'./quota.user';
	push @EXCEPTS,'./.tags';
	push @EXCEPTS,'./.PMIRROR_ENABLED';
	push @EXCEPTS,'./.PMIRROR_STATUS';
	push @EXCEPTS,'./.PMIRROR_HISTORY';

	my ($slave,$slave_path);
	my $slave_user='root';

	if ($target=~/^([^:]+):(.+)$/) {		# system:/path
		($slave,$slave_path)=($1,$2);
		if ($slave=~/^([^\@]+)\@(.+)$/) {	# user@system:/path
			($slave_user, $slave) = ($1, $2);
		}
	} else {					# /path
		($slave,$slave_path)=('',$target);
		$>==0 or $slave_user='whatever';	# if we are not root, the local slave will also no be root
	}

	if ($unix_socket && !defined $unix_socket_name) {
		$unix_socket_name=sprintf '%s/pmirror_setup_%s_%05d',($ENV{'TMPDIR'}||'/tmp'),$ENV{'USER'},int(rand(100000));
	}

	master($master_path,$slave_user,$slave,$slave_path);
}