X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=02ed55d179246a1cdbbb8be365662eda7c1f89fa;hp=6e175ad2b1f08b03088cd57f63087bc62c20fdb3;hb=7efe0539417015b5b0da6549dd79b411536bbd7d;hpb=2703ad402cb306b67cc0c96adfbd5335f0aff943 diff --git a/dgit b/dgit index 6e175ad2..02ed55d1 100755 --- a/dgit +++ b/dgit @@ -48,11 +48,12 @@ our $changesfile; our $buildproductsdir = '..'; our $new_package = 0; our $ignoredirty = 0; -our $noquilt = 0; our $rmonerror = 1; our $existing_package = 'dpkg'; our $cleanmode = 'dpkg-source'; our $changes_since_version; +our $quilt_mode; +our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck'; our $we_are_responder; our $initiator_tempdir; @@ -102,6 +103,7 @@ our $remotename = 'dgit'; our @ourdscfield = qw(Dgit Vcs-Dgit-Master); our $branchprefix = 'dgit'; our $csuite; +our $instead_distro; sub lbranch () { return "$branchprefix/$csuite"; } my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$'; @@ -162,7 +164,10 @@ sub waitstatusmsg () { sub printdebug { print DEBUG $debugprefix, @_ or die $!; } sub fail { - die $us.($we_are_responder ? " (build host)" : "").": @_\n"; + my $s = "@_\n"; + my $prefix = $us.($we_are_responder ? " (build host)" : "").": "; + $s =~ s/^/$prefix/gm; + die $s; } sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; } @@ -519,9 +524,18 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.archive-query' => 'madison:', 'dgit.default.sshpsql-dbname' => 'service=projectb', 'dgit-distro.debian.archive-query' => 'sshpsql:', - 'dgit-distro.debian.git-host' => 'git.debian.org', + 'dgit-distro.debian.git-host' => 'dgit-git.debian.net', + 'dgit-distro.debian.git-user-force' => 'dgit', 'dgit-distro.debian.git-proto' => 'git+ssh://', - 'dgit-distro.debian.git-path' => '/git/dgit-repos/repos', + 'dgit-distro.debian.git-path' => '/dgit/debian/repos', + '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', + 'dgit-distro.debian.diverts.alioth' => '/alioth', + 'dgit-distro.debian/alioth.git-host' => 'git.debian.org', + 'dgit-distro.debian/alioth.git-user-force' => '', + 'dgit-distro.debian/alioth.git-proto' => 'git+ssh://', + 'dgit-distro.debian/alioth.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', @@ -595,15 +609,16 @@ 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 if defined $quirkdistro; - - return @l; + unshift @l, $quirkdistro; + unshift @l, $instead_distro; + return grep { defined } @l; } sub access_cfg (@) { @@ -655,9 +670,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; } @@ -756,6 +778,27 @@ sub must_getcwd () { return $d; } +sub archive_api_query_cmd ($) { + my ($subpath) = @_; + my @cmd = qw(curl -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; + } + push @cmd, "--ca-certificate=$key", "--ca-directory=/dev/enoent"; + last; + } + } + push @cmd, $url.$subpath; + return @cmd; +} + our %rmad; sub archive_query ($) { @@ -829,7 +872,7 @@ sub sshpsql ($$$) { my ($userhost,$dbname) = ($`,$'); #'; my @rows; my @cmd = (access_cfg_ssh, $userhost, - ": dgit ssh-psql $runeinfo ;". + access_runeinfo("ssh-psql $runeinfo"). " export LANG=C;". " ".shellquote qw(psql -A), $dbname, qw(-c), $sql); printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0; @@ -971,16 +1014,25 @@ sub get_archive_dsc () { $dsc = undef; } +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(), - ": dgit git-check $package ;". + 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; + if ($r =~ m/^divert (\w+)$/) { + my $divert=$1; + my ($usedistro,) = access_distros(); + $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert"); + $instead_distro =~ s{^/}{ access_basedistro()."/" }e; + printdebug "diverting $divert so using distro $instead_distro\n"; + return check_for_git(); + } failedcmd @cmd unless $r =~ m/^[01]$/; return $r+0; } elsif ($how eq 'true') { @@ -997,7 +1049,7 @@ sub create_remote_git_repo () { if ($how eq 'ssh-cmd') { runcmd_ordryrun (access_cfg_ssh, access_gituserhost(), - " : dgit git-create $package ; ". + access_runeinfo("git-create $package"). "set -e; cd ".access_cfg('git-path').";". " cp -a _template $package.git"); } elsif ($how eq 'true') { @@ -1023,6 +1075,12 @@ sub mktree_in_ud_here () { symlink '../../../../objects','.git/objects' or die $!; } +sub git_write_tree () { + my $tree = cmdoutput @git, qw(write-tree); + $tree =~ m/^\w+$/ or die "$tree ?"; + return $tree; +} + sub mktree_in_ud_from_only_subdir () { # changes into the subdir my (@dirs) = <*/.>; @@ -1037,8 +1095,7 @@ sub mktree_in_ud_from_only_subdir () { rmtree '.pc'; } runcmd @git, qw(add -Af); - my $tree = cmdoutput @git, qw(write-tree); - $tree =~ m/^\w+$/ or die "$tree ?"; + my $tree=git_write_tree(); return ($tree,$dir); } @@ -1359,6 +1416,7 @@ sub clone ($) { my ($dstdir) = @_; canonicalise_suite(); badusage "dry run makes no sense with clone" unless act_local(); + my $hasgit = check_for_git(); mkdir $dstdir or die "$dstdir $!"; changedir $dstdir; runcmd @git, qw(init -q); @@ -1370,7 +1428,7 @@ sub clone ($) { close H or die $!; runcmd @git, qw(remote add), 'origin', $giturl; } - if (check_for_git()) { + if ($hasgit) { progress "fetching existing git history"; git_fetch_us(); runcmd_ordryrun_local @git, qw(fetch origin); @@ -1379,6 +1437,7 @@ sub clone ($) { } fetch_from_archive() or no_such_package; my $vcsgiturl = $dsc->{'Vcs-Git'}; + $vcsgiturl =~ s/\s+-b\s+\S+//g; if (length $vcsgiturl) { runcmd @git, qw(remote add vcs-git), $vcsgiturl; } @@ -1452,7 +1511,7 @@ sub get_source_format () { sub madformat ($) { my ($format) = @_; return 0 unless $format eq '3.0 (quilt)'; - if ($noquilt) { + if ($quilt_mode eq 'nocheck') { progress "Not doing any fixup of \`$format' due to --no-quilt-fixup"; return 0; } @@ -2004,8 +2063,276 @@ our $version; our $sourcechanges; our $dscfn; +#----- `3.0 (quilt)' handling ----- + our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT'; +sub quiltify_dpkg_commit ($$$;$) { + my ($patchname,$author,$msg, $xinfo) = @_; + $xinfo //= ''; + + mkpath '.git/dgit'; + my $descfn = ".git/dgit/quilt-description.tmp"; + open O, '>', $descfn or die "$descfn: $!"; + $msg =~ s/\s+$//g; + $msg =~ s/\n/\n /g; + $msg =~ s/^\s+$/ ./mg; + print O < $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 $; + }; + my $reportnot = sub { + my ($notp) = @_; + my $s = $abbrev->($notp); + my $c = $notp->{Child}; + $s .= "..".$abbrev->($c) if $c; + $s .= ": ".$c->{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"; + } + 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 = time; + 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; + + $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?"; + + my $title = $1; + my $patchname = $title; + $patchname =~ s/[.:]$//; + $patchname =~ y/ A-Z/-a-z/; + $patchname =~ y/-a-z0-9_.+=~//cd; + $patchname =~ s/^\W/x-$&/; + $patchname = substr($patchname,0,40); + my $index; + for ($index=''; + stat "debian/patches/$patchname$index"; + $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, + "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=get_source_format; return unless madformat $format; @@ -2124,33 +2451,7 @@ END rename '../fake/.pc','.pc' or die $!; } - my $author = getfield $clogp, 'Maintainer'; - 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; - print O <{Version}) - Last (up to) $ncommits git changes, FYI: - . - $msg -Author: $author - ---- - -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; - } + quiltify($clogp,$headref); if (!open P, '>>', ".pc/applied-patches") { $!==&ENOENT or die $!; @@ -2188,6 +2489,8 @@ sub quilt_fixup_editor () { exit 0; } +#----- other building ----- + sub clean_tree () { if ($cleanmode eq 'dpkg-source') { runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean); @@ -2325,6 +2628,13 @@ sub cmd_quilt_fixup { build_maybe_quilt_fixup(); } +sub cmd_archive_api_query { + badusage "need only 1 subpath argument" unless @ARGV==1; + my ($subpath) = @ARGV; + my @cmd = archive_api_query_cmd($subpath); + exec @cmd or fail "exec curl: $!\n"; +} + #---------- argument parsing and main program ---------- sub cmd_version { @@ -2394,12 +2704,17 @@ sub parseopts () { $cleanmode = $1; } elsif (m/^--clean=(.*)$/s) { badusage "unknown cleaning mode \`$1'"; + } elsif (m/^--quilt=($quilt_modes_re)$/s) { + push @ropts, $_; + $quilt_mode = $1; + } elsif (m/^--quilt=(.*)$/s) { + badusage "unknown quilt fixup 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; @@ -2434,24 +2749,27 @@ sub parseopts () { } elsif (s/^-c(.*=.*)//s) { push @ropts, $&; push @git, '-c', $1; - } elsif (s/^-d(.*)//s) { + } elsif (s/^-d(.+)//s) { push @ropts, $&; $idistro = $1; - } elsif (s/^-C(.*)//s) { + } elsif (s/^-C(.+)//s) { push @ropts, $&; $changesfile = $1; if ($changesfile =~ s#^(.*)/##) { $buildproductsdir = $1; } - } elsif (s/^-k(.*)//s) { + } elsif (s/^-k(.+)//s) { $keyid=$1; - } elsif (s/^-wn//s) { + } elsif (m/^-[vdCk]$/) { + badusage + "option \`$_' requires an argument (and no space before the argument)"; + } 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/^-wd$//s) { push @ropts, $&; $cleanmode = 'dpkg-source'; } else { @@ -2477,6 +2795,15 @@ if (!@ARGV) { my $cmd = shift @ARGV; $cmd =~ y/-/_/; +if (!defined $quilt_mode) { + $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; +} + my $fn = ${*::}{"cmd_$cmd"}; $fn or badusage "unknown operation $cmd"; $fn->();