When cloning, set up a remote `vcs-git' from the package's Vcs-Git (and put an approp...

[dgit.git] / dgit

diff --git a/dgit b/dgit
index 461e5e658305f3bfcfe2f507117931f05aabedbc..c8907cf6eb48739a2f53854c46cf54cb641ba79c 100755 (executable)
--- 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###
 
@@ -317,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;
@@ -753,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
@@ -766,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;
 }
@@ -838,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;
@@ -998,6 +1009,7 @@ sub generate_commit_from_dsc () {
     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;
 
@@ -1249,6 +1261,10 @@ sub clone ($) {
        progress "starting new git history";
     }
     fetch_from_archive() or no_such_package;
+    my $vcsgiturl = $dsc->{'Vcs-Git'};
+    if (length $vcsgiturl) {
+       runcmd @git, qw(remote add vcs-git), $vcsgiturl;
+    }
     runcmd @git, qw(reset --hard), lrref();
     printdone "ready for work in $dstdir";
 }
@@ -1936,6 +1952,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();
@@ -2206,4 +2227,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->();