X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;ds=sidebyside;f=dgit;h=b1ed90447748bb25d95f75f9575badc26e00aa08;hb=41e0ec2b26cba9b3d4016b195ec8795ca1bd40f4;hp=448412e242f218c12a3c32f0ce5efb724d86d7c1;hpb=b250e873041896930e9e1d2f92df580f5eb91529;p=dgit.git
diff --git a/dgit b/dgit
index 448412e2..b1ed9044 100755
--- a/dgit
+++ b/dgit
@@ -24,6 +24,7 @@ use Data::Dumper;
use LWP::UserAgent;
use Dpkg::Control::Hash;
use File::Path;
+use File::Temp qw(tempdir);
use File::Basename;
use Dpkg::Version;
use POSIX;
@@ -37,7 +38,7 @@ our $package;
our @ropts;
our $sign = 1;
-our $dryrun = 0;
+our $dryrun_level = 0;
our $changesfile;
our $new_package = 0;
our $ignoredirty = 0;
@@ -82,6 +83,8 @@ our $keyid;
our $debug = 0;
open DEBUG, ">/dev/null" or die $!;
+autoflush STDOUT 1;
+
our $remotename = 'dgit';
our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
our $branchprefix = 'dgit';
@@ -112,6 +115,9 @@ sub dscfn ($) {
sub changesopts () { return @changesopts[1..$#changesopts]; }
our $us = 'dgit';
+our $debugprefix = ' ';
+
+sub printdebug { print DEBUG $debugprefix, @_ or die $!; }
sub fail { die "$us: @_\n"; }
@@ -132,17 +138,17 @@ sub fetchspec () {
# remote push initiator/responder protocol:
# < dgit-remote-push-ready [optional extra info ignored by old initiators]
#
-# > file begin parsed-changelog
+# > file parsed-changelog
# [indicates that output of dpkg-parsechangelog follows]
# > data-block NBYTES
# > [NBYTES bytes of data (no newline)]
# [maybe some more blocks]
# > data-end
#
-# > file begin dsc
+# > file dsc
# [etc]
#
-# > file begin changes
+# > file changes
# [etc]
#
# > param head HEAD
@@ -176,7 +182,13 @@ sub protocol_expect (&$) {
local $_;
$_ = <$fh>;
defined && chomp or badproto $fh, "eof";
- return if &$match;
+ if (wantarray) {
+ my @r = &$match;
+ return @r if @r;
+ } else {
+ my $r = &$match;
+ return $r if $r;
+ }
badproto $fh, "\`$_'";
}
@@ -208,11 +220,15 @@ sub protocol_receive_file ($$) {
my ($fh, $ourfn) = @_;
open PF, ">", $ourfn or die "$ourfn: $!";
for (;;) {
- protocol_expect { m/^data-block (.*})$|data-end$/ } \*STDIN;
- length $1 or last;
+ my ($y,$l) = protocol_expect {
+ m/^data-block (.*})$|data-end$/;
+ length $1 ? (1,$1) : (0);
+ } \*STDIN;
+ last unless $y;
my $d = protocol_read_bytes \*STDIN, $1;
print PF $d or die $!;
}
+ printdebug "received into $ourfn\n";
}
#---------- remote protocol support, responder ----------
@@ -221,20 +237,22 @@ sub responder_send_command ($) {
my ($command) = @_;
return unless $we_are_responder;
# called even without $we_are_responder
- print DEBUG "<< $command\n";
+ printdebug "<< $command\n";
print $command, "\n" or die $!;
}
sub responder_send_file ($$) {
my ($keyword, $ourfn) = @_;
return unless $we_are_responder;
- responder_send_command "file-begin $keyword";
+ printdebug "[[ $keyword $ourfn\n";
+ responder_send_command "file $keyword";
protocol_send_file \*STDOUT, $ourfn;
}
sub responder_receive_files ($@) {
my ($keyword, @ourfns) = @_;
die unless $we_are_responder;
+ printdebug "]] $keyword @ourfns\n";
responder_send_command "want $keyword";
foreach my $fn (@ourfns) {
protocol_receive_file \*STDIN, $fn;
@@ -314,13 +332,16 @@ sub failedcmd {
}
sub runcmd {
- printcmd(\*DEBUG,"+",@_) if $debug>0;
+ printcmd(\*DEBUG,$debugprefix."+",@_) if $debug>0;
$!=0; $?=0;
failedcmd @_ if system @_;
}
+sub act_local () { return $dryrun_level <= 1; }
+sub act_scary () { return !$dryrun_level; }
+
sub printdone {
- if (!$dryrun) {
+ if (!$dryrun_level) {
progress "dgit ok: @_";
} else {
progress "would be ok: @_ (but dry run only)";
@@ -329,16 +350,16 @@ sub printdone {
sub cmdoutput_errok {
die Dumper(\@_)." ?" if grep { !defined } @_;
- printcmd(\*DEBUG,"|",@_) if $debug>0;
+ printcmd(\*DEBUG,$debugprefix."|",@_) if $debug>0;
open P, "-|", @_ or die $!;
my $d;
$!=0; $?=0;
{ local $/ = undef; $d =
; }
die $! if P->error;
- if (!close P) { print DEBUG "=>!$?\n" if $debug>0; return undef; }
+ if (!close P) { printdebug "=>!$?\n" if $debug>0; return undef; }
chomp $d;
$d =~ m/^.*/;
- print DEBUG "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
+ printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
return $d;
}
@@ -349,11 +370,19 @@ sub cmdoutput {
}
sub dryrun_report {
- printcmd(\*STDERR,"#",@_);
+ printcmd(\*STDERR,$debugprefix."#",@_);
}
sub runcmd_ordryrun {
- if (!$dryrun) {
+ if (act_scary()) {
+ runcmd @_;
+ } else {
+ dryrun_report @_;
+ }
+}
+
+sub runcmd_ordryrun_local {
+ if (act_local()) {
runcmd @_;
} else {
dryrun_report @_;
@@ -375,6 +404,7 @@ main usages:
important dgit options:
-k sign tag and package with instead of default
--dry-run -n do not change anything, but go through the motions
+ --damp-run -L like --dry-run but make local changes, without signing
--new -N allow introducing a new package
--debug -D increase debug level
-c= set git config option (used directly by dgit too)
@@ -630,9 +660,9 @@ sub get_archive_dsc () {
next;
}
my $dscfh = new IO::File \$dscdata, '<' or die $!;
- print DEBUG Dumper($dscdata) if $debug>1;
+ printdebug Dumper($dscdata) if $debug>1;
$dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
- print DEBUG Dumper($dsc) if $debug>1;
+ printdebug Dumper($dsc) if $debug>1;
my $fmt = getfield $dsc, 'Format';
fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
return;
@@ -849,7 +879,7 @@ sub ensure_we_have_orig () {
$origurl .= "/$f";
die "$f ?" unless $f =~ m/^${package}_/;
die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun shell_cmd 'cd ..', @dget,'--',$origurl;
+ runcmd_ordryrun_local shell_cmd 'cd ..', @dget,'--',$origurl;
}
}
@@ -870,7 +900,7 @@ sub is_fast_fwd ($$) {
}
sub git_fetch_us () {
- runcmd_ordryrun @git, qw(fetch),access_giturl(),fetchspec();
+ runcmd_ordryrun_local @git, qw(fetch),access_giturl(),fetchspec();
}
sub fetch_from_archive () {
@@ -904,7 +934,7 @@ sub fetch_from_archive () {
} else {
die "$lrref_fn $!";
}
- print DEBUG "previous reference hash=$lastpush_hash\n";
+ printdebug "previous reference hash=$lastpush_hash\n";
my $hash;
if (defined $dsc_hash) {
fail "missing git history even though dsc has hash -".
@@ -938,7 +968,7 @@ Package not found in the archive, but has allegedly been pushed using dgit.
$later_warning_msg
END
} else {
- print DEBUG "nothing found!\n";
+ printdebug "nothing found!\n";
if (defined $skew_warning_vsn) {
print STDERR <$clogf",
@git, qw(cat-file blob), "$hash:debian/changelog";
my $gotclogp = parsechangelog("-l$clogf");
my $got_vsn = getfield $gotclogp, 'Version';
- print DEBUG "SKEW CHECK GOT $got_vsn\n";
+ printdebug "SKEW CHECK GOT $got_vsn\n";
if (version_compare_string($got_vsn, $skew_warning_vsn) < 0) {
print STDERR <0;
+ printcmd(\*DEBUG,$debugprefix."+",@cmd) if $debug>0;
$!=0; $?=0; system @cmd;
return if !$! && !$?;
if (!$! && $?==256) {
@@ -1041,25 +1071,20 @@ sub check_not_dirty () {
sub commit_quilty_patch () {
my $output = cmdoutput @git, qw(status --porcelain);
my %adds;
- my $bad=0;
foreach my $l (split /\n/, $output) {
next unless $l =~ m/\S/;
if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
$adds{$1}++;
- } else {
- print STDERR "git status: $l\n";
- $bad++;
}
}
- fail "unexpected output from git status (is tree clean?)" if $bad;
if (!%adds) {
progress "nothing quilty to commit, ok.";
return;
}
- runcmd_ordryrun @git, qw(add), sort keys %adds;
+ runcmd_ordryrun_local @git, qw(add), sort keys %adds;
my $m = "Commit Debian 3.0 (quilt) metadata";
progress "$m";
- runcmd_ordryrun @git, qw(commit -m), $m;
+ runcmd_ordryrun_local @git, qw(commit -m), $m;
}
sub madformat ($) {
@@ -1141,7 +1166,7 @@ END
push @sign_cmd, qw(-u),$keyid if defined $keyid;
push @sign_cmd, $tfn->('.tmp');
runcmd_ordryrun @sign_cmd;
- if (!$dryrun) {
+ if (act_scary()) {
$tagobjfn = $tfn->('.signed.tmp');
runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
$tfn->('.tmp'), $tfn->('.tmp.asc');
@@ -1163,7 +1188,7 @@ sub sign_changes ($) {
}
sub dopush () {
- print DEBUG "actually entering push\n";
+ printdebug "actually entering push\n";
prep_ud();
my $clogpfn = ".git/dgit/changelog.822.tmp";
@@ -1183,7 +1208,7 @@ sub dopush () {
push_parse_dsc("../$dscfn", $dscfn, $cversion);
my $format = getfield $dsc, 'Format';
- print DEBUG "format $format\n";
+ printdebug "format $format\n";
if (madformat($format)) {
commit_quilty_patch();
}
@@ -1193,8 +1218,8 @@ sub dopush () {
runcmd qw(dpkg-source -x --), "../../../../$dscfn";
my ($tree,$dir) = mktree_in_ud_from_only_subdir();
chdir '../../../..' or die $!;
- printcmd \*DEBUG,"+",@_;
my @diffcmd = (@git, qw(diff --exit-code), $tree);
+ printcmd \*DEBUG,$debugprefix."+",@diffcmd;
$!=0; $?=0;
if (system @diffcmd) {
if ($! && $?==256) {
@@ -1240,7 +1265,7 @@ sub dopush () {
my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
- runcmd_ordryrun @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
+ runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
runcmd_ordryrun @git, qw(tag -v --), $tag;
if (!check_for_git()) {
@@ -1250,7 +1275,7 @@ sub dopush () {
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
if (!$we_are_responder) {
- if (!$dryrun) {
+ if (act_local()) {
rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
} else {
progress "[new .dsc left in $dscfn.tmp]";
@@ -1258,7 +1283,7 @@ sub dopush () {
}
if ($we_are_responder) {
- my $dryrunsuffix = $dryrun ? ".tmp" : "";
+ my $dryrunsuffix = act_local() ? "" : ".tmp";
responder_receive_files('signed-dsc-changes',
"../$dscfn$dryrunsuffix",
"$changesfile$dryrunsuffix");
@@ -1387,7 +1412,8 @@ sub cmd_remote_push_responder {
my ($dir) = @rargs;
chdir $dir or die "$dir: $!";
$we_are_responder = 1;
- $|=1;
+ $debugprefix = ' ';
+ autoflush STDOUT 1;
responder_send_command("dgit-remote-push-ready");
&cmd_push;
}
@@ -1421,18 +1447,21 @@ sub cmd_rpush {
my @rdgit;
push @rdgit, @dgit;
push @rdgit, @ropts;
- push @rdgit, (scalar @rargs), @rargs;
+ push @rdgit, qw(remote-push-responder), (scalar @rargs), @rargs;
push @rdgit, @ARGV;
my @cmd = (@ssh, $host, shellquote @rdgit);
- my $pid = open2(\*RO, \*RI, @cmd);
+ printcmd \*DEBUG,$debugprefix."+",@cmd;
eval {
$i_tmp = tempdir();
+ my $pid = open2(\*RO, \*RI, @cmd);
chdir $i_tmp or die "$i_tmp $!";
initiator_expect { m/^dgit-remote-push-ready/ };
for (;;) {
- initiator_expect { m/^(\S+)(?: (.*))?$/ };
- my ($icmd,$iargs) = ($1, $2);
- i_method "i_resp_", $icmd, $iargs;
+ my ($icmd,$iargs) = initiator_expect {
+ m/^(\S+)(?: (.*))?$/;
+ ($1,$2);
+ };
+ i_method "i_resp", $icmd, $iargs;
}
};
i_cleanup();
@@ -1452,7 +1481,7 @@ sub i_resp_complete {
sub i_resp_file ($) {
my ($keyword) = @_;
- my $localname = i_method "i_localname_", $keyword;
+ my $localname = i_method "i_localname", $keyword;
my $localpath = "$i_tmp/$localname";
stat $localpath and badproto \*RO, "file $keyword ($localpath) twice";
protocol_receive_file \*RO, $localpath;
@@ -1470,7 +1499,8 @@ our %i_wanted;
sub i_resp_want ($) {
my ($keyword) = @_;
die "$keyword ?" if $i_wanted{$keyword}++;
- my @localpaths = i_method "i_want_", $keyword;
+ my @localpaths = i_method "i_want", $keyword;
+ printdebug "]] $keyword @localpaths\n";
foreach my $localpath (@localpaths) {
protocol_send_file \*RI, $localpath;
}
@@ -1556,7 +1586,7 @@ END
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
local $ENV{'VISUAL'} = $ENV{'EDITOR'};
local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
- runcmd_ordryrun @dpkgsource, qw(--commit .), $patchname;
+ runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
}
if (!open P, '>>', ".pc/applied-patches") {
@@ -1601,7 +1631,7 @@ sub cmd_build {
badusage "dgit build implies --clean=dpkg-source"
if $cleanmode ne 'dpkg-source';
build_prep();
- runcmd_ordryrun @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV;
+ runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV;
printdone "build successful\n";
}
@@ -1617,7 +1647,7 @@ sub cmd_git_build {
push @cmd, "--git-debian-branch=".lbranch();
}
push @cmd, changesopts();
- runcmd_ordryrun @cmd, @ARGV;
+ runcmd_ordryrun_local @cmd, @ARGV;
printdone "build successful\n";
}
@@ -1626,10 +1656,11 @@ sub build_source {
$sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
$dscfn = dscfn($version);
if ($cleanmode eq 'dpkg-source') {
- runcmd_ordryrun (@dpkgbuildpackage, qw(-us -uc -S)), changesopts();
+ runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
+ changesopts();
} else {
if ($cleanmode eq 'git') {
- runcmd_ordryrun @git, qw(clean -xdf);
+ runcmd_ordryrun_local @git, qw(clean -xdf);
} elsif ($cleanmode eq 'none') {
} else {
die "$cleanmode ?";
@@ -1637,9 +1668,9 @@ sub build_source {
my $pwd = cmdoutput qw(env - pwd);
my $leafdir = basename $pwd;
chdir ".." or die $!;
- runcmd_ordryrun @dpkgsource, qw(-b --), $leafdir;
+ runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
chdir $pwd or die $!;
- runcmd_ordryrun qw(sh -ec),
+ runcmd_ordryrun_local qw(sh -ec),
'exec >$1; shift; exec "$@"','x',
"../$sourcechanges",
@dpkggenchanges, qw(-S), changesopts();
@@ -1656,7 +1687,7 @@ sub cmd_sbuild {
build_source();
chdir ".." or die $!;
my $pat = "${package}_".(stripepoch $version)."_*.changes";
- if (!$dryrun) {
+ if (act_local()) {
stat $dscfn or fail "$dscfn (in parent directory): $!";
stat $sourcechanges or fail "$sourcechanges (in parent directory): $!";
foreach my $cf (glob $pat) {
@@ -1664,10 +1695,10 @@ sub cmd_sbuild {
unlink $cf or fail "remove $cf: $!";
}
}
- runcmd_ordryrun @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
- runcmd_ordryrun @mergechanges, glob $pat;
+ runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
+ runcmd_ordryrun_local @mergechanges, glob $pat;
my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
- if (!$dryrun) {
+ if (act_local()) {
stat $multichanges or fail "$multichanges: $!";
}
printdone "build successful, results in $multichanges\n" or die $!;
@@ -1703,7 +1734,10 @@ sub parseopts () {
if (m/^--/) {
if (m/^--dry-run$/) {
push @ropts, $_;
- $dryrun=1;
+ $dryrun_level=2;
+ } elsif (m/^--damp-run$/) {
+ push @ropts, $_;
+ $dryrun_level=1;
} elsif (m/^--no-sign$/) {
push @ropts, $_;
$sign=0;
@@ -1747,40 +1781,44 @@ sub parseopts () {
} else {
while (m/^-./s) {
if (s/^-n/-/) {
- push @ropts, $_;
- $dryrun=1;
+ push @ropts, $&;
+ $dryrun_level=2;
+ } elsif (s/^-L/-/) {
+ push @ropts, $&;
+ $dryrun_level=1;
} elsif (s/^-h/-/) {
cmd_help();
} elsif (s/^-D/-/) {
- push @ropts, $_;
+ push @ropts, $&;
open DEBUG, ">&STDERR" or die $!;
+ autoflush DEBUG 1;
$debug++;
} elsif (s/^-N/-/) {
- push @ropts, $_;
+ push @ropts, $&;
$new_package=1;
} elsif (m/^-[vm]/) {
- push @ropts, $_;
+ push @ropts, $&;
push @changesopts, $_;
$_ = '';
} elsif (s/^-c(.*=.*)//s) {
- push @ropts, $_;
+ push @ropts, $&;
push @git, '-c', $1;
} elsif (s/^-d(.*)//s) {
- push @ropts, $_;
+ push @ropts, $&;
$idistro = $1;
} elsif (s/^-C(.*)//s) {
- push @ropts, $_;
+ push @ropts, $&;
$changesfile = $1;
} elsif (s/^-k(.*)//s) {
$keyid=$1;
} elsif (s/^-wn//s) {
- push @ropts, $_;
+ push @ropts, $&;
$cleanmode = 'none';
} elsif (s/^-wg//s) {
- push @ropts, $_;
+ push @ropts, $&;
$cleanmode = 'git';
} elsif (s/^-wd//s) {
- push @ropts, $_;
+ push @ropts, $&;
$cleanmode = 'dpkg-source';
} else {
badusage "unknown short option \`$_'";
@@ -1797,7 +1835,9 @@ if ($ENV{$fakeeditorenv}) {
delete $ENV{'DGET_UNPACK'};
parseopts();
-print STDERR "DRY RUN ONLY\n" if $dryrun;
+print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
+print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
+ if $dryrun_level == 1;
if (!@ARGV) {
print STDERR $helpmsg or die $!;
exit 8;