pdist

#! /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 -     hardlink
# B path perm uid gid rdev   -     hardlink
# C path perm uid gid rdev   -     hardlink
# P path perm uid gid -      -     hardlink
# S path perm uid gid -      -     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 :
			'-'
		),
		$type eq 'F' || $type eq 'D' || $type eq 'L' ? $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
		($type eq 'F'|| $type eq 'D' || $type eq 'L' ? $F[6] : 0 ),	# mtime
		($type eq 'L' ? fn_unescape($F[5]) : ''),	# target

	],
	$class;
}

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

	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 File::Find;
use Getopt::Long;
use Sys::Hostname;
use IO::File;
use IO::Socket::INET;
use Fcntl ':mode';
import My::Escaper;

use Net::Ping;
use Socket;

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

# constants

use constant {
	DISTFILE	=> '/root/Distfile',			# read FILES,HOSTS,EXCEPTS here
};

our $PID=$$;
our $TMPDIR='/tmp/pdist.'.$$;
our $TMPUPDDIR='/tmp/pdist.'.$$.'/upd';

sub clean_tmp {
	$$==$PID && -d $TMPDIR and system 'rm','-r',$TMPDIR;
}

END { clean_tmp(); }
$SIG{INT} = sub {clean_tmp();exit 1;};
$SIG{HUP} = sub {clean_tmp();exit 1;};
$SIG{PIPE} = sub {clean_tmp();exit 1;};

# options

our ($debug,$quiet,$fileop_noop,$fileop_debug,$delete,$set_pdist_status);
our ($verbose,$timeout,@files,$ssh_tunnel,$post_command,$parallel,$prompt,$msg_prefix);
our ($distfilename) = (DISTFILE);

# globals

our (
	$server_pid,	# if we forked a pack server

	%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 (@FILES,@HOSTS,@EXCEPTS);		# from Distfile

END { $server_pid and kill TERM=>$server_pid }

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)$/;
		my @F = lstat($path) or next;
		$LOCAL_DEV{$F[0]}=$path;
	}
}

sub read_distfile
{
	my ($filename)=@_;
	my %DIST;	# { macro => [value,value,value] , ... )

	open IN,"<$filename" or die "$filename: $!\n";
	my $distfile=(join '',<IN>);
	$distfile=~s/#.*//g;

	while ($distfile =~ /(\S+) ?= ?\(([^)]*)\)/g) {
		$DIST{$1} = [split (' ',$2)];
	}

	# for (keys %DIST) { print "$_ : ",join(' ',@{$DIST{$_}}),"\n"; }

	# sanity check;

	for (qw(HOSTS FILES)) { exists $DIST{$_} or die "didnt find list $_ in $filename\n" };
	return ($DIST{HOSTS} , $DIST{FILES} , $DIST{EXCEPTS} );

}

sub init_from_distfile
{
	my ($distfile)=@_;
	my ($hosts,$files,$excepts)=read_distfile($distfile);

	@HOSTS=@{$hosts};
	@FILES=@{$files};
	@EXCEPTS=map { $_ eq 'core' ? () : $_ }  @{$excepts};	# remove 'core' for /arch/i686/usr/local/include/boost-1_32/boost/spirit/core

	push @EXCEPTS,(
		'/root/.viminfo',
		'/root/.nedit',
		'/usr/share/man/cat*',
	);

	# the EXCEPTS is used by Distfile for excepts and not for excepts_pat. I think, this
	# is wrong, but doesn't make a difference, because we only have one relative filename
	# ( "core" )  and this one is w/o wildcards. Otherwise the glob would fail.
	# rdist doku is quiet unclear about the excact behaviour however.
	#
	# we do it here as is was meant to be: all files are matched aganst these pattern.
	# plus we dont recurse into matched directories (rdist propably does). Makes a
	# difference for /etc/sysconfig/network-devices or /arch/i686/lib/modules/
	#
	# additionally "core" is a bad idea because of the dir /arch/i686/usr/local/include/boost-1_32/boost/spirit/core
	#
	# after removing "core" from this list, all pathnames were absolut.

	my $fn='/root/Distfile.hostconfig';
	if (-e $fn) {
		open my $in,'<',$fn or die "$fn: $!\n";
		while (<$in>) {
			chomp;
			s/#.*$//,
			/\S/ and push @HOSTS,$_;
		}
	}
}

