X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=145fa9bb044be29d383f8849f7766ff0a72f2eab;hb=193cfa37a544a2c44f9252b83da54ca1af01c01f;hp=6401524ed90dee03c18914a330c99c17fa02b36a;hpb=7821907696dbe72c977548f7ffc4e8367d551b65;p=dgit.git diff --git a/dgit b/dgit index 6401524e..145fa9bb 100755 --- a/dgit +++ b/dgit @@ -36,6 +36,7 @@ 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); @@ -867,6 +870,22 @@ sub access_basedistro__noalias () { return $kl->{$k}; } } + foreach my $csvf () { + 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"); } } @@ -1191,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); @@ -1223,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; } @@ -1734,7 +1756,7 @@ sub get_archive_dsc () { foreach my $vinfo (@vsns) { my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo; $dscurl = $vsn_dscurl; - $dscdata = url_fetch($dscurl); + $dscdata = url_fetch($dscurl, Ok404 => 1 ); if (!$dscdata) { $skew_warning_vsn = $vsn if !defined $skew_warning_vsn; next; @@ -1792,7 +1814,9 @@ sub check_for_git () { CurlOpts => { CURLOPT_NOBODY() => 1 }, Ok404 => 1, AccessBase => 'git-check'; - return defined $result; + $result = defined $result; + printdebug "dgit-repos check_for_git => $result.\n"; + return $result; } elsif ($how eq 'true') { return 1; } elsif ($how eq 'false') { @@ -2011,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; } @@ -2636,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 @@ -2670,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 $@; } @@ -3577,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}; @@ -3844,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, @@ -3882,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); @@ -4020,6 +4060,7 @@ sub get_source_format () { } $_ = ; F->error and confess "$!"; + close F; chomp; return ($_, \%options); } @@ -4563,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_ <