X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=8df8f761baf9347ce341102b0fd5229aaf4fb03d;hp=051a4be568c8ab9d8651f64b21c43df1bb18cdd1;hb=86b1bd2035ce1da863c682223893b59ed74962f9;hpb=cc6570b2dc95d1c70c349e61493a9e57b4f2a233 diff --git a/dgit b/dgit index 051a4be5..8df8f761 100755 --- a/dgit +++ b/dgit @@ -379,6 +379,10 @@ sub branch_is_gdr ($) { printdebug "branch_is_gdr $walk ?-octopus NO\n"; return 0; } + if (!@parents) { + printdebug "branch_is_gdr $walk origin\n"; + return 0; + } if ($get_patches->($walk) ne $tip_patches) { # Our parent added, removed, or edited patches, and wasn't # a gdr make-patches commit. gdr make-patches probably @@ -516,7 +520,7 @@ sub protocol_send_file ($$) { print $fh $d or confess $!; } PF->error and die "$ourfn $!"; - print $fh "data-end\n" or die $!; + print $fh "data-end\n" or confess $!; close PF; } @@ -541,9 +545,9 @@ sub protocol_receive_file ($$) { } $fh; last unless $y; my $d = protocol_read_bytes $fh, $l; - print PF $d or die $!; + print PF $d or confess $!; } - close PF or die $!; + close PF or confess $!; } #---------- remote protocol support, responder ---------- @@ -553,7 +557,7 @@ sub responder_send_command ($) { return unless $we_are_responder; # called even without $we_are_responder printdebug ">> $command\n"; - print PO $command, "\n" or die $!; + print PO $command, "\n" or confess $!; } sub responder_send_file ($$) { @@ -588,8 +592,8 @@ sub initiator_expect (&) { sub progress { if ($we_are_responder) { my $m = join '', @_; - responder_send_command "progress ".length($m) or die $!; - print PO $m or die $!; + responder_send_command "progress ".length($m) or confess $!; + print PO $m or confess $!; } else { print @_, "\n"; } @@ -604,7 +608,7 @@ sub url_get { } my $what = $_[$#_]; progress "downloading $what..."; - my $r = $ua->get(@_) or die $!; + 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; @@ -668,7 +672,7 @@ Perhaps the upload is stuck in incoming. Using the version from git. END sub badusage { - print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or die $!; + print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess $!; finish 8; } @@ -681,7 +685,7 @@ sub pre_help () { not_necessarily_a_tree(); } sub cmd_help () { - print __ $helpmsg or die $!; + print __ $helpmsg or confess $!; finish 0; } @@ -928,8 +932,8 @@ sub supplementary_message ($) { return; } elsif ($protovsn >= 3) { responder_send_command "supplementary-message ".length($msg) - or die $!; - print PO $msg or die $!; + or confess $!; + print PO $msg or confess $!; } } @@ -1066,7 +1070,7 @@ sub commit_getclogp ($) { } sub parse_dscdata () { - my $dscfh = new IO::File \$dscdata, '<' or die $!; + my $dscfh = new IO::File \$dscdata, '<' or confess $!; printdebug Dumper($dscdata) if $debuglevel>1; $dsc = parsecontrolfh($dscfh,$dscurl,1); printdebug Dumper($dsc) if $debuglevel>1; @@ -1289,12 +1293,12 @@ sub aptget_prep ($) { access_cfg('mirror'), $aptsuites, access_cfg('aptget-components') - or die $!; + or confess $!; ensuredir "$aptget_base/cache"; ensuredir "$aptget_base/lists"; - open CONF, ">", $aptget_configpath or die $!; + open CONF, ">", $aptget_configpath or confess $!; print CONF <) { next unless stat_exists $oldlist; my ($mtime) = (stat _)[9]; @@ -1417,7 +1421,7 @@ sub dummycatapi_run_in_mirror ($@) { my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune, qw(x), $mirror, @$argl); debugcmd "-|", @cmd; - open FIA, "-|", @cmd or die $!; + open FIA, "-|", @cmd or confess $!; my $r = $fn->(); close FIA or ($!==0 && $?==141) or die failedcmd @cmd; return $r; @@ -1520,7 +1524,7 @@ sub sshpsql ($$$) { " export LC_MESSAGES=C; export LC_CTYPE=C;". " ".shellquote qw(psql -A), $dbname, qw(-c), $sql); debugcmd "|",@cmd; - open P, "-|", @cmd or die $!; + open P, "-|", @cmd or confess $!; while (

) { chomp or die; printdebug(">|$_|\n"); @@ -1821,7 +1825,7 @@ sub remove_stray_gits ($) { my ($what) = @_; my @gitscmd = qw(find -name .git -prune -print0); debugcmd "|",@gitscmd; - open GITS, "-|", @gitscmd or die $!; + open GITS, "-|", @gitscmd or confess $!; { local $/="\0"; while () { @@ -2220,18 +2224,18 @@ sub generate_commits_from_dsc () { printdebug "considering saving $f: "; - if (link $f, $upper_f) { + if (rename_link_xf 1, $f, $upper_f) { printdebug "linked.\n"; - } elsif ((printdebug "($!) "), + } elsif ((printdebug "($@) "), $! != EEXIST) { - fail f_ "saving %s: %s", "$buildproductsdir/$f", $!; + fail f_ "saving %s: %s", "$buildproductsdir/$f", $@; } elsif (!$refetched) { printdebug "no need.\n"; - } elsif (link $f, "$upper_f,fetch") { + } elsif (rename_link_xf 1, $f, "$upper_f,fetch") { printdebug "linked (using ...,fetch).\n"; - } elsif ((printdebug "($!) "), + } elsif ((printdebug "($@) "), $! != EEXIST) { - fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $!; + fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@; } else { printdebug "cannot.\n"; } @@ -2278,9 +2282,9 @@ sub generate_commits_from_dsc () { new Dpkg::Compression::Process compression => $cname; @compr_cmd = $compr_proc->get_uncompress_cmdline(); my $compr_fh = new IO::Handle; - my $compr_pid = open $compr_fh, "-|" // die $!; + my $compr_pid = open $compr_fh, "-|" // confess $!; if (!$compr_pid) { - open STDIN, "<&", $input or die $!; + open STDIN, "<&", $input or confess $!; exec @compr_cmd; die "dgit (child): exec $compr_cmd[0]: $!\n"; } @@ -2288,23 +2292,23 @@ sub generate_commits_from_dsc () { } rmtree "_unpack-tar"; - mkdir "_unpack-tar" or die $!; + mkdir "_unpack-tar" or confess $!; my @tarcmd = qw(tar -x -f - --no-same-owner --no-same-permissions --no-acls --no-xattrs --no-selinux); - my $tar_pid = fork // die $!; + my $tar_pid = fork // confess $!; if (!$tar_pid) { - chdir "_unpack-tar" or die $!; - open STDIN, "<&", $input or die $!; + chdir "_unpack-tar" or confess $!; + open STDIN, "<&", $input or confess $!; exec @tarcmd; die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!; } - $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!; + $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!; !$? or failedcmd @tarcmd; close $input or (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd) - : die $!); + : confess $!); # finally, we have the results in "tarball", but maybe # with the wrong permissions @@ -2461,14 +2465,14 @@ END_T printdebug "import main commit\n"; - open C, ">../commit.tmp" or die $!; - print C <../commit.tmp" or confess $!; + print C <{Commit} END - print C <{format}) { @@ -2522,7 +2526,7 @@ END progress f_ "%s: trying slow absurd-git-apply...", $us; rename "../../gbp-pq-output","../../gbp-pq-output.0" or $!==ENOENT - or die $!; + or confess $!; } eval { die "forbid absurd git-apply\n" if $use_absurd @@ -2588,7 +2592,7 @@ Version actually in archive: %s (older) Last version pushed with dgit: %s (newer or same) %s END - __ $later_warning_msg or die $!; + __ $later_warning_msg or confess $!; @output = $lastpush_mergeinput; } else { # Same version. Use what's in the server git branch, @@ -2618,7 +2622,7 @@ sub complete_file_from_dsc ($$;$) { open F, "<", "$tf" or die "$tf: $!"; $fi->{Digester}->reset(); $fi->{Digester}->addfile(*F); - F->error and die $!; + F->error and confess $!; $got = $fi->{Digester}->hexdigest(); return $got eq $fi->{Hash}; }; @@ -2752,7 +2756,7 @@ sub git_lrfetch_sane { debugcmd "|",@lcmd; my %wantr; - open GITLS, "-|", @lcmd or die $!; + open GITLS, "-|", @lcmd or confess $!; while () { printdebug "=> ", $_; m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; @@ -3173,7 +3177,7 @@ sub fetch_from_archive () { printdebug "del_lrfetchrefs: $objid $fullrefname\n"; if (!$gur) { $gur ||= new IO::Handle; - open $gur, "|-", qw(git update-ref --stdin) or die $!; + open $gur, "|-", qw(git update-ref --stdin) or confess $!; } printf $gur "delete %s %s\n", $fullrefname, $objid; } @@ -3194,7 +3198,7 @@ Commit referred to by archive: %s Last version pushed with dgit: %s %s END - __ $later_warning_msg or die $!; + __ $later_warning_msg or confess $!; @mergeinputs = ($lastpush_mergeinput); } else { # Archive has .dsc which is not a descendant of the last dgit @@ -3229,11 +3233,11 @@ END Package not found in the archive, but has allegedly been pushed using dgit. %s END - __ $later_warning_msg or die $!; + __ $later_warning_msg or confess $!; } else { printdebug "nothing found!\n"; if (defined $skew_warning_vsn) { - print STDERR f_ <", $mcf or die "$mcf $!"; - print MC <{Commit} } @mergeinputs; @parents = reverse @parents if $compat_info->{ReverseParents}; - print MC <{Commit} END - print MC <{Message}) { - print MC $compat_info->{Message} or die $!; + print MC $compat_info->{Message} or confess $!; } else { - print MC f_ <{Info} - or die $!; + or confess $!; }; $message_add_info->($mergeinputs[0]); - print MC __ <($_) foreach @mergeinputs[1..$#mergeinputs]; } - close MC or die $!; + close MC or confess $!; $hash = make_commit $mcf; } else { $hash = $mergeinputs[0]{Commit}; @@ -3362,7 +3366,7 @@ END my $got_vsn = getfield $gotclogp, 'Version'; printdebug "SKEW CHECK GOT $got_vsn\n"; if (version_compare($got_vsn, $skew_warning_vsn) < 0) { - print STDERR f_ <) { chomp; next if m{^debian/changelog\s}; - print NATTRS $_, "\n" or die $!; + print NATTRS $_, "\n" or confess $!; } - ATTRS->error and die $!; + ATTRS->error and confess $!; close ATTRS; } - print NATTRS "debian/changelog merge=$driver\n" or die $!; + print NATTRS "debian/changelog merge=$driver\n" or confess $!; close NATTRS; set_local_git_config "$cb.name", __ 'debian/changelog merge driver'; @@ -3467,7 +3471,7 @@ sub is_gitattrs_setup () { printdebug "is_gitattrs_setup: found old macro\n"; return 0; } - $gai->error and die $!; + $gai->error and confess $!; printdebug "is_gitattrs_setup: found nothing\n"; return undef; } @@ -3488,8 +3492,8 @@ END my $af = "$maindir_gitcommon/info/attributes"; ensuredir "$maindir_gitcommon/info"; - open GAO, "> $af.new" or die $!; - print GAO < $af.new" or confess $!; + print GAO <error and die $!; + $gai->error and confess $!; } - close GAO or die $!; + close GAO or confess $!; rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!; } @@ -3526,7 +3530,7 @@ sub check_gitattrs ($$) { my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:"); debugcmd "|",@cmd; my $gafl = new IO::File; - open $gafl, "-|", @cmd or die $!; + open $gafl, "-|", @cmd or confess $!; while (<$gafl>) { chomp or die; s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die; @@ -3551,7 +3555,7 @@ sub multisuite_suite_child ($$$) { # in child, sets things up, calls $fn->(), and returns undef # in parent, returns canonical suite name for $tsuite my $canonsuitefh = IO::File::new_tmpfile; - my $pid = fork // die $!; + my $pid = fork // confess $!; if (!$pid) { forkcheck_setup(); $isuite = $tsuite; @@ -3559,17 +3563,17 @@ sub multisuite_suite_child ($$$) { $debugprefix .= " "; progress f_ "fetching %s...", $tsuite; canonicalise_suite(); - print $canonsuitefh $csuite, "\n" or die $!; - close $canonsuitefh or die $!; + print $canonsuitefh $csuite, "\n" or confess $!; + close $canonsuitefh or confess $!; $fn->(); return undef; } - waitpid $pid,0 == $pid or die $!; + waitpid $pid,0 == $pid or confess $!; fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg() if $? && $?!=256*4; - seek $canonsuitefh,0,0 or die $!; + seek $canonsuitefh,0,0 or confess $!; local $csuite = <$canonsuitefh>; - die $! unless defined $csuite && chomp $csuite; + confess $! unless defined $csuite && chomp $csuite; if ($? == 256*4) { printdebug "multisuite $tsuite missing\n"; return $csuite; @@ -3712,9 +3716,9 @@ sub fork_for_multisuite ($) { } sub clone_set_head () { - open H, "> .git/HEAD" or die $!; - print H "ref: ".lref()."\n" or die $!; - close H or die $!; + open H, "> .git/HEAD" or confess $!; + print H "ref: ".lref()."\n" or confess $!; + close H or confess $!; } sub clone_finish ($) { my ($dstdir) = @_; @@ -3813,9 +3817,11 @@ sub pull () { } sub check_not_dirty () { - foreach my $f (qw(local-options local-patch-header)) { - if (stat_exists "debian/source/$f") { - fail f_ "git tree contains debian/source/%s", $f; + my @forbid = qw(local-options local-patch-header); + @forbid = map { "debian/source/$_" } @forbid; + foreach my $f (@forbid) { + if (stat_exists $f) { + fail f_ "git tree contains %s", $f; } } @@ -3880,18 +3886,18 @@ sub get_source_format () { $options{$_} = 1; } } - F->error and die $!; + F->error and confess $!; close F; } else { - die $! unless $!==&ENOENT; + confess $! unless $!==&ENOENT; } if (!open F, "debian/source/format") { - die $! unless $!==&ENOENT; + confess $! unless $!==&ENOENT; return ''; } $_ = ; - F->error and die $!; + F->error and confess $!; chomp; return ($_, \%options); } @@ -4012,7 +4018,7 @@ END sub pseudomerge_make_commit ($$$$ $$) { my ($clogp, $dgitview, $archive_hash, $i_arch_v, $msg_cmd, $msg_msg) = @_; - progress f_ "Declaring that HEAD inciudes all changes in %s...", + progress f_ "Declaring that HEAD includes all changes in %s...", $i_arch_v->[0]; my $tree = cmdoutput qw(git rev-parse), "${dgitview}:"; @@ -4028,7 +4034,7 @@ sub pseudomerge_make_commit ($$$$ $$) { # git rev-list --first-parent DTRT. my $pmf = dgit_privdir()."/pseudomerge"; open MC, ">", $pmf or die "$pmf $!"; - print MC <{$ourdscfield[0]} = join " ", $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag}, $reader_giturl; - $dsc->save("$dscfn.tmp") or die $!; + $dsc->save("$dscfn.tmp") or confess $!; my $changes = parsecontrol($changesfile,$changesfilewhat); foreach my $field (qw(Source Distribution Version)) { @@ -4242,8 +4248,8 @@ sub push_mktags ($$ $$ $) { my $head = $tw->{Objid}; my $tag = $tw->{Tag}; - open TO, '>', $tfn->('.tmp') or die $!; - print TO <', $tfn->('.tmp') or confess $!; + print TO <('.tmp'); if ($sign) { @@ -4284,7 +4290,7 @@ END if (!defined $keyid) { $keyid = getfield $clogp, 'Maintainer'; } - unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!; + unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!; my @sign_cmd = (@gpg, qw(--detach-sign --armor)); push @sign_cmd, qw(-u),$keyid if defined $keyid; push @sign_cmd, $tfn->('.tmp'); @@ -4519,11 +4525,11 @@ ENDT if ($sourceonlypolicy eq 'ok') { } elsif ($sourceonlypolicy eq 'always') { forceable_fail [qw(uploading-binaries)], - __ "uploading binaries, although distroy policy is source only" + __ "uploading binaries, although distro policy is source only" if $hasdebs; } elsif ($sourceonlypolicy eq 'never') { forceable_fail [qw(uploading-source-only)], - __ "source-only upload, although distroy policy requires .debs" + __ "source-only upload, although distro policy requires .debs" if !$hasdebs; } elsif ($sourceonlypolicy eq 'not-wholly-new') { forceable_fail [qw(uploading-source-only)], @@ -4891,11 +4897,11 @@ sub pre_remote_push_build_host { $we_are_responder = 1; $us .= " (build host)"; - open PI, "<&STDIN" or die $!; - open STDIN, "/dev/null" or die $!; - open PO, ">&STDOUT" or die $!; + open PI, "<&STDIN" or confess $!; + open STDIN, "/dev/null" or confess $!; + open PO, ">&STDOUT" or confess $!; autoflush PO 1; - open STDOUT, ">&STDERR" or die $!; + open STDOUT, ">&STDERR" or confess $!; autoflush STDOUT 1; $vsnwant //= 1; @@ -5019,7 +5025,7 @@ sub i_resp_complete { $i_child_pid = undef; # prevents killing some other process with same pid printdebug "waiting for build host child $pid...\n"; my $got = waitpid $pid, 0; - die $! unless $got == $pid; + confess $! unless $got == $pid; fail f_ "build host child failed: %s", waitstatusmsg() if $?; i_cleanup(); @@ -5075,7 +5081,7 @@ sub i_resp_want ($) { foreach my $localpath (@localpaths) { protocol_send_file \*RI, $localpath; } - print RI "files-end\n" or die $!; + print RI "files-end\n" or confess $!; } our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos); @@ -5182,13 +5188,13 @@ sub quiltify_dpkg_commit ($$$;$) { my $descfn = ".git/dgit/quilt-description.tmp"; open O, '>', $descfn or confess "$descfn: $!"; $msg =~ s/\n+/\n\n/; - print O <>$gipatch", @git, qw(diff), $unapplied, $headref, "--", sort keys %$editedignores; - open SERIES, "+>>", "debian/patches/series" or die $!; - defined seek SERIES, -1, 2 or $!==EINVAL or die $!; + open SERIES, "+>>", "debian/patches/series" or confess $!; + defined seek SERIES, -1, 2 or $!==EINVAL or confess $!; my $newline; - defined read SERIES, $newline, 1 or die $!; - print SERIES "\n" or die $! unless $newline eq "\n"; - print SERIES "auto-gitignore\n" or die $!; + defined read SERIES, $newline, 1 or confess $!; + print SERIES "\n" or confess $! unless $newline eq "\n"; + print SERIES "auto-gitignore\n" or confess $!; close SERIES or die $!; runcmd @git, qw(add -f -- debian/patches/series), $gipatch; commit_admin +(__ <{Commit} P=$p->{Commit}\n"; my @cmd= (@git, qw(diff-tree -r --name-only), - $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc)); + $p->{Commit},$c->{Commit}, + qw(-- debian/patches .pc debian/source/format)); my $patchstackchange = cmdoutput @cmd; if (length $patchstackchange) { $patchstackchange =~ s/\n/,/g; @@ -5715,7 +5722,10 @@ END if (act_local()) { debugcmd "+",@cmd; $!=0; $?=-1; - failedcmd @cmd if system @cmd and $?!=7*256; + failedcmd @cmd + if system @cmd + and not ($? == 7*256 or + $? == -1 && $!==ENOENT); } else { dryrun_report @cmd; } @@ -5741,7 +5751,7 @@ END sub unpack_playtree_mkwork ($) { my ($headref) = @_; - mkdir "work" or die $!; + mkdir "work" or confess $!; changedir "work"; mktree_in_ud_here(); runcmd @git, qw(reset -q --hard), $headref; @@ -5797,7 +5807,9 @@ sub quilt_fixup_singlepatch ($$$) { changedir ".."; runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc"); rename srcfn("$upstreamversion", "/debian/patches"), - "work/debian/patches"; + "work/debian/patches" + or $!==ENOENT + or confess "install d/patches: $!"; changedir "work"; commit_quilty_patch(); @@ -5808,8 +5820,8 @@ sub quilt_make_fake_dsc ($) { my $fakeversion="$upstreamversion-~~DGITFAKE"; - my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; - print $fakedsc <' or confess $!; + print $fakedsc <addfile($fh); - print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; + print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!; }; unpack_playtree_linkorigs($upstreamversion, $dscaddfile); @@ -5843,7 +5855,7 @@ END runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files; $dscaddfile->($debtar); - close $fakedsc or die $!; + close $fakedsc or confess $!; } sub quilt_fakedsc2unapplied ($$) { @@ -6036,7 +6048,7 @@ END progress __ "Tree already contains .pc - will use it then delete it."; $mustdeletepc=1; } else { - rename '../fake/.pc','.pc' or die $!; + rename '../fake/.pc','.pc' or confess $!; } changedir '../fake'; @@ -6116,7 +6128,7 @@ END quiltify($clogp,$headref,$oldtiptree,\@failsuggestion); if (!open P, '>>', ".pc/applied-patches") { - $!==&ENOENT or die $!; + $!==&ENOENT or confess $!; } else { close P; } @@ -6131,25 +6143,25 @@ END sub quilt_fixup_editor () { my $descfn = $ENV{$fakeeditorenv}; my $editing = $ARGV[$#ARGV]; - open I1, '<', $descfn or die "$descfn: $!"; - open I2, '<', $editing or die "$editing: $!"; - unlink $editing or die "$editing: $!"; - open O, '>', $editing or die "$editing: $!"; - while () { print O or die $!; } I1->error and die $!; + open I1, '<', $descfn or confess "$descfn: $!"; + open I2, '<', $editing or confess "$editing: $!"; + unlink $editing or confess "$editing: $!"; + open O, '>', $editing or confess "$editing: $!"; + while () { print O or confess $!; } I1->error and confess $!; my $copying = 0; while () { $copying ||= m/^\-\-\- /; next unless $copying; - print O or die $!; + print O or confess $!; } - I2->error and die $!; + I2->error and confess $!; close O or die $1; finish 0; } sub maybe_apply_patches_dirtily () { return unless $quilt_mode =~ m/gbp|unapplied/; - print STDERR <[0] } @vsns; @vsns = sort { -version_compare($a, $b) } @vsns; $changes_since_version = $vsns[0]; - progress "changelog will contain changes since $vsns[0]"; + progress f_ "changelog will contain changes since %s", $vsns[0]; } else { $changes_since_version = '_'; - progress "package seems new, not specifying -v"; + progress __ "package seems new, not specifying -v"; } } if ($changes_since_version ne '_') { @@ -6322,14 +6337,14 @@ sub massage_dbp_args ($;$) { $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d; $r |= WANTSRC_SOURCE if grep { s/^source$// } @d; $r |= WANTSRC_BUILDER if grep { m/./ } @d; - fail "Wanted to build nothing!" unless $r; + fail __ "Wanted to build nothing!" unless $r; $dmode = '--build='. join ',', grep m/./, @d; } else { $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE : $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER : $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER : - die "$dmode ?"; + confess "$dmode ?"; } printdebug "massage done $r $dmode.\n"; push @$cmd, $dmode; @@ -6359,30 +6374,35 @@ sub postbuild_mergechanges ($) { } @changesfiles; my $result; if (@changesfiles==1) { - fail <; }; - D->error and fail "read $dscfn: $!"; + D->error and fail f_ "read %s: %s", $dscfn, $!; close C; # we don't normally need this so import it here @@ -6752,13 +6799,13 @@ sub cmd_import_dsc { local $SIG{__WARN__} = sub { print STDERR $_[0]; return unless $needsig; - fail "import-dsc signature check failed"; + fail __ "import-dsc signature check failed"; }; if (!$dp->is_signed()) { - warn "$us: warning: importing unsigned .dsc\n"; + warn f_ "%s: warning: importing unsigned .dsc\n", $us; } else { my $r = $dp->check_signature(); - die "->check_signature => $r" if $needsig && $r; + confess "->check_signature => $r" if $needsig && $r; } } @@ -6766,7 +6813,7 @@ sub cmd_import_dsc { $package = getfield $dsc, 'Source'; - parse_dsc_field($dsc, "Dgit metadata in .dsc") + parse_dsc_field($dsc, __ "Dgit metadata in .dsc") unless forceing [qw(import-dsc-with-dgit-field)]; parse_dsc_field_def_dsc_distro(); @@ -6776,7 +6823,8 @@ sub cmd_import_dsc { notpushing(); if (defined $dsc_hash) { - progress "dgit: import-dsc of .dsc with Dgit field, using git hash"; + progress __ + "dgit: import-dsc of .dsc with Dgit field, using git hash"; resolve_dsc_field_commit undef, undef; } if (defined $dsc_hash) { @@ -6784,29 +6832,29 @@ sub cmd_import_dsc { "echo $dsc_hash | git cat-file --batch-check"); my $objgot = cmdoutput @cmd; if ($objgot =~ m#^\w+ missing\b#) { - fail < 0) { - progress "Not fast forward, forced update."; + progress __ "Not fast forward, forced update."; } else { - fail "Not fast forward to $dsc_hash"; + fail f_ "Not fast forward to %s", $dsc_hash; } } import_dsc_result $dstbranch, $dsc_hash, "dgit import-dsc (Dgit): $info", - "updated git ref $dstbranch"; + f_ "updated git ref %s", $dstbranch; return 0; } - fail < $there"; + stat $test or fail f_ + "import %s requires %s, but: %s", $dscfn, $test, $!; + symlink $there, $here or fail f_ + "symlink %s to %s: %s", $there, $here, $!; + progress f_ "made symlink %s -> %s", $here, $there; # print STDERR Dumper($fi); } my @mergeinputs = generate_commits_from_dsc(); @@ -6843,21 +6896,24 @@ END if ($oldhash) { if ($force > 0) { - progress "Import, forced update - synthetic orphan git history."; + progress __ + "Import, forced update - synthetic orphan git history."; } elsif ($force < 0) { - progress "Import, merging."; + progress __ "Import, merging."; my $tree = cmdoutput @git, qw(rev-parse), "$newhash:"; my $version = getfield $dsc, 'Version'; my $clogp = commit_getclogp $newhash; my $authline = clogp_authline $clogp; - $newhash = make_commit_text <",@cmd; - exec @cmd or fail "exec curl: $!\n"; + exec @cmd or fail f_ "exec curl: %s\n", $!; } sub repos_server_url () { @@ -6893,53 +6949,56 @@ sub pre_clone_dgit_repos_server () { not_necessarily_a_tree(); } sub cmd_clone_dgit_repos_server { - badusage "need destination argument" unless @ARGV==1; + badusage __ "need destination argument" unless @ARGV==1; my ($destdir) = @ARGV; my $url = repos_server_url(); my @cmd = (@git, qw(clone), $url, $destdir); debugcmd ">",@cmd; - exec @cmd or fail "exec git clone: $!\n"; + exec @cmd or fail f_ "exec git clone: %s\n", $!; } sub pre_print_dgit_repos_server_source_url () { not_necessarily_a_tree(); } sub cmd_print_dgit_repos_server_source_url { - badusage "no arguments allowed to dgit print-dgit-repos-server-source-url" + badusage __ + "no arguments allowed to dgit print-dgit-repos-server-source-url" if @ARGV; my $url = repos_server_url(); - print $url, "\n" or die $!; + print $url, "\n" or confess $!; } sub pre_print_dpkg_source_ignores { not_necessarily_a_tree(); } sub cmd_print_dpkg_source_ignores { - badusage "no arguments allowed to dgit print-dpkg-source-ignores" + badusage __ + "no arguments allowed to dgit print-dpkg-source-ignores" if @ARGV; - print "@dpkg_source_ignores\n" or die $!; + print "@dpkg_source_ignores\n" or confess $!; } sub cmd_setup_mergechangelogs { - badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV; + badusage __ "no arguments allowed to dgit setup-mergechangelogs" + if @ARGV; local $isuite = 'DGIT-SETUP-TREE'; setup_mergechangelogs(1); } sub cmd_setup_useremail { - badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV; local $isuite = 'DGIT-SETUP-TREE'; setup_useremail(1); } sub cmd_setup_gitattributes { - badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV; local $isuite = 'DGIT-SETUP-TREE'; setup_gitattrs(1); } sub cmd_setup_new_tree { - badusage "no arguments allowed to dgit setup-tree" if @ARGV; + badusage __ "no arguments allowed to dgit setup-tree" if @ARGV; local $isuite = 'DGIT-SETUP-TREE'; setup_new_tree(); } @@ -6947,7 +7006,7 @@ sub cmd_setup_new_tree { #---------- argument parsing and main program ---------- sub cmd_version { - print "dgit version $our_version\n" or die $!; + print "dgit version $our_version\n" or confess $!; finish 0; } @@ -6986,8 +7045,8 @@ defvalopt '', '-C', '.+', sub { defvalopt '--initiator-tempdir','','.*', sub { ($initiator_tempdir) = (@_); $initiator_tempdir =~ m#^/# or - badusage "--initiator-tempdir must be used specify an". - " absolute, not relative, directory." + badusage __ "--initiator-tempdir must be used specify an". + " absolute, not relative, directory." }; sub defoptmodes ($@) { @@ -7025,11 +7084,11 @@ sub parseopts () { my ($what) = @_; @rvalopts = ($_); if (!defined $val) { - badusage "$what needs a value" unless @ARGV; + badusage f_ "%s needs a value", $what unless @ARGV; $val = shift @ARGV; push @rvalopts, $val; } - badusage "bad value \`$val' for $what" unless + badusage f_ "bad value \`%s' for %s", $val, $what unless $val =~ m/^$oi->{Re}$(?!\n)/s; my $how = $oi->{How}; if (ref($how) eq 'SCALAR') { @@ -7114,7 +7173,8 @@ sub parseopts () { $_=''; } elsif (m/^--force-/) { print STDERR - "$us: warning: ignoring unknown force option $_\n"; + f_ "%s: warning: ignoring unknown force option %s\n", + $us, $_; $_=''; } elsif (m/^--dgit-tag-format=(old|new)$/s) { # undocumented, for testing @@ -7133,7 +7193,7 @@ sub parseopts () { push @ropts, $_; $funcopts_long{$_}(); } else { - badusage "unknown long option \`$_'"; + badusage f_ "unknown long option \`%s'", $_; } } else { while (m/^-./s) { @@ -7186,7 +7246,7 @@ sub parseopts () { $valopt->($oi->{Short}); $_ = ''; } else { - badusage "unknown short option \`$_'"; + badusage f_ "unknown short option \`%s'", $_; } } } @@ -7195,23 +7255,24 @@ sub parseopts () { sub check_env_sanity () { my $blocked = new POSIX::SigSet; - sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!; + sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!; eval { foreach my $name (qw(PIPE CHLD)) { my $signame = "SIG$name"; my $signum = eval "POSIX::$signame" // die; - die "$signame is set to something other than SIG_DFL\n" + die f_ "%s is set to something other than SIG_DFL\n", + $signame if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT'; $blocked->ismember($signum) and - die "$signame is blocked\n"; + die f_ "%s is blocked\n", $signame; } }; return unless $@; chomp $@; - fail <[0]; $om->[0] = $v; } @@ -7240,7 +7301,7 @@ sub parseopts_late_defaults () { printdebug "CL $c ", (join " ", map { shellquote } @vl), "\n" if $debuglevel >= 4; next unless @vl; - badcfg "cannot configure options for $k" + badcfg f_ "cannot configure options for %s", $k if $opts_opt_cmdonly{$k}; my $insertpos = $opts_cfg_insertpos{$k}; @$om = ( @$om[0..$insertpos-1], @@ -7260,7 +7321,7 @@ sub parseopts_late_defaults () { // access_cfg('quilt-mode', 'RETURN-UNDEF') // 'linear'; $quilt_mode =~ m/^($quilt_modes_re)$/ - or badcfg "unknown quilt-mode \`$quilt_mode'"; + or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode; $quilt_mode = $1; } @@ -7270,7 +7331,8 @@ sub parseopts_late_defaults () { next if defined $$vr; $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default}; my $v = $moc->{Vals}{$$vr}; - badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v; + badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr + unless defined $v; $$vr = $v; } @@ -7282,7 +7344,7 @@ sub parseopts_late_defaults () { $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF'); $cleanmode //= 'dpkg-source'; - badcfg "unknown clean-mode \`$cleanmode'" unless + badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s; } @@ -7303,11 +7365,11 @@ if ($ENV{$fakeeditorenv}) { parseopts(); check_env_sanity(); -print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; -print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n" +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 $!; + print STDERR __ $helpmsg or confess $!; finish 8; } $cmd = $subcommand = shift @ARGV; @@ -7316,11 +7378,14 @@ $cmd =~ y/-/_/; my $pre_fn = ${*::}{"pre_$cmd"}; $pre_fn->() if $pre_fn; -record_maindir if $invoked_in_git_tree; +if ($invoked_in_git_tree) { + changedir_git_toplevel(); + record_maindir(); +} git_slurp_config(); my $fn = ${*::}{"cmd_$cmd"}; -$fn or badusage "unknown operation $cmd"; +$fn or badusage f_ "unknown operation %s", $cmd; $fn->(); finish 0;