sub index_file_sort { return sort @_; }

#---------------------------- 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)=@_;
	$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)=@_;
	$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;
	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 index_wanted
{
	#
	# the File::Find 'wanted' function for the indexer
	#
	#

	if (is_excepted($_)) {
		$File::Find::prune=1;
		return;
	}

	my $st=My::FileInfo->lstat($_) or die "$_ : $!\n";

	if ( !exists $LOCAL_DEV{$st->dev} && !($st->dev == -1 && $st->type eq 'P')) { # osf bug: pipes show -1 as dev
		warn "$_ : remote filesystem\n";
		$File::Find::prune=1;
		return;
	}

	my $save_fn=fn_escape($_);
	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
		}
	}
	print $st->export_index,$hardlink;
}

sub prog_index
{
	cache_local_fs();

	# start index with list of excepts

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

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

	@files and @FILES=@files;	# override via --files

	find (
		{
			wanted => \&index_wanted,
			no_chdir => 1,
			preprocess => \&index_file_sort,	# does not stop File::Find to process files before dirs
			# bydepth => 1,				# would stop prune from working
		},
		index_file_sort(map glob,@FILES)
	);
	print '%','complete';	# end tag, because truncated indices can be quite destructive
}

sub prog_pack
{
	my $errors=0;
	my $pid=open TAR,'|-';
	defined $pid or die "$0 : $!\n";
	unless ($pid) {
		exec 'tar','cf','-','-C','/','-T','-';
		die "tar: exec failed: $!\n";
	}

	while (<STDIN>) {
		my ($tag,$save_fn,$size,$mtime)=split;
		$tag eq '+' or die "$0 invalid input record $_\n";
		my $fn=fn_unescape($save_fn);

		my @S;
		unless (@S=lstat $fn) {
			warn "$fn: $!\n";
			next;
		}
		unless (S_ISREG($S[2]) && $S[7]==$size && $S[9]==$mtime) {
			warn "$fn: requested files has changed\n";
		}
		$fn=~s"^/+"";
		print TAR $fn,"\n";
	}
	unless (close TAR) {
		$! and die "$0: $!\n";
		exit 1;			# child exit status. diagnostics should already be out.
	};
}

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

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 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 install_file
{
	my ($tmp_filename,$path,$mode,$uid,$gid)=@_;
	$quiet or warn sprintf ("install %s owner %d:%d mode 0%03o\n",$path,$uid,$gid,$mode);
	fileop_cp($tmp_filename,$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);
	}
}

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

use constant {
	F_REQUEST=>1,
	F_UPDATE=>2,
};

