X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=a67c12cb09ceac540f5d4f359987cbe68abcbd5c;hp=11f473ca8bf7c56096316094382db3f45f150a6e;hb=b5c3e33d87675507eff29ba1d5e1c4998b15f3fd;hpb=1837d3b05b891491c548a4a3b869f5ed24239886 diff --git a/dgit b/dgit index 11f473ca..a67c12cb 100755 --- a/dgit +++ b/dgit @@ -19,7 +19,7 @@ use strict; -use Debian::Dgit; +use Debian::Dgit qw(:DEFAULT :playground); setup_sigwarn(); use IO::Handle; @@ -34,7 +34,6 @@ use POSIX; use IPC::Open2; use Digest::SHA; use Digest::MD5; -use List::Util qw(any); use List::MoreUtils qw(pairwise); use Text::Glob qw(match_glob); use Fcntl qw(:DEFAULT :flock); @@ -48,6 +47,8 @@ our $absurdity = undef; ###substituted### our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format our $protovsn; +our $cmd; +our $subcommand; our $isuite; our $idistro; our $package; @@ -70,7 +71,6 @@ 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 $dodep14tag_re = 'want|no|always'; our $split_brain_save; our $we_are_responder; our $we_are_initiator; @@ -102,7 +102,7 @@ our $rewritemap = 'dgit-rewrite/map'; our (@git) = qw(git); our (@dget) = qw(dget); -our (@curl) = qw(curl); +our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L)); our (@dput) = qw(dput); our (@debsign) = qw(debsign); our (@gpg) = qw(gpg); @@ -145,6 +145,8 @@ our %opts_cfg_insertpos = map { } keys %opts_opt_map; sub parseopts_late_defaults(); +sub setup_gitattrs(;$); +sub check_gitattrs($$); our $keyid; @@ -156,6 +158,7 @@ our $split_brain = 0; END { local ($@, $?); + return unless forkcheck_mainprocess(); print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg; } @@ -220,6 +223,7 @@ initdebug(''); our @end; END { local ($?); + return unless forkcheck_mainprocess(); foreach my $f (@end) { eval { $f->(); }; print STDERR "$us: cleanup: $@" if length $@; @@ -247,12 +251,6 @@ sub no_such_package () { exit 4; } -sub changedir ($) { - my ($newdir) = @_; - printdebug "CD $newdir\n"; - chdir $newdir or confess "chdir: $newdir: $!"; -} - sub deliberately ($) { my ($enquiry) = @_; return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies; @@ -314,6 +312,9 @@ sub gbp_pq { # > param tagformat old|new # > param maint-view MAINT-VIEW-HEAD # +# > param buildinfo-filename P_V_X.buildinfo # zero or more times +# > file buildinfo # for buildinfos to sign +# # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward # # goes into tag, for replay prevention # @@ -330,6 +331,9 @@ sub gbp_pq { # [etc] # < data-block NBYTES [transfer of signed changes] # [etc] +# < data-block NBYTES [transfer of each signed buildinfo +# [etc] same number and order as "file buildinfo"] +# ... # < files-end # # > complete @@ -485,12 +489,6 @@ sub url_get { our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn); -sub runcmd { - debugcmd "+",@_; - $!=0; $?=-1; - failedcmd @_ if system @_; -} - sub act_local () { return $dryrun_level <= 1; } sub act_scary () { return !$dryrun_level; } @@ -558,6 +556,9 @@ sub nextarg { return scalar shift @ARGV; } +sub pre_help () { + not_necessarily_a_tree(); +} sub cmd_help () { print $helpmsg or die $!; exit 0; @@ -634,32 +635,17 @@ our %defcfg = ('dgit.default.distro' => 'debian', our %gitcfgs; our @gitcfgsources = qw(cmdline local global system); +our $invoked_in_git_tree = 1; 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 () { - chomp or die; - printdebug "=> ", (messagequote $_), "\n"; - m/\n/ or die "$_ ?"; - push @{ $gitcfgs{$src}{$`} }, $'; #'; - } - $!=0; $?=0; - close GITS - or ($!==0 && $?==256) - or failedcmd @cmd; + $gitcfgs{$src} = git_slurp_config_src $src; } } @@ -667,7 +653,7 @@ sub git_get_config ($) { my ($c) = @_; foreach my $src (@gitcfgsources) { my $l = $gitcfgs{$src}{$c}; - croak "$l $c" if $l && !ref $l; + confess "internal error ($l $c)" if $l && !ref $l; printdebug"C $c ".(defined $l ? join " ", map { messagequote "'$_'" } @$l : "undef")."\n" @@ -696,6 +682,12 @@ sub cfg { "$us: distro or suite appears not to be (properly) supported"; } +sub not_necessarily_a_tree () { + # needs to be called from pre_* + @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources; + $invoked_in_git_tree = 0; +} + sub access_basedistro__noalias () { if (defined $idistro) { return $idistro; @@ -995,12 +987,6 @@ sub commit_getclogp ($) { $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog"); } -sub must_getcwd () { - my $d = getcwd(); - defined $d or fail "getcwd failed: $!"; - return $d; -} - sub parse_dscdata () { my $dscfh = new IO::File \$dscdata, '<' or die $!; printdebug Dumper($dscdata) if $debuglevel>1; @@ -1317,6 +1303,8 @@ sub archive_query_aptget { return [ (getfield $pre_dsc, 'Version'), $uri ]; } +sub file_in_archive_aptget () { return undef; } + #---------- `dummyapicat' archive query method ---------- sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; } @@ -1682,21 +1670,13 @@ sub create_remote_git_repo () { our ($dsc_hash,$lastpush_mergeinput); our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url); -our $ud = '.git/dgit/unpack'; -sub prep_ud (;$) { - my ($d) = @_; - $d //= $ud; - rmtree($d); - mkpath '.git/dgit'; - mkdir $d or die $!; +sub prep_ud () { + fresh_playground 'dgit/unpack'; } sub mktree_in_ud_here () { - runcmd qw(git init -q); - runcmd qw(git config gc.auto 0); - rmtree('.git/objects'); - symlink '../../../../objects','.git/objects' or die $!; + playtree_setup $gitcfgs{local}; } sub git_write_tree () { @@ -1985,7 +1965,14 @@ sub make_commit_text ($) { 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/$git_authline_re/o or @@ -2064,29 +2051,50 @@ sub generate_commits_from_dsc () { # See big comment in fetch_from_archive, below. # See also README.dsc-import. prep_ud(); - changedir $ud; + changedir $playground; 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"; + } - printdebug "considering linking $f: "; - - link_ltarget "../../../../$f", $f - or ((printdebug "($!) "), 0) - or $!==&ENOENT - or die "$f $!"; - - printdebug "linked.\n"; - - complete_file_from_dsc('.', $fi) + my $refetched; + complete_file_from_dsc('.', $fi, \$refetched) or next; - if (is_orig_file_in_dsc($f, \@dfi)) { - link $f, "../../../../$f" - or $!==&EEXIST - or die "$f $!"; + 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"; } } @@ -2129,7 +2137,7 @@ sub generate_commits_from_dsc () { if defined $compr_ext && !defined $cname; my $compr_proc = new Dpkg::Compression::Process compression => $cname; - my @compr_cmd = $compr_proc->get_uncompress_cmdline(); + @compr_cmd = $compr_proc->get_uncompress_cmdline(); my $compr_fh = new IO::Handle; my $compr_pid = open $compr_fh, "-|" // die $!; if (!$compr_pid) { @@ -2156,7 +2164,7 @@ sub generate_commits_from_dsc () { !$? or failedcmd @tarcmd; close $input or - (@compr_cmd ? failedcmd @compr_cmd + (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd) : die $!); # finally, we have the results in "tarball", but maybe # with the wrong permissions @@ -2286,6 +2294,7 @@ sub generate_commits_from_dsc () { my $authline = clogp_authline $clogp; my $changes = getfield $clogp, 'Changes'; + $changes =~ s/^\n//; # Changes: \n my $cversion = getfield $clogp, 'Version'; if (@tartrees) { @@ -2452,44 +2461,61 @@ END @output = $lastpush_mergeinput; } } - changedir '../../../..'; - rmtree($ud); + changedir $maindir; + rmtree $playground; 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; + my $got; + my $checkhash = sub { + open F, "<", "$tf" or die "$tf: $!"; + $fi->{Digester}->reset(); + $fi->{Digester}->addfile(*F); + F->error and die $!; + $got = $fi->{Digester}->hexdigest(); + return $got eq $fi->{Hash}; + }; + if (stat_exists $tf) { - progress "using existing $f"; + 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 { printdebug "$tf does not exist, need to fetch\n"; - my $furl = $dscurl; - $furl =~ s{/[^/]+$}{}; - $furl .= "/$f"; - die "$f ?" unless $f =~ m/^\Q${package}\E_/; - die "$f ?" if $f =~ m#/#; - runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl"; - return 0 if !act_local(); - $downloaded = 1; - } - - 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; } @@ -2517,7 +2543,7 @@ sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); } # (If we deleted them unconditionally, then we might end up # re-fetching the same git objects each time dgit fetch was run.) # -# So, leach use of lrfetchrefs needs to be accompanied by arrangements +# 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. @@ -2531,7 +2557,7 @@ sub lrfetchref_used ($) { } sub git_lrfetch_sane { - my ($supplementary, @specs) = @_; + 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 @@ -2562,8 +2588,6 @@ sub git_lrfetch_sane { # git fetch to try to generate it. If we don't manage to generate # the target state, we try again. - my $url = access_giturl(); - printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n"; my $specre = join '|', map { @@ -2703,7 +2727,8 @@ sub git_fetch_us () { push @specs, $rewritemap; push @specs, qw(heads/*) if deliberately_not_fast_forward; - git_lrfetch_sane 0, @specs; + my $url = access_giturl(); + git_lrfetch_sane $url, 0, @specs; my %here; my @tagpats = debiantags('*',access_nomdistro); @@ -2724,8 +2749,8 @@ sub git_fetch_us () { } elsif ($here{$lref} eq $objid) { lrfetchref_used $fullrefname; } else { - print STDERR \ - "Not updateting $lref from $here{$lref} to $objid.\n"; + print STDERR + "Not updating $lref from $here{$lref} to $objid.\n"; } }); } @@ -2760,6 +2785,11 @@ sub fetch_from_archive_record_2 ($) { } } +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; @@ -2767,16 +2797,17 @@ sub parse_dsc_field ($$) { $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 = $&; - $dsc_distro //= cfg qw(dgit.default.old-dsc-distro - dgit.default.distro); + parse_dsc_field_def_dsc_distro(); $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'), $dsc_distro ]; progress "$what: specified git hash"; @@ -2826,13 +2857,13 @@ END or fail <("rewrite map", $rewritemap) or return; - $mapref = $lrf.'/'.$rewritemap; + 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) { @@ -2870,7 +2903,7 @@ 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); +# 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; @@ -3208,6 +3241,8 @@ END lrfetchref_used lrfetchref(); + check_gitattrs($hash, "fetched source tree"); + unshift @end, $del_lrfetchrefs; return $hash; } @@ -3269,11 +3304,89 @@ sub ensure_setup_existing_tree () { 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 < $af.new" or die $!; + print GAO <) { + 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 <(), and returns undef @@ -3281,6 +3394,7 @@ sub multisuite_suite_child ($$$) { my $canonsuitefh = IO::File::new_tmpfile; my $pid = fork // die $!; if (!$pid) { + forkcheck_setup(); $isuite = $tsuite; $us .= " [$isuite]"; $debugprefix .= " "; @@ -3338,6 +3452,7 @@ sub fork_for_multisuite ($) { $before_fetch_merge->(); foreach my $tsuite (@suites[1..$#suites]) { + $tsuite =~ s/^-/$cbasesuite-/; my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs, sub { @end = (); @@ -3452,6 +3567,9 @@ END } sub clone ($) { + # in multisuite, returns twice! + # once in parent after first suite fetched, + # and then again in child after everything is finished my ($dstdir) = @_; badusage "dry run makes no sense with clone" unless act_local(); @@ -3463,7 +3581,7 @@ sub clone ($) { printdebug "multi clone after fetch merge\n"; clone_set_head(); clone_finish($dstdir); - exit 0; + return; } printdebug "clone main body\n"; @@ -3472,6 +3590,8 @@ sub clone ($) { mkdir $dstdir or fail "create \`$dstdir': $!"; changedir $dstdir; runcmd @git, qw(init -q); + record_maindir(); + setup_new_tree(); clone_set_head(); my $giturl = access_giturl(1); if (defined $giturl) { @@ -3490,7 +3610,6 @@ sub clone ($) { $vcsgiturl =~ s/\s+-b\s+\S+//g; runcmd @git, qw(remote add vcs-git), $vcsgiturl; } - setup_new_tree(); clone_finish($dstdir); } @@ -3669,18 +3788,28 @@ sub pseudomerge_version_check ($$) { } 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 $cv = [ (getfield $vclogp, 'Version'), - "Version field from dpkg-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 <[0] =~ m/UNRELEASED/; +$cd->[1] is $cd->[0] +Your tree seems to based on earlier (not uploaded) $v. +END } } @@ -3738,6 +3867,7 @@ sub splitbrain_pseudomerge ($$$$) { # return $dgitview unless defined $archive_hash; + return $dgitview if deliberately_not_fast_forward(); printdebug "splitbrain_pseudomerge...\n"; @@ -4039,7 +4169,7 @@ END if (madformat_wantfixup($format)) { # user might have not used dgit build, so maybe do this now: if (quiltmode_splitbrain()) { - changedir $ud; + changedir $playground; quilt_make_fake_dsc($upstreamversion); my $cachekey; ($dgithead, $cachekey) = @@ -4052,7 +4182,7 @@ END $actualhead, $dgithead, $archive_hash); $maintviewhead = $actualhead; - changedir '../../../..'; + changedir $maindir; prep_ud(); # so _only_subdir() works, below } else { commit_quilty_patch(); @@ -4083,13 +4213,13 @@ END } } - changedir $ud; + changedir $playground; 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("source package"); check_for_vendor_patches() if madformat($dsc->{format}); - changedir '../../../..'; + changedir $maindir; my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead); debugcmd "+",@diffcmd; $!=0; $?=-1; @@ -4136,12 +4266,21 @@ END responder_send_file('changes',$changesfile); 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"); } + # Perhaps send buildinfo(s) for signing + my $changes_files = getfield $changes, 'Files'; + my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg); + foreach my $bi (@buildinfos) { + responder_send_command("param buildinfo-filename $bi"); + responder_send_file('buildinfo', "$buildproductsdir/$bi"); + } + if (deliberately_not_fast_forward) { git_for_each_ref(lrfetchrefs, sub { my ($objid,$objtype,$lrfetchrefname,$reftail) = @_; @@ -4212,9 +4351,10 @@ If you need to change the package, you must use a new version number. END if ($we_are_responder) { my $dryrunsuffix = act_local() ? "" : ".tmp"; + my @rfiles = ($dscpath, $changesfile); + push @rfiles, map { "$buildproductsdir/$_" } @buildinfos; responder_receive_files('signed-dsc-changes', - "$dscpath$dryrunsuffix", - "$changesfile$dryrunsuffix"); + map { "$_$dryrunsuffix" } @rfiles); } else { if (act_local()) { rename "$dscpath.tmp",$dscpath or die "$dscfn $!"; @@ -4240,6 +4380,9 @@ END responder_send_command("complete"); } +sub pre_clone () { + not_necessarily_a_tree(); +} sub cmd_clone { parseopts(); my $dstdir; @@ -4288,7 +4431,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 { @@ -4336,21 +4484,18 @@ END pull(); } -sub cmd_push { +sub prep_push () { parseopts(); - badusage "-p is not allowed with dgit push" if defined $package; + build_or_push_prep_early(); + pushing(); check_not_dirty(); - my $clogp = parsechangelog(); - $package = getfield $clogp, 'Source'; my $specsuite; if (@ARGV==0) { } elsif (@ARGV==1) { ($specsuite) = (@ARGV); } else { - badusage "incorrect arguments to dgit push"; + badusage "incorrect arguments to dgit $subcommand"; } - $isuite = getfield $clogp, 'Distribution'; - pushing(); if ($new_package) { local ($package) = $existing_package; # this is a hack canonicalise_suite(); @@ -4360,15 +4505,19 @@ sub cmd_push { if (defined $specsuite && $specsuite ne $isuite && $specsuite ne $csuite) { - fail "dgit push: changelog specifies $isuite ($csuite)". + fail "dgit $subcommand: changelog specifies $isuite ($csuite)". " but command line specifies $specsuite"; } +} + +sub cmd_push { + prep_push(); dopush(); } #---------- remote commands' implementation ---------- -sub cmd_remote_push_build_host { +sub pre_remote_push_build_host { my ($nrargs) = shift @ARGV; my (@rargs) = @ARGV[0..$nrargs-1]; @ARGV = @ARGV[$nrargs..$#ARGV]; @@ -4398,11 +4547,14 @@ sub cmd_remote_push_build_host { " but invocation host has $vsnwant" unless defined $protovsn; - responder_send_command("dgit-remote-push-ready $protovsn"); changedir $dir; +} +sub cmd_remote_push_build_host { + responder_send_command("dgit-remote-push-ready $protovsn"); &cmd_push; } +sub pre_remote_push_responder { pre_remote_push_build_host(); } 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) @@ -4431,7 +4583,10 @@ sub i_cleanup { } } -END { i_cleanup(); } +END { + return unless forkcheck_mainprocess(); + i_cleanup(); +} sub i_method { my ($base,$selector,@args) = @_; @@ -4439,8 +4594,10 @@ sub i_method { { no strict qw(refs); &{"${base}_${selector}"}(@args); } } +sub pre_rpush () { + not_necessarily_a_tree(); +} sub cmd_rpush { - pushing(); my $host = nextarg; my $dir; if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) { @@ -4475,11 +4632,6 @@ sub cmd_rpush { die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support; $supplementary_message = '' unless $protovsn >= 3; - fail "rpush negotiated protocol version $protovsn". - " which does not support quilt mode $quilt_mode" - if quiltmode_splitbrain; - - rpush_handle_protovsn_bothends(); for (;;) { my ($icmd,$iargs) = initiator_expect { m/^(\S+)(?: (.*))?$/; @@ -4543,6 +4695,18 @@ 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) { @@ -4551,7 +4715,7 @@ sub i_resp_want ($) { print RI "files-end\n" or die $!; } -our ($i_clogp, $i_version, $i_dscfn, $i_changesfn); +our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos); sub i_localname_parsed_changelog { return "remote-changelog.822"; @@ -4568,6 +4732,31 @@ sub i_localname_dsc { } sub i_file_dsc { } +sub i_localname_buildinfo ($) { + my $bi = $i_param{'buildinfo-filename'}; + defined $bi or badproto \*RO, "buildinfo before filename"; + defined $i_changesfn or badproto \*RO, "buildinfo before changes"; + $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s + or badproto \*RO, "improper buildinfo filename"; + return $&; +} +sub i_file_buildinfo { + my $bi = $i_param{'buildinfo-filename'}; + my $bd = parsecontrol "$i_tmp/$bi", $bi; + my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes'; + if (!forceing [qw(buildinfo-changes-mismatch)]) { + files_compare_inputs($bd, $ch); + (getfield $bd, $_) eq (getfield $ch, $_) or + fail "buildinfo mismatch $_" + foreach qw(Source Version); + !defined $bd->{$_} or + fail "buildinfo contains $_" + foreach qw(Changes Changed-by Distribution); + } + push @i_buildinfos, $bi; + delete $i_param{'buildinfo-filename'}; +} + sub i_localname_changes { defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)"; $i_changesfn = $i_dscfn; @@ -4609,7 +4798,7 @@ sub i_want_signed_tag { sub i_want_signed_dsc_changes { rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!"; sign_changes $i_changesfn; - return ($i_dscfn, $i_changesfn); + return ($i_dscfn, $i_changesfn, @i_buildinfos); } #---------- building etc. ---------- @@ -4658,7 +4847,7 @@ sub quiltify_trees_differ ($$;$$$) { # a list of unrepresentable changes (removals of upstream files # (as messages) local $/=undef; - my @cmd = (@git, qw(diff-tree -z)); + my @cmd = (@git, qw(diff-tree -z --no-renames)); push @cmd, qw(--name-only) unless $unrepres; push @cmd, qw(-r) if $finegrained || $unrepres; push @cmd, $x, $y; @@ -4677,16 +4866,23 @@ sub quiltify_trees_differ ($$;$$$) { if ($unrepres) { eval { - die "not a plain file\n" - unless $newmode =~ m/^10\d{4}$/ || - $oldmode =~ m/^10\d{4}$/; + die "not a plain file or symlink\n" + unless $newmode =~ m/^(?:10|12)\d{4}$/ || + $oldmode =~ m/^(?:10|12)\d{4}$/; if ($oldmode =~ m/[^0]/ && $newmode =~ m/[^0]/) { - die "mode changed\n" if $oldmode ne $newmode; + # both old and new files exist + die "mode or type changed\n" if $oldmode ne $newmode; + die "modified symlink\n" unless $newmode =~ m/^10/; + } elsif ($oldmode =~ m/[^0]/) { + # deletion + die "deletion of symlink\n" + unless $oldmode =~ m/^10/; } else { - die "non-default mode\n" - unless $newmode =~ m/^100644$/ || - $oldmode =~ m/^100644$/; + # creation + die "creation with non-default mode\n" + unless $newmode =~ m/^100644$/ or + $newmode =~ m/^120000$/; } }; if ($@) { @@ -4812,7 +5008,7 @@ END my $dgitview = git_rev_parse 'HEAD'; - changedir '../../../..'; + changedir $maindir; # When we no longer need to support squeeze, use --create-reflog # instead of this: ensuredir ".git/logs/refs/dgit-intern"; @@ -4837,7 +5033,7 @@ END runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache", $dgitview; - changedir '.git/dgit/unpack/work'; + changedir "$playground/work"; my $saved = maybe_split_brain_save $headref, $dgitview, "converted"; progress "dgit view: created ($saved)"; @@ -5041,6 +5237,7 @@ sub quiltify ($$$$) { 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 "is series file\n" if m{$series_filename_re}o; die "too long" if length > 200; }; return $_ unless $@; @@ -5079,6 +5276,7 @@ sub quiltify ($$$$) { $patchname =~ y/-a-z0-9_.+=~//cd; $patchname =~ s/^\W/x-$&/; $patchname = substr($patchname,0,40); + $patchname .= ".patch"; } if (!defined $patchdir) { $patchdir = ''; @@ -5134,7 +5332,7 @@ END my $headref = git_rev_parse('HEAD'); prep_ud(); - changedir $ud; + changedir $playground; my $upstreamversion = upstreamversion $version; @@ -5146,7 +5344,7 @@ END die 'bug' if $split_brain && !$need_split_build_invocation; - changedir '../../../..'; + changedir $maindir; runcmd_ordryrun_local @git, qw(pull --ff-only -q .git/dgit/unpack/work master); } @@ -5257,7 +5455,7 @@ END sub quilt_check_splitbrain_cache ($$) { my ($headref, $upstreamversion) = @_; # Called only if we are in (potentially) split brain mode. - # Called in $ud. + # Called in playground. # Computes the cache key and looks in the cache. # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey) @@ -5613,15 +5811,19 @@ sub cmd_clean () { maybe_unapply_patches_again(); } -sub build_prep_early () { - our $build_prep_early_done //= 0; - return if $build_prep_early_done++; - notpushing(); - badusage "-p is not allowed when building" if defined $package; +sub build_or_push_prep_early () { + our $build_or_push_prep_early_done //= 0; + return if $build_or_push_prep_early_done++; + badusage "-p is not allowed with dgit $subcommand" if defined $package; my $clogp = parsechangelog(); $isuite = getfield $clogp, 'Distribution'; $package = getfield $clogp, 'Source'; $version = getfield $clogp, 'Version'; +} + +sub build_prep_early () { + build_or_push_prep_early(); + notpushing(); check_not_dirty(); } @@ -5929,10 +6131,10 @@ sub build_source { } else { my @cmd = (@dpkgsource, qw(-b --)); if ($split_brain) { - changedir $ud; + changedir $playground; runcmd_ordryrun_local @cmd, "work"; my @udfiles = <${package}_*>; - changedir "../../.."; + changedir $maindir; foreach my $f (@udfiles) { printdebug "source copy, found $f\n"; next unless @@ -5940,7 +6142,7 @@ sub build_source { ($f =~ m/\.debian\.tar(?:\.\w+)$/ && $f eq srcfn($version, $&)); printdebug "source copy, found $f - renaming\n"; - rename "$ud/$f", "../$f" or $!==ENOENT + rename "$playground/$f", "../$f" or $!==ENOENT or fail "put in place new source file ($f): $!"; } } else { @@ -5992,6 +6194,15 @@ sub cmd_quilt_fixup { 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; @@ -6059,6 +6270,12 @@ sub cmd_import_dsc { 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"; @@ -6082,10 +6299,9 @@ END fail "Not fast forward to $dsc_hash"; } } - @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info", - $dstbranch, $dsc_hash); - runcmd @cmd; - progress "dgit: import-dsc updated git ref $dstbranch"; + import_dsc_result $dstbranch, $dsc_hash, + "dgit import-dsc (Dgit): $info", + "updated git ref $dstbranch"; return 0; } @@ -6100,7 +6316,10 @@ END foreach my $fi (@dfi) { my $f = $fi->{Filename}; my $here = "../$f"; - next if lstat $here; + if (lstat $here) { + next if stat $here; + fail "lstat $here works but stat gives $! !"; + } fail "stat $here: $!" unless $! == ENOENT; my $there = $dscfn; if ($dscfn =~ m#^(?:\./+)?\.\./+#) { @@ -6111,8 +6330,10 @@ END 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"; + fail "import $dscfn requires ../$f, but it does not exist"; $there .= "/$f"; + my $test = $there =~ m{^/} ? $there : "../$there"; + stat $test or fail "import $dscfn requires $test, but: $!"; symlink $there, $here or fail "symlink $there to $here: $!"; progress "made symlink $here -> $there"; # print STDERR Dumper($fi); @@ -6145,12 +6366,14 @@ END } } - my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info", - $dstbranch, $newhash); - runcmd @cmd; - progress "dgit: import-dsc results are in in git ref $dstbranch"; + import_dsc_result $dstbranch, $newhash, + "dgit import-dsc: $info", + "results are in in git ref $dstbranch"; } +sub pre_archive_api_query () { + not_necessarily_a_tree(); +} sub cmd_archive_api_query { badusage "need only 1 subpath argument" unless @ARGV==1; my ($subpath) = @ARGV; @@ -6160,37 +6383,56 @@ sub cmd_archive_api_query { 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 pre_clone_dgit_repos_server () { + not_necessarily_a_tree(); +} sub cmd_clone_dgit_repos_server { badusage "need destination argument" unless @ARGV==1; my ($destdir) = @ARGV; - $package = '_dgit-repos-server'; - local $access_forpush = 0; - my @cmd = (@git, qw(clone), access_giturl(), $destdir); + my $url = repos_server_url(); + my @cmd = (@git, qw(clone), $url, $destdir); debugcmd ">",@cmd; exec @cmd or fail "exec git clone: $!\n"; } +sub pre_print_dgit_repos_server_source_url () { + not_necessarily_a_tree(); +} sub cmd_print_dgit_repos_server_source_url { badusage "no arguments allowed to dgit print-dgit-repos-server-source-url" if @ARGV; - $package = '_dgit-repos-server'; - local $access_forpush = 0; - my $url = access_giturl(); + 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(); } @@ -6202,7 +6444,9 @@ sub cmd_version { } our (%valopts_long, %valopts_short); +our (%funcopts_long); our @rvalopts; +our (@modeopt_cfgs); sub defvalopt ($$$$) { my ($long,$short,$val_re,$how) = @_; @@ -6238,6 +6482,26 @@ defvalopt '--initiator-tempdir','','.*', sub { " 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; @@ -6320,15 +6584,6 @@ sub parseopts () { } elsif (m/^--overwrite=(.+)$/s) { push @ropts, $_; $overwrite_version = $1; - } elsif (m/^--dep14tag$/s) { - push @ropts, $_; - $dodep14tag= 'want'; - } elsif (m/^--no-dep14tag$/s) { - push @ropts, $_; - $dodep14tag= 'no'; - } elsif (m/^--always-dep14tag$/s) { - push @ropts, $_; - $dodep14tag= 'always'; } elsif (m/^--delayed=(\d+)$/s) { push @ropts, $_; push @dput, $_; @@ -6367,6 +6622,9 @@ sub parseopts () { } 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 \`$_'"; } @@ -6499,12 +6757,14 @@ sub parseopts_late_defaults () { $quilt_mode = $1; } - if (!defined $dodep14tag) { + foreach my $moc (@modeopt_cfgs) { local $access_forpush; - $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want'; - $dodep14tag =~ m/^($dodep14tag_re)$/ - or badcfg "unknown dep14tag setting \`$dodep14tag'"; - $dodep14tag = $1; + 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(); @@ -6526,7 +6786,6 @@ if ($ENV{$fakeeditorenv}) { 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" @@ -6535,12 +6794,15 @@ if (!@ARGV) { print STDERR $helpmsg or die $!; exit 8; } -my $cmd = shift @ARGV; +$cmd = $subcommand = shift @ARGV; $cmd =~ y/-/_/; my $pre_fn = ${*::}{"pre_$cmd"}; $pre_fn->() if $pre_fn; +record_maindir if $invoked_in_git_tree; +git_slurp_config(); + my $fn = ${*::}{"cmd_$cmd"}; $fn or badusage "unknown operation $cmd"; $fn->();