X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=145fa9bb044be29d383f8849f7766ff0a72f2eab;hb=193cfa37a544a2c44f9252b83da54ca1af01c01f;hp=4a5cae1d37c3bdbbcd733b3887af67da00cdfd6b;hpb=f3405131b5bab67ec0757eeeb2c0b7f532c9e05e;p=dgit.git diff --git a/dgit b/dgit index 4a5cae1d..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; @@ -54,6 +56,8 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### our $absurdity = undef; ###substituted### +$SIG{INT} = 'DEFAULT'; # work around #932841 + our @rpushprotovsn_support = qw(6 5 4); # Reverse order! our $protovsn; @@ -99,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); @@ -637,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; } @@ -879,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"); } } @@ -1190,12 +1197,11 @@ sub cfg_apply_map ($$$) { $$varref = $_; } -#---------- `ftpmasterapi' archive query method (nascent) ---------- - -sub archive_api_query_curl ($) { - my ($url) = @_; - - use WWW::Curl::Easy; +sub url_fetch ($;@) { + my ($url, %xopts) = @_; + # Ok404 => 1 means give undef for 404 + # AccessBase => 'archive-query' (eg) + # CurlOpts => { key => value } my $curl = WWW::Curl::Easy->new; my $setopt = sub { @@ -1204,36 +1210,53 @@ sub archive_api_query_curl ($) { 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); $setopt->(CURLOPT_WRITEDATA, \$response_body); - if ($url =~ m#^https://([-.0-9a-z]+)/#) { - foreach my $k (qw(archive-query-tls-key - archive-query-tls-curl-ca-args)) { + my $xcurlopts = $xopts{CurlOpts} // { }; + keys %$xcurlopts; + while (my ($k,$v) = each %$xcurlopts) { $setopt->($k,$v); } + + if ($xopts{AccessBase} && $url =~ m#^https://([-.0-9a-z]+)/#) { + foreach my $k ("$xopts{AccessBase}-tls-key", + "$xopts{AccessBase}-tls-curl-ca-args") { fail "config option $k is obsolete and no longer supported" if defined access_cfg($k, 'RETURN-UNDEF'); } } + printdebug "query: fetching $url...\n"; + + local $SIG{PIPE} = 'IGNORE'; + my $x = $curl->perform(); fail f_ "fetch of %s failed (%s): %s", $url, $curl->strerror($x), $curl->errbuf if $x; - return $curl->getinfo(CURLINFO_HTTP_CODE), $response_body; + my $code = $curl->getinfo(CURLINFO_HTTP_CODE); + if ($code eq '404' && $xopts{Ok404}) { return undef; } + + 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; } +#---------- `ftpmasterapi' archive query method (nascent) ---------- + sub api_query_raw ($;$) { my ($subpath, $ok404) = @_; my $url = access_cfg('archive-query-url'); $url .= $subpath; - my ($code,$json) = archive_api_query_curl($url); - return undef if $code eq '404' && $ok404; - fail f_ "fetch of %s gave HTTP code %s", $url, $code - unless $url =~ m#^file://# or $code =~ m/^2/; - return $json; + return url_fetch $url, + Ok404 => $ok404, + AccessBase => 'archive-query'; } sub api_query ($$;$) { @@ -1733,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; @@ -1787,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') { @@ -2021,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; } @@ -2646,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 @@ -2680,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 $@; } @@ -3587,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}; @@ -3854,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, @@ -3892,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); @@ -4030,6 +4060,7 @@ sub get_source_format () { } $_ = ; F->error and confess "$!"; + close F; chomp; return ($_, \%options); } @@ -4573,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_ <