X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=145fa9bb044be29d383f8849f7766ff0a72f2eab;hb=193cfa37a544a2c44f9252b83da54ca1af01c01f;hp=0f801a3d30127b518b393481e55842bde52a9d20;hpb=e9957b2d5326b0bdce0e5ca314fde99e213f53d8;p=dgit.git

diff --git a/dgit b/dgit
index 0f801a3d..145fa9bb 100755
--- a/dgit
+++ b/dgit
@@ -30,12 +30,13 @@ setup_sigwarn();
 
 use IO::Handle;
 use Data::Dumper;
-use LWP::UserAgent;
+use WWW::Curl::Easy;
 use Dpkg::Control::Hash;
 use File::Path;
 use File::Spec;
 use File::Temp qw(tempdir);
 use File::Basename;
+use File::Copy ();
 use Dpkg::Version;
 use Dpkg::Compression;
 use Dpkg::Compression::Process;
@@ -46,6 +47,7 @@ use Digest::SHA;
 use Digest::MD5;
 use List::MoreUtils qw(pairwise);
 use Text::Glob qw(match_glob);
+use Text::CSV;
 use Fcntl qw(:DEFAULT :flock);
 use Carp;
 
@@ -101,6 +103,7 @@ our %forceopts = map { $_=>0 }
     qw(unrepresentable unsupported-source-format
        dsc-changes-mismatch changes-origs-exactly
        uploading-binaries uploading-source-only
+       reusing-version
        import-gitapply-absurd
        import-gitapply-no-absurd
        import-dsc-with-dgit-field);
