X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=5f1ef2e59bc3864faf7f5d4abcd27409018ee9f3;hp=4c69b955877b20b73d9d5f3ad20415e6c045e734;hb=07261afb451ed4420d3dbda87613fa1229130276;hpb=29908c01094cb4d7be004bfb293e2f7214aabcd7

diff --git a/dgit b/dgit
index 4c69b955..5f1ef2e5 100755
--- a/dgit
+++ b/dgit
@@ -29,6 +29,7 @@ use File::Basename;
 use Dpkg::Version;
 use POSIX;
 use IPC::Open2;
+use Digest::SHA;
 
 our $our_version = 'UNRELEASED'; ###substituted###
 
@@ -44,6 +45,7 @@ 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;
@@ -52,8 +54,11 @@ our $initiator_tempdir;
 
 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 
+our $suite_re = '[-+.0-9a-z]+';
+
 our (@git) = qw(git);
 our (@dget) = qw(dget);
+our (@curl) = qw(curl -f);
 our (@dput) = qw(dput);
 our (@debsign) = qw(debsign);
 our (@gpg) = qw(gpg);
@@ -66,7 +71,8 @@ our (@dpkggenchanges) = qw(dpkg-genchanges);
 our (@mergechanges) = qw(mergechanges -f);
 our (@changesopts) = ('');
 
