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/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
40 our $our_version = 'UNRELEASED'; ###substituted###
42 our @rpushprotovsn_support = qw(3 2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
60 our $cleanmode = 'dpkg-source';
61 our $changes_since_version;
63 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
64 our $we_are_responder;
65 our $initiator_tempdir;
67 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
69 our $suite_re = '[-+.0-9a-z]+';
72 our (@dget) = qw(dget);
73 our (@curl) = qw(curl -f);
74 our (@dput) = qw(dput);
75 our (@debsign) = qw(debsign);
77 our (@sbuild) = qw(sbuild -A);
79 our (@dgit) = qw(dgit);
80 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
81 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
82 our (@dpkggenchanges) = qw(dpkg-genchanges);
83 our (@mergechanges) = qw(mergechanges -f);
84 our (@changesopts) = ('');
86 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
89 'debsign' => \@debsign,
94 'dpkg-source' => \@dpkgsource,
95 'dpkg-buildpackage' => \@dpkgbuildpackage,
96 'dpkg-genchanges' => \@dpkggenchanges,
97 'ch' => \@changesopts,
98 'mergechanges' => \@mergechanges);
100 our %opts_opt_cmdonly = ('gpg' => 1);
101 our %opts_cfg_insertpos = map {
103 scalar @{ $opts_opt_map{$_} }
104 } keys %opts_opt_map;
106 sub finalise_opts_opts();
112 our $supplementary_message = '';
116 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
119 our $remotename = 'dgit';
120 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
124 sub lbranch () { return "$branchprefix/$csuite"; }
125 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
126 sub lref () { return "refs/heads/".lbranch(); }
127 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
128 sub rrref () { return server_ref($csuite); }
130 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
140 return "${package}_".(stripepoch $vsn).$sfx
145 return srcfn($vsn,".dsc");
154 foreach my $f (@end) {
156 warn "$us: cleanup: $@" if length $@;
160 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
162 sub no_such_package () {
163 print STDERR "$us: package $package does not exist in suite $isuite\n";
169 return "+".rrref().":".lrref();
174 printdebug "CD $newdir\n";
175 chdir $newdir or die "chdir: $newdir: $!";
178 sub deliberately ($) {
180 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
183 sub deliberately_not_fast_forward () {
184 foreach (qw(not-fast-forward fresh-repo)) {
185 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
189 #---------- remote protocol support, common ----------
191 # remote push initiator/responder protocol:
192 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
193 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
194 # < dgit-remote-push-ready <actual-proto-vsn>
196 # > file parsed-changelog
197 # [indicates that output of dpkg-parsechangelog follows]
198 # > data-block NBYTES
199 # > [NBYTES bytes of data (no newline)]
200 # [maybe some more blocks]
212 # [indicates that signed tag is wanted]
213 # < data-block NBYTES
214 # < [NBYTES bytes of data (no newline)]
215 # [maybe some more blocks]
219 # > want signed-dsc-changes
220 # < data-block NBYTES [transfer of signed dsc]
222 # < data-block NBYTES [transfer of signed changes]
230 sub i_child_report () {
231 # Sees if our child has died, and reap it if so. Returns a string
232 # describing how it died if it failed, or undef otherwise.
233 return undef unless $i_child_pid;
234 my $got = waitpid $i_child_pid, WNOHANG;
235 return undef if $got <= 0;
236 die unless $got == $i_child_pid;
237 $i_child_pid = undef;
238 return undef unless $?;
239 return "build host child ".waitstatusmsg();
244 fail "connection lost: $!" if $fh->error;
245 fail "protocol violation; $m not expected";
248 sub badproto_badread ($$) {
250 fail "connection lost: $!" if $!;
251 my $report = i_child_report();
252 fail $report if defined $report;
253 badproto $fh, "eof (reading $wh)";
256 sub protocol_expect (&$) {
257 my ($match, $fh) = @_;
260 defined && chomp or badproto_badread $fh, "protocol message";
268 badproto $fh, "\`$_'";
271 sub protocol_send_file ($$) {
272 my ($fh, $ourfn) = @_;
273 open PF, "<", $ourfn or die "$ourfn: $!";
276 my $got = read PF, $d, 65536;
277 die "$ourfn: $!" unless defined $got;
279 print $fh "data-block ".length($d)."\n" or die $!;
280 print $fh $d or die $!;
282 PF->error and die "$ourfn $!";
283 print $fh "data-end\n" or die $!;
287 sub protocol_read_bytes ($$) {
288 my ($fh, $nbytes) = @_;
289 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
291 my $got = read $fh, $d, $nbytes;
292 $got==$nbytes or badproto_badread $fh, "data block";
296 sub protocol_receive_file ($$) {
297 my ($fh, $ourfn) = @_;
298 printdebug "() $ourfn\n";
299 open PF, ">", $ourfn or die "$ourfn: $!";
301 my ($y,$l) = protocol_expect {
302 m/^data-block (.*)$/ ? (1,$1) :
303 m/^data-end$/ ? (0,) :
307 my $d = protocol_read_bytes $fh, $l;
308 print PF $d or die $!;
313 #---------- remote protocol support, responder ----------
315 sub responder_send_command ($) {
317 return unless $we_are_responder;
318 # called even without $we_are_responder
319 printdebug ">> $command\n";
320 print PO $command, "\n" or die $!;
323 sub responder_send_file ($$) {
324 my ($keyword, $ourfn) = @_;
325 return unless $we_are_responder;
326 printdebug "]] $keyword $ourfn\n";
327 responder_send_command "file $keyword";
328 protocol_send_file \*PO, $ourfn;
331 sub responder_receive_files ($@) {
332 my ($keyword, @ourfns) = @_;
333 die unless $we_are_responder;
334 printdebug "[[ $keyword @ourfns\n";
335 responder_send_command "want $keyword";
336 foreach my $fn (@ourfns) {
337 protocol_receive_file \*PI, $fn;
340 protocol_expect { m/^files-end$/ } \*PI;
343 #---------- remote protocol support, initiator ----------
345 sub initiator_expect (&) {
347 protocol_expect { &$match } \*RO;
350 #---------- end remote code ----------
353 if ($we_are_responder) {
355 responder_send_command "progress ".length($m) or die $!;
356 print PO $m or die $!;
366 $ua = LWP::UserAgent->new();
370 progress "downloading $what...";
371 my $r = $ua->get(@_) or die $!;
372 return undef if $r->code == 404;
373 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
374 return $r->decoded_content(charset => 'none');
377 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
382 failedcmd @_ if system @_;
385 sub act_local () { return $dryrun_level <= 1; }
386 sub act_scary () { return !$dryrun_level; }
389 if (!$dryrun_level) {
390 progress "dgit ok: @_";
392 progress "would be ok: @_ (but dry run only)";
397 printcmd(\*STDERR,$debugprefix."#",@_);
400 sub runcmd_ordryrun {
408 sub runcmd_ordryrun_local {
417 my ($first_shell, @cmd) = @_;
418 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
421 our $helpmsg = <<END;
423 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
424 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
425 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
426 dgit [dgit-opts] push [dgit-opts] [suite]
427 dgit [dgit-opts] rpush build-host:build-dir ...
428 important dgit options:
429 -k<keyid> sign tag and package with <keyid> instead of default
430 --dry-run -n do not change anything, but go through the motions
431 --damp-run -L like --dry-run but make local changes, without signing
432 --new -N allow introducing a new package
433 --debug -D increase debug level
434 -c<name>=<value> set git config option (used directly by dgit too)
437 our $later_warning_msg = <<END;
438 Perhaps the upload is stuck in incoming. Using the version from git.
442 print STDERR "$us: @_\n", $helpmsg or die $!;
447 @ARGV or badusage "too few arguments";
448 return scalar shift @ARGV;
452 print $helpmsg or die $!;
456 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
458 our %defcfg = ('dgit.default.distro' => 'debian',
459 'dgit.default.username' => '',
460 'dgit.default.archive-query-default-component' => 'main',
461 'dgit.default.ssh' => 'ssh',
462 'dgit.default.archive-query' => 'madison:',
463 'dgit.default.sshpsql-dbname' => 'service=projectb',
464 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
465 'dgit-distro.debian.git-check' => 'url',
466 'dgit-distro.debian.git-check-suffix' => '/info/refs',
467 'dgit-distro.debian.new-private-pushers' => 't',
468 'dgit-distro.debian/push.git-url' => '',
469 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
470 'dgit-distro.debian/push.git-user-force' => 'dgit',
471 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
472 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
473 'dgit-distro.debian/push.git-create' => 'true',
474 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
475 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
476 # 'dgit-distro.debian.archive-query-tls-key',
477 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
478 # ^ this does not work because curl is broken nowadays
479 # Fixing #790093 properly will involve providing providing the key
480 # in some pacagke and maybe updating these paths.
482 # 'dgit-distro.debian.archive-query-tls-curl-args',
483 # '--ca-path=/etc/ssl/ca-debian',
484 # ^ this is a workaround but works (only) on DSA-administered machines
485 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
486 'dgit-distro.debian.git-url-suffix' => '',
487 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
488 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
489 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
490 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
491 'dgit-distro.ubuntu.git-check' => 'false',
492 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
493 'dgit-distro.test-dummy.ssh' => "$td/ssh",
494 'dgit-distro.test-dummy.username' => "alice",
495 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
496 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
497 'dgit-distro.test-dummy.git-url' => "$td/git",
498 'dgit-distro.test-dummy.git-host' => "git",
499 'dgit-distro.test-dummy.git-path' => "$td/git",
500 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
501 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
502 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
503 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
508 sub git_slurp_config () {
509 local ($debuglevel) = $debuglevel-2;
512 my @cmd = (@git, qw(config -z --get-regexp .*));
515 open GITS, "-|", @cmd or failedcmd @cmd;
518 printdebug "=> ", (messagequote $_), "\n";
520 push @{ $gitcfg{$`} }, $'; #';
524 or ($!==0 && $?==256)
528 sub git_get_config ($) {
532 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
538 return undef if $c =~ /RETURN-UNDEF/;
539 my $v = git_get_config($c);
540 return $v if defined $v;
541 my $dv = $defcfg{$c};
542 return $dv if defined $dv;
544 badcfg "need value for one of: @_\n".
545 "$us: distro or suite appears not to be (properly) supported";
548 sub access_basedistro () {
549 if (defined $idistro) {
552 return cfg("dgit-suite.$isuite.distro",
553 "dgit.default.distro");
557 sub access_quirk () {
558 # returns (quirk name, distro to use instead or undef, quirk-specific info)
559 my $basedistro = access_basedistro();
560 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
562 if (defined $backports_quirk) {
563 my $re = $backports_quirk;
564 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
566 $re =~ s/\%/([-0-9a-z_]+)/
567 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
568 if ($isuite =~ m/^$re$/) {
569 return ('backports',"$basedistro-backports",$1);
572 return ('none',undef);
577 sub parse_cfg_bool ($$$) {
578 my ($what,$def,$v) = @_;
581 $v =~ m/^[ty1]/ ? 1 :
582 $v =~ m/^[fn0]/ ? 0 :
583 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
586 sub access_forpush_config () {
587 my $d = access_basedistro();
591 parse_cfg_bool('new-private-pushers', 0,
592 cfg("dgit-distro.$d.new-private-pushers",
595 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
598 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
599 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
600 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
601 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
604 sub access_forpush () {
605 $access_forpush //= access_forpush_config();
606 return $access_forpush;
610 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
611 badcfg "pushing but distro is configured readonly"
612 if access_forpush_config() eq '0';
614 $supplementary_message = <<'END' unless $we_are_responder;
615 Push failed, before we got started.
616 You can retry the push, after fixing the problem, if you like.
618 finalise_opts_opts();
622 finalise_opts_opts();
625 sub supplementary_message ($) {
627 if (!$we_are_responder) {
628 $supplementary_message = $msg;
630 } elsif ($protovsn >= 3) {
631 responder_send_command "supplementary-message ".length($msg)
633 print PO $msg or die $!;
637 sub access_distros () {
638 # Returns list of distros to try, in order
641 # 0. `instead of' distro name(s) we have been pointed to
642 # 1. the access_quirk distro, if any
643 # 2a. the user's specified distro, or failing that } basedistro
644 # 2b. the distro calculated from the suite }
645 my @l = access_basedistro();
647 my (undef,$quirkdistro) = access_quirk();
648 unshift @l, $quirkdistro;
649 unshift @l, $instead_distro;
650 @l = grep { defined } @l;
652 if (access_forpush()) {
653 @l = map { ("$_/push", $_) } @l;
658 sub access_cfg_cfgs (@) {
661 # The nesting of these loops determines the search order. We put
662 # the key loop on the outside so that we search all the distros
663 # for each key, before going on to the next key. That means that
664 # if access_cfg is called with a more specific, and then a less
665 # specific, key, an earlier distro can override the less specific
666 # without necessarily overriding any more specific keys. (If the
667 # distro wants to override the more specific keys it can simply do
668 # so; whereas if we did the loop the other way around, it would be
669 # impossible to for an earlier distro to override a less specific
670 # key but not the more specific ones without restating the unknown
671 # values of the more specific keys.
674 # We have to deal with RETURN-UNDEF specially, so that we don't
675 # terminate the search prematurely.
677 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
680 foreach my $d (access_distros()) {
681 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
683 push @cfgs, map { "dgit.default.$_" } @realkeys;
690 my (@cfgs) = access_cfg_cfgs(@keys);
691 my $value = cfg(@cfgs);
695 sub string_to_ssh ($) {
697 if ($spec =~ m/\s/) {
698 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
704 sub access_cfg_ssh () {
705 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
706 if (!defined $gitssh) {
709 return string_to_ssh $gitssh;
713 sub access_runeinfo ($) {
715 return ": dgit ".access_basedistro()." $info ;";
718 sub access_someuserhost ($) {
720 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
721 defined($user) && length($user) or
722 $user = access_cfg("$some-user",'username');
723 my $host = access_cfg("$some-host");
724 return length($user) ? "$user\@$host" : $host;
727 sub access_gituserhost () {
728 return access_someuserhost('git');
731 sub access_giturl (;$) {
733 my $url = access_cfg('git-url','RETURN-UNDEF');
736 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
737 return undef unless defined $proto;
740 access_gituserhost().
741 access_cfg('git-path');
743 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
746 return "$url/$package$suffix";
749 sub parsecontrolfh ($$;$) {
750 my ($fh, $desc, $allowsigned) = @_;
751 our $dpkgcontrolhash_noissigned;
754 my %opts = ('name' => $desc);
755 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
756 $c = Dpkg::Control::Hash->new(%opts);
757 $c->parse($fh,$desc) or die "parsing of $desc failed";
758 last if $allowsigned;
759 last if $dpkgcontrolhash_noissigned;
760 my $issigned= $c->get_option('is_pgp_signed');
761 if (!defined $issigned) {
762 $dpkgcontrolhash_noissigned= 1;
763 seek $fh, 0,0 or die "seek $desc: $!";
764 } elsif ($issigned) {
765 fail "control file $desc is (already) PGP-signed. ".
766 " Note that dgit push needs to modify the .dsc and then".
767 " do the signature itself";
776 my ($file, $desc) = @_;
777 my $fh = new IO::Handle;
778 open $fh, '<', $file or die "$file: $!";
779 my $c = parsecontrolfh($fh,$desc);
780 $fh->error and die $!;
786 my ($dctrl,$field) = @_;
787 my $v = $dctrl->{$field};
788 return $v if defined $v;
789 fail "missing field $field in ".$v->get_option('name');
793 my $c = Dpkg::Control::Hash->new();
794 my $p = new IO::Handle;
795 my @cmd = (qw(dpkg-parsechangelog), @_);
796 open $p, '-|', @cmd or die $!;
798 $?=0; $!=0; close $p or failedcmd @cmd;
804 defined $d or fail "getcwd failed: $!";
810 sub archive_query ($) {
812 my $query = access_cfg('archive-query','RETURN-UNDEF');
813 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
816 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
819 sub pool_dsc_subpath ($$) {
820 my ($vsn,$component) = @_; # $package is implict arg
821 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
822 return "/pool/$component/$prefix/$package/".dscfn($vsn);
825 #---------- `ftpmasterapi' archive query method (nascent) ----------
827 sub archive_api_query_cmd ($) {
829 my @cmd = qw(curl -sS);
830 my $url = access_cfg('archive-query-url');
831 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
833 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
834 foreach my $key (split /\:/, $keys) {
835 $key =~ s/\%HOST\%/$host/g;
837 fail "for $url: stat $key: $!" unless $!==ENOENT;
840 fail "config requested specific TLS key but do not know".
841 " how to get curl to use exactly that EE key ($key)";
842 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
843 # # Sadly the above line does not work because of changes
844 # # to gnutls. The real fix for #790093 may involve
845 # # new curl options.
848 # Fixing #790093 properly will involve providing a value
849 # for this on clients.
850 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
851 push @cmd, split / /, $kargs if defined $kargs;
853 push @cmd, $url.$subpath;
859 my ($data, $subpath) = @_;
860 badcfg "ftpmasterapi archive query method takes no data part"
862 my @cmd = archive_api_query_cmd($subpath);
863 my $json = cmdoutput @cmd;
864 return decode_json($json);
867 sub canonicalise_suite_ftpmasterapi () {
868 my ($proto,$data) = @_;
869 my $suites = api_query($data, 'suites');
871 foreach my $entry (@$suites) {
873 my $v = $entry->{$_};
874 defined $v && $v eq $isuite;
876 push @matched, $entry;
878 fail "unknown suite $isuite" unless @matched;
881 @matched==1 or die "multiple matches for suite $isuite\n";
882 $cn = "$matched[0]{codename}";
883 defined $cn or die "suite $isuite info has no codename\n";
884 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
886 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
891 sub archive_query_ftpmasterapi () {
892 my ($proto,$data) = @_;
893 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
895 my $digester = Digest::SHA->new(256);
896 foreach my $entry (@$info) {
898 my $vsn = "$entry->{version}";
899 my ($ok,$msg) = version_check $vsn;
900 die "bad version: $msg\n" unless $ok;
901 my $component = "$entry->{component}";
902 $component =~ m/^$component_re$/ or die "bad component";
903 my $filename = "$entry->{filename}";
904 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
905 or die "bad filename";
906 my $sha256sum = "$entry->{sha256sum}";
907 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
908 push @rows, [ $vsn, "/pool/$component/$filename",
909 $digester, $sha256sum ];
911 die "bad ftpmaster api response: $@\n".Dumper($entry)
914 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
918 #---------- `madison' archive query method ----------
920 sub archive_query_madison {
921 return map { [ @$_[0..1] ] } madison_get_parse(@_);
924 sub madison_get_parse {
925 my ($proto,$data) = @_;
926 die unless $proto eq 'madison';
928 $data= access_cfg('madison-distro','RETURN-UNDEF');
929 $data //= access_basedistro();
931 $rmad{$proto,$data,$package} ||= cmdoutput
932 qw(rmadison -asource),"-s$isuite","-u$data",$package;
933 my $rmad = $rmad{$proto,$data,$package};
936 foreach my $l (split /\n/, $rmad) {
937 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
938 \s*( [^ \t|]+ )\s* \|
939 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
940 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
941 $1 eq $package or die "$rmad $package ?";
948 $component = access_cfg('archive-query-default-component');
950 $5 eq 'source' or die "$rmad ?";
951 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
953 return sort { -version_compare($a->[0],$b->[0]); } @out;
956 sub canonicalise_suite_madison {
957 # madison canonicalises for us
958 my @r = madison_get_parse(@_);
960 "unable to canonicalise suite using package $package".
961 " which does not appear to exist in suite $isuite;".
962 " --existing-package may help";
966 #---------- `sshpsql' archive query method ----------
969 my ($data,$runeinfo,$sql) = @_;
971 $data= access_someuserhost('sshpsql').':'.
972 access_cfg('sshpsql-dbname');
974 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
975 my ($userhost,$dbname) = ($`,$'); #';
977 my @cmd = (access_cfg_ssh, $userhost,
978 access_runeinfo("ssh-psql $runeinfo").
979 " export LC_MESSAGES=C; export LC_CTYPE=C;".
980 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
982 open P, "-|", @cmd or die $!;
985 printdebug("$debugprefix>|$_|\n");
988 $!=0; $?=0; close P or failedcmd @cmd;
990 my $nrows = pop @rows;
991 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
992 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
993 @rows = map { [ split /\|/, $_ ] } @rows;
994 my $ncols = scalar @{ shift @rows };
995 die if grep { scalar @$_ != $ncols } @rows;
999 sub sql_injection_check {
1000 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1003 sub archive_query_sshpsql ($$) {
1004 my ($proto,$data) = @_;
1005 sql_injection_check $isuite, $package;
1006 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1007 SELECT source.version, component.name, files.filename, files.sha256sum
1009 JOIN src_associations ON source.id = src_associations.source
1010 JOIN suite ON suite.id = src_associations.suite
1011 JOIN dsc_files ON dsc_files.source = source.id
1012 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1013 JOIN component ON component.id = files_archive_map.component_id
1014 JOIN files ON files.id = dsc_files.file
1015 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1016 AND source.source='$package'
1017 AND files.filename LIKE '%.dsc';
1019 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1020 my $digester = Digest::SHA->new(256);
1022 my ($vsn,$component,$filename,$sha256sum) = @$_;
1023 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1028 sub canonicalise_suite_sshpsql ($$) {
1029 my ($proto,$data) = @_;
1030 sql_injection_check $isuite;
1031 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1032 SELECT suite.codename
1033 FROM suite where suite_name='$isuite' or codename='$isuite';
1035 @rows = map { $_->[0] } @rows;
1036 fail "unknown suite $isuite" unless @rows;
1037 die "ambiguous $isuite: @rows ?" if @rows>1;
1041 #---------- `dummycat' archive query method ----------
1043 sub canonicalise_suite_dummycat ($$) {
1044 my ($proto,$data) = @_;
1045 my $dpath = "$data/suite.$isuite";
1046 if (!open C, "<", $dpath) {
1047 $!==ENOENT or die "$dpath: $!";
1048 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1052 chomp or die "$dpath: $!";
1054 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1058 sub archive_query_dummycat ($$) {
1059 my ($proto,$data) = @_;
1060 canonicalise_suite();
1061 my $dpath = "$data/package.$csuite.$package";
1062 if (!open C, "<", $dpath) {
1063 $!==ENOENT or die "$dpath: $!";
1064 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1072 printdebug "dummycat query $csuite $package $dpath | $_\n";
1073 my @row = split /\s+/, $_;
1074 @row==2 or die "$dpath: $_ ?";
1077 C->error and die "$dpath: $!";
1079 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1082 #---------- archive query entrypoints and rest of program ----------
1084 sub canonicalise_suite () {
1085 return if defined $csuite;
1086 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1087 $csuite = archive_query('canonicalise_suite');
1088 if ($isuite ne $csuite) {
1089 progress "canonical suite name for $isuite is $csuite";
1093 sub get_archive_dsc () {
1094 canonicalise_suite();
1095 my @vsns = archive_query('archive_query');
1096 foreach my $vinfo (@vsns) {
1097 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1098 $dscurl = access_cfg('mirror').$subpath;
1099 $dscdata = url_get($dscurl);
1101 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1106 $digester->add($dscdata);
1107 my $got = $digester->hexdigest();
1109 fail "$dscurl has hash $got but".
1110 " archive told us to expect $digest";
1112 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1113 printdebug Dumper($dscdata) if $debuglevel>1;
1114 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1115 printdebug Dumper($dsc) if $debuglevel>1;
1116 my $fmt = getfield $dsc, 'Format';
1117 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1118 $dsc_checked = !!$digester;
1124 sub check_for_git ();
1125 sub check_for_git () {
1127 my $how = access_cfg('git-check');
1128 if ($how eq 'ssh-cmd') {
1130 (access_cfg_ssh, access_gituserhost(),
1131 access_runeinfo("git-check $package").
1132 " set -e; cd ".access_cfg('git-path').";".
1133 " if test -d $package.git; then echo 1; else echo 0; fi");
1134 my $r= cmdoutput @cmd;
1135 if ($r =~ m/^divert (\w+)$/) {
1137 my ($usedistro,) = access_distros();
1138 # NB that if we are pushing, $usedistro will be $distro/push
1139 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1140 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1141 progress "diverting to $divert (using config for $instead_distro)";
1142 return check_for_git();
1144 failedcmd @cmd unless $r =~ m/^[01]$/;
1146 } elsif ($how eq 'url') {
1147 my $prefix = access_cfg('git-check-url','git-url');
1148 my $suffix = access_cfg('git-check-suffix','git-suffix',
1149 'RETURN-UNDEF') // '.git';
1150 my $url = "$prefix/$package$suffix";
1151 my @cmd = (qw(curl -sS -I), $url);
1152 my $result = cmdoutput @cmd;
1153 $result =~ m/^\S+ (404|200) /s or
1154 fail "unexpected results from git check query - ".
1155 Dumper($prefix, $result);
1157 if ($code eq '404') {
1159 } elsif ($code eq '200') {
1164 } elsif ($how eq 'true') {
1166 } elsif ($how eq 'false') {
1169 badcfg "unknown git-check \`$how'";
1173 sub create_remote_git_repo () {
1174 my $how = access_cfg('git-create');
1175 if ($how eq 'ssh-cmd') {
1177 (access_cfg_ssh, access_gituserhost(),
1178 access_runeinfo("git-create $package").
1179 "set -e; cd ".access_cfg('git-path').";".
1180 " cp -a _template $package.git");
1181 } elsif ($how eq 'true') {
1184 badcfg "unknown git-create \`$how'";
1188 our ($dsc_hash,$lastpush_hash);
1190 our $ud = '.git/dgit/unpack';
1195 mkdir $ud or die $!;
1198 sub mktree_in_ud_here () {
1199 runcmd qw(git init -q);
1200 rmtree('.git/objects');
1201 symlink '../../../../objects','.git/objects' or die $!;
1204 sub git_write_tree () {
1205 my $tree = cmdoutput @git, qw(write-tree);
1206 $tree =~ m/^\w+$/ or die "$tree ?";
1210 sub mktree_in_ud_from_only_subdir () {
1211 # changes into the subdir
1213 die unless @dirs==1;
1214 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1218 my @gitscmd = qw(find -name .git -prune -print0);
1219 debugcmd "|",@gitscmd;
1220 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1225 print STDERR "$us: warning: removing from source package: ",
1226 (messagequote $_), "\n";
1230 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1232 mktree_in_ud_here();
1233 my $format=get_source_format();
1234 if (madformat($format)) {
1237 runcmd @git, qw(add -Af);
1238 my $tree=git_write_tree();
1239 return ($tree,$dir);
1242 sub dsc_files_info () {
1243 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1244 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1245 ['Files', 'Digest::MD5', 'new()']) {
1246 my ($fname, $module, $method) = @$csumi;
1247 my $field = $dsc->{$fname};
1248 next unless defined $field;
1249 eval "use $module; 1;" or die $@;
1251 foreach (split /\n/, $field) {
1253 m/^(\w+) (\d+) (\S+)$/ or
1254 fail "could not parse .dsc $fname line \`$_'";
1255 my $digester = eval "$module"."->$method;" or die $@;
1260 Digester => $digester,
1265 fail "missing any supported Checksums-* or Files field in ".
1266 $dsc->get_option('name');
1270 map { $_->{Filename} } dsc_files_info();
1273 sub is_orig_file ($;$) {
1276 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1277 defined $base or return 1;
1281 sub make_commit ($) {
1283 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1286 sub clogp_authline ($) {
1288 my $author = getfield $clogp, 'Maintainer';
1289 $author =~ s#,.*##ms;
1290 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1291 my $authline = "$author $date";
1292 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1293 fail "unexpected commit author line format \`$authline'".
1294 " (was generated from changelog Maintainer field)";
1298 sub vendor_patches_distro ($$) {
1299 my ($checkdistro, $what) = @_;
1300 return unless defined $checkdistro;
1302 my $series = "debian/patches/\L$checkdistro\E.series";
1303 printdebug "checking for vendor-specific $series ($what)\n";
1305 if (!open SERIES, "<", $series) {
1306 die "$series $!" unless $!==ENOENT;
1315 Unfortunately, this source package uses a feature of dpkg-source where
1316 the same source package unpacks to different source code on different
1317 distros. dgit cannot safely operate on such packages on affected
1318 distros, because the meaning of source packages is not stable.
1320 Please ask the distro/maintainer to remove the distro-specific series
1321 files and use a different technique (if necessary, uploading actually
1322 different packages, if different distros are supposed to have
1326 fail "Found active distro-specific series file for".
1327 " $checkdistro ($what): $series, cannot continue";
1329 die "$series $!" if SERIES->error;
1333 sub check_for_vendor_patches () {
1334 # This dpkg-source feature doesn't seem to be documented anywhere!
1335 # But it can be found in the changelog (reformatted):
1337 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1338 # Author: Raphael Hertzog <hertzog@debian.org>
1339 # Date: Sun Oct 3 09:36:48 2010 +0200
1341 # dpkg-source: correctly create .pc/.quilt_series with alternate
1344 # If you have debian/patches/ubuntu.series and you were
1345 # unpacking the source package on ubuntu, quilt was still
1346 # directed to debian/patches/series instead of
1347 # debian/patches/ubuntu.series.
1349 # debian/changelog | 3 +++
1350 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1351 # 2 files changed, 6 insertions(+), 1 deletion(-)
1354 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1355 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1356 "Dpkg::Vendor \`current vendor'");
1357 vendor_patches_distro(access_basedistro(),
1358 "distro being accessed");
1361 sub generate_commit_from_dsc () {
1365 foreach my $fi (dsc_files_info()) {
1366 my $f = $fi->{Filename};
1367 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1369 link "../../../$f", $f
1373 complete_file_from_dsc('.', $fi);
1375 if (is_orig_file($f)) {
1376 link $f, "../../../../$f"
1382 my $dscfn = "$package.dsc";
1384 open D, ">", $dscfn or die "$dscfn: $!";
1385 print D $dscdata or die "$dscfn: $!";
1386 close D or die "$dscfn: $!";
1387 my @cmd = qw(dpkg-source);
1388 push @cmd, '--no-check' if $dsc_checked;
1389 push @cmd, qw(-x --), $dscfn;
1392 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1393 check_for_vendor_patches() if madformat($dsc->{format});
1394 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1395 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1396 my $authline = clogp_authline $clogp;
1397 my $changes = getfield $clogp, 'Changes';
1398 open C, ">../commit.tmp" or die $!;
1399 print C <<END or die $!;
1406 # imported from the archive
1409 my $outputhash = make_commit qw(../commit.tmp);
1410 my $cversion = getfield $clogp, 'Version';
1411 progress "synthesised git commit from .dsc $cversion";
1412 if ($lastpush_hash) {
1413 runcmd @git, qw(reset --hard), $lastpush_hash;
1414 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1415 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1416 my $oversion = getfield $oldclogp, 'Version';
1418 version_compare($oversion, $cversion);
1420 # git upload/ is earlier vsn than archive, use archive
1421 open C, ">../commit2.tmp" or die $!;
1422 print C <<END or die $!;
1424 parent $lastpush_hash
1429 Record $package ($cversion) in archive suite $csuite
1431 $outputhash = make_commit qw(../commit2.tmp);
1432 } elsif ($vcmp > 0) {
1433 print STDERR <<END or die $!;
1435 Version actually in archive: $cversion (older)
1436 Last allegedly pushed/uploaded: $oversion (newer or same)
1439 $outputhash = $lastpush_hash;
1441 $outputhash = $lastpush_hash;
1444 changedir '../../../..';
1445 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1446 'DGIT_ARCHIVE', $outputhash;
1447 cmdoutput @git, qw(log -n2), $outputhash;
1448 # ... gives git a chance to complain if our commit is malformed
1453 sub complete_file_from_dsc ($$) {
1454 our ($dstdir, $fi) = @_;
1455 # Ensures that we have, in $dir, the file $fi, with the correct
1456 # contents. (Downloading it from alongside $dscurl if necessary.)
1458 my $f = $fi->{Filename};
1459 my $tf = "$dstdir/$f";
1462 if (stat_exists $tf) {
1463 progress "using existing $f";
1466 $furl =~ s{/[^/]+$}{};
1468 die "$f ?" unless $f =~ m/^${package}_/;
1469 die "$f ?" if $f =~ m#/#;
1470 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1471 next if !act_local();
1475 open F, "<", "$tf" or die "$tf: $!";
1476 $fi->{Digester}->reset();
1477 $fi->{Digester}->addfile(*F);
1478 F->error and die $!;
1479 my $got = $fi->{Digester}->hexdigest();
1480 $got eq $fi->{Hash} or
1481 fail "file $f has hash $got but .dsc".
1482 " demands hash $fi->{Hash} ".
1483 ($downloaded ? "(got wrong file from archive!)"
1484 : "(perhaps you should delete this file?)");
1487 sub ensure_we_have_orig () {
1488 foreach my $fi (dsc_files_info()) {
1489 my $f = $fi->{Filename};
1490 next unless is_orig_file($f);
1491 complete_file_from_dsc('..', $fi);
1495 sub git_fetch_us () {
1496 my @specs = (fetchspec());
1498 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1500 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1503 my $tagpat = debiantag('*',access_basedistro);
1505 git_for_each_ref("refs/tags/".$tagpat, sub {
1506 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1507 printdebug "currently $fullrefname=$objid\n";
1508 $here{$fullrefname} = $objid;
1510 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1511 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1512 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1513 printdebug "offered $lref=$objid\n";
1514 if (!defined $here{$lref}) {
1515 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1516 runcmd_ordryrun_local @upd;
1517 } elsif ($here{$lref} eq $objid) {
1520 "Not updateting $lref from $here{$lref} to $objid.\n";
1525 sub fetch_from_archive () {
1526 # ensures that lrref() is what is actually in the archive,
1527 # one way or another
1531 foreach my $field (@ourdscfield) {
1532 $dsc_hash = $dsc->{$field};
1533 last if defined $dsc_hash;
1535 if (defined $dsc_hash) {
1536 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1538 progress "last upload to archive specified git hash";
1540 progress "last upload to archive has NO git hash";
1543 progress "no version available from the archive";
1546 $lastpush_hash = git_get_ref(lrref());
1547 printdebug "previous reference hash=$lastpush_hash\n";
1549 if (defined $dsc_hash) {
1550 fail "missing remote git history even though dsc has hash -".
1551 " could not find ref ".lrref().
1552 " (should have been fetched from ".access_giturl()."#".rrref().")"
1553 unless $lastpush_hash;
1555 ensure_we_have_orig();
1556 if ($dsc_hash eq $lastpush_hash) {
1557 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1558 print STDERR <<END or die $!;
1560 Git commit in archive is behind the last version allegedly pushed/uploaded.
1561 Commit referred to by archive: $dsc_hash
1562 Last allegedly pushed/uploaded: $lastpush_hash
1565 $hash = $lastpush_hash;
1567 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1568 "descendant of archive's .dsc hash ($dsc_hash)";
1571 $hash = generate_commit_from_dsc();
1572 } elsif ($lastpush_hash) {
1573 # only in git, not in the archive yet
1574 $hash = $lastpush_hash;
1575 print STDERR <<END or die $!;
1577 Package not found in the archive, but has allegedly been pushed using dgit.
1581 printdebug "nothing found!\n";
1582 if (defined $skew_warning_vsn) {
1583 print STDERR <<END or die $!;
1585 Warning: relevant archive skew detected.
1586 Archive allegedly contains $skew_warning_vsn
1587 But we were not able to obtain any version from the archive or git.
1593 printdebug "current hash=$hash\n";
1594 if ($lastpush_hash) {
1595 fail "not fast forward on last upload branch!".
1596 " (archive's version left in DGIT_ARCHIVE)"
1597 unless is_fast_fwd($lastpush_hash, $hash);
1599 if (defined $skew_warning_vsn) {
1601 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1602 my $clogf = ".git/dgit/changelog.tmp";
1603 runcmd shell_cmd "exec >$clogf",
1604 @git, qw(cat-file blob), "$hash:debian/changelog";
1605 my $gotclogp = parsechangelog("-l$clogf");
1606 my $got_vsn = getfield $gotclogp, 'Version';
1607 printdebug "SKEW CHECK GOT $got_vsn\n";
1608 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1609 print STDERR <<END or die $!;
1611 Warning: archive skew detected. Using the available version:
1612 Archive allegedly contains $skew_warning_vsn
1613 We were able to obtain only $got_vsn
1618 if ($lastpush_hash ne $hash) {
1619 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1623 dryrun_report @upd_cmd;
1629 sub set_local_git_config ($$) {
1631 runcmd @git, qw(config), $k, $v;
1634 sub setup_mergechangelogs () {
1635 my $driver = 'dpkg-mergechangelogs';
1636 my $cb = "merge.$driver";
1637 my $attrs = '.git/info/attributes';
1638 ensuredir '.git/info';
1640 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1641 if (!open ATTRS, "<", $attrs) {
1642 $!==ENOENT or die "$attrs: $!";
1646 next if m{^debian/changelog\s};
1647 print NATTRS $_, "\n" or die $!;
1649 ATTRS->error and die $!;
1652 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1655 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1656 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1658 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1663 canonicalise_suite();
1664 badusage "dry run makes no sense with clone" unless act_local();
1665 my $hasgit = check_for_git();
1666 mkdir $dstdir or die "$dstdir $!";
1668 runcmd @git, qw(init -q);
1669 my $giturl = access_giturl(1);
1670 if (defined $giturl) {
1671 set_local_git_config "remote.$remotename.fetch", fetchspec();
1672 open H, "> .git/HEAD" or die $!;
1673 print H "ref: ".lref()."\n" or die $!;
1675 runcmd @git, qw(remote add), 'origin', $giturl;
1678 progress "fetching existing git history";
1680 runcmd_ordryrun_local @git, qw(fetch origin);
1682 progress "starting new git history";
1684 fetch_from_archive() or no_such_package;
1685 my $vcsgiturl = $dsc->{'Vcs-Git'};
1686 if (length $vcsgiturl) {
1687 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1688 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1690 setup_mergechangelogs();
1691 runcmd @git, qw(reset --hard), lrref();
1692 printdone "ready for work in $dstdir";
1696 if (check_for_git()) {
1699 fetch_from_archive() or no_such_package();
1700 printdone "fetched into ".lrref();
1705 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1707 printdone "fetched to ".lrref()." and merged into HEAD";
1710 sub check_not_dirty () {
1711 return if $ignoredirty;
1712 my @cmd = (@git, qw(diff --quiet HEAD));
1714 $!=0; $?=0; system @cmd;
1715 return if !$! && !$?;
1716 if (!$! && $?==256) {
1717 fail "working tree is dirty (does not match HEAD)";
1723 sub commit_admin ($) {
1726 runcmd_ordryrun_local @git, qw(commit -m), $m;
1729 sub commit_quilty_patch () {
1730 my $output = cmdoutput @git, qw(status --porcelain);
1732 foreach my $l (split /\n/, $output) {
1733 next unless $l =~ m/\S/;
1734 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1738 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1740 progress "nothing quilty to commit, ok.";
1743 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1744 commit_admin "Commit Debian 3.0 (quilt) metadata";
1747 sub get_source_format () {
1748 if (!open F, "debian/source/format") {
1749 die $! unless $!==&ENOENT;
1753 F->error and die $!;
1760 return 0 unless $format eq '3.0 (quilt)';
1761 if ($quilt_mode eq 'nocheck') {
1762 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1765 progress "Format \`$format', checking/updating patch stack";
1769 sub push_parse_changelog ($) {
1772 my $clogp = Dpkg::Control::Hash->new();
1773 $clogp->load($clogpfn) or die;
1775 $package = getfield $clogp, 'Source';
1776 my $cversion = getfield $clogp, 'Version';
1777 my $tag = debiantag($cversion, access_basedistro);
1778 runcmd @git, qw(check-ref-format), $tag;
1780 my $dscfn = dscfn($cversion);
1782 return ($clogp, $cversion, $tag, $dscfn);
1785 sub push_parse_dsc ($$$) {
1786 my ($dscfn,$dscfnwhat, $cversion) = @_;
1787 $dsc = parsecontrol($dscfn,$dscfnwhat);
1788 my $dversion = getfield $dsc, 'Version';
1789 my $dscpackage = getfield $dsc, 'Source';
1790 ($dscpackage eq $package && $dversion eq $cversion) or
1791 fail "$dscfn is for $dscpackage $dversion".
1792 " but debian/changelog is for $package $cversion";
1795 sub push_mktag ($$$$$$$) {
1796 my ($head,$clogp,$tag,
1798 $changesfile,$changesfilewhat,
1801 $dsc->{$ourdscfield[0]} = $head;
1802 $dsc->save("$dscfn.tmp") or die $!;
1804 my $changes = parsecontrol($changesfile,$changesfilewhat);
1805 foreach my $field (qw(Source Distribution Version)) {
1806 $changes->{$field} eq $clogp->{$field} or
1807 fail "changes field $field \`$changes->{$field}'".
1808 " does not match changelog \`$clogp->{$field}'";
1811 my $cversion = getfield $clogp, 'Version';
1812 my $clogsuite = getfield $clogp, 'Distribution';
1814 # We make the git tag by hand because (a) that makes it easier
1815 # to control the "tagger" (b) we can do remote signing
1816 my $authline = clogp_authline $clogp;
1817 my $delibs = join(" ", "",@deliberatelies);
1818 my $declaredistro = access_basedistro();
1819 open TO, '>', $tfn->('.tmp') or die $!;
1820 print TO <<END or die $!;
1826 $package release $cversion for $clogsuite ($csuite) [dgit]
1827 [dgit distro=$declaredistro$delibs]
1829 foreach my $ref (sort keys %previously) {
1830 print TO <<END or die $!;
1831 [dgit previously:$ref=$previously{$ref}]
1837 my $tagobjfn = $tfn->('.tmp');
1839 if (!defined $keyid) {
1840 $keyid = access_cfg('keyid','RETURN-UNDEF');
1842 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1843 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1844 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1845 push @sign_cmd, $tfn->('.tmp');
1846 runcmd_ordryrun @sign_cmd;
1848 $tagobjfn = $tfn->('.signed.tmp');
1849 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1850 $tfn->('.tmp'), $tfn->('.tmp.asc');
1857 sub sign_changes ($) {
1858 my ($changesfile) = @_;
1860 my @debsign_cmd = @debsign;
1861 push @debsign_cmd, "-k$keyid" if defined $keyid;
1862 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1863 push @debsign_cmd, $changesfile;
1864 runcmd_ordryrun @debsign_cmd;
1869 my ($forceflag) = @_;
1870 printdebug "actually entering push\n";
1871 supplementary_message(<<'END');
1872 Push failed, while preparing your push.
1873 You can retry the push, after fixing the problem, if you like.
1877 access_giturl(); # check that success is vaguely likely
1879 my $clogpfn = ".git/dgit/changelog.822.tmp";
1880 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1882 responder_send_file('parsed-changelog', $clogpfn);
1884 my ($clogp, $cversion, $tag, $dscfn) =
1885 push_parse_changelog("$clogpfn");
1887 my $dscpath = "$buildproductsdir/$dscfn";
1888 stat_exists $dscpath or
1889 fail "looked for .dsc $dscfn, but $!;".
1890 " maybe you forgot to build";
1892 responder_send_file('dsc', $dscpath);
1894 push_parse_dsc($dscpath, $dscfn, $cversion);
1896 my $format = getfield $dsc, 'Format';
1897 printdebug "format $format\n";
1898 if (madformat($format)) {
1899 commit_quilty_patch();
1903 progress "checking that $dscfn corresponds to HEAD";
1904 runcmd qw(dpkg-source -x --),
1905 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1906 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1907 check_for_vendor_patches() if madformat($dsc->{format});
1908 changedir '../../../..';
1909 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1910 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1911 debugcmd "+",@diffcmd;
1913 my $r = system @diffcmd;
1916 fail "$dscfn specifies a different tree to your HEAD commit;".
1917 " perhaps you forgot to build".
1918 ($diffopt eq '--exit-code' ? "" :
1919 " (run with -D to see full diff output)");
1924 my $head = git_rev_parse('HEAD');
1925 if (!$changesfile) {
1926 my $multi = "$buildproductsdir/".
1927 "${package}_".(stripepoch $cversion)."_multi.changes";
1928 if (stat_exists "$multi") {
1929 $changesfile = $multi;
1931 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1932 my @cs = glob "$buildproductsdir/$pat";
1933 fail "failed to find unique changes file".
1934 " (looked for $pat in $buildproductsdir, or $multi);".
1935 " perhaps you need to use dgit -C"
1937 ($changesfile) = @cs;
1940 $changesfile = "$buildproductsdir/$changesfile";
1943 responder_send_file('changes',$changesfile);
1944 responder_send_command("param head $head");
1945 responder_send_command("param csuite $csuite");
1947 if (deliberately_not_fast_forward) {
1948 git_for_each_ref(lrfetchrefs, sub {
1949 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1950 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1951 responder_send_command("previously $rrefname=$objid");
1952 $previously{$rrefname} = $objid;
1956 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1959 supplementary_message(<<'END');
1960 Push failed, while signing the tag.
1961 You can retry the push, after fixing the problem, if you like.
1963 # If we manage to sign but fail to record it anywhere, it's fine.
1964 if ($we_are_responder) {
1965 $tagobjfn = $tfn->('.signed.tmp');
1966 responder_receive_files('signed-tag', $tagobjfn);
1969 push_mktag($head,$clogp,$tag,
1971 $changesfile,$changesfile,
1974 supplementary_message(<<'END');
1975 Push failed, *after* signing the tag.
1976 If you want to try again, you should use a new version number.
1979 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1980 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1981 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1983 supplementary_message(<<'END');
1984 Push failed, while updating the remote git repository - see messages above.
1985 If you want to try again, you should use a new version number.
1987 if (!check_for_git()) {
1988 create_remote_git_repo();
1990 runcmd_ordryrun @git, qw(push),access_giturl(),
1991 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1992 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1994 supplementary_message(<<'END');
1995 Push failed, after updating the remote git repository.
1996 If you want to try again, you must use a new version number.
1998 if ($we_are_responder) {
1999 my $dryrunsuffix = act_local() ? "" : ".tmp";
2000 responder_receive_files('signed-dsc-changes',
2001 "$dscpath$dryrunsuffix",
2002 "$changesfile$dryrunsuffix");
2005 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2007 progress "[new .dsc left in $dscpath.tmp]";
2009 sign_changes $changesfile;
2012 supplementary_message(<<'END');
2013 Push failed, while uploading package(s) to the archive server.
2014 You can retry the upload of exactly these same files with dput of:
2016 If that .changes file is broken, you will need to use a new version
2017 number for your next attempt at the upload.
2019 my $host = access_cfg('upload-host','RETURN-UNDEF');
2020 my @hostarg = defined($host) ? ($host,) : ();
2021 runcmd_ordryrun @dput, @hostarg, $changesfile;
2022 printdone "pushed and uploaded $cversion";
2024 supplementary_message('');
2025 responder_send_command("complete");
2032 badusage "-p is not allowed with clone; specify as argument instead"
2033 if defined $package;
2036 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2037 ($package,$isuite) = @ARGV;
2038 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2039 ($package,$dstdir) = @ARGV;
2040 } elsif (@ARGV==3) {
2041 ($package,$isuite,$dstdir) = @ARGV;
2043 badusage "incorrect arguments to dgit clone";
2045 $dstdir ||= "$package";
2047 if (stat_exists $dstdir) {
2048 fail "$dstdir already exists";
2052 if ($rmonerror && !$dryrun_level) {
2053 $cwd_remove= getcwd();
2055 return unless defined $cwd_remove;
2056 if (!chdir "$cwd_remove") {
2057 return if $!==&ENOENT;
2058 die "chdir $cwd_remove: $!";
2060 rmtree($dstdir) or die "remove $dstdir: $!\n";
2065 $cwd_remove = undef;
2068 sub branchsuite () {
2069 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2070 if ($branch =~ m#$lbranch_re#o) {
2077 sub fetchpullargs () {
2079 if (!defined $package) {
2080 my $sourcep = parsecontrol('debian/control','debian/control');
2081 $package = getfield $sourcep, 'Source';
2084 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2086 my $clogp = parsechangelog();
2087 $isuite = getfield $clogp, 'Distribution';
2089 canonicalise_suite();
2090 progress "fetching from suite $csuite";
2091 } elsif (@ARGV==1) {
2093 canonicalise_suite();
2095 badusage "incorrect arguments to dgit fetch or dgit pull";
2114 badusage "-p is not allowed with dgit push" if defined $package;
2116 my $clogp = parsechangelog();
2117 $package = getfield $clogp, 'Source';
2120 } elsif (@ARGV==1) {
2121 ($specsuite) = (@ARGV);
2123 badusage "incorrect arguments to dgit push";
2125 $isuite = getfield $clogp, 'Distribution';
2127 local ($package) = $existing_package; # this is a hack
2128 canonicalise_suite();
2130 canonicalise_suite();
2132 if (defined $specsuite &&
2133 $specsuite ne $isuite &&
2134 $specsuite ne $csuite) {
2135 fail "dgit push: changelog specifies $isuite ($csuite)".
2136 " but command line specifies $specsuite";
2138 supplementary_message(<<'END');
2139 Push failed, while checking state of the archive.
2140 You can retry the push, after fixing the problem, if you like.
2142 if (check_for_git()) {
2146 if (fetch_from_archive()) {
2147 if (is_fast_fwd(lrref(), 'HEAD')) {
2149 } elsif (deliberately_not_fast_forward) {
2152 fail "dgit push: HEAD is not a descendant".
2153 " of the archive's version.\n".
2154 "dgit: To overwrite its contents,".
2155 " use git merge -s ours ".lrref().".\n".
2156 "dgit: To rewind history, if permitted by the archive,".
2157 " use --deliberately-not-fast-forward";
2161 fail "package appears to be new in this suite;".
2162 " if this is intentional, use --new";
2167 #---------- remote commands' implementation ----------
2169 sub cmd_remote_push_build_host {
2170 my ($nrargs) = shift @ARGV;
2171 my (@rargs) = @ARGV[0..$nrargs-1];
2172 @ARGV = @ARGV[$nrargs..$#ARGV];
2174 my ($dir,$vsnwant) = @rargs;
2175 # vsnwant is a comma-separated list; we report which we have
2176 # chosen in our ready response (so other end can tell if they
2179 $we_are_responder = 1;
2180 $us .= " (build host)";
2184 open PI, "<&STDIN" or die $!;
2185 open STDIN, "/dev/null" or die $!;
2186 open PO, ">&STDOUT" or die $!;
2188 open STDOUT, ">&STDERR" or die $!;
2192 ($protovsn) = grep {
2193 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2194 } @rpushprotovsn_support;
2196 fail "build host has dgit rpush protocol versions ".
2197 (join ",", @rpushprotovsn_support).
2198 " but invocation host has $vsnwant"
2199 unless defined $protovsn;
2201 responder_send_command("dgit-remote-push-ready $protovsn");
2207 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2208 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2209 # a good error message)
2215 my $report = i_child_report();
2216 if (defined $report) {
2217 printdebug "($report)\n";
2218 } elsif ($i_child_pid) {
2219 printdebug "(killing build host child $i_child_pid)\n";
2220 kill 15, $i_child_pid;
2222 if (defined $i_tmp && !defined $initiator_tempdir) {
2224 eval { rmtree $i_tmp; };
2228 END { i_cleanup(); }
2231 my ($base,$selector,@args) = @_;
2232 $selector =~ s/\-/_/g;
2233 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2240 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2248 push @rargs, join ",", @rpushprotovsn_support;
2251 push @rdgit, @ropts;
2252 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2254 my @cmd = (@ssh, $host, shellquote @rdgit);
2257 if (defined $initiator_tempdir) {
2258 rmtree $initiator_tempdir;
2259 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2260 $i_tmp = $initiator_tempdir;
2264 $i_child_pid = open2(\*RO, \*RI, @cmd);
2266 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2267 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2268 $supplementary_message = '' unless $protovsn >= 3;
2270 my ($icmd,$iargs) = initiator_expect {
2271 m/^(\S+)(?: (.*))?$/;
2274 i_method "i_resp", $icmd, $iargs;
2278 sub i_resp_progress ($) {
2280 my $msg = protocol_read_bytes \*RO, $rhs;
2284 sub i_resp_supplementary_message ($) {
2286 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2289 sub i_resp_complete {
2290 my $pid = $i_child_pid;
2291 $i_child_pid = undef; # prevents killing some other process with same pid
2292 printdebug "waiting for build host child $pid...\n";
2293 my $got = waitpid $pid, 0;
2294 die $! unless $got == $pid;
2295 die "build host child failed $?" if $?;
2298 printdebug "all done\n";
2302 sub i_resp_file ($) {
2304 my $localname = i_method "i_localname", $keyword;
2305 my $localpath = "$i_tmp/$localname";
2306 stat_exists $localpath and
2307 badproto \*RO, "file $keyword ($localpath) twice";
2308 protocol_receive_file \*RO, $localpath;
2309 i_method "i_file", $keyword;
2314 sub i_resp_param ($) {
2315 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2319 sub i_resp_previously ($) {
2320 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2321 or badproto \*RO, "bad previously spec";
2322 my $r = system qw(git check-ref-format), $1;
2323 die "bad previously ref spec ($r)" if $r;
2324 $previously{$1} = $2;
2329 sub i_resp_want ($) {
2331 die "$keyword ?" if $i_wanted{$keyword}++;
2332 my @localpaths = i_method "i_want", $keyword;
2333 printdebug "[[ $keyword @localpaths\n";
2334 foreach my $localpath (@localpaths) {
2335 protocol_send_file \*RI, $localpath;
2337 print RI "files-end\n" or die $!;
2340 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2342 sub i_localname_parsed_changelog {
2343 return "remote-changelog.822";
2345 sub i_file_parsed_changelog {
2346 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2347 push_parse_changelog "$i_tmp/remote-changelog.822";
2348 die if $i_dscfn =~ m#/|^\W#;
2351 sub i_localname_dsc {
2352 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2357 sub i_localname_changes {
2358 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2359 $i_changesfn = $i_dscfn;
2360 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2361 return $i_changesfn;
2363 sub i_file_changes { }
2365 sub i_want_signed_tag {
2366 printdebug Dumper(\%i_param, $i_dscfn);
2367 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2368 && defined $i_param{'csuite'}
2369 or badproto \*RO, "premature desire for signed-tag";
2370 my $head = $i_param{'head'};
2371 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2373 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2375 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2378 push_mktag $head, $i_clogp, $i_tag,
2380 $i_changesfn, 'remote changes',
2381 sub { "tag$_[0]"; };
2386 sub i_want_signed_dsc_changes {
2387 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2388 sign_changes $i_changesfn;
2389 return ($i_dscfn, $i_changesfn);
2392 #---------- building etc. ----------
2398 #----- `3.0 (quilt)' handling -----
2400 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2402 sub quiltify_dpkg_commit ($$$;$) {
2403 my ($patchname,$author,$msg, $xinfo) = @_;
2407 my $descfn = ".git/dgit/quilt-description.tmp";
2408 open O, '>', $descfn or die "$descfn: $!";
2411 $msg =~ s/^\s+$/ ./mg;
2412 print O <<END or die $!;
2422 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2423 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2424 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2425 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2429 sub quiltify_trees_differ ($$) {
2431 # returns 1 iff the two tree objects differ other than in debian/
2433 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2434 my $diffs= cmdoutput @cmd;
2435 foreach my $f (split /\0/, $diffs) {
2436 next if $f eq 'debian';
2442 sub quiltify_tree_sentinelfiles ($) {
2443 # lists the `sentinel' files present in the tree
2445 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2446 qw(-- debian/rules debian/control);
2452 my ($clogp,$target) = @_;
2454 # Quilt patchification algorithm
2456 # We search backwards through the history of the main tree's HEAD
2457 # (T) looking for a start commit S whose tree object is identical
2458 # to to the patch tip tree (ie the tree corresponding to the
2459 # current dpkg-committed patch series). For these purposes
2460 # `identical' disregards anything in debian/ - this wrinkle is
2461 # necessary because dpkg-source treates debian/ specially.
2463 # We can only traverse edges where at most one of the ancestors'
2464 # trees differs (in changes outside in debian/). And we cannot
2465 # handle edges which change .pc/ or debian/patches. To avoid
2466 # going down a rathole we avoid traversing edges which introduce
2467 # debian/rules or debian/control. And we set a limit on the
2468 # number of edges we are willing to look at.
2470 # If we succeed, we walk forwards again. For each traversed edge
2471 # PC (with P parent, C child) (starting with P=S and ending with
2472 # C=T) to we do this:
2474 # - dpkg-source --commit with a patch name and message derived from C
2475 # After traversing PT, we git commit the changes which
2476 # should be contained within debian/patches.
2478 changedir '../fake';
2479 mktree_in_ud_here();
2481 runcmd @git, 'add', '.';
2482 my $oldtiptree=git_write_tree();
2483 changedir '../work';
2485 # The search for the path S..T is breadth-first. We maintain a
2486 # todo list containing search nodes. A search node identifies a
2487 # commit, and looks something like this:
2489 # Commit => $git_commit_id,
2490 # Child => $c, # or undef if P=T
2491 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2492 # Nontrivial => true iff $p..$c has relevant changes
2499 my %considered; # saves being exponential on some weird graphs
2501 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2504 my ($search,$whynot) = @_;
2505 printdebug " search NOT $search->{Commit} $whynot\n";
2506 $search->{Whynot} = $whynot;
2507 push @nots, $search;
2508 no warnings qw(exiting);
2517 my $c = shift @todo;
2518 next if $considered{$c->{Commit}}++;
2520 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2522 printdebug "quiltify investigate $c->{Commit}\n";
2525 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2526 printdebug " search finished hooray!\n";
2531 if ($quilt_mode eq 'nofix') {
2532 fail "quilt fixup required but quilt mode is \`nofix'\n".
2533 "HEAD commit $c->{Commit} differs from tree implied by ".
2534 " debian/patches (tree object $oldtiptree)";
2536 if ($quilt_mode eq 'smash') {
2537 printdebug " search quitting smash\n";
2541 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2542 $not->($c, "has $c_sentinels not $t_sentinels")
2543 if $c_sentinels ne $t_sentinels;
2545 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2546 $commitdata =~ m/\n\n/;
2548 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2549 @parents = map { { Commit => $_, Child => $c } } @parents;
2551 $not->($c, "root commit") if !@parents;
2553 foreach my $p (@parents) {
2554 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2556 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2557 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2559 foreach my $p (@parents) {
2560 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2562 my @cmd= (@git, qw(diff-tree -r --name-only),
2563 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2564 my $patchstackchange = cmdoutput @cmd;
2565 if (length $patchstackchange) {
2566 $patchstackchange =~ s/\n/,/g;
2567 $not->($p, "changed $patchstackchange");
2570 printdebug " search queue P=$p->{Commit} ",
2571 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2577 printdebug "quiltify want to smash\n";
2580 my $x = $_[0]{Commit};
2581 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2584 my $reportnot = sub {
2586 my $s = $abbrev->($notp);
2587 my $c = $notp->{Child};
2588 $s .= "..".$abbrev->($c) if $c;
2589 $s .= ": ".$notp->{Whynot};
2592 if ($quilt_mode eq 'linear') {
2593 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2594 foreach my $notp (@nots) {
2595 print STDERR "$us: ", $reportnot->($notp), "\n";
2597 fail "quilt fixup naive history linearisation failed.\n".
2598 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2599 } elsif ($quilt_mode eq 'smash') {
2600 } elsif ($quilt_mode eq 'auto') {
2601 progress "quilt fixup cannot be linear, smashing...";
2603 die "$quilt_mode ?";
2608 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2610 quiltify_dpkg_commit "auto-$version-$target-$time",
2611 (getfield $clogp, 'Maintainer'),
2612 "Automatically generated patch ($clogp->{Version})\n".
2613 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2617 progress "quiltify linearisation planning successful, executing...";
2619 for (my $p = $sref_S;
2620 my $c = $p->{Child};
2622 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2623 next unless $p->{Nontrivial};
2625 my $cc = $c->{Commit};
2627 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2628 $commitdata =~ m/\n\n/ or die "$c ?";
2631 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2634 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2637 my $patchname = $title;
2638 $patchname =~ s/[.:]$//;
2639 $patchname =~ y/ A-Z/-a-z/;
2640 $patchname =~ y/-a-z0-9_.+=~//cd;
2641 $patchname =~ s/^\W/x-$&/;
2642 $patchname = substr($patchname,0,40);
2645 stat "debian/patches/$patchname$index";
2647 $!==ENOENT or die "$patchname$index $!";
2649 runcmd @git, qw(checkout -q), $cc;
2651 # We use the tip's changelog so that dpkg-source doesn't
2652 # produce complaining messages from dpkg-parsechangelog. None
2653 # of the information dpkg-source gets from the changelog is
2654 # actually relevant - it gets put into the original message
2655 # which dpkg-source provides our stunt editor, and then
2657 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2659 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2660 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2662 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2665 runcmd @git, qw(checkout -q master);
2668 sub build_maybe_quilt_fixup () {
2669 my $format=get_source_format;
2670 return unless madformat $format;
2673 check_for_vendor_patches();
2676 # - honour any existing .pc in case it has any strangeness
2677 # - determine the git commit corresponding to the tip of
2678 # the patch stack (if there is one)
2679 # - if there is such a git commit, convert each subsequent
2680 # git commit into a quilt patch with dpkg-source --commit
2681 # - otherwise convert all the differences in the tree into
2682 # a single git commit
2686 # Our git tree doesn't necessarily contain .pc. (Some versions of
2687 # dgit would include the .pc in the git tree.) If there isn't
2688 # one, we need to generate one by unpacking the patches that we
2691 # We first look for a .pc in the git tree. If there is one, we
2692 # will use it. (This is not the normal case.)
2694 # Otherwise need to regenerate .pc so that dpkg-source --commit
2695 # can work. We do this as follows:
2696 # 1. Collect all relevant .orig from parent directory
2697 # 2. Generate a debian.tar.gz out of
2698 # debian/{patches,rules,source/format}
2699 # 3. Generate a fake .dsc containing just these fields:
2700 # Format Source Version Files
2701 # 4. Extract the fake .dsc
2702 # Now the fake .dsc has a .pc directory.
2703 # (In fact we do this in every case, because in future we will
2704 # want to search for a good base commit for generating patches.)
2706 # Then we can actually do the dpkg-source --commit
2707 # 1. Make a new working tree with the same object
2708 # store as our main tree and check out the main
2710 # 2. Copy .pc from the fake's extraction, if necessary
2711 # 3. Run dpkg-source --commit
2712 # 4. If the result has changes to debian/, then
2713 # - git-add them them
2714 # - git-add .pc if we had a .pc in-tree
2716 # 5. If we had a .pc in-tree, delete it, and git-commit
2717 # 6. Back in the main tree, fast forward to the new HEAD
2719 my $clogp = parsechangelog();
2720 my $headref = git_rev_parse('HEAD');
2725 my $upstreamversion=$version;
2726 $upstreamversion =~ s/-[^-]*$//;
2728 my $fakeversion="$upstreamversion-~~DGITFAKE";
2730 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2731 print $fakedsc <<END or die $!;
2734 Version: $fakeversion
2738 my $dscaddfile=sub {
2741 my $md = new Digest::MD5;
2743 my $fh = new IO::File $b, '<' or die "$b $!";
2748 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2751 foreach my $f (<../../../../*>) { #/){
2752 my $b=$f; $b =~ s{.*/}{};
2753 next unless is_orig_file $b, srcfn $upstreamversion,'';
2754 link $f, $b or die "$b $!";
2758 my @files=qw(debian/source/format debian/rules);
2759 if (stat_exists '../../../debian/patches') {
2760 push @files, 'debian/patches';
2763 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2764 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2766 $dscaddfile->($debtar);
2767 close $fakedsc or die $!;
2769 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2771 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2772 rename $fakexdir, "fake" or die "$fakexdir $!";
2774 mkdir "work" or die $!;
2776 mktree_in_ud_here();
2777 runcmd @git, qw(reset --hard), $headref;
2780 if (stat_exists ".pc") {
2782 progress "Tree already contains .pc - will use it then delete it.";
2785 rename '../fake/.pc','.pc' or die $!;
2788 quiltify($clogp,$headref);
2790 if (!open P, '>>', ".pc/applied-patches") {
2791 $!==&ENOENT or die $!;
2796 commit_quilty_patch();
2798 if ($mustdeletepc) {
2799 runcmd @git, qw(rm -rqf .pc);
2800 commit_admin "Commit removal of .pc (quilt series tracking data)";
2803 changedir '../../../..';
2804 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2807 sub quilt_fixup_editor () {
2808 my $descfn = $ENV{$fakeeditorenv};
2809 my $editing = $ARGV[$#ARGV];
2810 open I1, '<', $descfn or die "$descfn: $!";
2811 open I2, '<', $editing or die "$editing: $!";
2812 unlink $editing or die "$editing: $!";
2813 open O, '>', $editing or die "$editing: $!";
2814 while (<I1>) { print O or die $!; } I1->error and die $!;
2817 $copying ||= m/^\-\-\- /;
2818 next unless $copying;
2821 I2->error and die $!;
2826 #----- other building -----
2829 if ($cleanmode eq 'dpkg-source') {
2830 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2831 } elsif ($cleanmode eq 'dpkg-source-d') {
2832 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2833 } elsif ($cleanmode eq 'git') {
2834 runcmd_ordryrun_local @git, qw(clean -xdf);
2835 } elsif ($cleanmode eq 'git-ff') {
2836 runcmd_ordryrun_local @git, qw(clean -xdff);
2837 } elsif ($cleanmode eq 'check') {
2838 my $leftovers = cmdoutput @git, qw(clean -xdn);
2839 if (length $leftovers) {
2840 print STDERR $leftovers, "\n" or die $!;
2841 fail "tree contains uncommitted files and --clean=check specified";
2843 } elsif ($cleanmode eq 'none') {
2850 badusage "clean takes no additional arguments" if @ARGV;
2857 badusage "-p is not allowed when building" if defined $package;
2860 my $clogp = parsechangelog();
2861 $isuite = getfield $clogp, 'Distribution';
2862 $package = getfield $clogp, 'Source';
2863 $version = getfield $clogp, 'Version';
2864 build_maybe_quilt_fixup();
2867 sub changesopts () {
2868 my @opts =@changesopts[1..$#changesopts];
2869 if (!defined $changes_since_version) {
2870 my @vsns = archive_query('archive_query');
2871 my @quirk = access_quirk();
2872 if ($quirk[0] eq 'backports') {
2873 local $isuite = $quirk[2];
2875 canonicalise_suite();
2876 push @vsns, archive_query('archive_query');
2879 @vsns = map { $_->[0] } @vsns;
2880 @vsns = sort { -version_compare($a, $b) } @vsns;
2881 $changes_since_version = $vsns[0];
2882 progress "changelog will contain changes since $vsns[0]";
2884 $changes_since_version = '_';
2885 progress "package seems new, not specifying -v<version>";
2888 if ($changes_since_version ne '_') {
2889 unshift @opts, "-v$changes_since_version";
2894 sub massage_dbp_args ($) {
2896 return unless $cleanmode =~ m/git|none/;
2897 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2898 my @newcmd = shift @$cmd;
2899 # -nc has the side effect of specifying -b if nothing else specified
2900 push @newcmd, '-nc';
2901 # and some combinations of -S, -b, et al, are errors, rather than
2902 # later simply overriding earlier
2903 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2904 push @newcmd, @$cmd;
2910 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2911 massage_dbp_args \@dbp;
2912 runcmd_ordryrun_local @dbp;
2913 printdone "build successful\n";
2918 my @dbp = @dpkgbuildpackage;
2919 massage_dbp_args \@dbp;
2921 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2922 "--git-builder=@dbp");
2923 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2924 canonicalise_suite();
2925 push @cmd, "--git-debian-branch=".lbranch();
2927 push @cmd, changesopts();
2928 runcmd_ordryrun_local @cmd, @ARGV;
2929 printdone "build successful\n";
2934 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2935 $dscfn = dscfn($version);
2936 if ($cleanmode eq 'dpkg-source') {
2937 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2939 } elsif ($cleanmode eq 'dpkg-source-d') {
2940 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2943 my $pwd = must_getcwd();
2944 my $leafdir = basename $pwd;
2946 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2948 runcmd_ordryrun_local qw(sh -ec),
2949 'exec >$1; shift; exec "$@"','x',
2950 "../$sourcechanges",
2951 @dpkggenchanges, qw(-S), changesopts();
2955 sub cmd_build_source {
2956 badusage "build-source takes no additional arguments" if @ARGV;
2958 printdone "source built, results in $dscfn and $sourcechanges";
2964 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2966 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2967 stat_exists $sourcechanges
2968 or fail "$sourcechanges (in parent directory): $!";
2969 foreach my $cf (glob $pat) {
2970 next if $cf eq $sourcechanges;
2971 unlink $cf or fail "remove $cf: $!";
2974 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2975 my @changesfiles = glob $pat;
2976 @changesfiles = sort {
2977 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2980 fail "wrong number of different changes files (@changesfiles)"
2981 unless @changesfiles;
2982 runcmd_ordryrun_local @mergechanges, @changesfiles;
2983 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2985 stat_exists $multichanges or fail "$multichanges: $!";
2987 printdone "build successful, results in $multichanges\n" or die $!;
2990 sub cmd_quilt_fixup {
2991 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2992 my $clogp = parsechangelog();
2993 $version = getfield $clogp, 'Version';
2994 $package = getfield $clogp, 'Source';
2995 build_maybe_quilt_fixup();
2998 sub cmd_archive_api_query {
2999 badusage "need only 1 subpath argument" unless @ARGV==1;
3000 my ($subpath) = @ARGV;
3001 my @cmd = archive_api_query_cmd($subpath);
3003 exec @cmd or fail "exec curl: $!\n";
3006 sub cmd_clone_dgit_repos_server {
3007 badusage "need destination argument" unless @ARGV==1;
3008 my ($destdir) = @ARGV;
3009 $package = '_dgit-repos-server';
3010 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3012 exec @cmd or fail "exec git clone: $!\n";
3015 sub cmd_setup_mergechangelogs {
3016 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3017 setup_mergechangelogs();
3020 #---------- argument parsing and main program ----------
3023 print "dgit version $our_version\n" or die $!;
3030 if (defined $ENV{'DGIT_SSH'}) {
3031 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3032 } elsif (defined $ENV{'GIT_SSH'}) {
3033 @ssh = ($ENV{'GIT_SSH'});
3037 last unless $ARGV[0] =~ m/^-/;
3041 if (m/^--dry-run$/) {
3044 } elsif (m/^--damp-run$/) {
3047 } elsif (m/^--no-sign$/) {
3050 } elsif (m/^--help$/) {
3052 } elsif (m/^--version$/) {
3054 } elsif (m/^--new$/) {
3057 } elsif (m/^--since-version=([^_]+|_)$/) {
3059 $changes_since_version = $1;
3060 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3061 ($om = $opts_opt_map{$1}) &&
3065 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3066 !$opts_opt_cmdonly{$1} &&
3067 ($om = $opts_opt_map{$1})) {
3070 } elsif (m/^--existing-package=(.*)/s) {
3072 $existing_package = $1;
3073 } elsif (m/^--initiator-tempdir=(.*)/s) {
3074 $initiator_tempdir = $1;
3075 $initiator_tempdir =~ m#^/# or
3076 badusage "--initiator-tempdir must be used specify an".
3077 " absolute, not relative, directory."
3078 } elsif (m/^--distro=(.*)/s) {
3081 } elsif (m/^--build-products-dir=(.*)/s) {
3083 $buildproductsdir = $1;
3084 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3087 } elsif (m/^--clean=(.*)$/s) {
3088 badusage "unknown cleaning mode \`$1'";
3089 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3092 } elsif (m/^--quilt=(.*)$/s) {
3093 badusage "unknown quilt fixup mode \`$1'";
3094 } elsif (m/^--ignore-dirty$/s) {
3097 } elsif (m/^--no-quilt-fixup$/s) {
3099 $quilt_mode = 'nocheck';
3100 } elsif (m/^--no-rm-on-error$/s) {
3103 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3105 push @deliberatelies, $&;
3107 badusage "unknown long option \`$_'";
3114 } elsif (s/^-L/-/) {
3117 } elsif (s/^-h/-/) {
3119 } elsif (s/^-D/-/) {
3123 } elsif (s/^-N/-/) {
3126 } elsif (s/^-v([^_]+|_)$//s) {
3128 $changes_since_version = $1;
3131 push @changesopts, $_;
3133 } elsif (s/^-c(.*=.*)//s) {
3135 push @git, '-c', $1;
3136 } elsif (s/^-d(.+)//s) {
3139 } elsif (s/^-C(.+)//s) {
3142 if ($changesfile =~ s#^(.*)/##) {
3143 $buildproductsdir = $1;
3145 } elsif (s/^-k(.+)//s) {
3147 } elsif (m/^-[vdCk]$/) {
3149 "option \`$_' requires an argument (and no space before the argument)";
3150 } elsif (s/^-wn$//s) {
3152 $cleanmode = 'none';
3153 } elsif (s/^-wg$//s) {
3156 } elsif (s/^-wgf$//s) {
3158 $cleanmode = 'git-ff';
3159 } elsif (s/^-wd$//s) {
3161 $cleanmode = 'dpkg-source';
3162 } elsif (s/^-wdd$//s) {
3164 $cleanmode = 'dpkg-source-d';
3165 } elsif (s/^-wc$//s) {
3167 $cleanmode = 'check';
3169 badusage "unknown short option \`$_'";
3176 sub finalise_opts_opts () {
3177 foreach my $k (keys %opts_opt_map) {
3178 my $om = $opts_opt_map{$k};
3180 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3182 badcfg "cannot set command for $k"
3183 unless length $om->[0];
3187 foreach my $c (access_cfg_cfgs("opts-$k")) {
3188 local ($debuglevel) = $debuglevel-2;
3189 my $vl = $gitcfg{$c};
3191 badcfg "cannot configure options for $k"
3192 if $opts_opt_cmdonly{$k};
3193 my $insertpos = $opts_cfg_insertpos{$k};
3194 @$om = ( @$om[0..$insertpos-1],
3196 @$om[$insertpos..$#$om] );
3201 if ($ENV{$fakeeditorenv}) {
3203 quilt_fixup_editor();
3209 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3210 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3211 if $dryrun_level == 1;
3213 print STDERR $helpmsg or die $!;
3216 my $cmd = shift @ARGV;
3219 if (!defined $quilt_mode) {
3220 local $access_forpush;
3221 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3222 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3224 $quilt_mode =~ m/^($quilt_modes_re)$/
3225 or badcfg "unknown quilt-mode \`$quilt_mode'";
3229 my $fn = ${*::}{"cmd_$cmd"};
3230 $fn or badusage "unknown operation $cmd";