sub lbranch () { return "$branchprefix/$csuite"; }
my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
sub lref () { return "refs/heads/".lbranch(); }
-sub lrref () { return "refs/remotes/$remotename/$csuite"; }
+sub lrref () { return "refs/remotes/$remotename/$branchprefix/$csuite"; }
sub rrref () { return "refs/$branchprefix/$csuite"; }
-sub debiantag ($) { return "debian/$_[0]"; }
+sub debiantag ($) {
+ my ($v) = @_;
+ $v =~ y/~:/_%/;
+ return "debian/$v";
+}
sub dscfn ($) { return "${package}_$_[0].dsc"; }
my $what = $_[$#_];
print "downloading $what...\n";
my $r = $ua->get(@_) or die $!;
+ return undef if $r->code == 404;
$r->is_success or fail "failed to fetch $what: ".$r->status_line;
return $r->decoded_content();
}
-c<name>=<value> set git config option (used directly by dgit too)
END
+our $later_warning_msg = <<END;
+Perhaps the upload is stuck in incoming. Using the version from git.
+END
+
sub badusage {
print STDERR "$us: @_\n", $helpmsg or die $!;
exit 8;
'dgit.default.username' => '',
'dgit.default.archive-query-default-component' => 'main',
'dgit.default.ssh' => 'ssh',
- 'dgit-distro.debian.git-host' => 'dgit.debian.net',
+ 'dgit-distro.debian.git-host' => 'git.debian.org',
'dgit-distro.debian.git-proto' => 'git+ssh://',
'dgit-distro.debian.git-path' => '/git/dgit-repos',
'dgit-distro.debian.git-check' => 'ssh-cmd',
sub madison_parse ($) {
my ($rmad) = @_;
- if (!length $rmad) {
- return ();
- }
- $rmad =~ m{^ \s*( [^ \t|]+ )\s* \|
- \s*( [^ \t|]+ )\s* \|
- \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
- \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
- $1 eq $package or die "$rmad $package ?";
- my $vsn = $2;
- my $newsuite = $3;
- my $component;
- if (defined $4) {
- $component = $4;
- } else {
- $component = access_cfg('archive-query-default-component');
+ my @out;
+ foreach my $l (split /\n/, $rmad) {
+ $l =~ m{^ \s*( [^ \t|]+ )\s* \|
+ \s*( [^ \t|]+ )\s* \|
+ \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
+ \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
+ $1 eq $package or die "$rmad $package ?";
+ my $vsn = $2;
+ my $newsuite = $3;
+ my $component;
+ if (defined $4) {
+ $component = $4;
+ } else {
+ $component = access_cfg('archive-query-default-component');
+ }
+ $5 eq 'source' or die "$rmad ?";
+ my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
+ my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
+ push @out, [$vsn,$subpath,$newsuite];
}
- $5 eq 'source' or die "$rmad ?";
- my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
- my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
- return ($vsn,$subpath,$newsuite);
+ return sort { -version_compare_string($a->[0],$b->[0]); } @out;
}
sub canonicalise_suite_madison ($$) {
"unable to canonicalise suite using package $package".
" which does not appear to exist in suite $isuite;".
" --existing-package may help";
- return $r[2];
+ return $r[0][2];
}
sub canonicalise_suite () {
}
sub get_archive_dsc () {
- my ($vsn,$subpath) = archive_query('archive_query');
canonicalise_suite();
- if (!defined $vsn) { $dsc=undef; return undef; }
- $dscurl = access_cfg('mirror').$subpath;
- $dscdata = url_get($dscurl);
- my $dscfh = new IO::File \$dscdata, '<' or die $!;
- print DEBUG Dumper($dscdata) if $debug>1;
- $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
- print DEBUG Dumper($dsc) if $debug>1;
- my $fmt = getfield $dsc, 'Format';
- fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ my @vsns = archive_query('archive_query');
+ foreach my $vinfo (@vsns) {
+ my ($vsn,$subpath) = @$vinfo;
+ $dscurl = access_cfg('mirror').$subpath;
+ $dscdata = url_get($dscurl);
+ next unless defined $dscdata;
+ $dscurl = access_cfg('mirror').$subpath;
+ $dscdata = url_get($dscurl);
+ my $dscfh = new IO::File \$dscdata, '<' or die $!;
+ print DEBUG Dumper($dscdata) if $debug>1;
+ $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
+ print DEBUG Dumper($dsc) if $debug>1;
+ my $fmt = getfield $dsc, 'Format';
+ fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ return $dsc;
+ }
+ return undef;
}
sub check_for_git () {
runcmd_ordryrun
(access_cfg('ssh'),access_gituserhost(),
"set -e; cd ".access_cfg('git-path').";".
- " mkdir -p $package.git;".
- " cd $package.git;".
- " if ! test -d objects; then git init --bare; fi");
+ " cp -a _template $package.git");
} else {
badcfg "unknown git-create \`$how'";
}
$outputhash = make_commit qw(../commit2.tmp);
} elsif ($vcmp > 0) {
print STDERR <<END or die $!;
+
Version actually in archive: $cversion (older)
Last allegedly pushed/uploaded: $oversion (newer or same)
-Perhaps the upload is stuck in incoming. Using the version from git.
+$later_warning_msg
END
$outputhash = $upload_hash;
} elsif ($outputhash ne $upload_hash) {
if (defined $dsc_hash) {
fail "missing git history even though dsc has hash -".
" could not find commit $dsc_hash".
- " (should be in ".access_giturl()."#".rref().")"
+ " (should be in ".access_giturl()."#".rrref().")"
unless $upload_hash;
$hash = $dsc_hash;
ensure_we_have_orig();
+ if ($dsc_hash eq $upload_hash) {
+ } elsif (is_fast_fwd($dsc_hash,$upload_hash)) {
+ print STDERR <<END or die $!;
+
+Git commit in archive is behind the last version allegedly pushed/uploaded.
+Commit referred to by archive: $dsc_hash
+Last allegedly pushed/uploaded: $upload_hash
+$later_warning_msg
+END
+ $hash = $upload_hash;
+ } else {
+ fail "archive's .dsc refers to ".$dsc_hash.
+ " but this is an ancestor of ".$upload_hash;
+ }
} else {
$hash = generate_commit_from_dsc();
}
print "[new .dsc left in $dscfn.tmp]\n";
}
if ($sign) {
+ if (!defined $keyid) {
+ $keyid = access_cfg('keyid','RETURN-UNDEF');
+ }
my @tag_cmd = (@git, qw(tag -s -m),
"Release $dversion for $csuite [dgit]");
push @tag_cmd, qw(-u),$keyid if defined $keyid;
if (fetch_from_archive()) {
is_fast_fwd(lrref(), 'HEAD') or die;
} else {
- fail "package appears to be new in this suite;".
- " if this is intentional, use --new";
+ $new_package or
+ fail "package appears to be new in this suite;".
+ " if this is intentional, use --new";
}
dopush();
}
~ianmdlvl / dgit.git / blobdiff