#
# Sbuild.pm: library for sbuild
# Copyright © 2005 Ryan Murray <rmurray@debian.org>
# Copyright © 2005-2008 Roger Leigh <rleigh@debian.org
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# 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, see
# <http://www.gnu.org/licenses/>.
#
#######################################################################

package Sbuild;

use Sbuild::Sysconfig;

use strict;
use warnings;
use POSIX;
use FileHandle;
use Filesys::Df qw();
use Time::Local;
use IO::Zlib;
use MIME::Base64;
use Dpkg::Control;
use Dpkg::Checksums;
use POSIX qw(locale_h);

BEGIN {
	use Exporter ();
	our (@ISA, @EXPORT);

	@ISA = qw(Exporter);

	@EXPORT = qw($debug_level $devnull binNMU_version parse_date isin
	  copy dump_file check_packages help_text version_text
	  usage_error send_mail debug debug2 df check_unshare
	  check_group_membership dsc_files dsc_pkgver shellescape strftime_c);
}

our $devnull;
our $debug_level = 0;

BEGIN {
	# A file representing /dev/null
	if (!open($devnull, '+<', '/dev/null')) {
		die "Cannot open /dev/null: $!\n";
	}
}

sub binNMU_version ($$$);
sub parse_date ($);
sub isin ($@);
sub copy ($);
sub dump_file ($);
sub check_packages ($$);
sub help_text ($$);
sub version_text ($);
sub usage_error ($$);
sub debug (@);
sub debug2 (@);
sub check_unshare($$);
sub check_group_membership();
sub dsc_files ($);
sub shellescape ($);
sub strftime_c ($@);

sub binNMU_version ($$$) {
	my $v                 = shift;
	my $binNMUver         = shift;
	my $append_to_version = shift;

	my $ver = $v;
	if (defined($append_to_version) && $append_to_version) {
		$ver .= $append_to_version;
	}
	if (defined($binNMUver) && $binNMUver) {
		$ver .= "+b$binNMUver";
	}
	return $ver;
}

my %monname = (
	'jan', 0, 'feb', 1, 'mar', 2, 'apr', 3, 'may', 4,  'jun', 5,
	'jul', 6, 'aug', 7, 'sep', 8, 'oct', 9, 'nov', 10, 'dec', 11
);

sub parse_date ($) {
	my $text = shift;

	return 0 if !$text;
	die "Cannot parse date: $text\n"
	  if $text !~ /^(\d{4}) (\w{3}) (\d+) (\d{2}):(\d{2}):(\d{2})$/;
	my ($year, $mon, $day, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6);
	$mon =~ y/A-Z/a-z/;
	die "Invalid month name $mon" if !exists $monname{$mon};
	$mon = $monname{$mon};
	return timegm($sec, $min, $hour, $day, $mon, $year);
}

sub isin ($@) {
	my $val = shift;
	return grep($_ eq $val, @_);
}

sub copy ($) {
	my $r = shift;
	my $new;

	if (ref($r) eq "HASH") {
		$new = {};
		foreach (keys %$r) {
			$new->{$_} = copy($r->{$_});
		}
	} elsif (ref($r) eq "ARRAY") {
		my $i;
		$new = [];
		for ($i = 0 ; $i < @$r ; ++$i) {
			$new->[$i] = copy($r->[$i]);
		}
	} elsif (!ref($r)) {
		$new = $r;
	} else {
		die "unknown ref type in copy\n";
	}

	return $new;
}

sub dump_file ($) {
	my $file = shift;

	if (-r "$file"
		&& open(SOURCES, "<$file")) {

		print
"   +------------------------------------------------------------------------\n";
		while (<SOURCES>) {
			chomp;
			print "   |$_\n";
		}
		print
"   +------------------------------------------------------------------------\n";
		close(SOURCES) or print "Failed to close $file\n";
	} else {
		print "W: Failed to open $file\n";
	}
}