-our %opts_opt_map = ('dget' => \@dget,
+our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
+		     'curl' => \@curl,
 		     'dput' => \@dput,
 		     'debsign' => \@debsign,
                      'gpg' => \@gpg,
@@ -118,6 +124,15 @@ sub dscfn ($) {
 our $us = 'dgit';
 our $debugprefix = '';
 
+our @end;
+END { 
+    local ($?);
+    foreach my $f (@end) {
+	eval { $f->(); };
+	warn "$us: cleanup: $@" if length $@;
+    }
+};
+
 sub printdebug { print DEBUG $debugprefix, @_ or die $!; }
 
 sub fail { 
@@ -303,10 +318,10 @@ sub url_get {
     my $r = $ua->get(@_) or die $!;
     return undef if $r->code == 404;
     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
-    return $r->decoded_content();
+    return $r->decoded_content(charset => 'none');
 }
 
-our ($dscdata,$dscurl,$dsc,$skew_warning_vsn);
+our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
 
 sub shellquote {
     my @out;
@@ -453,12 +468,14 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       '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' => 'coccia.debian.org',
+	       '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' => '%-backports*',
+ 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
+	       'dgit-distro.ubuntu.git-check' => 'false',
+ 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
 	       'dgit-distro.test-dummy.ssh' => "$td/ssh",
 	       'dgit-distro.test-dummy.username' => "alice",
 	       'dgit-distro.test-dummy.git-check' => "ssh-cmd",
@@ -488,12 +505,19 @@ sub cfg {
 	my $dv = $defcfg{$c};
 	return $dv if defined $dv;
     }
-    badcfg "need value for one of: @_";
+    badcfg "need value for one of: @_\n".
+	"$us: distro or suite appears not to be (properly) supported";
 }
 
 sub access_basedistro () {
-    return cfg("dgit-suite.$isuite.distro",
-	       "dgit.default.distro");
+    if (defined $idistro) {
+	return cfg("dgit-distro.basedistro.distro",
+		   "dgit-suite.$isuite.distro",
+		   'RETURN-UNDEF') // $idistro;
+    } else {	
+	return cfg("dgit-suite.$isuite.distro",
+		   "dgit.default.distro");
+    }
 }
 
 sub access_quirk () {
@@ -503,9 +527,10 @@ sub access_quirk () {
 			      'RETURN-UNDEF');
     if (defined $backports_quirk) {
 	my $re = $backports_quirk;
-	$re =~ s/[^-0-9a-z_\%*]/\\$&/ig;
+	$re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
 	$re =~ s/\*/.*/g;
-	$re =~ s/\%/([-0-9a-z_]+)/ or badcfg "backports-quirk needs \%";
+	$re =~ s/\%/([-0-9a-z_]+)/
+	    or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
 	if ($isuite =~ m/^$re$/) {
 	    return ('backports',"$basedistro-backports",$1);
 	}
@@ -621,6 +646,12 @@ sub git_get_ref ($) {
     }
 }
 
+sub must_getcwd () {
+    my $d = getcwd();
+    defined $d or fail "getcwd failed: $!";
+    return $d;
+}
+
 our %rmad;
 
 sub archive_query ($) {
@@ -723,7 +754,7 @@ sub archive_query_sshpsql ($$) {
     my ($proto,$data) = @_;
     sql_injection_check $isuite, $package;
     my @rows = sshpsql($data, <<END);
-        SELECT source.version, component.name, files.filename
+        SELECT source.version, component.name, files.filename, files.sha256sum
           FROM source
           JOIN src_associations ON source.id = src_associations.source
           JOIN suite ON suite.id = src_associations.suite
@@ -736,9 +767,10 @@ sub archive_query_sshpsql ($$) {
            AND files.filename LIKE '%.dsc';
 END
     @rows = sort { -version_compare_string($a->[0],$b->[0]) } @rows;
+    my $digester = Digest::SHA->new(256);
     @rows = map {
-	my ($vsn,$component,$filename) = @$_;
-	[ $vsn, "/pool/$component/$filename" ];
+	my ($vsn,$component,$filename,$sha256sum) = @$_;
+	[ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
     } @rows;
     return @rows;
 }
@@ -808,19 +840,28 @@ sub get_archive_dsc () {
     canonicalise_suite();
     my @vsns = archive_query('archive_query');
     foreach my $vinfo (@vsns) {
-	my ($vsn,$subpath) = @$vinfo;
+	my ($vsn,$subpath,$digester,$digest) = @$vinfo;
 	$dscurl = access_cfg('mirror').$subpath;
 	$dscdata = url_get($dscurl);
 	if (!$dscdata) {
 	    $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
 	    next;
 	}
+	if ($digester) {
+	    $digester->reset();
+	    $digester->add($dscdata);
+	    my $got = $digester->hexdigest();
+	    $got eq $digest or
+		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, allow_pgp=>1);
 	printdebug Dumper($dsc) if $debug>1;
 	my $fmt = getfield $dsc, 'Format';
 	fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+	$dsc_checked = !!$digester;
 	return;
     }
     $dsc = undef;
@@ -839,6 +880,8 @@ sub check_for_git () {
 	return $r+0;
     } elsif ($how eq 'true') {
 	return 1;
+    } elsif ($how eq 'false') {
+	return 0;
     } else {
 	badcfg "unknown git-check \`$how'";
     }
@@ -942,20 +985,34 @@ sub clogp_authline ($) {
 sub generate_commit_from_dsc () {
     prep_ud();
     changedir $ud;
-    my @files;
-    foreach my $f (dsc_files()) {
+
+    foreach my $fi (dsc_files_info()) {
+	my $f = $fi->{Filename};
 	die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
-	push @files, $f;
+
 	link "../../../$f", $f
 	    or $!==&ENOENT
 	    or die "$f $!";
+
+	complete_file_from_dsc('.', $fi);
+
+	if (is_orig_file($f)) {
+	    link $f, "../../../../$f"
+		or $!==&EEXIST
+		or die "$f $!";
+	}
     }
-    runcmd @dget, qw(--), $dscurl;
-    foreach my $f (grep { is_orig_file($_) } @files) {
-	link $f, "../../../../$f"
-	    or $!==&EEXIST
-	    or die "$f $!";
-    }
+
+    my $dscfn = "$package.dsc";
+
+    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;
+    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");
@@ -1016,30 +1073,47 @@ END
     return $outputhash;
 }
 
+sub complete_file_from_dsc ($$) {
+    our ($dstdir, $fi) = @_;
+    # Ensures that we have, in $dir, the file $fi, with the correct
+    # contents.  (Downloading it from alongside $dscurl if necessary.)
+
+    my $f = $fi->{Filename};
+    my $tf = "$dstdir/$f";
+    my $downloaded = 0;
+
+    if (stat $tf) {
+	progress "using existing $f";
+    } 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;
+    }
+
+    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
+	fail "file $f has hash $got but .dsc".
+	    " demands hash $fi->{Hash} ".
+	    ($downloaded ? "(got wrong file from archive!)"
+	     : "(perhaps you should delete this file?)");
+}
+
 sub ensure_we_have_orig () {
     foreach my $fi (dsc_files_info()) {
 	my $f = $fi->{Filename};
 	next unless is_orig_file($f);
-	if (open F, "<", "../$f") {
-	    $fi->{Digester}->reset();
-	    $fi->{Digester}->addfile(*F);
-	    F->error and die $!;
-	    my $got = $fi->{Digester}->hexdigest();
-	    $got eq $fi->{Hash} or
-		fail "existing file $f has hash $got but .dsc".
-		    " demands hash $fi->{Hash}".
-		    " (perhaps you should delete this file?)";
-	    progress "using existing $f";
-	    next;
-	} else {
-	    die "$f $!" unless $!==&ENOENT;
-	}
-	my $origurl = $dscurl;
-	$origurl =~ s{/[^/]+$}{};
-	$origurl .= "/$f";
-	die "$f ?" unless $f =~ m/^${package}_/;
-	die "$f ?" if $f =~ m#/#;
-	runcmd_ordryrun_local shell_cmd 'cd ..', @dget,'--',$origurl;
+	complete_file_from_dsc('..', $fi);
     }
 }
 
@@ -1304,7 +1378,7 @@ type commit
 tag $tag
 tagger $authline
 
-$package release $cversion for $clogsuite [dgit]
+$package release $cversion for $clogsuite ($csuite) [dgit]
 END
     close TO or die $!;
 
@@ -1343,6 +1417,8 @@ sub dopush () {
     printdebug "actually entering push\n";
     prep_ud();
 
+    access_giturl(); # check that success is vaguely likely
+
     my $clogpfn = ".git/dgit/changelog.822.tmp";
     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
 
@@ -1372,13 +1448,17 @@ sub dopush () {
         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
     changedir '../../../..';
-    my @diffcmd = (@git, qw(diff --exit-code), $tree);
+    my $diffopt = $debug>0 ? '--exit-code' : '--quiet';
+    my @diffcmd = (@git, qw(diff), $diffopt, $tree);
     printcmd \*DEBUG,$debugprefix."+",@diffcmd;
     $!=0; $?=0;
-    if (system @diffcmd) {
-	if ($! && $?==256) {
+    my $r = system @diffcmd;
+    if ($r) {
+	if ($r==256) {
 	    fail "$dscfn specifies a different tree to your HEAD commit;".
-		" perhaps you forgot to build";
+		" perhaps you forgot to build".
+		($diffopt eq '--exit-code' ? "" :
+		 " (run with -D to see full diff output)");
 	} else {
 	    failedcmd @diffcmd;
 	}
@@ -1411,6 +1491,7 @@ sub dopush () {
 
     responder_send_file('changes',$changesfile);
     responder_send_command("param head $head");
+    responder_send_command("param csuite $csuite");
 
     my $tfn = sub { ".git/dgit/tag$_[0]"; };
     my $tagobjfn;
@@ -1438,20 +1519,17 @@ sub dopush () {
         "HEAD:".rrref(), "refs/tags/$tag";
     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
 
-    if (!$we_are_responder) {
-	if (act_local()) {
-	    rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
-	} else {
-	    progress "[new .dsc left in $dscpath.tmp]";
-	}
-    }
-
     if ($we_are_responder) {
 	my $dryrunsuffix = act_local() ? "" : ".tmp";
 	responder_receive_files('signed-dsc-changes',
 				"$dscpath$dryrunsuffix",
 				"$changesfile$dryrunsuffix");
     } else {
+	if (act_local()) {
+	    rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
+	} else {
+	    progress "[new .dsc left in $dscpath.tmp]";
+	}
 	sign_changes $changesfile;
     }
 
@@ -1480,7 +1558,28 @@ sub cmd_clone {
 	badusage "incorrect arguments to dgit clone";
     }
     $dstdir ||= "$package";
+
+    if (stat $dstdir) {
+	fail "$dstdir already exists";
+    } elsif ($! != &ENOENT) {
+	die "$dstdir: $!";
+    }
+
+    my $cwd_remove;
+    if ($rmonerror && !$dryrun_level) {
+	$cwd_remove= getcwd();
+	unshift @end, sub { 
+	    return unless defined $cwd_remove;
+	    if (!chdir "$cwd_remove") {
+		return if $!==&ENOENT;
+		die "chdir $cwd_remove: $!";
+	    }
+	    rmtree($dstdir) or die "remove $dstdir: $!\n";
+	};
+    }
+
     clone($dstdir);
+    $cwd_remove = undef;
 }
 
 sub branchsuite () {
@@ -1726,10 +1825,13 @@ sub i_file_changes { }
 sub i_want_signed_tag {
     printdebug Dumper(\%i_param, $i_dscfn);
     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
+	&& defined $i_param{'csuite'}
 	or badproto \*RO, "premature desire for signed-tag";
     my $head = $i_param{'head'};
     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
 
+    die unless $i_param{'csuite'} =~ m/^$suite_re$/;
+    $csuite = $&;
     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
 
     my $tagobjfn =
@@ -1846,6 +1948,11 @@ sub clean_tree () {
     }
 }
 
+sub cmd_clean () {
+    badusage "clean takes no additional arguments" if @ARGV;
+    clean_tree();
+}
+
 sub build_prep () {
     badusage "-p is not allowed when building" if defined $package;
     check_not_dirty();
@@ -1912,7 +2019,7 @@ sub build_source {
 	runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
 	    changesopts();
     } else {
-	my $pwd = cmdoutput qw(env - pwd);
+	my $pwd = must_getcwd();
 	my $leafdir = basename $pwd;
 	changedir "..";
 	runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
@@ -2040,6 +2147,9 @@ sub parseopts () {
 	    } elsif (m/^--no-quilt-fixup$/s) {
 		push @ropts, $_;
 		$noquilt = 1;
+	    } elsif (m/^--no-rm-on-error$/s) {
+		push @ropts, $_;
+		$rmonerror = 0;
 	    } else {
 		badusage "unknown long option \`$_'";
 	    }
@@ -2103,8 +2213,6 @@ if ($ENV{$fakeeditorenv}) {
     quilt_fixup_editor();
 }
 
-delete $ENV{'DGET_UNPACK'};
-
 parseopts();
 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
@@ -2115,4 +2223,7 @@ if (!@ARGV) {
 }
 my $cmd = shift @ARGV;
 $cmd =~ y/-/_/;
-{ no strict qw(refs); &{"cmd_$cmd"}(); }
+
+my $fn = ${*::}{"cmd_$cmd"};
+$fn or badusage "unknown operation $cmd";
+$fn->();