sub prog_update
{
	my ($function,$index1,$tarfile)=@_;

#
# (F_REQUEST,index-filename)
# (F_UPDATE, index-filename,undef)
# (F_UPDATE, index-filename,tar-filename)
# (F_UPDATE, index-filesname,'-')              # tar already extracted in TMPUPDDIR
#
#

	my @DIR_MTIME_QUEUE;
	my ($requested_files,$requested_bytes)=(0,0);

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

	if ($tarfile && $tarfile ne '-') {
		-d $TMPDIR or mkdir $TMPDIR or die $TMPDIR.": $!\n";
		if (-d $TMPUPDDIR) {
			$verbose and warn 'reusing existing directory '.$TMPUPDDIR."\n";
		} else {
			mkdir $TMPUPDDIR or die $TMPUPDDIR.": $!\n";
		}
		$verbose and warn 'unpacking to '.$TMPUPDDIR."\n";
		system 'tar','--extract',,'--directory',$TMPUPDDIR,'--file',$tarfile and exit 1;
	}

	open INDEX,"<$index1" or die "$index1: $!\n";
	while (<INDEX>) {
		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;;
		next if is_excepted($filename);

		if ($function==F_REQUEST) {
			next if $st_want->type ne 'F';
			next if $F[7] ne '-';
			my $st_is=My::FileInfo->lstat($filename);
			if (!$st_is || $st_is->type ne 'F' || $st_is->size != $st_want->size || $st_is->mtime != $st_want->mtime) {
				print '+',$st_want->name_escaped,$st_want->size,$st_want->mtime;
				$requested_files++;
				$requested_bytes+=$st_want->size;
			}
			next;
		}
		$function==F_UPDATE or die "internale logic error";

		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 $tmp_filename=$TMPUPDDIR.$filename;

			if ($hardlink ne '-') {
				my $st_src=My::FileInfo->lstat($hardlink);
				if (!$st_src && !$fileop_noop) {
					warn "$hardlink: $!\n";
				} elsif ( !$st_is || !$st_src || $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)
				}
			} 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) {
					if ($tarfile) {
						my $st_tmp=My::FileInfo->lstat($tmp_filename);
						unless ($st_tmp) {
							warn "$filename: missing from archive\n";
							next;
						}
						$st_tmp->type eq 'F' or die "$tmp_filename: not a regular file\n";
						$st_tmp->size == $st_want->size && $st_tmp->mtime == $st_want->mtime or warn "$tmp_filename: does not match index\n";
						$st_is and out_of_the_way($st_is);
						install_file($tmp_filename,$filename,$st_want->perm,$st_want->uid,$st_want->gid);
					} else {
						die "required file $filename not available\n";
					}
				} else {
					check_perm($st_is,$st_want);
				}
			} 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 ($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 {
				die "type ".$st_want->type."  not yet implemented\n";
			}
		}
	}
	defined $_ or die "$index1 : truncated\n";	# emergency exit

	if ($function==F_UPDATE) {
		if ($delete) {
			my %except;
			chomp (my $linux_version=`uname -r`);			# '5.4.0-rc2.mx64.295'
			if ($linux_version) {
				my ($build) = $linux_version =~ /\.(\d+)$/;
				%except=map {$_=>1} (
					"/boot/mariux.$build",
					"/boot/bzImage-$linux_version",
					"/lib/modules/$linux_version",
					"/boot/config-$linux_version",
					"/boot/System.map-$linux_version",
					"/usr/share/nvidia/kernel/$linux_version",
				)
			}
			for my $path (keys %CLEAN) {
				$except{$path} and next;
				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) {
				fileop_rmdir_recurse($path);
			}
		}

		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";
			}
		}

		if ( !$fileop_noop && $set_pdist_status) {
			my $t=time;
			open L,'>','/.pdist_status' or die "/.pdist_status: $!\n";
			print L 'OK',$t,scalar(localtime($t));
			close L;
		}
	}

	if ($function==F_REQUEST) {
		$verbose and warn sprintf "requesting %d files %5.2f MB\n",$requested_files,$requested_bytes/1024/1024;
		return ($requested_files,$requested_bytes);
	} else {
		return;
	}
}