# set and list saved package list (used by sbuild-checkpackages)
sub check_packages ($$) {
	my $session = shift;
	my $mode    = shift;

	my $package_checklist = $session->get_conf('PACKAGE_CHECKLIST');
	my $chroot_dir        = $session->get('Location');

	my (@status, @ref, @install, @remove);

	my $pipe = $session->pipe_command({
			COMMAND => [
				'dpkg-query', '--show',
				'--showformat=${Package} ${db:Status-Status}\n'
			] });
	while (<$pipe>) {
		chomp;
		my @token   = split / /, $_;
		my $pkgname = shift @token;
		my $state   = shift @token;
		next if $state ne "installed";
		push @status, $pkgname;
	}
	if (!close $pipe) {
		print STDERR "Error reading dpkg status file in chroot: $!\n";
		return 1;
	}
	@status = sort @status;
	if (!@status) {
		print STDERR "dpkg status file is empty\n";
		return 1;
	}

	if ($mode eq "set") {
		if (!open WREF, "> $chroot_dir/$package_checklist") {
			print STDERR
"Can't write reference status file $chroot_dir/$package_checklist: $!\n";
			return 1;
		}
		foreach (@status) {
			print WREF "$_\n";
		}
		if (!close WREF) {
			print STDERR "Error writing reference status file: $!\n";
			return 1;
		}
	} else {    # "list"
		if (!open REF, "< $chroot_dir/$package_checklist") {
			print STDERR
"Can't read reference status file $chroot_dir/$package_checklist: $!\n";
			return 1;
		}
		while (<REF>) {
			chomp;
			push @ref, $_;
		}
		if (!close REF) {
			print STDERR "Error reading reference status file: $!\n";
			return 1;
		}

		@ref = sort @ref;
		if (!@ref) {
			print STDERR "Reference status file is empty\n";
			return 1;
		}

		print "DELETE             ADD\n";
		print "--------------------------------------\n";
		my $i = 0;
		my $j = 0;

		while ($i < scalar @status && $j < scalar @ref) {

			my $c = $status[$i] cmp $ref[$j];
			if ($c < 0) {
				# In status, not reference; remove.
				print "$status[$i]\n";
				$i++;
			} elsif ($c > 0) {
				# In reference, not status; install.
				print "                   $ref[$j]\n";
				$j++;
			} else {
				# Identical; skip.
				$i++;
				$j++;
			}
		}

		# Print any remaining elements
		while ($i < scalar @status) {
			print "$status[$i]\n";
			$i++;
		}
		while ($j < scalar @ref) {
			print "                   $ref[$j]\n";
			$j++;
		}
	}
}

sub help_text ($$) {
	my $section = shift;
	my $page    = shift;

	system('man', '--', $section, $page);
	exit 0;
}

sub version_text ($) {
	my $program = shift;

	print <<"EOF";
$program (Debian sbuild) $Sbuild::Sysconfig::version ($Sbuild::Sysconfig::release_date)

Written by Roman Hodek, James Troup, Ben Collins, Ryan Murray, Rick
Younie, Francesco Paolo Lovergine, Michael Banck, Roger Leigh and
Andres Mejia.

Copyright © 1998-2000 Roman Hodek <roman\@hodek.net>
          © 1998-1999 James Troup <troup\@debian.org>
	  © 2003-2006 Ryan Murray <rmurray\@debian.org>
	  © 2001-2003 Rick Younie <younie\@debian.org>
	  © 2003-2004 Francesco Paolo Lovergine <frankie\@debian.org>
	  © 2005      Michael Banck <mbanck\@debian.org>
	  © 2005-2010 Roger Leigh <rleigh\@debian.org>
	  © 2009-2010 Andres Mejia <mcitadel\@gmail.com>

This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
EOF
	exit 0;
}

# Print an error message about incorrect command-line options
sub usage_error ($$) {
	my $program = shift;
	my $message = shift;

	print STDERR "E: $message\n";
	print STDERR
"I: Run '$program --help' to list usage example and all available options\n";
	exit 1;
}

sub send_mail ($$$$) {
	my $conf    = shift;
	my $to      = shift;
	my $subject = shift;
	my $file    = shift;
	local (*MAIL, *F);

	if (!open(F, "<$file")) {
		warn "Cannot open $file for mailing: $!\n";
		return 0;
	}
	local $SIG{'PIPE'} = 'IGNORE';

	if (!open(MAIL, "|" . $conf->get('MAILPROG') . " -oem $to")) {
		warn "Could not open pipe to " . $conf->get('MAILPROG') . ": $!\n";
		close(F);
		return 0;
	}

	print MAIL "From: " . $conf->get('MAILFROM') . "\n";
	print MAIL "To: $to\n";
	print MAIL "Subject: $subject\n";
	print MAIL "Content-Type: text/plain; charset=UTF-8\n";
	print MAIL "Content-Transfer-Encoding: 8bit\n";
	print MAIL "\n";
	while (<F>) {
		print MAIL "." if $_ eq ".\n";
		print MAIL $_;
	}

	close(F);
	if (!close(MAIL)) {
		warn $conf->get('MAILPROG') . " failed (exit status $?)\n";
		return 0;
	}
	return 1;
}

