summaryrefslogtreecommitdiffstats
path: root/lib/Sbuild.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Sbuild.pm')
-rw-r--r--lib/Sbuild.pm454
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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-07 01:20:24 +0000