our $sign = 1;
our $dryrun_level = 0;
our $changesfile;
+our $buildproductsdir = '..';
our $new_package = 0;
our $ignoredirty = 0;
our $noquilt = 0;
+our $rmonerror = 1;
our $existing_package = 'dpkg';
our $cleanmode = 'dpkg-source';
our $changes_since_version;
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
+our $suite_re = '[-+.0-9a-z]+';
+
our (@git) = qw(git);
our (@dget) = qw(dget);
our (@dput) = qw(dput);
our $us = 'dgit';
our $debugprefix = '';
+our @end;
+END {
+ local ($?);
+ foreach my $f (@end) {
+ eval { $f->(); };
+ warn "$us: cleanup: $@" if length $@;
+ }
+};
+
sub printdebug { print DEBUG $debugprefix, @_ or die $!; }
sub fail {
}
sub failedcmd {
- { local ($!); printcmd \*STDERR, "$_[0]: failed command:", @_ or die $!; };
+ { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; };
if ($!) {
fail "failed to fork/exec: $!";
} elsif (!($? & 0xff)) {
exit 0;
}
+our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
+
our %defcfg = ('dgit.default.distro' => 'debian',
'dgit.default.username' => '',
'dgit.default.archive-query-default-component' => 'main',
'dgit-distro.debian.sshpsql-host' => 'coccia.debian.org',
'dgit-distro.debian.sshpsql-dbname' => 'service=projectb',
'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
- 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/');
+ 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
+ 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
+ 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
+ 'dgit-distro.test-dummy.ssh' => "$td/ssh",
+ 'dgit-distro.test-dummy.username' => "alice",
+ 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
+ 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
+ 'dgit-distro.test-dummy.git-url' => "$td/git",
+ 'dgit-distro.test-dummy.git-host' => "git",
+ 'dgit-distro.test-dummy.git-path' => "$td/git",
+ 'dgit-distro.test-dummy.archive-query' => "dummycat:$td/aq",
+ 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
+ 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
+ );
sub cfg {
foreach my $c (@_) {
my $dv = $defcfg{$c};
return $dv if defined $dv;
}
- badcfg "need value for one of: @_";
+ badcfg "need value for one of: @_\n".
+ "$us: distro or suite appears not to be (properly) supported";
+}
+
+sub access_basedistro () {
+ if (defined $idistro) {
+ return cfg("dgit-distro.basedistro.distro",
+ "dgit-suite.$isuite.distro",
+ 'RETURN-UNDEF') // $idistro;
+ } else {
+ return cfg("dgit-suite.$isuite.distro",
+ "dgit.default.distro");
+ }
+}
+
+sub access_quirk () {
+ # returns (quirk name, distro to use instead, quirk-specific info)
+ my $basedistro = access_basedistro();
+ my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
+ 'RETURN-UNDEF');
+ if (defined $backports_quirk) {
+ my $re = $backports_quirk;
+ $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
+ $re =~ s/\*/.*/g;
+ $re =~ s/\%/([-0-9a-z_]+)/
+ or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
+ if ($isuite =~ m/^$re$/) {
+ return ('backports',"$basedistro-backports",$1);
+ }
+ }
+ return ('none',$basedistro);
}
sub access_distro () {
- return cfg("dgit-suite.$isuite.distro",
- "dgit.default.distro");
+ return (access_quirk())[1];
}
sub access_cfg (@) {
my (@keys) = @_;
+ my $basedistro = access_basedistro();
my $distro = $idistro || access_distro();
- my $value = cfg(map { ("dgit-distro.$distro.$_",
- "dgit.default.$_") } @keys);
+ my $value = cfg(map {
+ ("dgit-distro.$distro.$_",
+ "dgit-distro.$basedistro.$_",
+ "dgit.default.$_")
+ } @keys);
return $value;
}
return $c;
}
+sub git_get_ref ($) {
+ my ($refname) = @_;
+ my $got = cmdoutput_errok @git, qw(show-ref --), $refname;
+ if (!defined $got) {
+ $?==256 or fail "git show-ref failed (status $?)";
+ printdebug "ref $refname= [show-ref exited 1]\n";
+ return '';
+ }
+ if ($got =~ m/^(\w+) \Q$refname\E$/m) {
+ printdebug "ref $refname=$1\n";
+ return $1;
+ } else {
+ printdebug "ref $refname= [no match]\n";
+ return '';
+ }
+}
+
+sub must_getcwd () {
+ my $d = getcwd();
+ defined $d or fail "getcwd failed: $!";
+ return $d;
+}
+
our %rmad;
sub archive_query ($) {
my ($method) = @_;
my $query = access_cfg('archive-query','RETURN-UNDEF');
if (!defined $query) {
- my $distro = access_distro();
+ my $distro = access_basedistro();
if ($distro eq 'debian') {
$query = "sshpsql:".
access_someuserhost('sshpsql').':'.
$l =~ m{^ \s*( [^ \t|]+ )\s* \|
\s*( [^ \t|]+ )\s* \|
\s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
- \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
+ \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
$1 eq $package or die "$rmad $package ?";
my $vsn = $2;
my $newsuite = $3;
my ($userhost,$dbname) = ($`,$'); #';
my @rows;
my @cmd = (access_cfg_ssh, $userhost,
- shellquote qw(psql -A), $dbname, qw(-c), $sql);
+ "export LANG=C; ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0;
open P, "-|", @cmd or die $!;
while (<P>) {
printdebug("$debugprefix>|$_|\n");
push @rows, $_;
}
- $!=0; $?=0; close P or die "$! $?";
+ $!=0; $?=0; close P or failedcmd @cmd;
@rows or die;
my $nrows = pop @rows;
$nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
return $rows[0];
}
+sub canonicalise_suite_dummycat ($$) {
+ my ($proto,$data) = @_;
+ my $dpath = "$data/suite.$isuite";
+ if (!open C, "<", $dpath) {
+ $!==ENOENT or die "$dpath: $!";
+ printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
+ return $isuite;
+ }
+ $!=0; $_ = <C>;
+ chomp or die "$dpath: $!";
+ close C;
+ printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
+ return $_;
+}
+
+sub archive_query_dummycat ($$) {
+ my ($proto,$data) = @_;
+ canonicalise_suite();
+ my $dpath = "$data/package.$csuite.$package";
+ if (!open C, "<", $dpath) {
+ $!==ENOENT or die "$dpath: $!";
+ printdebug "dummycat query $csuite $package $dpath ENOENT\n";
+ return ();
+ }
+ my @rows;
+ while (<C>) {
+ next if m/^\#/;
+ next unless m/\S/;
+ die unless chomp;
+ printdebug "dummycat query $csuite $package $dpath | $_\n";
+ my @row = split /\s+/, $_;
+ @row==2 or die "$dpath: $_ ?";
+ push @rows, \@row;
+ }
+ C->error and die "$dpath: $!";
+ close C;
+ return sort { -version_compare_string($a->[0],$b->[0]); } @rows;
+}
+
sub canonicalise_suite () {
return if defined $csuite;
fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
my $r= cmdoutput @cmd;
failedcmd @cmd unless $r =~ m/^[01]$/;
return $r+0;
+ } elsif ($how eq 'true') {
+ return 1;
} else {
badcfg "unknown git-check \`$how'";
}
(access_cfg_ssh, access_gituserhost(),
"set -e; cd ".access_cfg('git-path').";".
" cp -a _template $package.git");
+ } elsif ($how eq 'true') {
+ # nothing to do
} else {
badcfg "unknown git-create \`$how'";
}
progress "no version available from the archive";
}
- my $lrref_fn = ".git/".lrref();
- if (open H, $lrref_fn) {
- $lastpush_hash = <H>;
- chomp $lastpush_hash;
- die "$lrref_fn $lastpush_hash ?" unless $lastpush_hash =~ m/^\w+$/;
- } elsif ($! == &ENOENT) {
- $lastpush_hash = '';
- } else {
- die "$lrref_fn $!";
- }
+ $lastpush_hash = git_get_ref(lrref());
printdebug "previous reference hash=$lastpush_hash\n";
my $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()."#".rrref().")"
+ fail "missing remote git history even though dsc has hash -".
+ " could not find ref ".lrref().
+ " (should have been fetched from ".access_giturl()."#".rrref().")"
unless $lastpush_hash;
$hash = $dsc_hash;
ensure_we_have_orig();
tag $tag
tagger $authline
-$package release $cversion for $clogsuite [dgit]
+$package release $cversion for $clogsuite ($csuite) [dgit]
END
close TO or die $!;
my ($clogp, $cversion, $tag, $dscfn) =
push_parse_changelog("$clogpfn");
- stat "../$dscfn" or
+ my $dscpath = "$buildproductsdir/$dscfn";
+ stat $dscpath or
fail "looked for .dsc $dscfn, but $!;".
" maybe you forgot to build";
- responder_send_file('dsc', "../$dscfn");
+ responder_send_file('dsc', $dscpath);
- push_parse_dsc("../$dscfn", $dscfn, $cversion);
+ push_parse_dsc($dscpath, $dscfn, $cversion);
my $format = getfield $dsc, 'Format';
printdebug "format $format\n";
check_not_dirty();
changedir $ud;
progress "checking that $dscfn corresponds to HEAD";
- runcmd qw(dpkg-source -x --), "../../../../$dscfn";
+ runcmd qw(dpkg-source -x --),
+ $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
my ($tree,$dir) = mktree_in_ud_from_only_subdir();
changedir '../../../..';
- my @diffcmd = (@git, qw(diff --exit-code), $tree);
+ my $diffopt = $debug>0 ? '--exit-code' : '--quiet';
+ my @diffcmd = (@git, qw(diff), $diffopt, $tree);
printcmd \*DEBUG,$debugprefix."+",@diffcmd;
$!=0; $?=0;
- if (system @diffcmd) {
- if ($! && $?==256) {
+ my $r = system @diffcmd;
+ if ($r) {
+ if ($r==256) {
fail "$dscfn specifies a different tree to your HEAD commit;".
- " perhaps you forgot to build";
+ " perhaps you forgot to build".
+ ($diffopt eq '--exit-code' ? "" :
+ " (run with -D to see full diff output)");
} else {
failedcmd @diffcmd;
}
# (uploadbranch());
my $head = rev_parse('HEAD');
if (!$changesfile) {
- my $multi = "../${package}_".(stripepoch $cversion)."_multi.changes";
+ my $multi = "$buildproductsdir/".
+ "${package}_".(stripepoch $cversion)."_multi.changes";
if (stat "$multi") {
$changesfile = $multi;
} else {
$!==&ENOENT or die "$multi: $!";
my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
- my @cs = glob "../$pat";
+ my @cs = glob "$buildproductsdir/$pat";
fail "failed to find unique changes file".
- " (looked for $pat in .., or $multi);".
+ " (looked for $pat in $buildproductsdir, or $multi);".
" perhaps you need to use dgit -C"
unless @cs==1;
($changesfile) = @cs;
}
+ } else {
+ $changesfile = "$buildproductsdir/$changesfile";
}
responder_send_file('changes',$changesfile);
responder_send_command("param head $head");
+ responder_send_command("param csuite $csuite");
my $tfn = sub { ".git/dgit/tag$_[0]"; };
my $tagobjfn;
} else {
$tagobjfn =
push_mktag($head,$clogp,$tag,
- "../$dscfn",
+ $dscpath,
$changesfile,$changesfile,
$tfn);
}
if (!check_for_git()) {
create_remote_git_repo();
}
- runcmd_ordryrun @git, qw(push),access_giturl(),"HEAD:".rrref();
+ runcmd_ordryrun @git, qw(push),access_giturl(),
+ "HEAD:".rrref(), "refs/tags/$tag";
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
- if (!$we_are_responder) {
- if (act_local()) {
- rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
- } else {
- progress "[new .dsc left in $dscfn.tmp]";
- }
- }
-
if ($we_are_responder) {
my $dryrunsuffix = act_local() ? "" : ".tmp";
responder_receive_files('signed-dsc-changes',
- "../$dscfn$dryrunsuffix",
+ "$dscpath$dryrunsuffix",
"$changesfile$dryrunsuffix");
} else {
+ if (act_local()) {
+ rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
+ } else {
+ progress "[new .dsc left in $dscpath.tmp]";
+ }
sign_changes $changesfile;
}
- runcmd_ordryrun @git, qw(push),access_giturl(),"refs/tags/$tag";
my $host = access_cfg('upload-host','RETURN-UNDEF');
my @hostarg = defined($host) ? ($host,) : ();
runcmd_ordryrun @dput, @hostarg, $changesfile;
badusage "incorrect arguments to dgit clone";
}
$dstdir ||= "$package";
+
+ my $cwd_remove;
+ if ($rmonerror && !$dryrun_level) {
+ $cwd_remove= getcwd();
+ unshift @end, sub {
+ return unless defined $cwd_remove;
+ if (!chdir "$cwd_remove") {
+ return if $!==&ENOENT;
+ die "chdir $cwd_remove: $!";
+ }
+ rmtree($dstdir) or die "remove $dstdir: $!\n";
+ };
+ }
+
clone($dstdir);
+ $cwd_remove = undef;
}
sub branchsuite () {
is_fast_fwd(lrref(), 'HEAD') or
fail "dgit push: HEAD is not a descendant".
" of the archive's version.\n".
- "$us: To overwrite it, use git-merge -s ours ".lrref().".";
+ "$us: To overwrite it, use git merge -s ours ".lrref().".";
} else {
$new_package or
fail "package appears to be new in this suite;".
sub i_want_signed_tag {
printdebug Dumper(\%i_param, $i_dscfn);
defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
+ && defined $i_param{'csuite'}
or badproto \*RO, "premature desire for signed-tag";
my $head = $i_param{'head'};
die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
+ die unless $i_param{'csuite'} =~ m/^$suite_re$/;
+ $csuite = $&;
push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
my $tagobjfn =
chomp;
return unless madformat($_);
# sigh
+
+ my @cmd = (@git, qw(ls-files --exclude-standard -iodm));
+ my $problems = cmdoutput @cmd;
+ if (length $problems) {
+ print STDERR "problematic files:\n";
+ print STDERR " $_\n" foreach split /\n/, $problems;
+ fail "Cannot do quilt fixup in tree containing ignored files. ".
+ "Perhaps your package's clean target is broken, in which".
+ " case -wg (which says to use git-clean -xdf) may help.";
+ }
+
my $clogp = parsechangelog();
my $version = getfield $clogp, 'Version';
my $author = getfield $clogp, 'Maintainer';
exit 0;
}
+sub clean_tree () {
+ if ($cleanmode eq 'dpkg-source') {
+ runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
+ } elsif ($cleanmode eq 'git') {
+ runcmd_ordryrun_local @git, qw(clean -xdf);
+ } elsif ($cleanmode eq 'none') {
+ } else {
+ die "$cleanmode ?";
+ }
+}
+
sub build_prep () {
badusage "-p is not allowed when building" if defined $package;
check_not_dirty();
+ clean_tree();
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
my @opts =@changesopts[1..$#changesopts];
if (!defined $changes_since_version) {
my @vsns = archive_query('archive_query');
+ my @quirk = access_quirk();
+ if ($quirk[0] eq 'backports') {
+ local $isuite = $quirk[2];
+ local $csuite;
+ canonicalise_suite();
+ push @vsns, archive_query('archive_query');
+ }
if (@vsns) {
@vsns = map { $_->[0] } @vsns;
- @vsns = sort { version_compare_string($a, $b) } @vsns;
+ @vsns = sort { -version_compare_string($a, $b) } @vsns;
$changes_since_version = $vsns[0];
progress "changelog will contain changes since $vsns[0]";
} else {
}
sub cmd_build {
- badusage "dgit build implies --clean=dpkg-source"
- if $cleanmode ne 'dpkg-source';
build_prep();
runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV;
printdone "build successful\n";
}
sub cmd_git_build {
- badusage "dgit git-build implies --clean=dpkg-source"
- if $cleanmode ne 'dpkg-source';
build_prep();
my @cmd =
(qw(git-buildpackage -us -uc --git-no-sign-tags),
runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
changesopts();
} else {
- if ($cleanmode eq 'git') {
- runcmd_ordryrun_local @git, qw(clean -xdf);
- } elsif ($cleanmode eq 'none') {
- } else {
- die "$cleanmode ?";
- }
- my $pwd = cmdoutput qw(env - pwd);
+ my $pwd = must_getcwd();
my $leafdir = basename $pwd;
changedir "..";
runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
} elsif (m/^--since-version=([^_]+|_)$/) {
push @ropts, $_;
$changes_since_version = $1;
- } elsif (m/^--(\w+)=(.*)/s &&
+ } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
($om = $opts_opt_map{$1}) &&
length $om->[0]) {
push @ropts, $_;
$om->[0] = $2;
- } elsif (m/^--(\w+):(.*)/s &&
+ } elsif (m/^--([-0-9a-z]+):(.*)/s &&
!$opts_opt_cmdonly{$1} &&
($om = $opts_opt_map{$1})) {
push @ropts, $_;
} elsif (m/^--distro=(.*)/s) {
push @ropts, $_;
$idistro = $1;
+ } elsif (m/^--build-products-dir=(.*)/s) {
+ push @ropts, $_;
+ $buildproductsdir = $1;
} elsif (m/^--clean=(dpkg-source|git|none)$/s) {
push @ropts, $_;
$cleanmode = $1;
} elsif (m/^--no-quilt-fixup$/s) {
push @ropts, $_;
$noquilt = 1;
+ } elsif (m/^--no-rm-on-error$/s) {
+ push @ropts, $_;
+ $rmonerror = 0;
} else {
badusage "unknown long option \`$_'";
}
} elsif (s/^-C(.*)//s) {
push @ropts, $&;
$changesfile = $1;
+ if ($changesfile =~ s#^(.*)/##) {
+ $buildproductsdir = $1;
+ }
} elsif (s/^-k(.*)//s) {
$keyid=$1;
} elsif (s/^-wn//s) {
~ianmdlvl / dgit.git / blobdiff