X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=4c6cc9c29124f9a145ad9b63a540cad68beca0ed;hb=f4e23593ad4e04711ec34d5b1d70f3a0508f2b66;hp=247b2432c2d7ab95ad07b86a498639f2bbbc61fa;hpb=175b4406b72856290aca44d0f06671a452537dfe;p=dgit.git diff --git a/dgit b/dgit index 247b2432..4c6cc9c2 100755 --- a/dgit +++ b/dgit @@ -18,7 +18,9 @@ # along with this program. If not, see . use strict; -$SIG{__WARN__} = sub { die $_[0]; }; + +use Debian::Dgit; +setup_sigwarn(); use IO::Handle; use Data::Dumper; @@ -37,7 +39,8 @@ use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### -our $rpushprotovsn = 2; +our @rpushprotovsn_support = qw(3 2); +our $protovsn; our $isuite = 'unstable'; our $idistro; @@ -95,11 +98,20 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'mergechanges' => \@mergechanges); our %opts_opt_cmdonly = ('gpg' => 1); +our %opts_opt_cmdline_opts; +sub finalise_opts_opts(); our $keyid; autoflush STDOUT 1; +our $supplementary_message = ''; + +END { + local ($@, $?); + print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg; +} + our $remotename = 'dgit'; our @ourdscfield = qw(Dgit Vcs-Dgit-Master); our $csuite; @@ -173,7 +185,9 @@ sub deliberately_not_fast_forward () { #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: -# < dgit-remote-push-ready [optional extra info ignored by old initiators] +# $ dgit remote-push-build-host ... ... +# where is ,... ... +# < dgit-remote-push-ready # # > file parsed-changelog # [indicates that output of dpkg-parsechangelog follows] @@ -268,7 +282,7 @@ sub protocol_send_file ($$) { sub protocol_read_bytes ($$) { my ($fh, $nbytes) = @_; - $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count"; + $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count"; my $d; my $got = read $fh, $d, $nbytes; $got==$nbytes or badproto_badread $fh, "data block"; @@ -446,6 +460,7 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.debian.archive-query' => 'ftpmasterapi:', 'dgit-distro.debian.git-check' => 'url', 'dgit-distro.debian.git-check-suffix' => '/info/refs', + 'dgit-distro.debian.new-private-pushers' => 't', 'dgit-distro.debian/push.git-url' => '', 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', 'dgit-distro.debian/push.git-user-force' => 'dgit', @@ -547,16 +562,68 @@ sub access_quirk () { return ('none',undef); } -our $access_forpush = 0; +our $access_forpush; -sub pushing () { - $access_forpush = 1; +sub parse_cfg_bool ($$$) { + my ($what,$def,$v) = @_; + $v //= $def; + return + $v =~ m/^[ty1]/ ? 1 : + $v =~ m/^[fn0]/ ? 0 : + badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'"; +} + +sub access_forpush_config () { + my $d = access_basedistro(); + + return 1 if + $new_package && + parse_cfg_bool('new-private-pushers', 0, + cfg("dgit-distro.$d.new-private-pushers", + 'RETURN-UNDEF')); + + my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF'); + $v //= 'a'; + return + $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0 + $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1 + $v =~ m/^[a]/ ? '' : # auto, forpush = '' + badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)"; } sub access_forpush () { + $access_forpush //= access_forpush_config(); return $access_forpush; } +sub pushing () { + die "$access_forpush ?" if ($access_forpush // 1) ne 1; + badcfg "pushing but distro is configured readonly" + if access_forpush_config() eq '0'; + $access_forpush = 1; + $supplementary_message = <<'END' unless $we_are_responder; +Push failed, before we got started. +You can retry the push, after fixing the problem, if you like. +END + finalise_opts_opts(); +} + +sub notpushing () { + finalise_opts_opts(); +} + +sub supplementary_message ($) { + my ($msg) = @_; + if (!$we_are_responder) { + $supplementary_message = $msg; + return; + } elsif ($protovsn >= 3) { + responder_send_command "supplementary-message ".length($msg) + or die $!; + print PO $msg or die $!; + } +} + sub access_distros () { # Returns list of distros to try, in order # @@ -578,7 +645,7 @@ sub access_distros () { @l; } -sub access_cfg (@) { +sub access_cfg_cfgs (@) { my (@keys) = @_; my @cfgs; # The nesting of these loops determines the search order. We put @@ -605,6 +672,12 @@ sub access_cfg (@) { } push @cfgs, map { "dgit.default.$_" } @realkeys; push @cfgs, @rundef; + return @cfgs; +} + +sub access_cfg (@) { + my (@keys) = @_; + my (@cfgs) = access_cfg_cfgs(@keys); my $value = cfg(@cfgs); return $value; } @@ -1131,7 +1204,21 @@ sub mktree_in_ud_from_only_subdir () { $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; - fail "source package contains .git directory" if stat_exists '.git'; + + my @gitscmd = qw(find -name .git -prune -print0); + debugcmd "|",@gitscmd; + open GITS, "-|", @gitscmd or failedcmd @gitscmd; + { + local $/="\0"; + while () { + chomp or die; + print STDERR "$us: warning: removing from source package: ", + (messagequote $_), "\n"; + rmtree $_; + } + } + $!=0; $?=0; close GITS or failedcmd @gitscmd; + mktree_in_ud_here(); my $format=get_source_format(); if (madformat($format)) { @@ -1771,6 +1858,10 @@ sub sign_changes ($) { sub dopush ($) { my ($forceflag) = @_; printdebug "actually entering push\n"; + supplementary_message(<<'END'); +Push failed, while preparing your push. +You can retry the push, after fixing the problem, if you like. +END prep_ud(); access_giturl(); # check that success is vaguely likely @@ -1855,6 +1946,11 @@ sub dopush ($) { my $tfn = sub { ".git/dgit/tag$_[0]"; }; my $tagobjfn; + supplementary_message(<<'END'); +Push failed, while signing the tag. +You can retry the push, after fixing the problem, if you like. +END + # If we manage to sign but fail to record it anywhere, it's fine. if ($we_are_responder) { $tagobjfn = $tfn->('.signed.tmp'); responder_receive_files('signed-tag', $tagobjfn); @@ -1865,11 +1961,19 @@ sub dopush ($) { $changesfile,$changesfile, $tfn); } + supplementary_message(<<'END'); +Push failed, *after* signing the tag. +If you want to try again, you should use a new version number. +END my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn; runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash; runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash; + supplementary_message(<<'END'); +Push failed, while updating the remote git repository - see messages above. +If you want to try again, you should use a new version number. +END if (!check_for_git()) { create_remote_git_repo(); } @@ -1877,6 +1981,10 @@ sub dopush ($) { $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag"; runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD'; + supplementary_message(<<'END'); +Push failed, after updating the remote git repository. +If you want to try again, you must use a new version number. +END if ($we_are_responder) { my $dryrunsuffix = act_local() ? "" : ".tmp"; responder_receive_files('signed-dsc-changes', @@ -1891,16 +1999,25 @@ sub dopush ($) { sign_changes $changesfile; } + supplementary_message(<<'END'); +Push failed, while uploading package(s) to the archive server. +You can retry the upload of exactly these same files with dput of: + $changesfile +If that .changes file is broken, you will need to use a new version +number for your next attempt at the upload. +END my $host = access_cfg('upload-host','RETURN-UNDEF'); my @hostarg = defined($host) ? ($host,) : (); runcmd_ordryrun @dput, @hostarg, $changesfile; printdone "pushed and uploaded $cversion"; + supplementary_message(''); responder_send_command("complete"); } sub cmd_clone { parseopts(); + notpushing(); my $dstdir; badusage "-p is not allowed with clone; specify as argument instead" if defined $package; @@ -1948,6 +2065,7 @@ sub branchsuite () { } sub fetchpullargs () { + notpushing(); if (!defined $package) { my $sourcep = parsecontrol('debian/control','debian/control'); $package = getfield $sourcep, 'Source'; @@ -1981,8 +2099,8 @@ sub cmd_pull { } sub cmd_push { - pushing(); parseopts(); + pushing(); badusage "-p is not allowed with dgit push" if defined $package; check_not_dirty(); my $clogp = parsechangelog(); @@ -2007,6 +2125,10 @@ sub cmd_push { fail "dgit push: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } + supplementary_message(<<'END'); +Push failed, while checking state of the archive. +You can retry the push, after fixing the problem, if you like. +END if (check_for_git()) { git_fetch_us(); } @@ -2035,7 +2157,6 @@ sub cmd_push { #---------- remote commands' implementation ---------- sub cmd_remote_push_build_host { - pushing(); my ($nrargs) = shift @ARGV; my (@rargs) = @ARGV[0..$nrargs-1]; @ARGV = @ARGV[$nrargs..$#ARGV]; @@ -2048,6 +2169,8 @@ sub cmd_remote_push_build_host { $we_are_responder = 1; $us .= " (build host)"; + pushing(); + open PI, "<&STDIN" or die $!; open STDIN, "/dev/null" or die $!; open PO, ">&STDOUT" or die $!; @@ -2056,11 +2179,16 @@ sub cmd_remote_push_build_host { autoflush STDOUT 1; $vsnwant //= 1; - fail "build host has dgit rpush protocol version". - " $rpushprotovsn but invocation host has $vsnwant" - unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant; + ($protovsn) = grep { + $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$} + } @rpushprotovsn_support; + + fail "build host has dgit rpush protocol versions ". + (join ",", @rpushprotovsn_support). + " but invocation host has $vsnwant" + unless defined $protovsn; - responder_send_command("dgit-remote-push-ready $rpushprotovsn"); + responder_send_command("dgit-remote-push-ready $protovsn"); changedir $dir; &cmd_push; @@ -2106,7 +2234,8 @@ sub cmd_rpush { $dir = nextarg; } $dir =~ s{^-}{./-}; - my @rargs = ($dir,$rpushprotovsn); + my @rargs = ($dir); + push @rargs, join ",", @rpushprotovsn_support; my @rdgit; push @rdgit, @dgit; push @rdgit, @ropts; @@ -2124,7 +2253,9 @@ sub cmd_rpush { } $i_child_pid = open2(\*RO, \*RI, @cmd); changedir $i_tmp; - initiator_expect { m/^dgit-remote-push-ready/ }; + ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ }; + die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support; + $supplementary_message = '' unless $protovsn >= 3; for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -2140,6 +2271,11 @@ sub i_resp_progress ($) { progress $msg; } +sub i_resp_supplementary_message ($) { + my ($rhs) = @_; + $supplementary_message = protocol_read_bytes \*RO, $rhs; +} + sub i_resp_complete { my $pid = $i_child_pid; $i_child_pid = undef; # prevents killing some other process with same pid @@ -2702,10 +2838,12 @@ sub clean_tree () { sub cmd_clean () { badusage "clean takes no additional arguments" if @ARGV; + notpushing(); clean_tree(); } sub build_prep () { + notpushing(); badusage "-p is not allowed when building" if defined $package; check_not_dirty(); clean_tree(); @@ -2909,7 +3047,7 @@ sub parseopts () { } elsif (m/^--since-version=([^_]+|_)$/) { push @ropts, $_; $changes_since_version = $1; - } elsif (m/^--([-0-9a-z]+)=(.*)/s && + } elsif (m/^--([-0-9a-z]+)=(.+)/s && ($om = $opts_opt_map{$1}) && length $om->[0]) { push @ropts, $_; @@ -2918,7 +3056,7 @@ sub parseopts () { !$opts_opt_cmdonly{$1} && ($om = $opts_opt_map{$1})) { push @ropts, $_; - push @$om, $2; + push @{ $opts_opt_cmdline_opts{$1} }, $2; } elsif (m/^--existing-package=(.*)/s) { push @ropts, $_; $existing_package = $1; @@ -3025,11 +3163,18 @@ sub parseopts () { } } +sub finalise_opts_opts () { + foreach my $k (keys %opts_opt_cmdline_opts) { + push @{ $opts_opt_map{$k} }, @{ $opts_opt_cmdline_opts{$k} }; + } +} + if ($ENV{$fakeeditorenv}) { quilt_fixup_editor(); } parseopts(); + print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n" if $dryrun_level == 1; @@ -3041,6 +3186,7 @@ my $cmd = shift @ARGV; $cmd =~ y/-/_/; if (!defined $quilt_mode) { + local $access_forpush; $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF') // access_cfg('quilt-mode', 'RETURN-UNDEF') // 'linear';