sub prog_client
{
	my ($master,$port)=@_;
	my $hostname=hostname;

	if ($msg_prefix) {
		set_prefix($msg_prefix);
	}

	-d $TMPDIR or mkdir $TMPDIR or die $TMPDIR.": $!\n";

	my ($tmp_free); {
		open P,'df -Pk '.$TMPDIR.'|' or die "$0 : $\n";
		$_=<P>;
		$_=<P>;
		my @F=split ' ';
		$tmp_free=$F[3];
		close P;
	}

	my $master_index=$TMPDIR."/snapshot.$master";
	my $tmpfile="$master_index.tmp";

	$verbose and warn "$hostname receiving index from $master\n";

	open OUT,">$tmpfile" or die "$tmpfile: $!\n";
	while (<STDIN>) {print OUT}
	close OUT;
	rename ($tmpfile,$master_index) or die "$master_index: $!\n";

	$verbose and warn "$hostname creating request\n";

	my $requestfile=$TMPDIR."/request.$master";
	$tmpfile="$requestfile.tmp";

	open OUT,">$tmpfile" or die "$tmpfile: $!\n";
	my $old=select(OUT);
	my ($req_files,$req_bytes)=prog_update(F_REQUEST,$master_index);
	select($old);
	close OUT;
	rename ($tmpfile,$requestfile) or die "$requestfile: $!\n";

	if ($req_bytes/1024*1.2 > $tmp_free) {
		die sprintf ("%s: insufficient disk space (%dk needed, %dk free)\n",$TMPDIR,$req_bytes/1024*1.2,$tmp_free);
	}

	if ($req_files) {
		my $s;
		if ($ssh_tunnel) {
			$verbose and warn "$hostname calling back $master via 127.0.0.1:$port\n";
			$s=new IO::Socket::INET (PeerHost=>'127.0.0.1',PeerPort=>$port,Proto=>'tcp') or die "$master: $!\n";

		} else {
			$verbose and warn "$hostname calling back $master via $master:$port\n";
			$s=new IO::Socket::INET (PeerHost=>$master,PeerPort=>$port,Proto=>'tcp') or die "$master: $!\n";
		}

		$verbose and warn "$hostname: connected to $master\n";
		defined (my $copy_pid=fork) or die "$0: $!\n";
		unless ($copy_pid) {
			$0="pdist [receiving tar from $master]";

			-d $TMPDIR or mkdir $TMPDIR or die $TMPDIR.": $!\n";
			if (-d $TMPUPDDIR) {
				$verbose and warn 'reusing existing directory '.$TMPUPDDIR."\n";
			} else {
				mkdir $TMPUPDDIR or die $TMPUPDDIR.": $!\n";
			}
			$verbose and warn 'unpacking to '.$TMPUPDDIR."\n";

			open STDIN,'<&',$s or die "$!";
			$verbose and warn "$hostname: about to exec tar --extract\n";
			exec 'tar','--extract','--directory',$TMPUPDDIR,'--file','-';
			die "tar: $!\n";
		}
		$verbose and warn "$hostname sending request to $master\n";
		open IN,"<$requestfile" or die "$requestfile: $!\n";
		while (<IN>) {
			$s->print($_);
		}
		$verbose and warn "$hostname: finished sending request\n";
		$s->shutdown(1);	# writing stopped

		waitpid $copy_pid,0;
		$? and exit 1;
		$verbose and warn "$hostname finished reading file data\n";
		$verbose and warn "$hostname installing\n";
		prog_update(F_UPDATE,$master_index,'-');
	} else {
		$verbose and warn "$hostname: installing from index $master_index (no files needed)\n";
		prog_update(F_UPDATE,$master_index,undef);
	}

	$verbose and warn "$hostname installation done. cleaning up\n";

	unlink ($master_index);
	unlink ($requestfile);

	if ($post_command) {
		$verbose and warn "$hostname: executing $post_command\n";
		$fileop_noop or system $post_command;
	}
}

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

sub set_prefix
{
	my ($client)=@_;
	$SIG{__WARN__} = sub { warn sprintf "%-30s: %s",$client,$_[0] };
	$SIG{__DIE__}  = sub { die  sprintf "%-30s: %s",$client,$_[0] };
}

sub  fork_pack_daemon
{
	my ($client)=@_;		# client name

	my $addr_i=inet_aton($client) or die "$client: cannot resolve $!\n";
	my $addr=inet_ntoa($addr_i);

	my $server_port;

	my $s_listen;
	if ($ssh_tunnel) {
		$s_listen=new IO::Socket::INET (Listen=>1,LocalAddr=>'127.0.0.1') or die "$0: $!\n";
	} else {
		$s_listen=new IO::Socket::INET (Listen=>1) or die "$0: $!\n";
	}
	$server_port=$s_listen->sockport;

	defined ($server_pid=fork) or die "$0: $!\n";
	unless ($server_pid) {
		$0="pdist [listening for $client]";
		while (defined (my $s=$s_listen->accept)) {
			my $peer=$s->peerhost;
			unless ($ssh_tunnel or $peer eq $addr) {
				warn "master: connect from wrong client $peer\n";
				$s->print("go away\n");
				$s->close;
				next;
			}
			$0="pdist [packing data for $client]";
			open STDIN, '<&',$s or die "$!";
			open STDOUT,'>&',$s or die "$!";
			prog_pack();
			exit;
			# $s->close;
			# open STDIN, '<','/dev/null' or die "$!\n";
			# open STDOUT,'>','/dev/null' or die "$!\n";
			# $0="pdist [listening for $client]";
		}
		exit # notreached
	}
	return ($server_port);
}

