X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=920787457bd271b3aecef6d0eecb8c1f924d9200;hb=fe216b34e36c059be82c18cfe850c729e5c8df21;hp=4587af257532c1c64036651feeb7d8c4d7fd3d85;hpb=75dd5aef7f0d91ce0ac78285cc15843f686f5914;p=dgit.git diff --git a/dgit b/dgit index 4587af25..92078745 100755 --- a/dgit +++ b/dgit @@ -32,6 +32,7 @@ use Data::Dumper; use LWP::UserAgent; use Dpkg::Control::Hash; use File::Path; +use File::Spec; use File::Temp qw(tempdir); use File::Basename; use Dpkg::Version; @@ -102,7 +103,7 @@ our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); our $suite_re = '[-+.0-9a-z]+'; our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )? - | git | git-ff + | (?: git | git-ff ) (?: ,always )? | check (?: ,ignores )? | none )}x; @@ -132,8 +133,8 @@ our (@mergechanges) = qw(mergechanges -f); our (@gbp_build) = (''); our (@gbp_pq) = ('gbp pq'); our (@changesopts) = (''); -our (@pbuilder) = ("sudo -E pbuilder"); -our (@cowbuilder) = ("sudo -E cowbuilder"); +our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes"); +our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes"); our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'curl' => \@curl, @@ -164,6 +165,7 @@ our %opts_cfg_insertpos = map { } keys %opts_opt_map; sub parseopts_late_defaults(); +sub quiltify_trees_differ ($$;$$$); sub setup_gitattrs(;$); sub check_gitattrs($$); @@ -173,7 +175,31 @@ our $keyid; autoflush STDOUT 1; our $supplementary_message = ''; -our $split_brain = 0; +our $made_split_brain = 0; +our $do_split_brain = 0; + +# Interactions between quilt mode and split brain +# (currently, split brain only implemented iff +# madformat_wantfixup && quiltmode_splitbrain) +# +# source format sane `3.0 (quilt)' +# madformat_wantfixup() +# +# quilt mode normal quiltmode +# (eg linear) _splitbrain +# +# ------------ ------------------------------------------------ +# +# no split no q cache no q cache forbidden, +# brain PM on master q fixup on master prevented +# !$do_split_brain PM on master +# +# split brain no q cache q fixup cached, to dgit view +# PM in dgit view PM in dgit view +# +# PM = pseudomerge to make ff, due to overwrite (or split view) +# "no q cache" = do not record in cache on build, do not check cache +# `3.0 (quilt)' with --quilt=nocheck is treated as sane format END { local ($@, $?); @@ -257,7 +283,7 @@ sub forceing ($) { } sub no_such_package () { - print STDERR f_ "%s: package %s does not exist in suite %s\n", + print STDERR f_ "%s: source package %s does not exist in suite %s\n", $us, $package, $isuite; finish 4; } @@ -396,7 +422,9 @@ sub branch_is_gdr ($) { return 0; } if ($tip_patches eq '' and - !defined git_cat_file "$walk:debian") { + !defined git_cat_file "$walk~:debian" and + !quiltify_trees_differ "$walk~", $walk + ) { # (gdr classification of parent: BreakwaterStart printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n"; return 1; @@ -520,11 +548,11 @@ sub protocol_send_file ($$) { my $got = read PF, $d, 65536; die "$ourfn: $!" unless defined $got; last if !$got; - print $fh "data-block ".length($d)."\n" or confess $!; - print $fh $d or confess $!; + print $fh "data-block ".length($d)."\n" or confess "$!"; + print $fh $d or confess "$!"; } PF->error and die "$ourfn $!"; - print $fh "data-end\n" or confess $!; + print $fh "data-end\n" or confess "$!"; close PF; } @@ -549,9 +577,9 @@ sub protocol_receive_file ($$) { } $fh; last unless $y; my $d = protocol_read_bytes $fh, $l; - print PF $d or confess $!; + print PF $d or confess "$!"; } - close PF or confess $!; + close PF or confess "$!"; } #---------- remote protocol support, responder ---------- @@ -561,7 +589,7 @@ sub responder_send_command ($) { return unless $we_are_responder; # called even without $we_are_responder printdebug ">> $command\n"; - print PO $command, "\n" or confess $!; + print PO $command, "\n" or confess "$!"; } sub responder_send_file ($$) { @@ -596,8 +624,8 @@ sub initiator_expect (&) { sub progress { if ($we_are_responder) { my $m = join '', @_; - responder_send_command "progress ".length($m) or confess $!; - print PO $m or confess $!; + responder_send_command "progress ".length($m) or confess "$!"; + print PO $m or confess "$!"; } else { print @_, "\n"; } @@ -612,7 +640,7 @@ sub url_get { } my $what = $_[$#_]; progress "downloading $what..."; - my $r = $ua->get(@_) or confess $!; + 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; @@ -676,7 +704,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 confess $!; + print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!"; finish 8; } @@ -689,7 +717,7 @@ sub pre_help () { not_necessarily_a_tree(); } sub cmd_help () { - print __ $helpmsg or confess $!; + print __ $helpmsg or confess "$!"; finish 0; } @@ -939,8 +967,8 @@ sub supplementary_message ($) { return; } elsif ($protovsn >= 3) { responder_send_command "supplementary-message ".length($msg) - or confess $!; - print PO $msg or confess $!; + or confess "$!"; + print PO $msg or confess "$!"; } } @@ -1077,7 +1105,7 @@ sub commit_getclogp ($) { } sub parse_dscdata () { - my $dscfh = new IO::File \$dscdata, '<' or confess $!; + 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; @@ -1295,17 +1323,17 @@ sub aptget_prep ($) { cfg_apply_map(\$aptsuites, 'suite map', access_cfg('aptget-suite-map', 'RETURN-UNDEF')); - open SRCS, ">", "$aptget_base/$sourceslist" or confess $!; + open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!"; printf SRCS "deb-src %s %s %s\n", access_cfg('mirror'), $aptsuites, access_cfg('aptget-components') - or confess $!; + or confess "$!"; ensuredir "$aptget_base/cache"; ensuredir "$aptget_base/lists"; - open CONF, ">", $aptget_configpath or confess $!; + open CONF, ">", $aptget_configpath or confess "$!"; print CONF <) { next unless stat_exists $oldlist; my ($mtime) = (stat _)[9]; @@ -1428,7 +1456,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 confess $!; + open FIA, "-|", @cmd or confess "$!"; my $r = $fn->(); close FIA or ($!==0 && $?==141) or die failedcmd @cmd; return $r; @@ -1531,7 +1559,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 confess $!; + open P, "-|", @cmd or confess "$!"; while (

) { chomp or die; printdebug(">|$_|\n"); @@ -1832,7 +1860,7 @@ sub remove_stray_gits ($) { my ($what) = @_; my @gitscmd = qw(find -name .git -prune -print0); debugcmd "|",@gitscmd; - open GITS, "-|", @gitscmd or confess $!; + open GITS, "-|", @gitscmd or confess "$!"; { local $/="\0"; while () { @@ -2197,17 +2225,89 @@ sub check_for_vendor_patches () { __ "(nominal) distro being accessed"); } +sub check_bpd_exists () { + stat $buildproductsdir + or fail f_ "build-products-dir %s is not accessible: %s\n", + $buildproductsdir, $!; +} + +sub dotdot_bpd_transfer_origs ($$$) { + my ($bpd_abs, $upstreamversion, $wanted) = @_; + # checks is_orig_file_of_vsn and if + # calls $wanted->{$leaf} and expects boolish + + return if $buildproductsdir eq '..'; + + my $warned; + my $dotdot = $maindir; + $dotdot =~ s{/[^/]+$}{}; + opendir DD, $dotdot or fail "opendir .. ($dotdot): $!"; + while ($!=0, defined(my $leaf = readdir DD)) { + { + local ($debuglevel) = $debuglevel-1; + printdebug "DD_BPD $leaf ?\n"; + } + next unless is_orig_file_of_vsn $leaf, $upstreamversion; + next unless $wanted->($leaf); + next if lstat "$bpd_abs/$leaf"; + + print STDERR f_ + "%s: found orig(s) in .. missing from build-products-dir, transferring:\n", + $us + unless $warned++; + $! == &ENOENT or fail f_ + "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!; + lstat "$dotdot/$leaf" or fail f_ + "check orig file %s in ..: %s", $leaf, $!; + if (-l _) { + stat "$dotdot/$leaf" or fail f_ + "check target of orig symlink %s in ..: %s", $leaf, $!; + my $ltarget = readlink "$dotdot/$leaf" or + die "readlink $dotdot/$leaf: $!"; + if ($ltarget !~ m{^/}) { + $ltarget = "$dotdot/$ltarget"; + } + symlink $ltarget, "$bpd_abs/$leaf" + or die "$ltarget $bpd_abs $leaf: $!"; + print STDERR f_ + "%s: cloned orig symlink from ..: %s\n", + $us, $leaf; + } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") { + print STDERR f_ + "%s: hardlinked orig from ..: %s\n", + $us, $leaf; + } elsif ($! != EXDEV) { + fail f_ "failed to make %s a hardlink to %s: %s", + "$bpd_abs/$leaf", "$dotdot/$leaf", $!; + } else { + symlink "$bpd_abs/$leaf", "$dotdot/$leaf" + or die "$bpd_abs $dotdot $leaf $!"; + print STDERR f_ + "%s: symmlinked orig from .. on other filesystem: %s\n", + $us, $leaf; + } + } + die "$dotdot; $!" if $!; + closedir DD; +} + sub generate_commits_from_dsc () { # See big comment in fetch_from_archive, below. # See also README.dsc-import. prep_ud(); changedir $playground; + my $bpd_abs = bpd_abs(); + my $upstreamv = upstreamversion $dsc->{version}; my @dfi = dsc_files_info(); + + dotdot_bpd_transfer_origs $bpd_abs, $upstreamv, + sub { grep { $_->{Filename} eq $_[0] } @dfi }; + foreach my $fi (@dfi) { my $f = $fi->{Filename}; die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#; - my $upper_f = (bpd_abs()."/$f"); + my $upper_f = "$bpd_abs/$f"; printdebug "considering reusing $f: "; @@ -2254,7 +2354,6 @@ sub generate_commits_from_dsc () { # from the debian/changelog, so we record the tree objects now and # make them into commits later. my @tartrees; - my $upstreamv = upstreamversion $dsc->{version}; my $orig_f_base = srcfn $upstreamv, ''; foreach my $fi (@dfi) { @@ -2289,9 +2388,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, "-|" // confess $!; + my $compr_pid = open $compr_fh, "-|" // confess "$!"; if (!$compr_pid) { - open STDIN, "<&", $input or confess $!; + open STDIN, "<&", $input or confess "$!"; exec @compr_cmd; die "dgit (child): exec $compr_cmd[0]: $!\n"; } @@ -2299,23 +2398,23 @@ sub generate_commits_from_dsc () { } rmtree "_unpack-tar"; - mkdir "_unpack-tar" or confess $!; + 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 // confess $!; + my $tar_pid = fork // confess "$!"; if (!$tar_pid) { - chdir "_unpack-tar" or confess $!; - open STDIN, "<&", $input or confess $!; + 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 confess $!; + $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!"; !$? or failedcmd @tarcmd; close $input or (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd) - : confess $!); + : confess "$!"); # finally, we have the results in "tarball", but maybe # with the wrong permissions @@ -2472,14 +2571,14 @@ END_T printdebug "import main commit\n"; - open C, ">../commit.tmp" or confess $!; - print C <../commit.tmp" or confess "$!"; + print C <{Commit} END - print C <{format}) { @@ -2533,7 +2632,7 @@ END progress f_ "%s: trying slow absurd-git-apply...", $us; rename "../../gbp-pq-output","../../gbp-pq-output.0" or $!==ENOENT - or confess $!; + or confess "$!"; } eval { die "forbid absurd git-apply\n" if $use_absurd @@ -2599,7 +2698,7 @@ Version actually in archive: %s (older) Last version pushed with dgit: %s (newer or same) %s END - __ $later_warning_msg or confess $!; + __ $later_warning_msg or confess "$!"; @output = $lastpush_mergeinput; } else { # Same version. Use what's in the server git branch, @@ -2629,7 +2728,7 @@ sub complete_file_from_dsc ($$;$) { open F, "<", "$tf" or die "$tf: $!"; $fi->{Digester}->reset(); $fi->{Digester}->addfile(*F); - F->error and confess $!; + F->error and confess "$!"; $got = $fi->{Digester}->hexdigest(); return $got eq $fi->{Hash}; }; @@ -2763,7 +2862,7 @@ sub git_lrfetch_sane { debugcmd "|",@lcmd; my %wantr; - open GITLS, "-|", @lcmd or confess $!; + open GITLS, "-|", @lcmd or confess "$!"; while () { printdebug "=> ", $_; m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; @@ -3062,6 +3161,7 @@ END } sub fetch_from_archive () { + check_bpd_exists(); ensure_setup_existing_tree(); # Ensures that lrref() is what is actually in the archive, one way @@ -3184,7 +3284,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 confess $!; + open $gur, "|-", qw(git update-ref --stdin) or confess "$!"; } printf $gur "delete %s %s\n", $fullrefname, $objid; } @@ -3205,7 +3305,7 @@ Commit referred to by archive: %s Last version pushed with dgit: %s %s END - __ $later_warning_msg or confess $!; + __ $later_warning_msg or confess "$!"; @mergeinputs = ($lastpush_mergeinput); } else { # Archive has .dsc which is not a descendant of the last dgit @@ -3240,11 +3340,11 @@ END Package not found in the archive, but has allegedly been pushed using dgit. %s END - __ $later_warning_msg or confess $!; + __ $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 confess $!; + print MC $compat_info->{Message} or confess "$!"; } else { - print MC f_ <{Info} - or confess $!; + or confess "$!"; }; $message_add_info->($mergeinputs[0]); - print MC __ <($_) foreach @mergeinputs[1..$#mergeinputs]; } - close MC or confess $!; + close MC or confess "$!"; $hash = make_commit $mcf; } else { $hash = $mergeinputs[0]{Commit}; @@ -3373,7 +3473,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 confess $!; + print NATTRS $_, "\n" or confess "$!"; } - ATTRS->error and confess $!; + ATTRS->error and confess "$!"; close ATTRS; } - print NATTRS "debian/changelog merge=$driver\n" or confess $!; + print NATTRS "debian/changelog merge=$driver\n" or confess "$!"; close NATTRS; set_local_git_config "$cb.name", __ 'debian/changelog merge driver'; @@ -3478,7 +3578,7 @@ sub is_gitattrs_setup () { printdebug "is_gitattrs_setup: found old macro\n"; return 0; } - $gai->error and confess $!; + $gai->error and confess "$!"; printdebug "is_gitattrs_setup: found nothing\n"; return undef; } @@ -3499,8 +3599,8 @@ END my $af = "$maindir_gitcommon/info/attributes"; ensuredir "$maindir_gitcommon/info"; - open GAO, "> $af.new" or confess $!; - print GAO < $af.new" or confess "$!"; + print GAO <error and confess $!; + $gai->error and confess "$!"; } - close GAO or confess $!; + close GAO or confess "$!"; rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!; } @@ -3537,7 +3637,7 @@ sub check_gitattrs ($$) { my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:"); debugcmd "|",@cmd; my $gafl = new IO::File; - open $gafl, "-|", @cmd or confess $!; + open $gafl, "-|", @cmd or confess "$!"; while (<$gafl>) { chomp or die; s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die; @@ -3562,7 +3662,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 // confess $!; + my $pid = fork // confess "$!"; if (!$pid) { forkcheck_setup(); $isuite = $tsuite; @@ -3570,17 +3670,17 @@ sub multisuite_suite_child ($$$) { $debugprefix .= " "; progress f_ "fetching %s...", $tsuite; canonicalise_suite(); - print $canonsuitefh $csuite, "\n" or confess $!; - close $canonsuitefh or confess $!; + print $canonsuitefh $csuite, "\n" or confess "$!"; + close $canonsuitefh or confess "$!"; $fn->(); return undef; } - waitpid $pid,0 == $pid or confess $!; + waitpid $pid,0 == $pid or confess "$!"; fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg() if $? && $?!=256*4; - seek $canonsuitefh,0,0 or confess $!; + seek $canonsuitefh,0,0 or confess "$!"; local $csuite = <$canonsuitefh>; - confess $! unless defined $csuite && chomp $csuite; + confess "$!" unless defined $csuite && chomp $csuite; if ($? == 256*4) { printdebug "multisuite $tsuite missing\n"; return $csuite; @@ -3723,9 +3823,9 @@ sub fork_for_multisuite ($) { } sub clone_set_head () { - open H, "> .git/HEAD" or confess $!; - print H "ref: ".lref()."\n" or confess $!; - close H or confess $!; + open H, "> .git/HEAD" or confess "$!"; + print H "ref: ".lref()."\n" or confess "$!"; + close H or confess "$!"; } sub clone_finish ($) { my ($dstdir) = @_; @@ -3758,10 +3858,13 @@ sub clone ($) { } printdebug "clone main body\n"; - canonicalise_suite(); - my $hasgit = check_for_git(); mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!; changedir $dstdir; + check_bpd_exists(); + + canonicalise_suite(); + my $hasgit = check_for_git(); + runcmd @git, qw(init -q); record_maindir(); setup_new_tree(); @@ -3904,18 +4007,18 @@ sub get_source_format () { $options{$_} = 1; } } - F->error and confess $!; + F->error and confess "$!"; close F; } else { - confess $! unless $!==&ENOENT; + confess "$!" unless $!==&ENOENT; } if (!open F, "debian/source/format") { - confess $! unless $!==&ENOENT; + confess "$!" unless $!==&ENOENT; return ''; } $_ = ; - F->error and confess $!; + F->error and confess "$!"; chomp; return ($_, \%options); } @@ -4052,7 +4155,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 confess $!; + $dsc->save("$dscfn.tmp") or confess "$!"; my $changes = parsecontrol($changesfile,$changesfilewhat); foreach my $field (qw(Source Distribution Version)) { @@ -4266,8 +4369,8 @@ sub push_mktags ($$ $$ $) { my $head = $tw->{Objid}; my $tag = $tw->{Tag}; - open TO, '>', $tfn->('.tmp') or confess $!; - print TO <', $tfn->('.tmp') or confess "$!"; + print TO <('.tmp'); if ($sign) { @@ -4308,7 +4411,7 @@ END if (!defined $keyid) { $keyid = getfield $clogp, 'Maintainer'; } - unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!; + 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'); @@ -4386,7 +4489,6 @@ END push_parse_dsc($dscpath, $dscfn, $cversion); my $format = getfield $dsc, 'Format'; - printdebug "format $format\n"; my $symref = git_get_symref(); my $actualhead = git_rev_parse('HEAD'); @@ -4412,9 +4514,8 @@ END if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: - if (quiltmode_splitbrain()) { + if ($do_split_brain) { changedir $playground; - quilt_make_fake_dsc($upstreamversion); my $cachekey; ($dgithead, $cachekey) = quilt_check_splitbrain_cache($actualhead, $upstreamversion); @@ -4422,17 +4523,22 @@ END "--quilt=%s but no cached dgit view: perhaps HEAD changed since dgit build[-source] ?", $quilt_mode; - $split_brain = 1; - $dgithead = splitbrain_pseudomerge($clogp, - $actualhead, $dgithead, - $archive_hash); - $maintviewhead = $actualhead; - changedir $maindir; - prep_ud(); # so _only_subdir() works, below - } else { + } + if (!$do_split_brain) { + # In split brain mode, do not attempt to incorporate dirty + # stuff from the user's working tree. That would be mad. commit_quilty_patch(); } } + if ($do_split_brain) { + $made_split_brain = 1; + $dgithead = splitbrain_pseudomerge($clogp, + $actualhead, $dgithead, + $archive_hash); + $maintviewhead = $actualhead; + changedir $maindir; + prep_ud(); # so _only_subdir() works, below + } if (defined $overwrite_version && !defined $maintviewhead && $archive_hash) { @@ -4459,6 +4565,8 @@ END } } + confess unless !!$made_split_brain == !!$do_split_brain; + changedir $playground; progress f_ "checking that %s corresponds to HEAD", $dscfn; runcmd qw(dpkg-source -x --), @@ -4472,7 +4580,7 @@ END my $r = system @diffcmd; if ($r) { if ($r==256) { - my $referent = $split_brain ? $dgithead : 'HEAD'; + my $referent = $made_split_brain ? $dgithead : 'HEAD'; my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead; my @mode_changes; @@ -4872,6 +4980,7 @@ sub prep_push () { parseopts(); build_or_push_prep_early(); pushing(); + build_or_push_prep_modes(); check_not_dirty(); my $specsuite; if (@ARGV==0) { @@ -4915,11 +5024,11 @@ sub pre_remote_push_build_host { $we_are_responder = 1; $us .= " (build host)"; - open PI, "<&STDIN" or confess $!; - open STDIN, "/dev/null" or confess $!; - open PO, ">&STDOUT" or confess $!; + open PI, "<&STDIN" or confess "$!"; + open STDIN, "/dev/null" or confess "$!"; + open PO, ">&STDOUT" or confess "$!"; autoflush PO 1; - open STDOUT, ">&STDERR" or confess $!; + open STDOUT, ">&STDERR" or confess "$!"; autoflush STDOUT 1; $vsnwant //= 1; @@ -5043,7 +5152,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; - confess $! unless $got == $pid; + confess "$!" unless $got == $pid; fail f_ "build host child failed: %s", waitstatusmsg() if $?; i_cleanup(); @@ -5092,14 +5201,14 @@ sub i_resp_want ($) { fail f_ "rpush negotiated protocol version %s". " which does not support quilt mode %s", $protovsn, $quilt_mode - if quiltmode_splitbrain; + if quiltmode_splitbrain && $protovsn < 4; my @localpaths = i_method "i_want", $keyword; printdebug "[[ $keyword @localpaths\n"; foreach my $localpath (@localpaths) { protocol_send_file \*RI, $localpath; } - print RI "files-end\n" or confess $!; + print RI "files-end\n" or confess "$!"; } our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos); @@ -5206,13 +5315,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 <{O2A} & 01)) { # some patches - quiltify_splitbrain_needed(); progress __ "dgit view: creating patches-applied version using gbp pq"; runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import); # gbp pq import creates a fresh branch; push back to dgit-view @@ -5369,7 +5471,6 @@ END } if (($diffbits->{O2H} & 02) && # user has modified .gitignore !($diffbits->{O2A} & 02)) { # patches do not change .gitignore - quiltify_splitbrain_needed(); progress __ "dgit view: creating patch to represent .gitignore changes"; ensuredir "debian/patches"; @@ -5394,12 +5495,12 @@ ENDU close GIPATCH or die "$gipatch: $!"; runcmd shell_cmd "exec >>$gipatch", @git, qw(diff), $unapplied, $headref, "--", sort keys %$editedignores; - open SERIES, "+>>", "debian/patches/series" or confess $!; - defined seek SERIES, -1, 2 or $!==EINVAL or confess $!; + open SERIES, "+>>", "debian/patches/series" or confess "$!"; + defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!"; my $newline; - defined read SERIES, $newline, 1 or confess $!; - print SERIES "\n" or confess $! unless $newline eq "\n"; - print SERIES "auto-gitignore\n" or confess $!; + 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 +(__ <{'single-debian-patch'} - && branch_is_gdr($headref)) { - # This is much faster. It also makes patches that gdr - # likes better for future updates without laundering. - # - # However, it can fail in some casses where we would - # succeed: if there are existing patches, which correspond - # to a prefix of the branch, but are not in gbp/gdr - # format, gdr will fail (exiting status 7), but we might - # be able to figure out where to start linearising. That - # will be slower so hopefully there's not much to do. - my @cmd = (@git_debrebase, - qw(--noop-ok -funclean-mixed -funclean-ordering - make-patches --quiet-would-amend)); - # We tolerate soe snags that gdr wouldn't, by default. - if (act_local()) { - debugcmd "+",@cmd; - $!=0; $?=-1; - failedcmd @cmd - if system @cmd - and not ($? == 7*256 or - $? == -1 && $!==ENOENT); - } else { - dryrun_report @cmd; - } - $headref = git_rev_parse('HEAD'); - } + my $upstreamversion = upstreamversion $version; prep_ud(); changedir $playground; - my $upstreamversion = upstreamversion $version; + my $splitbrain_cachekey; + + if ($do_split_brain) { + my $cachehit; + ($cachehit, $splitbrain_cachekey) = + quilt_check_splitbrain_cache($headref, $upstreamversion); + if ($cachehit) { + changedir $maindir; + return; + } + } + + unpack_playtree_need_cd_work($headref); + if ($do_split_brain) { + runcmd @git, qw(checkout -q -b dgit-view); + # so long as work is not deleted, its current branch will + # remain dgit-view, rather than master, so subsequent calls to + # unpack_playtree_need_cd_work + # will DTRT, resetting dgit-view. + confess if $made_split_brain; + $made_split_brain = 1; + } + chdir '..'; if ($fopts->{'single-debian-patch'}) { + fail f_ + "quilt mode %s does not make sense (or is not supported) with single-debian-patch", + $quilt_mode + if quiltmode_splitbrain(); quilt_fixup_singlepatch($clogp, $headref, $upstreamversion); } else { - quilt_fixup_multipatch($clogp, $headref, $upstreamversion); + quilt_fixup_multipatch($clogp, $headref, $upstreamversion, + $splitbrain_cachekey); } changedir $maindir; @@ -5766,12 +5859,29 @@ END @git, qw(pull --ff-only -q), "$playground/work", qw(master); } -sub unpack_playtree_mkwork ($) { +sub build_check_quilt_splitbrain () { + build_maybe_quilt_fixup(); + + if ($do_split_brain) { + fail <($leafname); my $bpd_abs = bpd_abs(); + + dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 }; + opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!"; - while ($!=0, defined(my $b = readdir QFD)) { - my $f = bpd_abs()."/".$b; + while ($!=0, defined(my $leaf = readdir QFD)) { + my $f = bpd_abs()."/".$leaf; { local ($debuglevel) = $debuglevel-1; - printdebug "QF linkorigs $b, $f ?\n"; + printdebug "QF linkorigs bpd $leaf, $f ?\n"; } - next unless is_orig_file_of_vsn $b, $upstreamversion; - printdebug "QF linkorigs $b, $f Y\n"; - link_ltarget $f, $b or die "$b $!"; - $fn->($b); + next unless is_orig_file_of_vsn $leaf, $upstreamversion; + printdebug "QF linkorigs $leaf, $f Y\n"; + link_ltarget $f, $leaf or die "$leaf $!"; + $fn->($leaf); } die "$buildproductsdir: $!" if $!; closedir QFD; @@ -5817,7 +5930,7 @@ sub quilt_fixup_singlepatch ($$$) { # necessary to build the source package. unpack_playtree_linkorigs($upstreamversion, sub { }); - unpack_playtree_mkwork($headref); + unpack_playtree_need_cd_work($headref); rmtree("debian/patches"); @@ -5833,13 +5946,18 @@ sub quilt_fixup_singlepatch ($$$) { commit_quilty_patch(); } -sub quilt_make_fake_dsc ($) { +sub quilt_need_fake_dsc ($) { + # cwd should be playground my ($upstreamversion) = @_; + return if stat_exists "fake.dsc"; + # ^ OK to test this as a sentinel because if we created it + # we must either have done the rest too, or crashed. + my $fakeversion="$upstreamversion-~~DGITFAKE"; - my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!; - print $fakedsc <' or confess "$!"; + print $fakedsc <addfile($fh); - print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!; + print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!"; }; unpack_playtree_linkorigs($upstreamversion, $dscaddfile); @@ -5873,14 +5991,15 @@ END runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files; $dscaddfile->($debtar); - close $fakedsc or confess $!; + close $fakedsc or confess "$!"; } sub quilt_fakedsc2unapplied ($$) { my ($headref, $upstreamversion) = @_; # must be run in the playground - # quilt_make_fake_dsc must have been called + # quilt_need_fake_dsc must have been called + quilt_need_fake_dsc($upstreamversion); runcmd qw(sh -ec), 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null'; @@ -5908,6 +6027,8 @@ sub quilt_check_splitbrain_cache ($$) { # Computes the cache key and looks in the cache. # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) + quilt_need_fake_dsc($upstreamversion); + my $splitbrain_cachekey; progress f_ @@ -5939,12 +6060,12 @@ sub quilt_check_splitbrain_cache ($$) { "refs/$splitbraincache", $splitbrain_cachekey; if ($cachehit) { - unpack_playtree_mkwork($headref); + unpack_playtree_need_cd_work($headref); my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit"; if ($cachehit ne $headref) { progress f_ "dgit view: found cached (%s)", $saved; runcmd @git, qw(checkout -q -b dgit-view), $cachehit; - $split_brain = 1; + $made_split_brain = 1; return ($cachehit, $splitbrain_cachekey); } progress __ "dgit view: found cached, no changes required"; @@ -5956,7 +6077,7 @@ sub quilt_check_splitbrain_cache ($$) { } sub quilt_fixup_multipatch ($$$) { - my ($clogp, $headref, $upstreamversion) = @_; + my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_; progress f_ "examining quilt state (multiple patches, %s mode)", $quilt_mode; @@ -6030,16 +6151,39 @@ sub quilt_fixup_multipatch ($$$) { # afterwards with dpkg-source --before-build. That lets us save a # tree object corresponding to .origs. - my $splitbrain_cachekey; + if ($quilt_mode eq 'linear' + && branch_is_gdr($headref)) { + # This is much faster. It also makes patches that gdr + # likes better for future updates without laundering. + # + # However, it can fail in some casses where we would + # succeed: if there are existing patches, which correspond + # to a prefix of the branch, but are not in gbp/gdr + # format, gdr will fail (exiting status 7), but we might + # be able to figure out where to start linearising. That + # will be slower so hopefully there's not much to do. - quilt_make_fake_dsc($upstreamversion); + unpack_playtree_need_cd_work $headref; - if (quiltmode_splitbrain()) { - my $cachehit; - ($cachehit, $splitbrain_cachekey) = - quilt_check_splitbrain_cache($headref, $upstreamversion); - return if $cachehit; + my @cmd = (@git_debrebase, + qw(--noop-ok -funclean-mixed -funclean-ordering + make-patches --quiet-would-amend)); + # We tolerate soe snags that gdr wouldn't, by default. + if (act_local()) { + debugcmd "+",@cmd; + $!=0; $?=-1; + failedcmd @cmd + if system @cmd + and not ($? == 7*256 or + $? == -1 && $!==ENOENT); + } else { + dryrun_report @cmd; + } + $headref = git_rev_parse('HEAD'); + + chdir '..'; } + my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion); ensuredir '.pc'; @@ -6058,7 +6202,7 @@ END changedir '..'; - unpack_playtree_mkwork($headref); + unpack_playtree_need_cd_work($headref); my $mustdeletepc=0; if (stat_exists ".pc") { @@ -6066,7 +6210,7 @@ END progress __ "Tree already contains .pc - will use it then delete it."; $mustdeletepc=1; } else { - rename '../fake/.pc','.pc' or confess $!; + rename '../fake/.pc','.pc' or confess "$!"; } changedir '../fake'; @@ -6092,9 +6236,9 @@ END }; my @dl; - foreach my $b (qw(01 02)) { + foreach my $bits (qw(01 02)) { foreach my $v (qw(O2H O2A H2A)) { - push @dl, ($diffbits->{$v} & $b) ? '##' : '=='; + push @dl, ($diffbits->{$v} & $bits) ? '##' : '=='; } } printdebug "differences \@dl @dl.\n"; @@ -6146,7 +6290,7 @@ END quiltify($clogp,$headref,$oldtiptree,\@failsuggestion); if (!open P, '>>', ".pc/applied-patches") { - $!==&ENOENT or confess $!; + $!==&ENOENT or confess "$!"; } else { close P; } @@ -6165,21 +6309,21 @@ sub quilt_fixup_editor () { 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 $!; + while () { print O or confess "$!"; } I1->error and confess "$!"; my $copying = 0; while () { $copying ||= m/^\-\-\- /; next unless $copying; - print O or confess $!; + print O or confess "$!"; } - I2->error and confess $!; + 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 __ <{Filename}; + # We transfer all the pieces of the dsc to the bpd, not just + # origs. This is by analogy with dgit fetch, which wants to + # keep them somewhere to avoid downloading them again. + # We make symlinks, though. If the user wants copies, then + # they can copy the parts of the dsc to the bpd using dcmd, + # or something. my $here = "$buildproductsdir/$f"; if (lstat $here) { - next if stat $here; + if (stat $here) { + next; + } fail f_ "lstat %s works but stat gives %s !", $here, $!; } fail f_ "stat %s: %s", $here, $! unless $! == ENOENT; + printdebug "not in bpd, $f ...\n"; + # $f does not exist in bpd, we need to transfer it my $there = $dscfn; - if ($dscfn =~ m#^(?:\./+)?\.\./+#) { - $there = $'; - } elsif ($dscfn =~ m#^/#) { - $there = $dscfn; + $there =~ s{[^/]+$}{$f} or confess "$there ?"; + # $there is file we want, relative to user's cwd, or abs + printdebug "not in bpd, $f, test $there ...\n"; + stat $there or fail f_ + "import %s requires %s, but: %s", $dscfn, $there, $!; + if ($there =~ m#^(?:\./+)?\.\./+#) { + # $there is relative to user's cwd + my $there_from_parent = $'; + if ($buildproductsdir !~ m{^/}) { + # abs2rel, despite its name, can take two relative paths + $there = File::Spec->abs2rel($there,$buildproductsdir); + # now $there is relative to bpd, great + printdebug "not in bpd, $f, abs2rel, $there ...\n"; + } else { + $there = (dirname $maindir)."/$there_from_parent"; + # now $there is absoute + printdebug "not in bpd, $f, rel2rel, $there ...\n"; + } + } elsif ($there =~ m#^/#) { + # $there is absolute already + printdebug "not in bpd, $f, abs, $there ...\n"; } else { fail f_ "cannot import %s which seems to be inside working tree!", $dscfn; } - $there =~ s#/+[^/]+$## or fail f_ - "import %s requires .../%s, but it does not exist", - $dscfn, $f; - $there .= "/$f"; - my $test = $there =~ m{^/} ? $there : "../$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; @@ -7025,7 +7205,7 @@ sub cmd_print_dgit_repos_server_source_url { "no arguments allowed to dgit print-dgit-repos-server-source-url" if @ARGV; my $url = repos_server_url(); - print $url, "\n" or confess $!; + print $url, "\n" or confess "$!"; } sub pre_print_dpkg_source_ignores { @@ -7035,7 +7215,7 @@ sub cmd_print_dpkg_source_ignores { badusage __ "no arguments allowed to dgit print-dpkg-source-ignores" if @ARGV; - print "@dpkg_source_ignores\n" or confess $!; + print "@dpkg_source_ignores\n" or confess "$!"; } sub cmd_setup_mergechangelogs { @@ -7066,7 +7246,7 @@ sub cmd_setup_new_tree { #---------- argument parsing and main program ---------- sub cmd_version { - print "dgit version $our_version\n" or confess $!; + print "dgit version $our_version\n" or confess "$!"; finish 0; } @@ -7190,6 +7370,12 @@ sub parseopts () { ($om = $opts_opt_map{$1})) { push @ropts, $_; push @$om, $2; + } elsif (m/^--([-0-9a-z]+)\!:(.*)/s && + !$opts_opt_cmdonly{$1} && + ($om = $opts_opt_map{$1})) { + push @ropts, $_; + my $cmd = shift @$om; + @$om = ($cmd, grep { $_ ne $2 } @$om); } elsif (m/^--(gbp|dpm)$/s) { push @ropts, "--quilt=$1"; $quilt_mode = $1; @@ -7279,12 +7465,11 @@ sub parseopts () { } elsif (s/^-wn$//s) { push @ropts, $&; $cleanmode = 'none'; - } elsif (s/^-wg$//s) { + } elsif (s/^-wg(f?)(a?)$//s) { push @ropts, $&; $cleanmode = 'git'; - } elsif (s/^-wgf$//s) { - push @ropts, $&; - $cleanmode = 'git-ff'; + $cleanmode .= '-ff' if $1; + $cleanmode .= ',always' if $2; } elsif (s/^-wd(d?)([na]?)$//s) { push @ropts, $&; $cleanmode = 'dpkg-source'; @@ -7318,7 +7503,7 @@ sub parseopts () { sub check_env_sanity () { my $blocked = new POSIX::SigSet; - sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!; + sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!"; eval { foreach my $name (qw(PIPE CHLD)) { @@ -7399,9 +7584,6 @@ sub parseopts_late_defaults () { $$vr = $v; } - fail __ "dgit: --include-dirty is not supported in split view quilt mode" - if $split_brain && $includedirty; - if (!defined $cleanmode) { local $access_forpush; $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF'); @@ -7435,7 +7617,7 @@ 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 confess $!; + print STDERR __ $helpmsg or confess "$!"; finish 8; } $cmd = $subcommand = shift @ARGV;