#!/usr/bin/perl -w
use strict;

my $BLOCK_SIZE = 512;
die("BLOCK_SIZE too small\n") if $BLOCK_SIZE<500;
my $zeroblock=chr(0)x$BLOCK_SIZE;
my $tarheader=" "x$BLOCK_SIZE;
my (%uid, %gid, %file);
die("usage: $0 config\n") unless $#ARGV==0;
readconfig($ARGV[0]);
my $umask=umask();

while(1)
{
	my ($nameheader, $linkheader);
	my ($name, $link, $size, $typeflag, $mode)=
		read_header($tarheader, $nameheader, $linkheader);
	last unless defined($name);

	die("Unknown file type: $typeflag\n")
	    unless $typeflag eq "\0" || $typeflag=~/[0-9]/;

	my $found=0;
	my $pattern;
	for $pattern (keys(%file))
	{
#		print STDERR "Trying $name against $pattern\n";
		if ($name=~m!$pattern!s)
		{
#			print STDERR "$name matches pattern $pattern\n";
			fixup($nameheader, $typeflag, $mode, @{$file{$pattern}})
			    if (defined($nameheader));
			fixup($linkheader, $typeflag, $mode, @{$file{$pattern}})
			    if (defined($linkheader));
			fixup($tarheader, $typeflag, $mode, @{$file{$pattern}});
			$found=1;
			last;
		}
	}
	warn("No file information found in config file for $name\n") 
	    unless $found;
	
	if (defined($nameheader)) {
		write_block($nameheader);
		write_file($name);
	}
	if (defined($linkheader)) {
		write_block($linkheader);
		write_file($link);
	}
	write_block($tarheader);
	$size=getnum($size);
	pass_file($size);
}

sub read_header
{
	my ($longname, $longlink);
      readheader:
	do {
		return undef unless read_block($_[0]);
	} while $_[0] eq $zeroblock;

	my ($name, $mode, $uid, $gid, $size, $mtime, $chksum, 
	    $typeflag, $linkname, $magic, $version, $uname, $gname,
	    $devmajor, $devminor, $prefix)
	    =unpack("A100A8A8A8A12A12a8AA100a6a2A32A32A8A8A155", $_[0]);

	my $c;
	my $csum=0;
	for ($c=0; $c<500; $c++) { $csum+=ord(substr($_[0], $c, 1)); }
	for ($c=0; $c<8; $c++)   { $csum-=ord(substr($chksum, $c, 1)); }
	$csum+=ord(" ")*8;

	my $headercsum=getnum($chksum);

	die("Bad tar header (incorrect checksum)\n")
	    unless $headercsum == $csum;

	if ($magic eq "ustar" && $version eq "00") {
		# print "POSIX\n";
	} elsif ($magic eq "ustar " && $version eq " \0") {
		# print "OLDGNU\n";
	} else {
		die("Don't know this tar archive format\n");
	}

	if ($typeflag eq "L")
	{
		$longname=read_file(getnum($size));
		$_[1]=$_[0];
		goto readheader;
		
	}
	if ($typeflag eq "K")
	{
		$longlink=read_file(getnum($size));
		$_[2]=$_[0];
		goto readheader;
		
	}

	my $realname=$name;
	$realname=$longname if defined($longname);
	my $reallink=$linkname;
	$reallink=$longlink if defined($longlink);
	$size="0" if $typeflag eq "1";
	return ($realname, $reallink, $size, $typeflag, $mode);
}

sub read_block
{
	my $bytesread=sysread(STDIN, $_[0], $BLOCK_SIZE);
	die("read $!\n") unless defined($bytesread);
	die("short read on stdin (wanted $BLOCK_SIZE, read $bytesread)\n") 
	    unless $bytesread==$BLOCK_SIZE || $bytesread==0;
	return $bytesread!=0;
}