sub push_single
{
	my ($client,$indexfile)=@_;
	my ($hostname)=hostname;

	open IN,'<',$indexfile or die "$indexfile: $!\n";

	my ($server_port)=fork_pack_daemon($client);

	defined (my $pid = open OUT,"|-") or die "$0: $!\n";
	unless ($pid) {
		my @remote_opts;

		$verbose and push @remote_opts,'--verbose';
		$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';
		$set_pdist_status and push @remote_opts,'--set-pdist-status';

		$post_command and push @remote_opts,'--post-command='.quotemeta($post_command);

		$parallel && $parallel>1 and push @remote_opts,'--msg-prefix',$client;

		my @l= (
			'ssh','-l','root',
			($prompt ? () : '-oBatchMode=yes'),
			'-oFallBackToRsh=no',
			'-oStrictHostKeyChecking=no',
			'-x',
			($ssh_tunnel ? ('-R',"$ssh_tunnel:127.0.0.1:$server_port") : () ),
			$client,
			'/usr/local/bin/pdist',
			'client',
			($ssh_tunnel ? ('127.0.0.1',$ssh_tunnel) : ($hostname,$server_port) ),
			@remote_opts,
		);
		$verbose and warn "executing @l\n";
		exec @l;
		die "ssh: exec failed: $!\n";
	}
	local($SIG{PIPE}) = sub { kill 'TERM',$server_pid,$pid;die "client hangup\n"; };
	local($SIG{ALRM}) = sub { kill 'TERM',$server_pid,$pid;die "timeout\n"; };
	alarm(600);
	while (<IN>) {print OUT;alarm(600);}
	alarm(0);
	defined $timeout and alarm($timeout);
	unless (close OUT) {
		$! and die "$0: $!\n";
		exit 1;			# child exit status. diagnostics should already be out.
	};
	alarm(0);
	# if the ssh pipe terminated, the server should be gone. kill it just in case
	kill TERM=>$server_pid;
}

