X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=db03cfbdcc6052d4be063af4cbc4b7da059c6f8a;hb=261784cf5da5928375f838a13745f82626a6fe10;hp=6cdf8d28a699070b84eb0cf1fca283f635ff2f23;hpb=19669291927ee91dbea3c47a412161b32859df88;p=dgit.git

diff --git a/dgit b/dgit
index 6cdf8d28..db03cfbd 100755
--- a/dgit
+++ b/dgit
@@ -41,6 +41,7 @@ use Carp;
 use Debian::Dgit;
 
 our $our_version = 'UNRELEASED'; ###substituted###
+our $absurdity = undef; ###substituted###
 
 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
 our $protovsn;
@@ -73,6 +74,12 @@ our $tagformat_want;
 our $tagformat;
 our $tagformatfn;
 
+our %forceopts = map { $_=>0 }
+    qw(unrepresentable unsupported-source-format
+       dsc-changes-mismatch
+       import-gitapply-absurd
+       import-gitapply-no-absurd);
+
 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 
 our $suite_re = '[-+.0-9a-z]+';
@@ -86,7 +93,7 @@ our $splitbraincache = 'dgit-intern/quilt-cache';
 
 our (@git) = qw(git);
 our (@dget) = qw(dget);
-our (@curl) = qw(curl -f);
+our (@curl) = qw(curl);
 our (@dput) = qw(dput);
 our (@debsign) = qw(debsign);
 our (@gpg) = qw(gpg);
@@ -144,6 +151,11 @@ our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
 our $csuite;
 our $instead_distro;
 