sub write_block
{
	my $byteswritten=syswrite(STDOUT, $_[0], $BLOCK_SIZE);
	die("write $!\n") unless defined($byteswritten);
	die("short write on stdout (tried $BLOCK_SIZE, wrote $byteswritten)\n") 
	    unless $byteswritten==$BLOCK_SIZE;
}

sub getnum
{
	my $value;
	my $str=shift;
	$str=~s/^ *//;
	if ($str=~/^[0-7]/)
	{
		return oct("0".$str);
	}
	if ($str=~/^[-+]/)
	{
		# base64
		die("Base64 numbers in tar header not supported\n");
	}
	if ($str=~/^[\200\377]/)
	{
		# base256
		my $l=length($str);
		my $c;
		$value=0;
		if ($str=~/^\377/)
		{
			for ($c=1; $c<$l; $c++)
			{
				$value=$value*256+256-ord(substr($str, $c, 1));
			}
		}
		else
		{
			for ($c=1; $c<$l; $c++)
			{
				$value=$value*256+ord(substr($str, $c, 1));
			}
		}
		return $value;
	}

	die("Couldn't parse (encoded) numeric value: $str\n");
}

sub pass_file
{
	my $size=shift;
	my $tmp;
	while ($size>0)
	{
		sysread(STDIN, $tmp, $BLOCK_SIZE);
		syswrite(STDOUT, $tmp, $BLOCK_SIZE);
		$size-=$BLOCK_SIZE;
	}
}

sub read_file
{
	my $size=shift;
	my $tmp;
	my $value="";
	while ($size>0)
	{
		my $bytesread=sysread(STDIN, $tmp, $BLOCK_SIZE);
		die("read: $!\n") unless defined($bytesread==0);
		die("short read on stdin\n") unless $bytesread==$BLOCK_SIZE;

		if ($size>=$BLOCK_SIZE) {
			$value.=$tmp;
		} else {
			$value.=substr($tmp, 0, $size);
		}
		$size-=$BLOCK_SIZE;
	}
	return $value;
}

sub write_file
{
	my $tmp=shift;
	my $offset=0;
      writeagain:
	while (length($tmp)>=$BLOCK_SIZE)
	{
		my $byteswritten=syswrite(STDOUT, $tmp, $BLOCK_SIZE);
		die("write: $!\n") unless defined($byteswritten);
		die("short write on stdout\n") unless $byteswritten==$BLOCK_SIZE;
		substr($tmp, 0, $BLOCK_SIZE)="";
	}
	return if length($tmp)==0;
	$tmp=$tmp."\0"x($BLOCK_SIZE-length($tmp));
	goto writeagain;	
}

sub readconfig
{
	my $configfile=shift;
	open(CONFIG, $configfile) || die("$configfile: $!\n");
	while (<CONFIG>)
	{
		chomp;
		next if /^#/ || /^$/;
		if (/^passwd: (.*)/)
		{
			readpwd($1);
			next;
		}
		if (/^group: (.*)/)
		{
			readgrp($1);
			next;
		}
		if (/^uid\(([^\)]+)\): (\d+)/)
		{
			$uid{$1}=$2;
			next;
		}
		if (/^gid\(([^\)]+)\): (\d+)/)
		{
			$gid{$1}=$2;
			next;
		}
		if (/^file\(([^\)]*)\): ([^\/]+)\/([^\/]+)\/([^\/]+)/)
		{
			my ($file, $perm, $user, $group)=($1, $2, $3, $4);
			die("user too long\n") if length($user)>32;
			die("group too long\n") if length($group)>32;
			die("Unknown user in config file: $user")
			    unless exists($uid{$user});
			die("Unknown group in config file: $group")
			    unless exists($gid{$group});
			my $u=sprintf("%o", $uid{$user});
			my $g=sprintf("%o", $gid{$group});
			die("uid too long in octal: $u\n") if length($u)>8;
			die("gid too long in octal: $g\n") if length($g)>8;
			die("perms invalid: $perm\n")
			    unless $perm=~/^[0-7]+$/ || 
				$perm=~/^[-ugoa+=rwxXstugo,]+$/;
			$file{$file}=[$perm, $u, $g, $user, $group];
			next;
		}
		die("Bad config line: $_\n");
	}
	close(CONFIG);
}