sub client_expand
{
	my (@spec)=@_;			# host host @group host @group

	our (%NG,$ng_init);

	my @ret;
	my %did;

	while (my $spec=shift @spec) {
		next if $did{$spec};
		if ($spec eq 'ALL') {
			unshift @spec,@HOSTS;
		} elsif ($spec =~ /^@(\S+)/) {
			unless ($ng_init) {
				for (`ypcat -k netgroup`) {
					my ($n,@v)=split ' ';
					my $a = $NG{$n} = [];
					for (@v) {
						if (/\(/) {
							/\((\S+),,\)/ and push @$a,$1
						} else {
							push @$a,'@'.$_;
						}
					}
				}
				$ng_init=1;
			}
			defined $NG{$1} or die "netgroup $1 unknown\n";
			unshift @spec,@{$NG{$1}};
		} else {
			unless ($spec =~ /\./) {
				$spec.='.molgen.mpg.de';
				next if $did{$spec};
			}
			push @ret,$spec;
		}
		$did{$spec}=1;
	}
	return @ret;
}

sub prog_push
{
	my @client_list = client_expand(@_);

	my $tmpfile;

	-d $TMPDIR or mkdir $TMPDIR or die $TMPDIR.": $!\n";
	$tmpfile=$TMPDIR.'/index.tmp';
	open SNAPSHOT,'>',$tmpfile or die "$tmpfile: $!\n";
	my $old=select(SNAPSHOT);
	$verbose and warn "creating index into $tmpfile\n";
	prog_index();
	select($old);
	close SNAPSHOT;

	if (@_==1 && @client_list==1) {
		push_single($client_list[0],$tmpfile);
	} elsif ($parallel) {
		my $running=0;
		while (1)  {
			last unless @client_list;
			if ($running<$parallel) {
				my $client=shift @client_list;
				my $pid=fork;
				defined $pid or die "$!\n";
				unless ($pid) {
					$0 = "pdist [push $client]";
					set_prefix($client);
					warn "started\n";
					push_single($client,$tmpfile);
					warn "finished\n";
					exit;
				}
				$running++
			} else {
				my $pid=wait;
				$running--;
			}
		}
		while (1) {
			my $pid=wait;
			$pid==-1 and last;
		}
	} else {
		my $pinger=new Net::Ping;
		for my $client (@client_list) {
			warn localtime()." processing client $client\n";
			unless ($pinger->ping($client)) {
				warn "$client: DOWN\n";
				next;
			}
			defined (my $pid=fork) or die "$0: $!\n";
			unless ($pid) {
				$0 = "pdist [push $client]";
				push_single($client,$tmpfile);
				exit;
			}
			waitpid ($pid,0);
		}
		warn localtime()." all clients done\n";
	}
	defined $tmpfile and unlink $tmpfile;
}

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

use constant USAGE => <<"__EOF__";

usage: $0 cmd [options]

# low level

  index                               # create file index on stdout
  request  want-indexfile             # produce request list on stdout
  pack                                # pack specified files to stdout tar archive
  update   want-indexfile [tarfile]   # update to want-indexfile using tar
  client master-name port [--msg-prefix] xxx  # client server

# high level

  push [options] client ...           # update client with our snapshot

     # client : hostname \@netgroup or ALL
     # ALL expands to HOSTS from Distfile (plus /root/Distfile.hostconfig if it exists)

# [common-options]

	--noop 	                # do not execute file operations
	--quiet			# do not log file operations
	--debug			# currently no function
	--distfilename name	# override distfilename
	--fileop_debug          # log all file operations
	--[no]delete		# do or do not clean up additional files on client.
				# default is delete unless --files is used
	--set-pdist-status	# force creation of /.pdist_status on target

	--verbose		# be more verbose
	--fileop_noop		# DEPRECATED: now --noop

	--parallel n		# maxmimun n parallel jobs
	--prompt		# allow (ssh password) prompts

# [index-options]

	--files spec		# override default file list - may be specified multiple times.

# [push-options]

	--ssh-tunnel remote-port		# use ssh tunnel for client to master callback

	--post-command command			# execute command after successfull update
	--timeout seconds		# timeout for client to finish

eg:
	$0 push pappnase --verbose --fileop_noop
	$0 push ALL
	$0 push pappnase amalie
	$0 push --files=/usr/local/lib/perl5/. ALL
	iview 1 'ps -Af|egrep "pdist|tar"|egrep -v "grep|nedit"||true'

__EOF__

use constant OPTIONS => (
	'noop'           => \$fileop_noop,
	'quiet'		 => \$quiet,
	'timeout=i'	 => \$timeout,

	'fileop_noop'    => sub { warn "warning: --fileop_noop deprecated. using --noop\n"; $fileop_noop=1;},

	'fileop_debug'   => \$fileop_debug,
	'delete!'        => \$delete,
	'set-pdist-status' => \$set_pdist_status,

	'verbose'	 => \$verbose,
	'debug'		 => \$debug,
	'distfilename=s' => \$distfilename,

	'files=s'        => \@files,

	'ssh-tunnel=i'   => \$ssh_tunnel,
	'post-command=s' => \$post_command,
	'parallel=i'	 => \$parallel,
	'prompt'	 => \$prompt,

	'msg-prefix=s'	 => \$msg_prefix,
);

GetOptions(OPTIONS) or die USAGE;

my $cmd=shift;
defined $cmd or die USAGE;

if ($cmd eq 'index') {
	init_from_distfile($distfilename);
	@ARGV==0 or die USAGE;
	prog_index();
} elsif ($cmd eq 'request') {
	@ARGV==1 or die USAGE;
	prog_update(F_REQUEST,@ARGV);
} elsif ($cmd eq 'pack') {
	@ARGV==0 or die USAGE;
	prog_pack();
} elsif ($cmd eq 'update') {
	@ARGV==1 || @ARGV==2  or die USAGE;
	prog_update(F_UPDATE,@ARGV);
} elsif ($cmd eq 'client') {
	@ARGV==2 or die USAGE;
	prog_client(@ARGV);
} elsif ($cmd eq 'push') {
	init_from_distfile($distfilename);
	defined $delete or $delete=(@files ? 0 : 1);
	@ARGV>=1 or die USAGE;
	prog_push(@ARGV);
} elsif ($cmd eq 'devel') {
	@ARGV==2 or die USAGE;
	fileop_cp(@ARGV);
} else {
	die USAGE;
}