3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 $SIG{__WARN__} = sub { die $_[0]; };
26 use Dpkg::Control::Hash;
28 use File::Temp qw(tempdir);
38 our $our_version = 'UNRELEASED'; ###substituted###
40 our $rpushprotovsn = 2;
42 our $isuite = 'unstable';
48 our $dryrun_level = 0;
50 our $buildproductsdir = '..';
56 our $existing_package = 'dpkg';
57 our $cleanmode = 'dpkg-source';
58 our $changes_since_version;
60 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
61 our $we_are_responder;
62 our $initiator_tempdir;
64 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
66 our $suite_re = '[-+.0-9a-z]+';
69 our (@dget) = qw(dget);
70 our (@curl) = qw(curl -f);
71 our (@dput) = qw(dput);
72 our (@debsign) = qw(debsign);
74 our (@sbuild) = qw(sbuild -A);
76 our (@dgit) = qw(dgit);
77 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
78 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
79 our (@dpkggenchanges) = qw(dpkg-genchanges);
80 our (@mergechanges) = qw(mergechanges -f);
81 our (@changesopts) = ('');
83 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
86 'debsign' => \@debsign,
91 'dpkg-source' => \@dpkgsource,
92 'dpkg-buildpackage' => \@dpkgbuildpackage,
93 'dpkg-genchanges' => \@dpkggenchanges,
94 'ch' => \@changesopts,
95 'mergechanges' => \@mergechanges);
97 our %opts_opt_cmdonly = ('gpg' => 1);
103 our $remotename = 'dgit';
104 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
108 sub lbranch () { return "$branchprefix/$csuite"; }
109 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
110 sub lref () { return "refs/heads/".lbranch(); }
111 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
112 sub rrref () { return server_ref($csuite); }
114 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
124 return "${package}_".(stripepoch $vsn).$sfx
129 return srcfn($vsn,".dsc");
138 foreach my $f (@end) {
140 warn "$us: cleanup: $@" if length $@;
144 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
146 sub no_such_package () {
147 print STDERR "$us: package $package does not exist in suite $isuite\n";
153 return "+".rrref().":".lrref();
158 printdebug "CD $newdir\n";
159 chdir $newdir or die "chdir: $newdir: $!";
162 sub deliberately ($) {
164 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
167 sub deliberately_not_fast_forward () {
168 foreach (qw(not-fast-forward fresh-repo)) {
169 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
173 #---------- remote protocol support, common ----------
175 # remote push initiator/responder protocol:
176 # < dgit-remote-push-ready [optional extra info ignored by old initiators]
178 # > file parsed-changelog
179 # [indicates that output of dpkg-parsechangelog follows]
180 # > data-block NBYTES
181 # > [NBYTES bytes of data (no newline)]
182 # [maybe some more blocks]
194 # [indicates that signed tag is wanted]
195 # < data-block NBYTES
196 # < [NBYTES bytes of data (no newline)]
197 # [maybe some more blocks]
201 # > want signed-dsc-changes
202 # < data-block NBYTES [transfer of signed dsc]
204 # < data-block NBYTES [transfer of signed changes]
212 sub i_child_report () {
213 # Sees if our child has died, and reap it if so. Returns a string
214 # describing how it died if it failed, or undef otherwise.
215 return undef unless $i_child_pid;
216 my $got = waitpid $i_child_pid, WNOHANG;
217 return undef if $got <= 0;
218 die unless $got == $i_child_pid;
219 $i_child_pid = undef;
220 return undef unless $?;
221 return "build host child ".waitstatusmsg();
226 fail "connection lost: $!" if $fh->error;
227 fail "protocol violation; $m not expected";
230 sub badproto_badread ($$) {
232 fail "connection lost: $!" if $!;
233 my $report = i_child_report();
234 fail $report if defined $report;
235 badproto $fh, "eof (reading $wh)";
238 sub protocol_expect (&$) {
239 my ($match, $fh) = @_;
242 defined && chomp or badproto_badread $fh, "protocol message";
250 badproto $fh, "\`$_'";
253 sub protocol_send_file ($$) {
254 my ($fh, $ourfn) = @_;
255 open PF, "<", $ourfn or die "$ourfn: $!";
258 my $got = read PF, $d, 65536;
259 die "$ourfn: $!" unless defined $got;
261 print $fh "data-block ".length($d)."\n" or die $!;
262 print $fh $d or die $!;
264 PF->error and die "$ourfn $!";
265 print $fh "data-end\n" or die $!;
269 sub protocol_read_bytes ($$) {
270 my ($fh, $nbytes) = @_;
271 $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
273 my $got = read $fh, $d, $nbytes;
274 $got==$nbytes or badproto_badread $fh, "data block";
278 sub protocol_receive_file ($$) {
279 my ($fh, $ourfn) = @_;
280 printdebug "() $ourfn\n";
281 open PF, ">", $ourfn or die "$ourfn: $!";
283 my ($y,$l) = protocol_expect {
284 m/^data-block (.*)$/ ? (1,$1) :
285 m/^data-end$/ ? (0,) :
289 my $d = protocol_read_bytes $fh, $l;
290 print PF $d or die $!;
295 #---------- remote protocol support, responder ----------
297 sub responder_send_command ($) {
299 return unless $we_are_responder;
300 # called even without $we_are_responder
301 printdebug ">> $command\n";
302 print PO $command, "\n" or die $!;
305 sub responder_send_file ($$) {
306 my ($keyword, $ourfn) = @_;
307 return unless $we_are_responder;
308 printdebug "]] $keyword $ourfn\n";
309 responder_send_command "file $keyword";
310 protocol_send_file \*PO, $ourfn;
313 sub responder_receive_files ($@) {
314 my ($keyword, @ourfns) = @_;
315 die unless $we_are_responder;
316 printdebug "[[ $keyword @ourfns\n";
317 responder_send_command "want $keyword";
318 foreach my $fn (@ourfns) {
319 protocol_receive_file \*PI, $fn;
322 protocol_expect { m/^files-end$/ } \*PI;
325 #---------- remote protocol support, initiator ----------
327 sub initiator_expect (&) {
329 protocol_expect { &$match } \*RO;
332 #---------- end remote code ----------
335 if ($we_are_responder) {
337 responder_send_command "progress ".length($m) or die $!;
338 print PO $m or die $!;
348 $ua = LWP::UserAgent->new();
352 progress "downloading $what...";
353 my $r = $ua->get(@_) or die $!;
354 return undef if $r->code == 404;
355 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
356 return $r->decoded_content(charset => 'none');
359 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
364 failedcmd @_ if system @_;
367 sub act_local () { return $dryrun_level <= 1; }
368 sub act_scary () { return !$dryrun_level; }
371 if (!$dryrun_level) {
372 progress "dgit ok: @_";
374 progress "would be ok: @_ (but dry run only)";
379 printcmd(\*STDERR,$debugprefix."#",@_);
382 sub runcmd_ordryrun {
390 sub runcmd_ordryrun_local {
399 my ($first_shell, @cmd) = @_;
400 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
403 our $helpmsg = <<END;
405 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
406 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
407 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
408 dgit [dgit-opts] push [dgit-opts] [suite]
409 dgit [dgit-opts] rpush build-host:build-dir ...
410 important dgit options:
411 -k<keyid> sign tag and package with <keyid> instead of default
412 --dry-run -n do not change anything, but go through the motions
413 --damp-run -L like --dry-run but make local changes, without signing
414 --new -N allow introducing a new package
415 --debug -D increase debug level
416 -c<name>=<value> set git config option (used directly by dgit too)
419 our $later_warning_msg = <<END;
420 Perhaps the upload is stuck in incoming. Using the version from git.
424 print STDERR "$us: @_\n", $helpmsg or die $!;
429 @ARGV or badusage "too few arguments";
430 return scalar shift @ARGV;
434 print $helpmsg or die $!;
438 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
440 our %defcfg = ('dgit.default.distro' => 'debian',
441 'dgit.default.username' => '',
442 'dgit.default.archive-query-default-component' => 'main',
443 'dgit.default.ssh' => 'ssh',
444 'dgit.default.archive-query' => 'madison:',
445 'dgit.default.sshpsql-dbname' => 'service=projectb',
446 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
447 'dgit-distro.debian.git-host' => 'dgit-git.debian.net',
448 'dgit-distro.debian.git-user-force' => 'dgit',
449 'dgit-distro.debian.git-proto' => 'git+ssh://',
450 'dgit-distro.debian.git-path' => '/dgit/debian/repos',
451 'dgit-distro.debian.git-check' => 'ssh-cmd',
452 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
453 # 'dgit-distro.debian.archive-query-tls-key',
454 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
455 # ^ this does not work because curl is broken nowadays
456 # Fixing #790093 properly will involve providing providing the key
457 # in some pacagke and maybe updating these paths.
459 # 'dgit-distro.debian.archive-query-tls-curl-args',
460 # '--ca-path=/etc/ssl/ca-debian',
461 # ^ this is a workaround but works (only) on DSA-administered machines
462 'dgit-distro.debian.diverts.alioth' => '/alioth',
463 'dgit-distro.debian/alioth.git-host' => 'git.debian.org',
464 'dgit-distro.debian/alioth.git-user-force' => '',
465 'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
466 'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
467 'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
468 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
469 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
470 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
471 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
472 'dgit-distro.ubuntu.git-check' => 'false',
473 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
474 'dgit-distro.test-dummy.ssh' => "$td/ssh",
475 'dgit-distro.test-dummy.username' => "alice",
476 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
477 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
478 'dgit-distro.test-dummy.git-url' => "$td/git",
479 'dgit-distro.test-dummy.git-host' => "git",
480 'dgit-distro.test-dummy.git-path' => "$td/git",
481 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
482 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
483 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
484 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
489 return undef if $c =~ /RETURN-UNDEF/;
490 my @cmd = (@git, qw(config --), $c);
493 local ($debuglevel) = $debuglevel-2;
494 $v = cmdoutput_errok @cmd;
501 my $dv = $defcfg{$c};
502 return $dv if defined $dv;
504 badcfg "need value for one of: @_\n".
505 "$us: distro or suite appears not to be (properly) supported";
508 sub access_basedistro () {
509 if (defined $idistro) {
512 return cfg("dgit-suite.$isuite.distro",
513 "dgit.default.distro");
517 sub access_quirk () {
518 # returns (quirk name, distro to use instead or undef, quirk-specific info)
519 my $basedistro = access_basedistro();
520 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
522 if (defined $backports_quirk) {
523 my $re = $backports_quirk;
524 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
526 $re =~ s/\%/([-0-9a-z_]+)/
527 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
528 if ($isuite =~ m/^$re$/) {
529 return ('backports',"$basedistro-backports",$1);
532 return ('none',undef);
535 sub access_distros () {
536 # Returns list of distros to try, in order
539 # 0. `instead of' distro name(s) we have been pointed to
540 # 1. the access_quirk distro, if any
541 # 2a. the user's specified distro, or failing that } basedistro
542 # 2b. the distro calculated from the suite }
543 my @l = access_basedistro();
545 my (undef,$quirkdistro) = access_quirk();
546 unshift @l, $quirkdistro;
547 unshift @l, $instead_distro;
548 return grep { defined } @l;
554 # The nesting of these loops determines the search order. We put
555 # the key loop on the outside so that we search all the distros
556 # for each key, before going on to the next key. That means that
557 # if access_cfg is called with a more specific, and then a less
558 # specific, key, an earlier distro can override the less specific
559 # without necessarily overriding any more specific keys. (If the
560 # distro wants to override the more specific keys it can simply do
561 # so; whereas if we did the loop the other way around, it would be
562 # impossible to for an earlier distro to override a less specific
563 # key but not the more specific ones without restating the unknown
564 # values of the more specific keys.
567 # We have to deal with RETURN-UNDEF specially, so that we don't
568 # terminate the search prematurely.
570 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
573 foreach my $d (access_distros()) {
574 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
576 push @cfgs, map { "dgit.default.$_" } @realkeys;
578 my $value = cfg(@cfgs);
582 sub string_to_ssh ($) {
584 if ($spec =~ m/\s/) {
585 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
591 sub access_cfg_ssh () {
592 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
593 if (!defined $gitssh) {
596 return string_to_ssh $gitssh;
600 sub access_runeinfo ($) {
602 return ": dgit ".access_basedistro()." $info ;";
605 sub access_someuserhost ($) {
607 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
608 defined($user) && length($user) or
609 $user = access_cfg("$some-user",'username');
610 my $host = access_cfg("$some-host");
611 return length($user) ? "$user\@$host" : $host;
614 sub access_gituserhost () {
615 return access_someuserhost('git');
618 sub access_giturl (;$) {
620 my $url = access_cfg('git-url','RETURN-UNDEF');
622 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
623 return undef unless defined $proto;
626 access_gituserhost().
627 access_cfg('git-path');
629 return "$url/$package.git";
632 sub parsecontrolfh ($$;$) {
633 my ($fh, $desc, $allowsigned) = @_;
634 our $dpkgcontrolhash_noissigned;
637 my %opts = ('name' => $desc);
638 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
639 $c = Dpkg::Control::Hash->new(%opts);
640 $c->parse($fh,$desc) or die "parsing of $desc failed";
641 last if $allowsigned;
642 last if $dpkgcontrolhash_noissigned;
643 my $issigned= $c->get_option('is_pgp_signed');
644 if (!defined $issigned) {
645 $dpkgcontrolhash_noissigned= 1;
646 seek $fh, 0,0 or die "seek $desc: $!";
647 } elsif ($issigned) {
648 fail "control file $desc is (already) PGP-signed. ".
649 " Note that dgit push needs to modify the .dsc and then".
650 " do the signature itself";
659 my ($file, $desc) = @_;
660 my $fh = new IO::Handle;
661 open $fh, '<', $file or die "$file: $!";
662 my $c = parsecontrolfh($fh,$desc);
663 $fh->error and die $!;
669 my ($dctrl,$field) = @_;
670 my $v = $dctrl->{$field};
671 return $v if defined $v;
672 fail "missing field $field in ".$v->get_option('name');
676 my $c = Dpkg::Control::Hash->new();
677 my $p = new IO::Handle;
678 my @cmd = (qw(dpkg-parsechangelog), @_);
679 open $p, '-|', @cmd or die $!;
681 $?=0; $!=0; close $p or failedcmd @cmd;
687 defined $d or fail "getcwd failed: $!";
693 sub archive_query ($) {
695 my $query = access_cfg('archive-query','RETURN-UNDEF');
696 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
699 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
702 sub pool_dsc_subpath ($$) {
703 my ($vsn,$component) = @_; # $package is implict arg
704 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
705 return "/pool/$component/$prefix/$package/".dscfn($vsn);
708 #---------- `ftpmasterapi' archive query method (nascent) ----------
710 sub archive_api_query_cmd ($) {
712 my @cmd = qw(curl -sS);
713 my $url = access_cfg('archive-query-url');
714 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
716 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
717 foreach my $key (split /\:/, $keys) {
718 $key =~ s/\%HOST\%/$host/g;
720 fail "for $url: stat $key: $!" unless $!==ENOENT;
723 fail "config requested specific TLS key but do not know".
724 " how to get curl to use exactly that EE key ($key)";
725 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
726 # # Sadly the above line does not work because of changes
727 # # to gnutls. The real fix for #790093 may involve
728 # # new curl options.
731 # Fixing #790093 properly will involve providing a value
732 # for this on clients.
733 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
734 push @cmd, split / /, $kargs if defined $kargs;
736 push @cmd, $url.$subpath;
742 my ($data, $subpath) = @_;
743 badcfg "ftpmasterapi archive query method takes no data part"
745 my @cmd = archive_api_query_cmd($subpath);
746 my $json = cmdoutput @cmd;
747 return decode_json($json);
750 sub canonicalise_suite_ftpmasterapi () {
751 my ($proto,$data) = @_;
752 my $suites = api_query($data, 'suites');
754 foreach my $entry (@$suites) {
756 my $v = $entry->{$_};
757 defined $v && $v eq $isuite;
759 push @matched, $entry;
761 fail "unknown suite $isuite" unless @matched;
764 @matched==1 or die "multiple matches for suite $isuite\n";
765 $cn = "$matched[0]{codename}";
766 defined $cn or die "suite $isuite info has no codename\n";
767 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
769 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
774 sub archive_query_ftpmasterapi () {
775 my ($proto,$data) = @_;
776 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
778 my $digester = Digest::SHA->new(256);
779 foreach my $entry (@$info) {
781 my $vsn = "$entry->{version}";
782 my ($ok,$msg) = version_check $vsn;
783 die "bad version: $msg\n" unless $ok;
784 my $component = "$entry->{component}";
785 $component =~ m/^$component_re$/ or die "bad component";
786 my $filename = "$entry->{filename}";
787 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
788 or die "bad filename";
789 my $sha256sum = "$entry->{sha256sum}";
790 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
791 push @rows, [ $vsn, "/pool/$component/$filename",
792 $digester, $sha256sum ];
794 die "bad ftpmaster api response: $@\n".Dumper($entry)
797 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
801 #---------- `madison' archive query method ----------
803 sub archive_query_madison {
804 return map { [ @$_[0..1] ] } madison_get_parse(@_);
807 sub madison_get_parse {
808 my ($proto,$data) = @_;
809 die unless $proto eq 'madison';
811 $data= access_cfg('madison-distro','RETURN-UNDEF');
812 $data //= access_basedistro();
814 $rmad{$proto,$data,$package} ||= cmdoutput
815 qw(rmadison -asource),"-s$isuite","-u$data",$package;
816 my $rmad = $rmad{$proto,$data,$package};
819 foreach my $l (split /\n/, $rmad) {
820 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
821 \s*( [^ \t|]+ )\s* \|
822 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
823 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
824 $1 eq $package or die "$rmad $package ?";
831 $component = access_cfg('archive-query-default-component');
833 $5 eq 'source' or die "$rmad ?";
834 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
836 return sort { -version_compare($a->[0],$b->[0]); } @out;
839 sub canonicalise_suite_madison {
840 # madison canonicalises for us
841 my @r = madison_get_parse(@_);
843 "unable to canonicalise suite using package $package".
844 " which does not appear to exist in suite $isuite;".
845 " --existing-package may help";
849 #---------- `sshpsql' archive query method ----------
852 my ($data,$runeinfo,$sql) = @_;
854 $data= access_someuserhost('sshpsql').':'.
855 access_cfg('sshpsql-dbname');
857 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
858 my ($userhost,$dbname) = ($`,$'); #';
860 my @cmd = (access_cfg_ssh, $userhost,
861 access_runeinfo("ssh-psql $runeinfo").
862 " export LC_MESSAGES=C; export LC_CTYPE=C;".
863 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
865 open P, "-|", @cmd or die $!;
868 printdebug("$debugprefix>|$_|\n");
871 $!=0; $?=0; close P or failedcmd @cmd;
873 my $nrows = pop @rows;
874 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
875 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
876 @rows = map { [ split /\|/, $_ ] } @rows;
877 my $ncols = scalar @{ shift @rows };
878 die if grep { scalar @$_ != $ncols } @rows;
882 sub sql_injection_check {
883 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
886 sub archive_query_sshpsql ($$) {
887 my ($proto,$data) = @_;
888 sql_injection_check $isuite, $package;
889 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
890 SELECT source.version, component.name, files.filename, files.sha256sum
892 JOIN src_associations ON source.id = src_associations.source
893 JOIN suite ON suite.id = src_associations.suite
894 JOIN dsc_files ON dsc_files.source = source.id
895 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
896 JOIN component ON component.id = files_archive_map.component_id
897 JOIN files ON files.id = dsc_files.file
898 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
899 AND source.source='$package'
900 AND files.filename LIKE '%.dsc';
902 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
903 my $digester = Digest::SHA->new(256);
905 my ($vsn,$component,$filename,$sha256sum) = @$_;
906 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
911 sub canonicalise_suite_sshpsql ($$) {
912 my ($proto,$data) = @_;
913 sql_injection_check $isuite;
914 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
915 SELECT suite.codename
916 FROM suite where suite_name='$isuite' or codename='$isuite';
918 @rows = map { $_->[0] } @rows;
919 fail "unknown suite $isuite" unless @rows;
920 die "ambiguous $isuite: @rows ?" if @rows>1;
924 #---------- `dummycat' archive query method ----------
926 sub canonicalise_suite_dummycat ($$) {
927 my ($proto,$data) = @_;
928 my $dpath = "$data/suite.$isuite";
929 if (!open C, "<", $dpath) {
930 $!==ENOENT or die "$dpath: $!";
931 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
935 chomp or die "$dpath: $!";
937 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
941 sub archive_query_dummycat ($$) {
942 my ($proto,$data) = @_;
943 canonicalise_suite();
944 my $dpath = "$data/package.$csuite.$package";
945 if (!open C, "<", $dpath) {
946 $!==ENOENT or die "$dpath: $!";
947 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
955 printdebug "dummycat query $csuite $package $dpath | $_\n";
956 my @row = split /\s+/, $_;
957 @row==2 or die "$dpath: $_ ?";
960 C->error and die "$dpath: $!";
962 return sort { -version_compare($a->[0],$b->[0]); } @rows;
965 #---------- archive query entrypoints and rest of program ----------
967 sub canonicalise_suite () {
968 return if defined $csuite;
969 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
970 $csuite = archive_query('canonicalise_suite');
971 if ($isuite ne $csuite) {
972 progress "canonical suite name for $isuite is $csuite";
976 sub get_archive_dsc () {
977 canonicalise_suite();
978 my @vsns = archive_query('archive_query');
979 foreach my $vinfo (@vsns) {
980 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
981 $dscurl = access_cfg('mirror').$subpath;
982 $dscdata = url_get($dscurl);
984 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
989 $digester->add($dscdata);
990 my $got = $digester->hexdigest();
992 fail "$dscurl has hash $got but".
993 " archive told us to expect $digest";
995 my $dscfh = new IO::File \$dscdata, '<' or die $!;
996 printdebug Dumper($dscdata) if $debuglevel>1;
997 $dsc = parsecontrolfh($dscfh,$dscurl,1);
998 printdebug Dumper($dsc) if $debuglevel>1;
999 my $fmt = getfield $dsc, 'Format';
1000 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1001 $dsc_checked = !!$digester;
1007 sub check_for_git ();
1008 sub check_for_git () {
1010 my $how = access_cfg('git-check');
1011 if ($how eq 'ssh-cmd') {
1013 (access_cfg_ssh, access_gituserhost(),
1014 access_runeinfo("git-check $package").
1015 " set -e; cd ".access_cfg('git-path').";".
1016 " if test -d $package.git; then echo 1; else echo 0; fi");
1017 my $r= cmdoutput @cmd;
1018 if ($r =~ m/^divert (\w+)$/) {
1020 my ($usedistro,) = access_distros();
1021 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1022 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1023 printdebug "diverting $divert so using distro $instead_distro\n";
1024 return check_for_git();
1026 failedcmd @cmd unless $r =~ m/^[01]$/;
1028 } elsif ($how eq 'true') {
1030 } elsif ($how eq 'false') {
1033 badcfg "unknown git-check \`$how'";
1037 sub create_remote_git_repo () {
1038 my $how = access_cfg('git-create');
1039 if ($how eq 'ssh-cmd') {
1041 (access_cfg_ssh, access_gituserhost(),
1042 access_runeinfo("git-create $package").
1043 "set -e; cd ".access_cfg('git-path').";".
1044 " cp -a _template $package.git");
1045 } elsif ($how eq 'true') {
1048 badcfg "unknown git-create \`$how'";
1052 our ($dsc_hash,$lastpush_hash);
1054 our $ud = '.git/dgit/unpack';
1059 mkdir $ud or die $!;
1062 sub mktree_in_ud_here () {
1063 runcmd qw(git init -q);
1064 rmtree('.git/objects');
1065 symlink '../../../../objects','.git/objects' or die $!;
1068 sub git_write_tree () {
1069 my $tree = cmdoutput @git, qw(write-tree);
1070 $tree =~ m/^\w+$/ or die "$tree ?";
1074 sub mktree_in_ud_from_only_subdir () {
1075 # changes into the subdir
1077 die unless @dirs==1;
1078 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1081 fail "source package contains .git directory" if stat_exists '.git';
1082 mktree_in_ud_here();
1083 my $format=get_source_format();
1084 if (madformat($format)) {
1087 runcmd @git, qw(add -Af);
1088 my $tree=git_write_tree();
1089 return ($tree,$dir);
1092 sub dsc_files_info () {
1093 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1094 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1095 ['Files', 'Digest::MD5', 'new()']) {
1096 my ($fname, $module, $method) = @$csumi;
1097 my $field = $dsc->{$fname};
1098 next unless defined $field;
1099 eval "use $module; 1;" or die $@;
1101 foreach (split /\n/, $field) {
1103 m/^(\w+) (\d+) (\S+)$/ or
1104 fail "could not parse .dsc $fname line \`$_'";
1105 my $digester = eval "$module"."->$method;" or die $@;
1110 Digester => $digester,
1115 fail "missing any supported Checksums-* or Files field in ".
1116 $dsc->get_option('name');
1120 map { $_->{Filename} } dsc_files_info();
1123 sub is_orig_file ($;$) {
1126 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1127 defined $base or return 1;
1131 sub make_commit ($) {
1133 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1136 sub clogp_authline ($) {
1138 my $author = getfield $clogp, 'Maintainer';
1139 $author =~ s#,.*##ms;
1140 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1141 my $authline = "$author $date";
1142 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1143 fail "unexpected commit author line format \`$authline'".
1144 " (was generated from changelog Maintainer field)";
1148 sub vendor_patches_distro ($$) {
1149 my ($checkdistro, $what) = @_;
1150 return unless defined $checkdistro;
1152 my $series = "debian/patches/\L$checkdistro\E.series";
1153 printdebug "checking for vendor-specific $series ($what)\n";
1155 if (!open SERIES, "<", $series) {
1156 die "$series $!" unless $!==ENOENT;
1165 Unfortunately, this source package uses a feature of dpkg-source where
1166 the same source package unpacks to different source code on different
1167 distros. dgit cannot safely operate on such packages on affected
1168 distros, because the meaning of source packages is not stable.
1170 Please ask the distro/maintainer to remove the distro-specific series
1171 files and use a different technique (if necessary, uploading actually
1172 different packages, if different distros are supposed to have
1176 fail "Found active distro-specific series file for".
1177 " $checkdistro ($what): $series, cannot continue";
1179 die "$series $!" if SERIES->error;
1183 sub check_for_vendor_patches () {
1184 # This dpkg-source feature doesn't seem to be documented anywhere!
1185 # But it can be found in the changelog (reformatted):
1187 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1188 # Author: Raphael Hertzog <hertzog@debian.org>
1189 # Date: Sun Oct 3 09:36:48 2010 +0200
1191 # dpkg-source: correctly create .pc/.quilt_series with alternate
1194 # If you have debian/patches/ubuntu.series and you were
1195 # unpacking the source package on ubuntu, quilt was still
1196 # directed to debian/patches/series instead of
1197 # debian/patches/ubuntu.series.
1199 # debian/changelog | 3 +++
1200 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1201 # 2 files changed, 6 insertions(+), 1 deletion(-)
1204 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1205 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1206 "Dpkg::Vendor \`current vendor'");
1207 vendor_patches_distro(access_basedistro(),
1208 "distro being accessed");
1211 sub generate_commit_from_dsc () {
1215 foreach my $fi (dsc_files_info()) {
1216 my $f = $fi->{Filename};
1217 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1219 link "../../../$f", $f
1223 complete_file_from_dsc('.', $fi);
1225 if (is_orig_file($f)) {
1226 link $f, "../../../../$f"
1232 my $dscfn = "$package.dsc";
1234 open D, ">", $dscfn or die "$dscfn: $!";
1235 print D $dscdata or die "$dscfn: $!";
1236 close D or die "$dscfn: $!";
1237 my @cmd = qw(dpkg-source);
1238 push @cmd, '--no-check' if $dsc_checked;
1239 push @cmd, qw(-x --), $dscfn;
1242 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1243 check_for_vendor_patches() if madformat($dsc->{format});
1244 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1245 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1246 my $authline = clogp_authline $clogp;
1247 my $changes = getfield $clogp, 'Changes';
1248 open C, ">../commit.tmp" or die $!;
1249 print C <<END or die $!;
1256 # imported from the archive
1259 my $outputhash = make_commit qw(../commit.tmp);
1260 my $cversion = getfield $clogp, 'Version';
1261 progress "synthesised git commit from .dsc $cversion";
1262 if ($lastpush_hash) {
1263 runcmd @git, qw(reset --hard), $lastpush_hash;
1264 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1265 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1266 my $oversion = getfield $oldclogp, 'Version';
1268 version_compare($oversion, $cversion);
1270 # git upload/ is earlier vsn than archive, use archive
1271 open C, ">../commit2.tmp" or die $!;
1272 print C <<END or die $!;
1274 parent $lastpush_hash
1279 Record $package ($cversion) in archive suite $csuite
1281 $outputhash = make_commit qw(../commit2.tmp);
1282 } elsif ($vcmp > 0) {
1283 print STDERR <<END or die $!;
1285 Version actually in archive: $cversion (older)
1286 Last allegedly pushed/uploaded: $oversion (newer or same)
1289 $outputhash = $lastpush_hash;
1291 $outputhash = $lastpush_hash;
1294 changedir '../../../..';
1295 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1296 'DGIT_ARCHIVE', $outputhash;
1297 cmdoutput @git, qw(log -n2), $outputhash;
1298 # ... gives git a chance to complain if our commit is malformed
1303 sub complete_file_from_dsc ($$) {
1304 our ($dstdir, $fi) = @_;
1305 # Ensures that we have, in $dir, the file $fi, with the correct
1306 # contents. (Downloading it from alongside $dscurl if necessary.)
1308 my $f = $fi->{Filename};
1309 my $tf = "$dstdir/$f";
1312 if (stat_exists $tf) {
1313 progress "using existing $f";
1316 $furl =~ s{/[^/]+$}{};
1318 die "$f ?" unless $f =~ m/^${package}_/;
1319 die "$f ?" if $f =~ m#/#;
1320 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1321 next if !act_local();
1325 open F, "<", "$tf" or die "$tf: $!";
1326 $fi->{Digester}->reset();
1327 $fi->{Digester}->addfile(*F);
1328 F->error and die $!;
1329 my $got = $fi->{Digester}->hexdigest();
1330 $got eq $fi->{Hash} or
1331 fail "file $f has hash $got but .dsc".
1332 " demands hash $fi->{Hash} ".
1333 ($downloaded ? "(got wrong file from archive!)"
1334 : "(perhaps you should delete this file?)");
1337 sub ensure_we_have_orig () {
1338 foreach my $fi (dsc_files_info()) {
1339 my $f = $fi->{Filename};
1340 next unless is_orig_file($f);
1341 complete_file_from_dsc('..', $fi);
1345 sub git_fetch_us () {
1346 my @specs = (fetchspec());
1348 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1350 runcmd_ordryrun_local @git, qw(fetch -p -n), access_giturl(), @specs;
1353 my $tagpat = debiantag('*',access_basedistro);
1355 git_for_each_ref("refs/tags/".$tagpat, sub {
1356 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1357 printdebug "currently $fullrefname=$objid\n";
1358 $here{$fullrefname} = $objid;
1360 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1361 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1362 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1363 printdebug "offered $lref=$objid\n";
1364 if (!defined $here{$lref}) {
1365 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1366 runcmd_ordryrun_local @upd;
1367 } elsif ($here{$lref} eq $objid) {
1370 "Not updateting $lref from $here{$lref} to $objid.\n";
1375 sub fetch_from_archive () {
1376 # ensures that lrref() is what is actually in the archive,
1377 # one way or another
1381 foreach my $field (@ourdscfield) {
1382 $dsc_hash = $dsc->{$field};
1383 last if defined $dsc_hash;
1385 if (defined $dsc_hash) {
1386 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1388 progress "last upload to archive specified git hash";
1390 progress "last upload to archive has NO git hash";
1393 progress "no version available from the archive";
1396 $lastpush_hash = git_get_ref(lrref());
1397 printdebug "previous reference hash=$lastpush_hash\n";
1399 if (defined $dsc_hash) {
1400 fail "missing remote git history even though dsc has hash -".
1401 " could not find ref ".lrref().
1402 " (should have been fetched from ".access_giturl()."#".rrref().")"
1403 unless $lastpush_hash;
1405 ensure_we_have_orig();
1406 if ($dsc_hash eq $lastpush_hash) {
1407 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1408 print STDERR <<END or die $!;
1410 Git commit in archive is behind the last version allegedly pushed/uploaded.
1411 Commit referred to by archive: $dsc_hash
1412 Last allegedly pushed/uploaded: $lastpush_hash
1415 $hash = $lastpush_hash;
1417 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1418 "descendant of archive's .dsc hash ($dsc_hash)";
1421 $hash = generate_commit_from_dsc();
1422 } elsif ($lastpush_hash) {
1423 # only in git, not in the archive yet
1424 $hash = $lastpush_hash;
1425 print STDERR <<END or die $!;
1427 Package not found in the archive, but has allegedly been pushed using dgit.
1431 printdebug "nothing found!\n";
1432 if (defined $skew_warning_vsn) {
1433 print STDERR <<END or die $!;
1435 Warning: relevant archive skew detected.
1436 Archive allegedly contains $skew_warning_vsn
1437 But we were not able to obtain any version from the archive or git.
1443 printdebug "current hash=$hash\n";
1444 if ($lastpush_hash) {
1445 fail "not fast forward on last upload branch!".
1446 " (archive's version left in DGIT_ARCHIVE)"
1447 unless is_fast_fwd($lastpush_hash, $hash);
1449 if (defined $skew_warning_vsn) {
1451 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1452 my $clogf = ".git/dgit/changelog.tmp";
1453 runcmd shell_cmd "exec >$clogf",
1454 @git, qw(cat-file blob), "$hash:debian/changelog";
1455 my $gotclogp = parsechangelog("-l$clogf");
1456 my $got_vsn = getfield $gotclogp, 'Version';
1457 printdebug "SKEW CHECK GOT $got_vsn\n";
1458 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1459 print STDERR <<END or die $!;
1461 Warning: archive skew detected. Using the available version:
1462 Archive allegedly contains $skew_warning_vsn
1463 We were able to obtain only $got_vsn
1468 if ($lastpush_hash ne $hash) {
1469 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1473 dryrun_report @upd_cmd;
1479 sub set_local_git_config ($$) {
1481 runcmd @git, qw(config), $k, $v;
1486 canonicalise_suite();
1487 badusage "dry run makes no sense with clone" unless act_local();
1488 my $hasgit = check_for_git();
1489 mkdir $dstdir or die "$dstdir $!";
1491 runcmd @git, qw(init -q);
1492 my $giturl = access_giturl(1);
1493 if (defined $giturl) {
1494 set_local_git_config "remote.$remotename.fetch", fetchspec();
1495 open H, "> .git/HEAD" or die $!;
1496 print H "ref: ".lref()."\n" or die $!;
1498 runcmd @git, qw(remote add), 'origin', $giturl;
1501 progress "fetching existing git history";
1503 runcmd_ordryrun_local @git, qw(fetch origin);
1505 progress "starting new git history";
1507 fetch_from_archive() or no_such_package;
1508 my $vcsgiturl = $dsc->{'Vcs-Git'};
1509 if (length $vcsgiturl) {
1510 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1511 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1513 runcmd @git, qw(reset --hard), lrref();
1514 printdone "ready for work in $dstdir";
1518 if (check_for_git()) {
1521 fetch_from_archive() or no_such_package();
1522 printdone "fetched into ".lrref();
1527 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1529 printdone "fetched to ".lrref()." and merged into HEAD";
1532 sub check_not_dirty () {
1533 return if $ignoredirty;
1534 my @cmd = (@git, qw(diff --quiet HEAD));
1536 $!=0; $?=0; system @cmd;
1537 return if !$! && !$?;
1538 if (!$! && $?==256) {
1539 fail "working tree is dirty (does not match HEAD)";
1545 sub commit_admin ($) {
1548 runcmd_ordryrun_local @git, qw(commit -m), $m;
1551 sub commit_quilty_patch () {
1552 my $output = cmdoutput @git, qw(status --porcelain);
1554 foreach my $l (split /\n/, $output) {
1555 next unless $l =~ m/\S/;
1556 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1560 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1562 progress "nothing quilty to commit, ok.";
1565 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1566 commit_admin "Commit Debian 3.0 (quilt) metadata";
1569 sub get_source_format () {
1570 if (!open F, "debian/source/format") {
1571 die $! unless $!==&ENOENT;
1575 F->error and die $!;
1582 return 0 unless $format eq '3.0 (quilt)';
1583 if ($quilt_mode eq 'nocheck') {
1584 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1587 progress "Format \`$format', checking/updating patch stack";
1591 sub push_parse_changelog ($) {
1594 my $clogp = Dpkg::Control::Hash->new();
1595 $clogp->load($clogpfn) or die;
1597 $package = getfield $clogp, 'Source';
1598 my $cversion = getfield $clogp, 'Version';
1599 my $tag = debiantag($cversion, access_basedistro);
1600 runcmd @git, qw(check-ref-format), $tag;
1602 my $dscfn = dscfn($cversion);
1604 return ($clogp, $cversion, $tag, $dscfn);
1607 sub push_parse_dsc ($$$) {
1608 my ($dscfn,$dscfnwhat, $cversion) = @_;
1609 $dsc = parsecontrol($dscfn,$dscfnwhat);
1610 my $dversion = getfield $dsc, 'Version';
1611 my $dscpackage = getfield $dsc, 'Source';
1612 ($dscpackage eq $package && $dversion eq $cversion) or
1613 fail "$dscfn is for $dscpackage $dversion".
1614 " but debian/changelog is for $package $cversion";
1617 sub push_mktag ($$$$$$$) {
1618 my ($head,$clogp,$tag,
1620 $changesfile,$changesfilewhat,
1623 $dsc->{$ourdscfield[0]} = $head;
1624 $dsc->save("$dscfn.tmp") or die $!;
1626 my $changes = parsecontrol($changesfile,$changesfilewhat);
1627 foreach my $field (qw(Source Distribution Version)) {
1628 $changes->{$field} eq $clogp->{$field} or
1629 fail "changes field $field \`$changes->{$field}'".
1630 " does not match changelog \`$clogp->{$field}'";
1633 my $cversion = getfield $clogp, 'Version';
1634 my $clogsuite = getfield $clogp, 'Distribution';
1636 # We make the git tag by hand because (a) that makes it easier
1637 # to control the "tagger" (b) we can do remote signing
1638 my $authline = clogp_authline $clogp;
1639 my $delibs = join(" ", "",@deliberatelies);
1640 my $declaredistro = access_basedistro();
1641 open TO, '>', $tfn->('.tmp') or die $!;
1642 print TO <<END or die $!;
1648 $package release $cversion for $clogsuite ($csuite) [dgit]
1649 [dgit distro=$declaredistro$delibs]
1651 foreach my $ref (sort keys %previously) {
1652 print TO <<END or die $!;
1653 [dgit previously:$ref=$previously{$ref}]
1659 my $tagobjfn = $tfn->('.tmp');
1661 if (!defined $keyid) {
1662 $keyid = access_cfg('keyid','RETURN-UNDEF');
1664 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1665 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1666 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1667 push @sign_cmd, $tfn->('.tmp');
1668 runcmd_ordryrun @sign_cmd;
1670 $tagobjfn = $tfn->('.signed.tmp');
1671 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1672 $tfn->('.tmp'), $tfn->('.tmp.asc');
1679 sub sign_changes ($) {
1680 my ($changesfile) = @_;
1682 my @debsign_cmd = @debsign;
1683 push @debsign_cmd, "-k$keyid" if defined $keyid;
1684 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1685 push @debsign_cmd, $changesfile;
1686 runcmd_ordryrun @debsign_cmd;
1691 my ($forceflag) = @_;
1692 printdebug "actually entering push\n";
1695 access_giturl(); # check that success is vaguely likely
1697 my $clogpfn = ".git/dgit/changelog.822.tmp";
1698 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1700 responder_send_file('parsed-changelog', $clogpfn);
1702 my ($clogp, $cversion, $tag, $dscfn) =
1703 push_parse_changelog("$clogpfn");
1705 my $dscpath = "$buildproductsdir/$dscfn";
1706 stat_exists $dscpath or
1707 fail "looked for .dsc $dscfn, but $!;".
1708 " maybe you forgot to build";
1710 responder_send_file('dsc', $dscpath);
1712 push_parse_dsc($dscpath, $dscfn, $cversion);
1714 my $format = getfield $dsc, 'Format';
1715 printdebug "format $format\n";
1716 if (madformat($format)) {
1717 commit_quilty_patch();
1721 progress "checking that $dscfn corresponds to HEAD";
1722 runcmd qw(dpkg-source -x --),
1723 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1724 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1725 check_for_vendor_patches() if madformat($dsc->{format});
1726 changedir '../../../..';
1727 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1728 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1729 debugcmd "+",@diffcmd;
1731 my $r = system @diffcmd;
1734 fail "$dscfn specifies a different tree to your HEAD commit;".
1735 " perhaps you forgot to build".
1736 ($diffopt eq '--exit-code' ? "" :
1737 " (run with -D to see full diff output)");
1743 #do fast forward check and maybe fake merge
1744 # if (!is_fast_fwd(mainbranch
1745 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1746 # map { lref($_).":".rref($_) }
1748 my $head = git_rev_parse('HEAD');
1749 if (!$changesfile) {
1750 my $multi = "$buildproductsdir/".
1751 "${package}_".(stripepoch $cversion)."_multi.changes";
1752 if (stat_exists "$multi") {
1753 $changesfile = $multi;
1755 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1756 my @cs = glob "$buildproductsdir/$pat";
1757 fail "failed to find unique changes file".
1758 " (looked for $pat in $buildproductsdir, or $multi);".
1759 " perhaps you need to use dgit -C"
1761 ($changesfile) = @cs;
1764 $changesfile = "$buildproductsdir/$changesfile";
1767 responder_send_file('changes',$changesfile);
1768 responder_send_command("param head $head");
1769 responder_send_command("param csuite $csuite");
1771 if (deliberately_not_fast_forward) {
1772 git_for_each_ref(lrfetchrefs, sub {
1773 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1774 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1775 responder_send_command("previously $rrefname=$objid");
1776 $previously{$rrefname} = $objid;
1780 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1783 if ($we_are_responder) {
1784 $tagobjfn = $tfn->('.signed.tmp');
1785 responder_receive_files('signed-tag', $tagobjfn);
1788 push_mktag($head,$clogp,$tag,
1790 $changesfile,$changesfile,
1794 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1795 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1796 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1797 runcmd_ordryrun @git, qw(tag -v --), $tag;
1799 if (!check_for_git()) {
1800 create_remote_git_repo();
1802 runcmd_ordryrun @git, qw(push),access_giturl(),
1803 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1804 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1806 if ($we_are_responder) {
1807 my $dryrunsuffix = act_local() ? "" : ".tmp";
1808 responder_receive_files('signed-dsc-changes',
1809 "$dscpath$dryrunsuffix",
1810 "$changesfile$dryrunsuffix");
1813 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1815 progress "[new .dsc left in $dscpath.tmp]";
1817 sign_changes $changesfile;
1820 my $host = access_cfg('upload-host','RETURN-UNDEF');
1821 my @hostarg = defined($host) ? ($host,) : ();
1822 runcmd_ordryrun @dput, @hostarg, $changesfile;
1823 printdone "pushed and uploaded $cversion";
1825 responder_send_command("complete");
1831 badusage "-p is not allowed with clone; specify as argument instead"
1832 if defined $package;
1835 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1836 ($package,$isuite) = @ARGV;
1837 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1838 ($package,$dstdir) = @ARGV;
1839 } elsif (@ARGV==3) {
1840 ($package,$isuite,$dstdir) = @ARGV;
1842 badusage "incorrect arguments to dgit clone";
1844 $dstdir ||= "$package";
1846 if (stat_exists $dstdir) {
1847 fail "$dstdir already exists";
1851 if ($rmonerror && !$dryrun_level) {
1852 $cwd_remove= getcwd();
1854 return unless defined $cwd_remove;
1855 if (!chdir "$cwd_remove") {
1856 return if $!==&ENOENT;
1857 die "chdir $cwd_remove: $!";
1859 rmtree($dstdir) or die "remove $dstdir: $!\n";
1864 $cwd_remove = undef;
1867 sub branchsuite () {
1868 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1869 if ($branch =~ m#$lbranch_re#o) {
1876 sub fetchpullargs () {
1877 if (!defined $package) {
1878 my $sourcep = parsecontrol('debian/control','debian/control');
1879 $package = getfield $sourcep, 'Source';
1882 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1884 my $clogp = parsechangelog();
1885 $isuite = getfield $clogp, 'Distribution';
1887 canonicalise_suite();
1888 progress "fetching from suite $csuite";
1889 } elsif (@ARGV==1) {
1891 canonicalise_suite();
1893 badusage "incorrect arguments to dgit fetch or dgit pull";
1911 badusage "-p is not allowed with dgit push" if defined $package;
1913 my $clogp = parsechangelog();
1914 $package = getfield $clogp, 'Source';
1917 } elsif (@ARGV==1) {
1918 ($specsuite) = (@ARGV);
1920 badusage "incorrect arguments to dgit push";
1922 $isuite = getfield $clogp, 'Distribution';
1924 local ($package) = $existing_package; # this is a hack
1925 canonicalise_suite();
1927 canonicalise_suite();
1929 if (defined $specsuite &&
1930 $specsuite ne $isuite &&
1931 $specsuite ne $csuite) {
1932 fail "dgit push: changelog specifies $isuite ($csuite)".
1933 " but command line specifies $specsuite";
1935 if (check_for_git()) {
1939 if (fetch_from_archive()) {
1940 if (is_fast_fwd(lrref(), 'HEAD')) {
1942 } elsif (deliberately_not_fast_forward) {
1945 fail "dgit push: HEAD is not a descendant".
1946 " of the archive's version.\n".
1947 "dgit: To overwrite its contents,".
1948 " use git merge -s ours ".lrref().".\n".
1949 "dgit: To rewind history, if permitted by the archive,".
1950 " use --deliberately-not-fast-forward";
1954 fail "package appears to be new in this suite;".
1955 " if this is intentional, use --new";
1960 #---------- remote commands' implementation ----------
1962 sub cmd_remote_push_build_host {
1963 my ($nrargs) = shift @ARGV;
1964 my (@rargs) = @ARGV[0..$nrargs-1];
1965 @ARGV = @ARGV[$nrargs..$#ARGV];
1967 my ($dir,$vsnwant) = @rargs;
1968 # vsnwant is a comma-separated list; we report which we have
1969 # chosen in our ready response (so other end can tell if they
1972 $we_are_responder = 1;
1973 $us .= " (build host)";
1975 open PI, "<&STDIN" or die $!;
1976 open STDIN, "/dev/null" or die $!;
1977 open PO, ">&STDOUT" or die $!;
1979 open STDOUT, ">&STDERR" or die $!;
1983 fail "build host has dgit rpush protocol version".
1984 " $rpushprotovsn but invocation host has $vsnwant"
1985 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
1987 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
1993 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
1994 # ... for compatibility with proto vsn.1 dgit (just so that user gets
1995 # a good error message)
2001 my $report = i_child_report();
2002 if (defined $report) {
2003 printdebug "($report)\n";
2004 } elsif ($i_child_pid) {
2005 printdebug "(killing build host child $i_child_pid)\n";
2006 kill 15, $i_child_pid;
2008 if (defined $i_tmp && !defined $initiator_tempdir) {
2010 eval { rmtree $i_tmp; };
2014 END { i_cleanup(); }
2017 my ($base,$selector,@args) = @_;
2018 $selector =~ s/\-/_/g;
2019 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2025 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2032 my @rargs = ($dir,$rpushprotovsn);
2035 push @rdgit, @ropts;
2036 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2038 my @cmd = (@ssh, $host, shellquote @rdgit);
2041 if (defined $initiator_tempdir) {
2042 rmtree $initiator_tempdir;
2043 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2044 $i_tmp = $initiator_tempdir;
2048 $i_child_pid = open2(\*RO, \*RI, @cmd);
2050 initiator_expect { m/^dgit-remote-push-ready/ };
2052 my ($icmd,$iargs) = initiator_expect {
2053 m/^(\S+)(?: (.*))?$/;
2056 i_method "i_resp", $icmd, $iargs;
2060 sub i_resp_progress ($) {
2062 my $msg = protocol_read_bytes \*RO, $rhs;
2066 sub i_resp_complete {
2067 my $pid = $i_child_pid;
2068 $i_child_pid = undef; # prevents killing some other process with same pid
2069 printdebug "waiting for build host child $pid...\n";
2070 my $got = waitpid $pid, 0;
2071 die $! unless $got == $pid;
2072 die "build host child failed $?" if $?;
2075 printdebug "all done\n";
2079 sub i_resp_file ($) {
2081 my $localname = i_method "i_localname", $keyword;
2082 my $localpath = "$i_tmp/$localname";
2083 stat_exists $localpath and
2084 badproto \*RO, "file $keyword ($localpath) twice";
2085 protocol_receive_file \*RO, $localpath;
2086 i_method "i_file", $keyword;
2091 sub i_resp_param ($) {
2092 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2096 sub i_resp_previously ($) {
2097 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2098 or badproto \*RO, "bad previously spec";
2099 my $r = system qw(git check-ref-format), $1;
2100 die "bad previously ref spec ($r)" if $r;
2101 $previously{$1} = $2;
2106 sub i_resp_want ($) {
2108 die "$keyword ?" if $i_wanted{$keyword}++;
2109 my @localpaths = i_method "i_want", $keyword;
2110 printdebug "[[ $keyword @localpaths\n";
2111 foreach my $localpath (@localpaths) {
2112 protocol_send_file \*RI, $localpath;
2114 print RI "files-end\n" or die $!;
2117 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2119 sub i_localname_parsed_changelog {
2120 return "remote-changelog.822";
2122 sub i_file_parsed_changelog {
2123 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2124 push_parse_changelog "$i_tmp/remote-changelog.822";
2125 die if $i_dscfn =~ m#/|^\W#;
2128 sub i_localname_dsc {
2129 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2134 sub i_localname_changes {
2135 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2136 $i_changesfn = $i_dscfn;
2137 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2138 return $i_changesfn;
2140 sub i_file_changes { }
2142 sub i_want_signed_tag {
2143 printdebug Dumper(\%i_param, $i_dscfn);
2144 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2145 && defined $i_param{'csuite'}
2146 or badproto \*RO, "premature desire for signed-tag";
2147 my $head = $i_param{'head'};
2148 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2150 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2152 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2155 push_mktag $head, $i_clogp, $i_tag,
2157 $i_changesfn, 'remote changes',
2158 sub { "tag$_[0]"; };
2163 sub i_want_signed_dsc_changes {
2164 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2165 sign_changes $i_changesfn;
2166 return ($i_dscfn, $i_changesfn);
2169 #---------- building etc. ----------
2175 #----- `3.0 (quilt)' handling -----
2177 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2179 sub quiltify_dpkg_commit ($$$;$) {
2180 my ($patchname,$author,$msg, $xinfo) = @_;
2184 my $descfn = ".git/dgit/quilt-description.tmp";
2185 open O, '>', $descfn or die "$descfn: $!";
2188 $msg =~ s/^\s+$/ ./mg;
2189 print O <<END or die $!;
2199 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2200 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2201 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2202 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2206 sub quiltify_trees_differ ($$) {
2208 # returns 1 iff the two tree objects differ other than in debian/
2210 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2211 my $diffs= cmdoutput @cmd;
2212 foreach my $f (split /\0/, $diffs) {
2213 next if $f eq 'debian';
2219 sub quiltify_tree_sentinelfiles ($) {
2220 # lists the `sentinel' files present in the tree
2222 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2223 qw(-- debian/rules debian/control);
2229 my ($clogp,$target) = @_;
2231 # Quilt patchification algorithm
2233 # We search backwards through the history of the main tree's HEAD
2234 # (T) looking for a start commit S whose tree object is identical
2235 # to to the patch tip tree (ie the tree corresponding to the
2236 # current dpkg-committed patch series). For these purposes
2237 # `identical' disregards anything in debian/ - this wrinkle is
2238 # necessary because dpkg-source treates debian/ specially.
2240 # We can only traverse edges where at most one of the ancestors'
2241 # trees differs (in changes outside in debian/). And we cannot
2242 # handle edges which change .pc/ or debian/patches. To avoid
2243 # going down a rathole we avoid traversing edges which introduce
2244 # debian/rules or debian/control. And we set a limit on the
2245 # number of edges we are willing to look at.
2247 # If we succeed, we walk forwards again. For each traversed edge
2248 # PC (with P parent, C child) (starting with P=S and ending with
2249 # C=T) to we do this:
2251 # - dpkg-source --commit with a patch name and message derived from C
2252 # After traversing PT, we git commit the changes which
2253 # should be contained within debian/patches.
2255 changedir '../fake';
2256 mktree_in_ud_here();
2258 runcmd @git, 'add', '.';
2259 my $oldtiptree=git_write_tree();
2260 changedir '../work';
2262 # The search for the path S..T is breadth-first. We maintain a
2263 # todo list containing search nodes. A search node identifies a
2264 # commit, and looks something like this:
2266 # Commit => $git_commit_id,
2267 # Child => $c, # or undef if P=T
2268 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2269 # Nontrivial => true iff $p..$c has relevant changes
2276 my %considered; # saves being exponential on some weird graphs
2278 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2281 my ($search,$whynot) = @_;
2282 printdebug " search NOT $search->{Commit} $whynot\n";
2283 $search->{Whynot} = $whynot;
2284 push @nots, $search;
2285 no warnings qw(exiting);
2294 my $c = shift @todo;
2295 next if $considered{$c->{Commit}}++;
2297 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2299 printdebug "quiltify investigate $c->{Commit}\n";
2302 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2303 printdebug " search finished hooray!\n";
2308 if ($quilt_mode eq 'nofix') {
2309 fail "quilt fixup required but quilt mode is \`nofix'\n".
2310 "HEAD commit $c->{Commit} differs from tree implied by ".
2311 " debian/patches (tree object $oldtiptree)";
2313 if ($quilt_mode eq 'smash') {
2314 printdebug " search quitting smash\n";
2318 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2319 $not->($c, "has $c_sentinels not $t_sentinels")
2320 if $c_sentinels ne $t_sentinels;
2322 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2323 $commitdata =~ m/\n\n/;
2325 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2326 @parents = map { { Commit => $_, Child => $c } } @parents;
2328 $not->($c, "root commit") if !@parents;
2330 foreach my $p (@parents) {
2331 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2333 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2334 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2336 foreach my $p (@parents) {
2337 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2339 my @cmd= (@git, qw(diff-tree -r --name-only),
2340 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2341 my $patchstackchange = cmdoutput @cmd;
2342 if (length $patchstackchange) {
2343 $patchstackchange =~ s/\n/,/g;
2344 $not->($p, "changed $patchstackchange");
2347 printdebug " search queue P=$p->{Commit} ",
2348 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2354 printdebug "quiltify want to smash\n";
2357 my $x = $_[0]{Commit};
2358 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2361 my $reportnot = sub {
2363 my $s = $abbrev->($notp);
2364 my $c = $notp->{Child};
2365 $s .= "..".$abbrev->($c) if $c;
2366 $s .= ": ".$notp->{Whynot};
2369 if ($quilt_mode eq 'linear') {
2370 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2371 foreach my $notp (@nots) {
2372 print STDERR "$us: ", $reportnot->($notp), "\n";
2374 fail "quilt fixup naive history linearisation failed.\n".
2375 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2376 } elsif ($quilt_mode eq 'smash') {
2377 } elsif ($quilt_mode eq 'auto') {
2378 progress "quilt fixup cannot be linear, smashing...";
2380 die "$quilt_mode ?";
2385 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2387 quiltify_dpkg_commit "auto-$version-$target-$time",
2388 (getfield $clogp, 'Maintainer'),
2389 "Automatically generated patch ($clogp->{Version})\n".
2390 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2394 progress "quiltify linearisation planning successful, executing...";
2396 for (my $p = $sref_S;
2397 my $c = $p->{Child};
2399 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2400 next unless $p->{Nontrivial};
2402 my $cc = $c->{Commit};
2404 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2405 $commitdata =~ m/\n\n/ or die "$c ?";
2408 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2411 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2414 my $patchname = $title;
2415 $patchname =~ s/[.:]$//;
2416 $patchname =~ y/ A-Z/-a-z/;
2417 $patchname =~ y/-a-z0-9_.+=~//cd;
2418 $patchname =~ s/^\W/x-$&/;
2419 $patchname = substr($patchname,0,40);
2422 stat "debian/patches/$patchname$index";
2424 $!==ENOENT or die "$patchname$index $!";
2426 runcmd @git, qw(checkout -q), $cc;
2428 # We use the tip's changelog so that dpkg-source doesn't
2429 # produce complaining messages from dpkg-parsechangelog. None
2430 # of the information dpkg-source gets from the changelog is
2431 # actually relevant - it gets put into the original message
2432 # which dpkg-source provides our stunt editor, and then
2434 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2436 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2437 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2439 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2442 runcmd @git, qw(checkout -q master);
2445 sub build_maybe_quilt_fixup () {
2446 my $format=get_source_format;
2447 return unless madformat $format;
2450 check_for_vendor_patches();
2453 # - honour any existing .pc in case it has any strangeness
2454 # - determine the git commit corresponding to the tip of
2455 # the patch stack (if there is one)
2456 # - if there is such a git commit, convert each subsequent
2457 # git commit into a quilt patch with dpkg-source --commit
2458 # - otherwise convert all the differences in the tree into
2459 # a single git commit
2463 # Our git tree doesn't necessarily contain .pc. (Some versions of
2464 # dgit would include the .pc in the git tree.) If there isn't
2465 # one, we need to generate one by unpacking the patches that we
2468 # We first look for a .pc in the git tree. If there is one, we
2469 # will use it. (This is not the normal case.)
2471 # Otherwise need to regenerate .pc so that dpkg-source --commit
2472 # can work. We do this as follows:
2473 # 1. Collect all relevant .orig from parent directory
2474 # 2. Generate a debian.tar.gz out of
2475 # debian/{patches,rules,source/format}
2476 # 3. Generate a fake .dsc containing just these fields:
2477 # Format Source Version Files
2478 # 4. Extract the fake .dsc
2479 # Now the fake .dsc has a .pc directory.
2480 # (In fact we do this in every case, because in future we will
2481 # want to search for a good base commit for generating patches.)
2483 # Then we can actually do the dpkg-source --commit
2484 # 1. Make a new working tree with the same object
2485 # store as our main tree and check out the main
2487 # 2. Copy .pc from the fake's extraction, if necessary
2488 # 3. Run dpkg-source --commit
2489 # 4. If the result has changes to debian/, then
2490 # - git-add them them
2491 # - git-add .pc if we had a .pc in-tree
2493 # 5. If we had a .pc in-tree, delete it, and git-commit
2494 # 6. Back in the main tree, fast forward to the new HEAD
2496 my $clogp = parsechangelog();
2497 my $headref = git_rev_parse('HEAD');
2502 my $upstreamversion=$version;
2503 $upstreamversion =~ s/-[^-]*$//;
2505 my $fakeversion="$upstreamversion-~~DGITFAKE";
2507 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2508 print $fakedsc <<END or die $!;
2511 Version: $fakeversion
2515 my $dscaddfile=sub {
2518 my $md = new Digest::MD5;
2520 my $fh = new IO::File $b, '<' or die "$b $!";
2525 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2528 foreach my $f (<../../../../*>) { #/){
2529 my $b=$f; $b =~ s{.*/}{};
2530 next unless is_orig_file $b, srcfn $upstreamversion,'';
2531 link $f, $b or die "$b $!";
2535 my @files=qw(debian/source/format debian/rules);
2536 if (stat_exists '../../../debian/patches') {
2537 push @files, 'debian/patches';
2540 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2541 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2543 $dscaddfile->($debtar);
2544 close $fakedsc or die $!;
2546 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2548 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2549 rename $fakexdir, "fake" or die "$fakexdir $!";
2551 mkdir "work" or die $!;
2553 mktree_in_ud_here();
2554 runcmd @git, qw(reset --hard), $headref;
2557 if (stat_exists ".pc") {
2559 progress "Tree already contains .pc - will use it then delete it.";
2562 rename '../fake/.pc','.pc' or die $!;
2565 quiltify($clogp,$headref);
2567 if (!open P, '>>', ".pc/applied-patches") {
2568 $!==&ENOENT or die $!;
2573 commit_quilty_patch();
2575 if ($mustdeletepc) {
2576 runcmd @git, qw(rm -rqf .pc);
2577 commit_admin "Commit removal of .pc (quilt series tracking data)";
2580 changedir '../../../..';
2581 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2584 sub quilt_fixup_editor () {
2585 my $descfn = $ENV{$fakeeditorenv};
2586 my $editing = $ARGV[$#ARGV];
2587 open I1, '<', $descfn or die "$descfn: $!";
2588 open I2, '<', $editing or die "$editing: $!";
2589 unlink $editing or die "$editing: $!";
2590 open O, '>', $editing or die "$editing: $!";
2591 while (<I1>) { print O or die $!; } I1->error and die $!;
2594 $copying ||= m/^\-\-\- /;
2595 next unless $copying;
2598 I2->error and die $!;
2603 #----- other building -----
2606 if ($cleanmode eq 'dpkg-source') {
2607 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2608 } elsif ($cleanmode eq 'git') {
2609 runcmd_ordryrun_local @git, qw(clean -xdf);
2610 } elsif ($cleanmode eq 'none') {
2617 badusage "clean takes no additional arguments" if @ARGV;
2622 badusage "-p is not allowed when building" if defined $package;
2625 my $clogp = parsechangelog();
2626 $isuite = getfield $clogp, 'Distribution';
2627 $package = getfield $clogp, 'Source';
2628 $version = getfield $clogp, 'Version';
2629 build_maybe_quilt_fixup();
2632 sub changesopts () {
2633 my @opts =@changesopts[1..$#changesopts];
2634 if (!defined $changes_since_version) {
2635 my @vsns = archive_query('archive_query');
2636 my @quirk = access_quirk();
2637 if ($quirk[0] eq 'backports') {
2638 local $isuite = $quirk[2];
2640 canonicalise_suite();
2641 push @vsns, archive_query('archive_query');
2644 @vsns = map { $_->[0] } @vsns;
2645 @vsns = sort { -version_compare($a, $b) } @vsns;
2646 $changes_since_version = $vsns[0];
2647 progress "changelog will contain changes since $vsns[0]";
2649 $changes_since_version = '_';
2650 progress "package seems new, not specifying -v<version>";
2653 if ($changes_since_version ne '_') {
2654 unshift @opts, "-v$changes_since_version";
2659 sub massage_dbp_args ($) {
2661 return unless $cleanmode =~ m/git|none/;
2662 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2663 my @newcmd = shift @$cmd;
2664 # -nc has the side effect of specifying -b if nothing else specified
2665 push @newcmd, '-nc';
2666 # and some combinations of -S, -b, et al, are errors, rather than
2667 # later simply overriding earlier
2668 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2669 push @newcmd, @$cmd;
2675 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2676 massage_dbp_args \@dbp;
2677 runcmd_ordryrun_local @dbp;
2678 printdone "build successful\n";
2683 my @dbp = @dpkgbuildpackage;
2684 massage_dbp_args \@dbp;
2686 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2687 "--git-builder=@dbp");
2688 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2689 canonicalise_suite();
2690 push @cmd, "--git-debian-branch=".lbranch();
2692 push @cmd, changesopts();
2693 runcmd_ordryrun_local @cmd, @ARGV;
2694 printdone "build successful\n";
2699 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2700 $dscfn = dscfn($version);
2701 if ($cleanmode eq 'dpkg-source') {
2702 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2705 my $pwd = must_getcwd();
2706 my $leafdir = basename $pwd;
2708 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2710 runcmd_ordryrun_local qw(sh -ec),
2711 'exec >$1; shift; exec "$@"','x',
2712 "../$sourcechanges",
2713 @dpkggenchanges, qw(-S), changesopts();
2717 sub cmd_build_source {
2718 badusage "build-source takes no additional arguments" if @ARGV;
2720 printdone "source built, results in $dscfn and $sourcechanges";
2726 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2728 stat_exist $dscfn or fail "$dscfn (in parent directory): $!";
2729 stat_exists $sourcechanges
2730 or fail "$sourcechanges (in parent directory): $!";
2731 foreach my $cf (glob $pat) {
2732 next if $cf eq $sourcechanges;
2733 unlink $cf or fail "remove $cf: $!";
2736 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2737 my @changesfiles = glob $pat;
2738 @changesfiles = sort {
2739 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2742 fail "wrong number of different changes files (@changesfiles)"
2743 unless @changesfiles;
2744 runcmd_ordryrun_local @mergechanges, @changesfiles;
2745 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2747 stat_exists $multichanges or fail "$multichanges: $!";
2749 printdone "build successful, results in $multichanges\n" or die $!;
2752 sub cmd_quilt_fixup {
2753 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2754 my $clogp = parsechangelog();
2755 $version = getfield $clogp, 'Version';
2756 $package = getfield $clogp, 'Source';
2757 build_maybe_quilt_fixup();
2760 sub cmd_archive_api_query {
2761 badusage "need only 1 subpath argument" unless @ARGV==1;
2762 my ($subpath) = @ARGV;
2763 my @cmd = archive_api_query_cmd($subpath);
2765 exec @cmd or fail "exec curl: $!\n";
2768 sub cmd_clone_dgit_repos_server {
2769 badusage "need destination argument" unless @ARGV==1;
2770 my ($destdir) = @ARGV;
2771 $package = '_dgit-repos-server';
2772 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2774 exec @cmd or fail "exec git clone: $!\n";
2777 #---------- argument parsing and main program ----------
2780 print "dgit version $our_version\n" or die $!;
2787 if (defined $ENV{'DGIT_SSH'}) {
2788 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2789 } elsif (defined $ENV{'GIT_SSH'}) {
2790 @ssh = ($ENV{'GIT_SSH'});
2794 last unless $ARGV[0] =~ m/^-/;
2798 if (m/^--dry-run$/) {
2801 } elsif (m/^--damp-run$/) {
2804 } elsif (m/^--no-sign$/) {
2807 } elsif (m/^--help$/) {
2809 } elsif (m/^--version$/) {
2811 } elsif (m/^--new$/) {
2814 } elsif (m/^--since-version=([^_]+|_)$/) {
2816 $changes_since_version = $1;
2817 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2818 ($om = $opts_opt_map{$1}) &&
2822 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2823 !$opts_opt_cmdonly{$1} &&
2824 ($om = $opts_opt_map{$1})) {
2827 } elsif (m/^--existing-package=(.*)/s) {
2829 $existing_package = $1;
2830 } elsif (m/^--initiator-tempdir=(.*)/s) {
2831 $initiator_tempdir = $1;
2832 $initiator_tempdir =~ m#^/# or
2833 badusage "--initiator-tempdir must be used specify an".
2834 " absolute, not relative, directory."
2835 } elsif (m/^--distro=(.*)/s) {
2838 } elsif (m/^--build-products-dir=(.*)/s) {
2840 $buildproductsdir = $1;
2841 } elsif (m/^--clean=(dpkg-source|git|none)$/s) {
2844 } elsif (m/^--clean=(.*)$/s) {
2845 badusage "unknown cleaning mode \`$1'";
2846 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2849 } elsif (m/^--quilt=(.*)$/s) {
2850 badusage "unknown quilt fixup mode \`$1'";
2851 } elsif (m/^--ignore-dirty$/s) {
2854 } elsif (m/^--no-quilt-fixup$/s) {
2856 $quilt_mode = 'nocheck';
2857 } elsif (m/^--no-rm-on-error$/s) {
2860 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2862 push @deliberatelies, $&;
2864 badusage "unknown long option \`$_'";
2871 } elsif (s/^-L/-/) {
2874 } elsif (s/^-h/-/) {
2876 } elsif (s/^-D/-/) {
2880 } elsif (s/^-N/-/) {
2883 } elsif (s/^-v([^_]+|_)$//s) {
2885 $changes_since_version = $1;
2888 push @changesopts, $_;
2890 } elsif (s/^-c(.*=.*)//s) {
2892 push @git, '-c', $1;
2893 } elsif (s/^-d(.+)//s) {
2896 } elsif (s/^-C(.+)//s) {
2899 if ($changesfile =~ s#^(.*)/##) {
2900 $buildproductsdir = $1;
2902 } elsif (s/^-k(.+)//s) {
2904 } elsif (m/^-[vdCk]$/) {
2906 "option \`$_' requires an argument (and no space before the argument)";
2907 } elsif (s/^-wn$//s) {
2909 $cleanmode = 'none';
2910 } elsif (s/^-wg$//s) {
2913 } elsif (s/^-wd$//s) {
2915 $cleanmode = 'dpkg-source';
2917 badusage "unknown short option \`$_'";
2924 if ($ENV{$fakeeditorenv}) {
2925 quilt_fixup_editor();
2929 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
2930 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
2931 if $dryrun_level == 1;
2933 print STDERR $helpmsg or die $!;
2936 my $cmd = shift @ARGV;
2939 if (!defined $quilt_mode) {
2940 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
2941 // access_cfg('quilt-mode', 'RETURN-UNDEF')
2943 $quilt_mode =~ m/^($quilt_modes_re)$/
2944 or badcfg "unknown quilt-mode \`$quilt_mode'";
2948 my $fn = ${*::}{"cmd_$cmd"};
2949 $fn or badusage "unknown operation $cmd";