#!/usr/bin/perl

#############################################################################
# Copyright (c) 2012 Novell, Inc.
# All Rights Reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of version 2 of the GNU General Public License as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.   See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, contact Novell, Inc.
#
# To contact Novell about this file by physical or electronic mail,
# you may find current contact information at www.novell.com
#############################################################################

# A very limited tar writer. Creates archives in the ustar format and
# makes sure that identical content results in identical archives.

use strict;
use warnings;

my $USAGE = "Usage: $0 --mtime=<decimal timestamp> [--exclude=<pattern] [-C directory] file|directory ... >archive.tar\n";

use Getopt::Long;
use File::Find;
use File::Copy;
use Fcntl ':mode';

my $mtime;
my $disable_paxheaders;
my $chdir;
my $files_from;
my @exclude = ();
GetOptions(
	"t|mtime=i" => \$mtime,
	"exclude=s" => \@exclude,
	"no-paxheaders" => \$disable_paxheaders,
	"C=s" => \$chdir,
	"T|files-from=s" => \$files_from,
) or die($USAGE);

if (!defined($mtime)) {
	warn "$0: --mtime not specified, using 2000-01-01\n";
	$mtime = 946681200;
}
my @args;
if ($files_from) {
	if ($files_from eq '-') {
		@args = <>;
	} else {
		open(my $fh, '<', $files_from) or die "$files_from: $!\n";
		@args = <$fh>;
		close($fh);
	}
	chomp(@args);
} else {
	@args = @ARGV;
}
if (!@args) {
	print STDERR "No arguments given\n";
	die($USAGE);
}

chdir($chdir) if $chdir;
my @files;

s/\./\\./g for @exclude;
s/\*/.*/g for @exclude;
s/\?/./g for @exclude;
s/.*/^$&\$/ for @exclude;
sub wanted {
	for my $pattern (@exclude) {
		return if $_ =~ $pattern;
	}
	push(@files, $File::Find::name);
}

for my $file (@args) {
	if (-d $file) {
		find(\&wanted, $file);
	} else {
		push(@files, $file);
	}
}
$| = 1;
my $total_size = 0;

# Tar header format description
# filed => <width><type>
# where type is either _s_string or _o_ctal
my @header_layout = (
	name => "100s",
	mode => "8o",
	uid => "8o",
	gid => "8o",
	size => "12o",
	mtime => "12o",
	csum => "8s",
	typeflag => "1s",
	linktarget => "100s",
	magic => "6s",
	version => "2s",
	user => "32s",
	group => "32s",
	devmajor => "8o",
	devminor => "8o",
	prefix => "155s"
);

for my $file (sort(@files)) {
	my %header = ();

	$header{name} = $file;
	my $need_paxheader = 0;
	if (length($file) > 100) {
		($header{prefix} = $file) =~ s:/[^/]*$::;
		($header{name} = $file) =~ s:^.*/::;
		if (length($header{name}) > 100 ||
					length($header{prefix}) > 155) {
			if ($disable_paxheaders) {
				die "Too long filenames are impossible with --no-paxheaders: $file\n";
			}
			$header{name} = substr($header{name}, 0, 100);
			$header{prefix} = substr($header{prefix}, 0, 155);
			$need_paxheader = 1;
		}
	}
	my @stat = lstat($file) or die "$file: $!\n";
	my $mode = $stat[2];
	$header{mode} = ($mode & 0111) ? 0755 : 0644;
	# 65534:65534 is commonly used for nobody:nobody
	$header{uid} = 65534;
	$header{gid} = 65533;
	$header{user} = "nobody";
	$header{group} = "nobody";

	$header{mtime} = $mtime;

	if ($need_paxheader) {
		my $record = "path=$file\n";
		# length means length of the whole record, including the
		# length number
		my $length = length($record) + 2;
		while ($length < length(sprintf("%d %s", $length, $record))) {
			$length++;
		}
		$record = sprintf("%d %s", $length, $record);
		$header{typeflag} = "x";
		$header{size} = length($record);
		print gen_header(\%header);
		$total_size += 512;
		print $record;
		# padding to 512 byte boundary
		my $pad = pad_tail($header{size}, 512);
		print $pad;
		$total_size += length($pad);
	}
	if (S_ISREG($mode)) {
		$header{size} = $stat[7];
		$header{typeflag} = "0";
	} elsif (S_ISLNK($mode)) {
		$header{size} = 0;
		$header{linktarget} = readlink($file);
		$header{typeflag} = "2";
	} elsif (S_ISDIR($mode)) {
		$header{size} = 0;
		$header{typeflag} = "5";
	} else {
		die "Only regular files, symlinks and directories supported: $file\n";
	}
	print gen_header(\%header);
	$total_size += 512;
	next unless S_ISREG($mode);

	# PAYLOAD
	copy($file, \*STDOUT);
	$total_size += $header{size};
	# padding to 512 byte boundary
	my $pad = pad_tail($header{size}, 512);
	print $pad;
	$total_size += length($pad);
}
# end of archive marker
print pad("", 1024);
$total_size += 1024;
# pad to 10240 boundary
print pad_tail($total_size, 10240);
exit;

sub gen_header {
	my $header = shift;

	$header->{magic} = "ustar";
	$header->{version} = "00";

	my $res = "";
	my $csum_pos = 0;
	for (my $i = 0; $i < scalar(@header_layout); $i += 2) {
		my $field = $header_layout[$i];
		my $fmt = $header_layout[$i + 1];
		(my $length = $fmt) =~ s/.$//;
		(my $type = $fmt) =~ s/^\d*//;
		my $value = $header->{$field};

		# special case
		if ($field eq "csum") {
			$csum_pos = length($res);
			$res .= " " x 8;
			next;
		}
		if ($type eq "s") {
			$value = "" unless defined($value);
			$res .= pad($value, $length);
		} elsif ($type eq "o") {
			$value = 0 unless defined($value);
			$res .= pad_octal($value, $length);
		} else {
			die "Invalid format for $field: $fmt";
		}
	}
	# add the checksum, using the "%06o\0 " format like GNU tar
	my $csum = header_checksum($res);
	substr($res, $csum_pos, 7) = pad_octal($csum, 7);

	# padding to 512 byte boundary
	$res .= pad("", 12);
	die "error: header is not 512 bytes long" unless length($res) == 512;

	return $res;
}

sub pad {
	my ($string, $length) = @_;
	
	my $pad = $length - length($string);
	if ($pad < 0) {
		die "Field over $length bytes: $string\n";
	}
	return $string . "\0" x $pad;
}

sub pad_octal {
	my ($num, $length) = @_;

	$length--;
	return sprintf("%0${length}o\0", $num);
}

# after $size bytes written, padd to the neares $boundary
sub pad_tail {
	my ($size, $boundary) = @_;

	return "" unless $size % $boundary;
	my $padding = $boundary - $size % $boundary;
	return pad("", $padding);
}

sub header_checksum {
	my $header = shift;

	my $res = 0;
	for (my $i = 0; $i < length($header); $i++) {
		$res += ord(substr($header, $i, 1))
	}
	return $res;
}