X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=8db03b3f5ee8737b55a50b1c8c585c66c0ea1ec0;hp=2e67eb5be574b26115d412101be1956c314d9bfb;hb=2ed034f34fe81fcdb2232d8d7a5e7c02dcb091dd;hpb=b839e9edc77dde4c40f2a8479e1b42223852daee

diff --git a/dgit b/dgit
index 2e67eb5b..8db03b3f 100755
--- a/dgit
+++ b/dgit
@@ -18,6 +18,7 @@
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 use strict;
+$SIG{__WARN__} = sub { die $_[0]; };
 
 use IO::Handle;
 use Data::Dumper;
@@ -98,9 +99,6 @@ our %opts_opt_cmdonly = ('gpg' => 1);
 
 our $keyid;
 
-our $debug = 0;
-open DEBUG, ">/dev/null" or die $!;
-
 autoflush STDOUT 1;
 
 our $remotename = 'dgit';
@@ -131,7 +129,7 @@ sub dscfn ($) {
 }
 
 our $us = 'dgit';
-our $debugprefix = '';
+initdebug('');
 
 our @end;
 END { 
@@ -159,8 +157,6 @@ sub waitstatusmsg () {
     }
 }
 
-sub printdebug { print DEBUG $debugprefix, @_ or die $!; }
-
 sub fail { 
     my $s = "@_\n";
     my $prefix = $us.($we_are_responder ? " (build host)" : "").": ";
@@ -378,29 +374,6 @@ sub url_get {
 
 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 
-sub shellquote {
-    my @out;
-    local $_;
-    foreach my $a (@_) {
-	$_ = $a;
-	if (m{[^-=_./0-9a-z]}i) {
-	    s{['\\]}{'\\$&'}g;
-	    push @out, "'$_'";
-	} else {
-	    push @out, $_;
-	}
-    }
-    return join ' ', @out;
-}
-
-sub printcmd {
-    my $fh = shift @_;
-    my $intro = shift @_;
-    print $fh $intro," " or die $!;
-    print $fh shellquote @_ or die $!;
-    print $fh "\n" or die $!;
-}
-
 sub failedcmd {
     { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; };
     if ($!) {
@@ -413,7 +386,7 @@ sub failedcmd {
 }
 
 sub runcmd {
-    printcmd(\*DEBUG,$debugprefix."+",@_) if $debug>0;
+    debugcmd "+",@_;
     $!=0; $?=0;
     failedcmd @_ if system @_;
 }
@@ -431,16 +404,16 @@ sub printdone {
 
 sub cmdoutput_errok {
     die Dumper(\@_)." ?" if grep { !defined } @_;
-    printcmd(\*DEBUG,$debugprefix."|",@_) if $debug>0;
+    debugcmd "|",@_;
     open P, "-|", @_ or die $!;
     my $d;
     $!=0; $?=0;
     { local $/ = undef; $d = <P>; }
     die $! if P->error;
-    if (!close P) { printdebug "=>!$?\n" if $debug>0; return undef; }
+    if (!close P) { printdebug "=>!$?\n"; return undef; }
     chomp $d;
     $d =~ m/^.*/;
-    printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
+    printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debuglevel>0; #';
     return $d;
 }
 
@@ -518,7 +491,7 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit.default.ssh' => 'ssh',
 	       'dgit.default.archive-query' => 'madison:',
 	       'dgit.default.sshpsql-dbname' => 'service=projectb',
-	       'dgit-distro.debian.archive-query' => 'sshpsql:',
+	       'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
 	       'dgit-distro.debian.git-host' => 'dgit-git.debian.net',
 	       'dgit-distro.debian.git-user-force' => 'dgit',
 	       'dgit-distro.debian.git-proto' => 'git+ssh://',
@@ -533,7 +506,6 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
 	       'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
 	       'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
-	       'dgit-distro.debian.sshpsql-host' => 'mirror.ftp-master.debian.org',
 	       'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
@@ -547,7 +519,8 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit-distro.test-dummy.git-url' => "$td/git",
 	       'dgit-distro.test-dummy.git-host' => "git",
 	       'dgit-distro.test-dummy.git-path' => "$td/git",
-	       'dgit-distro.test-dummy.archive-query' => "dummycat:$td/aq",
+	       'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
+	       'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
 	       'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
 	       'dgit-distro.test-dummy.upload-host' => 'test-dummy',
                );
@@ -558,7 +531,7 @@ sub cfg {
 	my @cmd = (@git, qw(config --), $c);
 	my $v;
 	{
-	    local ($debug) = $debug-1;
+	    local ($debuglevel) = $debuglevel-2;
 	    $v = cmdoutput_errok @cmd;
 	};
 	if ($?==0) {
@@ -790,7 +763,7 @@ sub pool_dsc_subpath ($$) {
     return "/pool/$component/$prefix/$package/".dscfn($vsn);
 }
 
-#---------- `ftpmaster-api' archive query method (nascent) ----------
+#---------- `ftpmasterapi' archive query method (nascent) ----------
 
 sub archive_api_query_cmd ($) {
     my ($subpath) = @_;
@@ -813,6 +786,67 @@ sub archive_api_query_cmd ($) {
     return @cmd;
 }
 
+sub api_query ($$) {
+    use JSON;
+    my ($data, $subpath) = @_;
+    badcfg "ftpmasterapi archive query method takes no data part"
+	if length $data;
+    my @cmd = archive_api_query_cmd($subpath);
+    my $json = cmdoutput @cmd;
+    return decode_json($json);
+}
+
+sub canonicalise_suite_ftpmasterapi () {
+    my ($proto,$data) = @_;
+    my $suites = api_query($data, 'suites');
+    my @matched;
+    foreach my $entry (@$suites) {
+	next unless grep { 
+	    my $v = $entry->{$_};
+	    defined $v && $v eq $isuite;
+	} qw(codename name);
+	push @matched, $entry;
+    }
+    fail "unknown suite $isuite" unless @matched;
+    my $cn;
+    eval {
+	@matched==1 or die "multiple matches for suite $isuite\n";
+	$cn = "$matched[0]{codename}";
+	defined $cn or die "suite $isuite info has no codename\n";
+	$cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
+    };
+    die "bad ftpmaster api response: $@\n".Dumper(\@matched)
+	if length $@;
+    return $cn;
+}
+
+sub archive_query_ftpmasterapi () {
+    my ($proto,$data) = @_;
+    my $info = api_query($data, "dsc_in_suite/$isuite/$package");
+    my @rows;
+    my $digester = Digest::SHA->new(256);
+    foreach my $entry (@$info) {
+	eval {
+	    my $vsn = "$entry->{version}";
+	    my ($ok,$msg) = version_check $vsn;
+	    die "bad version: $msg\n" unless $ok;
+	    my $component = "$entry->{component}";
+	    $component =~ m/^$component_re$/ or die "bad component";
+	    my $filename = "$entry->{filename}";
+	    $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
+		or die "bad filename";
+	    my $sha256sum = "$entry->{sha256sum}";
+	    $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
+	    push @rows, [ $vsn, "/pool/$component/$filename",
+			  $digester, $sha256sum ];
+	};
+	die "bad ftpmaster api response: $@\n".Dumper($entry)
+	    if length $@;
+    }
+    @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
+    return @rows;
+}
+
 #---------- `madison' archive query method ----------
 
 sub archive_query_madison {
@@ -874,9 +908,9 @@ sub sshpsql ($$$) {
     my @rows;
     my @cmd = (access_cfg_ssh, $userhost,
 	       access_runeinfo("ssh-psql $runeinfo").
-	       " export LANG=C;".
+	       " export LC_MESSAGES=C; export LC_CTYPE=C;".
 	       " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
-    printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0;
+    debugcmd "|",@cmd;
     open P, "-|", @cmd or die $!;
     while (<P>) {
 	chomp or die;
@@ -1008,9 +1042,9 @@ sub get_archive_dsc () {
 		    " archive told us to expect $digest";
 	}
 	my $dscfh = new IO::File \$dscdata, '<' or die $!;
-	printdebug Dumper($dscdata) if $debug>1;
+	printdebug Dumper($dscdata) if $debuglevel>1;
 	$dsc = parsecontrolfh($dscfh,$dscurl,1);
-	printdebug Dumper($dsc) if $debug>1;
+	printdebug Dumper($dsc) if $debuglevel>1;
 	my $fmt = getfield $dsc, 'Format';
 	fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
 	$dsc_checked = !!$digester;
@@ -1355,8 +1389,8 @@ $later_warning_msg
 END
 	    $hash = $lastpush_hash;
 	} else {
-	    fail "archive's .dsc refers to ".$dsc_hash.
-		" but this is an ancestor of ".$lastpush_hash;
+	    fail "git head (".lrref()."=$lastpush_hash) is not a ".
+		"descendant of archive's .dsc hash ($dsc_hash)";
 	}
     } elsif ($dsc) {
 	$hash = generate_commit_from_dsc();
@@ -1442,8 +1476,8 @@ sub clone ($) {
     }
     fetch_from_archive() or no_such_package;
     my $vcsgiturl = $dsc->{'Vcs-Git'};
-    $vcsgiturl =~ s/\s+-b\s+\S+//g;
     if (length $vcsgiturl) {
+	$vcsgiturl =~ s/\s+-b\s+\S+//g;
 	runcmd @git, qw(remote add vcs-git), $vcsgiturl;
     }
     runcmd @git, qw(reset --hard), lrref();
@@ -1468,7 +1502,7 @@ sub pull () {
 sub check_not_dirty () {
     return if $ignoredirty;
     my @cmd = (@git, qw(diff --quiet HEAD));
-    printcmd(\*DEBUG,$debugprefix."+",@cmd) if $debug>0;
+    debugcmd "+",@cmd;
     $!=0; $?=0; system @cmd;
     return if !$! && !$?;
     if (!$! && $?==256) {
@@ -1658,9 +1692,9 @@ sub dopush () {
         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
     changedir '../../../..';
-    my $diffopt = $debug>0 ? '--exit-code' : '--quiet';
+    my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
-    printcmd \*DEBUG,$debugprefix."+",@diffcmd;
+    debugcmd "+",@diffcmd;
     $!=0; $?=0;
     my $r = system @diffcmd;
     if ($r) {
@@ -1958,7 +1992,7 @@ sub cmd_rpush {
     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
     push @rdgit, @ARGV;
     my @cmd = (@ssh, $host, shellquote @rdgit);
-    printcmd \*DEBUG,$debugprefix."+",@cmd;
+    debugcmd "+",@cmd;
 
     if (defined $initiator_tempdir) {
 	rmtree $initiator_tempdir;
@@ -2663,6 +2697,7 @@ sub cmd_archive_api_query {
     badusage "need only 1 subpath argument" unless @ARGV==1;
     my ($subpath) = @ARGV;
     my @cmd = archive_api_query_cmd($subpath);
+    debugcmd ">",@cmd;
     exec @cmd or fail "exec curl: $!\n";
 }
 
@@ -2767,9 +2802,8 @@ sub parseopts () {
 		    cmd_help();
 		} elsif (s/^-D/-/) {
 		    push @ropts, $&;
-		    open DEBUG, ">&STDERR" or die $!;
-		    autoflush DEBUG 1;
-		    $debug++;
+		    $debuglevel++;
+		    enabledebug();
 		} elsif (s/^-N/-/) {
 		    push @ropts, $&;
 		    $new_package=1;