X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=8264f3e576a625e37cecb9c30bfe70f3596fd9a4;hp=d3b2ec7ee5cfde2e9c36d05efa6fba4d340a8ef8;hb=14a6daa486a195f465c8049122d20675d6626f07;hpb=140e8c84b7e36eacbf9802c8a04f40eb32ef59ce diff --git a/dgit b/dgit index d3b2ec7e..8264f3e5 100755 --- a/dgit +++ b/dgit @@ -2,7 +2,7 @@ # dgit # Integration between git and Debian-style archives # -# Copyright (C)2013-2015 Ian Jackson +# Copyright (C)2013-2016 Ian Jackson # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -36,10 +36,12 @@ 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 $absurdity = undef; ###substituted### our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; @@ -62,8 +64,10 @@ 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|gbp|unapplied'; +our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied'; +our $split_brain_save; our $we_are_responder; our $initiator_tempdir; our $patches_applied_dirtily = 00; @@ -71,17 +75,27 @@ our $tagformat_want; our $tagformat; our $tagformatfn; +our %forceopts = map { $_=>0 } + qw(unrepresentable unsupported-source-format + dsc-changes-mismatch changes-origs-exactly + import-gitapply-absurd + import-gitapply-no-absurd + import-dsc-with-dgit-field); + 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); -our (@curl) = qw(curl -f); +our (@curl) = qw(curl); our (@dput) = qw(dput); our (@debsign) = qw(debsign); our (@gpg) = qw(gpg); @@ -92,7 +106,8 @@ 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) = qw(gbp); +our (@gbp_build) = (''); +our (@gbp_pq) = ('gbp pq'); our (@changesopts) = (''); our %opts_opt_map = ('dget' => \@dget, # accept for compatibility @@ -107,7 +122,8 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'dpkg-source' => \@dpkgsource, 'dpkg-buildpackage' => \@dpkgbuildpackage, 'dpkg-genchanges' => \@dpkggenchanges, - 'gbp' => \@gbp, + 'gbp-build' => \@gbp_build, + 'gbp-pq' => \@gbp_pq, 'ch' => \@changesopts, 'mergechanges' => \@mergechanges); @@ -137,6 +153,11 @@ our @ourdscfield = qw(Dgit Vcs-Dgit-Master); our $csuite; our $instead_distro; +if (!defined $absurdity) { + $absurdity = $0; + $absurdity =~ s{/[^/]+$}{/absurd} or die; +} + sub debiantag ($$) { my ($v,$distro) = @_; return $tagformatfn->($v, $distro); @@ -148,6 +169,8 @@ sub debiantag_maintview ($$) { 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(); } @@ -157,6 +180,27 @@ 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) = @_; $vsn =~ s/^\d+\://; @@ -178,6 +222,12 @@ sub changespat ($;$) { return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; } +sub upstreamversion ($) { + my ($vsn) = @_; + $vsn =~ s/-[^-]+$//; + return $vsn; +} + our $us = 'dgit'; initdebug(''); @@ -192,6 +242,20 @@ END { sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; } +sub forceable_fail ($$) { + my ($forceoptsl, $msg) = @_; + fail $msg unless grep { $forceopts{$_} } @$forceoptsl; + print STDERR "warning: overriding problem due to --force:\n". $msg; +} + +sub forceing ($) { + my ($forceoptsl) = @_; + my @got = grep { $forceopts{$_} } @$forceoptsl; + return 0 unless @got; + print STDERR + "warning: skipping checks or functionality due to --force-$got[0]\n"; +} + sub no_such_package () { print STDERR "$us: package $package does not exist in suite $isuite\n"; exit 4; @@ -200,7 +264,7 @@ sub no_such_package () { sub changedir ($) { my ($newdir) = @_; printdebug "CD $newdir\n"; - chdir $newdir or die "chdir: $newdir: $!"; + chdir $newdir or confess "chdir: $newdir: $!"; } sub deliberately ($) { @@ -218,6 +282,17 @@ 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: @@ -510,12 +585,16 @@ 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', + 'dgit.default.dgit-tag-format' => 'new,old,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' => 'old', 'dgit-distro.debian/push.git-url' => '', 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', 'dgit-distro.debian/push.git-user-force' => 'dgit', @@ -548,42 +627,55 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.test-dummy.git-url' => "$td/git", 'dgit-distro.test-dummy.git-host' => "git", 'dgit-distro.test-dummy.git-path' => "$td/git", - 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:", + 'dgit-distro.test-dummy.archive-query' => "dummycatapi:", 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/", 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/", '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; + # 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 @{ $gitcfg{$`} }, $'; #'; + 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 { @@ -844,11 +936,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 $!; @@ -857,21 +949,41 @@ 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: $!"; return $d; } +sub parse_dscdata () { + my $dscfh = new IO::File \$dscdata, '<' or die $!; + printdebug Dumper($dscdata) if $debuglevel>1; + $dsc = parsecontrolfh($dscfh,$dscurl,1); + printdebug Dumper($dsc) if $debuglevel>1; +} + our %rmad; -sub archive_query ($) { - my ($method) = @_; +sub archive_query ($;@) { + my ($method) = shift @_; my $query = access_cfg('archive-query','RETURN-UNDEF'); $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'"; my $proto = $1; my $data = $'; #'; - { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); } + { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); } } sub pool_dsc_subpath ($$) { @@ -884,7 +996,7 @@ sub pool_dsc_subpath ($$) { sub archive_api_query_cmd ($) { my ($subpath) = @_; - my @cmd = qw(curl -sS); + my @cmd = (@curl, qw(-sS)); my $url = access_cfg('archive-query-url'); if ($url =~ m#^https://([-.0-9a-z]+)/#) { my $host = $1; @@ -912,17 +1024,27 @@ sub archive_api_query_cmd ($) { return @cmd; } -sub api_query ($$) { +sub api_query ($$;$) { use JSON; - my ($data, $subpath) = @_; + my ($data, $subpath, $ok404) = @_; badcfg "ftpmasterapi archive query method takes no data part" if length $data; my @cmd = archive_api_query_cmd($subpath); + my $url = $cmd[$#cmd]; + push @cmd, qw(-w %{http_code}); my $json = cmdoutput @cmd; + unless ($json =~ s/\d+\d+\d$//) { + failedcmd_report_cmd undef, @cmd; + fail "curl failed to print 3-digit HTTP code"; + } + my $code = $&; + return undef if $code eq '404' && $ok404; + fail "fetch of $url gave HTTP code $code" + unless $url =~ m#^file://# or $code =~ m/^2/; return decode_json($json); } -sub canonicalise_suite_ftpmasterapi () { +sub canonicalise_suite_ftpmasterapi { my ($proto,$data) = @_; my $suites = api_query($data, 'suites'); my @matched; @@ -946,7 +1068,7 @@ sub canonicalise_suite_ftpmasterapi () { return $cn; } -sub archive_query_ftpmasterapi () { +sub archive_query_ftpmasterapi { my ($proto,$data) = @_; my $info = api_query($data, "dsc_in_suite/$isuite/$package"); my @rows; @@ -973,6 +1095,42 @@ sub archive_query_ftpmasterapi () { return @rows; } +sub file_in_archive_ftpmasterapi { + my ($proto,$data,$filename) = @_; + my $pat = $filename; + $pat =~ s/_/\\_/g; + $pat = "%/$pat"; + $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge; + my $info = api_query($data, "file_in_archive/$pat", 1); +} + +#---------- `dummyapicat' archive query method ---------- + +sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; } +sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; } + +sub file_in_archive_dummycatapi ($$$) { + my ($proto,$data,$filename) = @_; + my $mirror = access_cfg('mirror'); + $mirror =~ s#^file://#/# or die "$mirror ?"; + my @out; + my @cmd = (qw(sh -ec), ' + cd "$1" + find -name "$2" -print0 | + xargs -0r sha256sum + ', qw(x), $mirror, $filename); + debugcmd "-|", @cmd; + open FIA, "-|", @cmd or die $!; + while () { + chomp or die; + printdebug "| $_\n"; + m/^(\w+) (\S+)$/ or die "$_ ?"; + push @out, { sha256sum => $1, filename => $2 }; + } + close FIA or die failedcmd @cmd; + return \@out; +} + #---------- `madison' archive query method ---------- sub archive_query_madison { @@ -1021,6 +1179,8 @@ sub canonicalise_suite_madison { return $r[0][2]; } +sub file_in_archive_madison { return undef; } + #---------- `sshpsql' archive query method ---------- sub sshpsql ($$$) { @@ -1096,6 +1256,8 @@ END return $rows[0]; } +sub file_in_archive_sshpsql ($$$) { return undef; } + #---------- `dummycat' archive query method ---------- sub canonicalise_suite_dummycat ($$) { @@ -1137,6 +1299,8 @@ sub archive_query_dummycat ($$) { return sort { -version_compare($a->[0],$b->[0]); } @rows; } +sub file_in_archive_dummycat () { return undef; } + #---------- tag format handling ---------- sub access_cfg_tagformats () { @@ -1158,7 +1322,7 @@ sub select_tagformat () { die 'bug' if $tagformatfn && $tagformat_want; # ... $tagformat_want assigned after previous select_tagformat - my (@supported) = grep { $_ ne 'maint' } access_cfg_tagformats(); + my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats(); printdebug "select_tagformat supported @supported\n"; $tagformat_want //= [ $supported[0], "distro access configuration", 0 ]; @@ -1209,12 +1373,11 @@ sub get_archive_dsc () { fail "$dscurl has hash $got but". " archive told us to expect $digest"; } - my $dscfh = new IO::File \$dscdata, '<' or die $!; - printdebug Dumper($dscdata) if $debuglevel>1; - $dsc = parsecontrolfh($dscfh,$dscurl,1); - printdebug Dumper($dsc) if $debuglevel>1; + parse_dscdata(); my $fmt = getfield $dsc, 'Format'; - fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt}; + $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)], + "unsupported source format $fmt, sorry"; + $dsc_checked = !!$digester; printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n"; return; @@ -1250,7 +1413,7 @@ sub check_for_git () { my $suffix = access_cfg('git-check-suffix','git-suffix', 'RETURN-UNDEF') // '.git'; my $url = "$prefix/$package$suffix"; - my @cmd = (qw(curl -sS -I), $url); + my @cmd = (@curl, qw(-sS -I), $url); my $result = cmdoutput @cmd; $result =~ s/^\S+ 200 .*\n\r?\n//; # curl -sS -I with https_proxy prints @@ -1304,6 +1467,7 @@ sub prep_ud (;$) { 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 $!; } @@ -1330,29 +1494,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 "@dirs ?" 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)', 'sha256sum'], + ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'], + ['Files', 'Digest::MD5', 'new()', 'md5sum']); + 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; @@ -1380,12 +1552,174 @@ 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 changes_update_origs_from_dsc ($$$$) { + my ($dsc, $changes, $upstreamvsn, $changesfile) = @_; + my %changes_f; + printdebug "checking origs needed ($upstreamvsn)...\n"; + $_ = getfield $changes, 'Files'; + m/^\w+ \d+ (\S+ \S+) \S+$/m or + fail "cannot find section/priority from .changes Files field"; + my $placementinfo = $1; + my %changed; + printdebug "checking origs needed placement '$placementinfo'...\n"; + foreach my $l (split /\n/, getfield $dsc, 'Files') { + $l =~ m/\S+$/ or next; + my $file = $&; + printdebug "origs $file | $l\n"; + next unless is_orig_file_of_vsn $file, $upstreamvsn; + printdebug "origs $file is_orig\n"; + my $have = archive_query('file_in_archive', $file); + if (!defined $have) { + print STDERR <{$archivefield}; + $_ = $dsc->{$fname}; + next unless defined; + m/^(\w+) .* \Q$file\E$/m or + fail ".dsc $fname missing entry for $file"; + if ($h->{$archivefield} eq $1) { + $same++; + } else { + push @differ, + "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)"; + } + } + die "$file ".Dumper($h)." ?!" if $same && @differ; + $found_same++ + if $same; + push @found_differ, "archive $h->{filename}: ".join "; ", @differ + if @differ; + } + print "origs $file f.same=$found_same #f._differ=$#found_differ\n"; + if (@found_differ && !$found_same) { + fail join "\n", + "archive contains $file with different checksum", + @found_differ; + } + # Now we edit the changes file to add or remove it + foreach my $csumi (@files_csum_info_fields) { + my ($fname, $module, $method, $archivefield) = @$csumi; + next unless defined $changes->{$fname}; + if ($found_same) { + # in archive, delete from .changes if it's there + $changed{$file} = "removed" if + $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m; + } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) { + # not in archive, but it's here in the .changes + } else { + my $dsc_data = getfield $dsc, $fname; + $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?"; + my $extra = $1; + $extra =~ s/ \d+ /$&$placementinfo / + or die "$fname $extra >$dsc_data< ?" + if $fname eq 'Files'; + $changes->{$fname} .= "\n". $extra; + $changed{$file} = "added"; + } + } + } + if (%changed) { + foreach my $file (keys %changed) { + progress sprintf + "edited .changes for archive .orig contents: %s %s", + $changed{$file}, $file; + } + my $chtmp = "$changesfile.tmp"; + $changes->save($chtmp); + if (act_local()) { + rename $chtmp,$changesfile or die "$changesfile $!"; + } else { + progress "[new .changes left in $changesfile]"; + } + } else { + progress "$changesfile already has appropriate .orig(s) (if any)"; + } } sub make_commit ($) { @@ -1393,6 +1727,28 @@ 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'; @@ -1471,67 +1827,361 @@ sub check_for_vendor_patches () { 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$#; - link_ltarget "../../../$f", $f + printdebug "considering linking $f: "; + + link_ltarget "../../../../$f", $f + or ((printdebug "($!) "), 0) or $!==&ENOENT or die "$f $!"; + printdebug "linked.\n"; + 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 = upstreamversion $dsc->{version}; + 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 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', @showcmd; + debugcmd "+",@realcmd; + if (system @realcmd) { + die +(shellquote @showcmd). + " failed: ". + failedcmd_waitstatus()."\n"; + } + + my $gapplied = git_rev_parse('HEAD'); + my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:); + $gappliedtree eq $dappliedtree or + fail < $rawimport_hash, Info => "Import of source package", }; my @output = ($rawimport_mergeinput); - progress "synthesised git commit from .dsc $cversion"; + if ($lastpush_mergeinput) { - my $lastpush_hash = $lastpush_mergeinput->{Commit}; - runcmd @git, qw(reset -q --hard), $lastpush_hash; - runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp'; - my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); + my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput); my $oversion = getfield $oldclogp, 'Version'; my $vcmp = version_compare($oversion, $cversion); @@ -1549,6 +2199,9 @@ $later_warning_msg END @output = $lastpush_mergeinput; } else { + # Same version. Use what's in the server git branch, + # discarding our own import. (This could happen if the + # server automatically imports all packages into git.) @output = $lastpush_mergeinput; } } @@ -1569,12 +2222,13 @@ sub complete_file_from_dsc ($$) { if (stat_exists $tf) { progress "using existing $f"; } else { + printdebug "$tf does not exist, need to fetch\n"; my $furl = $dscurl; $furl =~ s{/[^/]+$}{}; $furl .= "/$f"; die "$f ?" unless $f =~ m/^\Q${package}\E_/; die "$f ?" if $f =~ m#/#; - runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl"; + runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl"; return 0 if !act_local(); $downloaded = 1; } @@ -1594,19 +2248,157 @@ sub complete_file_from_dsc ($$) { } sub ensure_we_have_orig () { - foreach my $fi (dsc_files_info()) { + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { my $f = $fi->{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 = - map { "+refs/$_/*:".lrfetchrefs."/$_/*" } - qw(tags heads), $branchprefix; - 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. + + printdebug "git_fetch_us specs @specs\n"; + + 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 (;;) { + printdebug "git_fetch_us iteration $fetch_iteration\n"; + 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 - return $mi->{Clogp} if $mi->{Clogp}; - my $mclog = ".git/dgit/clog-$mi->{Commit}"; - mkpath '.git/dgit'; - runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob), - "$mi->{Commit}:debian/changelog"; - $mi->{Clogp} = parsechangelog("-l$mclog"); + my ($mi) = @_; + $mi->{Clogp} = commit_getclogp($mi->{Commit}); } sub mergeinfo_version ($) { @@ -1647,8 +2436,13 @@ sub mergeinfo_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) { @@ -1727,7 +2521,7 @@ sub fetch_from_archive () { # 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 psuedo-merge and put them in @mergeinputs. + # to any public view pseudo-merge and put them in @mergeinputs. my @mergeinputs; # $mergeinputs[]{Commit} @@ -1762,12 +2556,28 @@ sub fetch_from_archive () { 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 ".rref()." at ".access_giturl() - unless $lastpush_hash; ensure_we_have_orig(); - if ($dsc_hash eq $lastpush_hash) { + if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) { @mergeinputs = $dsc_mergeinput } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) { print STDERR <($lastpush_hash, 'dgit repo server tip (last push)'); + $chkff->($lastpush_hash, 'dgit repo server tip (last push)') + if $lastpush_hash; $chkff->($lastfetch_hash, 'local tracking tip (last fetch)'); runcmd @git, qw(update-ref -m), "dgit fetch $csuite", @@ -1944,10 +2756,7 @@ END 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) { @@ -1969,7 +2778,11 @@ END dryrun_report @upd_cmd; } } - return 1; + + lrfetchref_used lrfetchref(); + + unshift @end, $del_lrfetchrefs; + return $hash; } sub set_local_git_config ($$) { @@ -2022,6 +2835,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(); @@ -2057,6 +2877,11 @@ sub clone ($) { } setup_new_tree(); runcmd @git, qw(reset --hard), lrref(); + runcmd qw(bash -ec), <<'END'; + set -o pipefail + git ls-tree -r --name-only -z HEAD | \ + xargs -0r touch -r . -- +END printdone "ready for work in $dstdir"; } @@ -2117,7 +2942,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 < message fragment "$saved" describing disposition of $dgitview + return "commit id $dgitview" unless defined $split_brain_save; + my @cmd = (shell_cmd "cd ../../../..", + @git, qw(update-ref -m), + "dgit --dgit-view-save $msg HEAD=$headref", + $split_brain_save, $dgitview); + runcmd @cmd; + return "and left in $split_brain_save"; +} - my $clogp = Dpkg::Control::Hash->new(); - $clogp->load($clogpfn) or die; +# An "infopair" is a tuple [ $thing, $what ] +# (often $thing is a commit hash; $what is a description) - $package = getfield $clogp, 'Source'; - my $cversion = getfield $clogp, 'Version'; - my $tag = debiantag($cversion, access_basedistro); - runcmd @git, qw(check-ref-format), $tag; +sub infopair_cond_equal ($$) { + my ($x,$y) = @_; + $x->[0] eq $y->[0] or fail <[1] ($x->[0]) not equal to $y->[1] ($y->[0]) +END +}; - my $dscfn = dscfn($cversion); +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' + # + + return $dgitview unless defined $archive_hash; + + printdebug "splitbrain_pseudomerge...\n"; + + my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash); + + if (!defined $overwrite_version) { + progress "Checking that HEAD inciudes all changes in archive..."; + } + + return $dgitview if is_fast_fwd $archive_hash, $dgitview; + + if (defined $overwrite_version) { + } elsif (!eval { + 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); + infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]); + 1; + }) { + print STDERR <[0] +END_OVERWR +Make fast forward from $i_arch_v->[0] +END_MAKEFF + + maybe_split_brain_save $maintview, $r, "pseudomerge"; + + 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); + + 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) = @_; + + my $clogp = Dpkg::Control::Hash->new(); + $clogp->load($clogpfn) or die; + + my $clogpackage = getfield $clogp, 'Source'; + $package //= $clogpackage; + fail "-p specified $package but changelog specified $clogpackage" + unless $package eq $clogpackage; + my $cversion = getfield $clogp, 'Version'; + my $tag = debiantag($cversion, access_basedistro); + runcmd @git, qw(check-ref-format), $tag; + + my $dscfn = dscfn($cversion); + + return ($clogp, $cversion, $dscfn); } sub push_parse_dsc ($$$) { @@ -2213,6 +3244,7 @@ sub push_tagwants ($$$$) { $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro); $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; }; } + printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants); return @tagwants; } @@ -2314,9 +3346,23 @@ 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. @@ -2354,20 +3400,23 @@ END my $dgithead = $actualhead; my $maintviewhead = undef; - if (madformat($format)) { + my $upstreamversion = upstreamversion $clogp->{Version}; + + 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) = + my $cachekey; + ($dgithead, $cachekey) = quilt_check_splitbrain_cache($actualhead, $upstreamversion); - $dgitview or fail + $dgithead or fail "--quilt=$quilt_mode but no cached dgit view: perhaps tree changed since dgit build[-source] ?"; $split_brain = 1; - $dgithead = $dgitview; + $dgithead = splitbrain_pseudomerge($clogp, + $actualhead, $dgithead, + $archive_hash); $maintviewhead = $actualhead; changedir '../../../..'; prep_ud(); # so _only_subdir() works, below @@ -2376,7 +3425,30 @@ END } } + 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 --), @@ -2384,17 +3456,20 @@ 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, $dgithead); + my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); debugcmd "+",@diffcmd; $!=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"); } @@ -2471,15 +3559,13 @@ END create_remote_git_repo(); } - my @pushrefs = $forceflag."HEAD:".rrref(); + my @pushrefs = $forceflag.$dgithead.":".rrref(); foreach my $tw (@tagwants) { - my $view = $tw->{View}; - next unless $view eq 'dgit' - or any { $_ eq $view } access_cfg_tagformats(); push @pushrefs, $forceflag."refs/tags/$tw->{Tag}"; } - runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs; + 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'); @@ -2550,7 +3636,7 @@ sub cmd_clone { } if (stat $dstdir) { rmtree($dstdir) or die "remove $dstdir: $!\n"; - } elsif (!grep { $! == $_ } + } elsif (grep { $! == $_ } (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) { } else { print STDERR "check whether to remove $dstdir: $!\n"; @@ -2602,6 +3688,12 @@ sub cmd_fetch { sub cmd_pull { parseopts(); fetchpullargs(); + if (quiltmode_splitbrain()) { + my ($format, $fopts) = get_source_format(); + madformat($format) and fail <', $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)); - push @cmd, qw(-r) if $finegrained; + 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) { + 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; @@ -2999,9 +4091,12 @@ sub quiltify_splitbrain ($$$$$$) { 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->{H2O} & 01)) { + ($diffbits->{O2H} & 01)) { my $msg = "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n". " but git tree differs from orig in upstream files."; @@ -3011,16 +4106,31 @@ sub quiltify_splitbrain ($$$$$$) { } 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, qw(pq import); + 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 (($diffbits->{H2O} & 02) && # user has modified .gitignore + 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"; @@ -3037,7 +4147,7 @@ The Debian packaging git branch contains these updates to the upstream .gitignore file(s). This patch is autogenerated, to provide these updates to users of the official Debian archive view of the package. -[dgit version $our_version] +[dgit ($our_version) update-gitignore] --- END close GIPATCH or die "$gipatch: $!"; @@ -3051,21 +4161,44 @@ END print SERIES "auto-gitignore\n" or die $!; close SERIES or die $!; runcmd @git, qw(add -- debian/patches/series), $gipatch; - commit_admin "Commit patch to update .gitignore"; + commit_admin <>' or die $!; + + my $oldcache = git_get_ref "refs/$splitbraincache"; + if ($oldcache eq $dgitview) { + my $tree = cmdoutput qw(git rev-parse), "$dgitview:"; + # git update-ref doesn't always update, in this case. *sigh* + my $dummy = make_commit_text < 1000000000 +0000 +committer Dgit 1000000000 +0000 + +Dummy commit - do not use +END + runcmd @git, qw(update-ref -m), "dgit $our_version - dummy", + "refs/$splitbraincache", $dummy; + } runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", $dgitview; - progress "dgit view: created (commit id $dgitview)"; - changedir '.git/dgit/unpack/work'; + + my $saved = maybe_split_brain_save $headref, $dgitview, "converted"; + progress "dgit view: created ($saved)"; } sub quiltify ($$$$) { @@ -3246,15 +4379,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"; @@ -3272,6 +4465,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); @@ -3282,19 +4476,28 @@ 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); @@ -3328,7 +4531,7 @@ sub quilt_fixup_linkorigs ($$) { local ($debuglevel) = $debuglevel-1; printdebug "QF linkorigs $b, $f ?\n"; } - next unless is_orig_file $b, srcfn $upstreamversion,''; + 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); @@ -3337,7 +4540,11 @@ sub quilt_fixup_linkorigs ($$) { sub quilt_fixup_delete_pc () { runcmd @git, qw(rm -rqf .pc); - commit_admin "Commit removal of .pc (quilt series tracking data)"; + commit_admin <new(256); my %sfs = ( %INC, '$0(dgit)' => $0 ); foreach my $sfk (sort keys %sfs) { - next unless m/^\$0\b/ || m{^Debian/Dgit\b}; + next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b}; $srcshash->add($sfk," "); $srcshash->add(hashfile($sfs{$sfk})); $srcshash->add("\n"); @@ -3439,7 +4646,7 @@ sub quilt_check_splitbrain_cache ($$) { push @cachekey, $srcshash->hexdigest(); $splitbrain_cachekey = "@cachekey"; - my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs', + my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs', $splitbraincache); printdebug "splitbrain cachekey $splitbrain_cachekey\n"; debugcmd "|(probably)",@cmd; @@ -3460,8 +4667,9 @@ sub quilt_check_splitbrain_cache ($$) { my $cachehit = $1; quilt_fixup_mkwork($headref); + my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit"; if ($cachehit ne $headref) { - progress "dgit view: found cached (commit id $cachehit)"; + progress "dgit view: found cached ($saved)"; runcmd @git, qw(checkout -q -b dgit-view), $cachehit; $split_brain = 1; return ($cachehit, $splitbrain_cachekey); @@ -3519,10 +4727,10 @@ sub quilt_fixup_multipatch ($$$) { # 2. Copy .pc from the fake's extraction, if necessary # 3. Run dpkg-source --commit # 4. If the result has changes to debian/, then - # - git-add them them - # - git-add .pc if we had a .pc in-tree - # - git-commit - # 5. If we had a .pc in-tree, delete it, and git-commit + # - git add them them + # - git add .pc if we had a .pc in-tree + # - git commit + # 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 # Another situation we may have to cope with is gbp-style @@ -3531,7 +4739,7 @@ sub quilt_fixup_multipatch ($$$) { # 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). + # (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 @@ -3580,8 +4788,17 @@ sub quilt_fixup_multipatch ($$$) { ensuredir '.pc'; - runcmd qw(sh -ec), - 'exec dpkg-source --before-build . >/dev/null'; + my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null'); + $!=0; $?=-1; + if (system @bbcmd) { + failedcmd @bbcmd if $? < 0; + fail < quiltify_trees_differ($headref, $unapplied, 1,\%editedignores), + 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(H2O O2A H2A)) { + 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; + forceable_fail [qw(unrepresentable)], <{H2O} & $diffbits->{O2A})) { + if (!($diffbits->{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 ?"; + " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?"; if (quiltmode_splitbrain()) { quiltify_splitbrain($clogp, $unapplied, $headref, @@ -3703,6 +4933,7 @@ sub maybe_unapply_patches_again () { if $patches_applied_dirtily & 01; rmtree '.pc' if $patches_applied_dirtily & 02; + $patches_applied_dirtily = 0; } #----- other building ----- @@ -3744,15 +4975,21 @@ sub cmd_clean () { maybe_unapply_patches_again(); } -sub build_prep () { +sub build_prep_early () { + our $build_prep_early_done //= 0; + return if $build_prep_early_done++; notpushing(); badusage "-p is not allowed when building" if defined $package; - check_not_dirty(); - clean_tree(); my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; + check_not_dirty(); +} + +sub build_prep () { + build_prep_early(); + clean_tree(); build_maybe_quilt_fixup(); if ($rmchanges) { my $pat = changespat $version; @@ -3853,11 +5090,87 @@ sub massage_dbp_args ($;$) { return $r; } +sub in_parent (&) { + my ($fn) = @_; + my $wasdir = must_getcwd(); + changedir ".."; + $fn->(); + changedir $wasdir; +} + +sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent) + my ($msg_if_onlyone) = @_; + # If there is only one .changes file, fail with $msg_if_onlyone, + # or if that is undef, be a no-op. + # Returns the changes file to report to the user. + my $pat = changespat $version; + my @changesfiles = glob $pat; + @changesfiles = sort { + ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/) + or $a cmp $b + } @changesfiles; + my $result; + if (@changesfiles==1) { + fail < 0) { build_source(); + midbuild_checkchanges_vanilla $wantsrc; } else { build_prep(); } @@ -3867,41 +5180,80 @@ sub cmd_build { runcmd_ordryrun_local @dbp; } maybe_unapply_patches_again(); - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; +} + +sub pre_gbp_build { + $quilt_mode //= 'gbp'; } sub cmd_gbp_build { + build_prep_early(); + + # gbp can make .origs out of thin air. In my tests it does this + # even for a 1.0 format package, with no origs present. So I + # guess it keys off just the version number. We don't know + # exactly what .origs ought to exist, but let's assume that we + # should run gbp if: the version has an upstream part and the main + # orig is absent. + my $upstreamversion = upstreamversion $version; + my $origfnpat = srcfn $upstreamversion, '.orig.tar.*'; + my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat"); + + if ($gbp_make_orig) { + clean_tree(); + $cleanmode = 'none'; # don't do it again + $need_split_build_invocation = 1; + } + my @dbp = @dpkgbuildpackage; my $wantsrc = massage_dbp_args \@dbp, \@ARGV; - my @cmd; - if (length executable_on_path('git-buildpackage')) { - @cmd = qw(git-buildpackage); - } else { - @cmd = qw(gbp buildpackage); + 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 ($gbp_make_orig) { + ensuredir '.git/dgit'; + my $ok = '.git/dgit/origs-gen-ok'; + unlink $ok or $!==&ENOENT or die $!; + my @origs_cmd = @cmd; + push @origs_cmd, qw(--git-cleaner=true); + push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok"; + push @origs_cmd, @ARGV; + if (act_local()) { + debugcmd @origs_cmd; + system @origs_cmd; + do { local $!; stat_exists $ok; } + or failedcmd @origs_cmd; + } else { + dryrun_report @origs_cmd; + } + } + if ($wantsrc > 0) { build_source(); + midbuild_checkchanges_vanilla $wantsrc; } else { if (!$clean_using_builder) { push @cmd, '--git-cleaner=true'; } build_prep(); } + 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(); - maybe_apply_patches_dirtily(); runcmd_ordryrun_local @cmd, @ARGV; } - maybe_unapply_patches_again(); - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 @@ -3974,45 +5326,22 @@ sub cmd_build_source { 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; - } - changedir ".."; - if (act_local()) { - stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; - stat_exists $sourcechanges - or fail "$sourcechanges (in parent directory): $!"; - } - 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==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 = 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}: $!"; + midbuild_checkchanges(); + in_parent { + if (act_local()) { + stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; + stat_exists $sourcechanges + or fail "$sourcechanges (in parent directory): $!"; } - } + runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn; + }; maybe_unapply_patches_again(); - printdone "build successful, results in $multichanges\n" or die $!; + in_parent { + postbuild_mergechanges(<; }; + D->error and fail "read $dscfn: $!"; + close C; + + # we don't normally need this so import it here + use Dpkg::Source::Package; + my $dp = new Dpkg::Source::Package filename => $dscfn, + require_valid_signature => $needsig; + { + local $SIG{__WARN__} = sub { + print STDERR $_[0]; + return unless $needsig; + fail "import-dsc signature check failed"; + }; + if (!$dp->is_signed()) { + warn "$us: warning: importing unsigned .dsc\n"; + } else { + my $r = $dp->check_signature(); + die "->check_signature => $r" if $needsig && $r; + } + } + + parse_dscdata(); + + my $dgit_commit = $dsc->{$ourdscfield[0]}; + if (defined $dgit_commit && + !forceing [qw(import-dsc-with-dgit-field)]) { + $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc"; + progress "dgit: import-dsc of .dsc with Dgit field, using git hash"; + my @cmd = (qw(sh -ec), + "echo $dgit_commit | git cat-file --batch-check"); + my $objgot = cmdoutput @cmd; + if ($objgot =~ m#^\w+ missing\b#) { + fail < 0) { + progress "Not fast forward, forced update."; + } else { + fail "Not fast forward to $dgit_commit"; + } + } + @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info", + $dstbranch, $dgit_commit); + runcmd @cmd; + progress "dgit: import-dsc updated git ref $dstbranch"; + return 0; + } + + fail <{Filename}; + my $here = "../$f"; + next if lstat $here; + fail "stat $here: $!" unless $! == ENOENT; + my $there = $dscfn; + if ($dscfn =~ m#^(?:\./+)?\.\./+#) { + $there = $'; + } elsif ($dscfn =~ m#^/#) { + $there = $dscfn; + } else { + fail "cannot import $dscfn which seems to be inside working tree!"; + } + $there =~ s#/+[^/]+$## or + fail "cannot import $dscfn which seems to not have a basename"; + $there .= "/$f"; + symlink $there, $here or fail "symlink $there to $here: $!"; + progress "made symlink $here -> $there"; + print STDERR Dumper($fi); + } + my @mergeinputs = generate_commits_from_dsc(); + die unless @mergeinputs == 1; + + my $newhash = $mergeinputs[0]{Commit}; + + if ($oldhash) { + if ($force > 0) { + progress "Import, forced update - synthetic orphan git history."; + } elsif ($force < 0) { + progress "Import, merging."; + my $tree = cmdoutput @git, qw(rev-parse), "$newhash:"; + my $version = getfield $dsc, 'Version'; + $newhash = make_commit_text <",@cmd; exec @cmd or fail "exec curl: $!\n"; } @@ -4084,10 +5565,9 @@ defvalopt '', '-k', '.+', \$keyid; defvalopt '--existing-package','', '.*', \$existing_package; defvalopt '--build-products-dir','','.*', \$buildproductsdir; defvalopt '--clean', '', $cleanmode_re, \$cleanmode; +defvalopt '--package', '-p', $package_re, \$package; defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode; -defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; }; - defvalopt '', '-C', '.+', sub { ($changesfile) = (@_); if ($changesfile =~ s#^(.*)/##) { @@ -4163,6 +5643,9 @@ sub parseopts () { ($om = $opts_opt_map{$1})) { push @ropts, $_; push @$om, $2; + } elsif (m/^--(gbp|dpm)$/s) { + push @ropts, "--quilt=$1"; + $quilt_mode = $1; } elsif (m/^--ignore-dirty$/s) { push @ropts, $_; $ignoredirty = 1; @@ -4172,12 +5655,33 @@ 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/^--delayed=(\d+)$/s) { + push @ropts, $_; + push @dput, $_; + } elsif (m/^--dgit-view-save=(.+)$/s) { + push @ropts, $_; + $split_brain_save = $1; + $split_brain_save =~ s#^(?!refs/)#refs/heads/#; } elsif (m/^--(no-)?rm-old-changes$/s) { push @ropts, $_; $rmchanges = !$1; } elsif (m/^--deliberately-($deliberately_re)$/s) { push @ropts, $_; push @deliberatelies, $&; + } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) { + push @ropts, $&; + $forceopts{$1} = 1; + $_=''; + } elsif (m/^--force-/) { + print STDERR + "$us: warning: ignoring unknown force option $_\n"; + $_=''; } elsif (m/^--dgit-tag-format=(old|new)$/s) { # undocumented, for testing push @ropts, $_; @@ -4232,6 +5736,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; @@ -4245,6 +5755,30 @@ sub parseopts () { } } +sub check_env_sanity () { + my $blocked = new POSIX::SigSet; + sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!; + + eval { + foreach my $name (qw(PIPE CHLD)) { + my $signame = "SIG$name"; + my $signum = eval "POSIX::$signame" // die; + ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or + die "$signame is set to something other than SIG_DFL\n"; + $blocked->ismember($signum) and + die "$signame is blocked\n"; + } + }; + return unless $@; + chomp $@; + fail <= 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] ); } } @@ -4278,6 +5814,7 @@ if ($ENV{$fakeeditorenv}) { } parseopts(); +check_env_sanity(); git_slurp_config(); print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; @@ -4290,6 +5827,9 @@ 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');