X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=af62eb503534920cea40a43ee3c10743026f6aca;hp=ae07145cb1e58d818d4a232a72cdf8c5737bf705;hb=be4d76851f775f1863ff597ddb7adf171d8bb583;hpb=2f3f7b330bf4f06c32bdb101fba8530d90399752 diff --git a/dgit b/dgit index ae07145c..af62eb50 100755 --- a/dgit +++ b/dgit @@ -41,6 +41,7 @@ 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; @@ -66,6 +67,7 @@ our $rmchanges; our $overwrite_version; # undef: not specified; '': check changelog our $quilt_mode; 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; @@ -73,6 +75,13 @@ 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]+'; @@ -144,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); @@ -208,6 +222,12 @@ sub changespat ($;$) { return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; } +sub upstreamversion ($) { + my ($vsn) = @_; + $vsn =~ s/-[^-]+$//; + return $vsn; +} + our $us = 'dgit'; initdebug(''); @@ -222,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; @@ -593,7 +627,7 @@ 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', @@ -934,15 +968,22 @@ sub must_getcwd () { 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 ($$) { @@ -983,9 +1024,9 @@ 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); @@ -997,12 +1038,13 @@ sub api_query ($$) { 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; @@ -1026,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; @@ -1053,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 { @@ -1101,6 +1179,8 @@ sub canonicalise_suite_madison { return $r[0][2]; } +sub file_in_archive_madison { return undef; } + #---------- `sshpsql' archive query method ---------- sub sshpsql ($$$) { @@ -1176,6 +1256,8 @@ END return $rows[0]; } +sub file_in_archive_sshpsql ($$$) { return undef; } + #---------- `dummycat' archive query method ---------- sub canonicalise_suite_dummycat ($$) { @@ -1217,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 () { @@ -1289,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; @@ -1436,9 +1519,9 @@ sub mktree_in_ud_from_only_subdir (;$) { } our @files_csum_info_fields = - (['Checksums-Sha256','Digest::SHA', 'new(256)'], - ['Checksums-Sha1', 'Digest::SHA', 'new(1)'], - ['Files', 'Digest::MD5', 'new()']); + (['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 (@files_csum_info_fields) { @@ -1544,6 +1627,101 @@ sub is_orig_file_of_vsn ($$) { 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 ($) { my ($file) = @_; return cmdoutput @git, qw(hash-object -w -t commit), $file; @@ -1658,10 +1836,15 @@ sub generate_commits_from_dsc () { 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; @@ -1678,8 +1861,7 @@ sub generate_commits_from_dsc () { # from the debian/changelog, so we record the tree objects now and # make them into commits later. my @tartrees; - my $upstreamv = $dsc->{version}; - $upstreamv =~ s/-[^-]+$//; + my $upstreamv = upstreamversion $dsc->{version}; my $orig_f_base = srcfn $upstreamv, ''; foreach my $fi (@dfi) { @@ -1940,25 +2122,54 @@ END local $ENV{GIT_AUTHOR_EMAIL} = $authline[1]; local $ENV{GIT_AUTHOR_DATE} = $authline[2]; - eval { - runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output', - gbp_pq, qw(import); - }; - if ($@) { - { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; } - die $@; - } + my $path = $ENV{PATH} or die; + + foreach my $use_absurd (qw(0 1)) { + local $ENV{PATH} = $path; + if ($use_absurd) { + chomp $@; + progress "warning: $@"; + $path = "$absurdity:$path"; + progress "$us: trying slow absurd-git-apply..."; + rename "../../gbp-pq-output","../../gbp-pq-output.0" + or $!==ENOENT + or die $!; + } + eval { + die "forbid absurd git-apply\n" if $use_absurd + && forceing [qw(import-gitapply-no-absurd)]; + die "only absurd git-apply!\n" if !$use_absurd + && forceing [qw(import-gitapply-absurd)]; + + local $ENV{PATH} = $path if $use_absurd; + + my @showcmd = (gbp_pq, qw(import)); + my @realcmd = shell_cmd + 'exec >/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 < 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"; +} + # An "infopair" is a tuple [ $thing, $what ] # (often $thing is a commit hash; $what is a description) @@ -2893,12 +3122,12 @@ sub splitbrain_pseudomerge ($$$$) { # this: $dgitview' # + return $dgitview unless defined $archive_hash; + 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..."; } @@ -2935,6 +3164,8 @@ 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; } @@ -3163,11 +3394,11 @@ END my $dgithead = $actualhead; my $maintviewhead = undef; + 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 $cachekey; @@ -3251,7 +3482,14 @@ END # Check that changes and .dsc agree enough $changesfile =~ m{[^/]*$}; - files_compare_inputs($dsc, parsecontrol($changesfile,$&)); + my $changes = parsecontrol($changesfile,$&); + files_compare_inputs($dsc, $changes) + unless forceing [qw(dsc-changes-mismatch)]; + + # Perhaps adjust .dsc to contain right set of origs + changes_update_origs_from_dsc($dsc, $changes, $upstreamversion, + $changesfile) + unless forceing [qw(changes-origs-exactly)]; # Checks complete, we're going to try and go ahead: @@ -3945,9 +4183,10 @@ END 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 ($$$$) { @@ -4246,8 +4485,7 @@ END prep_ud(); changedir $ud; - my $upstreamversion=$version; - $upstreamversion =~ s/-[^-]*$//; + my $upstreamversion = upstreamversion $version; if ($fopts->{'single-debian-patch'}) { quilt_fixup_singlepatch($clogp, $headref, $upstreamversion); @@ -4417,8 +4655,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); @@ -4605,7 +4844,7 @@ END if (@unrepres) { print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n" foreach @unrepres; - fail <(); + 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(); } @@ -4847,7 +5162,7 @@ sub cmd_build { runcmd_ordryrun_local @dbp; } maybe_unapply_patches_again(); - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } sub pre_gbp_build { @@ -4872,6 +5187,7 @@ sub cmd_gbp_build { if ($wantsrc > 0) { build_source(); + midbuild_checkchanges_vanilla $wantsrc; } else { if (!$clean_using_builder) { push @cmd, '--git-cleaner=true'; @@ -4883,7 +5199,7 @@ sub cmd_gbp_build { push @cmd, changesopts(); runcmd_ordryrun_local @cmd, @ARGV; } - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 @@ -4956,53 +5272,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 < $a =~ m/_source\.changes$/) - or $a cmp $b - } @changesfiles; - fail <; }; + 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 <