X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=e3fc0eefd33bb6bf0372044f070cc7db03e0ad15;hp=87448742fcdfd37b1e6edd8bd1546f13c6fcaca8;hb=5e359c5927e8df1a0ce1652a4b83436e9d5d3410;hpb=1b77fa116900faf2c61e65cec67b0e7e59f31b10 diff --git a/dgit b/dgit index 87448742..e3fc0eef 100755 --- a/dgit +++ b/dgit @@ -29,6 +29,8 @@ use File::Basename; use Dpkg::Version; use POSIX; use IPC::Open2; +use Digest::SHA; +use Config; our $our_version = 'UNRELEASED'; ###substituted### @@ -57,6 +59,7 @@ 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); @@ -69,7 +72,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, @@ -130,6 +134,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 { @@ -315,10 +336,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; @@ -347,10 +368,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"; } @@ -465,7 +484,7 @@ 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/', @@ -591,11 +610,30 @@ sub access_giturl () { 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; +print STDERR Dumper(\%opts); + $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; } @@ -751,7 +789,7 @@ sub archive_query_sshpsql ($$) { my ($proto,$data) = @_; sql_injection_check $isuite, $package; my @rows = sshpsql($data, <[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; } @@ -836,19 +875,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); + $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}; + $dsc_checked = !!$digester; return; } $dsc = undef; @@ -972,20 +1020,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"); @@ -1046,30 +1108,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); } } @@ -1217,6 +1296,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"; } @@ -1515,6 +1598,12 @@ sub cmd_clone { } $dstdir ||= "$package"; + if (stat $dstdir) { + fail "$dstdir already exists"; + } elsif ($! != &ENOENT) { + die "$dstdir: $!"; + } + my $cwd_remove; if ($rmonerror && !$dryrun_level) { $cwd_remove= getcwd(); @@ -1898,6 +1987,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(); @@ -2158,8 +2252,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" @@ -2170,4 +2262,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->();