diff options
Diffstat (limited to 'dgit')
-rwxr-xr-x | dgit | 5744 |
1 files changed, 5099 insertions, 645 deletions
@@ -2,7 +2,7 @@ # dgit # Integration between git and Debian-style archives # -# Copyright (C)2013 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 @@ -19,6 +19,9 @@ use strict; +use Debian::Dgit; +setup_sigwarn(); + use IO::Handle; use Data::Dumper; use LWP::UserAgent; @@ -30,13 +33,21 @@ use Dpkg::Version; use POSIX; use IPC::Open2; use Digest::SHA; -use Config; +use Digest::MD5; +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 = 2; +our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format +our $protovsn; -our $isuite = 'unstable'; +our $isuite; our $idistro; our $package; our @ropts; @@ -47,31 +58,63 @@ our $changesfile; our $buildproductsdir = '..'; our $new_package = 0; our $ignoredirty = 0; -our $noquilt = 0; our $rmonerror = 1; +our @deliberatelies; +our %previously; our $existing_package = 'dpkg'; -our $cleanmode = 'dpkg-source'; +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|dpm|unapplied'; +our $dodep14tag; +our $split_brain_save; our $we_are_responder; +our $we_are_initiator; our $initiator_tempdir; +our $patches_applied_dirtily = 00; +our $tagformat_want; +our $tagformat; +our $tagformatfn; +our $chase_dsc_distro=1; + +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 $rewritemap = 'dgit-rewrite/map'; 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 -A); +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 @@ -82,36 +125,68 @@ our %opts_opt_map = ('dget' => \@dget, # accept for compatibility 'sbuild' => \@sbuild, '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); -our %opts_opt_cmdonly = ('gpg' => 1); +our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1); +our %opts_cfg_insertpos = map { + $_, + scalar @{ $opts_opt_map{$_} } +} keys %opts_opt_map; -our $keyid; +sub parseopts_late_defaults(); +sub setup_gitattrs(;$); +sub check_gitattrs($$); -our $debug = 0; -open DEBUG, ">/dev/null" or die $!; +our $keyid; autoflush STDOUT 1; +our $supplementary_message = ''; +our $need_split_build_invocation = 0; +our $split_brain = 0; + +END { + local ($@, $?); + return unless forkcheck_mainprocess(); + print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg; +} + our $remotename = 'dgit'; our @ourdscfield = qw(Dgit Vcs-Dgit-Master); -our $branchprefix = 'dgit'; 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) = @_; + return "$distro/".dep14_version_mangle $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(); } -sub lrref () { return "refs/remotes/$remotename/$branchprefix/$csuite"; } -sub rrref () { return "refs/$branchprefix/$csuite"; } -sub debiantag ($) { - my ($v) = @_; - $v =~ y/~:/_%/; - return "debian/$v"; -} +sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); } +sub rrref () { return server_ref($csuite); } sub stripepoch ($) { my ($vsn) = @_; @@ -119,68 +194,109 @@ sub stripepoch ($) { return $vsn; } +sub srcfn ($$) { + my ($vsn,$sfx) = @_; + return "${package}_".(stripepoch $vsn).$sfx +} + sub dscfn ($) { my ($vsn) = @_; - return "${package}_".(stripepoch $vsn).".dsc"; + return srcfn($vsn,".dsc"); +} + +sub changespat ($;$) { + my ($vsn, $arch) = @_; + return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes"; +} + +sub upstreamversion ($) { + my ($vsn) = @_; + $vsn =~ s/-[^-]+$//; + return $vsn; } our $us = 'dgit'; -our $debugprefix = ''; +initdebug(''); our @end; END { local ($?); + return unless forkcheck_mainprocess(); foreach my $f (@end) { eval { $f->(); }; - warn "$us: cleanup: $@" if length $@; + print STDERR "$us: cleanup: $@" if length $@; } }; -our @signames = split / /, $Config{sig_name}; - -sub waitstatusmsg () { - if (!$?) { - return "terminated, reporting successful completion"; - } elsif (!($? & 255)) { - return "failed with error exit status ".WEXITSTATUS($?); - } elsif (WIFSIGNALED($?)) { - my $signum=WTERMSIG($?); - return "died due to fatal signal ". - ($signames[$signum] // "number $signum"). - ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP - } else { - return "failed with unknown wait status ".$?; - } -} - -sub printdebug { print DEBUG $debugprefix, @_ or die $!; } +sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; } -sub fail { - die $us.($we_are_responder ? " (build host)" : "").": @_\n"; +sub forceable_fail ($$) { + my ($forceoptsl, $msg) = @_; + fail $msg unless grep { $forceopts{$_} } @$forceoptsl; + print STDERR "warning: overriding problem due to --force:\n". $msg; } -sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; } +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 ($) { + my ($enquiry) = @_; + return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies; +} + +sub deliberately_not_fast_forward () { + foreach (qw(not-fast-forward fresh-repo)) { + return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_"); + } +} + +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: -# < dgit-remote-push-ready [optional extra info ignored by old initiators] +# $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>... +# where <rargs> is <push-host-dir> <supported-proto-vsn>,... ... +# < dgit-remote-push-ready <actual-proto-vsn> +# +# occasionally: +# +# > progress NBYTES +# [NBYTES message] +# +# > supplementary-message NBYTES # $protovsn >= 3 +# [NBYTES message] +# +# main sequence: # # > file parsed-changelog # [indicates that output of dpkg-parsechangelog follows] @@ -195,7 +311,13 @@ sub changedir ($) { # > 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] @@ -275,7 +397,7 @@ sub protocol_send_file ($$) { sub protocol_read_bytes ($$) { my ($fh, $nbytes) = @_; - $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count"; + $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count"; my $d; my $got = read $fh, $d, $nbytes; $got==$nbytes or badproto_badread $fh, "data block"; @@ -365,43 +487,9 @@ sub url_get { our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); -sub shellquote { - my @out; - local $_; - foreach my $a (@_) { - $_ = $a; - if (m{[^-=_./0-9a-z]}i) { - s{['\\]}{'\\$&'}g; - push @out, "'$_'"; - } else { - push @out, $_; - } - } - return join ' ', @out; -} - -sub printcmd { - my $fh = shift @_; - my $intro = shift @_; - print $fh $intro," " or die $!; - print $fh shellquote @_ or die $!; - print $fh "\n" or die $!; -} - -sub failedcmd { - { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; }; - if ($!) { - fail "failed to fork/exec: $!"; - } elsif ($?) { - fail "subprocess ".waitstatusmsg(); - } else { - fail "subprocess produced invalid output"; - } -} - sub runcmd { - printcmd(\*DEBUG,$debugprefix."+",@_) if $debug>0; - $!=0; $?=0; + debugcmd "+",@_; + $!=0; $?=-1; failedcmd @_ if system @_; } @@ -410,33 +498,12 @@ 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)"; } } -sub cmdoutput_errok { - die Dumper(\@_)." ?" if grep { !defined } @_; - printcmd(\*DEBUG,$debugprefix."|",@_) if $debug>0; - open P, "-|", @_ or die $!; - my $d; - $!=0; $?=0; - { local $/ = undef; $d = <P>; } - die $! if P->error; - if (!close P) { printdebug "=>!$?\n" if $debug>0; return undef; } - chomp $d; - $d =~ m/^.*/; - printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #'; - return $d; -} - -sub cmdoutput { - my $d = cmdoutput_errok @_; - defined $d or failedcmd @_; - return $d; -} - sub dryrun_report { printcmd(\*STDERR,$debugprefix."#",@_); } @@ -466,7 +533,8 @@ our $helpmsg = <<END; main usages: dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir] dgit [dgit-opts] fetch|pull [dgit-opts] [suite] - dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts] + dgit [dgit-opts] build [dpkg-buildpackage-opts] + dgit [dgit-opts] sbuild [sbuild-opts] dgit [dgit-opts] push [dgit-opts] [suite] dgit [dgit-opts] rpush build-host:build-dir ... important dgit options: @@ -500,18 +568,55 @@ sub cmd_help () { our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset"; our %defcfg = ('dgit.default.distro' => 'debian', + 'dgit.default.default-suite' => 'unstable', + 'dgit.default.old-dsc-distro' => 'debian', + 'dgit-suite.*-security.distro' => 'debian-security', 'dgit.default.username' => '', 'dgit.default.archive-query-default-component' => 'main', 'dgit.default.ssh' => 'ssh', - 'dgit-distro.debian.git-host' => 'git.debian.org', - 'dgit-distro.debian.git-proto' => 'git+ssh://', - 'dgit-distro.debian.git-path' => '/git/dgit-repos/repos', - 'dgit-distro.debian.git-check' => 'ssh-cmd', - 'dgit-distro.debian.git-create' => 'ssh-cmd', - 'dgit-distro.debian.sshpsql-host' => 'mirror.ftp-master.debian.org', - 'dgit-distro.debian.sshpsql-dbname' => 'service=projectb', + 'dgit.default.archive-query' => 'madison:', + 'dgit.default.sshpsql-dbname' => 'service=projectb', + 'dgit.default.aptget-components' => 'main', + 'dgit.default.dgit-tag-format' => 'new,old,maint', + 'dgit.dsc-url-proto-ok.http' => 'true', + 'dgit.dsc-url-proto-ok.https' => 'true', + 'dgit.dsc-url-proto-ok.git' => 'true', + 'dgit.default.dsc-url-proto-ok' => 'false', + # old means "repo server accepts pushes with old dgit tags" + # new means "repo server accepts pushes with new dgit tags" + # maint means "repo server accepts split brain pushes" + # hist means "repo server may have old pushes without new tag" + # ("hist" is implied by "old") + 'dgit-distro.debian.archive-query' => 'ftpmasterapi:', + 'dgit-distro.debian.git-check' => 'url', + 'dgit-distro.debian.git-check-suffix' => '/info/refs', + 'dgit-distro.debian.new-private-pushers' => 't', + 'dgit-distro.debian/push.git-url' => '', + 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org', + 'dgit-distro.debian/push.git-user-force' => 'dgit', + 'dgit-distro.debian/push.git-proto' => 'git+ssh://', + 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos', + 'dgit-distro.debian/push.git-create' => 'true', + 'dgit-distro.debian/push.git-check' => 'ssh-cmd', + 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/', +# 'dgit-distro.debian.archive-query-tls-key', +# '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem', +# ^ this does not work because curl is broken nowadays +# Fixing #790093 properly will involve providing providing the key +# in some pacagke and maybe updating these paths. +# +# 'dgit-distro.debian.archive-query-tls-curl-args', +# '--ca-path=/etc/ssl/ca-debian', +# ^ this is a workaround but works (only) on DSA-administered machines + 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org', + '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', @@ -523,45 +628,112 @@ 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' => "dummycat:$td/aq", + '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 %gitcfgs; +our @gitcfgsources = qw(cmdline local global system); + +sub git_slurp_config () { + local ($debuglevel) = $debuglevel-2; + local $/="\0"; + + # 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 (<GITS>) { + chomp or die; + printdebug "=> ", (messagequote $_), "\n"; + m/\n/ or die "$_ ?"; + push @{ $gitcfgs{$src}{$`} }, $'; #'; + } + $!=0; $?=0; + close GITS + or ($!==0 && $?==256) + or failedcmd @cmd; + } +} + +sub git_get_config ($) { + my ($c) = @_; + foreach my $src (@gitcfgsources) { + my $l = $gitcfgs{$src}{$c}; + confess "internal error ($l $c)" if $l && !ref $l; + printdebug"C $c ".(defined $l ? + join " ", map { 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 { foreach my $c (@_) { return undef if $c =~ /RETURN-UNDEF/; - my @cmd = (@git, qw(config --), $c); - my $v; - { - local ($debug) = $debug-1; - $v = cmdoutput_errok @cmd; - }; - if ($?==0) { - return $v; - } elsif ($?!=256) { - failedcmd @cmd; - } + printdebug "C? $c\n" if $debuglevel >= 5; + my $v = git_get_config($c); + return $v if defined $v; my $dv = $defcfg{$c}; - return $dv if defined $dv; + if (defined $dv) { + printdebug "CD $c $dv\n" if $debuglevel >= 4; + return $dv; + } } badcfg "need value for one of: @_\n". "$us: distro or suite appears not to be (properly) supported"; } -sub access_basedistro () { +sub access_basedistro__noalias () { if (defined $idistro) { - return cfg("dgit-distro.basedistro.distro", - "dgit-suite.$isuite.distro", - 'RETURN-UNDEF') // $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_basedistro () { + my $noalias = access_basedistro__noalias(); + my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF'); + return $canon // $noalias; +} + +sub access_nomdistro () { + my $base = access_basedistro(); + my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base; + $r =~ m/^$distro_re$/ or badcfg + "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)"; + return $r; +} + sub access_quirk () { - # returns (quirk name, distro to use instead, quirk-specific info) + # returns (quirk name, distro to use instead or undef, quirk-specific info) my $basedistro = access_basedistro(); my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk", 'RETURN-UNDEF'); @@ -575,25 +747,136 @@ sub access_quirk () { return ('backports',"$basedistro-backports",$1); } } - return ('none',$basedistro); + return ('none',undef); +} + +our $access_forpush; + +sub parse_cfg_bool ($$$) { + my ($what,$def,$v) = @_; + $v //= $def; + return + $v =~ m/^[ty1]/ ? 1 : + $v =~ m/^[fn0]/ ? 0 : + badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'"; +} + +sub access_forpush_config () { + my $d = access_basedistro(); + + return 1 if + $new_package && + parse_cfg_bool('new-private-pushers', 0, + cfg("dgit-distro.$d.new-private-pushers", + 'RETURN-UNDEF')); + + my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF'); + $v //= 'a'; + return + $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0 + $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1 + $v =~ m/^[a]/ ? '' : # auto, forpush = '' + badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)"; } -sub access_distro () { - return (access_quirk())[1]; +sub access_forpush () { + $access_forpush //= access_forpush_config(); + return $access_forpush; +} + +sub pushing () { + die "$access_forpush ?" if ($access_forpush // 1) ne 1; + badcfg "pushing but distro is configured readonly" + if access_forpush_config() eq '0'; + $access_forpush = 1; + $supplementary_message = <<'END' unless $we_are_responder; +Push failed, before we got started. +You can retry the push, after fixing the problem, if you like. +END + parseopts_late_defaults(); +} + +sub notpushing () { + parseopts_late_defaults(); +} + +sub supplementary_message ($) { + my ($msg) = @_; + if (!$we_are_responder) { + $supplementary_message = $msg; + return; + } elsif ($protovsn >= 3) { + responder_send_command "supplementary-message ".length($msg) + or die $!; + print PO $msg or die $!; + } +} + +sub access_distros () { + # Returns list of distros to try, in order + # + # We want to try: + # 0. `instead of' distro name(s) we have been pointed to + # 1. the access_quirk distro, if any + # 2a. the user's specified distro, or failing that } basedistro + # 2b. the distro calculated from the suite } + my @l = access_basedistro(); + + my (undef,$quirkdistro) = access_quirk(); + unshift @l, $quirkdistro; + unshift @l, $instead_distro; + @l = grep { defined } @l; + + push @l, access_nomdistro(); + + if (access_forpush()) { + @l = map { ("$_/push", $_) } @l; + } + @l; +} + +sub access_cfg_cfgs (@) { + my (@keys) = @_; + my @cfgs; + # The nesting of these loops determines the search order. We put + # the key loop on the outside so that we search all the distros + # for each key, before going on to the next key. That means that + # if access_cfg is called with a more specific, and then a less + # specific, key, an earlier distro can override the less specific + # without necessarily overriding any more specific keys. (If the + # distro wants to override the more specific keys it can simply do + # so; whereas if we did the loop the other way around, it would be + # impossible to for an earlier distro to override a less specific + # key but not the more specific ones without restating the unknown + # values of the more specific keys. + my @realkeys; + my @rundef; + # We have to deal with RETURN-UNDEF specially, so that we don't + # terminate the search prematurely. + foreach (@keys) { + if (m/RETURN-UNDEF/) { push @rundef, $_; last; } + push @realkeys, $_ + } + foreach my $d (access_distros()) { + push @cfgs, map { "dgit-distro.$d.$_" } @realkeys; + } + push @cfgs, map { "dgit.default.$_" } @realkeys; + push @cfgs, @rundef; + return @cfgs; } sub access_cfg (@) { my (@keys) = @_; - my $basedistro = access_basedistro(); - my $distro = $idistro || access_distro(); - my $value = cfg(map { - ("dgit-distro.$distro.$_", - "dgit-distro.$basedistro.$_", - "dgit.default.$_") - } @keys); + my (@cfgs) = access_cfg_cfgs(@keys); + my $value = cfg(@cfgs); return $value; } +sub access_cfg_bool ($$) { + my ($def, @keys) = @_; + parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF')); +} + sub string_to_ssh ($) { my ($spec) = @_; if ($spec =~ m/\s/) { @@ -612,9 +895,16 @@ sub access_cfg_ssh () { } } +sub access_runeinfo ($) { + my ($info) = @_; + return ": dgit ".access_basedistro()." $info ;"; +} + sub access_someuserhost ($) { my ($some) = @_; - my $user = access_cfg("$some-user",'username'); + my $user = access_cfg("$some-user-force", 'RETURN-UNDEF'); + defined($user) && length($user) or + $user = access_cfg("$some-user",'username'); my $host = access_cfg("$some-host"); return length($user) ? "$user\@$host" : $host; } @@ -623,15 +913,22 @@ sub access_gituserhost () { return access_someuserhost('git'); } -sub access_giturl () { +sub access_giturl (;$) { + my ($optional) = @_; my $url = access_cfg('git-url','RETURN-UNDEF'); - if (!defined $url) { + my $suffix; + if (!length $url) { + my $proto = access_cfg('git-proto', 'RETURN-UNDEF'); + return undef unless defined $proto; $url = - access_cfg('git-proto'). + $proto. access_gituserhost(). access_cfg('git-path'); + } else { + $suffix = access_cfg('git-url-suffix','RETURN-UNDEF'); } - return "$url/$package.git"; + $suffix //= '.git'; + return "$url/$package$suffix"; } sub parsecontrolfh ($$;$) { @@ -661,10 +958,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; @@ -674,11 +971,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 $!; @@ -687,21 +984,17 @@ sub parsechangelog { return $c; } -sub git_get_ref ($) { - my ($refname) = @_; - my $got = cmdoutput_errok @git, qw(show-ref --), $refname; - if (!defined $got) { - $?==256 or fail "git show-ref failed (status $?)"; - printdebug "ref $refname= [show-ref exited 1]\n"; - return ''; - } - if ($got =~ m/^(\w+) \Q$refname\E$/m) { - printdebug "ref $refname=$1\n"; - return $1; - } else { - printdebug "ref $refname= [no match]\n"; - return ''; - } +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 () { @@ -710,25 +1003,29 @@ sub must_getcwd () { return $d; } +sub parse_dscdata () { + my $dscfh = new IO::File \$dscdata, '<' or die $!; + printdebug Dumper($dscdata) if $debuglevel>1; + $dsc = parsecontrolfh($dscfh,$dscurl,1); + printdebug Dumper($dsc) if $debuglevel>1; +} + our %rmad; -sub archive_query ($) { - my ($method) = @_; +sub archive_query ($;@) { + my ($method) = shift @_; + fail "this operation does not support multiple comma-separated suites" + if $isuite =~ m/,/; my $query = access_cfg('archive-query','RETURN-UNDEF'); - if (!defined $query) { - my $distro = access_basedistro(); - if ($distro eq 'debian') { - $query = "sshpsql:". - access_someuserhost('sshpsql').':'. - access_cfg('sshpsql-dbname'); - } else { - $query = "madison:$distro"; - } - } $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 ($$) { @@ -737,17 +1034,338 @@ sub pool_dsc_subpath ($$) { return "/pool/$component/$prefix/$package/".dscfn($vsn); } -sub archive_query_madison ($$) { +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 = (@curl, qw(-sS)); + my $url = access_cfg('archive-query-url'); + if ($url =~ m#^https://([-.0-9a-z]+)/#) { + my $host = $1; + my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //''; + foreach my $key (split /\:/, $keys) { + $key =~ s/\%HOST\%/$host/g; + if (!stat $key) { + fail "for $url: stat $key: $!" unless $!==ENOENT; + next; + } + fail "config requested specific TLS key but do not know". + " how to get curl to use exactly that EE key ($key)"; +# push @cmd, "--cacert", $key, "--capath", "/dev/enoent"; +# # Sadly the above line does not work because of changes +# # to gnutls. The real fix for #790093 may involve +# # new curl options. + last; + } + # Fixing #790093 properly will involve providing a value + # for this on clients. + my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF'); + push @cmd, split / /, $kargs if defined $kargs; + } + push @cmd, $url.$subpath; + return @cmd; +} + +sub api_query ($$;$) { + use JSON; + 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 { + my ($proto,$data) = @_; + my $suites = api_query($data, 'suites'); + my @matched; + foreach my $entry (@$suites) { + next unless grep { + my $v = $entry->{$_}; + defined $v && $v eq $isuite; + } qw(codename name); + push @matched, $entry; + } + fail "unknown suite $isuite" unless @matched; + my $cn; + eval { + @matched==1 or die "multiple matches for suite $isuite\n"; + $cn = "$matched[0]{codename}"; + defined $cn or die "suite $isuite info has no codename\n"; + $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n"; + }; + die "bad ftpmaster api response: $@\n".Dumper(\@matched) + if length $@; + return $cn; +} + +sub archive_query_ftpmasterapi { + my ($proto,$data) = @_; + my $info = api_query($data, "dsc_in_suite/$isuite/$package"); + my @rows; + my $digester = Digest::SHA->new(256); + foreach my $entry (@$info) { + eval { + my $vsn = "$entry->{version}"; + my ($ok,$msg) = version_check $vsn; + die "bad version: $msg\n" unless $ok; + my $component = "$entry->{component}"; + $component =~ m/^$component_re$/ or die "bad component"; + my $filename = "$entry->{filename}"; + $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]# + or die "bad filename"; + my $sha256sum = "$entry->{sha256sum}"; + $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum"; + push @rows, [ $vsn, "/pool/$component/$filename", + $digester, $sha256sum ]; + }; + die "bad ftpmaster api response: $@\n".Dumper($entry) + if length $@; + } + @rows = sort { -version_compare($a->[0],$b->[0]) } @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 <<END; +Debug::NoLocking "true"; +APT::Get::List-Cleanup "false"; +#clear APT::Update::Post-Invoke-Success; +Dir::Etc::SourceList "$quoted_base/$sourceslist"; +Dir::State::Lists "$quoted_base/lists"; +Dir::Etc::preferences "$quoted_base/preferences"; +Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey"; +Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey"; +END + + foreach my $key (qw( + Dir::Cache + Dir::State + Dir::Cache::Archives + Dir::Etc::SourceParts + Dir::Etc::preferencesparts + )) { + ensuredir "$aptget_base/$key"; + print CONF "$key \"$quoted_base/$key\";\n" or die $!; + }; + + my $oldatime = (time // die $!) - 1; + foreach my $oldlist (<$aptget_base/lists/*Release>) { + 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 ]; +} + +sub file_in_archive_aptget () { return undef; } + +#---------- `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 (<FIA>) { + 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 archive_query_prepend_mirror + map { [ @$_[0..1] ] } madison_get_parse(@_); +} + +sub madison_get_parse { my ($proto,$data) = @_; die unless $proto eq 'madison'; - $rmad{$package} ||= cmdoutput + if (!length $data) { + $data= access_cfg('madison-distro','RETURN-UNDEF'); + $data //= access_basedistro(); + } + $rmad{$proto,$data,$package} ||= cmdoutput qw(rmadison -asource),"-s$isuite","-u$data",$package; - my $rmad = $rmad{$package}; - return madison_parse($rmad); -} + my $rmad = $rmad{$proto,$data,$package}; -sub madison_parse ($) { - my ($rmad) = @_; my @out; foreach my $l (split /\n/, $rmad) { $l =~ m{^ \s*( [^ \t|]+ )\s* \| @@ -766,12 +1384,12 @@ sub madison_parse ($) { $5 eq 'source' or die "$rmad ?"; push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite]; } - return sort { -version_compare_string($a->[0],$b->[0]); } @out; + return sort { -version_compare($a->[0],$b->[0]); } @out; } -sub canonicalise_suite_madison ($$) { +sub canonicalise_suite_madison { # madison canonicalises for us - my @r = archive_query_madison($_[0],$_[1]); + my @r = madison_get_parse(@_); @r or fail "unable to canonicalise suite using package $package". " which does not appear to exist in suite $isuite;". @@ -779,18 +1397,28 @@ sub canonicalise_suite_madison ($$) { return $r[0][2]; } -sub sshpsql ($$) { - my ($data,$sql) = @_; +sub file_in_archive_madison { return undef; } + +#---------- `sshpsql' archive query method ---------- + +sub sshpsql ($$$) { + my ($data,$runeinfo,$sql) = @_; + if (!length $data) { + $data= access_someuserhost('sshpsql').':'. + access_cfg('sshpsql-dbname'); + } $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'"; my ($userhost,$dbname) = ($`,$'); #'; my @rows; my @cmd = (access_cfg_ssh, $userhost, - "export LANG=C; ".shellquote qw(psql -A), $dbname, qw(-c), $sql); - printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0; + access_runeinfo("ssh-psql $runeinfo"). + " export LC_MESSAGES=C; export LC_CTYPE=C;". + " ".shellquote qw(psql -A), $dbname, qw(-c), $sql); + debugcmd "|",@cmd; open P, "-|", @cmd or die $!; while (<P>) { chomp or die; - printdebug("$debugprefix>|$_|\n"); + printdebug(">|$_|\n"); push @rows, $_; } $!=0; $?=0; close P or failedcmd @cmd; @@ -805,13 +1433,13 @@ sub sshpsql ($$) { } sub sql_injection_check { - foreach (@_) { die "$_ $& ?" if m/[']/; } + foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; } } sub archive_query_sshpsql ($$) { my ($proto,$data) = @_; sql_injection_check $isuite, $package; - my @rows = sshpsql($data, <<END); + my @rows = sshpsql($data, "archive-query $isuite $package", <<END); SELECT source.version, component.name, files.filename, files.sha256sum FROM source JOIN src_associations ON source.id = src_associations.source @@ -824,19 +1452,19 @@ sub archive_query_sshpsql ($$) { AND source.source='$package' AND files.filename LIKE '%.dsc'; END - @rows = sort { -version_compare_string($a->[0],$b->[0]) } @rows; + @rows = sort { -version_compare($a->[0],$b->[0]) } @rows; my $digester = Digest::SHA->new(256); @rows = map { my ($vsn,$component,$filename,$sha256sum) = @$_; [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ]; } @rows; - return @rows; + return archive_query_prepend_mirror @rows; } sub canonicalise_suite_sshpsql ($$) { my ($proto,$data) = @_; sql_injection_check $isuite; - my @rows = sshpsql($data, <<END); + my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END); SELECT suite.codename FROM suite where suite_name='$isuite' or codename='$isuite'; END @@ -846,6 +1474,10 @@ END return $rows[0]; } +sub file_in_archive_sshpsql ($$$) { return undef; } + +#---------- `dummycat' archive query method ---------- + sub canonicalise_suite_dummycat ($$) { my ($proto,$data) = @_; my $dpath = "$data/suite.$isuite"; @@ -882,15 +1514,73 @@ sub archive_query_dummycat ($$) { } C->error and die "$dpath: $!"; close C; - return sort { -version_compare_string($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 access_cfg_tagformats_can_splitbrain () { + my %y = map { $_ => 1 } access_cfg_tagformats; + foreach my $needtf (qw(new maint)) { + next if $y{$needtf}; + return 0; + } + return 1; +} + +sub need_tagformat ($$) { + my ($fmt, $why) = @_; + fail "need to use tag format $fmt ($why) but also need". + " to use tag format $tagformat_want->[0] ($tagformat_want->[1])". + " - no way to proceed" + if $tagformat_want && $tagformat_want->[0] ne $fmt; + $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0]; +} + +sub select_tagformat () { + # sets $tagformatfn + return if $tagformatfn && !$tagformat_want; + die 'bug' if $tagformatfn && $tagformat_want; + # ... $tagformat_want assigned after previous select_tagformat + + my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats(); + printdebug "select_tagformat supported @supported\n"; + + $tagformat_want //= [ $supported[0], "distro access configuration", 0 ]; + printdebug "select_tagformat specified @$tagformat_want\n"; + + my ($fmt,$why,$override) = @$tagformat_want; + + fail "target distro supports tag formats @supported". + " but have to use $fmt ($why)" + unless $override + or grep { $_ eq $fmt } @supported; + + $tagformat_want = undef; + $tagformat = $fmt; + $tagformatfn = ${*::}{"debiantag_$fmt"}; + + fail "trying to use unknown tag format \`$fmt' ($why) !" + unless $tagformatfn; } +#---------- archive query entrypoints and rest of program ---------- + sub canonicalise_suite () { return if defined $csuite; fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED'; $csuite = archive_query('canonicalise_suite'); if ($isuite ne $csuite) { progress "canonical suite name for $isuite is $csuite"; + } else { + progress "canonical suite name is $csuite"; } } @@ -898,8 +1588,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; @@ -913,29 +1603,62 @@ 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 $debug>1; - $dsc = parsecontrolfh($dscfh,$dscurl,1); - printdebug Dumper($dsc) if $debug>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 (); sub check_for_git () { # returns 0 or 1 my $how = access_cfg('git-check'); if ($how eq 'ssh-cmd') { my @cmd = (access_cfg_ssh, access_gituserhost(), + access_runeinfo("git-check $package"). " set -e; cd ".access_cfg('git-path').";". " if test -d $package.git; then echo 1; else echo 0; fi"); my $r= cmdoutput @cmd; - failedcmd @cmd unless $r =~ m/^[01]$/; + 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 + $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert"); + $instead_distro =~ s{^/}{ access_basedistro()."/" }e; + progress "diverting to $divert (using config for $instead_distro)"; + return check_for_git(); + } + 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 = (@curl, qw(-sS -I), $url); + my $result = cmdoutput @cmd; + $result =~ s/^\S+ 200 .*\n\r?\n//; + # curl -sS -I with https_proxy prints + # HTTP/1.0 200 Connection established + $result =~ m/^\S+ (404|200) /s or + fail "unexpected results from git check query - ". + Dumper($prefix, $result); + my $code = $1; + if ($code eq '404') { + return 0; + } elsif ($code eq '200') { + return 1; + } else { + die; + } } elsif ($how eq 'true') { return 1; } elsif ($how eq 'false') { @@ -950,6 +1673,7 @@ sub create_remote_git_repo () { if ($how eq 'ssh-cmd') { runcmd_ordryrun (access_cfg_ssh, access_gituserhost(), + access_runeinfo("git-create $package"). "set -e; cd ".access_cfg('git-path').";". " cp -a _template $package.git"); } elsif ($how eq 'true') { @@ -959,38 +1683,90 @@ sub create_remote_git_repo () { } } -our ($dsc_hash,$lastpush_hash); +our ($dsc_hash,$lastpush_mergeinput); +our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url); our $ud = '.git/dgit/unpack'; -sub prep_ud () { - rmtree($ud); +sub prep_ud (;$) { + my ($d) = @_; + $d //= $ud; + rmtree($d); mkpath '.git/dgit'; - mkdir $ud or die $!; + mkdir $d or die $!; } -sub mktree_in_ud_from_only_subdir () { - # changes into the subdir - my (@dirs) = <*/.>; - die unless @dirs==1; - $dirs[0] =~ m#^([^/]+)/\.$# or die; - my $dir = $1; - changedir $dir; - fail "source package contains .git directory" if stat '.git'; - die $! unless $!==&ENOENT; +sub mktree_in_ud_here () { runcmd qw(git init -q); + runcmd qw(git config gc.auto 0); + foreach my $copy (qw(user.email user.name user.useConfigOnly)) { + my $v = $gitcfgs{local}{$copy}; + next unless $v; + runcmd qw(git config), $copy, $_ foreach @$v; + } rmtree('.git/objects'); symlink '../../../../objects','.git/objects' or die $!; - runcmd @git, qw(add -Af); + setup_gitattrs(1); +} + +sub git_write_tree () { my $tree = cmdoutput @git, qw(write-tree); $tree =~ m/^\w+$/ or die "$tree ?"; + return $tree; +} + +sub git_add_write_tree () { + runcmd @git, qw(add -Af .); + return git_write_tree(); +} + +sub remove_stray_gits ($) { + my ($what) = @_; + my @gitscmd = qw(find -name .git -prune -print0); + debugcmd "|",@gitscmd; + open GITS, "-|", @gitscmd or die $!; + { + local $/="\0"; + while (<GITS>) { + chomp or die; + print STDERR "$us: warning: removing from $what: ", + (messagequote $_), "\n"; + rmtree $_; + } + } + $!=0; $?=0; close GITS or failedcmd @gitscmd; +} + +sub mktree_in_ud_from_only_subdir ($;$) { + my ($what,$raw) = @_; + + # changes into the subdir + my (@dirs) = <*/.>; + die "expected one subdir but found @dirs ?" unless @dirs==1; + $dirs[0] =~ m#^([^/]+)/\.$# or die; + my $dir = $1; + changedir $dir; + + remove_stray_gits($what); + mktree_in_ud_here(); + if (!$raw) { + my ($format, $fopts) = get_source_format(); + if (madformat($format)) { + rmtree '.pc'; + } + } + + my $tree=git_add_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; @@ -1018,9 +1794,175 @@ sub dsc_files () { map { $_->{Filename} } dsc_files_info(); } -sub is_orig_file ($) { - local ($_) = @_; - m/\.orig(?:-\w+)?\.tar\.\w+$/; +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 <<END; +archive does not support .orig check; hope you used --ch:--sa/-sd if needed +END + return; + } + my $found_same = 0; + my @found_differ; + printdebug "origs $file \$#\$have=$#$have\n"; + foreach my $h (@$have) { + my $same = 0; + my @differ; + foreach my $csumi (@files_csum_info_fields) { + my ($fname, $module, $method, $archivefield) = @$csumi; + next unless defined $h->{$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 ($) { @@ -1028,223 +1970,1150 @@ 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; + if ($author =~ m/^[^"\@]+\,/) { + # single entry Maintainer field with unquoted comma + $author = ($& =~ y/,//rd).$'; # strip the comma + } + # git wants a single author; any remaining commas in $author + # are by now preceded by @ (or "). It seems safer to punt on + # "..." for now rather than attempting to dequote or something. + $author =~ s#,.*##ms unless $author =~ m/"/; 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; } -sub generate_commit_from_dsc () { +sub vendor_patches_distro ($$) { + my ($checkdistro, $what) = @_; + return unless defined $checkdistro; + + my $series = "debian/patches/\L$checkdistro\E.series"; + printdebug "checking for vendor-specific $series ($what)\n"; + + if (!open SERIES, "<", $series) { + die "$series $!" unless $!==ENOENT; + return; + } + while (<SERIES>) { + next unless m/\S/; + next if m/^\s+\#/; + + print STDERR <<END; + +Unfortunately, this source package uses a feature of dpkg-source where +the same source package unpacks to different source code on different +distros. dgit cannot safely operate on such packages on affected +distros, because the meaning of source packages is not stable. + +Please ask the distro/maintainer to remove the distro-specific series +files and use a different technique (if necessary, uploading actually +different packages, if different distros are supposed to have +different code). + +END + fail "Found active distro-specific series file for". + " $checkdistro ($what): $series, cannot continue"; + } + die "$series $!" if SERIES->error; + close SERIES; +} + +sub check_for_vendor_patches () { + # This dpkg-source feature doesn't seem to be documented anywhere! + # But it can be found in the changelog (reformatted): + + # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c + # Author: Raphael Hertzog <hertzog@debian.org> + # Date: Sun Oct 3 09:36:48 2010 +0200 + + # dpkg-source: correctly create .pc/.quilt_series with alternate + # series files + # + # If you have debian/patches/ubuntu.series and you were + # unpacking the source package on ubuntu, quilt was still + # directed to debian/patches/series instead of + # debian/patches/ubuntu.series. + # + # debian/changelog | 3 +++ + # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++- + # 2 files changed, 6 insertions(+), 1 deletion(-) + + use Dpkg::Vendor; + vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR"); + vendor_patches_distro(Dpkg::Vendor::get_current_vendor(), + "Dpkg::Vendor \`current vendor'"); + vendor_patches_distro(access_basedistro(), + "(base) distro being accessed"); + vendor_patches_distro(access_nomdistro(), + "(nominal) distro being accessed"); +} + +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$#; + my $upper_f = "../../../../$f"; + + printdebug "considering reusing $f: "; + + if (link_ltarget "$upper_f,fetch", $f) { + printdebug "linked (using ...,fetch).\n"; + } elsif ((printdebug "($!) "), + $! != ENOENT) { + fail "accessing ../$f,fetch: $!"; + } elsif (link_ltarget $upper_f, $f) { + printdebug "linked.\n"; + } elsif ((printdebug "($!) "), + $! != ENOENT) { + fail "accessing ../$f: $!"; + } else { + printdebug "absent.\n"; + } - link "../../../$f", $f - or $!==&ENOENT - or die "$f $!"; + my $refetched; + complete_file_from_dsc('.', $fi, \$refetched) + or next; + + printdebug "considering saving $f: "; + + if (link $f, $upper_f) { + printdebug "linked.\n"; + } elsif ((printdebug "($!) "), + $! != EEXIST) { + fail "saving ../$f: $!"; + } elsif (!$refetched) { + printdebug "no need.\n"; + } elsif (link $f, "$upper_f,fetch") { + printdebug "linked (using ...,fetch).\n"; + } elsif ((printdebug "($!) "), + $! != EEXIST) { + fail "saving ../$f,fetch: $!"; + } else { + printdebug "cannot.\n"; + } + } - complete_file_from_dsc('.', $fi); + # 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, ''; - if (is_orig_file($f)) { - link $f, "../../../../$f" - or $!==&EEXIST - or die "$f $!"; + 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"; + remove_stray_gits($f); + mktree_in_ud_here(); + + my ($tree) = git_add_write_tree(); + my $tentries = cmdoutput @git, qw(ls-tree -z), $tree; + if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) { + $tree = $1; + printdebug "one subtree $1\n"; + } else { + printdebug "multiple subtrees\n"; + } + changedir ".."; + 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(); - runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp'; - my $clogp = parsecontrol('../changelog.tmp',"commit's changelog"); + my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package"); + 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'; + $dappliedtree = git_add_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 $/=""; <CLOGS>; }; + 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'; + $changes =~ s/^\n//; # Changes: \n + 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} ? <<END_O : <<END_T); +tree $tt->{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 <<END or die $!; tree $tree +END + print C <<END or die $! foreach @tartrees; +parent $_->{Commit} +END + print C <<END or die $!; author $authline committer $authline $changes -# imported from the archive +[dgit import $treeimporthow $package $cversion] END + close C or die $!; - my $outputhash = make_commit qw(../commit.tmp); - my $cversion = getfield $clogp, 'Version'; + my $rawimport_hash = make_commit qw(../commit.tmp); + + if (madformat $dsc->{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(<<END); +tree $dappliedtree +author $authline +committer $authline + +[dgit dummy commit] +END + runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit; + + runcmd @git, qw(checkout -q -b unpa), $rawimport_hash; + + # We need the answers 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]; + + my $path = $ENV{PATH} or die; + + foreach my $use_absurd (qw(0 1)) { + runcmd @git, qw(checkout -q unpa); + runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa); + local $ENV{PATH} = $path; + if ($use_absurd) { + chomp $@; + progress "warning: $@"; + $path = "$absurdity:$path"; + progress "$us: trying slow absurd-git-apply..."; + rename "../../gbp-pq-output","../../gbp-pq-output.0" + or $!==ENOENT + or die $!; + } + eval { + die "forbid absurd git-apply\n" if $use_absurd + && forceing [qw(import-gitapply-no-absurd)]; + die "only absurd git-apply!\n" if !$use_absurd + && forceing [qw(import-gitapply-absurd)]; + + local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd; + local $ENV{PATH} = $path if $use_absurd; + + my @showcmd = (gbp_pq, qw(import)); + my @realcmd = shell_cmd + 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd; + debugcmd "+",@realcmd; + if (system @realcmd) { + die +(shellquote @showcmd). + " failed: ". + failedcmd_waitstatus()."\n"; + } + + my $gapplied = git_rev_parse('HEAD'); + my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:); + $gappliedtree eq $dappliedtree or + fail <<END; +gbp-pq import and dpkg-source disagree! + gbp-pq import gave commit $gapplied + gbp-pq import gave tree $gappliedtree + dpkg-source --before-build gave tree $dappliedtree +END + $rawimport_hash = $gapplied; + }; + last unless $@; + } + if ($@) { + { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; } + die $@; + } + } + progress "synthesised git commit from .dsc $cversion"; - if ($lastpush_hash) { - runcmd @git, qw(reset --hard), $lastpush_hash; - runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp'; - my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); + + my $rawimport_mergeinput = { + Commit => $rawimport_hash, + Info => "Import of source package", + }; + my @output = ($rawimport_mergeinput); + + if ($lastpush_mergeinput) { + my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput); my $oversion = getfield $oldclogp, 'Version'; my $vcmp = - version_compare_string($oversion, $cversion); + version_compare($oversion, $cversion); if ($vcmp < 0) { - # git upload/ is earlier vsn than archive, use archive - open C, ">../commit2.tmp" or die $!; - print C <<END or die $!; -tree $tree -parent $lastpush_hash -parent $outputhash -author $authline -committer $authline - + @output = ($rawimport_mergeinput, $lastpush_mergeinput, + { Message => <<END, ReverseParents => 1 }); Record $package ($cversion) in archive suite $csuite END - $outputhash = make_commit qw(../commit2.tmp); } elsif ($vcmp > 0) { print STDERR <<END or die $!; -Version actually in archive: $cversion (older) -Last allegedly pushed/uploaded: $oversion (newer or same) +Version actually in archive: $cversion (older) +Last version pushed with dgit: $oversion (newer or same) $later_warning_msg END - $outputhash = $lastpush_hash; + @output = $lastpush_mergeinput; } else { - $outputhash = $lastpush_hash; + # Same version. Use what's in the server git branch, + # discarding our own import. (This could happen if the + # server automatically imports all packages into git.) + @output = $lastpush_mergeinput; } } changedir '../../../..'; - runcmd @git, qw(update-ref -m),"dgit fetch import $cversion", - 'DGIT_ARCHIVE', $outputhash; - cmdoutput @git, qw(log -n2), $outputhash; - # ... gives git a chance to complain if our commit is malformed rmtree($ud); - return $outputhash; + return @output; } -sub complete_file_from_dsc ($$) { - our ($dstdir, $fi) = @_; - # Ensures that we have, in $dir, the file $fi, with the correct +sub complete_file_from_dsc ($$;$) { + our ($dstdir, $fi, $refetched) = @_; + # Ensures that we have, in $dstdir, the file $fi, with the correct # contents. (Downloading it from alongside $dscurl if necessary.) + # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}" + # and will set $$refetched=1 if it did so (or tried to). my $f = $fi->{Filename}; my $tf = "$dstdir/$f"; my $downloaded = 0; - if (stat $tf) { - progress "using existing $f"; + my $got; + my $checkhash = sub { + open F, "<", "$tf" or die "$tf: $!"; + $fi->{Digester}->reset(); + $fi->{Digester}->addfile(*F); + F->error and die $!; + my $got = $fi->{Digester}->hexdigest(); + return $got eq $fi->{Hash}; + }; + + if (stat_exists $tf) { + if ($checkhash->()) { + progress "using existing $f"; + return 1; + } + if (!$refetched) { + fail "file $f has hash $got but .dsc". + " demands hash $fi->{Hash} ". + "(perhaps you should delete this file?)"; + } + progress "need to fetch correct version of $f"; + unlink $tf or die "$tf $!"; + $$refetched = 1; } else { - die "$tf $!" unless $!==&ENOENT; - - my $furl = $dscurl; - $furl =~ s{/[^/]+$}{}; - $furl .= "/$f"; - die "$f ?" unless $f =~ m/^${package}_/; - die "$f ?" if $f =~ m#/#; - runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl"; - next if !act_local(); - $downloaded = 1; + printdebug "$tf does not exist, need to fetch\n"; } - open F, "<", "$tf" or die "$tf: $!"; - $fi->{Digester}->reset(); - $fi->{Digester}->addfile(*F); - F->error and die $!; - my $got = $fi->{Digester}->hexdigest(); - $got eq $fi->{Hash} or + my $furl = $dscurl; + $furl =~ s{/[^/]+$}{}; + $furl .= "/$f"; + die "$f ?" unless $f =~ m/^\Q${package}\E_/; + die "$f ?" if $f =~ m#/#; + runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl"; + return 0 if !act_local(); + + $checkhash->() or fail "file $f has hash $got but .dsc". " demands hash $fi->{Hash} ". - ($downloaded ? "(got wrong file from archive!)" - : "(perhaps you should delete this file?)"); + "(got wrong file from archive!)"; + + return 1; } sub ensure_we_have_orig () { - foreach my $fi (dsc_files_info()) { + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { my $f = $fi->{Filename}; - next unless is_orig_file($f); - complete_file_from_dsc('..', $fi); + next unless is_orig_file_in_dsc($f, \@dfi); + complete_file_from_dsc('..', $fi) + or next; } } -sub rev_parse ($) { - return cmdoutput @git, qw(rev-parse), "$_[0]~0"; +#---------- git fetch ---------- + +sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); } +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, each 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 is_fast_fwd ($$) { - my ($ancestor,$child) = @_; - my @cmd = (@git, qw(merge-base), $ancestor, $child); - my $mb = cmdoutput_errok @cmd; - if (defined $mb) { - return rev_parse($mb) eq rev_parse($ancestor); - } else { - $?==256 or failedcmd @cmd; - return 0; +sub git_lrfetch_sane { + my ($url, $supplementary, @specs) = @_; + # Make a 'refs/'.lrfetchrefs.'/*' be just like on server, + # at least as regards @specs. Also leave the results in + # %lrfetchrefs_f, and arrange for lrfetchref_used to be + # able to clean these up. + # + # With $supplementary==1, @specs must not contain wildcards + # and we add to our previous fetches (non-atomically). + + # 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_lrfetch_sane suppl=$supplementary specs @specs\n"; + + my $specre = join '|', map { + my $x = $_; + $x =~ s/\W/\\$&/g; + my $wildcard = $x =~ s/\\\*$/.*/; + die if $wildcard && $supplementary; + "(?:refs/$x)"; + } @specs; + printdebug "git_lrfetch_sane specre=$specre\n"; + my $wanted_rref = sub { + local ($_) = @_; + return m/^(?:$specre)$/; + }; + + my $fetch_iteration = 0; + FETCH_ITERATION: + for (;;) { + printdebug "git_lrfetch_sane 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), $url, @look); + debugcmd "|",@lcmd; + + my %wantr; + open GITLS, "-|", @lcmd or die $!; + while (<GITLS>) { + printdebug "=> ", $_; + m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?"; + my ($objid,$rrefname) = ($1,$2); + if (!$wanted_rref->($rrefname)) { + print STDERR <<END; +warning: git ls-remote @look reported $rrefname; this is silly, ignoring it. +END + next; + } + $wantr{$rrefname} = $objid; + } + $!=0; $?=0; + close GITLS or failedcmd @lcmd; + + # OK, now %want is exactly what we want for refs in @specs + my @fspecs = map { + !m/\*$/ && !exists $wantr{"refs/$_"} ? () : + "+refs/$_:".lrfetchrefs."/$_"; + } @specs; + + printdebug "git_lrfetch_sane fspecs @fspecs\n"; + + my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs); + runcmd_ordryrun_local @fcmd if @fspecs; + + if (!$supplementary) { + %lrfetchrefs_f = (); + } + my %objgot; + + git_for_each_ref(lrfetchrefs, sub { + my ($objid,$objtype,$lrefname,$reftail) = @_; + $lrfetchrefs_f{$lrefname} = $objid; + $objgot{$objid} = 1; + }); + + if ($supplementary) { + last; + } + + foreach my $lrefname (sort keys %lrfetchrefs_f) { + my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs); + if (!exists $wantr{$rrefname}) { + if ($wanted_rref->($rrefname)) { + printdebug <<END; +git-fetch @fspecs created $lrefname which git ls-remote @look didn't list. +END + } else { + print STDERR <<END +warning: git fetch @fspecs created $lrefname; this is silly, deleting it. +END + } + runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname; + delete $lrfetchrefs_f{$lrefname}; + next; + } + } + foreach my $rrefname (sort keys %wantr) { + my $lrefname = lrfetchrefs.substr($rrefname, 4); + my $got = $lrfetchrefs_f{$lrefname} // '<none>'; + my $want = $wantr{$rrefname}; + next if $got eq $want; + if (!defined $objgot{$want}) { + print STDERR <<END; +warning: git ls-remote suggests we want $lrefname +warning: and it should refer to $want +warning: but git fetch didn't fetch that object to any relevant ref. +warning: This may be due to a race with someone updating the server. +warning: Will try again... +END + next FETCH_ITERATION; + } + printdebug <<END; +git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want +END + runcmd_ordryrun_local @git, qw(update-ref -m), + "dgit fetch git fetch fixup", $lrefname, $want; + $lrfetchrefs_f{$lrefname} = $want; + } + last; + } + + if (defined $csuite) { + printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n"; + git_for_each_ref("refs/dgit-fetch/$csuite", sub { + my ($objid,$objtype,$lrefname,$reftail) = @_; + next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ? + runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname; + }); } + + printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n", + Dumper(\%lrfetchrefs_f); } sub git_fetch_us () { - runcmd_ordryrun_local @git, qw(fetch),access_giturl(),fetchspec(); + # 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, $rewritemap; + push @specs, qw(heads/*) if deliberately_not_fast_forward; + + my $url = access_giturl(); + git_lrfetch_sane $url, 0, @specs; + + my %here; + my @tagpats = debiantags('*',access_nomdistro); + + git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub { + my ($objid,$objtype,$fullrefname,$reftail) = @_; + printdebug "currently $fullrefname=$objid\n"; + $here{$fullrefname} = $objid; + }); + git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub { + my ($objid,$objtype,$fullrefname,$reftail) = @_; + my $lref = "refs".substr($fullrefname, length(lrfetchrefs)); + printdebug "offered $lref=$objid\n"; + if (!defined $here{$lref}) { + my @upd = (@git, qw(update-ref), $lref, $objid, ''); + runcmd_ordryrun_local @upd; + lrfetchref_used $fullrefname; + } elsif ($here{$lref} eq $objid) { + lrfetchref_used $fullrefname; + } else { + print STDERR + "Not updating $lref from $here{$lref} to $objid.\n"; + } + }); +} + +#---------- dsc and archive handling ---------- + +sub mergeinfo_getclogp ($) { + # Ensures thit $mi->{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 parse_dsc_field_def_dsc_distro () { + $dsc_distro //= cfg qw(dgit.default.old-dsc-distro + dgit.default.distro); +} + +sub parse_dsc_field ($$) { + my ($dsc, $what) = @_; + my $f; + foreach my $field (@ourdscfield) { + $f = $dsc->{$field}; + last if defined $f; + } + + if (!defined $f) { + progress "$what: NO git hash"; + parse_dsc_field_def_dsc_distro(); + } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url) + = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) { + progress "$what: specified git info ($dsc_distro)"; + $dsc_hint_tag = [ $dsc_hint_tag ]; + } elsif ($f =~ m/^\w+\s*$/) { + $dsc_hash = $&; + parse_dsc_field_def_dsc_distro(); + $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'), + $dsc_distro ]; + progress "$what: specified git hash"; + } else { + fail "$what: invalid Dgit info"; + } +} + +sub resolve_dsc_field_commit ($$) { + my ($already_distro, $already_mapref) = @_; + + return unless defined $dsc_hash; + + my $mapref = + defined $already_mapref && + ($already_distro eq $dsc_distro || !$chase_dsc_distro) + ? $already_mapref : undef; + + my $do_fetch; + $do_fetch = sub { + my ($what, @fetch) = @_; + + local $idistro = $dsc_distro; + my $lrf = lrfetchrefs; + + if (!$chase_dsc_distro) { + progress + "not chasing .dsc distro $dsc_distro: not fetching $what"; + return 0; + } + + progress + ".dsc names distro $dsc_distro: fetching $what"; + + my $url = access_giturl(); + if (!defined $url) { + defined $dsc_hint_url or fail <<END; +.dsc Dgit metadata is in context of distro $dsc_distro +for which we have no configured url and .dsc provides no hint +END + my $proto = + $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 : + $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax'; + parse_cfg_bool "dsc-url-proto-ok", 'false', + cfg("dgit.dsc-url-proto-ok.$proto", + "dgit.default.dsc-url-proto-ok") + or fail <<END; +.dsc Dgit metadata is in context of distro $dsc_distro +for which we have no configured url; +.dsc provides hinted url with protocol $proto which is unsafe. +(can be overridden by config - consult documentation) +END + $url = $dsc_hint_url; + } + + git_lrfetch_sane $url, 1, @fetch; + + return $lrf; + }; + + my $rewrite_enable = do { + local $idistro = $dsc_distro; + access_cfg('rewrite-map-enable', 'RETURN-UNDEF'); + }; + + if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) { + if (!defined $mapref) { + my $lrf = $do_fetch->("rewrite map", $rewritemap) or return; + $mapref = $lrf.'/'.$rewritemap; + } + my $rewritemapdata = git_cat_file $mapref.':map'; + if (defined $rewritemapdata + && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) { + progress + "server's git history rewrite map contains a relevant entry!"; + + $dsc_hash = $1; + if (defined $dsc_hash) { + progress "using rewritten git hash in place of .dsc value"; + } else { + progress "server data says .dsc hash is to be disregarded"; + } + } + } + + if (!defined git_cat_file $dsc_hash) { + my @tags = map { "tags/".$_ } @$dsc_hint_tag; + my $lrf = $do_fetch->("additional commits", @tags) && + defined git_cat_file $dsc_hash + or fail <<END; +.dsc Dgit metadata requires commit $dsc_hash +but we could not obtain that object anywhere. +END + foreach my $t (@tags) { + my $fullrefname = $lrf.'/'.$t; +# print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f); + next unless $lrfetchrefs_f{$fullrefname}; + next unless is_fast_fwd "$fullrefname~0", $dsc_hash; + lrfetchref_used $fullrefname; + } + } } 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) { - foreach my $field (@ourdscfield) { - $dsc_hash = $dsc->{$field}; - last if defined $dsc_hash; - } - if (defined $dsc_hash) { - $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'"; - $dsc_hash = $&; - progress "last upload to archive specified git hash"; - } else { - progress "last upload to archive has NO git hash"; - } + parse_dsc_field($dsc, 'last upload to archive'); + resolve_dsc_field_commit access_basedistro, + lrfetchrefs."/".$rewritemap } else { 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 <<END or die $!; Git commit in archive is behind the last version allegedly pushed/uploaded. -Commit referred to by archive: $dsc_hash -Last allegedly pushed/uploaded: $lastpush_hash +Commit referred to by archive: $dsc_hash +Last version pushed with dgit: $lastpush_hash $later_warning_msg END - $hash = $lastpush_hash; + @mergeinputs = ($lastpush_mergeinput); } else { - fail "archive's .dsc refers to ".$dsc_hash. - " but this is an ancestor of ".$lastpush_hash; + # Archive has .dsc which is not a descendant of the last dgit + # push. This can happen if the archive moves .dscs about. + # Just follow its lead. + if (is_fast_fwd($lastpush_hash,$dsc_hash)) { + progress "archive .dsc names newer git commit"; + @mergeinputs = ($dsc_mergeinput); + } else { + progress "archive .dsc names other git commit, fixing up"; + @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput); + } } } elsif ($dsc) { - $hash = generate_commit_from_dsc(); + @mergeinputs = generate_commits_from_dsc(); + # We have just done an import. Now, our import algorithm might + # have been improved. But even so we do not want to generate + # a new different import of the same package. So if the + # version numbers are the same, just use our existing version. + # If the version numbers are different, the archive has changed + # (perhaps, rewound). + if ($lastfetch_mergeinput && + !version_compare( (mergeinfo_version $lastfetch_mergeinput), + (mergeinfo_version $mergeinputs[0]) )) { + @mergeinputs = ($lastfetch_mergeinput); + } } elsif ($lastpush_hash) { # only in git, not in the archive yet - $hash = $lastpush_hash; + @mergeinputs = ($lastpush_mergeinput); print STDERR <<END or die $!; Package not found in the archive, but has allegedly been pushed using dgit. @@ -1261,24 +3130,131 @@ But we were not able to obtain any version from the archive or git. END } - return 0; + unshift @end, $del_lrfetchrefs; + return undef; } - printdebug "current hash=$hash\n"; - if ($lastpush_hash) { - fail "not fast forward on last upload branch!". - " (archive's version left in DGIT_ARCHIVE)" - unless is_fast_fwd($lastpush_hash, $hash); + + if ($lastfetch_hash && + !grep { + my $h = $_->{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 <<END or die $!; +tree $tree +END + + my @parents = grep { $_->{Commit} } @mergeinputs; + @parents = reverse @parents if $compat_info->{ReverseParents}; + print MC <<END or die $! foreach @parents; +parent $_->{Commit} +END + + print MC <<END or die $!; +author $author +committer $author + +END + + if (defined $compat_info->{Message}) { + print MC $compat_info->{Message} or die $!; + } else { + print MC <<END or die $!; +Record $package ($cversion) in archive suite $csuite + +Record that +END + my $message_add_info = sub { + my ($mi) = (@_); + my $mversion = mergeinfo_version $mi; + printf MC " %-20s %s\n", $mversion, $mi->{Info} + or die $!; + }; + + $message_add_info->($mergeinputs[0]); + print MC <<END or die $!; +should be treated as descended from +END + $message_add_info->($_) 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_string($got_vsn, $skew_warning_vsn) < 0) { + if (version_compare($got_vsn, $skew_warning_vsn) < 0) { print STDERR <<END or die $!; Warning: archive skew detected. Using the available version: @@ -1288,30 +3264,364 @@ 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); + } + + lrfetchref_used lrfetchref(); + + check_gitattrs($hash, "fetched source tree"); + + unshift @end, $del_lrfetchrefs; + return $hash; +} + +sub set_local_git_config ($$) { + my ($k, $v) = @_; + runcmd @git, qw(config), $k, $v; +} + +sub setup_mergechangelogs (;$) { + my ($always) = @_; + return unless $always || access_cfg_bool(1, 'setup-mergechangelogs'); + + my $driver = 'dpkg-mergechangelogs'; + my $cb = "merge.$driver"; + my $attrs = '.git/info/attributes'; + ensuredir '.git/info'; + + open NATTRS, ">", "$attrs.new" or die "$attrs.new $!"; + if (!open ATTRS, "<", $attrs) { + $!==ENOENT or die "$attrs: $!"; + } else { + while (<ATTRS>) { + chomp; + next if m{^debian/changelog\s}; + print NATTRS $_, "\n" or die $!; } + ATTRS->error and die $!; + close ATTRS; + } + print NATTRS "debian/changelog merge=$driver\n" or die $!; + close NATTRS; + + set_local_git_config "$cb.name", 'debian/changelog merge driver'; + set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A'; + + rename "$attrs.new", "$attrs" or die "$attrs: $!"; +} + +sub setup_useremail (;$) { + my ($always) = @_; + return unless $always || access_cfg_bool(1, 'setup-useremail'); + + my $setup = sub { + my ($k, $envvar) = @_; + my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar}; + return unless defined $v; + set_local_git_config "user.$k", $v; + }; + + $setup->('email', 'DEBEMAIL'); + $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 open_gitattrs () { + my $gai = new IO::File ".git/info/attributes" + or $!==ENOENT + or die "open .git/info/attributes: $!"; + return $gai; +} + +sub is_gitattrs_setup () { + my $gai = open_gitattrs(); + return 0 unless $gai; + while (<$gai>) { + return 1 if m{^\[attr\]dgit-defuse-attrs\s}; } + $gai->error and die $!; + return 0; +} + +sub setup_gitattrs (;$) { + my ($always) = @_; + return unless $always || access_cfg_bool(1, 'setup-gitattributes'); + + if (is_gitattrs_setup()) { + progress <<END; +[attr]dgit-defuse-attrs already found in .git/info/attributes + not doing further gitattributes setup +END + return; + } + my $af = ".git/info/attributes"; + open GAO, "> $af.new" or die $!; + print GAO <<END or die $!; +* dgit-defuse-attrs +[attr]dgit-defuse-attrs -text -eol -crlf -ident -filter +# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1) +END + my $gai = open_gitattrs(); + if ($gai) { + while (<$gai>) { + chomp; + print GAO $_, "\n" or die $!; + } + $gai->error and die $!; + } + close GAO or die $!; + rename "$af.new", "$af" or die "install $af: $!"; +} + +sub setup_new_tree () { + setup_mergechangelogs(); + setup_useremail(); + setup_gitattrs(); +} + +sub check_gitattrs ($$) { + my ($treeish, $what) = @_; + + return if is_gitattrs_setup; + + local $/="\0"; + my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:"); + debugcmd "|",@cmd; + my $gafl = new IO::File; + open $gafl, "-|", @cmd or die $!; + while (<$gafl>) { + chomp or die; + s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die; + next if $1 == 0; + next unless m{(?:^|/)\.gitattributes$}; + + # oh dear, found one + print STDERR <<END; +dgit: warning: $what contains .gitattributes +dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree. +END + close $gafl; + return; + } + # tree contains no .gitattributes files + $?=0; $!=0; close $gafl or failedcmd @cmd; +} + + +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) { + forkcheck_setup(); + $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 -h -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(); - mkdir $dstdir or die "$dstdir $!"; + + 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); - runcmd @git, qw(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', access_giturl(); - if (check_for_git()) { + setup_new_tree(); + clone_set_head(); + my $giturl = access_giturl(1); + if (defined $giturl) { + runcmd @git, qw(remote add), 'origin', $giturl; + } + if ($hasgit) { progress "fetching existing git history"; git_fetch_us(); runcmd_ordryrun_local @git, qw(fetch origin); @@ -1321,13 +3631,14 @@ sub clone ($) { fetch_from_archive() or no_such_package; my $vcsgiturl = $dsc->{'Vcs-Git'}; if (length $vcsgiturl) { + $vcsgiturl =~ s/\s+-b\s+\S+//g; runcmd @git, qw(remote add vcs-git), $vcsgiturl; } - 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(); } @@ -1336,25 +3647,40 @@ 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"; } sub check_not_dirty () { + foreach my $f (qw(local-options local-patch-header)) { + if (stat_exists "debian/source/$f") { + fail "git tree contains debian/source/$f"; + } + } + return if $ignoredirty; + my @cmd = (@git, qw(diff --quiet HEAD)); - printcmd(\*DEBUG,$debugprefix."+",@cmd) if $debug>0; - $!=0; $?=0; system @cmd; - return if !$! && !$?; - if (!$! && $?==256) { + debugcmd "+",@cmd; + $!=0; $?=-1; system @cmd; + return if !$?; + if ($?==256) { fail "working tree is dirty (does not match HEAD)"; } else { failedcmd @cmd; } } +sub commit_admin ($) { + my ($m) = @_; + progress "$m"; + runcmd_ordryrun_local @git, qw(commit -m), $m; +} + sub commit_quilty_patch () { my $output = cmdoutput @git, qw(status --porcelain); my %adds; @@ -1364,41 +3690,297 @@ sub commit_quilty_patch () { $adds{$1}++; } } + delete $adds{'.pc'}; # if there wasn't one before, don't add it if (!%adds) { progress "nothing quilty to commit, ok."; return; } - runcmd_ordryrun_local @git, qw(add), sort keys %adds; - my $m = "Commit Debian 3.0 (quilt) metadata"; - progress "$m"; - runcmd_ordryrun_local @git, qw(commit -m), $m; + my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds; + runcmd_ordryrun_local @git, qw(add -f), @adds; + commit_admin <<END +Commit Debian 3.0 (quilt) metadata + +[dgit ($our_version) quilt-fixup] +END +} + +sub get_source_format () { + my %options; + if (open F, "debian/source/options") { + while (<F>) { + next if m/^\s*\#/; + next unless m/\S/; + s/\s+$//; # ignore missing final newline + if (m/\s*\#\s*/) { + my ($k, $v) = ($`, $'); #'); + $v =~ s/^"(.*)"$/$1/; + $options{$k} = $v; + } else { + $options{$_} = 1; + } + } + F->error and die $!; + close F; + } else { + die $! unless $!==&ENOENT; + } + + if (!open F, "debian/source/format") { + die $! unless $!==&ENOENT; + return ''; + } + $_ = <F>; + F->error and die $!; + chomp; + return ($_, \%options); } -sub madformat ($) { +sub madformat_wantfixup ($) { my ($format) = @_; return 0 unless $format eq '3.0 (quilt)'; - progress "Format \`$format', urgh"; - if ($noquilt) { - progress "Not doing any fixup of \`$format' due to --no-quilt-fixup"; + our $quilt_mode_warned; + if ($quilt_mode eq 'nocheck') { + progress "Not doing any fixup of \`$format' due to". + " ----no-quilt-fixup or --quilt=nocheck" + unless $quilt_mode_warned++; return 0; } + progress "Format \`$format', need to check/update patch stack" + unless $quilt_mode_warned++; return 1; } +sub maybe_split_brain_save ($$$) { + my ($headref, $dgitview, $msg) = @_; + # => 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 <<END; +$x->[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 ? <<END : <<END; +Wanted tag $what (@tagnames) on dgit server, but not found +END +Wanted tag $what (one of: @tagnames) on dgit server, but not found +END +} + +sub infopair_cond_ff ($$) { + my ($anc,$desc) = @_; + is_fast_fwd($anc->[0], $desc->[0]) or fail <<END; +$anc->[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 ..."; + my $cd; + eval { + my @xa = ("-f$v", "-t$v"); + my $vclogp = parsechangelog @xa; + my $gf = sub { + my ($fn) = @_; + [ (getfield $vclogp, $fn), + "$fn field from dpkg-parsechangelog @xa" ]; + }; + my $cv = $gf->('Version'); + infopair_cond_equal($i_arch_v, $cv); + $cd = $gf->('Distribution'); + }; + if ($@) { + $@ =~ s/^dgit: //gm; + fail "$@". + "Perhaps debian/changelog does not mention $v ?"; + } + fail <<END if $cd->[0] =~ m/UNRELEASED/; +$cd->[1] is $cd->[0] +Your tree seems to based on earlier (not uploaded) $v. +END + } + } + + 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 <<END or die $!; +tree $tree +parent $dgitview +parent $archive_hash +author $authline +committer $authline + +$msg_msg + +[$msg_cmd] +END + close MC or die $!; + + return make_commit($pmf); +} + +sub splitbrain_pseudomerge ($$$$) { + my ($clogp, $maintview, $dgitview, $archive_hash) = @_; + # => $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; + return $dgitview if deliberately_not_fast_forward(); + + 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 <<END; +$us: check failed (maybe --overwrite is needed, consult documentation) +END + die "$@"; + } + + my $r = pseudomerge_make_commit + $clogp, $dgitview, $archive_hash, $i_arch_v, + "dgit --quilt=$quilt_mode", + (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF); +Declare fast forward from $i_arch_v->[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); - runcmd @git, qw(check-ref-format), $tag; + + if (!$we_are_initiator) { + # rpush initiator can't do this because it doesn't have $isuite yet + 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 ($$$) { @@ -1411,13 +3993,57 @@ 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', + }; + } elsif ($dodep14tag eq 'no' ? 0 + : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain + : $dodep14tag eq 'always' + ? (access_cfg_tagformats_can_splitbrain or fail <<END) +--dep14tag-always (or equivalent in config) means server must support + both "new" and "maint" tag formats, but config says it doesn't. +END + : die "$dodep14tag ?") { + push @tagwants, { + TagFn => \&debiantag_maintview, + Objid => $dgithead, + TfSuffix => '-dgit', + View => 'dgit', + }; + }; + 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; + my $declaredistro = access_nomdistro(); + my $reader_giturl = do { local $access_forpush=0; access_giturl(); }; + $dsc->{$ourdscfield[0]} = join " ", + $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag}, + $reader_giturl; $dsc->save("$dscfn.tmp") or die $!; my $changes = parsecontrol($changesfile,$changesfilewhat); @@ -1433,35 +4059,67 @@ sub push_mktag ($$$$$$$) { # We make the git tag by hand because (a) that makes it easier # to control the "tagger" (b) we can do remote signing my $authline = clogp_authline $clogp; - open TO, '>', $tfn->('.tmp') or die $!; - print TO <<END or die $!; + my $delibs = join(" ", "",@deliberatelies); + + my $mktag = sub { + my ($tw) = @_; + my $tfn = $tw->{Tfn}; + my $head = $tw->{Objid}; + my $tag = $tw->{Tag}; + + open TO, '>', $tfn->('.tmp') or die $!; + print TO <<END or die $!; object $head type commit tag $tag tagger $authline +END + if ($tw->{View} eq 'dgit') { + print TO <<END or die $!; $package release $cversion for $clogsuite ($csuite) [dgit] +[dgit distro=$declaredistro$delibs] END - close TO or die $!; - - my $tagobjfn = $tfn->('.tmp'); - if ($sign) { - if (!defined $keyid) { - $keyid = access_cfg('keyid','RETURN-UNDEF'); + foreach my $ref (sort keys %previously) { + print TO <<END or die $!; +[dgit previously:$ref=$previously{$ref}] +END + } + } elsif ($tw->{View} eq 'maint') { + print TO <<END or die $!; +$package release $cversion for $clogsuite ($csuite) +(maintainer view tag generated by dgit --quilt=$quilt_mode) +END + } else { + die Dumper($tw)."?"; } - 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'); + + close TO or die $!; + + 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 ($) { @@ -1477,21 +4135,46 @@ sub sign_changes ($) { 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 + rpush_handle_protovsn_bothends() if $we_are_initiator; + 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"; - stat $dscpath or - fail "looked for .dsc $dscfn, but $!;". + stat_exists $dscpath or + fail "looked for .dsc $dscpath, but $!;". " maybe you forgot to build"; responder_send_file('dsc', $dscpath); @@ -1500,87 +4183,188 @@ sub dopush () { my $format = getfield $dsc, 'Format'; printdebug "format $format\n"; - if (madformat($format)) { - commit_quilty_patch(); + + my $actualhead = git_rev_parse('HEAD'); + my $dgithead = $actualhead; + my $maintviewhead = undef; + + my $upstreamversion = upstreamversion $clogp->{Version}; + + if (madformat_wantfixup($format)) { + # user might have not used dgit build, so maybe do this now: + 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 --), $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath"; - my ($tree,$dir) = mktree_in_ud_from_only_subdir(); + my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package"); + check_for_vendor_patches() if madformat($dsc->{format}); changedir '../../../..'; - my $diffopt = $debug>0 ? '--exit-code' : '--quiet'; - my @diffcmd = (@git, qw(diff), $diffopt, $tree); - printcmd \*DEBUG,$debugprefix."+",@diffcmd; - $!=0; $?=0; + my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); + debugcmd "+",@diffcmd; + $!=0; $?=-1; my $r = system @diffcmd; if ($r) { if ($r==256) { - fail "$dscfn specifies a different tree to your HEAD commit;". - " perhaps you forgot to build". - ($diffopt eq '--exit-code' ? "" : - " (run with -D to see full diff output)"); + my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead; + fail <<END +HEAD specifies a different tree to $dscfn: +$diffs +Perhaps you forgot to build. Or perhaps there is a problem with your + source tree (see dgit(7) for some hints). To see a full diff, run + git diff $tree HEAD +END } else { failedcmd @diffcmd; } } -#fetch from alioth -#do fast forward check and maybe fake merge -# if (!is_fast_fwd(mainbranch -# runcmd @git, qw(fetch -p ), "$alioth_git/$package.git", -# map { lref($_).":".rref($_) } -# (uploadbranch()); - my $head = rev_parse('HEAD'); if (!$changesfile) { - my $multi = "$buildproductsdir/". - "${package}_".(stripepoch $cversion)."_multi.changes"; - if (stat "$multi") { - $changesfile = $multi; - } else { - $!==&ENOENT or die "$multi: $!"; - my $pat = "${package}_".(stripepoch $cversion)."_*.changes"; - my @cs = glob "$buildproductsdir/$pat"; - fail "failed to find unique changes file". - " (looked for $pat in $buildproductsdir, or $multi);". - " perhaps you need to use dgit -C" - unless @cs==1; - ($changesfile) = @cs; - } + my $pat = changespat $cversion; + my @cs = glob "$buildproductsdir/$pat"; + fail "failed to find unique changes file". + " (looked for $pat in $buildproductsdir);". + " perhaps you need to use dgit -C" + unless @cs==1; + ($changesfile) = @cs; } else { $changesfile = "$buildproductsdir/$changesfile"; } + # Check that changes and .dsc agree enough + $changesfile =~ m{[^/]*$}; + my $changes = parsecontrol($changesfile,$&); + files_compare_inputs($dsc, $changes) + unless forceing [qw(dsc-changes-mismatch)]; + + # Perhaps adjust .dsc to contain right set of origs + changes_update_origs_from_dsc($dsc, $changes, $upstreamversion, + $changesfile) + unless forceing [qw(changes-origs-exactly)]; + + # Checks complete, we're going to try and go ahead: + responder_send_file('changes',$changesfile); - responder_send_command("param head $head"); + responder_send_command("param head $dgithead"); responder_send_command("param csuite $csuite"); + responder_send_command("param isuite $isuite"); + responder_send_command("param tagformat $tagformat"); + if (defined $maintviewhead) { + die unless ($protovsn//4) >= 4; + responder_send_command("param maint-view $maintviewhead"); + } - my $tfn = sub { ".git/dgit/tag$_[0]"; }; - my $tagobjfn; + if (deliberately_not_fast_forward) { + git_for_each_ref(lrfetchrefs, sub { + my ($objid,$objtype,$lrfetchrefname,$reftail) = @_; + my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1); + responder_send_command("previously $rrefname=$objid"); + $previously{$rrefname} = $objid; + }); + } + + my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead, + ".git/dgit/tag"); + my @tagobjfns; + supplementary_message(<<'END'); +Push failed, while signing the tag. +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 + + pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns; - 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; - runcmd_ordryrun @git, qw(tag -v --), $tag; + 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. +If you want to try again, you should use a new version number. +END if (!check_for_git()) { create_remote_git_repo(); } - runcmd_ordryrun @git, qw(push),access_giturl(), - "HEAD:".rrref(), "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, while obtaining signatures on the .changes and .dsc. +If it was just that the signature failed, you may try again by using +debsign by hand to sign the changes + $changesfile +and then dput to complete the upload. +If you need to change the package, you must use a new version number. +END if ($we_are_responder) { my $dryrunsuffix = act_local() ? "" : ".tmp"; responder_receive_files('signed-dsc-changes', @@ -1595,11 +4379,19 @@ sub dopush () { sign_changes $changesfile; } + supplementary_message(<<END); +Push failed, while uploading package(s) to the archive server. +You can retry the upload of exactly these same files with dput of: + $changesfile +If that .changes file is broken, you will need to use a new version +number for your next attempt at the upload. +END my $host = access_cfg('upload-host','RETURN-UNDEF'); my @hostarg = defined($host) ? ($host,) : (); runcmd_ordryrun @dput, @hostarg, $changesfile; printdone "pushed and uploaded $cversion"; + supplementary_message(''); responder_send_command("complete"); } @@ -1619,12 +4411,11 @@ sub cmd_clone { } else { badusage "incorrect arguments to dgit clone"; } - $dstdir ||= "$package"; + notpushing(); - if (stat $dstdir) { + $dstdir ||= "$package"; + if (stat_exists $dstdir) { fail "$dstdir already exists"; - } elsif ($! != &ENOENT) { - die "$dstdir: $!"; } my $cwd_remove; @@ -1636,7 +4427,14 @@ sub cmd_clone { return if $!==&ENOENT; die "chdir $cwd_remove: $!"; } - rmtree($dstdir) or die "remove $dstdir: $!\n"; + printdebug "clone rmonerror removing $dstdir\n"; + if (stat $dstdir) { + rmtree($dstdir) or die "remove $dstdir: $!\n"; + } elsif (grep { $! == $_ } + (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) { + } else { + print STDERR "check whether to remove $dstdir: $!\n"; + } }; } @@ -1645,7 +4443,12 @@ sub cmd_clone { } sub branchsuite () { - my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD); + my @cmd = (@git, qw(symbolic-ref -q HEAD)); + my $branch = cmdoutput_errok @cmd; + if (!defined $branch) { + $?==256 or failedcmd @cmd; + return undef; + } if ($branch =~ m#$lbranch_re#o) { return $1; } else { @@ -1659,30 +4462,37 @@ 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'; + my $clogsuite = getfield $clogp, 'Distribution'; + $isuite= $clogsuite if $clogsuite ne 'UNRELEASED'; } - canonicalise_suite(); - progress "fetching from suite $csuite"; } elsif (@ARGV==1) { ($isuite) = @ARGV; - canonicalise_suite(); } else { badusage "incorrect arguments to dgit fetch or dgit pull"; } + notpushing(); } 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 <<END +dgit pull not yet supported in split view mode (--quilt=$quilt_mode) +END + } pull(); } @@ -1700,29 +4510,19 @@ sub cmd_push { badusage "incorrect arguments to dgit push"; } $isuite = getfield $clogp, 'Distribution'; + pushing(); if ($new_package) { local ($package) = $existing_package; # this is a hack canonicalise_suite(); - } - if (defined $specsuite && $specsuite ne $isuite) { + } else { canonicalise_suite(); - $csuite eq $specsuite or + } + if (defined $specsuite && + $specsuite ne $isuite && + $specsuite ne $csuite) { fail "dgit push: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } - if (check_for_git()) { - git_fetch_us(); - } - if (fetch_from_archive()) { - is_fast_fwd(lrref(), 'HEAD') or - fail "dgit push: HEAD is not a descendant". - " of the archive's version.\n". - "$us: To overwrite it, use git merge -s ours ".lrref()."."; - } else { - $new_package or - fail "package appears to be new in this suite;". - " if this is intentional, use --new"; - } dopush(); } @@ -1739,6 +4539,7 @@ sub cmd_remote_push_build_host { # offered several) $debugprefix = ' '; $we_are_responder = 1; + $us .= " (build host)"; open PI, "<&STDIN" or die $!; open STDIN, "/dev/null" or die $!; @@ -1748,12 +4549,16 @@ sub cmd_remote_push_build_host { autoflush STDOUT 1; $vsnwant //= 1; - fail "build host has dgit rpush protocol version". - " $rpushprotovsn but invocation host has $vsnwant" - unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant; + ($protovsn) = grep { + $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$} + } @rpushprotovsn_support; - responder_send_command("dgit-remote-push-ready $rpushprotovsn"); + fail "build host has dgit rpush protocol versions ". + (join ",", @rpushprotovsn_support). + " but invocation host has $vsnwant" + unless defined $protovsn; + responder_send_command("dgit-remote-push-ready $protovsn"); changedir $dir; &cmd_push; } @@ -1762,6 +4567,13 @@ sub cmd_remote_push_responder { cmd_remote_push_build_host(); } # ... for compatibility with proto vsn.1 dgit (just so that user gets # a good error message) +sub rpush_handle_protovsn_bothends () { + if ($protovsn < 4) { + need_tagformat 'old', "rpush negotiated protocol $protovsn"; + } + select_tagformat(); +} + our $i_tmp; sub i_cleanup { @@ -1779,7 +4591,10 @@ sub i_cleanup { } } -END { i_cleanup(); } +END { + return unless forkcheck_mainprocess(); + i_cleanup(); +} sub i_method { my ($base,$selector,@args) = @_; @@ -1797,14 +4612,17 @@ sub cmd_rpush { $dir = nextarg; } $dir =~ s{^-}{./-}; - my @rargs = ($dir,$rpushprotovsn); + my @rargs = ($dir); + push @rargs, join ",", @rpushprotovsn_support; my @rdgit; push @rdgit, @dgit; push @rdgit, @ropts; push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs; push @rdgit, @ARGV; my @cmd = (@ssh, $host, shellquote @rdgit); - printcmd \*DEBUG,$debugprefix."+",@cmd; + debugcmd "+",@cmd; + + $we_are_initiator=1; if (defined $initiator_tempdir) { rmtree $initiator_tempdir; @@ -1815,7 +4633,10 @@ sub cmd_rpush { } $i_child_pid = open2(\*RO, \*RI, @cmd); changedir $i_tmp; - initiator_expect { m/^dgit-remote-push-ready/ }; + ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ }; + die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support; + $supplementary_message = '' unless $protovsn >= 3; + for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -1831,6 +4652,11 @@ sub i_resp_progress ($) { progress $msg; } +sub i_resp_supplementary_message ($) { + my ($rhs) = @_; + $supplementary_message = protocol_read_bytes \*RO, $rhs; +} + sub i_resp_complete { my $pid = $i_child_pid; $i_child_pid = undef; # prevents killing some other process with same pid @@ -1848,7 +4674,8 @@ sub i_resp_file ($) { my ($keyword) = @_; my $localname = i_method "i_localname", $keyword; my $localpath = "$i_tmp/$localname"; - stat $localpath and badproto \*RO, "file $keyword ($localpath) twice"; + stat_exists $localpath and + badproto \*RO, "file $keyword ($localpath) twice"; protocol_receive_file \*RO, $localpath; i_method "i_file", $keyword; } @@ -1860,11 +4687,31 @@ sub i_resp_param ($) { $i_param{$1} = $2; } +sub i_resp_previously ($) { + $_[0] =~ m#^(refs/tags/\S+)=(\w+)$# + or badproto \*RO, "bad previously spec"; + my $r = system qw(git check-ref-format), $1; + die "bad previously ref spec ($r)" if $r; + $previously{$1} = $2; +} + our %i_wanted; sub i_resp_want ($) { my ($keyword) = @_; die "$keyword ?" if $i_wanted{$keyword}++; + + defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite"; + $isuite = $i_param{'isuite'} // $i_param{'csuite'}; + die unless $isuite =~ m/^$suite_re$/; + + pushing(); + rpush_handle_protovsn_bothends(); + + fail "rpush negotiated protocol version $protovsn". + " which does not support quilt mode $quilt_mode" + if quiltmode_splitbrain; + my @localpaths = i_method "i_want", $keyword; printdebug "[[ $keyword @localpaths\n"; foreach my $localpath (@localpaths) { @@ -1873,13 +4720,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#; } @@ -1906,17 +4753,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'} // '<undef>'; + $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 { @@ -1931,59 +4787,905 @@ our $version; our $sourcechanges; our $dscfn; +#----- `3.0 (quilt)' handling ----- + our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT'; -sub build_maybe_quilt_fixup () { - if (!open F, "debian/source/format") { - die $! unless $!==&ENOENT; - return; - } - $_ = <F>; - F->error and die $!; - chomp; - return unless madformat($_); - # sigh - - my @cmd = (@git, qw(ls-files --exclude-standard -iodm)); - my $problems = cmdoutput @cmd; - if (length $problems) { - print STDERR "problematic files:\n"; - print STDERR " $_\n" foreach split /\n/, $problems; - fail "Cannot do quilt fixup in tree containing ignored files. ". - "Perhaps your package's clean target is broken, in which". - " case -wg (which says to use git-clean -xdf) may help."; - } +sub quiltify_dpkg_commit ($$$;$) { + my ($patchname,$author,$msg, $xinfo) = @_; + $xinfo //= ''; - my $clogp = parsechangelog(); - my $version = getfield $clogp, 'Version'; - my $author = getfield $clogp, 'Maintainer'; - my $headref = rev_parse('HEAD'); - my $time = time; - my $ncommits = 3; - my $patchname = "auto-$version-$headref-$time"; - my $msg = cmdoutput @git, qw(log), "-n$ncommits"; mkpath '.git/dgit'; my $descfn = ".git/dgit/quilt-description.tmp"; open O, '>', $descfn or die "$descfn: $!"; - $msg =~ s/\n/\n /g; - $msg =~ s/^\s+$/ ./mg; + $msg =~ s/\n+/\n\n/; print O <<END or die $!; -Description: Automatically generated patch ($clogp->{Version}) - Last (up to) $ncommits git changes, FYI: - . - $msg -Author: $author - +From: $author +${xinfo}Subject: $msg --- END close O or die $!; + { local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0; local $ENV{'VISUAL'} = $ENV{'EDITOR'}; local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn; - runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname; + runcmd @dpkgsource, qw(--commit --include-removal .), $patchname; + } +} + +sub quiltify_trees_differ ($$;$$$) { + my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_; + # returns true iff the two tree objects differ other than in debian/ + # with $finegrained, + # returns bitmask 01 - differ in upstream files except .gitignore + # 02 - differ in .gitignore + # if $ignorenamesr is defined, $ingorenamesr->{$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 -z)); + push @cmd, qw(--name-only) unless $unrepres; + push @cmd, qw(-r) if $finegrained || $unrepres; + push @cmd, $x, $y; + my $diffs= cmdoutput @cmd; + my $r = 0; + my @lmodes; + foreach my $f (split /\0/, $diffs) { + if ($unrepres && !@lmodes) { + @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?"; + next; + } + my ($oldmode,$newmode) = @lmodes; + @lmodes = (); + + next if $f =~ m#^debian(?:/.*)?$#s; + + if ($unrepres) { + eval { + die "not a plain file\n" + unless $newmode =~ m/^10\d{4}$/ || + $oldmode =~ m/^10\d{4}$/; + if ($oldmode =~ m/[^0]/ && + $newmode =~ m/[^0]/) { + die "mode changed\n" if $oldmode ne $newmode; + } else { + die "non-default mode\n" + unless $newmode =~ m/^100644$/ || + $oldmode =~ m/^100644$/; + } + }; + if ($@) { + local $/="\n"; chomp $@; + push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ]; + } + } + + 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; +} + +sub quiltify_tree_sentinelfiles ($) { + # lists the `sentinel' files present in the tree + my ($x) = @_; + my $r = cmdoutput @git, qw(ls-tree --name-only), $x, + qw(-- debian/rules debian/control); + $r =~ s/\n/,/g; + return $r; +} + +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 <<END; +--quilt=$quilt_mode specified, implying patches-applied git tree + but git tree differs from result of applying debian/patches to upstream +END + } + if ($quilt_mode =~ m/gbp|unapplied/ && + ($diffbits->{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 <<END +--quilt=$quilt_mode specified, implying that HEAD is for use with a + tool which does not create patches for changes to upstream + .gitignores: but, such patches exist in debian/patches. +END + } + if (($diffbits->{O2H} & 02) && # user has modified .gitignore + !($diffbits->{O2A} & 02)) { # patches do not change .gitignore + quiltify_splitbrain_needed(); + progress "dgit view: creating patch to represent .gitignore changes"; + ensuredir "debian/patches"; + 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 <<END or die "$gipatch: $!"; +Subject: Update .gitignore from Debian packaging branch + +The Debian packaging git branch contains these updates to the upstream +.gitignore file(s). This patch is autogenerated, to provide these +updates to users of the official Debian archive view of the package. + +[dgit ($our_version) update-gitignore] +--- +END + close GIPATCH or die "$gipatch: $!"; + runcmd shell_cmd "exec >>$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 <<END +Commit patch to update .gitignore + +[dgit ($our_version) update-gitignore-quilt-fixup] +END + } + + my $dgitview = git_rev_parse 'HEAD'; + + changedir '../../../..'; + # When we no longer need to support squeeze, use --create-reflog + # instead of this: + ensuredir ".git/logs/refs/dgit-intern"; + my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>' + 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 <<END; +tree $tree +parent $dgitview +author Dgit <dgit\@example.com> 1000000000 +0000 +committer Dgit <dgit\@example.com> 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 ($$$$) { + my ($clogp,$target,$oldtiptree,$failsuggestion) = @_; + + # Quilt patchification algorithm + # + # We search backwards through the history of the main tree's HEAD + # (T) looking for a start commit S whose tree object is identical + # to to the patch tip tree (ie the tree corresponding to the + # current dpkg-committed patch series). For these purposes + # `identical' disregards anything in debian/ - this wrinkle is + # necessary because dpkg-source treates debian/ specially. + # + # We can only traverse edges where at most one of the ancestors' + # trees differs (in changes outside in debian/). And we cannot + # handle edges which change .pc/ or debian/patches. To avoid + # going down a rathole we avoid traversing edges which introduce + # debian/rules or debian/control. And we set a limit on the + # number of edges we are willing to look at. + # + # If we succeed, we walk forwards again. For each traversed edge + # PC (with P parent, C child) (starting with P=S and ending with + # C=T) to we do this: + # - git checkout C + # - dpkg-source --commit with a patch name and message derived from C + # After traversing PT, we git commit the changes which + # should be contained within debian/patches. + + # The search for the path S..T is breadth-first. We maintain a + # todo list containing search nodes. A search node identifies a + # commit, and looks something like this: + # $p = { + # Commit => $git_commit_id, + # Child => $c, # or undef if P=T + # Whynot => $reason_edge_PC_unsuitable, # in @nots only + # Nontrivial => true iff $p..$c has relevant changes + # }; + + my @todo; + my @nots; + my $sref_S; + my $max_work=100; + my %considered; # saves being exponential on some weird graphs + + my $t_sentinels = quiltify_tree_sentinelfiles $target; + + my $not = sub { + my ($search,$whynot) = @_; + printdebug " search NOT $search->{Commit} $whynot\n"; + $search->{Whynot} = $whynot; + push @nots, $search; + no warnings qw(exiting); + next; + }; + + push @todo, { + Commit => $target, + }; + + while (@todo) { + my $c = shift @todo; + next if $considered{$c->{Commit}}++; + + $not->($c, "maximum search space exceeded") if --$max_work <= 0; + + printdebug "quiltify investigate $c->{Commit}\n"; + + # are we done? + if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) { + printdebug " search finished hooray!\n"; + $sref_S = $c; + last; + } + + if ($quilt_mode eq 'nofix') { + fail "quilt fixup required but quilt mode is \`nofix'\n". + "HEAD commit $c->{Commit} differs from tree implied by ". + " debian/patches (tree object $oldtiptree)"; + } + if ($quilt_mode eq 'smash') { + printdebug " search quitting smash\n"; + last; + } + + my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit}; + $not->($c, "has $c_sentinels not $t_sentinels") + if $c_sentinels ne $t_sentinels; + + my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit}; + $commitdata =~ m/\n\n/; + $commitdata =~ $`; + my @parents = ($commitdata =~ m/^parent (\w+)$/gm); + @parents = map { { Commit => $_, Child => $c } } @parents; + + $not->($c, "root commit") if !@parents; + + foreach my $p (@parents) { + $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit}; + } + my $ndiffers = grep { $_->{Nontrivial} } @parents; + $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1; + + foreach my $p (@parents) { + printdebug "considering C=$c->{Commit} P=$p->{Commit}\n"; + + my @cmd= (@git, qw(diff-tree -r --name-only), + $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc)); + my $patchstackchange = cmdoutput @cmd; + if (length $patchstackchange) { + $patchstackchange =~ s/\n/,/g; + $not->($p, "changed $patchstackchange"); + } + + printdebug " search queue P=$p->{Commit} ", + ($p->{Nontrivial} ? "NT" : "triv"),"\n"; + push @todo, $p; + } + } + + if (!$sref_S) { + printdebug "quiltify want to smash\n"; + + my $abbrev = sub { + my $x = $_[0]{Commit}; + $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/; + return $x; + }; + my $reportnot = sub { + my ($notp) = @_; + my $s = $abbrev->($notp); + my $c = $notp->{Child}; + $s .= "..".$abbrev->($c) if $c; + $s .= ": ".$notp->{Whynot}; + return $s; + }; + if ($quilt_mode eq 'linear') { + print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n"; + foreach my $notp (@nots) { + print STDERR "$us: ", $reportnot->($notp), "\n"; + } + print STDERR "$us: $_\n" foreach @$failsuggestion; + fail "quilt fixup naive history linearisation failed.\n". + "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch"; + } elsif ($quilt_mode eq 'smash') { + } elsif ($quilt_mode eq 'auto') { + progress "quilt fixup cannot be linear, smashing..."; + } else { + die "$quilt_mode ?"; + } + + 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"; + + quiltify_dpkg_commit "auto-$version-$target-$time", + (getfield $clogp, 'Maintainer'), + "Automatically generated patch ($clogp->{Version})\n". + "Last (up to) $ncommits git changes, FYI:\n\n". $msg; + return; + } + + progress "quiltify linearisation planning successful, executing..."; + + for (my $p = $sref_S; + my $c = $p->{Child}; + $p = $p->{Child}) { + printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n"; + next unless $p->{Nontrivial}; + + my $cc = $c->{Commit}; + + my $commitdata = cmdoutput @git, qw(cat-file commit), $cc; + $commitdata =~ m/\n\n/ or die "$c ?"; + $commitdata = $`; + my $msg = $'; #'; + $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?"; + my $author = $1; + + my $commitdate = cmdoutput + @git, qw(log -n1 --pretty=format:%aD), $cc; + + $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?"; + + my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; }; + $strip_nls->(); + + my $title = $1; + my $patchname; + my $patchdir; + + my $gbp_check_suitable = sub { + $_ = shift; + my ($what) = @_; + + eval { + die "contains unexpected slashes\n" if m{//} || m{/$}; + die "contains leading punctuation\n" if m{^\W} || m{/\W}; + die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i; + die "too long" if length > 200; + }; + return $_ unless $@; + print STDERR "quiltifying commit $cc:". + " ignoring/dropping Gbp-Pq $what: $@"; + return undef; + }; + + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ | + gbp-pq-name: \s* ) + (\S+) \s* \n //ixm) { + $patchname = $gbp_check_suitable->($1, 'Name'); + } + if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ | + gbp-pq-topic: \s* ) + (\S+) \s* \n //ixm) { + $patchdir = $gbp_check_suitable->($1, 'Topic'); + } + + $strip_nls->(); + + if (!defined $patchname) { + $patchname = $title; + $patchname =~ s/[.:]$//; + use Text::Iconv; + eval { + my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT); + my $translitname = $converter->convert($patchname); + die unless defined $translitname; + $patchname = $translitname; + }; + print STDERR + "dgit: patch title transliteration error: $@" + if $@; + $patchname =~ y/ A-Z/-a-z/; + $patchname =~ y/-a-z0-9_.+=~//cd; + $patchname =~ s/^\W/x-$&/; + $patchname = substr($patchname,0,40); + } + if (!defined $patchdir) { + $patchdir = ''; + } + if (length $patchdir) { + $patchname = "$patchdir/$patchname"; + } + if ($patchname =~ m{^(.*)/}) { + mkpath "debian/patches/$1"; + } + + my $index; + for ($index=''; + stat "debian/patches/$patchname$index"; + $index++) { } + $!==ENOENT or die "$patchname$index $!"; + + runcmd @git, qw(checkout -q), $cc; + + # We use the tip's changelog so that dpkg-source doesn't + # produce complaining messages from dpkg-parsechangelog. None + # of the information dpkg-source gets from the changelog is + # actually relevant - it gets put into the original message + # which dpkg-source provides our stunt editor, and then + # overwritten. + 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); + } + + runcmd @git, qw(checkout -q master); +} + +sub build_maybe_quilt_fixup () { + my ($format,$fopts) = get_source_format; + return unless madformat_wantfixup $format; + # sigh + + check_for_vendor_patches(); + + if (quiltmode_splitbrain) { + fail <<END unless access_cfg_tagformats_can_splitbrain; +quilt mode $quilt_mode requires split view so server needs to support + both "new" and "maint" tag formats, but config says it doesn't. +END + } + + my $clogp = parsechangelog(); + my $headref = git_rev_parse('HEAD'); + + prep_ud(); + changedir $ud; + + my $upstreamversion = upstreamversion $version; + + if ($fopts->{'single-debian-patch'}) { + quilt_fixup_singlepatch($clogp, $headref, $upstreamversion); + } else { + quilt_fixup_multipatch($clogp, $headref, $upstreamversion); + } + + die 'bug' if $split_brain && !$need_split_build_invocation; + + changedir '../../../..'; + runcmd_ordryrun_local + @git, qw(pull --ff-only -q .git/dgit/unpack/work master); +} + +sub quilt_fixup_mkwork ($) { + my ($headref) = @_; + + mkdir "work" or die $!; + changedir "work"; + mktree_in_ud_here(); + runcmd @git, qw(reset -q --hard), $headref; +} + +sub quilt_fixup_linkorigs ($$) { + my ($upstreamversion, $fn) = @_; + # calls $fn->($leafname); + + foreach my $f (<../../../../*>) { #/){ + my $b=$f; $b =~ s{.*/}{}; + { + local ($debuglevel) = $debuglevel-1; + printdebug "QF linkorigs $b, $f ?\n"; + } + next unless is_orig_file_of_vsn $b, $upstreamversion; + printdebug "QF linkorigs $b, $f Y\n"; + link_ltarget $f, $b or die "$b $!"; + $fn->($b); } +} + +sub quilt_fixup_delete_pc () { + runcmd @git, qw(rm -rqf .pc); + commit_admin <<END +Commit removal of .pc (quilt series tracking data) + +[dgit ($our_version) upgrade quilt-remove-pc] +END +} + +sub quilt_fixup_singlepatch ($$$) { + my ($clogp, $headref, $upstreamversion) = @_; + + progress "starting quiltify (single-debian-patch)"; + + # dpkg-source --commit generates new patches even if + # single-debian-patch is in debian/source/options. In order to + # get it to generate debian/patches/debian-changes, it is + # necessary to build the source package. + + quilt_fixup_linkorigs($upstreamversion, sub { }); + quilt_fixup_mkwork($headref); + + rmtree("debian/patches"); + + runcmd @dpkgsource, qw(-b .); + changedir ".."; + runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc"); + rename srcfn("$upstreamversion", "/debian/patches"), + "work/debian/patches"; + + changedir "work"; + commit_quilty_patch(); +} + +sub quilt_make_fake_dsc ($) { + my ($upstreamversion) = @_; + + my $fakeversion="$upstreamversion-~~DGITFAKE"; + + my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; + print $fakedsc <<END or die $!; +Format: 3.0 (quilt) +Source: $package +Version: $fakeversion +Files: +END + + my $dscaddfile=sub { + my ($b) = @_; + + my $md = new Digest::MD5; + + my $fh = new IO::File $b, '<' or die "$b $!"; + stat $fh or die $!; + my $size = -s _; + + $md->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 (<GC>) { + 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 "examining quilt state (multiple patches, $quilt_mode mode)"; + + # Our objective is: + # - honour any existing .pc in case it has any strangeness + # - determine the git commit corresponding to the tip of + # the patch stack (if there is one) + # - if there is such a git commit, convert each subsequent + # git commit into a quilt patch with dpkg-source --commit + # - otherwise convert all the differences in the tree into + # a single git commit + # + # To do this we: + + # Our git tree doesn't necessarily contain .pc. (Some versions of + # dgit would include the .pc in the git tree.) If there isn't + # one, we need to generate one by unpacking the patches that we + # have. + # + # We first look for a .pc in the git tree. If there is one, we + # will use it. (This is not the normal case.) + # + # Otherwise need to regenerate .pc so that dpkg-source --commit + # can work. We do this as follows: + # 1. Collect all relevant .orig from parent directory + # 2. Generate a debian.tar.gz out of + # debian/{patches,rules,source/format,source/options} + # 3. Generate a fake .dsc containing just these fields: + # Format Source Version Files + # 4. Extract the fake .dsc + # Now the fake .dsc has a .pc directory. + # (In fact we do this in every case, because in future we will + # want to search for a good base commit for generating patches.) + # + # Then we can actually do the dpkg-source --commit + # 1. Make a new working tree with the same object + # store as our main tree and check out the main + # tree's HEAD. + # 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 + # 6. Back in the main tree, fast forward to the new HEAD + + # Another situation we may have to cope with is gbp-style + # patches-unapplied trees. + # + # We would want to detect these, so we know to escape into + # quilt_fixup_gbp. However, this is in general not possible. + # Consider a package with a one patch which the dgit user reverts + # (with git revert or the moral equivalent). + # + # That is indistinguishable in contents from a patches-unapplied + # tree. And looking at the history to distinguish them is not + # useful because the user might have made a confusing-looking git + # history structure (which ought to produce an error if dgit can't + # cope, not a silent reintroduction of an unwanted patch). + # + # So gbp users will have to pass an option. But we can usually + # detect their failure to do so: if the tree is not a clean + # patches-applied tree, quilt linearisation fails, but the tree + # _is_ a clean patches-unapplied tree, we can suggest that maybe + # they want --quilt=unapplied. + # + # To help detect this, when we are extracting the fake dsc, we + # first extract it with --skip-patches, and then apply the patches + # afterwards with dpkg-source --before-build. That lets us save a + # tree object corresponding to .origs. + + my $splitbrain_cachekey; + + quilt_make_fake_dsc($upstreamversion); + + if (quiltmode_splitbrain()) { + my $cachehit; + ($cachehit, $splitbrain_cachekey) = + quilt_check_splitbrain_cache($headref, $upstreamversion); + return if $cachehit; + } + + runcmd qw(sh -ec), + 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null'; + + my $fakexdir= $package.'-'.(stripepoch $upstreamversion); + rename $fakexdir, "fake" or die "$fakexdir $!"; + + changedir 'fake'; + + remove_stray_gits("source package"); + mktree_in_ud_here(); + + rmtree '.pc'; + + runcmd @git, qw(checkout -f), $headref, qw(-- debian); + my $unapplied=git_add_write_tree(); + printdebug "fake orig tree object $unapplied\n"; + + ensuredir '.pc'; + + my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null'); + $!=0; $?=-1; + if (system @bbcmd) { + failedcmd @bbcmd if $? < 0; + fail <<END; +failed to apply your git tree's patch stack (from debian/patches/) to + the corresponding upstream tarball(s). Your source tree and .orig + are probably too inconsistent. dgit can only fix up certain kinds of + anomaly (depending on the quilt mode). See --quilt= in dgit(1). +END + } + + changedir '..'; + + quilt_fixup_mkwork($headref); + + my $mustdeletepc=0; + if (stat_exists ".pc") { + -d _ or die; + progress "Tree already contains .pc - will use it then delete it."; + $mustdeletepc=1; + } else { + rename '../fake/.pc','.pc' or die $!; + } + + changedir '../fake'; + rmtree '.pc'; + my $oldtiptree=git_add_write_tree(); + printdebug "fake o+d/p tree object $unapplied\n"; + changedir '../work'; + + + # We calculate some guesswork now about what kind of tree this might + # be. This is mostly for error reporting. + + my %editedignores; + my @unrepres; + my $diffbits = { + # H = user's HEAD + # O = orig, without patches applied + # A = "applied", ie orig with H's debian/patches applied + O2H => quiltify_trees_differ($unapplied,$headref, 1, + \%editedignores, \@unrepres), + H2A => quiltify_trees_differ($headref, $oldtiptree,1), + O2A => quiltify_trees_differ($unapplied,$oldtiptree,1), + }; + + my @dl; + foreach my $b (qw(01 02)) { + foreach my $v (qw(O2H O2A H2A)) { + push @dl, ($diffbits->{$v} & $b) ? '##' : '=='; + } + } + printdebug "differences \@dl @dl.\n"; + + progress sprintf +"$us: base trees orig=%.20s o+d/p=%.20s", + $unapplied, $oldtiptree; + progress sprintf +"$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n". +"$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p", + $dl[0], $dl[1], $dl[3], $dl[4], + $dl[2], $dl[5]; + + if (@unrepres) { + print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n" + foreach @unrepres; + forceable_fail [qw(unrepresentable)], <<END; +HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)' +END + } + + my @failsuggestion; + 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 ?"; + + if (quiltmode_splitbrain()) { + quiltify_splitbrain($clogp, $unapplied, $headref, + $diffbits, \%editedignores, + $splitbrain_cachekey); + return; + } + + progress "starting quiltify (multiple patches, $quilt_mode mode)"; + quiltify($clogp,$headref,$oldtiptree,\@failsuggestion); if (!open P, '>>', ".pc/applied-patches") { $!==&ENOENT or die $!; @@ -1992,6 +5694,10 @@ END } commit_quilty_patch(); + + if ($mustdeletepc) { + quilt_fixup_delete_pc(); + } } sub quilt_fixup_editor () { @@ -2013,11 +5719,56 @@ sub quilt_fixup_editor () { exit 0; } +sub maybe_apply_patches_dirtily () { + return unless $quilt_mode =~ m/gbp|unapplied/; + print STDERR <<END or die $!; + +dgit: Building, or cleaning with rules target, in patches-unapplied tree. +dgit: Have to apply the patches - making the tree dirty. +dgit: (Consider specifying --clean=git and (or) using dgit sbuild.) + +END + $patches_applied_dirtily = 01; + $patches_applied_dirtily |= 02 unless stat_exists '.pc'; + runcmd qw(dpkg-source --before-build .); +} + +sub maybe_unapply_patches_again () { + progress "dgit: Unapplying patches again to tidy up the tree." + if $patches_applied_dirtily; + runcmd qw(dpkg-source --after-build .) + if $patches_applied_dirtily & 01; + rmtree '.pc' + if $patches_applied_dirtily & 02; + $patches_applied_dirtily = 0; +} + +#----- other building ----- + +our $clean_using_builder; +# ^ tree is to be cleaned by dpkg-source's builtin idea that it should +# clean the tree before building (perhaps invoked indirectly by +# whatever we are using to run the build), rather than separately +# and explicitly by us. + sub clean_tree () { + return if $clean_using_builder; if ($cleanmode eq 'dpkg-source') { + maybe_apply_patches_dirtily(); runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean); + } elsif ($cleanmode eq 'dpkg-source-d') { + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean); } elsif ($cleanmode eq 'git') { runcmd_ordryrun_local @git, qw(clean -xdf); + } elsif ($cleanmode eq 'git-ff') { + runcmd_ordryrun_local @git, qw(clean -xdff); + } elsif ($cleanmode eq 'check') { + my $leftovers = cmdoutput @git, qw(clean -xdn); + if (length $leftovers) { + print STDERR $leftovers, "\n" or die $!; + fail "tree contains uncommitted files and --clean=check specified"; + } } elsif ($cleanmode eq 'none') { } else { die "$cleanmode ?"; @@ -2026,22 +5777,44 @@ sub clean_tree () { sub cmd_clean () { badusage "clean takes no additional arguments" if @ARGV; + notpushing(); clean_tree(); + maybe_unapply_patches_again(); } -sub build_prep () { +sub build_prep_early () { + our $build_prep_early_done //= 0; + return if $build_prep_early_done++; badusage "-p is not allowed when building" if defined $package; - check_not_dirty(); - clean_tree(); my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; + notpushing(); + check_not_dirty(); +} + +sub build_prep () { + build_prep_early(); + clean_tree(); build_maybe_quilt_fixup(); + if ($rmchanges) { + my $pat = changespat $version; + foreach my $f (glob "$buildproductsdir/$pat") { + if (act_local()) { + unlink $f or fail "remove old changes file $f: $!"; + } else { + progress "would remove $f"; + } + } + } } -sub changesopts () { +sub changesopts_initial () { my @opts =@changesopts[1..$#changesopts]; +} + +sub changesopts_version () { if (!defined $changes_since_version) { my @vsns = archive_query('archive_query'); my @quirk = access_quirk(); @@ -2053,7 +5826,7 @@ sub changesopts () { } if (@vsns) { @vsns = map { $_->[0] } @vsns; - @vsns = sort { -version_compare_string($a, $b) } @vsns; + @vsns = sort { -version_compare($a, $b) } @vsns; $changes_since_version = $vsns[0]; progress "changelog will contain changes since $vsns[0]"; } else { @@ -2062,44 +5835,290 @@ sub changesopts () { } } if ($changes_since_version ne '_') { - unshift @opts, "-v$changes_since_version"; + return ("-v$changes_since_version"); + } else { + return (); + } +} + +sub changesopts () { + return (changesopts_initial(), changesopts_version()); +} + +sub massage_dbp_args ($;$) { + my ($cmd,$xargs) = @_; + # We need to: + # + # - if we're going to split the source build out so we can + # do strange things to it, massage the arguments to dpkg-buildpackage + # so that the main build doessn't build source (or add an argument + # to stop it building source by default). + # + # - add -nc to stop dpkg-source cleaning the source tree, + # unless we're not doing a split build and want dpkg-source + # as cleanmode, in which case we can do nothing + # + # return values: + # 0 - source will NOT need to be built separately by caller + # +1 - source will need to be built separately by caller + # +2 - source will need to be built separately by caller AND + # dpkg-buildpackage should not in fact be run at all! + debugcmd '#massaging#', @$cmd if $debuglevel>1; +#print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation); + if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) { + $clean_using_builder = 1; + return 0; + } + # -nc has the side effect of specifying -b if nothing else specified + # and some combinations of -S, -b, et al, are errors, rather than + # later simply overriding earlie. So we need to: + # - search the command line for these options + # - pick the last one + # - perhaps add our own as a default + # - perhaps adjust it to the corresponding non-source-building version + my $dmode = '-F'; + foreach my $l ($cmd, $xargs) { + next unless $l; + @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l; + } + push @$cmd, '-nc'; +#print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode); + my $r = 0; + if ($need_split_build_invocation) { + printdebug "massage split $dmode.\n"; + $r = $dmode =~ m/[S]/ ? +2 : + $dmode =~ y/gGF/ABb/ ? +1 : + $dmode =~ m/[ABb]/ ? 0 : + die "$dmode ?"; + } + printdebug "massage done $r $dmode.\n"; + push @$cmd, $dmode; +#print STDERR "MASS2 ",Dumper($cmd, $xargs, $r); + return $r; +} + +sub 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 <<END.$msg_if_onlyone if defined $msg_if_onlyone; +only one changes file from build (@changesfiles) +END + $result = $changesfiles[0]; + } elsif (@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}: $!"; + } + } + $result = $multichanges; + } else { + fail "wrong number of different changes files (@changesfiles)"; + } + printdone "build successful, results in $result\n" or die $!; +} + +sub midbuild_checkchanges () { + my $pat = changespat $version; + return if $rmchanges; + my @unwanted = map { s#^\.\./##; $_; } glob "../$pat"; + @unwanted = grep { $_ ne changespat $version,'source' } @unwanted; + fail <<END +changes files other than source matching $pat already present; building would result in ambiguity about the intended results. +Suggest you delete @unwanted. +END + if @unwanted; +} + +sub midbuild_checkchanges_vanilla ($) { + my ($wantsrc) = @_; + midbuild_checkchanges() if $wantsrc == 1; +} + +sub postbuild_mergechanges_vanilla ($) { + my ($wantsrc) = @_; + if ($wantsrc == 1) { + in_parent { + postbuild_mergechanges(undef); + }; + } else { + printdone "build successful\n"; } - return @opts; } sub cmd_build { - build_prep(); - runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV; - printdone "build successful\n"; + build_prep_early(); + my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV); + my $wantsrc = massage_dbp_args \@dbp; + if ($wantsrc > 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; + } + maybe_unapply_patches_again(); + postbuild_mergechanges_vanilla $wantsrc; } -sub cmd_git_build { - build_prep(); - my @cmd = - (qw(git-buildpackage -us -uc --git-no-sign-tags), - "--git-builder=@dpkgbuildpackage"); - unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) { - canonicalise_suite(); - push @cmd, "--git-debian-branch=".lbranch(); +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; } - push @cmd, changesopts(); - runcmd_ordryrun_local @cmd, @ARGV; - printdone "build successful\n"; + + my @dbp = @dpkgbuildpackage; + + my $wantsrc = massage_dbp_args \@dbp, \@ARGV; + + if (!length $gbp_build[0]) { + if (length executable_on_path('git-buildpackage')) { + $gbp_build[0] = qw(git-buildpackage); + } else { + $gbp_build[0] = 'gbp buildpackage'; + } + } + my @cmd = opts_opt_multi_cmd @gbp_build; + + push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp"); + + if ($gbp_make_orig) { + ensuredir '.git/dgit'; + my $ok = '.git/dgit/origs-gen-ok'; + unlink $ok or $!==&ENOENT or die $!; + my @origs_cmd = @cmd; + push @origs_cmd, qw(--git-cleaner=true); + push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok"; + push @origs_cmd, @ARGV; + if (act_local()) { + debugcmd @origs_cmd; + system @origs_cmd; + do { local $!; stat_exists $ok; } + or failedcmd @origs_cmd; + } else { + dryrun_report @origs_cmd; + } + } + + if ($wantsrc > 0) { + build_source(); + midbuild_checkchanges_vanilla $wantsrc; + } else { + if (!$clean_using_builder) { + push @cmd, '--git-cleaner=true'; + } + build_prep(); + } + maybe_unapply_patches_again(); + if ($wantsrc < 2) { + push @cmd, changesopts(); + runcmd_ordryrun_local @cmd, @ARGV; + } + postbuild_mergechanges_vanilla $wantsrc; } +sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0 sub build_source { + build_prep_early(); + my $our_cleanmode = $cleanmode; + if ($need_split_build_invocation) { + # Pretend that clean is being done some other way. This + # forces us not to try to use dpkg-buildpackage to clean and + # build source all in one go; and instead we run dpkg-source + # (and build_prep() will do the clean since $clean_using_builder + # is false). + $our_cleanmode = 'ELSEWHERE'; + } + if ($our_cleanmode =~ m/^dpkg-source/) { + # dpkg-source invocation (below) will clean, so build_prep shouldn't + $clean_using_builder = 1; + } build_prep(); - $sourcechanges = "${package}_".(stripepoch $version)."_source.changes"; + $sourcechanges = changespat $version,'source'; + if (act_local()) { + unlink "../$sourcechanges" or $!==ENOENT + or fail "remove $sourcechanges: $!"; + } $dscfn = dscfn($version); - if ($cleanmode eq 'dpkg-source') { - runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)), + if ($our_cleanmode eq 'dpkg-source') { + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S), + changesopts(); + } elsif ($our_cleanmode eq 'dpkg-source-d') { + maybe_apply_patches_dirtily(); + runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d), changesopts(); } else { - my $pwd = must_getcwd(); - my $leafdir = basename $pwd; - changedir ".."; - runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir; - changedir $pwd; + my @cmd = (@dpkgsource, qw(-b --)); + if ($split_brain) { + changedir $ud; + runcmd_ordryrun_local @cmd, "work"; + my @udfiles = <${package}_*>; + changedir "../../.."; + foreach my $f (@udfiles) { + printdebug "source copy, found $f\n"; + next unless + $f eq $dscfn or + ($f =~ m/\.debian\.tar(?:\.\w+)$/ && + $f eq srcfn($version, $&)); + printdebug "source copy, found $f - renaming\n"; + rename "$ud/$f", "../$f" or $!==ENOENT + or fail "put in place new source file ($f): $!"; + } + } else { + my $pwd = must_getcwd(); + my $leafdir = basename $pwd; + changedir ".."; + runcmd_ordryrun_local @cmd, $leafdir; + changedir $pwd; + } runcmd_ordryrun_local qw(sh -ec), 'exec >$1; shift; exec "$@"','x', "../$sourcechanges", @@ -2108,46 +6127,268 @@ sub build_source { } sub cmd_build_source { + build_prep_early(); 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(); - changedir ".."; - my $pat = "${package}_".(stripepoch $version)."_*.changes"; - if (act_local()) { - stat $dscfn or fail "$dscfn (in parent directory): $!"; - stat $sourcechanges or fail "$sourcechanges (in parent directory): $!"; - foreach my $cf (glob $pat) { - next if $cf eq $sourcechanges; - unlink $cf or fail "remove $cf: $!"; + midbuild_checkchanges(); + in_parent { + if (act_local()) { + stat_exists $dscfn or fail "$dscfn (in parent directory): $!"; + stat_exists $sourcechanges + or fail "$sourcechanges (in parent directory): $!"; } - } - runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $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; - runcmd_ordryrun_local @mergechanges, @changesfiles; - my $multichanges = "${package}_".(stripepoch $version)."_multi.changes"; - if (act_local()) { - stat $multichanges or fail "$multichanges: $!"; - } - 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(<<END); +perhaps you need to pass -A ? (sbuild's default is to build only +arch-specific binaries; dgit 1.4 used to override that.) +END + }; } sub cmd_quilt_fixup { badusage "incorrect arguments to dgit quilt-fixup" if @ARGV; - my $clogp = parsechangelog(); - $version = getfield $clogp, 'Version'; + build_prep_early(); + clean_tree(); build_maybe_quilt_fixup(); } +sub import_dsc_result { + my ($dstref, $newhash, $what_log, $what_msg) = @_; + my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash); + runcmd @cmd; + check_gitattrs($newhash, "source tree"); + + progress "dgit: import-dsc: $what_msg"; +} + +sub cmd_import_dsc { + my $needsig = 0; + + while (@ARGV) { + last unless $ARGV[0] =~ m/^-/; + $_ = shift @ARGV; + last if m/^--?$/; + if (m/^--require-valid-signature$/) { + $needsig = 1; + } else { + badusage "unknown dgit import-dsc sub-option \`$_'"; + } + } + + badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2; + my ($dscfn, $dstbranch) = @ARGV; + + badusage "dry run makes no sense with import-dsc" unless act_local(); + + my $force = $dstbranch =~ s/^\+// ? +1 : + $dstbranch =~ s/^\.\.// ? -1 : + 0; + my $info = $force ? " $&" : ''; + $info = "$dscfn$info"; + + my $specbranch = $dstbranch; + $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#; + $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch; + + my @symcmd = (@git, qw(symbolic-ref -q HEAD)); + my $chead = cmdoutput_errok @symcmd; + defined $chead or $?==256 or failedcmd @symcmd; + + fail "$dstbranch is checked out - will not update it" + if defined $chead and $chead eq $dstbranch; + + my $oldhash = git_get_ref $dstbranch; + + open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!"; + $dscdata = do { local $/ = undef; <D>; }; + 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(); + + $package = getfield $dsc, 'Source'; + + parse_dsc_field($dsc, "Dgit metadata in .dsc") + unless forceing [qw(import-dsc-with-dgit-field)]; + parse_dsc_field_def_dsc_distro(); + + $isuite = 'DGIT-IMPORT-DSC'; + $idistro //= $dsc_distro; + + notpushing(); + + if (defined $dsc_hash) { + progress "dgit: import-dsc of .dsc with Dgit field, using git hash"; + resolve_dsc_field_commit undef, undef; + } + if (defined $dsc_hash) { + my @cmd = (qw(sh -ec), + "echo $dsc_hash | git cat-file --batch-check"); + my $objgot = cmdoutput @cmd; + if ($objgot =~ m#^\w+ missing\b#) { + fail <<END +.dsc contains Dgit field referring to object $dsc_hash +Your git tree does not have that object. Try `git fetch' from a +plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again. +END + } + if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) { + if ($force > 0) { + progress "Not fast forward, forced update."; + } else { + fail "Not fast forward to $dsc_hash"; + } + } + import_dsc_result $dstbranch, $dsc_hash, + "dgit import-dsc (Dgit): $info", + "updated git ref $dstbranch"; + return 0; + } + + fail <<END +Branch $dstbranch already exists +Specify ..$specbranch for a pseudo-merge, binding in existing history +Specify +$specbranch to overwrite, discarding existing history +END + if $oldhash && !$force; + + my @dfi = dsc_files_info(); + foreach my $fi (@dfi) { + my $f = $fi->{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'; + my $clogp = commit_getclogp $newhash; + my $authline = clogp_authline $clogp; + $newhash = make_commit_text <<END; +tree $tree +parent $newhash +parent $oldhash +author $authline +committer $authline + +Merge $package ($version) import into $dstbranch +END + } else { + die; # caught earlier + } + } + + import_dsc_result $dstbranch, $newhash, + "dgit import-dsc: $info", + "results are in in git ref $dstbranch"; +} + +sub cmd_archive_api_query { + badusage "need only 1 subpath argument" unless @ARGV==1; + my ($subpath) = @ARGV; + my @cmd = archive_api_query_cmd($subpath); + push @cmd, qw(-f); + debugcmd ">",@cmd; + exec @cmd or fail "exec curl: $!\n"; +} + +sub repos_server_url () { + $package = '_dgit-repos-server'; + local $access_forpush = 1; + local $isuite = 'DGIT-REPOS-SERVER'; + my $url = access_giturl(); +} + +sub cmd_clone_dgit_repos_server { + badusage "need destination argument" unless @ARGV==1; + my ($destdir) = @ARGV; + my $url = repos_server_url(); + my @cmd = (@git, qw(clone), $url, $destdir); + debugcmd ">",@cmd; + exec @cmd or fail "exec git clone: $!\n"; +} + +sub cmd_print_dgit_repos_server_source_url { + badusage "no arguments allowed to dgit print-dgit-repos-server-source-url" + if @ARGV; + my $url = repos_server_url(); + print $url, "\n" or die $!; +} + +sub cmd_setup_mergechangelogs { + badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; + setup_mergechangelogs(1); +} + +sub cmd_setup_useremail { + badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; + setup_useremail(1); +} + +sub cmd_setup_gitattributes { + badusage "no arguments allowed to dgit setup-useremail" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; + setup_gitattrs(1); +} + +sub cmd_setup_new_tree { + badusage "no arguments allowed to dgit setup-tree" if @ARGV; + local $isuite = 'DGIT-SETUP-TREE'; + setup_new_tree(); +} + #---------- argument parsing and main program ---------- sub cmd_version { @@ -2155,6 +6396,65 @@ sub cmd_version { exit 0; } +our (%valopts_long, %valopts_short); +our (%funcopts_long); +our @rvalopts; +our (@modeopt_cfgs); + +sub defvalopt ($$$$) { + my ($long,$short,$val_re,$how) = @_; + my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how }; + $valopts_long{$long} = $oi; + $valopts_short{$short} = $oi; + # $how subref should: + # do whatever assignemnt or thing it likes with $_[0] + # if the option should not be passed on to remote, @rvalopts=() + # or $how can be a scalar ref, meaning simply assign the value +} + +defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version; +defvalopt '--distro', '-d', '.+', \$idistro; +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 { + ($changesfile) = (@_); + if ($changesfile =~ s#^(.*)/##) { + $buildproductsdir = $1; + } +}; + +defvalopt '--initiator-tempdir','','.*', sub { + ($initiator_tempdir) = (@_); + $initiator_tempdir =~ m#^/# or + badusage "--initiator-tempdir must be used specify an". + " absolute, not relative, directory." +}; + +sub defoptmodes ($@) { + my ($varref, $cfgkey, $default, %optmap) = @_; + my %permit; + while (my ($opt,$val) = each %optmap) { + $funcopts_long{$opt} = sub { $$varref = $val; }; + $permit{$val} = $val; + } + push @modeopt_cfgs, { + Var => $varref, + Key => $cfgkey, + Default => $default, + Vals => \%permit + }; +} + +defoptmodes \$dodep14tag, qw( dep14tag want + --dep14tag want + --no-dep14tag no + --always-dep14tag always ); + sub parseopts () { my $om; @@ -2164,6 +6464,27 @@ sub parseopts () { @ssh = ($ENV{'GIT_SSH'}); } + my $oi; + my $val; + my $valopt = sub { + my ($what) = @_; + @rvalopts = ($_); + if (!defined $val) { + badusage "$what needs a value" unless @ARGV; + $val = shift @ARGV; + push @rvalopts, $val; + } + badusage "bad value \`$val' for $what" unless + $val =~ m/^$oi->{Re}$(?!\n)/s; + my $how = $oi->{How}; + if (ref($how) eq 'SCALAR') { + $$how = $val; + } else { + $how->($val); + } + push @ropts, @rvalopts; + }; + while (@ARGV) { last unless $ARGV[0] =~ m/^-/; $_ = shift @ARGV; @@ -2185,10 +6506,7 @@ sub parseopts () { } elsif (m/^--new$/) { push @ropts, $_; $new_package=1; - } elsif (m/^--since-version=([^_]+|_)$/) { - push @ropts, $_; - $changes_since_version = $1; - } elsif (m/^--([-0-9a-z]+)=(.*)/s && + } elsif (m/^--([-0-9a-z]+)=(.+)/s && ($om = $opts_opt_map{$1}) && length $om->[0]) { push @ropts, $_; @@ -2198,34 +6516,68 @@ sub parseopts () { ($om = $opts_opt_map{$1})) { push @ropts, $_; push @$om, $2; - } elsif (m/^--existing-package=(.*)/s) { - push @ropts, $_; - $existing_package = $1; - } elsif (m/^--initiator-tempdir=(.*)/s) { - $initiator_tempdir = $1; - $initiator_tempdir =~ m#^/# or - badusage "--initiator-tempdir must be used specify an". - " absolute, not relative, directory." - } elsif (m/^--distro=(.*)/s) { - push @ropts, $_; - $idistro = $1; - } elsif (m/^--build-products-dir=(.*)/s) { - push @ropts, $_; - $buildproductsdir = $1; - } elsif (m/^--clean=(dpkg-source|git|none)$/s) { - push @ropts, $_; - $cleanmode = $1; - } elsif (m/^--clean=(.*)$/s) { - badusage "unknown cleaning mode \`$1'"; + } elsif (m/^--(gbp|dpm)$/s) { + push @ropts, "--quilt=$1"; + $quilt_mode = $1; } elsif (m/^--ignore-dirty$/s) { push @ropts, $_; $ignoredirty = 1; } elsif (m/^--no-quilt-fixup$/s) { push @ropts, $_; - $noquilt = 1; + $quilt_mode = 'nocheck'; } elsif (m/^--no-rm-on-error$/s) { push @ropts, $_; $rmonerror = 0; + } elsif (m/^--no-chase-dsc-distro$/s) { + push @ropts, $_; + $chase_dsc_distro = 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, $_; + $need_split_build_invocation = 1; + } elsif (m/^--config-lookup-explode=(.+)$/s) { + # undocumented, for testing + push @ropts, $_; + $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE'; + # ^ it's supposed to be an array ref + } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) { + $val = $2 ? $' : undef; #'; + $valopt->($oi->{Long}); + } elsif ($funcopts_long{$_}) { + push @ropts, $_; + $funcopts_long{$_}(); } else { badusage "unknown long option \`$_'"; } @@ -2241,42 +6593,44 @@ sub parseopts () { cmd_help(); } elsif (s/^-D/-/) { push @ropts, $&; - open DEBUG, ">&STDERR" or die $!; - autoflush DEBUG 1; - $debug++; + $debuglevel++; + enabledebug(); } elsif (s/^-N/-/) { push @ropts, $&; $new_package=1; - } elsif (s/^-v([^_]+|_)$//s) { - push @ropts, $&; - $changes_since_version = $1; } elsif (m/^-m/) { push @ropts, $&; push @changesopts, $_; $_ = ''; - } elsif (s/^-c(.*=.*)//s) { - push @ropts, $&; - push @git, '-c', $1; - } elsif (s/^-d(.*)//s) { - push @ropts, $&; - $idistro = $1; - } elsif (s/^-C(.*)//s) { - push @ropts, $&; - $changesfile = $1; - if ($changesfile =~ s#^(.*)/##) { - $buildproductsdir = $1; - } - } elsif (s/^-k(.*)//s) { - $keyid=$1; - } elsif (s/^-wn//s) { + } elsif (s/^-wn$//s) { push @ropts, $&; $cleanmode = 'none'; - } elsif (s/^-wg//s) { + } elsif (s/^-wg$//s) { push @ropts, $&; $cleanmode = 'git'; - } elsif (s/^-wd//s) { + } elsif (s/^-wgf$//s) { + push @ropts, $&; + $cleanmode = 'git-ff'; + } elsif (s/^-wd$//s) { push @ropts, $&; $cleanmode = 'dpkg-source'; + } elsif (s/^-wdd$//s) { + push @ropts, $&; + $cleanmode = 'dpkg-source-d'; + } 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; + $valopt->($oi->{Short}); + $_ = ''; } else { badusage "unknown short option \`$_'"; } @@ -2285,11 +6639,108 @@ 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 <<END; +On entry to dgit, $@ +This is a bug produced by something in in your execution environment. +Giving up. +END +} + + +sub parseopts_late_defaults () { + $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF') + if defined $idistro; + $isuite //= cfg('dgit.default.default-suite'); + + foreach my $k (keys %opts_opt_map) { + my $om = $opts_opt_map{$k}; + + my $v = access_cfg("cmd-$k", 'RETURN-UNDEF'); + if (defined $v) { + badcfg "cannot set command for $k" + unless length $om->[0]; + $om->[0] = $v; + } + + foreach my $c (access_cfg_cfgs("opts-$k")) { + my @vl = + map { $_ ? @$_ : () } + map { $gitcfgs{$_}{$c} } + reverse @gitcfgsources; + printdebug "CL $c ", (join " ", map { shellquote } @vl), + "\n" if $debuglevel >= 4; + 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, + @$om[$insertpos..$#$om] ); + } + } + + if (!defined $rmchanges) { + local $access_forpush; + $rmchanges = access_cfg_bool(0, 'rm-old-changes'); + } + + if (!defined $quilt_mode) { + local $access_forpush; + $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF') + // access_cfg('quilt-mode', 'RETURN-UNDEF') + // 'linear'; + $quilt_mode =~ m/^($quilt_modes_re)$/ + or badcfg "unknown quilt-mode \`$quilt_mode'"; + $quilt_mode = $1; + } + + foreach my $moc (@modeopt_cfgs) { + local $access_forpush; + my $vr = $moc->{Var}; + next if defined $$vr; + $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default}; + my $v = $moc->{Vals}{$$vr}; + badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v; + $$vr = $v; + } + + $need_split_build_invocation ||= quiltmode_splitbrain(); + + if (!defined $cleanmode) { + local $access_forpush; + $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF'); + $cleanmode //= 'dpkg-source'; + + badcfg "unknown clean-mode \`$cleanmode'" unless + $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s; + } +} + if ($ENV{$fakeeditorenv}) { + git_slurp_config(); quilt_fixup_editor(); } parseopts(); +check_env_sanity(); +git_slurp_config(); + print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1; print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n" if $dryrun_level == 1; @@ -2300,6 +6751,9 @@ if (!@ARGV) { my $cmd = shift @ARGV; $cmd =~ y/-/_/; +my $pre_fn = ${*::}{"pre_$cmd"}; +$pre_fn->() if $pre_fn; + my $fn = ${*::}{"cmd_$cmd"}; $fn or badusage "unknown operation $cmd"; $fn->(); |