X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=blobdiff_plain;f=dgit;h=89795013c12804a47ddefa9b59caee9adae63194;hb=862997ec70c49b644de04639f6f68bc8309e3d56;hp=08d07bec9190b600fac461f8ccb3bde037a593f2;hpb=bd5e99ad04dc4eda140aca37840628118d1fa94d;p=dgit.git diff --git a/dgit b/dgit index 08d07bec..89795013 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 @@ -34,12 +34,18 @@ use POSIX; use IPC::Open2; use Digest::SHA; use Digest::MD5; +use List::Util qw(any); +use List::MoreUtils qw(pairwise); +use Text::Glob qw(match_glob); +use Fcntl qw(:DEFAULT :flock); +use Carp; use Debian::Dgit; our $our_version = 'UNRELEASED'; ###substituted### +our $absurdity = undef; ###substituted### -our @rpushprotovsn_support = qw(3 2); +our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; our $isuite = 'unstable'; @@ -60,29 +66,52 @@ 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; +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); our (@sbuild) = qw(sbuild); our (@ssh) = 'ssh'; our (@dgit) = qw(dgit); +our (@aptget) = qw(apt-get); +our (@aptcache) = qw(apt-cache); 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 @@ -94,9 +123,13 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'ssh' => \@ssh, 'dgit' => \@dgit, 'git' => \@git, + 'apt-get' => \@aptget, + 'apt-cache' => \@aptcache, 'dpkg-source' => \@dpkgsource, 'dpkg-buildpackage' => \@dpkgbuildpackage, 'dpkg-genchanges' => \@dpkggenchanges, + 'gbp-build' => \@gbp_build, + 'gbp-pq' => \@gbp_pq, 'ch' => \@changesopts, 'mergechanges' => \@mergechanges); @@ -114,6 +147,7 @@ autoflush STDOUT 1; our $supplementary_message = ''; our $need_split_build_invocation = 0; +our $split_brain = 0; END { local ($@, $?); @@ -125,6 +159,24 @@ 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); +} + +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(); } @@ -132,6 +184,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) = @_; @@ -154,6 +228,12 @@ sub changespat ($;$) { return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; } +sub upstreamversion ($) { + my ($vsn) = @_; + $vsn =~ s/-[^-]+$//; + return $vsn; +} + our $us = 'dgit'; initdebug(''); @@ -168,20 +248,29 @@ 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; } -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 ($) { @@ -195,6 +284,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: @@ -202,6 +306,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 @@ -215,7 +329,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] @@ -387,7 +507,7 @@ our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); sub runcmd { debugcmd "+",@_; - $!=0; $?=0; + $!=0; $?=-1; failedcmd @_ if system @_; } @@ -396,7 +516,7 @@ sub act_scary () { return !$dryrun_level; } sub printdone { if (!$dryrun_level) { - progress "dgit ok: @_"; + progress "$us ok: @_"; } else { progress "would be ok: @_ (but dry run only)"; } @@ -466,11 +586,19 @@ sub cmd_help () { our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset"; our %defcfg = ('dgit.default.distro' => 'debian', + 'dgit-suite.*-security.distro' => 'debian-security', 'dgit.default.username' => '', 'dgit.default.archive-query-default-component' => 'main', 'dgit.default.ssh' => 'ssh', 'dgit.default.archive-query' => 'madison:', 'dgit.default.sshpsql-dbname' => 'service=projectb', + 'dgit.default.aptget-components' => 'main', + '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', @@ -496,6 +624,11 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit-distro.debian.git-url-suffix' => '', 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/', + 'dgit-distro.debian-security.archive-query' => 'aptget:', + 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/', + 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#', + 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#', + 'dgit-distro.debian-security.nominal-distro' => 'debian', 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*', 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/', 'dgit-distro.ubuntu.git-check' => 'false', @@ -507,42 +640,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; - - 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 { @@ -561,11 +707,27 @@ sub access_basedistro () { if (defined $idistro) { return $idistro; } else { - return cfg("dgit-suite.$isuite.distro", - "dgit.default.distro"); + my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF'); + return $def if defined $def; + foreach my $src (@gitcfgsources, 'internal') { + my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src}; + next unless $kl; + foreach my $k (keys %$kl) { + next unless $k =~ m#^dgit-suite\.(.*)\.distro$#; + my $dpat = $1; + next unless match_glob $dpat, $isuite; + return $kl->{$k}; + } + } + return cfg("dgit.default.distro"); } } +sub access_nomdistro () { + my $base = access_basedistro(); + return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base; +} + sub access_quirk () { # returns (quirk name, distro to use instead or undef, quirk-specific info) my $basedistro = access_basedistro(); @@ -661,6 +823,8 @@ sub access_distros () { unshift @l, $instead_distro; @l = grep { defined } @l; + push @l, access_nomdistro(); + if (access_forpush()) { @l = map { ("$_/push", $_) } @l; } @@ -790,10 +954,10 @@ sub parsecontrolfh ($$;$) { } sub parsecontrol { - my ($file, $desc) = @_; + my ($file, $desc, $allowsigned) = @_; my $fh = new IO::Handle; open $fh, '<', $file or die "$file: $!"; - my $c = parsecontrolfh($fh,$desc); + my $c = parsecontrolfh($fh,$desc,$allowsigned); $fh->error and die $!; close $fh; return $c; @@ -803,11 +967,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 $!; @@ -816,21 +980,48 @@ 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 @_; + fail "this operation does not support multiple comma-separated suites" + if $isuite =~ m/,/; 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 archive_query_prepend_mirror { + my $m = access_cfg('mirror'); + return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_; } sub pool_dsc_subpath ($$) { @@ -839,11 +1030,22 @@ sub pool_dsc_subpath ($$) { return "/pool/$component/$prefix/$package/".dscfn($vsn); } +sub cfg_apply_map ($$$) { + my ($varref, $what, $mapspec) = @_; + return unless $mapspec; + + printdebug "config $what EVAL{ $mapspec; }\n"; + $_ = $$varref; + eval "package Dgit::Config; $mapspec;"; + die $@ if $@; + $$varref = $_; +} + #---------- `ftpmasterapi' archive query method (nascent) ---------- 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; @@ -871,17 +1073,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; @@ -905,7 +1117,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; @@ -929,13 +1141,212 @@ sub archive_query_ftpmasterapi () { if length $@; } @rows = sort { -version_compare($a->[0],$b->[0]) } @rows; - return @rows; + return archive_query_prepend_mirror @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); +} + +#---------- `aptget' archive query method ---------- + +our $aptget_base; +our $aptget_releasefile; +our $aptget_configpath; + +sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; } +sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; } + +sub aptget_cache_clean { + runcmd_ordryrun_local qw(sh -ec), + 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --', + 'x', $aptget_base; +} + +sub aptget_lock_acquire () { + my $lockfile = "$aptget_base/lock"; + open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!"; + flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!"; +} + +sub aptget_prep ($) { + my ($data) = @_; + return if defined $aptget_base; + + badcfg "aptget archive query method takes no data part" + if length $data; + + my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache"; + + ensuredir $cache; + ensuredir "$cache/dgit"; + my $cachekey = + access_cfg('aptget-cachekey','RETURN-UNDEF') + // access_nomdistro(); + + $aptget_base = "$cache/dgit/aptget"; + ensuredir $aptget_base; + + my $quoted_base = $aptget_base; + die "$quoted_base contains bad chars, cannot continue" + if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/ + + ensuredir $aptget_base; + + aptget_lock_acquire(); + + aptget_cache_clean(); + + $aptget_configpath = "$aptget_base/apt.conf#$cachekey"; + my $sourceslist = "source.list#$cachekey"; + + my $aptsuites = $isuite; + cfg_apply_map(\$aptsuites, 'suite map', + access_cfg('aptget-suite-map', 'RETURN-UNDEF')); + + open SRCS, ">", "$aptget_base/$sourceslist" or die $!; + printf SRCS "deb-src %s %s %s\n", + access_cfg('mirror'), + $aptsuites, + access_cfg('aptget-components') + or die $!; + + ensuredir "$aptget_base/cache"; + ensuredir "$aptget_base/lists"; + + open CONF, ">", $aptget_configpath or die $!; + print CONF <) { + next unless stat_exists $oldlist; + my ($mtime) = (stat _)[9]; + utime $oldatime, $mtime, $oldlist or die "$oldlist $!"; + } + + runcmd_ordryrun_local aptget_aptget(), qw(update); + + my @releasefiles; + foreach my $oldlist (<$aptget_base/lists/*Release>) { + next unless stat_exists $oldlist; + my ($atime) = (stat _)[8]; + next if $atime == $oldatime; + push @releasefiles, $oldlist; + } + my @inreleasefiles = grep { m#/InRelease$# } @releasefiles; + @releasefiles = @inreleasefiles if @inreleasefiles; + die "apt updated wrong number of Release files (@releasefiles), erk" + unless @releasefiles == 1; + + ($aptget_releasefile) = @releasefiles; +} + +sub canonicalise_suite_aptget { + my ($proto,$data) = @_; + aptget_prep($data); + + my $release = parsecontrol $aptget_releasefile, "Release file", 1; + + foreach my $name (qw(Codename Suite)) { + my $val = $release->{$name}; + if (defined $val) { + printdebug "release file $name: $val\n"; + $val =~ m/^$suite_re$/o or fail + "Release file ($aptget_releasefile) specifies intolerable $name"; + cfg_apply_map(\$val, 'suite rmap', + access_cfg('aptget-suite-rmap', 'RETURN-UNDEF')); + return $val + } + } + return $isuite; +} + +sub archive_query_aptget { + my ($proto,$data) = @_; + aptget_prep($data); + + ensuredir "$aptget_base/source"; + foreach my $old (<$aptget_base/source/*.dsc>) { + unlink $old or die "$old: $!"; + } + + my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package; + return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi; + # avoids apt-get source failing with ambiguous error code + + runcmd_ordryrun_local + shell_cmd 'cd "$1"/source; shift', $aptget_base, + aptget_aptget(), qw(--download-only --only-source source), $package; + + my @dscs = <$aptget_base/source/*.dsc>; + fail "apt-get source did not produce a .dsc" unless @dscs; + fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1; + + my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1; + + use URI::Escape; + my $uri = "file://". uri_escape $dscs[0]; + $uri =~ s{\%2f}{/}gi; + return [ (getfield $pre_dsc, 'Version'), $uri ]; +} + +#---------- `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 { - return map { [ @$_[0..1] ] } madison_get_parse(@_); + return archive_query_prepend_mirror + map { [ @$_[0..1] ] } madison_get_parse(@_); } sub madison_get_parse { @@ -980,6 +1391,8 @@ sub canonicalise_suite_madison { return $r[0][2]; } +sub file_in_archive_madison { return undef; } + #---------- `sshpsql' archive query method ---------- sub sshpsql ($$$) { @@ -1039,7 +1452,7 @@ END my ($vsn,$component,$filename,$sha256sum) = @$_; [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ]; } @rows; - return @rows; + return archive_query_prepend_mirror @rows; } sub canonicalise_suite_sshpsql ($$) { @@ -1055,6 +1468,8 @@ END return $rows[0]; } +sub file_in_archive_sshpsql ($$$) { return undef; } + #---------- `dummycat' archive query method ---------- sub canonicalise_suite_dummycat ($$) { @@ -1093,7 +1508,52 @@ sub archive_query_dummycat ($$) { } C->error and die "$dpath: $!"; close C; - return sort { -version_compare($a->[0],$b->[0]); } @rows; + return archive_query_prepend_mirror + sort { -version_compare($a->[0],$b->[0]); } @rows; +} + +sub file_in_archive_dummycat () { return undef; } + +#---------- 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 ---------- @@ -1104,6 +1564,8 @@ sub canonicalise_suite () { $csuite = archive_query('canonicalise_suite'); if ($isuite ne $csuite) { progress "canonical suite name for $isuite is $csuite"; + } else { + progress "canonical suite name is $csuite"; } } @@ -1111,8 +1573,8 @@ sub get_archive_dsc () { canonicalise_suite(); my @vsns = archive_query('archive_query'); foreach my $vinfo (@vsns) { - my ($vsn,$subpath,$digester,$digest) = @$vinfo; - $dscurl = access_cfg('mirror').$subpath; + my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo; + $dscurl = $vsn_dscurl; $dscdata = url_get($dscurl); if (!$dscdata) { $skew_warning_vsn = $vsn if !defined $skew_warning_vsn; @@ -1126,16 +1588,17 @@ 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; } $dsc = undef; + printdebug "get_archive_dsc: nothing in archive, returning undef\n"; } sub check_for_git (); @@ -1149,7 +1612,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 @@ -1158,14 +1621,14 @@ 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'); 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 @@ -1205,7 +1668,7 @@ sub create_remote_git_repo () { } } -our ($dsc_hash,$lastpush_hash); +our ($dsc_hash,$lastpush_mergeinput); our $ud = '.git/dgit/unpack'; @@ -1219,6 +1682,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 $!; } @@ -1229,10 +1693,15 @@ sub git_write_tree () { return $tree; } +sub git_add_write_tree () { + runcmd @git, qw(add -Af .); + return 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 () { @@ -1245,29 +1714,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)', '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; @@ -1295,12 +1772,175 @@ 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; + } + printdebug "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 ($) { @@ -1308,15 +1948,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; } @@ -1380,100 +2043,394 @@ sub check_for_vendor_patches () { vendor_patches_distro(Dpkg::Vendor::get_current_vendor(), "Dpkg::Vendor \`current vendor'"); vendor_patches_distro(access_basedistro(), - "distro being accessed"); + "(base) distro being accessed"); + vendor_patches_distro(access_nomdistro(), + "(nominal) 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$#; - 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 <>../changelogold.tmp'; - my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); - 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 <{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(< 0) { - print STDERR </dev/null 2>../../gbp-pq-output', @showcmd; + debugcmd "+",@realcmd; + if (system @realcmd) { + die +(shellquote @showcmd). + " failed: ". + failedcmd_waitstatus()."\n"; + } -Version actually in archive: $cversion (older) -Last allegedly pushed/uploaded: $oversion (newer or same) -$later_warning_msg + 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); + + if ($lastpush_mergeinput) { + my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput); + my $oversion = getfield $oldclogp, 'Version'; + my $vcmp = + version_compare($oversion, $cversion); + if ($vcmp < 0) { + @output = ($rawimport_mergeinput, $lastpush_mergeinput, + { Message => < 1 }); +Record $package ($cversion) in archive suite $csuite +END + } 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_nomdistro) } + \&debiantag_new, \&debiantag_maintview) + : debiantags('*',access_nomdistro)); + 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 + my ($mi) = @_; + $mi->{Clogp} = commit_getclogp($mi->{Commit}); +} + +sub mergeinfo_version ($) { + return getfield( (mergeinfo_getclogp $_[0]), 'Version' ); +} + +sub fetch_from_archive_record_1 ($) { + my ($hash) = @_; + 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 +} + +sub fetch_from_archive_record_2 ($) { + my ($hash) = @_; + my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash); + if (act_local()) { + cmdoutput @upd_cmd; + } else { + dryrun_report @upd_cmd; + } +} + 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) { @@ -1572,35 +2702,161 @@ 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().")" - unless $lastpush_hash; - $hash = $dsc_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 <{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)') + if $lastpush_hash; + $chkff->($lastfetch_hash, 'local tracking tip (last fetch)'); + + fetch_from_archive_record_1($hash); + 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) { @@ -1644,15 +3007,15 @@ We were able to obtain only $got_vsn END } } - if ($lastpush_hash ne $hash) { - my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash); - if (act_local()) { - cmdoutput @upd_cmd; - } else { - dryrun_report @upd_cmd; - } + + if ($lastfetch_hash ne $hash) { + fetch_from_archive_record_2($hash); } - return 1; + + lrfetchref_used lrfetchref(); + + unshift @end, $del_lrfetchrefs; + return $hash; } sub set_local_git_config ($$) { @@ -1705,25 +3068,219 @@ 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(); } +sub multisuite_suite_child ($$$) { + my ($tsuite, $merginputs, $fn) = @_; + # in child, sets things up, calls $fn->(), and returns undef + # in parent, returns canonical suite name for $tsuite + my $canonsuitefh = IO::File::new_tmpfile; + my $pid = fork // die $!; + if (!$pid) { + $isuite = $tsuite; + $us .= " [$isuite]"; + $debugprefix .= " "; + progress "fetching $tsuite..."; + canonicalise_suite(); + print $canonsuitefh $csuite, "\n" or die $!; + close $canonsuitefh or die $!; + $fn->(); + return undef; + } + waitpid $pid,0 == $pid or die $!; + fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4; + seek $canonsuitefh,0,0 or die $!; + local $csuite = <$canonsuitefh>; + die $! unless defined $csuite && chomp $csuite; + if ($? == 256*4) { + printdebug "multisuite $tsuite missing\n"; + return $csuite; + } + printdebug "multisuite $tsuite ok (canon=$csuite)\n"; + push @$merginputs, { + Ref => lrref, + Info => $csuite, + }; + return $csuite; +} + +sub fork_for_multisuite ($) { + my ($before_fetch_merge) = @_; + # if nothing unusual, just returns '' + # + # if multisuite: + # returns 0 to caller in child, to do first of the specified suites + # in child, $csuite is not yet set + # + # returns 1 to caller in parent, to finish up anything needed after + # in parent, $csuite is set to canonicalised portmanteau + + my $org_isuite = $isuite; + my @suites = split /\,/, $isuite; + return '' unless @suites > 1; + printdebug "fork_for_multisuite: @suites\n"; + + my @mergeinputs; + + my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs, + sub { }); + return 0 unless defined $cbasesuite; + + fail "package $package missing in (base suite) $cbasesuite" + unless @mergeinputs; + + my @csuites = ($cbasesuite); + + $before_fetch_merge->(); + + foreach my $tsuite (@suites[1..$#suites]) { + my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs, + sub { + @end = (); + fetch(); + exit 0; + }); + # xxx collecte the ref here + + $csubsuite =~ s/^\Q$cbasesuite\E-/-/; + push @csuites, $csubsuite; + } + + foreach my $mi (@mergeinputs) { + my $ref = git_get_ref $mi->{Ref}; + die "$mi->{Ref} ?" unless length $ref; + $mi->{Commit} = $ref; + } + + $csuite = join ",", @csuites; + + my $previous = git_get_ref lrref; + if ($previous) { + unshift @mergeinputs, { + Commit => $previous, + Info => "local combined tracking branch", + Warning => + "archive seems to have rewound: local tracking branch is ahead!", + }; + } + + foreach my $ix (0..$#mergeinputs) { + $mergeinputs[$ix]{Index} = $ix; + } + + @mergeinputs = sort { + -version_compare(mergeinfo_version $a, + mergeinfo_version $b) # highest version first + or + $a->{Index} <=> $b->{Index}; # earliest in spec first + } @mergeinputs; + + my @needed; + + NEEDED: + foreach my $mi (@mergeinputs) { + printdebug "multisuite merge check $mi->{Info}\n"; + foreach my $previous (@needed) { + next unless is_fast_fwd $mi->{Commit}, $previous->{Commit}; + printdebug "multisuite merge un-needed $previous->{Info}\n"; + next NEEDED; + } + push @needed, $mi; + printdebug "multisuite merge this-needed\n"; + $mi->{Character} = '+'; + } + + $needed[0]{Character} = '*'; + + my $output = $needed[0]{Commit}; + + if (@needed > 1) { + printdebug "multisuite merge nontrivial\n"; + my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':'; + + my $commit = "tree $tree\n"; + my $msg = "Combine archive branches $csuite [dgit]\n\n". + "Input branches:\n"; + + foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) { + printdebug "multisuite merge include $mi->{Info}\n"; + $mi->{Character} //= ' '; + $commit .= "parent $mi->{Commit}\n"; + $msg .= sprintf " %s %-25s %s\n", + $mi->{Character}, + (mergeinfo_version $mi), + $mi->{Info}; + } + my $authline = clogp_authline mergeinfo_getclogp $needed[0]; + $msg .= "\nKey\n". + " * marks the highest version branch, which choose to use\n". + " + marks each branch which was not already an ancestor\n\n". + "[dgit multi-suite $csuite]\n"; + $commit .= + "author $authline\n". + "committer $authline\n\n"; + $output = make_commit_text $commit.$msg; + printdebug "multisuite merge generated $output\n"; + } + + fetch_from_archive_record_1($output); + fetch_from_archive_record_2($output); + + progress "calculated combined tracking suite $csuite"; + + return 1; +} + +sub clone_set_head () { + open H, "> .git/HEAD" or die $!; + print H "ref: ".lref()."\n" or die $!; + close H or die $!; +} +sub clone_finish ($) { + my ($dstdir) = @_; + 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"; +} + sub clone ($) { my ($dstdir) = @_; - canonicalise_suite(); badusage "dry run makes no sense with clone" unless act_local(); + + my $multi_fetched = fork_for_multisuite(sub { + printdebug "multi clone before fetch merge\n"; + changedir $dstdir; + }); + if ($multi_fetched) { + printdebug "multi clone after fetch merge\n"; + clone_set_head(); + clone_finish($dstdir); + exit 0; + } + printdebug "clone main body\n"; + + canonicalise_suite(); my $hasgit = check_for_git(); mkdir $dstdir or fail "create \`$dstdir': $!"; changedir $dstdir; runcmd @git, qw(init -q); + clone_set_head(); 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 $!; runcmd @git, qw(remote add), 'origin', $giturl; } if ($hasgit) { @@ -1740,11 +3297,11 @@ sub clone ($) { runcmd @git, qw(remote add vcs-git), $vcsgiturl; } setup_new_tree(); - runcmd @git, qw(reset --hard), lrref(); - printdone "ready for work in $dstdir"; + clone_finish($dstdir); } sub fetch () { + canonicalise_suite(); if (check_for_git()) { git_fetch_us(); } @@ -1753,7 +3310,9 @@ sub fetch () { } sub pull () { - fetch(); + my $multi_fetched = fork_for_multisuite(sub { }); + fetch() unless $multi_fetched; # parent + return if $multi_fetched eq '0'; # child runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]", lrref(); printdone "fetched to ".lrref()." and merged into HEAD"; @@ -1770,9 +3329,9 @@ sub check_not_dirty () { 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; @@ -1801,7 +3360,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"; +} + +# An "infopair" is a tuple [ $thing, $what ] +# (often $thing is a commit hash; $what is a description) + +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 +}; + +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_nomdistro; + my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag"); + my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro; + 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; - $package = getfield $clogp, 'Source'; + 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); + my $tag = debiantag($cversion, access_nomdistro); runcmd @git, qw(check-ref-format), $tag; my $dscfn = dscfn($cversion); - return ($clogp, $cversion, $tag, $dscfn); + return ($clogp, $cversion, $dscfn); } sub push_parse_dsc ($$$) { @@ -1872,13 +3641,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_nomdistro); + $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; }; + } + printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants); + return @tagwants; +} + +sub push_mktags ($$ $$ $) { + my ($clogp,$dscfn, $changesfile,$changesfilewhat, - $tfn) = @_; + $tagwants) = @_; + + die unless $tagwants->[0]{View} eq 'dgit'; - $dsc->{$ourdscfield[0]} = $head; + $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid}; $dsc->save("$dscfn.tmp") or die $!; my $changes = parsecontrol($changesfile,$changesfilewhat); @@ -1895,46 +3690,67 @@ sub push_mktag ($$$$$$$) { # to control the "tagger" (b) we can do remote signing 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 ($) { @@ -1948,23 +3764,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"; @@ -1978,11 +3813,60 @@ END my $format = getfield $dsc, 'Format'; printdebug "format $format\n"; - if (madformat($format)) { + + my $actualhead = git_rev_parse('HEAD'); + 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: - commit_quilty_patch(); + if (quiltmode_splitbrain()) { + changedir $ud; + quilt_make_fake_dsc($upstreamversion); + my $cachekey; + ($dgithead, $cachekey) = + quilt_check_splitbrain_cache($actualhead, $upstreamversion); + $dgithead 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, $dgithead, + $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 --), @@ -1990,22 +3874,24 @@ 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 { @@ -2031,8 +3935,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. @@ -2040,23 +3945,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. @@ -2065,9 +3976,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. @@ -2135,9 +4052,10 @@ sub cmd_clone { return if $!==&ENOENT; die "chdir $cwd_remove: $!"; } + printdebug "clone rmonerror removing $dstdir\n"; 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"; @@ -2165,16 +4083,13 @@ sub fetchpullargs () { $package = getfield $sourcep, 'Source'; } if (@ARGV==0) { -# $isuite = branchsuite(); # this doesn't work because dak hates canons + $isuite = branchsuite(); if (!$isuite) { my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; } - canonicalise_suite(); - progress "fetching from suite $csuite"; } elsif (@ARGV==1) { ($isuite) = @ARGV; - canonicalise_suite(); } else { badusage "incorrect arguments to dgit fetch or dgit pull"; } @@ -2183,12 +4098,20 @@ sub fetchpullargs () { sub cmd_fetch { parseopts(); fetchpullargs(); + my $multi_fetched = fork_for_multisuite(sub { }); + exit 0 if $multi_fetched; fetch(); } sub cmd_pull { parseopts(); fetchpullargs(); + if (quiltmode_splitbrain()) { + my ($format, $fopts) = get_source_format(); + madformat($format) and fail <= 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+)(?: (.*))?$/; @@ -2421,13 +4331,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#; } @@ -2454,17 +4364,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 { @@ -2490,13 +4409,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)); - 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; - $r |= ($f =~ m#^(?:.*/)?.gitignore$#s) ? 02 : 01; + + 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; } printdebug "quiltify_trees_differ $x $y => $r\n"; return $r; @@ -2539,13 +4488,135 @@ sub quiltify_tree_sentinelfiles ($) { return $r; } -sub quiltify_splitbrain ($) { - my ($diffbits) = @_; - # memoisation via git-reflog - my $may_apply = $quilt_mode =~ m/gbp|unapplied/; - die "xxx not yet implemented"; -# if ($may_apply && -# quiltify_trees_differ($userhead,)) {} +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 $!; + + 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; + + changedir '.git/dgit/unpack/work'; + + my $saved = maybe_split_brain_save $headref, $dgitview, "converted"; + progress "dgit view: created ($saved)"; } sub quiltify ($$$$) { @@ -2697,7 +4768,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"; @@ -2725,15 +4797,75 @@ sub quiltify ($$$$) { $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?"; my $author = $1; - $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?"; + 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; + 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 $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 $index; for ($index=''; stat "debian/patches/$patchname$index"; @@ -2751,6 +4883,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); @@ -2761,19 +4894,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); @@ -2781,6 +4923,8 @@ sub build_maybe_quilt_fixup () { 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); @@ -2805,7 +4949,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); @@ -2814,7 +4958,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 <' 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 $sfk =~ m/^\$0\b/ || $sfk =~ 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(log -g), '--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); + my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit"; + if ($cachehit ne $headref) { + progress "dgit view: found cached ($saved)"; + 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 "starting quiltify (multiple patches, $quilt_mode mode)"; + progress "examining quilt state (multiple patches, $quilt_mode mode)"; # Our objective is: # - honour any existing .pc in case it has any strangeness @@ -2887,10 +5145,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 @@ -2899,7 +5157,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 @@ -2918,45 +5176,17 @@ sub quilt_fixup_multipatch ($$$) { # afterwards with dpkg-source --before-build. That lets us save a # tree object corresponding to .origs. - my $fakeversion="$upstreamversion-~~DGITFAKE"; - - my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; - print $fakedsc <addfile($fh); - print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; - }; + my $splitbrain_cachekey; - quilt_fixup_linkorigs($upstreamversion, $dscaddfile); + quilt_make_fake_dsc($upstreamversion); - 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; + if (quiltmode_splitbrain()) { + my $cachehit; + ($cachehit, $splitbrain_cachekey) = + quilt_check_splitbrain_cache($headref, $upstreamversion); + return if $cachehit; } - my $debtar= srcfn $fakeversion,'.debian.tar.gz'; - runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files; - - $dscaddfile->($debtar); - close $fakedsc or die $!; - runcmd qw(sh -ec), 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null'; @@ -2970,14 +5200,22 @@ END rmtree '.pc'; - runcmd @git, qw(add -Af .); - my $unapplied=git_write_tree(); + my $unapplied=git_add_write_tree(); printdebug "fake orig tree object $unapplied\n"; 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), + 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 ($quilt_mode =~ m/gbp|dpm|apply/) { - quiltify_splitbrain($diffbits); + 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") { @@ -3073,15 +5328,45 @@ sub quilt_fixup_editor () { exit 0; } +sub maybe_apply_patches_dirtily () { + return unless $quilt_mode =~ m/gbp|unapplied/; + print STDERR <1; #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation); if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) { - $suppress_clean = 1; + $clean_using_builder = 1; return 0; } # -nc has the side effect of specifying -b if nothing else specified @@ -3202,68 +5494,198 @@ sub massage_dbp_args ($;$) { #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 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(); } if ($wantsrc < 2) { push @dbp, changesopts_version(); + maybe_apply_patches_dirtily(); runcmd_ordryrun_local @dbp; } - printdone "build successful\n"; + maybe_unapply_patches_again(); + 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 (!$suppress_clean) { + 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(); runcmd_ordryrun_local @cmd, @ARGV; } - printdone "build successful\n"; + postbuild_mergechanges_vanilla $wantsrc; } 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 = changespat $version,'source'; @@ -3272,18 +5694,38 @@ sub build_source { or fail "remove $sourcechanges: $!"; } $dscfn = dscfn($version); - if ($cleanmode eq 'dpkg-source') { + 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') { + changesopts(); + } elsif ($our_cleanmode eq 'dpkg-source-d') { + maybe_apply_patches_dirtily(); runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d), - changesopts(); + 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", @@ -3294,49 +5736,28 @@ 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; - } - 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): $!"; } - } - printdone "build successful, results in $multichanges\n" or die $!; + runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn; + }; + maybe_unapply_patches_again(); + 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"; } @@ -3408,10 +5981,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#^(.*)/##) { @@ -3487,6 +6059,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; @@ -3496,12 +6071,38 @@ 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, $_; + $tagformat_want = [ $1, 'command line', 1 ]; + # 1 menas overrides distro configuration } elsif (m/^--always-split-source-build$/s) { # undocumented, for testing push @ropts, $_; @@ -3551,6 +6152,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; @@ -3564,6 +6171,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] ); } } @@ -3597,6 +6230,7 @@ if ($ENV{$fakeeditorenv}) { } parseopts(); +check_env_sanity(); git_slurp_config(); print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; @@ -3609,6 +6243,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'); @@ -3624,6 +6261,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');