Adding upstream version 0.85.6.upstream/0.85.6

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 454 insertions, 0 deletions

diff --git a/lib/Sbuild.pm b/lib/Sbuild.pm
new file mode 100644
index 0000000..d4ddf52
--- /dev/null
+++ b/lib/Sbuild.pm
@@ -0,0 +1,454 @@
+#
+# 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_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_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_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;