+if (!defined $absurdity) {
+    $absurdity = $0;
+    $absurdity =~ s{/[^/]+$}{/absurd} or die;
+}
+
 sub debiantag ($$) {
     my ($v,$distro) = @_;
     return $tagformatfn->($v, $distro);
@@ -222,6 +234,20 @@ END {
 
 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 
+sub forceable_fail ($$) {
+    my ($forceoptsl, $msg) = @_;
+    fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
+    print STDERR "warning: overriding problem due to --force:\n". $msg;
+}
+
+sub forceing ($) {
+    my ($forceoptsl) = @_;
+    my @got = grep { $forceopts{$_} } @$forceoptsl;
+    return 0 unless @got;
+    print STDERR
+ "warning: skipping checks or functionality due to --force-$got[0]\n";
+}
+
 sub no_such_package () {
     print STDERR "$us: package $package does not exist in suite $isuite\n";
     exit 4;
@@ -593,7 +619,7 @@ 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' => "ftpmasterapi:",
+	       'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
 	       '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',
@@ -936,13 +962,13 @@ sub must_getcwd () {
 
 our %rmad;
 
-sub archive_query ($) {
-    my ($method) = @_;
+sub archive_query ($;@) {
+    my ($method) = shift @_;
     my $query = access_cfg('archive-query','RETURN-UNDEF');
     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
     my $proto = $1;
     my $data = $'; #';
-    { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
+    { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
 }
 
 sub pool_dsc_subpath ($$) {
@@ -955,7 +981,7 @@ sub pool_dsc_subpath ($$) {
 
 sub archive_api_query_cmd ($) {
     my ($subpath) = @_;
-    my @cmd = qw(curl -sS);
+    my @cmd = (@curl, qw(-sS));
     my $url = access_cfg('archive-query-url');
     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
 	my $host = $1;
@@ -983,17 +1009,27 @@ sub archive_api_query_cmd ($) {
     return @cmd;
 }
 
-sub api_query ($$) {
+sub api_query ($$;$) {
     use JSON;
-    my ($data, $subpath) = @_;
+    my ($data, $subpath, $ok404) = @_;
     badcfg "ftpmasterapi archive query method takes no data part"
 	if length $data;
     my @cmd = archive_api_query_cmd($subpath);
+    my $url = $cmd[$#cmd];
+    push @cmd, qw(-w %{http_code});
     my $json = cmdoutput @cmd;
+    unless ($json =~ s/\d+\d+\d$//) {
+	failedcmd_report_cmd undef, @cmd;
+	fail "curl failed to print 3-digit HTTP code";
+    }
+    my $code = $&;
+    return undef if $code eq '404' && $ok404;
+    fail "fetch of $url gave HTTP code $code"
+	unless $url =~ m#^file://# or $code =~ m/^2/;
     return decode_json($json);
 }
 
-sub canonicalise_suite_ftpmasterapi () {
+sub canonicalise_suite_ftpmasterapi {
     my ($proto,$data) = @_;
     my $suites = api_query($data, 'suites');
     my @matched;
@@ -1017,7 +1053,7 @@ sub canonicalise_suite_ftpmasterapi () {
     return $cn;
 }
 
-sub archive_query_ftpmasterapi () {
+sub archive_query_ftpmasterapi {
     my ($proto,$data) = @_;
     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
     my @rows;
@@ -1044,6 +1080,42 @@ sub archive_query_ftpmasterapi () {
     return @rows;
 }
 
+sub file_in_archive_ftpmasterapi {
+    my ($proto,$data,$filename) = @_;
+    my $pat = $filename;
+    $pat =~ s/_/\\_/g;
+    $pat = "%/$pat";
+    $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
+    my $info = api_query($data, "file_in_archive/$pat", 1);
+}
+
+#---------- `dummyapicat' archive query method ----------
+
+sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
+sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
+
+sub file_in_archive_dummycatapi ($$$) {
+    my ($proto,$data,$filename) = @_;
+    my $mirror = access_cfg('mirror');
+    $mirror =~ s#^file://#/# or die "$mirror ?";
+    my @out;
+    my @cmd = (qw(sh -ec), '
+            cd "$1"
+            find -name "$2" -print0 |
+            xargs -0r sha256sum
+        ', qw(x), $mirror, $filename);
+    debugcmd "-|", @cmd;
+    open FIA, "-|", @cmd or die $!;
+    while (<FIA>) {
+	chomp or die;
+	printdebug "| $_\n";
+	m/^(\w+)  (\S+)$/ or die "$_ ?";
+	push @out, { sha256sum => $1, filename => $2 };
+    }
+    close FIA or die failedcmd @cmd;
+    return \@out;
+}
+
 #---------- `madison' archive query method ----------
 
 sub archive_query_madison {
@@ -1092,6 +1164,8 @@ sub canonicalise_suite_madison {
     return $r[0][2];
 }
 
+sub file_in_archive_madison { return undef; }
+
 #---------- `sshpsql' archive query method ----------
 
 sub sshpsql ($$$) {
@@ -1167,6 +1241,8 @@ END
     return $rows[0];
 }
 
+sub file_in_archive_sshpsql ($$$) { return undef; }
+
 #---------- `dummycat' archive query method ----------
 
 sub canonicalise_suite_dummycat ($$) {
@@ -1208,6 +1284,8 @@ sub archive_query_dummycat ($$) {
     return sort { -version_compare($a->[0],$b->[0]); } @rows;
 }
 
+sub file_in_archive_dummycat () { return undef; }
+
 #---------- tag format handling ----------
 
 sub access_cfg_tagformats () {
@@ -1285,7 +1363,9 @@ sub get_archive_dsc () {
 	$dsc = parsecontrolfh($dscfh,$dscurl,1);
 	printdebug Dumper($dsc) if $debuglevel>1;
 	my $fmt = getfield $dsc, 'Format';
-	fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+	$format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
+	    "unsupported source format $fmt, sorry";
+	    
 	$dsc_checked = !!$digester;
 	printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
 	return;
@@ -1321,7 +1401,7 @@ sub check_for_git () {
 	my $suffix = access_cfg('git-check-suffix','git-suffix',
 				'RETURN-UNDEF') // '.git';
 	my $url = "$prefix/$package$suffix";
-	my @cmd = (qw(curl -sS -I), $url);
+	my @cmd = (@curl, qw(-sS -I), $url);
 	my $result = cmdoutput @cmd;
 	$result =~ s/^\S+ 200 .*\n\r?\n//;
 	# curl -sS -I with https_proxy prints
@@ -1427,9 +1507,9 @@ sub mktree_in_ud_from_only_subdir (;$) {
 }
 
 our @files_csum_info_fields = 
-    (['Checksums-Sha256','Digest::SHA', 'new(256)'],
-     ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
-     ['Files',           'Digest::MD5', 'new()']);
+    (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
+     ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
+     ['Files',           'Digest::MD5', 'new()',    'md5sum']);
 
 sub dsc_files_info () {
     foreach my $csumi (@files_csum_info_fields) {
@@ -1931,25 +2011,54 @@ END
 	local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
 	local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
 
-	eval {
-	    runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
-		gbp_pq, qw(import);
-	};
-	if ($@) {
-	    { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
-	    die $@;
-	}
+	my $path = $ENV{PATH} or die;
+
+	foreach my $use_absurd (qw(0 1)) {
+	    local $ENV{PATH} = $path;
+	    if ($use_absurd) {
+		chomp $@;
+		progress "warning: $@";
+		$path = "$absurdity:$path";
+		progress "$us: trying slow absurd-git-apply...";
+		rename "../../gbp-pq-output","../../gbp-pq-output.0"
+		    or $!==ENOENT
+		    or die $!;
+	    }
+	    eval {
+		die "forbid absurd git-apply\n" if $use_absurd
+		    && forceing [qw(import-gitapply-no-absurd)];
+		die "only absurd git-apply!\n" if !$use_absurd
+		    && forceing [qw(import-gitapply-absurd)];
+
+		local $ENV{PATH} = $path if $use_absurd;
+
+		my @showcmd = (gbp_pq, qw(import));
+		my @realcmd = shell_cmd
+		    'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
+		debugcmd "+",@realcmd;
+		if (system @realcmd) {
+		    die +(shellquote @showcmd).
+			" failed: ".
+			failedcmd_waitstatus()."\n";
+		}
 
-	my $gapplied = git_rev_parse('HEAD');
-	my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
-	$gappliedtree eq $dappliedtree or
-	    fail <<END;
+		my $gapplied = git_rev_parse('HEAD');
+		my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
+		$gappliedtree eq $dappliedtree or
+		    fail <<END;
 gbp-pq import and dpkg-source disagree!
  gbp-pq import gave commit $gapplied
  gbp-pq import gave tree $gappliedtree
  dpkg-source --before-build gave tree $dappliedtree
 END
-	$rawimport_hash = $gapplied;
+		$rawimport_hash = $gapplied;
+	    };
+	    last unless $@;
+	}
+	if ($@) {
+	    { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
+	    die $@;
+	}
     }
 
     progress "synthesised git commit from .dsc $cversion";
@@ -2007,7 +2116,7 @@ sub complete_file_from_dsc ($$) {
 	$furl .= "/$f";
 	die "$f ?" unless $f =~ m/^\Q${package}\E_/;
 	die "$f ?" if $f =~ m#/#;
-	runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+	runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
 	return 0 if !act_local();
 	$downloaded = 1;
     }
@@ -2884,12 +2993,12 @@ sub splitbrain_pseudomerge ($$$$) {
     #   this:                                   $dgitview'
     #
 
+    return $dgitview unless defined $archive_hash;
+
     printdebug "splitbrain_pseudomerge...\n";
 
     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
 
-    return $dgitview unless defined $archive_hash;
-
     if (!defined $overwrite_version) {
 	progress "Checking that HEAD inciudes all changes in archive...";
     }
@@ -3154,11 +3263,12 @@ END
     my $dgithead = $actualhead;
     my $maintviewhead = undef;
 
+    my $upstreamversion = $clogp->{Version};
+    $upstreamversion =~ s/-[^-]*$//;
+
     if (madformat_wantfixup($format)) {
 	# user might have not used dgit build, so maybe do this now:
 	if (quiltmode_splitbrain()) {
-	    my $upstreamversion = $clogp->{Version};
-	    $upstreamversion =~ s/-[^-]*$//;
 	    changedir $ud;
 	    quilt_make_fake_dsc($upstreamversion);
 	    my $cachekey;
@@ -3242,7 +3352,9 @@ END
 
     # Check that changes and .dsc agree enough
     $changesfile =~ m{[^/]*$};
-    files_compare_inputs($dsc, parsecontrol($changesfile,$&));
+    my $changes = parsecontrol($changesfile,$&);
+    files_compare_inputs($dsc, $changes)
+	unless forceing [qw(dsc-changes-mismatch)];
 
     # Checks complete, we're going to try and go ahead:
 
@@ -3909,7 +4021,7 @@ Commit patch to update .gitignore
 END
     }
 
-    my $dgitview = git_rev_parse 'refs/heads/dgit-view';
+    my $dgitview = git_rev_parse 'HEAD';
 
     changedir '../../../..';
     # When we no longer need to support squeeze, use --create-reflog
@@ -4596,7 +4708,7 @@ END
     if (@unrepres) {
 	print STDERR "dgit:  cannot represent change: $_->[1]: $_->[0]\n"
 	    foreach @unrepres;
-	fail <<END;
+	forceable_fail [qw(unrepresentable)], <<END;
 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
 END
     }
@@ -4608,7 +4720,7 @@ END
         push @failsuggestion, "This might be a patches-applied branch.";
     }
     push @failsuggestion, "Maybe you need to specify one of".
-        " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
+        " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
 
     if (quiltmode_splitbrain()) {
 	quiltify_splitbrain($clogp, $unapplied, $headref,
@@ -4824,11 +4936,87 @@ sub massage_dbp_args ($;$) {
     return $r;
 }
 
+sub in_parent (&) {
+    my ($fn) = @_;
+    my $wasdir = must_getcwd();
+    changedir "..";
+    $fn->();
+    changedir $wasdir;
+}    
+
+sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+    my ($msg_if_onlyone) = @_;
+    # If there is only one .changes file, fail with $msg_if_onlyone,
+    # or if that is undef, be a no-op.
+    # Returns the changes file to report to the user.
+    my $pat = changespat $version;
+    my @changesfiles = glob $pat;
+    @changesfiles = sort {
+	($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
+	    or $a cmp $b
+    } @changesfiles;
+    my $result;
+    if (@changesfiles==1) {
+	fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
+only one changes file from build (@changesfiles)
+END
+	$result = $changesfiles[0];
+    } elsif (@changesfiles==2) {
+	my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
+	foreach my $l (split /\n/, getfield $binchanges, 'Files') {
+	    fail "$l found in binaries changes file $binchanges"
+		if $l =~ m/\.dsc$/;
+	}
+	runcmd_ordryrun_local @mergechanges, @changesfiles;
+	my $multichanges = changespat $version,'multi';
+	if (act_local()) {
+	    stat_exists $multichanges or fail "$multichanges: $!";
+	    foreach my $cf (glob $pat) {
+		next if $cf eq $multichanges;
+		rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+	    }
+	}
+	$result = $multichanges;
+    } else {
+	fail "wrong number of different changes files (@changesfiles)";
+    }
+    printdone "build successful, results in $result\n" or die $!;
+}
+
+sub midbuild_checkchanges () {
+    my $pat = changespat $version;
+    return if $rmchanges;
+    my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
+    @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
+    fail <<END
+changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
+Suggest you delete @unwanted.
+END
+	if @unwanted;
+}
+
+sub midbuild_checkchanges_vanilla ($) {
+    my ($wantsrc) = @_;
+    midbuild_checkchanges() if $wantsrc == 1;
+}
+
+sub postbuild_mergechanges_vanilla ($) {
+    my ($wantsrc) = @_;
+    if ($wantsrc == 1) {
+	in_parent {
+	    postbuild_mergechanges(undef);
+	};
+    } else {
+	printdone "build successful\n";
+    }
+}
+
 sub cmd_build {
     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
     my $wantsrc = massage_dbp_args \@dbp;
     if ($wantsrc > 0) {
 	build_source();
+	midbuild_checkchanges_vanilla $wantsrc;
     } else {
 	build_prep();
     }
@@ -4838,7 +5026,7 @@ sub cmd_build {
 	runcmd_ordryrun_local @dbp;
     }
     maybe_unapply_patches_again();
-    printdone "build successful\n";
+    postbuild_mergechanges_vanilla $wantsrc;
 }
 
 sub pre_gbp_build {
@@ -4863,6 +5051,7 @@ sub cmd_gbp_build {
 
     if ($wantsrc > 0) {
 	build_source();
+	midbuild_checkchanges_vanilla $wantsrc;
     } else {
 	if (!$clean_using_builder) {
 	    push @cmd, '--git-cleaner=true';
@@ -4874,7 +5063,7 @@ sub cmd_gbp_build {
 	push @cmd, changesopts();
 	runcmd_ordryrun_local @cmd, @ARGV;
     }
-    printdone "build successful\n";
+    postbuild_mergechanges_vanilla $wantsrc;
 }
 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
 
@@ -4947,53 +5136,22 @@ sub cmd_build_source {
 
 sub cmd_sbuild {
     build_source();
-    my $pat = changespat $version;
-    if (!$rmchanges) {
-	my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
-	@unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
-	fail <<END
-changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
-Suggest you delete @unwanted.
-END
-	    if @unwanted;
-    }
-    my $wasdir = must_getcwd();
-    changedir "..";
-    if (act_local()) {
-	stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
-	stat_exists $sourcechanges
-	    or fail "$sourcechanges (in parent directory): $!";
-    }
-    runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
-    my @changesfiles = glob $pat;
-    @changesfiles = sort {
-	($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
-	    or $a cmp $b
-    } @changesfiles;
-    fail <<END if @changesfiles==1;
-only one changes file from sbuild (@changesfiles)
+    midbuild_checkchanges();
+    in_parent {
+	if (act_local()) {
+	    stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
+	    stat_exists $sourcechanges
+		or fail "$sourcechanges (in parent directory): $!";
+	}
+	runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
+    };
+    maybe_unapply_patches_again();
+    in_parent {
+	postbuild_mergechanges(<<END);
 perhaps you need to pass -A ?  (sbuild's default is to build only
 arch-specific binaries; dgit 1.4 used to override that.)
 END
-    fail "wrong number of different changes files (@changesfiles)"
-	unless @changesfiles==2;
-    my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
-    foreach my $l (split /\n/, getfield $binchanges, 'Files') {
-	fail "$l found in binaries changes file $binchanges"
-	    if $l =~ m/\.dsc$/;
-    }
-    runcmd_ordryrun_local @mergechanges, @changesfiles;
-    my $multichanges = changespat $version,'multi';
-    if (act_local()) {
-	stat_exists $multichanges or fail "$multichanges: $!";
-	foreach my $cf (glob $pat) {
-	    next if $cf eq $multichanges;
-	    rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
-	}
-    }
-    changedir $wasdir;
-    maybe_unapply_patches_again();
-    printdone "build successful, results in $multichanges\n" or die $!;
+    };
 }    
 
 sub cmd_quilt_fixup {
@@ -5010,6 +5168,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);
+    push @cmd, qw(-f);
     debugcmd ">",@cmd;
     exec @cmd or fail "exec curl: $!\n";
 }
@@ -5142,6 +5301,9 @@ sub parseopts () {
 		     ($om = $opts_opt_map{$1})) {
 		push @ropts, $_;
 		push @$om, $2;
+	    } elsif (m/^--(gbp|dpm)$/s) {
+		push @ropts, "--quilt=$1";
+		$quilt_mode = $1;
 	    } elsif (m/^--ignore-dirty$/s) {
 		push @ropts, $_;
 		$ignoredirty = 1;
@@ -5163,6 +5325,14 @@ sub parseopts () {
 	    } elsif (m/^--deliberately-($deliberately_re)$/s) {
 		push @ropts, $_;
 		push @deliberatelies, $&;
+	    } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
+		push @ropts, $&;
+		$forceopts{$1} = 1;
+		$_='';
+	    } elsif (m/^--force-/) {
+		print STDERR
+		    "$us: warning: ignoring unknown force option $_\n";
+		$_='';
 	    } elsif (m/^--dgit-tag-format=(old|new)$/s) {
 		# undocumented, for testing
 		push @ropts, $_;