X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=5c8d24a7908eb891ef1ebf5765593100683f47e7;hp=c8907cf6eb48739a2f53854c46cf54cb641ba79c;hb=346892585656da58a8d913cf9f808872a3096823;hpb=e4fb7e9b2592d0a80ca213c94f3a462abd31c6c8 diff --git a/dgit b/dgit index c8907cf6..5c8d24a7 100755 --- a/dgit +++ b/dgit @@ -30,9 +30,13 @@ use Dpkg::Version; use POSIX; use IPC::Open2; use Digest::SHA; +use Digest::MD5; +use Config; our $our_version = 'UNRELEASED'; ###substituted### +our $rpushprotovsn = 2; + our $isuite = 'unstable'; our $idistro; our $package; @@ -98,6 +102,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.'/([^/.]+)$'; @@ -116,9 +121,14 @@ 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"); } our $us = 'dgit'; @@ -133,6 +143,23 @@ END { } }; +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 fail { @@ -157,6 +184,13 @@ sub changedir ($) { chdir $newdir or die "chdir: $newdir: $!"; } +sub stat_exists ($) { + my ($f) = @_; + return 1 if stat $f; + return 0 if $!==&ENOENT; + die "stat $f: $!"; +} + #---------- remote protocol support, common ---------- # remote push initiator/responder protocol: @@ -194,17 +228,39 @@ sub changedir ($) { # # > complete +our $i_child_pid; + +sub i_child_report () { + # Sees if our child has died, and reap it if so. Returns a string + # describing how it died if it failed, or undef otherwise. + return undef unless $i_child_pid; + my $got = waitpid $i_child_pid, WNOHANG; + return undef if $got <= 0; + die unless $got == $i_child_pid; + $i_child_pid = undef; + return undef unless $?; + return "build host child ".waitstatusmsg(); +} + sub badproto ($$) { my ($fh, $m) = @_; fail "connection lost: $!" if $fh->error; fail "protocol violation; $m not expected"; } +sub badproto_badread ($$) { + my ($fh, $wh) = @_; + fail "connection lost: $!" if $!; + my $report = i_child_report(); + fail $report if defined $report; + badproto $fh, "eof (reading $wh)"; +} + sub protocol_expect (&$) { my ($match, $fh) = @_; local $_; $_ = <$fh>; - defined && chomp or badproto $fh, "eof"; + defined && chomp or badproto_badread $fh, "protocol message"; if (wantarray) { my @r = &$match; return @r if @r; @@ -236,7 +292,7 @@ sub protocol_read_bytes ($$) { $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count"; my $d; my $got = read $fh, $d, $nbytes; - $got==$nbytes or badproto $fh, "eof during data block"; + $got==$nbytes or badproto_badread $fh, "data block"; return $d; } @@ -350,10 +406,8 @@ sub failedcmd { { local ($!); printcmd \*STDERR, "$us: failed command:", @_ or die $!; }; if ($!) { fail "failed to fork/exec: $!"; - } elsif (!($? & 0xff)) { - fail "subprocess failed with error exit status ".($?>>8); } elsif ($?) { - fail "subprocess crashed (wait status $?)"; + fail "subprocess ".waitstatusmsg(); } else { fail "subprocess produced invalid output"; } @@ -463,13 +517,21 @@ our %defcfg = ('dgit.default.distro' => 'debian', 'dgit.default.username' => '', 'dgit.default.archive-query-default-component' => 'main', 'dgit.default.ssh' => 'ssh', - 'dgit-distro.debian.git-host' => 'git.debian.org', + 'dgit.default.archive-query' => 'madison:', + 'dgit.default.sshpsql-dbname' => 'service=projectb', + 'dgit-distro.debian.archive-query' => 'sshpsql:', + '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.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', - 'dgit-distro.debian.sshpsql-dbname' => 'service=projectb', 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/', 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*', @@ -511,9 +573,7 @@ sub cfg { sub access_basedistro () { 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"); @@ -521,7 +581,7 @@ sub access_basedistro () { } 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'); @@ -535,22 +595,53 @@ sub access_quirk () { return ('backports',"$basedistro-backports",$1); } } - return ('none',$basedistro); + return ('none',undef); } -sub access_distro () { - return (access_quirk())[1]; +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; + return grep { defined } @l; } 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; + # 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; + my $value = cfg(@cfgs); return $value; } @@ -572,9 +663,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; } @@ -583,22 +681,43 @@ 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 $proto = access_cfg('git-proto', 'RETURN-UNDEF'); + return undef unless defined $proto; $url = - access_cfg('git-proto'). + $proto. access_gituserhost(). access_cfg('git-path'); } return "$url/$package.git"; } -sub parsecontrolfh ($$@) { - my ($fh, $desc, @opts) = @_; - my %opts = ('name' => $desc, @opts); - my $c = Dpkg::Control::Hash->new(%opts); - $c->parse($fh) or die "parsing of $desc failed"; +sub parsecontrolfh ($$;$) { + my ($fh, $desc, $allowsigned) = @_; + our $dpkgcontrolhash_noissigned; + my $c; + for (;;) { + my %opts = ('name' => $desc); + $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned; + $c = Dpkg::Control::Hash->new(%opts); + $c->parse($fh,$desc) or die "parsing of $desc failed"; + last if $allowsigned; + last if $dpkgcontrolhash_noissigned; + my $issigned= $c->get_option('is_pgp_signed'); + if (!defined $issigned) { + $dpkgcontrolhash_noissigned= 1; + seek $fh, 0,0 or die "seek $desc: $!"; + } elsif ($issigned) { + fail "control file $desc is (already) PGP-signed. ". + " Note that dgit push needs to modify the .dsc and then". + " do the signature itself"; + } else { + last; + } + } return $c; } @@ -657,16 +776,6 @@ our %rmad; sub archive_query ($) { my ($method) = @_; 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 = $'; #'; @@ -679,17 +788,21 @@ sub pool_dsc_subpath ($$) { return "/pool/$component/$prefix/$package/".dscfn($vsn); } -sub archive_query_madison ($$) { +sub archive_query_madison { + return 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* \| @@ -708,12 +821,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;". @@ -721,13 +834,19 @@ sub canonicalise_suite_madison ($$) { return $r[0][2]; } -sub sshpsql ($$) { - my ($data,$sql) = @_; +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); + access_runeinfo("ssh-psql $runeinfo"). + " export LANG=C;". + " ".shellquote qw(psql -A), $dbname, qw(-c), $sql); printcmd(\*DEBUG,$debugprefix."|",@cmd) if $debug>0; open P, "-|", @cmd or die $!; while (

) { @@ -747,13 +866,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, <[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) = @$_; @@ -778,7 +897,7 @@ END sub canonicalise_suite_sshpsql ($$) { my ($proto,$data) = @_; sql_injection_check $isuite; - my @rows = sshpsql($data, <error and die "$dpath: $!"; close C; - return sort { -version_compare_string($a->[0],$b->[0]); } @rows; + return sort { -version_compare($a->[0],$b->[0]); } @rows; } sub canonicalise_suite () { @@ -857,7 +976,7 @@ sub get_archive_dsc () { } my $dscfh = new IO::File \$dscdata, '<' or die $!; printdebug Dumper($dscdata) if $debug>1; - $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1); + $dsc = parsecontrolfh($dscfh,$dscurl,1); printdebug Dumper($dsc) if $debug>1; my $fmt = getfield $dsc, 'Format'; fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt}; @@ -867,15 +986,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(), + 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') { @@ -892,6 +1021,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') { @@ -911,6 +1041,18 @@ sub prep_ud () { mkdir $ud or die $!; } +sub mktree_in_ud_here () { + runcmd qw(git init -q); + rmtree('.git/objects'); + 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) = <*/.>; @@ -918,14 +1060,14 @@ sub mktree_in_ud_from_only_subdir () { $dirs[0] =~ m#^([^/]+)/\.$# or die; my $dir = $1; changedir $dir; - fail "source package contains .git directory" if stat '.git'; - die $! unless $!==&ENOENT; - runcmd qw(git init -q); - rmtree('.git/objects'); - symlink '../../../../objects','.git/objects' or die $!; + fail "source package contains .git directory" if stat_exists '.git'; + mktree_in_ud_here(); + my $format=get_source_format(); + if (madformat($format)) { + 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); } @@ -960,9 +1102,12 @@ sub dsc_files () { map { $_->{Filename} } dsc_files_info(); } -sub is_orig_file ($) { - local ($_) = @_; - m/\.orig(?:-\w+)?\.tar\.\w+$/; +sub is_orig_file ($;$) { + local ($_) = $_[0]; + my $base = $_[1]; + m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0; + defined $base or return 1; + return $` eq $base; } sub make_commit ($) { @@ -1038,7 +1183,7 @@ END my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog'); 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 $!; @@ -1082,11 +1227,9 @@ sub complete_file_from_dsc ($$) { my $tf = "$dstdir/$f"; my $downloaded = 0; - if (stat $tf) { + if (stat_exists $tf) { progress "using existing $f"; } else { - die "$tf $!" unless $!==&ENOENT; - my $furl = $dscurl; $furl =~ s{/[^/]+$}{}; $furl .= "/$f"; @@ -1220,7 +1363,7 @@ END my $gotclogp = parsechangelog("-l$clogf"); 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 < .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()) { + my $giturl = access_giturl(1); + if (defined $giturl) { + 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', $giturl; + } + if ($hasgit) { progress "fetching existing git history"; git_fetch_us(); runcmd_ordryrun_local @git, qw(fetch origin); @@ -1297,6 +1444,12 @@ sub check_not_dirty () { } } +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; @@ -1306,24 +1459,34 @@ 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; + commit_admin "Commit Debian 3.0 (quilt) metadata"; +} + +sub get_source_format () { + if (!open F, "debian/source/format") { + die $! unless $!==&ENOENT; + return ''; + } + $_ = ; + F->error and die $!; + chomp; + return $_; } sub madformat ($) { 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"; return 0; } + progress "Format \`$format', checking/updating patch stack"; return 1; } @@ -1432,7 +1595,7 @@ sub dopush () { push_parse_changelog("$clogpfn"); my $dscpath = "$buildproductsdir/$dscfn"; - stat $dscpath or + stat_exists $dscpath or fail "looked for .dsc $dscfn, but $!;". " maybe you forgot to build"; @@ -1477,10 +1640,9 @@ sub dopush () { if (!$changesfile) { my $multi = "$buildproductsdir/". "${package}_".(stripepoch $cversion)."_multi.changes"; - if (stat "$multi") { + if (stat_exists "$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". @@ -1563,10 +1725,8 @@ sub cmd_clone { } $dstdir ||= "$package"; - if (stat $dstdir) { + if (stat_exists $dstdir) { fail "$dstdir already exists"; - } elsif ($! != &ENOENT) { - die "$dstdir: $!"; } my $cwd_remove; @@ -1670,12 +1830,15 @@ sub cmd_push { #---------- remote commands' implementation ---------- -sub cmd_remote_push_responder { +sub cmd_remote_push_build_host { my ($nrargs) = shift @ARGV; my (@rargs) = @ARGV[0..$nrargs-1]; @ARGV = @ARGV[$nrargs..$#ARGV]; die unless @rargs; - my ($dir) = @rargs; + my ($dir,$vsnwant) = @rargs; + # vsnwant is a comma-separated list; we report which we have + # chosen in our ready response (so other end can tell if they + # offered several) $debugprefix = ' '; $we_are_responder = 1; @@ -1686,19 +1849,30 @@ sub cmd_remote_push_responder { open STDOUT, ">&STDERR" or die $!; autoflush STDOUT 1; - responder_send_command("dgit-remote-push-ready"); + $vsnwant //= 1; + fail "build host has dgit rpush protocol version". + " $rpushprotovsn but invocation host has $vsnwant" + unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant; + + responder_send_command("dgit-remote-push-ready $rpushprotovsn"); changedir $dir; &cmd_push; } +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) + our $i_tmp; -our $i_child_pid; sub i_cleanup { - local ($@); - if ($i_child_pid) { - printdebug "(killing remote child $i_child_pid)\n"; + local ($@, $?); + my $report = i_child_report(); + if (defined $report) { + printdebug "($report)\n"; + } elsif ($i_child_pid) { + printdebug "(killing build host child $i_child_pid)\n"; kill 15, $i_child_pid; } if (defined $i_tmp && !defined $initiator_tempdir) { @@ -1725,11 +1899,11 @@ sub cmd_rpush { $dir = nextarg; } $dir =~ s{^-}{./-}; - my @rargs = ($dir); + my @rargs = ($dir,$rpushprotovsn); my @rdgit; push @rdgit, @dgit; push @rdgit, @ropts; - push @rdgit, qw(remote-push-responder), (scalar @rargs), @rargs; + push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs; push @rdgit, @ARGV; my @cmd = (@ssh, $host, shellquote @rdgit); printcmd \*DEBUG,$debugprefix."+",@cmd; @@ -1762,10 +1936,10 @@ sub i_resp_progress ($) { sub i_resp_complete { my $pid = $i_child_pid; $i_child_pid = undef; # prevents killing some other process with same pid - printdebug "waiting for remote child $pid...\n"; + printdebug "waiting for build host child $pid...\n"; my $got = waitpid $pid, 0; die $! unless $got == $pid; - die "remote child failed $?" if $?; + die "build host child failed $?" if $?; i_cleanup(); printdebug "all done\n"; @@ -1776,7 +1950,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; } @@ -1861,31 +2036,10 @@ our $dscfn; our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT'; -sub build_maybe_quilt_fixup () { - if (!open F, "debian/source/format") { - die $! unless $!==&ENOENT; - return; - } - $_ = ; - 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 ($$) { + my ($clogp,$headref) = @_; - 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"; @@ -1912,6 +2066,127 @@ END local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn; runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname; } +} + +sub build_maybe_quilt_fixup () { + my $format=get_source_format; + return unless madformat $format; + # sigh + + # 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} + # 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 + + my $clogp = parsechangelog(); + my $headref = rev_parse('HEAD'); + + prep_ud(); + changedir $ud; + + my $upstreamversion=$version; + $upstreamversion =~ s/-[^-]*$//; + + my $fakeversion="$upstreamversion-~~DGITFAKE"; + + my $fakedsc=new IO::File 'fake.dsc', '>' or die $!; + print $fakedsc <addfile($fh); + print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!; + }; + + foreach my $f (<../../../../*>) { #/){ + my $b=$f; $b =~ s{.*/}{}; + next unless is_orig_file $b, srcfn $upstreamversion,''; + link $f, $b or die "$b $!"; + $dscaddfile->($b); + } + + my @files=qw(debian/source/format debian/rules); + if (stat_exists '../../../debian/patches') { + push @files, 'debian/patches'; + } + + my $debtar= srcfn $fakeversion,'.debian.tar.gz'; + runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files; + + $dscaddfile->($debtar); + close $fakedsc or die $!; + + runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null'; + + my $fakexdir= $package.'-'.(stripepoch $upstreamversion); + rename $fakexdir, "fake" or die "$fakexdir $!"; + + mkdir "work" or die $!; + changedir "work"; + mktree_in_ud_here(); + runcmd @git, qw(reset --hard), $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 $!; + } + + quiltify($clogp,$headref); if (!open P, '>>', ".pc/applied-patches") { $!==&ENOENT or die $!; @@ -1920,6 +2195,14 @@ END } commit_quilty_patch(); + + if ($mustdeletepc) { + runcmd @git, qw(rm -rq .pc); + commit_admin "Commit removal of .pc (quilt series tracking data)"; + } + + changedir '../../../..'; + runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master); } sub quilt_fixup_editor () { @@ -1981,7 +2264,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 { @@ -2046,8 +2329,9 @@ sub cmd_sbuild { 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): $!"; + stat_exist $dscfn or fail "$dscfn (in parent directory): $!"; + stat_exists $sourcechanges + or fail "$sourcechanges (in parent directory): $!"; foreach my $cf (glob $pat) { next if $cf eq $sourcechanges; unlink $cf or fail "remove $cf: $!"; @@ -2064,7 +2348,7 @@ sub cmd_sbuild { runcmd_ordryrun_local @mergechanges, @changesfiles; my $multichanges = "${package}_".(stripepoch $version)."_multi.changes"; if (act_local()) { - stat $multichanges or fail "$multichanges: $!"; + stat_exists $multichanges or fail "$multichanges: $!"; } printdone "build successful, results in $multichanges\n" or die $!; } @@ -2073,6 +2357,7 @@ sub cmd_quilt_fixup { badusage "incorrect arguments to dgit quilt-fixup" if @ARGV; my $clogp = parsechangelog(); $version = getfield $clogp, 'Version'; + $package = getfield $clogp, 'Source'; build_maybe_quilt_fixup(); }