sub readpwd
{
	my $pwdfile=shift;
	open(PWD, $pwdfile) || die("$pwdfile: $!\n");
	while (<PWD>)
	{
		chomp;
		die("Bad format of password file (want min 7 fields): $_\n")
		    unless /^([^:]+):[^:]*:(\d+):\d+:[^:]*:[^:]*:[^:]*$/;
		$uid{$1}=$2;
	}
	close(PWD);
}

sub readgrp
{
	my $grpfile=shift;
	open(GRP, $grpfile) || die("$grpfile: $!\n");
	while (<GRP>)
	{
		chomp;
		die("Bad format of group file (want min 4 fields): $_\n")
		    unless /^([^:]+):[^:]*:(\d+):[^:]*$/;
		$gid{$1}=$2;
	}
	close(GRP);
}

sub fixup
{
	my ($header, $typeflag, $mode, $perm, $uid, $gid, $uname, $gname)=@_;
	$mode=permchange(getnum($mode), $perm, $typeflag eq "5", $umask);
	$mode=sprintf("%o", $mode);
	substr($_[0], 100, 8)=padzero($mode, 8);
	substr($_[0], 108, 8)=padzero($uid, 8);
	substr($_[0], 116, 8)=padzero($gid, 8);
	substr($_[0], 265, 32)=padnul($uname, 32);
	substr($_[0], 297, 32)=padnul($gname, 32);
	substr($_[0], 148, 8)="        ";
	my $c;
	my $csum=0;
	for ($c=0; $c<500; $c++) { $csum+=ord(substr($_[0], $c, 1)); }
	$csum=sprintf("%06o\0", $csum);
	substr($_[0], 148, length($csum))=$csum;
}

sub padnul
{
	my $wantlen=$_[1];
	my $len=length($_[0]);
	return $_[0].="\0"x($wantlen-$len);
}

sub padzero
{
	my $wantlen=$_[1];
	my $len=length($_[0]);
	return "0"x($wantlen-$len).$_[0];
}

sub permchange
{
	my ($perms, $newperms, $isdir, $umask)=@_;
	return oct("0".$newperms) if $newperms=~/^[0-7]+$/;
	my $operms = $perms;
	$isdir=1 if $perms & 0111;
	my @list=split(/,/, $newperms);
	for (@list)
	{
		my $mask=0;
		die("Invalid ownership change: $_\n") 
		    unless /^([ugoa]*)([-+=])([rwxXstugo]*)/;
		my ($target, $op, $action)=($1,$2,$3);
		for (split(//, $target))
		{
			$mask|=01700 if $_ eq "u";
			$mask|=02070 if $_ eq "g";
			$mask|=04007 if $_ eq "o";
			$mask|=07777 if $_ eq "a";
		}
		$mask=07777-$umask if $mask==0;
		my $actmask=0;
		for (split(//, $action))
		{
			$actmask|=00444 if $_ eq "r";
			$actmask|=00222 if $_ eq "w";
			$actmask|=00111 if $_ eq "x";
			$actmask|=00111 if $_ eq "X" && $isdir;
			$actmask|=06000 if $_ eq "s";
			$actmask|=01000 if $_ eq "t";
			$actmask|=00111*(($operms & 0700)>>6) if $_ eq "u";
			$actmask|=00111*(($operms & 0070)>>3) if $_ eq "g";
			$actmask|=00111*(($operms & 0007)>>0) if $_ eq "o";
		}
		if ($op eq "=") {
			my $complement=07777-$mask;
			$perms = ($mask & $actmask) | ($complement & $perms);
		} elsif ($op eq "+") {
			$perms |= ($mask & $actmask);
		} else {
			my $complement=07777-($mask & $actmask);
			$perms &= $complement;
		}
	}
	return $perms;
}