X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=45eef630367ae6a1ba7d4fa6ab1b5255671f2515;hp=ce858ab98057bd770095ecf2b16b8e322e126922;hb=66a602dbe193353842441bc9ef49be8f9f565620;hpb=4880bd4da0a8e79a6cfb7697dc737e1e0e1caca2 diff --git a/dgit b/dgit index ce858ab9..7a4b391a 100755 --- a/dgit +++ b/dgit @@ -34,12 +34,15 @@ use POSIX; use IPC::Open2; use Digest::SHA; use Digest::MD5; +use List::Util qw(any); +use List::MoreUtils qw(pairwise); +use Carp; use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### -our @rpushprotovsn_support = qw(3 2); +our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; our $isuite = 'unstable'; @@ -59,15 +62,27 @@ our %previously; our $existing_package = 'dpkg'; our $cleanmode; our $changes_since_version; +our $rmchanges; +our $overwrite_version; # undef: not specified; '': check changelog our $quilt_mode; -our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck'; +our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied'; our $we_are_responder; our $initiator_tempdir; +our $patches_applied_dirtily = 00; +our $tagformat_want; +our $tagformat; +our $tagformatfn; our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)"); our $suite_re = '[-+.0-9a-z]+'; our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none'; +our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?'; +our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)'; +our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?"; + +our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$'; +our $splitbraincache = 'dgit-intern/quilt-cache'; our (@git) = qw(git); our (@dget) = qw(dget); @@ -75,13 +90,15 @@ our (@curl) = qw(curl -f); our (@dput) = qw(dput); our (@debsign) = qw(debsign); our (@gpg) = qw(gpg); -our (@sbuild) = qw(sbuild -A); +our (@sbuild) = qw(sbuild); our (@ssh) = 'ssh'; our (@dgit) = qw(dgit); our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git); our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git); our (@dpkggenchanges) = qw(dpkg-genchanges); our (@mergechanges) = qw(mergechanges -f); +our (@gbp_build) = (''); +our (@gbp_pq) = ('gbp pq'); our (@changesopts) = (''); our %opts_opt_map = ('dget' => \@dget, # accept for compatibility @@ -96,6 +113,8 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'dpkg-source' => \@dpkgsource, 'dpkg-buildpackage' => \@dpkgbuildpackage, 'dpkg-genchanges' => \@dpkggenchanges, + 'gbp-build' => \@gbp_build, + 'gbp-pq' => \@gbp_pq, 'ch' => \@changesopts, 'mergechanges' => \@mergechanges); @@ -112,6 +131,8 @@ our $keyid; autoflush STDOUT 1; our $supplementary_message = ''; +our $need_split_build_invocation = 0; +our $split_brain = 0; END { local ($@, $?); @@ -123,6 +144,19 @@ our @ourdscfield = qw(Dgit Vcs-Dgit-Master); our $csuite; our $instead_distro; +sub debiantag ($$) { + my ($v,$distro) = @_; + return $tagformatfn->($v, $distro); +} + +sub debiantag_maintview ($$) { + my ($v,$distro) = @_; + $v =~ y/~:/_%/; + return "$distro/$v"; +} + +sub madformat ($) { $_[0] eq '3.0 (quilt)' } + sub lbranch () { return "$branchprefix/$csuite"; } my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$'; sub lref () { return "refs/heads/".lbranch(); } @@ -130,6 +164,28 @@ sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); } sub rrref () { return server_ref($csuite); } sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; } +sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); } + +# We fetch some parts of lrfetchrefs/*. Ideally we delete these +# locally fetched refs because they have unhelpful names and clutter +# up gitk etc. So we track whether we have "used up" head ref (ie, +# whether we have made another local ref which refers to this object). +# +# (If we deleted them unconditionally, then we might end up +# re-fetching the same git objects each time dgit fetch was run.) +# +# So, leach use of lrfetchrefs needs to be accompanied by arrangements +# in git_fetch_us to fetch the refs in question, and possibly a call +# to lrfetchref_used. + +our (%lrfetchrefs_f, %lrfetchrefs_d); +# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid + +sub lrfetchref_used ($) { + my ($fullrefname) = @_; + my $objid = $lrfetchrefs_f{$fullrefname}; + $lrfetchrefs_d{$fullrefname} = $objid if defined $objid; +} sub stripepoch ($) { my ($vsn) = @_; @@ -147,6 +203,11 @@ sub dscfn ($) { return srcfn($vsn,".dsc"); } +sub changespat ($;$) { + my ($vsn, $arch) = @_; + return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; +} + our $us = 'dgit'; initdebug(''); @@ -155,7 +216,7 @@ END { local ($?); foreach my $f (@end) { eval { $f->(); }; - warn "$us: cleanup: $@" if length $@; + print STDERR "$us: cleanup: $@" if length $@; } }; @@ -166,15 +227,10 @@ sub no_such_package () { exit 4; } -sub fetchspec () { - local $csuite = '*'; - return "+".rrref().":".lrref(); -} - sub changedir ($) { my ($newdir) = @_; printdebug "CD $newdir\n"; - chdir $newdir or die "chdir: $newdir: $!"; + chdir $newdir or confess "chdir: $newdir: $!"; } sub deliberately ($) { @@ -188,6 +244,21 @@ sub deliberately_not_fast_forward () { } } +sub quiltmode_splitbrain () { + $quilt_mode =~ m/gbp|dpm|unapplied/; +} + +sub opts_opt_multi_cmd { + my @cmd; + push @cmd, split /\s+/, shift @_; + push @cmd, @_; + @cmd; +} + +sub gbp_pq { + return opts_opt_multi_cmd @gbp_pq; +} + #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: @@ -195,6 +266,16 @@ sub deliberately_not_fast_forward () { # where is ,... ... # < dgit-remote-push-ready # +# occasionally: +# +# > progress NBYTES +# [NBYTES message] +# +# > supplementary-message NBYTES # $protovsn >= 3 +# [NBYTES message] +# +# main sequence: +# # > file parsed-changelog # [indicates that output of dpkg-parsechangelog follows] # > data-block NBYTES @@ -208,7 +289,13 @@ sub deliberately_not_fast_forward () { # > file changes # [etc] # -# > param head HEAD +# > param head DGIT-VIEW-HEAD +# > param csuite SUITE +# > param tagformat old|new +# > param maint-view MAINT-VIEW-HEAD +# +# > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward +# # goes into tag, for replay prevention # # > want signed-tag # [indicates that signed tag is wanted] @@ -380,7 +467,7 @@ our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); sub runcmd { debugcmd "+",@_; - $!=0; $?=0; + $!=0; $?=-1; failedcmd @_ if system @_; } @@ -464,10 +551,17 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.ssh' => 'ssh', 'dgit.default.archive-query' => 'madison:', 'dgit.default.sshpsql-dbname' => 'service=projectb', + 'dgit.default.dgit-tag-format' => 'old,new,maint', + # old means "repo server accepts pushes with old dgit tags" + # new means "repo server accepts pushes with new dgit tags" + # maint means "repo server accepts split brain pushes" + # hist means "repo server may have old pushes without new tag" + # ("hist" is implied by "old") '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.dgit-tag-format' => 'new', 'dgit-distro.debian/push.git-url' => '', 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', 'dgit-distro.debian/push.git-user-force' => 'dgit', @@ -506,36 +600,49 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.test-dummy.upload-host' => 'test-dummy', ); -our %gitcfg; +our %gitcfgs; +our @gitcfgsources = qw(cmdline local global system); sub git_slurp_config () { local ($debuglevel) = $debuglevel-2; local $/="\0"; - my @cmd = (@git, qw(config -z --get-regexp .*)); - debugcmd "|",@cmd; - - open GITS, "-|", @cmd or failedcmd @cmd; - while () { - chomp or die; - printdebug "=> ", (messagequote $_), "\n"; - m/\n/ or die "$_ ?"; - push @{ $gitcfg{$`} }, $'; #'; + # This algoritm is a bit subtle, but this is needed so that for + # options which we want to be single-valued, we allow the + # different config sources to override properly. See #835858. + foreach my $src (@gitcfgsources) { + next if $src eq 'cmdline'; + # we do this ourselves since git doesn't handle it + + my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*)); + debugcmd "|",@cmd; + + open GITS, "-|", @cmd or die $!; + while () { + chomp or die; + printdebug "=> ", (messagequote $_), "\n"; + m/\n/ or die "$_ ?"; + push @{ $gitcfgs{$src}{$`} }, $'; #'; + } + $!=0; $?=0; + close GITS + or ($!==0 && $?==256) + or failedcmd @cmd; } - $!=0; $?=0; - close GITS - or ($!==0 && $?==256) - or failedcmd @cmd; } sub git_get_config ($) { my ($c) = @_; - my $l = $gitcfg{$c}; - printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n" - if $debuglevel >= 4; - $l or return undef; - @$l==1 or badcfg "multiple values for $c" if @$l > 1; - return $l->[0]; + foreach my $src (@gitcfgsources) { + my $l = $gitcfgs{$src}{$c}; + printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n" + if $debuglevel >= 4; + $l or next; + @$l==1 or badcfg "multiple values for $c". + " (in $src git config)" if @$l > 1; + return $l->[0]; + } + return undef; } sub cfg { @@ -796,11 +903,11 @@ sub getfield ($$) { my ($dctrl,$field) = @_; my $v = $dctrl->{$field}; return $v if defined $v; - fail "missing field $field in ".$v->get_option('name'); + fail "missing field $field in ".$dctrl->get_option('name'); } sub parsechangelog { - my $c = Dpkg::Control::Hash->new(); + my $c = Dpkg::Control::Hash->new(name => 'parsed changelog'); my $p = new IO::Handle; my @cmd = (qw(dpkg-parsechangelog), @_); open $p, '-|', @cmd or die $!; @@ -809,6 +916,19 @@ sub parsechangelog { return $c; } +sub commit_getclogp ($) { + # Returns the parsed changelog hashref for a particular commit + my ($objid) = @_; + our %commit_getclogp_memo; + my $memo = $commit_getclogp_memo{$objid}; + return $memo if $memo; + mkpath '.git/dgit'; + my $mclog = ".git/dgit/clog-$objid"; + runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob), + "$objid:debian/changelog"; + $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog"); +} + sub must_getcwd () { my $d = getcwd(); defined $d or fail "getcwd failed: $!"; @@ -1089,6 +1209,48 @@ sub archive_query_dummycat ($$) { return sort { -version_compare($a->[0],$b->[0]); } @rows; } +#---------- tag format handling ---------- + +sub access_cfg_tagformats () { + split /\,/, access_cfg('dgit-tag-format'); +} + +sub need_tagformat ($$) { + my ($fmt, $why) = @_; + fail "need to use tag format $fmt ($why) but also need". + " to use tag format $tagformat_want->[0] ($tagformat_want->[1])". + " - no way to proceed" + if $tagformat_want && $tagformat_want->[0] ne $fmt; + $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0]; +} + +sub select_tagformat () { + # sets $tagformatfn + return if $tagformatfn && !$tagformat_want; + die 'bug' if $tagformatfn && $tagformat_want; + # ... $tagformat_want assigned after previous select_tagformat + + my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats(); + printdebug "select_tagformat supported @supported\n"; + + $tagformat_want //= [ $supported[0], "distro access configuration", 0 ]; + printdebug "select_tagformat specified @$tagformat_want\n"; + + my ($fmt,$why,$override) = @$tagformat_want; + + fail "target distro supports tag formats @supported". + " but have to use $fmt ($why)" + unless $override + or grep { $_ eq $fmt } @supported; + + $tagformat_want = undef; + $tagformat = $fmt; + $tagformatfn = ${*::}{"debiantag_$fmt"}; + + fail "trying to use unknown tag format \`$fmt' ($why) !" + unless $tagformatfn; +} + #---------- archive query entrypoints and rest of program ---------- sub canonicalise_suite () { @@ -1126,9 +1288,11 @@ sub get_archive_dsc () { my $fmt = getfield $dsc, 'Format'; fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt}; $dsc_checked = !!$digester; + printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n"; return; } $dsc = undef; + printdebug "get_archive_dsc: nothing in archive, returning undef\n"; } sub check_for_git (); @@ -1142,7 +1306,7 @@ sub check_for_git () { " set -e; cd ".access_cfg('git-path').";". " if test -d $package.git; then echo 1; else echo 0; fi"); my $r= cmdoutput @cmd; - if ($r =~ m/^divert (\w+)$/) { + if (defined $r and $r =~ m/^divert (\w+)$/) { my $divert=$1; my ($usedistro,) = access_distros(); # NB that if we are pushing, $usedistro will be $distro/push @@ -1151,7 +1315,7 @@ sub check_for_git () { progress "diverting to $divert (using config for $instead_distro)"; return check_for_git(); } - failedcmd @cmd unless $r =~ m/^[01]$/; + failedcmd @cmd unless defined $r and $r =~ m/^[01]$/; return $r+0; } elsif ($how eq 'url') { my $prefix = access_cfg('git-check-url','git-url'); @@ -1198,18 +1362,21 @@ sub create_remote_git_repo () { } } -our ($dsc_hash,$lastpush_hash); +our ($dsc_hash,$lastpush_mergeinput); our $ud = '.git/dgit/unpack'; -sub prep_ud () { - rmtree($ud); +sub prep_ud (;$) { + my ($d) = @_; + $d //= $ud; + rmtree($d); mkpath '.git/dgit'; - mkdir $ud or die $!; + mkdir $d or die $!; } sub mktree_in_ud_here () { runcmd qw(git init -q); + runcmd qw(git config gc.auto 0); rmtree('.git/objects'); symlink '../../../../objects','.git/objects' or die $!; } @@ -1223,7 +1390,7 @@ sub git_write_tree () { sub remove_stray_gits () { my @gitscmd = qw(find -name .git -prune -print0); debugcmd "|",@gitscmd; - open GITS, "-|", @gitscmd or failedcmd @gitscmd; + open GITS, "-|", @gitscmd or die $!; { local $/="\0"; while () { @@ -1236,29 +1403,37 @@ sub remove_stray_gits () { $!=0; $?=0; close GITS or failedcmd @gitscmd; } -sub mktree_in_ud_from_only_subdir () { +sub mktree_in_ud_from_only_subdir (;$) { + my ($raw) = @_; + # changes into the subdir my (@dirs) = <*/.>; - die unless @dirs==1; + die "expected one subdir but found @dirs ?" unless @dirs==1; $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; remove_stray_gits(); mktree_in_ud_here(); - my ($format, $fopts) = get_source_format(); - if (madformat($format)) { - rmtree '.pc'; + if (!$raw) { + my ($format, $fopts) = get_source_format(); + if (madformat($format)) { + rmtree '.pc'; + } } + runcmd @git, qw(add -Af); my $tree=git_write_tree(); return ($tree,$dir); } +our @files_csum_info_fields = + (['Checksums-Sha256','Digest::SHA', 'new(256)'], + ['Checksums-Sha1', 'Digest::SHA', 'new(1)'], + ['Files', 'Digest::MD5', 'new()']); + sub dsc_files_info () { - foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'], - ['Checksums-Sha1', 'Digest::SHA', 'new(1)'], - ['Files', 'Digest::MD5', 'new()']) { + foreach my $csumi (@files_csum_info_fields) { my ($fname, $module, $method) = @$csumi; my $field = $dsc->{$fname}; next unless defined $field; @@ -1286,12 +1461,79 @@ sub dsc_files () { map { $_->{Filename} } dsc_files_info(); } -sub is_orig_file ($;$) { - local ($_) = $_[0]; - my $base = $_[1]; - m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0; - defined $base or return 1; - return $` eq $base; +sub files_compare_inputs (@) { + my $inputs = \@_; + my %record; + my %fchecked; + + my $showinputs = sub { + return join "; ", map { $_->get_option('name') } @$inputs; + }; + + foreach my $in (@$inputs) { + my $expected_files; + my $in_name = $in->get_option('name'); + + printdebug "files_compare_inputs $in_name\n"; + + foreach my $csumi (@files_csum_info_fields) { + my ($fname) = @$csumi; + printdebug "files_compare_inputs $in_name $fname\n"; + + my $field = $in->{$fname}; + next unless defined $field; + + my @files; + foreach (split /\n/, $field) { + next unless m/\S/; + + my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or + fail "could not parse $in_name $fname line \`$_'"; + + printdebug "files_compare_inputs $in_name $fname $f\n"; + + push @files, $f; + + my $re = \ $record{$f}{$fname}; + if (defined $$re) { + $fchecked{$f}{$in_name} = 1; + $$re eq $info or + fail "hash or size of $f varies in $fname fields". + " (between: ".$showinputs->().")"; + } else { + $$re = $info; + } + } + @files = sort @files; + $expected_files //= \@files; + "@$expected_files" eq "@files" or + fail "file list in $in_name varies between hash fields!"; + } + $expected_files or + fail "$in_name has no files list field(s)"; + } + printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record) + if $debuglevel>=2; + + grep { keys %$_ == @$inputs-1 } values %fchecked + or fail "no file appears in all file lists". + " (looked in: ".$showinputs->().")"; +} + +sub is_orig_file_in_dsc ($$) { + my ($f, $dsc_files_info) = @_; + return 0 if @$dsc_files_info <= 1; + # One file means no origs, and the filename doesn't have a "what + # part of dsc" component. (Consider versions ending `.orig'.) + return 0 unless $f =~ m/\.$orig_f_tail_re$/o; + return 1; +} + +sub is_orig_file_of_vsn ($$) { + my ($f, $upstreamvsn) = @_; + my $base = srcfn $upstreamvsn, ''; + return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/; + return 1; } sub make_commit ($) { @@ -1299,15 +1541,38 @@ sub make_commit ($) { return cmdoutput @git, qw(hash-object -w -t commit), $file; } +sub make_commit_text ($) { + my ($text) = @_; + my ($out, $in); + my @cmd = (@git, qw(hash-object -w -t commit --stdin)); + debugcmd "|",@cmd; + print Dumper($text) if $debuglevel > 1; + my $child = open2($out, $in, @cmd) or die $!; + my $h; + eval { + print $in $text or die $!; + close $in or die $!; + $h = <$out>; + $h =~ m/^\w+$/ or die; + $h = $&; + printdebug "=> $h\n"; + }; + close $out; + waitpid $child, 0 == $child or die "$child $!"; + $? and failedcmd @cmd; + return $h; +} + sub clogp_authline ($) { my ($clogp) = @_; my $author = getfield $clogp, 'Maintainer'; $author =~ s#,.*##ms; my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date'); my $authline = "$author $date"; - $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or + $authline =~ m/$git_authline_re/o or fail "unexpected commit author line format \`$authline'". " (was generated from changelog Maintainer field)"; + return ($1,$2,$3) if wantarray; return $authline; } @@ -1374,11 +1639,14 @@ sub check_for_vendor_patches () { "distro being accessed"); } -sub generate_commit_from_dsc () { +sub generate_commits_from_dsc () { + # See big comment in fetch_from_archive, below. + # See also README.dsc-import. prep_ud(); changedir $ud; - foreach my $fi (dsc_files_info()) { + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { my $f = $fi->{Filename}; die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#; @@ -1389,82 +1657,338 @@ sub generate_commit_from_dsc () { complete_file_from_dsc('.', $fi) or next; - if (is_orig_file($f)) { + if (is_orig_file_in_dsc($f, \@dfi)) { link $f, "../../../../$f" or $!==&EEXIST or die "$f $!"; } } + # We unpack and record the orig tarballs first, so that we only + # need disk space for one private copy of the unpacked source. + # But we can't make them into commits until we have the metadata + # from the debian/changelog, so we record the tree objects now and + # make them into commits later. + my @tartrees; + my $upstreamv = $dsc->{version}; + $upstreamv =~ s/-[^-]+$//; + my $orig_f_base = srcfn $upstreamv, ''; + + foreach my $fi (@dfi) { + # We actually import, and record as a commit, every tarball + # (unless there is only one file, in which case there seems + # little point. + + my $f = $fi->{Filename}; + printdebug "import considering $f "; + (printdebug "only one dfi\n"), next if @dfi == 1; + (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/; + (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o; + my $compr_ext = $1; + + my ($orig_f_part) = + $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/; + + printdebug "Y ", (join ' ', map { $_//"(none)" } + $compr_ext, $orig_f_part + ), "\n"; + + my $input = new IO::File $f, '<' or die "$f $!"; + my $compr_pid; + my @compr_cmd; + + if (defined $compr_ext) { + my $cname = + Dpkg::Compression::compression_guess_from_filename $f; + fail "Dpkg::Compression cannot handle file $f in source package" + if defined $compr_ext && !defined $cname; + my $compr_proc = + new Dpkg::Compression::Process compression => $cname; + my @compr_cmd = $compr_proc->get_uncompress_cmdline(); + my $compr_fh = new IO::Handle; + my $compr_pid = open $compr_fh, "-|" // die $!; + if (!$compr_pid) { + open STDIN, "<&", $input or die $!; + exec @compr_cmd; + die "dgit (child): exec $compr_cmd[0]: $!\n"; + } + $input = $compr_fh; + } + + rmtree "../unpack-tar"; + mkdir "../unpack-tar" or die $!; + my @tarcmd = qw(tar -x -f - + --no-same-owner --no-same-permissions + --no-acls --no-xattrs --no-selinux); + my $tar_pid = fork // die $!; + if (!$tar_pid) { + chdir "../unpack-tar" or die $!; + open STDIN, "<&", $input or die $!; + exec @tarcmd; + die "dgit (child): exec $tarcmd[0]: $!"; + } + $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!; + !$? or failedcmd @tarcmd; + + close $input or + (@compr_cmd ? failedcmd @compr_cmd + : die $!); + # finally, we have the results in "tarball", but maybe + # with the wrong permissions + + runcmd qw(chmod -R +rwX ../unpack-tar); + changedir "../unpack-tar"; + my ($tree) = mktree_in_ud_from_only_subdir(1); + changedir "../../unpack"; + rmtree "../unpack-tar"; + + my $ent = [ $f, $tree ]; + push @tartrees, { + Orig => !!$orig_f_part, + Sort => (!$orig_f_part ? 2 : + $orig_f_part =~ m/-/g ? 1 : + 0), + F => $f, + Tree => $tree, + }; + } + + @tartrees = sort { + # put any without "_" first (spec is not clear whether files + # are always in the usual order). Tarballs without "_" are + # the main orig or the debian tarball. + $a->{Sort} <=> $b->{Sort} or + $a->{F} cmp $b->{F} + } @tartrees; + + my $any_orig = grep { $_->{Orig} } @tartrees; + my $dscfn = "$package.dsc"; + my $treeimporthow = 'package'; + open D, ">", $dscfn or die "$dscfn: $!"; print D $dscdata or die "$dscfn: $!"; close D or die "$dscfn: $!"; my @cmd = qw(dpkg-source); push @cmd, '--no-check' if $dsc_checked; + if (madformat $dsc->{format}) { + push @cmd, '--skip-patches'; + $treeimporthow = 'unpatched'; + } push @cmd, qw(-x --), $dscfn; runcmd @cmd; my ($tree,$dir) = mktree_in_ud_from_only_subdir(); - check_for_vendor_patches() if madformat($dsc->{format}); - runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp'; - my $clogp = parsecontrol('../changelog.tmp',"commit's changelog"); + if (madformat $dsc->{format}) { + check_for_vendor_patches(); + } + + my $dappliedtree; + if (madformat $dsc->{format}) { + my @pcmd = qw(dpkg-source --before-build .); + runcmd shell_cmd 'exec >/dev/null', @pcmd; + rmtree '.pc'; + runcmd @git, qw(add -Af); + $dappliedtree = git_write_tree(); + } + + my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all); + debugcmd "|",@clogcmd; + open CLOGS, "-|", @clogcmd or die $!; + + my $clogp; + my $r1clogp; + + printdebug "import clog search...\n"; + + for (;;) { + my $stanzatext = do { local $/=""; ; }; + printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1; + last if !defined $stanzatext; + + my $desc = "package changelog, entry no.$."; + open my $stanzafh, "<", \$stanzatext or die; + my $thisstanza = parsecontrolfh $stanzafh, $desc, 1; + $clogp //= $thisstanza; + + printdebug "import clog $thisstanza->{version} $desc...\n"; + + last if !$any_orig; # we don't need $r1clogp + + # We look for the first (most recent) changelog entry whose + # version number is lower than the upstream version of this + # package. Then the last (least recent) previous changelog + # entry is treated as the one which introduced this upstream + # version and used for the synthetic commits for the upstream + # tarballs. + + # One might think that a more sophisticated algorithm would be + # necessary. But: we do not want to scan the whole changelog + # file. Stopping when we see an earlier version, which + # necessarily then is an earlier upstream version, is the only + # realistic way to do that. Then, either the earliest + # changelog entry we have seen so far is indeed the earliest + # upload of this upstream version; or there are only changelog + # entries relating to later upstream versions (which is not + # possible unless the changelog and .dsc disagree about the + # version). Then it remains to choose between the physically + # last entry in the file, and the one with the lowest version + # number. If these are not the same, we guess that the + # versions were created in a non-monotic order rather than + # that the changelog entries have been misordered. + + printdebug "import clog $thisstanza->{version} vs $upstreamv...\n"; + + last if version_compare($thisstanza->{version}, $upstreamv) < 0; + $r1clogp = $thisstanza; + + printdebug "import clog $r1clogp->{version} becomes r1\n"; + } + die $! if CLOGS->error; + close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd; + + $clogp or fail "package changelog has no entries!"; + my $authline = clogp_authline $clogp; my $changes = getfield $clogp, 'Changes'; + my $cversion = getfield $clogp, 'Version'; + + if (@tartrees) { + $r1clogp //= $clogp; # maybe there's only one entry; + my $r1authline = clogp_authline $r1clogp; + # Strictly, r1authline might now be wrong if it's going to be + # unused because !$any_orig. Whatever. + + printdebug "import tartrees authline $authline\n"; + printdebug "import tartrees r1authline $r1authline\n"; + + foreach my $tt (@tartrees) { + printdebug "import tartree $tt->{F} $tt->{Tree}\n"; + + $tt->{Commit} = make_commit_text($tt->{Orig} ? <{Tree} +author $r1authline +committer $r1authline + +Import $tt->{F} + +[dgit import orig $tt->{F}] +END_O +tree $tt->{Tree} +author $authline +committer $authline + +Import $tt->{F} + +[dgit import tarball $package $cversion $tt->{F}] +END_T + } + } + + printdebug "import main commit\n"; + open C, ">../commit.tmp" or die $!; print C <{Commit} +END + print C <{format}) { + printdebug "import apply patches...\n"; + + # regularise the state of the working tree so that + # the checkout of $rawimport_hash works nicely. + my $dappliedcommit = make_commit_text(</dev/null 2>../../gbp-pq-output', + gbp_pq, qw(import); + }; + if ($@) { + { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; } + die $@; + } + + my $gapplied = git_rev_parse('HEAD'); + my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:); + $gappliedtree eq $dappliedtree or + fail <>../changelogold.tmp'; - my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); + + my $rawimport_mergeinput = { + Commit => $rawimport_hash, + Info => "Import of source package", + }; + my @output = ($rawimport_mergeinput); + + if ($lastpush_mergeinput) { + my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput); my $oversion = getfield $oldclogp, 'Version'; my $vcmp = version_compare($oversion, $cversion); if ($vcmp < 0) { - # git upload/ is earlier vsn than archive, use archive - open C, ">../commit2.tmp" or die $!; - print C < < 1 }); Record $package ($cversion) in archive suite $csuite END - $outputhash = make_commit qw(../commit2.tmp); } elsif ($vcmp > 0) { print STDERR <{Filename}; - next unless is_orig_file($f); + next unless is_orig_file_in_dsc($f, \@dfi); complete_file_from_dsc('..', $fi) or next; } } sub git_fetch_us () { - my @specs = (fetchspec()); - push @specs, - map { "+refs/$_/*:".lrfetchrefs."/$_/*" } - qw(tags heads); - runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs; + # Want to fetch only what we are going to use, unless + # deliberately-not-ff, in which case we must fetch everything. + + my @specs = deliberately_not_fast_forward ? qw(tags/*) : + map { "tags/$_" } + (quiltmode_splitbrain + ? (map { $_->('*',access_basedistro) } + \&debiantag_new, \&debiantag_maintview) + : debiantags('*',access_basedistro)); + push @specs, server_branch($csuite); + push @specs, qw(heads/*) if deliberately_not_fast_forward; + + # This is rather miserable: + # When git-fetch --prune is passed a fetchspec ending with a *, + # it does a plausible thing. If there is no * then: + # - it matches subpaths too, even if the supplied refspec + # starts refs, and behaves completely madly if the source + # has refs/refs/something. (See, for example, Debian #NNNN.) + # - if there is no matching remote ref, it bombs out the whole + # fetch. + # We want to fetch a fixed ref, and we don't know in advance + # if it exists, so this is not suitable. + # + # Our workaround is to use git-ls-remote. git-ls-remote has its + # own qairks. Notably, it has the absurd multi-tail-matching + # behaviour: git-ls-remote R refs/foo can report refs/foo AND + # refs/refs/foo etc. + # + # Also, we want an idempotent snapshot, but we have to make two + # calls to the remote: one to git-ls-remote and to git-fetch. The + # solution is use git-ls-remote to obtain a target state, and + # git-fetch to try to generate it. If we don't manage to generate + # the target state, we try again. + + my $specre = join '|', map { + my $x = $_; + $x =~ s/\W/\\$&/g; + $x =~ s/\\\*$/.*/; + "(?:refs/$x)"; + } @specs; + printdebug "git_fetch_us specre=$specre\n"; + my $wanted_rref = sub { + local ($_) = @_; + return m/^(?:$specre)$/o; + }; + + my $fetch_iteration = 0; + FETCH_ITERATION: + for (;;) { + if (++$fetch_iteration > 10) { + fail "too many iterations trying to get sane fetch!"; + } + + my @look = map { "refs/$_" } @specs; + my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look); + debugcmd "|",@lcmd; + + my %wantr; + open GITLS, "-|", @lcmd or die $!; + while () { + printdebug "=> ", $_; + m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; + my ($objid,$rrefname) = ($1,$2); + if (!$wanted_rref->($rrefname)) { + print STDERR <($rrefname)) { + printdebug <'; + my $want = $wantr{$rrefname}; + next if $got eq $want; + if (!defined $objgot{$want}) { + print STDERR <{Clogp} exists and returns it + my ($mi) = @_; + $mi->{Clogp} = commit_getclogp($mi->{Commit}); +} + +sub mergeinfo_version ($) { + return getfield( (mergeinfo_getclogp $_[0]), 'Version' ); +} + sub fetch_from_archive () { - # ensures that lrref() is what is actually in the archive, - # one way or another + ensure_setup_existing_tree(); + + # Ensures that lrref() is what is actually in the archive, one way + # or another, according to us - ie this client's + # appropritaely-updated archive view. Also returns the commit id. + # If there is nothing in the archive, leaves lrref alone and + # returns undef. git_fetch_us must have already been called. get_archive_dsc(); if ($dsc) { @@ -1563,35 +2236,164 @@ sub fetch_from_archive () { progress "no version available from the archive"; } - $lastpush_hash = git_get_ref(lrref()); + # If the archive's .dsc has a Dgit field, there are three + # relevant git commitids we need to choose between and/or merge + # together: + # 1. $dsc_hash: the Dgit field from the archive + # 2. $lastpush_hash: the suite branch on the dgit git server + # 3. $lastfetch_hash: our local tracking brach for the suite + # + # These may all be distinct and need not be in any fast forward + # relationship: + # + # If the dsc was pushed to this suite, then the server suite + # branch will have been updated; but it might have been pushed to + # a different suite and copied by the archive. Conversely a more + # recent version may have been pushed with dgit but not appeared + # in the archive (yet). + # + # $lastfetch_hash may be awkward because archive imports + # (particularly, imports of Dgit-less .dscs) are performed only as + # needed on individual clients, so different clients may perform a + # different subset of them - and these imports are only made + # public during push. So $lastfetch_hash may represent a set of + # imports different to a subsequent upload by a different dgit + # client. + # + # Our approach is as follows: + # + # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a + # descendant of $dsc_hash, then it was pushed by a dgit user who + # had based their work on $dsc_hash, so we should prefer it. + # Otherwise, $dsc_hash was installed into this suite in the + # archive other than by a dgit push, and (necessarily) after the + # last dgit push into that suite (since a dgit push would have + # been descended from the dgit server git branch); thus, in that + # case, we prefer the archive's version (and produce a + # pseudo-merge to overwrite the dgit server git branch). + # + # (If there is no Dgit field in the archive's .dsc then + # generate_commit_from_dsc uses the version numbers to decide + # whether the suite branch or the archive is newer. If the suite + # branch is newer it ignores the archive's .dsc; otherwise it + # generates an import of the .dsc, and produces a pseudo-merge to + # overwrite the suite branch with the archive contents.) + # + # The outcome of that part of the algorithm is the `public view', + # and is same for all dgit clients: it does not depend on any + # unpublished history in the local tracking branch. + # + # As between the public view and the local tracking branch: The + # local tracking branch is only updated by dgit fetch, and + # whenever dgit fetch runs it includes the public view in the + # local tracking branch. Therefore if the public view is not + # descended from the local tracking branch, the local tracking + # branch must contain history which was imported from the archive + # but never pushed; and, its tip is now out of date. So, we make + # a pseudo-merge to overwrite the old imports and stitch the old + # history in. + # + # Finally: we do not necessarily reify the public view (as + # described above). This is so that we do not end up stacking two + # pseudo-merges. So what we actually do is figure out the inputs + # to any public view pseudo-merge and put them in @mergeinputs. + + my @mergeinputs; + # $mergeinputs[]{Commit} + # $mergeinputs[]{Info} + # $mergeinputs[0] is the one whose tree we use + # @mergeinputs is in the order we use in the actual commit) + # + # Also: + # $mergeinputs[]{Message} is a commit message to use + # $mergeinputs[]{ReverseParents} if def specifies that parent + # list should be in opposite order + # Such an entry has no Commit or Info. It applies only when found + # in the last entry. (This ugliness is to support making + # identical imports to previous dgit versions.) + + my $lastpush_hash = git_get_ref(lrfetchref()); printdebug "previous reference hash=$lastpush_hash\n"; - my $hash; + $lastpush_mergeinput = $lastpush_hash && { + Commit => $lastpush_hash, + Info => "dgit suite branch on dgit git server", + }; + + my $lastfetch_hash = git_get_ref(lrref()); + printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n"; + my $lastfetch_mergeinput = $lastfetch_hash && { + Commit => $lastfetch_hash, + Info => "dgit client's archive history view", + }; + + my $dsc_mergeinput = $dsc_hash && { + Commit => $dsc_hash, + Info => "Dgit field in .dsc from archive", + }; + + my $cwd = getcwd(); + my $del_lrfetchrefs = sub { + changedir $cwd; + my $gur; + printdebug "del_lrfetchrefs...\n"; + foreach my $fullrefname (sort keys %lrfetchrefs_d) { + my $objid = $lrfetchrefs_d{$fullrefname}; + printdebug "del_lrfetchrefs: $objid $fullrefname\n"; + if (!$gur) { + $gur ||= new IO::Handle; + open $gur, "|-", qw(git update-ref --stdin) or die $!; + } + printf $gur "delete %s %s\n", $fullrefname, $objid; + } + if ($gur) { + close $gur or failedcmd "git update-ref delete lrfetchrefs"; + } + }; + if (defined $dsc_hash) { fail "missing remote git history even though dsc has hash -". - " could not find ref ".lrref(). - " (should have been fetched from ".access_giturl()."#".rrref().")" + " could not find ref ".rref()." at ".access_giturl() unless $lastpush_hash; - $hash = $dsc_hash; ensure_we_have_orig(); if ($dsc_hash eq $lastpush_hash) { + @mergeinputs = $dsc_mergeinput } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) { print STDERR <{Commit}; + $h and is_fast_fwd($lastfetch_hash, $h); + # If true, one of the existing parents of this commit + # is a descendant of the $lastfetch_hash, so we'll + # be ff from that automatically. + } @mergeinputs + ) { + # Otherwise: + push @mergeinputs, $lastfetch_mergeinput; + } + + printdebug "fetch mergeinfos:\n"; + foreach my $mi (@mergeinputs) { + if ($mi->{Info}) { + printdebug " commit $mi->{Commit} $mi->{Info}\n"; + } else { + printdebug sprintf " ReverseParents=%d Message=%s", + $mi->{ReverseParents}, $mi->{Message}; + } + } + + my $compat_info= pop @mergeinputs + if $mergeinputs[$#mergeinputs]{Message}; + + @mergeinputs = grep { defined $_->{Commit} } @mergeinputs; + + my $hash; + if (@mergeinputs > 1) { + # here we go, then: + my $tree_commit = $mergeinputs[0]{Commit}; + + my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit; + $tree =~ m/\n\n/; $tree = $`; + $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?"; + $tree = $1; + + # We use the changelog author of the package in question the + # author of this pseudo-merge. This is (roughly) correct if + # this commit is simply representing aa non-dgit upload. + # (Roughly because it does not record sponsorship - but we + # don't have sponsorship info because that's in the .changes, + # which isn't in the archivw.) + # + # But, it might be that we are representing archive history + # updates (including in-archive copies). These are not really + # the responsibility of the person who created the .dsc, but + # there is no-one whose name we should better use. (The + # author of the .dsc-named commit is clearly worse.) + + my $useclogp = mergeinfo_getclogp $mergeinputs[0]; + my $author = clogp_authline $useclogp; + my $cversion = getfield $useclogp, 'Version'; + + my $mcf = ".git/dgit/mergecommit"; + open MC, ">", $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 $!; + } else { + print MC <{Info} + or die $!; + }; + + $message_add_info->($mergeinputs[0]); + print MC <($_) foreach @mergeinputs[1..$#mergeinputs]; + } + + close MC or die $!; + $hash = make_commit $mcf; + } else { + $hash = $mergeinputs[0]{Commit}; } + printdebug "fetch hash=$hash\n"; + + my $chkff = sub { + my ($lasth, $what) = @_; + return unless $lasth; + die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash); + }; + + $chkff->($lastpush_hash, 'dgit repo server tip (last push)'); + $chkff->($lastfetch_hash, 'local tracking tip (last fetch)'); + + runcmd @git, qw(update-ref -m), "dgit fetch $csuite", + 'DGIT_ARCHIVE', $hash; + cmdoutput @git, qw(log -n2), $hash; + # ... gives git a chance to complain if our commit is malformed + if (defined $skew_warning_vsn) { mkpath '.git/dgit'; printdebug "SKEW CHECK WANT $skew_warning_vsn\n"; - my $clogf = ".git/dgit/changelog.tmp"; - runcmd shell_cmd "exec >$clogf", - @git, qw(cat-file blob), "$hash:debian/changelog"; - my $gotclogp = parsechangelog("-l$clogf"); + my $gotclogp = commit_getclogp($hash); my $got_vsn = getfield $gotclogp, 'Version'; printdebug "SKEW CHECK GOT $got_vsn\n"; if (version_compare($got_vsn, $skew_warning_vsn) < 0) { @@ -1635,7 +2546,8 @@ We were able to obtain only $got_vsn END } } - if ($lastpush_hash ne $hash) { + + if ($lastfetch_hash ne $hash) { my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash); if (act_local()) { cmdoutput @upd_cmd; @@ -1643,7 +2555,11 @@ END dryrun_report @upd_cmd; } } - return 1; + + lrfetchref_used lrfetchref(); + + unshift @end, $del_lrfetchrefs; + return $hash; } sub set_local_git_config ($$) { @@ -1696,6 +2612,13 @@ sub setup_useremail (;$) { $setup->('name', 'DEBFULLNAME'); } +sub ensure_setup_existing_tree () { + my $k = "remote.$remotename.skipdefaultupdate"; + my $c = git_get_config $k; + return if defined $c; + set_local_git_config $k, 'true'; +} + sub setup_new_tree () { setup_mergechangelogs(); setup_useremail(); @@ -1706,12 +2629,11 @@ sub clone ($) { canonicalise_suite(); badusage "dry run makes no sense with clone" unless act_local(); my $hasgit = check_for_git(); - mkdir $dstdir or die "$dstdir $!"; + mkdir $dstdir or fail "create \`$dstdir': $!"; changedir $dstdir; runcmd @git, qw(init -q); my $giturl = access_giturl(1); if (defined $giturl) { - set_local_git_config "remote.$remotename.fetch", fetchspec(); open H, "> .git/HEAD" or die $!; print H "ref: ".lref()."\n" or die $!; close H or die $!; @@ -1751,20 +2673,23 @@ sub pull () { } sub check_not_dirty () { + foreach my $f (qw(local-options local-patch-header)) { + if (stat_exists "debian/source/$f") { + fail "git tree contains debian/source/$f"; + } + } + return if $ignoredirty; + my @cmd = (@git, qw(diff --quiet HEAD)); debugcmd "+",@cmd; - $!=0; $?=0; system @cmd; - return if !$! && !$?; - if (!$! && $?==256) { + $!=0; $?=-1; system @cmd; + return if !$?; + if ($?==256) { fail "working tree is dirty (does not match HEAD)"; } else { failedcmd @cmd; } - - if (stat_exists "debian/source/local-options") { - fail "git tree contains debian/source/local-options"; - } } sub commit_admin ($) { @@ -1789,7 +2714,11 @@ sub commit_quilty_patch () { } my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds; runcmd_ordryrun_local @git, qw(add -f), @adds; - commit_admin "Commit Debian 3.0 (quilt) metadata"; + commit_admin <[0] eq $y->[0] or fail <[1] ($x->[0]) not equal to $y->[1] ($y->[0]) +END +}; + +sub infopair_lrf_tag_lookup ($$) { + my ($tagnames, $what) = @_; + # $tagname may be an array ref + my @tagnames = ref $tagnames ? @$tagnames : ($tagnames); + printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n"; + foreach my $tagname (@tagnames) { + my $lrefname = lrfetchrefs."/tags/$tagname"; + my $tagobj = $lrfetchrefs_f{$lrefname}; + next unless defined $tagobj; + printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n"; + return [ git_rev_parse($tagobj), $what ]; + } + fail @tagnames==1 ? <[0], $desc->[0]) or fail <[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward +END +}; + +sub pseudomerge_version_check ($$) { + my ($clogp, $archive_hash) = @_; + + my $arch_clogp = commit_getclogp $archive_hash; + my $i_arch_v = [ (getfield $arch_clogp, 'Version'), + 'version currently in archive' ]; + if (defined $overwrite_version) { + if (length $overwrite_version) { + infopair_cond_equal([ $overwrite_version, + '--overwrite= version' ], + $i_arch_v); + } else { + my $v = $i_arch_v->[0]; + progress "Checking package changelog for archive version $v ..."; + eval { + my @xa = ("-f$v", "-t$v"); + my $vclogp = parsechangelog @xa; + my $cv = [ (getfield $vclogp, 'Version'), + "Version field from dpkg-parsechangelog @xa" ]; + infopair_cond_equal($i_arch_v, $cv); + }; + if ($@) { + $@ =~ s/^dgit: //gm; + fail "$@". + "Perhaps debian/changelog does not mention $v ?"; + } + } + } + + printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n"; + return $i_arch_v; +} + +sub pseudomerge_make_commit ($$$$ $$) { + my ($clogp, $dgitview, $archive_hash, $i_arch_v, + $msg_cmd, $msg_msg) = @_; + progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]..."; + + my $tree = cmdoutput qw(git rev-parse), "${dgitview}:"; + my $authline = clogp_authline $clogp; + + chomp $msg_msg; + $msg_cmd .= + !defined $overwrite_version ? "" + : !length $overwrite_version ? " --overwrite" + : " --overwrite=".$overwrite_version; + + mkpath '.git/dgit'; + my $pmf = ".git/dgit/pseudomerge"; + open MC, ">", $pmf or die "$pmf $!"; + print MC < $merged_dgitview + printdebug "splitbrain_pseudomerge...\n"; + # + # We: debian/PREVIOUS HEAD($maintview) + # expect: o ----------------- o + # \ \ + # o o + # a/d/PREVIOUS $dgitview + # $archive_hash \ + # If so, \ \ + # we do: `------------------ o + # this: $dgitview' + # + + printdebug "splitbrain_pseudomerge...\n"; + + my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); + + return $dgitview unless defined $archive_hash; + + if (!defined $overwrite_version) { + progress "Checking that HEAD inciudes all changes in archive..."; + } + + return $dgitview if is_fast_fwd $archive_hash, $dgitview; + + my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro; + my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag"); + my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro; + my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag"); + my $i_archive = [ $archive_hash, "current archive contents" ]; + + printdebug "splitbrain_pseudomerge i_archive @$i_archive\n"; + + infopair_cond_equal($i_dgit, $i_archive); + infopair_cond_ff($i_dep14, $i_dgit); + $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]); + + my $r = pseudomerge_make_commit + $clogp, $dgitview, $archive_hash, $i_arch_v, + "dgit --quilt=$quilt_mode", + (defined $overwrite_version ? <[0] +END_MAKEFF + + progress "Made pseudo-merge of $i_arch_v->[0] into dgit view."; + return $r; +} + +sub plain_overwrite_pseudomerge ($$$) { + my ($clogp, $head, $archive_hash) = @_; + + printdebug "plain_overwrite_pseudomerge..."; + + my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); + + my @tagformats = access_cfg_tagformats(); + my @t_overwr = + map { $_->($i_arch_v->[0], access_basedistro) } + (grep { m/^(?:old|hist)$/ } @tagformats) + ? \&debiantags : \&debiantag_new; + my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag"; + my $i_archive = [ $archive_hash, "current archive contents" ]; + + infopair_cond_equal($i_overwr, $i_archive); + + return $head if is_fast_fwd $archive_hash, $head; + + my $m = "Declare fast forward from $i_arch_v->[0]"; + + my $r = pseudomerge_make_commit + $clogp, $head, $archive_hash, $i_arch_v, + "dgit", $m; + + runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head; + + progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD."; + return $r; +} + sub push_parse_changelog ($) { my ($clogpfn) = @_; @@ -1847,7 +2966,7 @@ sub push_parse_changelog ($) { my $dscfn = dscfn($cversion); - return ($clogp, $cversion, $tag, $dscfn); + return ($clogp, $cversion, $dscfn); } sub push_parse_dsc ($$$) { @@ -1860,13 +2979,39 @@ sub push_parse_dsc ($$$) { " but debian/changelog is for $package $cversion"; } -sub push_mktag ($$$$$$$) { - my ($head,$clogp,$tag, - $dscfn, +sub push_tagwants ($$$$) { + my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_; + my @tagwants; + push @tagwants, { + TagFn => \&debiantag, + Objid => $dgithead, + TfSuffix => '', + View => 'dgit', + }; + if (defined $maintviewhead) { + push @tagwants, { + TagFn => \&debiantag_maintview, + Objid => $maintviewhead, + TfSuffix => '-maintview', + View => 'maint', + }; + } + foreach my $tw (@tagwants) { + $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro); + $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; }; + } + printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants); + return @tagwants; +} + +sub push_mktags ($$ $$ $) { + my ($clogp,$dscfn, $changesfile,$changesfilewhat, - $tfn) = @_; + $tagwants) = @_; - $dsc->{$ourdscfield[0]} = $head; + die unless $tagwants->[0]{View} eq 'dgit'; + + $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid}; $dsc->save("$dscfn.tmp") or die $!; my $changes = parsecontrol($changesfile,$changesfilewhat); @@ -1884,45 +3029,66 @@ sub push_mktag ($$$$$$$) { my $authline = clogp_authline $clogp; my $delibs = join(" ", "",@deliberatelies); my $declaredistro = access_basedistro(); - open TO, '>', $tfn->('.tmp') or die $!; - print TO <{Tfn}; + my $head = $tw->{Objid}; + my $tag = $tw->{Tag}; + + open TO, '>', $tfn->('.tmp') or die $!; + print TO <{View} eq 'dgit') { + print TO <{View} eq 'maint') { + print TO <('.tmp'); - if ($sign) { - if (!defined $keyid) { - $keyid = access_cfg('keyid','RETURN-UNDEF'); - } - if (!defined $keyid) { - $keyid = getfield $clogp, 'Maintainer'; - } - unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!; - my @sign_cmd = (@gpg, qw(--detach-sign --armor)); - push @sign_cmd, qw(-u),$keyid if defined $keyid; - push @sign_cmd, $tfn->('.tmp'); - runcmd_ordryrun @sign_cmd; - if (act_scary()) { - $tagobjfn = $tfn->('.signed.tmp'); - runcmd shell_cmd "exec >$tagobjfn", qw(cat --), - $tfn->('.tmp'), $tfn->('.tmp.asc'); + my $tagobjfn = $tfn->('.tmp'); + if ($sign) { + if (!defined $keyid) { + $keyid = access_cfg('keyid','RETURN-UNDEF'); + } + if (!defined $keyid) { + $keyid = getfield $clogp, 'Maintainer'; + } + unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!; + my @sign_cmd = (@gpg, qw(--detach-sign --armor)); + push @sign_cmd, qw(-u),$keyid if defined $keyid; + push @sign_cmd, $tfn->('.tmp'); + runcmd_ordryrun @sign_cmd; + if (act_scary()) { + $tagobjfn = $tfn->('.signed.tmp'); + runcmd shell_cmd "exec >$tagobjfn", qw(cat --), + $tfn->('.tmp'), $tfn->('.tmp.asc'); + } } - } + return $tagobjfn; + }; - return ($tagobjfn); + my @r = map { $mktag->($_); } @$tagwants; + return @r; } sub sign_changes ($) { @@ -1936,23 +3102,42 @@ sub sign_changes ($) { } } -sub dopush ($) { - my ($forceflag) = @_; +sub dopush () { printdebug "actually entering push\n"; + + 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(); + } + my $archive_hash = fetch_from_archive(); + if (!$archive_hash) { + $new_package or + fail "package appears to be new in this suite;". + " if this is intentional, use --new"; + } + supplementary_message(<<'END'); Push failed, while preparing your push. You can retry the push, after fixing the problem, if you like. END + + need_tagformat 'new', "quilt mode $quilt_mode" + if quiltmode_splitbrain; + prep_ud(); access_giturl(); # check that success is vaguely likely + select_tagformat(); my $clogpfn = ".git/dgit/changelog.822.tmp"; runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog); responder_send_file('parsed-changelog', $clogpfn); - my ($clogp, $cversion, $tag, $dscfn) = + my ($clogp, $cversion, $dscfn) = push_parse_changelog("$clogpfn"); my $dscpath = "$buildproductsdir/$dscfn"; @@ -1966,10 +3151,59 @@ END my $format = getfield $dsc, 'Format'; printdebug "format $format\n"; - if (madformat($format)) { - commit_quilty_patch(); + + my $actualhead = git_rev_parse('HEAD'); + my $dgithead = $actualhead; + my $maintviewhead = undef; + + if (madformat_wantfixup($format)) { + # user might have not used dgit build, so maybe do this now: + if (quiltmode_splitbrain()) { + my $upstreamversion = $clogp->{Version}; + $upstreamversion =~ s/-[^-]*$//; + changedir $ud; + quilt_make_fake_dsc($upstreamversion); + my ($dgitview, $cachekey) = + quilt_check_splitbrain_cache($actualhead, $upstreamversion); + $dgitview or fail + "--quilt=$quilt_mode but no cached dgit view: + perhaps tree changed since dgit build[-source] ?"; + $split_brain = 1; + $dgithead = splitbrain_pseudomerge($clogp, + $actualhead, $dgitview, + $archive_hash); + $maintviewhead = $actualhead; + changedir '../../../..'; + prep_ud(); # so _only_subdir() works, below + } else { + commit_quilty_patch(); + } + } + + if (defined $overwrite_version && !defined $maintviewhead) { + $dgithead = plain_overwrite_pseudomerge($clogp, + $dgithead, + $archive_hash); } + check_not_dirty(); + + my $forceflag = ''; + if ($archive_hash) { + if (is_fast_fwd($archive_hash, $dgithead)) { + # ok + } elsif (deliberately_not_fast_forward) { + $forceflag = '+'; + } else { + fail "dgit push: HEAD is not a descendant". + " of the archive's version.\n". + "To overwrite the archive's contents,". + " pass --overwrite[=VERSION].\n". + "To rewind history, if permitted by the archive,". + " use --deliberately-not-fast-forward."; + } + } + changedir $ud; progress "checking that $dscfn corresponds to HEAD"; runcmd qw(dpkg-source -x --), @@ -1977,43 +3211,50 @@ END my ($tree,$dir) = mktree_in_ud_from_only_subdir(); check_for_vendor_patches() if madformat($dsc->{format}); changedir '../../../..'; - my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet'; - my @diffcmd = (@git, qw(diff), $diffopt, $tree); + my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); debugcmd "+",@diffcmd; - $!=0; $?=0; + $!=0; $?=-1; my $r = system @diffcmd; if ($r) { if ($r==256) { - fail "$dscfn specifies a different tree to your HEAD commit;". - " perhaps you forgot to build". - ($diffopt eq '--exit-code' ? "" : - " (run with -D to see full diff output)"); + my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead; + fail <= 4; + responder_send_command("param maint-view $maintviewhead"); + } if (deliberately_not_fast_forward) { git_for_each_ref(lrfetchrefs, sub { @@ -2024,8 +3265,9 @@ END }); } - my $tfn = sub { ".git/dgit/tag$_[0]"; }; - my $tagobjfn; + my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead, + ".git/dgit/tag"); + my @tagobjfns; supplementary_message(<<'END'); Push failed, while signing the tag. @@ -2033,23 +3275,29 @@ 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); + @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants; + responder_receive_files('signed-tag', @tagobjfns); } else { - $tagobjfn = - push_mktag($head,$clogp,$tag, - $dscpath, - $changesfile,$changesfile, - $tfn); + @tagobjfns = push_mktags($clogp,$dscpath, + $changesfile,$changesfile, + \@tagwants); } 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; + pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns; + + foreach my $tw (@tagwants) { + my $tag = $tw->{Tag}; + my $tagobjfn = $tw->{TagObjFn}; + 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. @@ -2058,9 +3306,15 @@ END if (!check_for_git()) { create_remote_git_repo(); } - runcmd_ordryrun @git, qw(push),access_giturl(), - $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag"; - runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD'; + + my @pushrefs = $forceflag.$dgithead.":".rrref(); + foreach my $tw (@tagwants) { + push @pushrefs, $forceflag."refs/tags/$tw->{Tag}"; + } + + runcmd_ordryrun @git, + qw(-c push.followTags=false push), access_giturl(), @pushrefs; + runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead; supplementary_message(<<'END'); Push failed, after updating the remote git repository. @@ -2080,7 +3334,7 @@ END sign_changes $changesfile; } - supplementary_message(<<'END'); + supplementary_message(<= 3; + + fail "rpush negotiated protocol version $protovsn". + " which does not support quilt mode $quilt_mode" + if quiltmode_splitbrain; + + rpush_handle_protovsn_bothends(); for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -2408,13 +3655,13 @@ sub i_resp_want ($) { print RI "files-end\n" or die $!; } -our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn); +our ($i_clogp, $i_version, $i_dscfn, $i_changesfn); sub i_localname_parsed_changelog { return "remote-changelog.822"; } sub i_file_parsed_changelog { - ($i_clogp, $i_version, $i_tag, $i_dscfn) = + ($i_clogp, $i_version, $i_dscfn) = push_parse_changelog "$i_tmp/remote-changelog.822"; die if $i_dscfn =~ m#/|^\W#; } @@ -2441,17 +3688,26 @@ sub i_want_signed_tag { my $head = $i_param{'head'}; die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../; + my $maintview = $i_param{'maint-view'}; + die if defined $maintview && $maintview =~ m/[^0-9a-f]/; + + select_tagformat(); + if ($protovsn >= 4) { + my $p = $i_param{'tagformat'} // ''; + $p eq $tagformat + or badproto \*RO, "tag format mismatch: $p vs. $tagformat"; + } + die unless $i_param{'csuite'} =~ m/^$suite_re$/; $csuite = $&; push_parse_dsc $i_dscfn, 'remote dsc', $i_version; - my $tagobjfn = - push_mktag $head, $i_clogp, $i_tag, - $i_dscfn, - $i_changesfn, 'remote changes', - sub { "tag$_[0]"; }; + my @tagwants = push_tagwants $i_version, $head, $maintview, "tag"; - return $tagobjfn; + return + push_mktags $i_clogp, $i_dscfn, + $i_changesfn, 'remote changes', + \@tagwants; } sub i_want_signed_dsc_changes { @@ -2477,13 +3733,10 @@ sub quiltify_dpkg_commit ($$$;$) { mkpath '.git/dgit'; my $descfn = ".git/dgit/quilt-description.tmp"; open O, '>', $descfn or die "$descfn: $!"; - $msg =~ s/\s+$//g; - $msg =~ s/\n/\n /g; - $msg =~ s/^\s+$/ ./mg; + $msg =~ s/\n+/\n\n/; print O <{$fn} + # is set for each modified .gitignore filename $fn + # if $unrepres is defined, array ref to which is appeneded + # a list of unrepresentable changes (removals of upstream files + # (as messages) local $/=undef; - my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y); + my @cmd = (@git, qw(diff-tree -z)); + push @cmd, qw(--name-only) unless $unrepres; + push @cmd, qw(-r) if $finegrained || $unrepres; + push @cmd, $x, $y; my $diffs= cmdoutput @cmd; + my $r = 0; + my @lmodes; foreach my $f (split /\0/, $diffs) { - next if $f eq 'debian'; - return 1; + if ($unrepres && !@lmodes) { + @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?"; + next; + } + my ($oldmode,$newmode) = @lmodes; + @lmodes = (); + + next if $f =~ m#^debian(?:/.*)?$#s; + + if ($unrepres) { + eval { + die "deleted\n" unless $newmode =~ m/[^0]/; + die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/; + if ($oldmode =~ m/[^0]/) { + die "mode changed\n" if $oldmode ne $newmode; + } else { + die "non-default mode\n" unless $newmode =~ m/^100644$/; + } + }; + if ($@) { + local $/="\n"; chomp $@; + push @$unrepres, [ $f, $@ ]; + } + } + + my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s; + $r |= $isignore ? 02 : 01; + $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore; } - return 0; + printdebug "quiltify_trees_differ $x $y => $r\n"; + return $r; } sub quiltify_tree_sentinelfiles ($) { @@ -2519,8 +3812,120 @@ sub quiltify_tree_sentinelfiles ($) { return $r; } -sub quiltify ($$) { - my ($clogp,$target) = @_; +sub quiltify_splitbrain_needed () { + if (!$split_brain) { + progress "dgit view: changes are required..."; + runcmd @git, qw(checkout -q -b dgit-view); + $split_brain = 1; + } +} + +sub quiltify_splitbrain ($$$$$$) { + my ($clogp, $unapplied, $headref, $diffbits, + $editedignores, $cachekey) = @_; + if ($quilt_mode !~ m/gbp|dpm/) { + # treat .gitignore just like any other upstream file + $diffbits = { %$diffbits }; + $_ = !!$_ foreach values %$diffbits; + } + # We would like any commits we generate to be reproducible + my @authline = clogp_authline($clogp); + local $ENV{GIT_COMMITTER_NAME} = $authline[0]; + local $ENV{GIT_COMMITTER_EMAIL} = $authline[1]; + local $ENV{GIT_COMMITTER_DATE} = $authline[2]; + local $ENV{GIT_AUTHOR_NAME} = $authline[0]; + local $ENV{GIT_AUTHOR_EMAIL} = $authline[1]; + local $ENV{GIT_AUTHOR_DATE} = $authline[2]; + + if ($quilt_mode =~ m/gbp|unapplied/ && + ($diffbits->{O2H} & 01)) { + my $msg = + "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n". + " but git tree differs from orig in upstream files."; + if (!stat_exists "debian/patches") { + $msg .= + "\n ... debian/patches is missing; perhaps this is a patch queue branch?"; + } + fail $msg; + } + if ($quilt_mode =~ m/dpm/ && + ($diffbits->{H2A} & 01)) { + fail <{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 + runcmd @git, qw(update-ref refs/heads/dgit-view HEAD); + runcmd @git, qw(checkout -q dgit-view); + } + if ($quilt_mode =~ m/gbp|dpm/ && + ($diffbits->{O2A} & 02)) { + fail <{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"; + my $gipatch = "debian/patches/auto-gitignore"; + open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!"; + stat GIPATCH or die "$gipatch: $!"; + fail "$gipatch already exists; but want to create it". + " to record .gitignore changes" if (stat _)[7]; + print GIPATCH <>$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 $!; + 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 $!; + close SERIES or die $!; + runcmd @git, qw(add -- debian/patches/series), $gipatch; + commit_admin <>' + or die $!; + runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", + $dgitview; + + progress "dgit view: created (commit id $dgitview)"; + + changedir '.git/dgit/unpack/work'; +} + +sub quiltify ($$$$) { + my ($clogp,$target,$oldtiptree,$failsuggestion) = @_; # Quilt patchification algorithm # @@ -2546,14 +3951,6 @@ sub quiltify ($$) { # After traversing PT, we git commit the changes which # should be contained within debian/patches. - changedir '../fake'; - remove_stray_gits(); - mktree_in_ud_here(); - rmtree '.pc'; - runcmd @git, qw(add -Af .); - my $oldtiptree=git_write_tree(); - changedir '../work'; - # The search for the path S..T is breadth-first. We maintain a # todo list containing search nodes. A search node identifies a # commit, and looks something like this: @@ -2666,6 +4063,7 @@ sub quiltify ($$) { foreach my $notp (@nots) { print STDERR "$us: ", $reportnot->($notp), "\n"; } + print STDERR "$us: $_\n" foreach @$failsuggestion; fail "quilt fixup naive history linearisation failed.\n". "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch"; } elsif ($quilt_mode eq 'smash') { @@ -2675,7 +4073,8 @@ sub quiltify ($$) { die "$quilt_mode ?"; } - my $time = time; + my $time = $ENV{'GIT_COMMITTER_DATE'} || time; + $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE my $ncommits = 3; my $msg = cmdoutput @git, qw(log), "-n$ncommits"; @@ -2703,15 +4102,75 @@ sub quiltify ($$) { $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?"; my $author = $1; + my $commitdate = cmdoutput + @git, qw(log -n1 --pretty=format:%aD), $cc; + $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?"; + my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; }; + $strip_nls->(); + my $title = $1; - my $patchname = $title; - $patchname =~ s/[.:]$//; - $patchname =~ y/ A-Z/-a-z/; - $patchname =~ y/-a-z0-9_.+=~//cd; - $patchname =~ s/^\W/x-$&/; - $patchname = substr($patchname,0,40); + my $patchname; + my $patchdir; + + my $gbp_check_suitable = sub { + $_ = shift; + my ($what) = @_; + + eval { + die "contains unexpected slashes\n" if m{//} || m{/$}; + die "contains leading punctuation\n" if m{^\W} || m{/\W}; + die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i; + die "too long" if length > 200; + }; + return $_ unless $@; + print STDERR "quiltifying commit $cc:". + " ignoring/dropping Gbp-Pq $what: $@"; + return undef; + }; + + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ | + gbp-pq-name: \s* ) + (\S+) \s* \n //ixm) { + $patchname = $gbp_check_suitable->($1, 'Name'); + } + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ | + gbp-pq-topic: \s* ) + (\S+) \s* \n //ixm) { + $patchdir = $gbp_check_suitable->($1, 'Topic'); + } + + $strip_nls->(); + + if (!defined $patchname) { + $patchname = $title; + $patchname =~ s/[.:]$//; + use Text::Iconv; + eval { + my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT); + my $translitname = $converter->convert($patchname); + die unless defined $translitname; + $patchname = $translitname; + }; + print STDERR + "dgit: patch title transliteration error: $@" + if $@; + $patchname =~ y/ A-Z/-a-z/; + $patchname =~ y/-a-z0-9_.+=~//cd; + $patchname =~ s/^\W/x-$&/; + $patchname = substr($patchname,0,40); + } + if (!defined $patchdir) { + $patchdir = ''; + } + if (length $patchdir) { + $patchname = "$patchdir/$patchname"; + } + if ($patchname =~ m{^(.*)/}) { + mkpath "debian/patches/$1"; + } + my $index; for ($index=''; stat "debian/patches/$patchname$index"; @@ -2729,6 +4188,7 @@ sub quiltify ($$) { runcmd @git, qw(checkout -q), $target, qw(debian/changelog); quiltify_dpkg_commit "$patchname$index", $author, $msg, + "Date: $commitdate\n". "X-Dgit-Generated: $clogp->{Version} $cc\n"; runcmd @git, qw(checkout -q), $cc, qw(debian/changelog); @@ -2739,11 +4199,219 @@ sub quiltify ($$) { sub build_maybe_quilt_fixup () { my ($format,$fopts) = get_source_format; - return unless madformat $format; + return unless madformat_wantfixup $format; # sigh check_for_vendor_patches(); + if (quiltmode_splitbrain) { + foreach my $needtf (qw(new maint)) { + next if grep { $_ eq $needtf } access_cfg_tagformats; + fail <{'single-debian-patch'}) { + quilt_fixup_singlepatch($clogp, $headref, $upstreamversion); + } else { + quilt_fixup_multipatch($clogp, $headref, $upstreamversion); + } + + die 'bug' if $split_brain && !$need_split_build_invocation; + + changedir '../../../..'; + runcmd_ordryrun_local + @git, qw(pull --ff-only -q .git/dgit/unpack/work master); +} + +sub quilt_fixup_mkwork ($) { + my ($headref) = @_; + + mkdir "work" or die $!; + changedir "work"; + mktree_in_ud_here(); + runcmd @git, qw(reset -q --hard), $headref; +} + +sub quilt_fixup_linkorigs ($$) { + my ($upstreamversion, $fn) = @_; + # calls $fn->($leafname); + + foreach my $f (<../../../../*>) { #/){ + my $b=$f; $b =~ s{.*/}{}; + { + local ($debuglevel) = $debuglevel-1; + printdebug "QF linkorigs $b, $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); + } +} + +sub quilt_fixup_delete_pc () { + runcmd @git, qw(rm -rqf .pc); + commit_admin <' or die $!; + print $fakedsc <addfile($fh); + print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; + }; + + quilt_fixup_linkorigs($upstreamversion, $dscaddfile); + + my @files=qw(debian/source/format debian/rules + debian/control debian/changelog); + foreach my $maybe (qw(debian/patches debian/source/options + debian/tests/control)) { + next unless stat_exists "../../../$maybe"; + push @files, $maybe; + } + + my $debtar= srcfn $fakeversion,'.debian.tar.gz'; + runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files; + + $dscaddfile->($debtar); + close $fakedsc or die $!; +} + +sub quilt_check_splitbrain_cache ($$) { + my ($headref, $upstreamversion) = @_; + # Called only if we are in (potentially) split brain mode. + # Called in $ud. + # Computes the cache key and looks in the cache. + # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) + + my $splitbrain_cachekey; + + progress + "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode)."; + # we look in the reflog of dgit-intern/quilt-cache + # we look for an entry whose message is the key for the cache lookup + my @cachekey = (qw(dgit), $our_version); + push @cachekey, $upstreamversion; + push @cachekey, $quilt_mode; + push @cachekey, $headref; + + push @cachekey, hashfile('fake.dsc'); + + my $srcshash = Digest::SHA->new(256); + my %sfs = ( %INC, '$0(dgit)' => $0 ); + foreach my $sfk (sort keys %sfs) { + next unless m/^\$0\b/ || m{^Debian/Dgit\b}; + $srcshash->add($sfk," "); + $srcshash->add(hashfile($sfs{$sfk})); + $srcshash->add("\n"); + } + push @cachekey, $srcshash->hexdigest(); + $splitbrain_cachekey = "@cachekey"; + + my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs', + $splitbraincache); + printdebug "splitbrain cachekey $splitbrain_cachekey\n"; + debugcmd "|(probably)",@cmd; + my $child = open GC, "-|"; defined $child or die $!; + if (!$child) { + chdir '../../..' or die $!; + if (!stat ".git/logs/refs/$splitbraincache") { + $! == ENOENT or die $!; + printdebug ">(no reflog)\n"; + exit 0; + } + exec @cmd; die $!; + } + while () { + chomp; + printdebug ">| ", $_, "\n" if $debuglevel > 1; + next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey; + + my $cachehit = $1; + quilt_fixup_mkwork($headref); + if ($cachehit ne $headref) { + progress "dgit view: found cached (commit id $cachehit)"; + runcmd @git, qw(checkout -q -b dgit-view), $cachehit; + $split_brain = 1; + return ($cachehit, $splitbrain_cachekey); + } + progress "dgit view: found cached, no changes required"; + return ($headref, $splitbrain_cachekey); + } + die $! if GC->error; + failedcmd unless close GC; + + printdebug "splitbrain cache miss\n"; + return (undef, $splitbrain_cachekey); +} + +sub quilt_fixup_multipatch ($$$) { + my ($clogp, $headref, $upstreamversion) = @_; + + progress "examining quilt state (multiple patches, $quilt_mode mode)"; + # Our objective is: # - honour any existing .pc in case it has any strangeness # - determine the git commit corresponding to the tip of @@ -2788,66 +4456,76 @@ sub build_maybe_quilt_fixup () { # 5. If we had a .pc in-tree, delete it, and git-commit # 6. Back in the main tree, fast forward to the new HEAD - my $clogp = parsechangelog(); - my $headref = git_rev_parse('HEAD'); + # Another situation we may have to cope with is gbp-style + # patches-unapplied trees. + # + # We would want to detect these, so we know to escape into + # quilt_fixup_gbp. However, this is in general not possible. + # Consider a package with a one patch which the dgit user reverts + # (with git-revert or the moral equivalent). + # + # That is indistinguishable in contents from a patches-unapplied + # tree. And looking at the history to distinguish them is not + # useful because the user might have made a confusing-looking git + # history structure (which ought to produce an error if dgit can't + # cope, not a silent reintroduction of an unwanted patch). + # + # So gbp users will have to pass an option. But we can usually + # detect their failure to do so: if the tree is not a clean + # patches-applied tree, quilt linearisation fails, but the tree + # _is_ a clean patches-unapplied tree, we can suggest that maybe + # they want --quilt=unapplied. + # + # To help detect this, when we are extracting the fake dsc, we + # first extract it with --skip-patches, and then apply the patches + # afterwards with dpkg-source --before-build. That lets us save a + # tree object corresponding to .origs. - prep_ud(); - changedir $ud; + my $splitbrain_cachekey; - my $upstreamversion=$version; - $upstreamversion =~ s/-[^-]*$//; + quilt_make_fake_dsc($upstreamversion); - my $fakeversion="$upstreamversion-~~DGITFAKE"; + if (quiltmode_splitbrain()) { + my $cachehit; + ($cachehit, $splitbrain_cachekey) = + quilt_check_splitbrain_cache($headref, $upstreamversion); + return if $cachehit; + } - my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; - print $fakedsc </dev/null'; - my $dscaddfile=sub { - my ($b) = @_; - - my $md = new Digest::MD5; + my $fakexdir= $package.'-'.(stripepoch $upstreamversion); + rename $fakexdir, "fake" or die "$fakexdir $!"; - my $fh = new IO::File $b, '<' or die "$b $!"; - stat $fh or die $!; - my $size = -s _; + changedir 'fake'; - $md->addfile($fh); - print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; - }; + remove_stray_gits(); + mktree_in_ud_here(); - foreach my $f (<../../../../*>) { #/){ - my $b=$f; $b =~ s{.*/}{}; - next unless is_orig_file $b, srcfn $upstreamversion,''; - link_ltarget $f, $b or die "$b $!"; - $dscaddfile->($b); - } + rmtree '.pc'; - my @files=qw(debian/source/format debian/rules); - foreach my $maybe (qw(debian/patches debian/source/options)) { - next unless stat_exists "../../../$maybe"; - push @files, $maybe; + runcmd @git, qw(add -Af .); + my $unapplied=git_write_tree(); + printdebug "fake orig tree object $unapplied\n"; + + ensuredir '.pc'; + + my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null'); + $!=0; $?=-1; + if (system @bbcmd) { + failedcmd @bbcmd if $? < 0; + fail <($debtar); - close $fakedsc or die $!; - - runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null'; - - my $fakexdir= $package.'-'.(stripepoch $upstreamversion); - rename $fakexdir, "fake" or die "$fakexdir $!"; - - mkdir "work" or die $!; - changedir "work"; - mktree_in_ud_here(); - runcmd @git, qw(reset --hard), $headref; + quilt_fixup_mkwork($headref); my $mustdeletepc=0; if (stat_exists ".pc") { @@ -2858,7 +4536,72 @@ END rename '../fake/.pc','.pc' or die $!; } - quiltify($clogp,$headref); + changedir '../fake'; + rmtree '.pc'; + runcmd @git, qw(add -Af .); + my $oldtiptree=git_write_tree(); + printdebug "fake o+d/p tree object $unapplied\n"; + changedir '../work'; + + + # We calculate some guesswork now about what kind of tree this might + # be. This is mostly for error reporting. + + my %editedignores; + my @unrepres; + my $diffbits = { + # H = user's HEAD + # O = orig, without patches applied + # A = "applied", ie orig with H's debian/patches applied + O2H => quiltify_trees_differ($unapplied,$headref, 1, + \%editedignores, \@unrepres), + H2A => quiltify_trees_differ($headref, $oldtiptree,1), + O2A => quiltify_trees_differ($unapplied,$oldtiptree,1), + }; + + my @dl; + foreach my $b (qw(01 02)) { + foreach my $v (qw(O2H O2A H2A)) { + push @dl, ($diffbits->{$v} & $b) ? '##' : '=='; + } + } + printdebug "differences \@dl @dl.\n"; + + progress sprintf +"$us: base trees orig=%.20s o+d/p=%.20s", + $unapplied, $oldtiptree; + progress sprintf +"$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n". +"$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p", + $dl[0], $dl[1], $dl[3], $dl[4], + $dl[2], $dl[5]; + + if (@unrepres) { + print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n" + foreach @unrepres; + fail <{O2H} & $diffbits->{O2A})) { + push @failsuggestion, "This might be a patches-unapplied branch."; + } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) { + push @failsuggestion, "This might be a patches-applied branch."; + } + push @failsuggestion, "Maybe you need to specify one of". + " --quilt=gbp --quilt=dpm --quilt=unapplied ?"; + + if (quiltmode_splitbrain()) { + quiltify_splitbrain($clogp, $unapplied, $headref, + $diffbits, \%editedignores, + $splitbrain_cachekey); + return; + } + + progress "starting quiltify (multiple patches, $quilt_mode mode)"; + quiltify($clogp,$headref,$oldtiptree,\@failsuggestion); if (!open P, '>>', ".pc/applied-patches") { $!==&ENOENT or die $!; @@ -2869,13 +4612,8 @@ END commit_quilty_patch(); if ($mustdeletepc) { - runcmd @git, qw(rm -rqf .pc); - commit_admin "Commit removal of .pc (quilt series tracking data)"; + quilt_fixup_delete_pc(); } - - changedir '../../../..'; - runcmd_ordryrun_local - @git, qw(pull --ff-only -q .git/dgit/unpack/work master); } sub quilt_fixup_editor () { @@ -2897,15 +4635,45 @@ sub quilt_fixup_editor () { exit 0; } +sub maybe_apply_patches_dirtily () { + return unless $quilt_mode =~ m/gbp|unapplied/; + print STDERR <1; - my @newcmd = shift @$cmd; +#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation); + if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) { + $clean_using_builder = 1; + return 0; + } # -nc has the side effect of specifying -b if nothing else specified - push @newcmd, '-nc'; # and some combinations of -S, -b, et al, are errors, rather than - # later simply overriding earlier - push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } (@$cmd, @$xargs); - push @newcmd, @$cmd; - @$cmd = @newcmd; + # later simply overriding earlie. So we need to: + # - search the command line for these options + # - pick the last one + # - perhaps add our own as a default + # - perhaps adjust it to the corresponding non-source-building version + my $dmode = '-F'; + foreach my $l ($cmd, $xargs) { + next unless $l; + @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l; + } + push @$cmd, '-nc'; +#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode); + my $r = 0; + if ($need_split_build_invocation) { + printdebug "massage split $dmode.\n"; + $r = $dmode =~ m/[S]/ ? +2 : + $dmode =~ y/gGF/ABb/ ? +1 : + $dmode =~ m/[ABb]/ ? 0 : + die "$dmode ?"; + } + printdebug "massage done $r $dmode.\n"; + push @$cmd, $dmode; +#print STDERR "MASS2 ",Dumper($cmd, $xargs, $r); + return $r; } sub cmd_build { my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV); - massage_dbp_args \@dbp; - build_prep(); - push @dbp, changesopts_version(); - runcmd_ordryrun_local @dbp; + my $wantsrc = massage_dbp_args \@dbp; + if ($wantsrc > 0) { + build_source(); + } else { + build_prep(); + } + if ($wantsrc < 2) { + push @dbp, changesopts_version(); + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dbp; + } + maybe_unapply_patches_again(); printdone "build successful\n"; } +sub pre_gbp_build { + $quilt_mode //= 'gbp'; +} + sub cmd_gbp_build { my @dbp = @dpkgbuildpackage; - massage_dbp_args \@dbp, \@ARGV; - my @cmd; - if (length executable_on_path('git-buildpackage')) { - @cmd = qw(git-buildpackage); - } else { - @cmd = qw(gbp buildpackage); + my $wantsrc = massage_dbp_args \@dbp, \@ARGV; + + if (!length $gbp_build[0]) { + if (length executable_on_path('git-buildpackage')) { + $gbp_build[0] = qw(git-buildpackage); + } else { + $gbp_build[0] = 'gbp buildpackage'; + } } + my @cmd = opts_opt_multi_cmd @gbp_build; + push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp"); - if ($cleanmode eq 'dpkg-source') { - $suppress_clean = 1; + if ($wantsrc > 0) { + build_source(); } else { - push @cmd, '--git-cleaner=true'; + if (!$clean_using_builder) { + push @cmd, '--git-cleaner=true'; + } + build_prep(); } - build_prep(); - unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) { - canonicalise_suite(); - push @cmd, "--git-debian-branch=".lbranch(); + maybe_unapply_patches_again(); + if ($wantsrc < 2) { + unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) { + canonicalise_suite(); + push @cmd, "--git-debian-branch=".lbranch(); + } + push @cmd, changesopts(); + runcmd_ordryrun_local @cmd, @ARGV; } - push @cmd, changesopts(); - runcmd_ordryrun_local @cmd, @ARGV; printdone "build successful\n"; } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 sub build_source { - if ($cleanmode =~ m/^dpkg-source/) { - # dpkg-source will clean, so we shouldn't - $suppress_clean = 1; + my $our_cleanmode = $cleanmode; + if ($need_split_build_invocation) { + # Pretend that clean is being done some other way. This + # forces us not to try to use dpkg-buildpackage to clean and + # build source all in one go; and instead we run dpkg-source + # (and build_prep() will do the clean since $clean_using_builder + # is false). + $our_cleanmode = 'ELSEWHERE'; + } + if ($our_cleanmode =~ m/^dpkg-source/) { + # dpkg-source invocation (below) will clean, so build_prep shouldn't + $clean_using_builder = 1; } build_prep(); - $sourcechanges = "${package}_".(stripepoch $version)."_source.changes"; + $sourcechanges = changespat $version,'source'; + if (act_local()) { + unlink "../$sourcechanges" or $!==ENOENT + or fail "remove $sourcechanges: $!"; + } $dscfn = dscfn($version); - if ($cleanmode eq 'dpkg-source') { - runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)), + if ($our_cleanmode eq 'dpkg-source') { + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S), changesopts(); - } elsif ($cleanmode eq 'dpkg-source-d') { - runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)), + } elsif ($our_cleanmode eq 'dpkg-source-d') { + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d), changesopts(); } else { - my $pwd = must_getcwd(); - my $leafdir = basename $pwd; - changedir ".."; - runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir; - changedir $pwd; + my @cmd = (@dpkgsource, qw(-b --)); + if ($split_brain) { + changedir $ud; + runcmd_ordryrun_local @cmd, "work"; + my @udfiles = <${package}_*>; + changedir "../../.."; + foreach my $f (@udfiles) { + printdebug "source copy, found $f\n"; + next unless + $f eq $dscfn or + ($f =~ m/\.debian\.tar(?:\.\w+)$/ && + $f eq srcfn($version, $&)); + printdebug "source copy, found $f - renaming\n"; + rename "$ud/$f", "../$f" or $!==ENOENT + or fail "put in place new source file ($f): $!"; + } + } else { + my $pwd = must_getcwd(); + my $leafdir = basename $pwd; + changedir ".."; + runcmd_ordryrun_local @cmd, $leafdir; + changedir $pwd; + } runcmd_ordryrun_local qw(sh -ec), 'exec >$1; shift; exec "$@"','x', "../$sourcechanges", @@ -3060,35 +4928,52 @@ sub build_source { sub cmd_build_source { badusage "build-source takes no additional arguments" if @ARGV; build_source(); + maybe_unapply_patches_again(); printdone "source built, results in $dscfn and $sourcechanges"; } sub cmd_sbuild { build_source(); + my $pat = changespat $version; + if (!$rmchanges) { + my @unwanted = map { s#^\.\./##; $_; } glob "../$pat"; + @unwanted = grep { $_ ne changespat $version,'source' } @unwanted; + fail "changes files other than source matching $pat". + " already present (@unwanted);". + " building would result in ambiguity about the intended results" + if @unwanted; + } + my $wasdir = must_getcwd(); changedir ".."; - my $pat = "${package}_".(stripepoch $version)."_*.changes"; if (act_local()) { stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; stat_exists $sourcechanges or fail "$sourcechanges (in parent directory): $!"; - foreach my $cf (glob $pat) { - next if $cf eq $sourcechanges; - unlink $cf or fail "remove $cf: $!"; - } } - runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn; + runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn; my @changesfiles = glob $pat; @changesfiles = sort { ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/) or $a cmp $b } @changesfiles; fail "wrong number of different changes files (@changesfiles)" - unless @changesfiles; + unless @changesfiles==2; + my $binchanges = parsecontrol($changesfiles[1], "binary changes file"); + foreach my $l (split /\n/, getfield $binchanges, 'Files') { + fail "$l found in binaries changes file $binchanges" + if $l =~ m/\.dsc$/; + } runcmd_ordryrun_local @mergechanges, @changesfiles; - my $multichanges = "${package}_".(stripepoch $version)."_multi.changes"; + my $multichanges = changespat $version,'multi'; if (act_local()) { stat_exists $multichanges or fail "$multichanges: $!"; + foreach my $cf (glob $pat) { + next if $cf eq $multichanges; + rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!"; + } } + changedir $wasdir; + maybe_unapply_patches_again(); printdone "build successful, results in $multichanges\n" or die $!; } @@ -3097,6 +4982,8 @@ sub cmd_quilt_fixup { my $clogp = parsechangelog(); $version = getfield $clogp, 'Version'; $package = getfield $clogp, 'Source'; + check_not_dirty(); + clean_tree(); build_maybe_quilt_fixup(); } @@ -3161,8 +5048,6 @@ defvalopt '--build-products-dir','','.*', \$buildproductsdir; defvalopt '--clean', '', $cleanmode_re, \$cleanmode; defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode; -defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; }; - defvalopt '', '-C', '.+', sub { ($changesfile) = (@_); if ($changesfile =~ s#^(.*)/##) { @@ -3247,9 +5132,27 @@ sub parseopts () { } elsif (m/^--no-rm-on-error$/s) { push @ropts, $_; $rmonerror = 0; + } elsif (m/^--overwrite$/s) { + push @ropts, $_; + $overwrite_version = ''; + } elsif (m/^--overwrite=(.+)$/s) { + push @ropts, $_; + $overwrite_version = $1; + } elsif (m/^--(no-)?rm-old-changes$/s) { + push @ropts, $_; + $rmchanges = !$1; } elsif (m/^--deliberately-($deliberately_re)$/s) { push @ropts, $_; push @deliberatelies, $&; + } elsif (m/^--dgit-tag-format=(old|new)$/s) { + # undocumented, for testing + push @ropts, $_; + $tagformat_want = [ $1, 'command line', 1 ]; + # 1 menas overrides distro configuration + } elsif (m/^--always-split-source-build$/s) { + # undocumented, for testing + push @ropts, $_; + $need_split_build_invocation = 1; } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) { $val = $2 ? $' : undef; #'; $valopt->($oi->{Long}); @@ -3295,6 +5198,12 @@ sub parseopts () { } elsif (s/^-wc$//s) { push @ropts, $&; $cleanmode = 'check'; + } elsif (s/^-c([^=]*)\=(.*)$//s) { + push @git, '-c', $&; + $gitcfgs{cmdline}{$1} = [ $2 ]; + } elsif (s/^-c([^=]+)$//s) { + push @git, '-c', $&; + $gitcfgs{cmdline}{$1} = [ 'true' ]; } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) { $val = $'; #'; $val = undef unless length $val; @@ -3320,16 +5229,18 @@ sub finalise_opts_opts () { } foreach my $c (access_cfg_cfgs("opts-$k")) { - my $vl = $gitcfg{$c}; - printdebug "CL $c ", - ($vl ? join " ", map { shellquote } @$vl : ""), + my @vl = + map { $_ ? @$_ : () } + map { $gitcfgs{$_}{$c} } + reverse @gitcfgsources; + printdebug "CL $c ", (join " ", map { shellquote } @vl), "\n" if $debuglevel >= 4; - next unless $vl; + next unless @vl; badcfg "cannot configure options for $k" if $opts_opt_cmdonly{$k}; my $insertpos = $opts_cfg_insertpos{$k}; @$om = ( @$om[0..$insertpos-1], - @$vl, + @vl, @$om[$insertpos..$#$om] ); } } @@ -3353,6 +5264,14 @@ if (!@ARGV) { my $cmd = shift @ARGV; $cmd =~ y/-/_/; +my $pre_fn = ${*::}{"pre_$cmd"}; +$pre_fn->() if $pre_fn; + +if (!defined $rmchanges) { + local $access_forpush; + $rmchanges = access_cfg_bool(0, 'rm-old-changes'); +} + if (!defined $quilt_mode) { local $access_forpush; $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF') @@ -3363,6 +5282,8 @@ if (!defined $quilt_mode) { $quilt_mode = $1; } +$need_split_build_invocation ||= quiltmode_splitbrain(); + if (!defined $cleanmode) { local $access_forpush; $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');