@@ -639,20 +642,6 @@ sub progress {
 
 our $ua;
 
-sub url_get {
-    if (!$ua) {
-	$ua = LWP::UserAgent->new();
-	$ua->env_proxy;
-    }
-    my $what = $_[$#_];
-    progress "downloading $what...";
-    my $r = $ua->get(@_) or confess "$!";
-    return undef if $r->code == 404;
-    $r->is_success or fail f_ "failed to fetch %s: %s",
-	$what, $r->status_line;
-    return $r->decoded_content(charset => 'none');
-}
-
 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 
 sub act_local () { return $dryrun_level <= 1; }
@@ -881,6 +870,22 @@ sub access_basedistro__noalias () {
 		return $kl->{$k};
 	    }
 	}
+	foreach my $csvf (</usr/share/distro-info/*.csv>) {
+	    my $csv_distro =
+		$csvf =~ m{/(\w+)\.csv$} ? $1 : do {
+		    printdebug "skipping $csvf\n";
+		    next;
+		};
+	    my $csv = Text::CSV->new({ binary => 1, auto_diag => 2 }) or die;
+	    my $fh = new IO::File $csvf, "<:encoding(utf8)"
+		or die "open $csvf: $!";
+	    while (my $cols = $csv->getline($fh)) {
+		next unless $cols->[2] eq $isuite;
+		return $csv_distro;
+	    }
+	    die "$csvf $!" if $fh->error;
+	    close $fh;
+	}
 	return cfg("dgit.default.distro");
     }
 }
@@ -1198,8 +1203,6 @@ sub url_fetch ($;@) {
     # AccessBase => 'archive-query' (eg)
     # CurlOpts => { key => value }
 
-    use WWW::Curl::Easy;
-
     my $curl  = WWW::Curl::Easy->new;
     my $setopt = sub {
 	my ($k,$v) = @_;
@@ -1207,7 +1210,8 @@ sub url_fetch ($;@) {
 	confess "$k $v ".$curl->strerror($x)." ?" if $x;
     };
 
-    my $response_body;
+    my $response_body = '';
+    $setopt->(CURLOPT_FOLLOWLOCATION,  1);
     $setopt->(CURLOPT_REDIR_PROTOCOLS, CURLPROTO_HTTPS|CURLPROTO_HTTP);
     $setopt->(CURLOPT_URL,             $url);
     $setopt->(CURLOPT_NOSIGNAL,        1);
@@ -1239,6 +1243,8 @@ sub url_fetch ($;@) {
     
     fail f_ "fetch of %s gave HTTP code %s", $url, $code
 	unless $url =~ m#^file://# or $code =~ m/^2/;
+
+    confess unless defined $response_body;
     return $response_body;
 }
 
@@ -1750,7 +1756,7 @@ sub get_archive_dsc () {
     foreach my $vinfo (@vsns) {
 	my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
 	$dscurl = $vsn_dscurl;
-	$dscdata = url_get($dscurl);
+	$dscdata = url_fetch($dscurl, Ok404 => 1 );
 	if (!$dscdata) {
 	    $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
 	    next;
@@ -1804,22 +1810,13 @@ sub check_for_git () {
 	my $suffix = access_cfg('git-check-suffix','git-suffix',
 				'RETURN-UNDEF') // '.git';
 	my $url = "$prefix/$package$suffix";
-	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
-	# HTTP/1.0 200 Connection established
-	$result =~ m/^\S+ (404|200) /s or
-	    fail +(__ "unexpected results from git check query - ").
-	        Dumper($prefix, $result);
-	my $code = $1;
-	if ($code eq '404') {
-	    return 0;
-	} elsif ($code eq '200') {
-	    return 1;
-	} else {
-	    die;
-	}
+	my $result = url_fetch $url,
+	    CurlOpts => { CURLOPT_NOBODY() => 1 },
+	    Ok404 => 1,
+	    AccessBase => 'git-check';
+	$result = defined $result;
+	printdebug "dgit-repos check_for_git => $result.\n";
+	return $result;
     } elsif ($how eq 'true') {
 	return 1;
     } elsif ($how eq 'false') {
@@ -2038,7 +2035,7 @@ sub test_source_only_changes ($) {
     foreach my $l (split /\n/, getfield $changes, 'Files') {
         $l =~ m/\S+$/ or next;
         # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
-        unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
+        unless ($& =~ m/(?:\.dsc|\.diff\.gz|$tarball_f_ext_re|_source\.buildinfo)$/) {
             print f_ "purportedly source-only changes polluted by %s\n", $&;
             return 0;
         }
@@ -2663,6 +2660,8 @@ END
 		chomp $@;
 		progress "warning: $@";
 		$path = "$absurdity:$path";
+		open T, ">../../absurd-apply-warnings" or die $!;
+		close T or die $!;
 		progress f_ "%s: trying slow absurd-git-apply...", $us;
 		rename "../../gbp-pq-output","../../gbp-pq-output.0"
 		    or $!==ENOENT
@@ -2697,6 +2696,11 @@ gbp-pq import and dpkg-source disagree!
  dpkg-source --before-build gave tree %s
 END
 		$rawimport_hash = $gapplied;
+
+		if ($use_absurd) {
+		    File::Copy::copy("../../absurd-apply-warnings", \*STDERR)
+			  or die $!;
+		}
 	    };
 	    last unless $@;
 	}
@@ -3604,7 +3608,7 @@ sub is_gitattrs_setup () {
     #     0: there is a dgit-defuse-attrs but it needs fixing
     #     undef: there is none
     my $gai = open_main_gitattrs();
-    return 0 unless $gai;
+    return undef unless $gai;
     while (<$gai>) {
 	next unless m{$gitattrs_ourmacro_re};
 	return 1 if m{\s-working-tree-encoding\s};
@@ -3871,6 +3875,16 @@ END
     printdone f_ "ready for work in %s", $dstdir;
 }
 
+sub vcs_git_url_of_ctrl ($) {
+    my ($ctrl) = @_;
+    my $vcsgiturl = $ctrl->{'Vcs-Git'};
+    if (length $vcsgiturl) {
+	$vcsgiturl =~ s/\s+-b\s+\S+//g;
+	$vcsgiturl =~ s/\s+\[[^][]*\]//g;
+    }
+    return $vcsgiturl;
+}
+
 sub clone ($) {
     # in multisuite, returns twice!
     # once in parent after first suite fetched,
@@ -3909,9 +3923,8 @@ sub clone ($) {
 	progress __ "starting new git history";
     }
     fetch_from_archive() or no_such_package;
-    my $vcsgiturl = $dsc->{'Vcs-Git'};
+    my $vcsgiturl = vcs_git_url_of_ctrl $dsc;
     if (length $vcsgiturl) {
-	$vcsgiturl =~ s/\s+-b\s+\S+//g;
 	runcmd @git, qw(remote add vcs-git), $vcsgiturl;
     }
     clone_finish($dstdir);
@@ -4047,6 +4060,7 @@ sub get_source_format () {
     }
     $_ = <F>;
     F->error and confess "$!";
+    close F;
     chomp;
     return ($_, \%options);
 }
@@ -4590,13 +4604,27 @@ END
 	        " of the archive's version.\n".
 		"To overwrite the archive's contents,".
 		" pass --overwrite[=VERSION].\n".
-		"To rewind history, if permitted by the archive,".
+		"To rewrite history, if permitted by the archive,".
 		" use --deliberately-not-fast-forward.";
 	}
     }
 
     confess unless !!$made_split_brain == do_split_brain();
 
+    my $tagname = debiantag_new $cversion, access_nomdistro();
+    if (!(forceing[qw(reusing-version)]) && git_get_ref "refs/tags/$tagname") {
+	supplementary_message '';
+	print STDERR f_ <<END, $cversion;
+
+Version %s has already been tagged (pushed?)
+If this was a failed (or incomplete or rejected) upload by you, just
+add a new changelog stanza for a new version number and try again.
+END
+	fail f_ <<END, $tagname;
+Tag %s already exists.
+END
+    }
+
     changedir $playground;
     progress f_ "checking that %s corresponds to HEAD", $dscfn;
     runcmd qw(dpkg-source -x --),
@@ -4986,7 +5014,8 @@ sub cmd_update_vcs_git () {
 	get_archive_dsc();
 	$ctrl = $dsc;
     }
-    my $url = getfield $ctrl, 'Vcs-Git';
+    my $url = vcs_git_url_of_ctrl $ctrl;
+    fail 'no Vcs-Git header in control file' unless length $url;
 
     my @cmd;
     my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
@@ -4994,12 +5023,12 @@ sub cmd_update_vcs_git () {
 	print STDERR f_ "setting up vcs-git: %s\n", $url;
 	@cmd = (@git, qw(remote add vcs-git), $url);
     } elsif ($orgurl eq $url) {
-	print STDERR f_ "vcs git already configured: %s\n", $url;
+	print STDERR f_ "vcs git unchanged: %s\n", $url;
     } else {
 	print STDERR f_ "changing vcs-git url to: %s\n", $url;
 	@cmd = (@git, qw(remote set-url vcs-git), $url);
     }
-    runcmd_ordryrun_local @cmd;
+    runcmd_ordryrun_local @cmd if @cmd;
     if ($dofetch) {
 	print f_ "fetching (%s)\n", "@ARGV";
 	runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
@@ -6674,6 +6703,31 @@ sub build_prep ($) {
     }
 }
 
+sub maybe_warn_opt_confusion ($$$) {
+    my ($subcommand, $willrun, $optsref) = @_;
+    foreach (@$optsref) {
+	if (m/^(?: --dry-run  $
+	         | --damp-run $
+		 | --clean= | -w[gcnd]
+		 | --(?:include|ignore)-dirty$
+		 | --quilt= | --gbp$ | --dpm$ | --baredebian
+		 | --split-view=
+		 | --build-products-dir=
+		 )/x) {
+	    print STDERR f_ <<END, $&, $subcommand or die $!;
+warning: dgit option %s must be passed before %s on dgit command line
+END
+	} elsif (m/^(?: -C
+		      | --no-sign  $
+		      | -k
+		      )/x) {
+	    print STDERR f_ <<END, $&, $subcommand, $willrun or die $!;
+warning: option %s should probably be passed to dgit before %s sub-command on the dgit command line, so that it is seen by dgit and not simply passed to %s
+END
+	}
+    }
+}
+
 sub changesopts_initial () {
     my @opts =@changesopts[1..$#changesopts];
 }
@@ -6847,6 +6901,7 @@ sub postbuild_mergechanges_vanilla ($) {
 
 sub cmd_build {
     build_prep_early();
+    maybe_warn_opt_confusion 'build', 'dpkg-buildpackage', \@ARGV;
     $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
 %s: warning: build-products-dir will be ignored; files will go to ..
@@ -6874,6 +6929,7 @@ sub pre_gbp_build {
 
 sub cmd_gbp_build {
     build_prep_early();
+    maybe_warn_opt_confusion 'gbp-build', 'gbp buildpackage', \@ARGV;
 
     # gbp can make .origs out of thin air.  In my tests it does this
     # even for a 1.0 format package, with no origs present.  So I
@@ -7081,6 +7137,7 @@ sub binary_builder {
 
 sub cmd_sbuild {
     build_prep_early();
+    maybe_warn_opt_confusion 'sbuild', 'sbuild', \@ARGV;
     binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
 perhaps you need to pass -A ?  (sbuild's default is to build only
 arch-specific binaries; dgit 1.4 used to override that.)
@@ -7090,6 +7147,7 @@ END
 sub pbuilder ($) {
     my ($pbuilder) = @_;
     build_prep_early();
+    maybe_warn_opt_confusion 'pbuilder', 'pbuilder', \@ARGV;
     # @ARGV is allowed to contain only things that should be passed to
     # pbuilder under debbuildopts; just massage those
     my $wantsrc = massage_dbp_args \@ARGV;