use IO::Handle;
use Data::Dumper;
-use LWP::UserAgent;
+use WWW::Curl::Easy;
use Dpkg::Control::Hash;
use File::Path;
use File::Spec;
use Digest::MD5;
use List::MoreUtils qw(pairwise);
use Text::Glob qw(match_glob);
+use Text::CSV;
use Fcntl qw(:DEFAULT :flock);
use Carp;
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;
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);
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; }
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");
}
}
$$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 {
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 ($$;$) {
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;
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') {
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;
}
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,
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);
}
$_ = <F>;
F->error and confess "$!";
+ close F;
chomp;
return ($_, \%options);
}
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 --),
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';
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;
}
}
+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];
}
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 ..
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
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.)
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;