X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=94b9ab16d287592a9a808d695e7c413524e77011;hp=088f5d29174efbe53c5f534c86d3d05ef313bbfa;hb=82fe8098ed0b3749821190dfcbb0062947bd024b;hpb=92ce4806cd4e9029cb5aaf96abbb51d6e9442c1c

diff --git a/dgit b/dgit
index 088f5d29..94b9ab16 100755
--- a/dgit
+++ b/dgit
@@ -40,6 +40,7 @@ our @ropts;
 our $sign = 1;
 our $dryrun_level = 0;
 our $changesfile;
+our $buildproductsdir = '..';
 our $new_package = 0;
 our $ignoredirty = 0;
 our $noquilt = 0;
@@ -441,6 +442,8 @@ sub cmd_help () {
     exit 0;
 }
 
+our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
+
 our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit.default.username' => '',
 	       'dgit.default.archive-query-default-component' => 'main',
@@ -453,7 +456,20 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       'dgit-distro.debian.sshpsql-host' => 'coccia.debian.org',
 	       'dgit-distro.debian.sshpsql-dbname' => 'service=projectb',
 	       'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
-	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/');
+	       'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
+ 'dgit-distro.debian.backports-quirk' => '%-backports*',
+ 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
+	       'dgit-distro.test-dummy.ssh' => "$td/ssh",
+	       'dgit-distro.test-dummy.username' => "alice",
+	       'dgit-distro.test-dummy.git-check' => "ssh-cmd",
+	       'dgit-distro.test-dummy.git-create' => "ssh-cmd",
+	       '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.mirror' => "file://$td/mirror/",
+	       'dgit-distro.test-dummy.upload-host' => 'test-dummy',
+               );
 
 sub cfg {
     foreach my $c (@_) {
@@ -475,16 +491,41 @@ sub cfg {
     badcfg "need value for one of: @_";
 }
 
-sub access_distro () {
+sub access_basedistro () {
     return cfg("dgit-suite.$isuite.distro",
 	       "dgit.default.distro");
 }
 
+sub access_quirk () {
+    # returns (quirk name, distro to use instead, quirk-specific info)
+    my $basedistro = access_basedistro();
+    my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
+			      'RETURN-UNDEF');
+    if (defined $backports_quirk) {
+	my $re = $backports_quirk;
+	$re =~ s/[^-0-9a-z_\%*]/\\$&/ig;
+	$re =~ s/\*/.*/g;
+	$re =~ s/\%/([-0-9a-z_]+)/ or badcfg "backports-quirk needs \%";
+	if ($isuite =~ m/^$re$/) {
+	    return ('backports',"$basedistro-backports",$1);
+	}
+    }
+    return ('none',$basedistro);
+}
+
+sub access_distro () {
+    return (access_quirk())[1];
+}
+
 sub access_cfg (@) {
     my (@keys) = @_;
+    my $basedistro = access_basedistro();
     my $distro = $idistro || access_distro();
-    my $value = cfg(map { ("dgit-distro.$distro.$_",
-			   "dgit.default.$_") } @keys);
+    my $value = cfg(map {
+	("dgit-distro.$distro.$_",
+	 "dgit-distro.$basedistro.$_",
+	 "dgit.default.$_")
+		    } @keys);
     return $value;
 }
 
@@ -586,7 +627,7 @@ sub archive_query ($) {
     my ($method) = @_;
     my $query = access_cfg('archive-query','RETURN-UNDEF');
     if (!defined $query) {
-	my $distro = access_distro();
+	my $distro = access_basedistro();
 	if ($distro eq 'debian') {
 	    $query = "sshpsql:".
 		access_someuserhost('sshpsql').':'.
@@ -623,7 +664,7 @@ sub madison_parse ($) {
 	$l =~ m{^ \s*( [^ \t|]+ )\s* \|
                   \s*( [^ \t|]+ )\s* \|
                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
-                  \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
+                  \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
 	$1 eq $package or die "$rmad $package ?";
 	my $vsn = $2;
 	my $newsuite = $3;
@@ -663,7 +704,7 @@ sub sshpsql ($$) {
 	printdebug("$debugprefix>|$_|\n");
 	push @rows, $_;
     }
-    $!=0; $?=0; close P or die "$! $?";
+    $!=0; $?=0; close P or failedcmd @cmd;
     @rows or die;
     my $nrows = pop @rows;
     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
@@ -715,6 +756,45 @@ END
     return $rows[0];
 }
 
+sub canonicalise_suite_dummycat ($$) {
+    my ($proto,$data) = @_;
+    my $dpath = "$data/suite.$isuite";
+    if (!open C, "<", $dpath) {
+	$!==ENOENT or die "$dpath: $!";
+	printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
+	return $isuite;
+    }
+    $!=0; $_ = <C>;
+    chomp or die "$dpath: $!";
+    close C;
+    printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
+    return $_;
+}
+
+sub archive_query_dummycat ($$) {
+    my ($proto,$data) = @_;
+    canonicalise_suite();
+    my $dpath = "$data/package.$csuite.$package";
+    if (!open C, "<", $dpath) {
+	$!==ENOENT or die "$dpath: $!";
+	printdebug "dummycat query $csuite $package $dpath ENOENT\n";
+	return ();
+    }
+    my @rows;
+    while (<C>) {
+	next if m/^\#/;
+	next unless m/\S/;
+	die unless chomp;
+	printdebug "dummycat query $csuite $package $dpath | $_\n";
+	my @row = split /\s+/, $_;
+	@row==2 or die "$dpath: $_ ?";
+	push @rows, \@row;
+    }
+    C->error and die "$dpath: $!";
+    close C;
+    return sort { -version_compare_string($a->[0],$b->[0]); } @rows;
+}
+
 sub canonicalise_suite () {
     return if defined $csuite;
     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
@@ -1267,13 +1347,14 @@ sub dopush () {
     my ($clogp, $cversion, $tag, $dscfn) =
 	push_parse_changelog("$clogpfn");
 
-    stat "../$dscfn" or
+    my $dscpath = "$buildproductsdir/$dscfn";
+    stat $dscpath or
 	fail "looked for .dsc $dscfn, but $!;".
 	    " maybe you forgot to build";
 
-    responder_send_file('dsc', "../$dscfn");
+    responder_send_file('dsc', $dscpath);
 
-    push_parse_dsc("../$dscfn", $dscfn, $cversion);
+    push_parse_dsc($dscpath, $dscfn, $cversion);
 
     my $format = getfield $dsc, 'Format';
     printdebug "format $format\n";
@@ -1283,7 +1364,8 @@ sub dopush () {
     check_not_dirty();
     changedir $ud;
     progress "checking that $dscfn corresponds to HEAD";
-    runcmd qw(dpkg-source -x --), "../../../../$dscfn";
+    runcmd qw(dpkg-source -x --),
+        $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
     changedir '../../../..';
     my @diffcmd = (@git, qw(diff --exit-code), $tree);
@@ -1305,19 +1387,22 @@ sub dopush () {
 #        (uploadbranch());
     my $head = rev_parse('HEAD');
     if (!$changesfile) {
-	my $multi = "../${package}_".(stripepoch $cversion)."_multi.changes";
+	my $multi = "$buildproductsdir/".
+	    "${package}_".(stripepoch $cversion)."_multi.changes";
 	if (stat "$multi") {
 	    $changesfile = $multi;
 	} else {
 	    $!==&ENOENT or die "$multi: $!";
 	    my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
-	    my @cs = glob "../$pat";
+	    my @cs = glob "$buildproductsdir/$pat";
 	    fail "failed to find unique changes file".
-		" (looked for $pat in .., or $multi);".
+		" (looked for $pat in $buildproductsdir, or $multi);".
 		" perhaps you need to use dgit -C"
 		unless @cs==1;
 	    ($changesfile) = @cs;
 	}
+    } else {
+	$changesfile = "$buildproductsdir/$changesfile";
     }
 
     responder_send_file('changes',$changesfile);
@@ -1332,7 +1417,7 @@ sub dopush () {
     } else {
 	$tagobjfn =
 	    push_mktag($head,$clogp,$tag,
-		       "../$dscfn",
+		       $dscpath,
 		       $changesfile,$changesfile,
 		       $tfn);
     }
@@ -1350,16 +1435,16 @@ sub dopush () {
 
     if (!$we_are_responder) {
 	if (act_local()) {
-	    rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
+	    rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
 	} else {
-	    progress "[new .dsc left in $dscfn.tmp]";
+	    progress "[new .dsc left in $dscpath.tmp]";
 	}
     }
 
     if ($we_are_responder) {
 	my $dryrunsuffix = act_local() ? "" : ".tmp";
 	responder_receive_files('signed-dsc-changes',
-				"../$dscfn$dryrunsuffix",
+				"$dscpath$dryrunsuffix",
 				"$changesfile$dryrunsuffix");
     } else {
 	sign_changes $changesfile;
@@ -1676,6 +1761,17 @@ sub build_maybe_quilt_fixup () {
     chomp;
     return unless madformat($_);
     # sigh
+    
+    my @cmd = (@git, qw(ls-files --exclude-standard -iodm));
+    my $problems = cmdoutput @cmd;
+    if (length $problems) {
+	print STDERR "problematic files:\n";
+	print STDERR "  $_\n" foreach split /\n/, $problems;
+	fail "Cannot do quilt fixup in tree containing ignored files.  ".
+	    "Perhaps your package's clean target is broken, in which".
+	    " case -wg (which says to use git-clean -xdf) may help.";
+    }
+
     my $clogp = parsechangelog();
     my $version = getfield $clogp, 'Version';
     my $author = getfield $clogp, 'Maintainer';
@@ -1735,9 +1831,21 @@ sub quilt_fixup_editor () {
     exit 0;
 }
 
+sub clean_tree () {
+    if ($cleanmode eq 'dpkg-source') {
+	runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
+    } elsif ($cleanmode eq 'git') {
+	runcmd_ordryrun_local @git, qw(clean -xdf);
+    } elsif ($cleanmode eq 'none') {
+    } else {
+	die "$cleanmode ?";
+    }
+}
+
 sub build_prep () {
     badusage "-p is not allowed when building" if defined $package;
     check_not_dirty();
+    clean_tree();
     my $clogp = parsechangelog();
     $isuite = getfield $clogp, 'Distribution';
     $package = getfield $clogp, 'Source';
@@ -1749,9 +1857,16 @@ sub changesopts () {
     my @opts =@changesopts[1..$#changesopts];
     if (!defined $changes_since_version) {
 	my @vsns = archive_query('archive_query');
+	my @quirk = access_quirk();
+	if ($quirk[0] eq 'backports') {
+	    local $isuite = $quirk[2];
+	    local $csuite;
+	    canonicalise_suite();
+	    push @vsns, archive_query('archive_query');
+	}
 	if (@vsns) {
 	    @vsns = map { $_->[0] } @vsns;
-	    @vsns = sort { version_compare_string($a, $b) } @vsns;
+	    @vsns = sort { -version_compare_string($a, $b) } @vsns;
 	    $changes_since_version = $vsns[0];
 	    progress "changelog will contain changes since $vsns[0]";
 	} else {
@@ -1766,16 +1881,12 @@ sub changesopts () {
 }
 
 sub cmd_build {
-    badusage "dgit build implies --clean=dpkg-source"
-	if $cleanmode ne 'dpkg-source';
     build_prep();
     runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV;
     printdone "build successful\n";
 }
 
 sub cmd_git_build {
-    badusage "dgit git-build implies --clean=dpkg-source"
-	if $cleanmode ne 'dpkg-source';
     build_prep();
     my @cmd =
 	(qw(git-buildpackage -us -uc --git-no-sign-tags),
@@ -1797,12 +1908,6 @@ sub build_source {
 	runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
 	    changesopts();
     } else {
-	if ($cleanmode eq 'git') {
-	    runcmd_ordryrun_local @git, qw(clean -xdf);
-	} elsif ($cleanmode eq 'none') {
-	} else {
-	    die "$cleanmode ?";
-	}
 	my $pwd = cmdoutput qw(env - pwd);
 	my $leafdir = basename $pwd;
 	changedir "..";
@@ -1896,12 +2001,12 @@ sub parseopts () {
 	    } elsif (m/^--since-version=([^_]+|_)$/) {
 		push @ropts, $_;
 		$changes_since_version = $1;
-	    } elsif (m/^--(\w+)=(.*)/s &&
+	    } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
 		     ($om = $opts_opt_map{$1}) &&
 		     length $om->[0]) {
 		push @ropts, $_;
 		$om->[0] = $2;
-	    } elsif (m/^--(\w+):(.*)/s &&
+	    } elsif (m/^--([-0-9a-z]+):(.*)/s &&
 		     !$opts_opt_cmdonly{$1} &&
 		     ($om = $opts_opt_map{$1})) {
 		push @ropts, $_;
@@ -1917,6 +2022,9 @@ sub parseopts () {
 	    } elsif (m/^--distro=(.*)/s) {
 		push @ropts, $_;
 		$idistro = $1;
+	    } elsif (m/^--build-products-dir=(.*)/s) {
+		push @ropts, $_;
+		$buildproductsdir = $1;
 	    } elsif (m/^--clean=(dpkg-source|git|none)$/s) {
 		push @ropts, $_;
 		$cleanmode = $1;
@@ -1965,6 +2073,9 @@ sub parseopts () {
 		} elsif (s/^-C(.*)//s) {
 		    push @ropts, $&;
 		    $changesfile = $1;
+		    if ($changesfile =~ s#^(.*)/##) {
+			$buildproductsdir = $1;
+		    }
 		} elsif (s/^-k(.*)//s) {
 		    $keyid=$1;
 		} elsif (s/^-wn//s) {