# Note: split to stderr
sub debug (@) {

	# TODO: Add debug level checking.
	if ($debug_level) {
		print STDERR "D: ", @_;
	}
}

sub debug2 (@) {

	# TODO: Add debug level checking.
	if ($debug_level && $debug_level >= 2) {
		print STDERR "D2: ", @_;
	}
}

sub df {
	my $dir = shift;

	my $stat = Filesys::Df::df($dir);

	return $stat->{bfree} if (defined($stat));

	# This only happens if $dir was not a valid file or directory.
	return 0;
}

sub check_unshare($$) {
	my $prog = shift;
	my $conf = shift;

	if ($conf->get('CHROOT_MODE') eq 'unshare') {
		print
		  "$prog is only useful for chroot_mode=\"schroot\" and \"sudo\".\n";
		print "\n";
		print "With the \"unshare\" mode, it is without function.\n";
		print "Instead, recreate tarballs from scratch or let sbuild \n";
		print
"manage them for you and use mmdebstrap_extra_args to do the custom setup.\n";
		exit 1;
	}
}

sub check_group_membership () {
	# Skip for root
	return if ($< == 0);

	my $user = getpwuid($<);
	my ($name, $passwd, $gid, $members) = getgrnam("sbuild");

	if (!$gid) {
		die "Group sbuild does not exist";
	}

	my $in_group = 0;
	my @groups   = getgroups();
	push @groups, getgid();
	foreach (@groups) {
		($name, $passwd, $gid, $members) = getgrgid($_);
		$in_group = 1 if defined($name) && $name eq 'sbuild';
	}

	if (!$in_group) {
		print STDERR
"User $user is not currently an effective member of group sbuild. Please run:\n";
		print STDERR " sudo sbuild-adduser $user\n";
		print STDERR
"And then either log out and log in again or use `newgrp sbuild` to gain sbuild group privileges\n";
		exit(1);
	}

	return;
}

sub dsc_files ($) {
	my $dsc = shift;

	debug("Parsing $dsc\n");
	my $pdsc = Dpkg::Control->new(type => CTRL_PKG_SRC);
	$pdsc->set_options(allow_pgp => 1);
	if (!$pdsc->load($dsc)) {
		print STDERR "Could not parse $dsc\n";
		return undef;
	}

	my $csums = Dpkg::Checksums->new();
	$csums->add_from_control($pdsc, use_files_for_md5 => 1);
	return $csums->get_files();
}

sub dsc_pkgver ($) {
	my $dsc = shift;

	debug("Parsing $dsc\n");
	my $pdsc = Dpkg::Control->new(type => CTRL_PKG_SRC);
	$pdsc->set_options(allow_pgp => 1);
	if (!$pdsc->load($dsc)) {
		print STDERR "Could not parse $dsc\n";
		return undef;
	}

	return ($pdsc->{'Source'}, $pdsc->{'Version'});
}

# avoid dependency on String::ShellQuote by implementing the mechanism
# from python's shlex.quote function
sub shellescape ($) {
	my $string = shift;
	if (length $string == 0) {
		return "''";
	}
	# search for occurrences of characters that are not safe
	# the 'a' regex modifier makes sure that \w only matches ASCII
	if ($string !~ m/[^\w@\%+=:,.\/-]/a) {
		return $string;
	}
	# wrap the string in single quotes and handle existing single quotes by
	# putting them outside of the single-quoted string
	$string =~ s/'/'"'"'/g;
	return "'$string'";
}

# this function uses strftime to format a timestamp as a string but makes sure
# to use the C locale to do so instead of the system locale
sub strftime_c ($@) {
	my $format = shift;
	my @time   = @_;

	my $old_locale = setlocale(LC_TIME);
	setlocale(LC_TIME, "C.UTF-8");
	my $ret = strftime $format, @time;
	setlocale(LC_TIME, $old_locale);

	return $ret;
}

1;
