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 ($) {
531 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
534 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
540 return undef if $c =~ /RETURN-UNDEF/;
541 my $v = git_get_config($c);
542 return $v if defined $v;
543 my $dv = $defcfg{$c};
544 return $dv if defined $dv;
546 badcfg "need value for one of: @_\n".
547 "$us: distro or suite appears not to be (properly) supported";
550 sub access_basedistro () {
551 if (defined $idistro) {
554 return cfg("dgit-suite.$isuite.distro",
555 "dgit.default.distro");
559 sub access_quirk () {
560 # returns (quirk name, distro to use instead or undef, quirk-specific info)
561 my $basedistro = access_basedistro();
562 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
564 if (defined $backports_quirk) {
565 my $re = $backports_quirk;
566 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
568 $re =~ s/\%/([-0-9a-z_]+)/
569 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
570 if ($isuite =~ m/^$re$/) {
571 return ('backports',"$basedistro-backports",$1);
574 return ('none',undef);
579 sub parse_cfg_bool ($$$) {
580 my ($what,$def,$v) = @_;
583 $v =~ m/^[ty1]/ ? 1 :
584 $v =~ m/^[fn0]/ ? 0 :
585 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
588 sub access_forpush_config () {
589 my $d = access_basedistro();
593 parse_cfg_bool('new-private-pushers', 0,
594 cfg("dgit-distro.$d.new-private-pushers",
597 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
600 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
601 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
602 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
603 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
606 sub access_forpush () {
607 $access_forpush //= access_forpush_config();
608 return $access_forpush;
612 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
613 badcfg "pushing but distro is configured readonly"
614 if access_forpush_config() eq '0';
616 $supplementary_message = <<'END' unless $we_are_responder;
617 Push failed, before we got started.
618 You can retry the push, after fixing the problem, if you like.
620 finalise_opts_opts();
624 finalise_opts_opts();
627 sub supplementary_message ($) {
629 if (!$we_are_responder) {
630 $supplementary_message = $msg;
632 } elsif ($protovsn >= 3) {
633 responder_send_command "supplementary-message ".length($msg)
635 print PO $msg or die $!;
639 sub access_distros () {
640 # Returns list of distros to try, in order
643 # 0. `instead of' distro name(s) we have been pointed to
644 # 1. the access_quirk distro, if any
645 # 2a. the user's specified distro, or failing that } basedistro
646 # 2b. the distro calculated from the suite }
647 my @l = access_basedistro();
649 my (undef,$quirkdistro) = access_quirk();
650 unshift @l, $quirkdistro;
651 unshift @l, $instead_distro;
652 @l = grep { defined } @l;
654 if (access_forpush()) {
655 @l = map { ("$_/push", $_) } @l;
660 sub access_cfg_cfgs (@) {
663 # The nesting of these loops determines the search order. We put
664 # the key loop on the outside so that we search all the distros
665 # for each key, before going on to the next key. That means that
666 # if access_cfg is called with a more specific, and then a less
667 # specific, key, an earlier distro can override the less specific
668 # without necessarily overriding any more specific keys. (If the
669 # distro wants to override the more specific keys it can simply do
670 # so; whereas if we did the loop the other way around, it would be
671 # impossible to for an earlier distro to override a less specific
672 # key but not the more specific ones without restating the unknown
673 # values of the more specific keys.
676 # We have to deal with RETURN-UNDEF specially, so that we don't
677 # terminate the search prematurely.
679 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
682 foreach my $d (access_distros()) {
683 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
685 push @cfgs, map { "dgit.default.$_" } @realkeys;
692 my (@cfgs) = access_cfg_cfgs(@keys);
693 my $value = cfg(@cfgs);
697 sub access_cfg_bool ($$) {
698 my ($def, @keys) = @_;
699 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
702 sub string_to_ssh ($) {
704 if ($spec =~ m/\s/) {
705 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
711 sub access_cfg_ssh () {
712 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
713 if (!defined $gitssh) {
716 return string_to_ssh $gitssh;
720 sub access_runeinfo ($) {
722 return ": dgit ".access_basedistro()." $info ;";
725 sub access_someuserhost ($) {
727 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
728 defined($user) && length($user) or
729 $user = access_cfg("$some-user",'username');
730 my $host = access_cfg("$some-host");
731 return length($user) ? "$user\@$host" : $host;
734 sub access_gituserhost () {
735 return access_someuserhost('git');
738 sub access_giturl (;$) {
740 my $url = access_cfg('git-url','RETURN-UNDEF');
743 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
744 return undef unless defined $proto;
747 access_gituserhost().
748 access_cfg('git-path');
750 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
753 return "$url/$package$suffix";
756 sub parsecontrolfh ($$;$) {
757 my ($fh, $desc, $allowsigned) = @_;
758 our $dpkgcontrolhash_noissigned;
761 my %opts = ('name' => $desc);
762 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
763 $c = Dpkg::Control::Hash->new(%opts);
764 $c->parse($fh,$desc) or die "parsing of $desc failed";
765 last if $allowsigned;
766 last if $dpkgcontrolhash_noissigned;
767 my $issigned= $c->get_option('is_pgp_signed');
768 if (!defined $issigned) {
769 $dpkgcontrolhash_noissigned= 1;
770 seek $fh, 0,0 or die "seek $desc: $!";
771 } elsif ($issigned) {
772 fail "control file $desc is (already) PGP-signed. ".
773 " Note that dgit push needs to modify the .dsc and then".
774 " do the signature itself";
783 my ($file, $desc) = @_;
784 my $fh = new IO::Handle;
785 open $fh, '<', $file or die "$file: $!";
786 my $c = parsecontrolfh($fh,$desc);
787 $fh->error and die $!;
793 my ($dctrl,$field) = @_;
794 my $v = $dctrl->{$field};
795 return $v if defined $v;
796 fail "missing field $field in ".$v->get_option('name');
800 my $c = Dpkg::Control::Hash->new();
801 my $p = new IO::Handle;
802 my @cmd = (qw(dpkg-parsechangelog), @_);
803 open $p, '-|', @cmd or die $!;
805 $?=0; $!=0; close $p or failedcmd @cmd;
811 defined $d or fail "getcwd failed: $!";
817 sub archive_query ($) {
819 my $query = access_cfg('archive-query','RETURN-UNDEF');
820 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
823 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
826 sub pool_dsc_subpath ($$) {
827 my ($vsn,$component) = @_; # $package is implict arg
828 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
829 return "/pool/$component/$prefix/$package/".dscfn($vsn);
832 #---------- `ftpmasterapi' archive query method (nascent) ----------
834 sub archive_api_query_cmd ($) {
836 my @cmd = qw(curl -sS);
837 my $url = access_cfg('archive-query-url');
838 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
840 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
841 foreach my $key (split /\:/, $keys) {
842 $key =~ s/\%HOST\%/$host/g;
844 fail "for $url: stat $key: $!" unless $!==ENOENT;
847 fail "config requested specific TLS key but do not know".
848 " how to get curl to use exactly that EE key ($key)";
849 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
850 # # Sadly the above line does not work because of changes
851 # # to gnutls. The real fix for #790093 may involve
852 # # new curl options.
855 # Fixing #790093 properly will involve providing a value
856 # for this on clients.
857 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
858 push @cmd, split / /, $kargs if defined $kargs;
860 push @cmd, $url.$subpath;
866 my ($data, $subpath) = @_;
867 badcfg "ftpmasterapi archive query method takes no data part"
869 my @cmd = archive_api_query_cmd($subpath);
870 my $json = cmdoutput @cmd;
871 return decode_json($json);
874 sub canonicalise_suite_ftpmasterapi () {
875 my ($proto,$data) = @_;
876 my $suites = api_query($data, 'suites');
878 foreach my $entry (@$suites) {
880 my $v = $entry->{$_};
881 defined $v && $v eq $isuite;
883 push @matched, $entry;
885 fail "unknown suite $isuite" unless @matched;
888 @matched==1 or die "multiple matches for suite $isuite\n";
889 $cn = "$matched[0]{codename}";
890 defined $cn or die "suite $isuite info has no codename\n";
891 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
893 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
898 sub archive_query_ftpmasterapi () {
899 my ($proto,$data) = @_;
900 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
902 my $digester = Digest::SHA->new(256);
903 foreach my $entry (@$info) {
905 my $vsn = "$entry->{version}";
906 my ($ok,$msg) = version_check $vsn;
907 die "bad version: $msg\n" unless $ok;
908 my $component = "$entry->{component}";
909 $component =~ m/^$component_re$/ or die "bad component";
910 my $filename = "$entry->{filename}";
911 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
912 or die "bad filename";
913 my $sha256sum = "$entry->{sha256sum}";
914 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
915 push @rows, [ $vsn, "/pool/$component/$filename",
916 $digester, $sha256sum ];
918 die "bad ftpmaster api response: $@\n".Dumper($entry)
921 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
925 #---------- `madison' archive query method ----------
927 sub archive_query_madison {
928 return map { [ @$_[0..1] ] } madison_get_parse(@_);
931 sub madison_get_parse {
932 my ($proto,$data) = @_;
933 die unless $proto eq 'madison';
935 $data= access_cfg('madison-distro','RETURN-UNDEF');
936 $data //= access_basedistro();
938 $rmad{$proto,$data,$package} ||= cmdoutput
939 qw(rmadison -asource),"-s$isuite","-u$data",$package;
940 my $rmad = $rmad{$proto,$data,$package};
943 foreach my $l (split /\n/, $rmad) {
944 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
945 \s*( [^ \t|]+ )\s* \|
946 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
947 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
948 $1 eq $package or die "$rmad $package ?";
955 $component = access_cfg('archive-query-default-component');
957 $5 eq 'source' or die "$rmad ?";
958 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
960 return sort { -version_compare($a->[0],$b->[0]); } @out;
963 sub canonicalise_suite_madison {
964 # madison canonicalises for us
965 my @r = madison_get_parse(@_);
967 "unable to canonicalise suite using package $package".
968 " which does not appear to exist in suite $isuite;".
969 " --existing-package may help";
973 #---------- `sshpsql' archive query method ----------
976 my ($data,$runeinfo,$sql) = @_;
978 $data= access_someuserhost('sshpsql').':'.
979 access_cfg('sshpsql-dbname');
981 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
982 my ($userhost,$dbname) = ($`,$'); #';
984 my @cmd = (access_cfg_ssh, $userhost,
985 access_runeinfo("ssh-psql $runeinfo").
986 " export LC_MESSAGES=C; export LC_CTYPE=C;".
987 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
989 open P, "-|", @cmd or die $!;
992 printdebug(">|$_|\n");
995 $!=0; $?=0; close P or failedcmd @cmd;
997 my $nrows = pop @rows;
998 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
999 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1000 @rows = map { [ split /\|/, $_ ] } @rows;
1001 my $ncols = scalar @{ shift @rows };
1002 die if grep { scalar @$_ != $ncols } @rows;
1006 sub sql_injection_check {
1007 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1010 sub archive_query_sshpsql ($$) {
1011 my ($proto,$data) = @_;
1012 sql_injection_check $isuite, $package;
1013 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1014 SELECT source.version, component.name, files.filename, files.sha256sum
1016 JOIN src_associations ON source.id = src_associations.source
1017 JOIN suite ON suite.id = src_associations.suite
1018 JOIN dsc_files ON dsc_files.source = source.id
1019 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1020 JOIN component ON component.id = files_archive_map.component_id
1021 JOIN files ON files.id = dsc_files.file
1022 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1023 AND source.source='$package'
1024 AND files.filename LIKE '%.dsc';
1026 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1027 my $digester = Digest::SHA->new(256);
1029 my ($vsn,$component,$filename,$sha256sum) = @$_;
1030 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1035 sub canonicalise_suite_sshpsql ($$) {
1036 my ($proto,$data) = @_;
1037 sql_injection_check $isuite;
1038 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1039 SELECT suite.codename
1040 FROM suite where suite_name='$isuite' or codename='$isuite';
1042 @rows = map { $_->[0] } @rows;
1043 fail "unknown suite $isuite" unless @rows;
1044 die "ambiguous $isuite: @rows ?" if @rows>1;
1048 #---------- `dummycat' archive query method ----------
1050 sub canonicalise_suite_dummycat ($$) {
1051 my ($proto,$data) = @_;
1052 my $dpath = "$data/suite.$isuite";
1053 if (!open C, "<", $dpath) {
1054 $!==ENOENT or die "$dpath: $!";
1055 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1059 chomp or die "$dpath: $!";
1061 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1065 sub archive_query_dummycat ($$) {
1066 my ($proto,$data) = @_;
1067 canonicalise_suite();
1068 my $dpath = "$data/package.$csuite.$package";
1069 if (!open C, "<", $dpath) {
1070 $!==ENOENT or die "$dpath: $!";
1071 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1079 printdebug "dummycat query $csuite $package $dpath | $_\n";
1080 my @row = split /\s+/, $_;
1081 @row==2 or die "$dpath: $_ ?";
1084 C->error and die "$dpath: $!";
1086 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1089 #---------- archive query entrypoints and rest of program ----------
1091 sub canonicalise_suite () {
1092 return if defined $csuite;
1093 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1094 $csuite = archive_query('canonicalise_suite');
1095 if ($isuite ne $csuite) {
1096 progress "canonical suite name for $isuite is $csuite";
1100 sub get_archive_dsc () {
1101 canonicalise_suite();
1102 my @vsns = archive_query('archive_query');
1103 foreach my $vinfo (@vsns) {
1104 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1105 $dscurl = access_cfg('mirror').$subpath;
1106 $dscdata = url_get($dscurl);
1108 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1113 $digester->add($dscdata);
1114 my $got = $digester->hexdigest();
1116 fail "$dscurl has hash $got but".
1117 " archive told us to expect $digest";
1119 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1120 printdebug Dumper($dscdata) if $debuglevel>1;
1121 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1122 printdebug Dumper($dsc) if $debuglevel>1;
1123 my $fmt = getfield $dsc, 'Format';
1124 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1125 $dsc_checked = !!$digester;
1131 sub check_for_git ();
1132 sub check_for_git () {
1134 my $how = access_cfg('git-check');
1135 if ($how eq 'ssh-cmd') {
1137 (access_cfg_ssh, access_gituserhost(),
1138 access_runeinfo("git-check $package").
1139 " set -e; cd ".access_cfg('git-path').";".
1140 " if test -d $package.git; then echo 1; else echo 0; fi");
1141 my $r= cmdoutput @cmd;
1142 if ($r =~ m/^divert (\w+)$/) {
1144 my ($usedistro,) = access_distros();
1145 # NB that if we are pushing, $usedistro will be $distro/push
1146 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1147 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1148 progress "diverting to $divert (using config for $instead_distro)";
1149 return check_for_git();
1151 failedcmd @cmd unless $r =~ m/^[01]$/;
1153 } elsif ($how eq 'url') {
1154 my $prefix = access_cfg('git-check-url','git-url');
1155 my $suffix = access_cfg('git-check-suffix','git-suffix',
1156 'RETURN-UNDEF') // '.git';
1157 my $url = "$prefix/$package$suffix";
1158 my @cmd = (qw(curl -sS -I), $url);
1159 my $result = cmdoutput @cmd;
1160 $result =~ s/^\S+ 200 .*\n\r?\n//;
1161 # curl -sS -I with https_proxy prints
1162 # HTTP/1.0 200 Connection established
1163 $result =~ m/^\S+ (404|200) /s or
1164 fail "unexpected results from git check query - ".
1165 Dumper($prefix, $result);
1167 if ($code eq '404') {
1169 } elsif ($code eq '200') {
1174 } elsif ($how eq 'true') {
1176 } elsif ($how eq 'false') {
1179 badcfg "unknown git-check \`$how'";
1183 sub create_remote_git_repo () {
1184 my $how = access_cfg('git-create');
1185 if ($how eq 'ssh-cmd') {
1187 (access_cfg_ssh, access_gituserhost(),
1188 access_runeinfo("git-create $package").
1189 "set -e; cd ".access_cfg('git-path').";".
1190 " cp -a _template $package.git");
1191 } elsif ($how eq 'true') {
1194 badcfg "unknown git-create \`$how'";
1198 our ($dsc_hash,$lastpush_hash);
1200 our $ud = '.git/dgit/unpack';
1205 mkdir $ud or die $!;
1208 sub mktree_in_ud_here () {
1209 runcmd qw(git init -q);
1210 rmtree('.git/objects');
1211 symlink '../../../../objects','.git/objects' or die $!;
1214 sub git_write_tree () {
1215 my $tree = cmdoutput @git, qw(write-tree);
1216 $tree =~ m/^\w+$/ or die "$tree ?";
1220 sub mktree_in_ud_from_only_subdir () {
1221 # changes into the subdir
1223 die unless @dirs==1;
1224 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1228 my @gitscmd = qw(find -name .git -prune -print0);
1229 debugcmd "|",@gitscmd;
1230 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1235 print STDERR "$us: warning: removing from source package: ",
1236 (messagequote $_), "\n";
1240 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1242 mktree_in_ud_here();
1243 my $format=get_source_format();
1244 if (madformat($format)) {
1247 runcmd @git, qw(add -Af);
1248 my $tree=git_write_tree();
1249 return ($tree,$dir);
1252 sub dsc_files_info () {
1253 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1254 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1255 ['Files', 'Digest::MD5', 'new()']) {
1256 my ($fname, $module, $method) = @$csumi;
1257 my $field = $dsc->{$fname};
1258 next unless defined $field;
1259 eval "use $module; 1;" or die $@;
1261 foreach (split /\n/, $field) {
1263 m/^(\w+) (\d+) (\S+)$/ or
1264 fail "could not parse .dsc $fname line \`$_'";
1265 my $digester = eval "$module"."->$method;" or die $@;
1270 Digester => $digester,
1275 fail "missing any supported Checksums-* or Files field in ".
1276 $dsc->get_option('name');
1280 map { $_->{Filename} } dsc_files_info();
1283 sub is_orig_file ($;$) {
1286 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1287 defined $base or return 1;
1291 sub make_commit ($) {
1293 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1296 sub clogp_authline ($) {
1298 my $author = getfield $clogp, 'Maintainer';
1299 $author =~ s#,.*##ms;
1300 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1301 my $authline = "$author $date";
1302 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1303 fail "unexpected commit author line format \`$authline'".
1304 " (was generated from changelog Maintainer field)";
1308 sub vendor_patches_distro ($$) {
1309 my ($checkdistro, $what) = @_;
1310 return unless defined $checkdistro;
1312 my $series = "debian/patches/\L$checkdistro\E.series";
1313 printdebug "checking for vendor-specific $series ($what)\n";
1315 if (!open SERIES, "<", $series) {
1316 die "$series $!" unless $!==ENOENT;
1325 Unfortunately, this source package uses a feature of dpkg-source where
1326 the same source package unpacks to different source code on different
1327 distros. dgit cannot safely operate on such packages on affected
1328 distros, because the meaning of source packages is not stable.
1330 Please ask the distro/maintainer to remove the distro-specific series
1331 files and use a different technique (if necessary, uploading actually
1332 different packages, if different distros are supposed to have
1336 fail "Found active distro-specific series file for".
1337 " $checkdistro ($what): $series, cannot continue";
1339 die "$series $!" if SERIES->error;
1343 sub check_for_vendor_patches () {
1344 # This dpkg-source feature doesn't seem to be documented anywhere!
1345 # But it can be found in the changelog (reformatted):
1347 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1348 # Author: Raphael Hertzog <hertzog@debian.org>
1349 # Date: Sun Oct 3 09:36:48 2010 +0200
1351 # dpkg-source: correctly create .pc/.quilt_series with alternate
1354 # If you have debian/patches/ubuntu.series and you were
1355 # unpacking the source package on ubuntu, quilt was still
1356 # directed to debian/patches/series instead of
1357 # debian/patches/ubuntu.series.
1359 # debian/changelog | 3 +++
1360 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1361 # 2 files changed, 6 insertions(+), 1 deletion(-)
1364 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1365 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1366 "Dpkg::Vendor \`current vendor'");
1367 vendor_patches_distro(access_basedistro(),
1368 "distro being accessed");
1371 sub generate_commit_from_dsc () {
1375 foreach my $fi (dsc_files_info()) {
1376 my $f = $fi->{Filename};
1377 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1379 link "../../../$f", $f
1383 complete_file_from_dsc('.', $fi);
1385 if (is_orig_file($f)) {
1386 link $f, "../../../../$f"
1392 my $dscfn = "$package.dsc";
1394 open D, ">", $dscfn or die "$dscfn: $!";
1395 print D $dscdata or die "$dscfn: $!";
1396 close D or die "$dscfn: $!";
1397 my @cmd = qw(dpkg-source);
1398 push @cmd, '--no-check' if $dsc_checked;
1399 push @cmd, qw(-x --), $dscfn;
1402 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1403 check_for_vendor_patches() if madformat($dsc->{format});
1404 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1405 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1406 my $authline = clogp_authline $clogp;
1407 my $changes = getfield $clogp, 'Changes';
1408 open C, ">../commit.tmp" or die $!;
1409 print C <<END or die $!;
1416 # imported from the archive
1419 my $outputhash = make_commit qw(../commit.tmp);
1420 my $cversion = getfield $clogp, 'Version';
1421 progress "synthesised git commit from .dsc $cversion";
1422 if ($lastpush_hash) {
1423 runcmd @git, qw(reset --hard), $lastpush_hash;
1424 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1425 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1426 my $oversion = getfield $oldclogp, 'Version';
1428 version_compare($oversion, $cversion);
1430 # git upload/ is earlier vsn than archive, use archive
1431 open C, ">../commit2.tmp" or die $!;
1432 print C <<END or die $!;
1434 parent $lastpush_hash
1439 Record $package ($cversion) in archive suite $csuite
1441 $outputhash = make_commit qw(../commit2.tmp);
1442 } elsif ($vcmp > 0) {
1443 print STDERR <<END or die $!;
1445 Version actually in archive: $cversion (older)
1446 Last allegedly pushed/uploaded: $oversion (newer or same)
1449 $outputhash = $lastpush_hash;
1451 $outputhash = $lastpush_hash;
1454 changedir '../../../..';
1455 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1456 'DGIT_ARCHIVE', $outputhash;
1457 cmdoutput @git, qw(log -n2), $outputhash;
1458 # ... gives git a chance to complain if our commit is malformed
1463 sub complete_file_from_dsc ($$) {
1464 our ($dstdir, $fi) = @_;
1465 # Ensures that we have, in $dir, the file $fi, with the correct
1466 # contents. (Downloading it from alongside $dscurl if necessary.)
1468 my $f = $fi->{Filename};
1469 my $tf = "$dstdir/$f";
1472 if (stat_exists $tf) {
1473 progress "using existing $f";
1476 $furl =~ s{/[^/]+$}{};
1478 die "$f ?" unless $f =~ m/^${package}_/;
1479 die "$f ?" if $f =~ m#/#;
1480 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1481 next if !act_local();
1485 open F, "<", "$tf" or die "$tf: $!";
1486 $fi->{Digester}->reset();
1487 $fi->{Digester}->addfile(*F);
1488 F->error and die $!;
1489 my $got = $fi->{Digester}->hexdigest();
1490 $got eq $fi->{Hash} or
1491 fail "file $f has hash $got but .dsc".
1492 " demands hash $fi->{Hash} ".
1493 ($downloaded ? "(got wrong file from archive!)"
1494 : "(perhaps you should delete this file?)");
1497 sub ensure_we_have_orig () {
1498 foreach my $fi (dsc_files_info()) {
1499 my $f = $fi->{Filename};
1500 next unless is_orig_file($f);
1501 complete_file_from_dsc('..', $fi);
1505 sub git_fetch_us () {
1506 my @specs = (fetchspec());
1508 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1510 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1513 my $tagpat = debiantag('*',access_basedistro);
1515 git_for_each_ref("refs/tags/".$tagpat, sub {
1516 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1517 printdebug "currently $fullrefname=$objid\n";
1518 $here{$fullrefname} = $objid;
1520 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1521 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1522 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1523 printdebug "offered $lref=$objid\n";
1524 if (!defined $here{$lref}) {
1525 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1526 runcmd_ordryrun_local @upd;
1527 } elsif ($here{$lref} eq $objid) {
1530 "Not updateting $lref from $here{$lref} to $objid.\n";
1535 sub fetch_from_archive () {
1536 # ensures that lrref() is what is actually in the archive,
1537 # one way or another
1541 foreach my $field (@ourdscfield) {
1542 $dsc_hash = $dsc->{$field};
1543 last if defined $dsc_hash;
1545 if (defined $dsc_hash) {
1546 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1548 progress "last upload to archive specified git hash";
1550 progress "last upload to archive has NO git hash";
1553 progress "no version available from the archive";
1556 $lastpush_hash = git_get_ref(lrref());
1557 printdebug "previous reference hash=$lastpush_hash\n";
1559 if (defined $dsc_hash) {
1560 fail "missing remote git history even though dsc has hash -".
1561 " could not find ref ".lrref().
1562 " (should have been fetched from ".access_giturl()."#".rrref().")"
1563 unless $lastpush_hash;
1565 ensure_we_have_orig();
1566 if ($dsc_hash eq $lastpush_hash) {
1567 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1568 print STDERR <<END or die $!;
1570 Git commit in archive is behind the last version allegedly pushed/uploaded.
1571 Commit referred to by archive: $dsc_hash
1572 Last allegedly pushed/uploaded: $lastpush_hash
1575 $hash = $lastpush_hash;
1577 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1578 "descendant of archive's .dsc hash ($dsc_hash)";
1581 $hash = generate_commit_from_dsc();
1582 } elsif ($lastpush_hash) {
1583 # only in git, not in the archive yet
1584 $hash = $lastpush_hash;
1585 print STDERR <<END or die $!;
1587 Package not found in the archive, but has allegedly been pushed using dgit.
1591 printdebug "nothing found!\n";
1592 if (defined $skew_warning_vsn) {
1593 print STDERR <<END or die $!;
1595 Warning: relevant archive skew detected.
1596 Archive allegedly contains $skew_warning_vsn
1597 But we were not able to obtain any version from the archive or git.
1603 printdebug "current hash=$hash\n";
1604 if ($lastpush_hash) {
1605 fail "not fast forward on last upload branch!".
1606 " (archive's version left in DGIT_ARCHIVE)"
1607 unless is_fast_fwd($lastpush_hash, $hash);
1609 if (defined $skew_warning_vsn) {
1611 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1612 my $clogf = ".git/dgit/changelog.tmp";
1613 runcmd shell_cmd "exec >$clogf",
1614 @git, qw(cat-file blob), "$hash:debian/changelog";
1615 my $gotclogp = parsechangelog("-l$clogf");
1616 my $got_vsn = getfield $gotclogp, 'Version';
1617 printdebug "SKEW CHECK GOT $got_vsn\n";
1618 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1619 print STDERR <<END or die $!;
1621 Warning: archive skew detected. Using the available version:
1622 Archive allegedly contains $skew_warning_vsn
1623 We were able to obtain only $got_vsn
1628 if ($lastpush_hash ne $hash) {
1629 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1633 dryrun_report @upd_cmd;
1639 sub set_local_git_config ($$) {
1641 runcmd @git, qw(config), $k, $v;
1644 sub setup_mergechangelogs (;$) {
1646 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1648 my $driver = 'dpkg-mergechangelogs';
1649 my $cb = "merge.$driver";
1650 my $attrs = '.git/info/attributes';
1651 ensuredir '.git/info';
1653 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1654 if (!open ATTRS, "<", $attrs) {
1655 $!==ENOENT or die "$attrs: $!";
1659 next if m{^debian/changelog\s};
1660 print NATTRS $_, "\n" or die $!;
1662 ATTRS->error and die $!;
1665 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1668 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1669 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1671 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1674 sub setup_useremail (;$) {
1676 return unless $always || access_cfg_bool(1, 'setup-useremail');
1679 my ($k, $envvar) = @_;
1680 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1681 return unless defined $v;
1682 set_local_git_config "user.$k", $v;
1685 $setup->('email', 'DEBEMAIL');
1686 $setup->('name', 'DEBFULLNAME');
1689 sub setup_new_tree () {
1690 setup_mergechangelogs();
1696 canonicalise_suite();
1697 badusage "dry run makes no sense with clone" unless act_local();
1698 my $hasgit = check_for_git();
1699 mkdir $dstdir or die "$dstdir $!";
1701 runcmd @git, qw(init -q);
1702 my $giturl = access_giturl(1);
1703 if (defined $giturl) {
1704 set_local_git_config "remote.$remotename.fetch", fetchspec();
1705 open H, "> .git/HEAD" or die $!;
1706 print H "ref: ".lref()."\n" or die $!;
1708 runcmd @git, qw(remote add), 'origin', $giturl;
1711 progress "fetching existing git history";
1713 runcmd_ordryrun_local @git, qw(fetch origin);
1715 progress "starting new git history";
1717 fetch_from_archive() or no_such_package;
1718 my $vcsgiturl = $dsc->{'Vcs-Git'};
1719 if (length $vcsgiturl) {
1720 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1721 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1724 runcmd @git, qw(reset --hard), lrref();
1725 printdone "ready for work in $dstdir";
1729 if (check_for_git()) {
1732 fetch_from_archive() or no_such_package();
1733 printdone "fetched into ".lrref();
1738 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1740 printdone "fetched to ".lrref()." and merged into HEAD";
1743 sub check_not_dirty () {
1744 return if $ignoredirty;
1745 my @cmd = (@git, qw(diff --quiet HEAD));
1747 $!=0; $?=0; system @cmd;
1748 return if !$! && !$?;
1749 if (!$! && $?==256) {
1750 fail "working tree is dirty (does not match HEAD)";
1756 sub commit_admin ($) {
1759 runcmd_ordryrun_local @git, qw(commit -m), $m;
1762 sub commit_quilty_patch () {
1763 my $output = cmdoutput @git, qw(status --porcelain);
1765 foreach my $l (split /\n/, $output) {
1766 next unless $l =~ m/\S/;
1767 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1771 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1773 progress "nothing quilty to commit, ok.";
1776 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1777 commit_admin "Commit Debian 3.0 (quilt) metadata";
1780 sub get_source_format () {
1781 if (!open F, "debian/source/format") {
1782 die $! unless $!==&ENOENT;
1786 F->error and die $!;
1793 return 0 unless $format eq '3.0 (quilt)';
1794 if ($quilt_mode eq 'nocheck') {
1795 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1798 progress "Format \`$format', checking/updating patch stack";
1802 sub push_parse_changelog ($) {
1805 my $clogp = Dpkg::Control::Hash->new();
1806 $clogp->load($clogpfn) or die;
1808 $package = getfield $clogp, 'Source';
1809 my $cversion = getfield $clogp, 'Version';
1810 my $tag = debiantag($cversion, access_basedistro);
1811 runcmd @git, qw(check-ref-format), $tag;
1813 my $dscfn = dscfn($cversion);
1815 return ($clogp, $cversion, $tag, $dscfn);
1818 sub push_parse_dsc ($$$) {
1819 my ($dscfn,$dscfnwhat, $cversion) = @_;
1820 $dsc = parsecontrol($dscfn,$dscfnwhat);
1821 my $dversion = getfield $dsc, 'Version';
1822 my $dscpackage = getfield $dsc, 'Source';
1823 ($dscpackage eq $package && $dversion eq $cversion) or
1824 fail "$dscfn is for $dscpackage $dversion".
1825 " but debian/changelog is for $package $cversion";
1828 sub push_mktag ($$$$$$$) {
1829 my ($head,$clogp,$tag,
1831 $changesfile,$changesfilewhat,
1834 $dsc->{$ourdscfield[0]} = $head;
1835 $dsc->save("$dscfn.tmp") or die $!;
1837 my $changes = parsecontrol($changesfile,$changesfilewhat);
1838 foreach my $field (qw(Source Distribution Version)) {
1839 $changes->{$field} eq $clogp->{$field} or
1840 fail "changes field $field \`$changes->{$field}'".
1841 " does not match changelog \`$clogp->{$field}'";
1844 my $cversion = getfield $clogp, 'Version';
1845 my $clogsuite = getfield $clogp, 'Distribution';
1847 # We make the git tag by hand because (a) that makes it easier
1848 # to control the "tagger" (b) we can do remote signing
1849 my $authline = clogp_authline $clogp;
1850 my $delibs = join(" ", "",@deliberatelies);
1851 my $declaredistro = access_basedistro();
1852 open TO, '>', $tfn->('.tmp') or die $!;
1853 print TO <<END or die $!;
1859 $package release $cversion for $clogsuite ($csuite) [dgit]
1860 [dgit distro=$declaredistro$delibs]
1862 foreach my $ref (sort keys %previously) {
1863 print TO <<END or die $!;
1864 [dgit previously:$ref=$previously{$ref}]
1870 my $tagobjfn = $tfn->('.tmp');
1872 if (!defined $keyid) {
1873 $keyid = access_cfg('keyid','RETURN-UNDEF');
1875 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1876 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1877 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1878 push @sign_cmd, $tfn->('.tmp');
1879 runcmd_ordryrun @sign_cmd;
1881 $tagobjfn = $tfn->('.signed.tmp');
1882 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1883 $tfn->('.tmp'), $tfn->('.tmp.asc');
1890 sub sign_changes ($) {
1891 my ($changesfile) = @_;
1893 my @debsign_cmd = @debsign;
1894 push @debsign_cmd, "-k$keyid" if defined $keyid;
1895 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1896 push @debsign_cmd, $changesfile;
1897 runcmd_ordryrun @debsign_cmd;
1902 my ($forceflag) = @_;
1903 printdebug "actually entering push\n";
1904 supplementary_message(<<'END');
1905 Push failed, while preparing your push.
1906 You can retry the push, after fixing the problem, if you like.
1910 access_giturl(); # check that success is vaguely likely
1912 my $clogpfn = ".git/dgit/changelog.822.tmp";
1913 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1915 responder_send_file('parsed-changelog', $clogpfn);
1917 my ($clogp, $cversion, $tag, $dscfn) =
1918 push_parse_changelog("$clogpfn");
1920 my $dscpath = "$buildproductsdir/$dscfn";
1921 stat_exists $dscpath or
1922 fail "looked for .dsc $dscfn, but $!;".
1923 " maybe you forgot to build";
1925 responder_send_file('dsc', $dscpath);
1927 push_parse_dsc($dscpath, $dscfn, $cversion);
1929 my $format = getfield $dsc, 'Format';
1930 printdebug "format $format\n";
1931 if (madformat($format)) {
1932 commit_quilty_patch();
1936 progress "checking that $dscfn corresponds to HEAD";
1937 runcmd qw(dpkg-source -x --),
1938 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1939 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1940 check_for_vendor_patches() if madformat($dsc->{format});
1941 changedir '../../../..';
1942 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1943 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1944 debugcmd "+",@diffcmd;
1946 my $r = system @diffcmd;
1949 fail "$dscfn specifies a different tree to your HEAD commit;".
1950 " perhaps you forgot to build".
1951 ($diffopt eq '--exit-code' ? "" :
1952 " (run with -D to see full diff output)");
1957 my $head = git_rev_parse('HEAD');
1958 if (!$changesfile) {
1959 my $multi = "$buildproductsdir/".
1960 "${package}_".(stripepoch $cversion)."_multi.changes";
1961 if (stat_exists "$multi") {
1962 $changesfile = $multi;
1964 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1965 my @cs = glob "$buildproductsdir/$pat";
1966 fail "failed to find unique changes file".
1967 " (looked for $pat in $buildproductsdir, or $multi);".
1968 " perhaps you need to use dgit -C"
1970 ($changesfile) = @cs;
1973 $changesfile = "$buildproductsdir/$changesfile";
1976 responder_send_file('changes',$changesfile);
1977 responder_send_command("param head $head");
1978 responder_send_command("param csuite $csuite");
1980 if (deliberately_not_fast_forward) {
1981 git_for_each_ref(lrfetchrefs, sub {
1982 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1983 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1984 responder_send_command("previously $rrefname=$objid");
1985 $previously{$rrefname} = $objid;
1989 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1992 supplementary_message(<<'END');
1993 Push failed, while signing the tag.
1994 You can retry the push, after fixing the problem, if you like.
1996 # If we manage to sign but fail to record it anywhere, it's fine.
1997 if ($we_are_responder) {
1998 $tagobjfn = $tfn->('.signed.tmp');
1999 responder_receive_files('signed-tag', $tagobjfn);
2002 push_mktag($head,$clogp,$tag,
2004 $changesfile,$changesfile,
2007 supplementary_message(<<'END');
2008 Push failed, *after* signing the tag.
2009 If you want to try again, you should use a new version number.
2012 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2013 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2014 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2016 supplementary_message(<<'END');
2017 Push failed, while updating the remote git repository - see messages above.
2018 If you want to try again, you should use a new version number.
2020 if (!check_for_git()) {
2021 create_remote_git_repo();
2023 runcmd_ordryrun @git, qw(push),access_giturl(),
2024 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2025 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2027 supplementary_message(<<'END');
2028 Push failed, after updating the remote git repository.
2029 If you want to try again, you must use a new version number.
2031 if ($we_are_responder) {
2032 my $dryrunsuffix = act_local() ? "" : ".tmp";
2033 responder_receive_files('signed-dsc-changes',
2034 "$dscpath$dryrunsuffix",
2035 "$changesfile$dryrunsuffix");
2038 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2040 progress "[new .dsc left in $dscpath.tmp]";
2042 sign_changes $changesfile;
2045 supplementary_message(<<'END');
2046 Push failed, while uploading package(s) to the archive server.
2047 You can retry the upload of exactly these same files with dput of:
2049 If that .changes file is broken, you will need to use a new version
2050 number for your next attempt at the upload.
2052 my $host = access_cfg('upload-host','RETURN-UNDEF');
2053 my @hostarg = defined($host) ? ($host,) : ();
2054 runcmd_ordryrun @dput, @hostarg, $changesfile;
2055 printdone "pushed and uploaded $cversion";
2057 supplementary_message('');
2058 responder_send_command("complete");
2065 badusage "-p is not allowed with clone; specify as argument instead"
2066 if defined $package;
2069 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2070 ($package,$isuite) = @ARGV;
2071 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2072 ($package,$dstdir) = @ARGV;
2073 } elsif (@ARGV==3) {
2074 ($package,$isuite,$dstdir) = @ARGV;
2076 badusage "incorrect arguments to dgit clone";
2078 $dstdir ||= "$package";
2080 if (stat_exists $dstdir) {
2081 fail "$dstdir already exists";
2085 if ($rmonerror && !$dryrun_level) {
2086 $cwd_remove= getcwd();
2088 return unless defined $cwd_remove;
2089 if (!chdir "$cwd_remove") {
2090 return if $!==&ENOENT;
2091 die "chdir $cwd_remove: $!";
2093 rmtree($dstdir) or die "remove $dstdir: $!\n";
2098 $cwd_remove = undef;
2101 sub branchsuite () {
2102 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2103 if ($branch =~ m#$lbranch_re#o) {
2110 sub fetchpullargs () {
2112 if (!defined $package) {
2113 my $sourcep = parsecontrol('debian/control','debian/control');
2114 $package = getfield $sourcep, 'Source';
2117 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2119 my $clogp = parsechangelog();
2120 $isuite = getfield $clogp, 'Distribution';
2122 canonicalise_suite();
2123 progress "fetching from suite $csuite";
2124 } elsif (@ARGV==1) {
2126 canonicalise_suite();
2128 badusage "incorrect arguments to dgit fetch or dgit pull";
2147 badusage "-p is not allowed with dgit push" if defined $package;
2149 my $clogp = parsechangelog();
2150 $package = getfield $clogp, 'Source';
2153 } elsif (@ARGV==1) {
2154 ($specsuite) = (@ARGV);
2156 badusage "incorrect arguments to dgit push";
2158 $isuite = getfield $clogp, 'Distribution';
2160 local ($package) = $existing_package; # this is a hack
2161 canonicalise_suite();
2163 canonicalise_suite();
2165 if (defined $specsuite &&
2166 $specsuite ne $isuite &&
2167 $specsuite ne $csuite) {
2168 fail "dgit push: changelog specifies $isuite ($csuite)".
2169 " but command line specifies $specsuite";
2171 supplementary_message(<<'END');
2172 Push failed, while checking state of the archive.
2173 You can retry the push, after fixing the problem, if you like.
2175 if (check_for_git()) {
2179 if (fetch_from_archive()) {
2180 if (is_fast_fwd(lrref(), 'HEAD')) {
2182 } elsif (deliberately_not_fast_forward) {
2185 fail "dgit push: HEAD is not a descendant".
2186 " of the archive's version.\n".
2187 "dgit: To overwrite its contents,".
2188 " use git merge -s ours ".lrref().".\n".
2189 "dgit: To rewind history, if permitted by the archive,".
2190 " use --deliberately-not-fast-forward";
2194 fail "package appears to be new in this suite;".
2195 " if this is intentional, use --new";
2200 #---------- remote commands' implementation ----------
2202 sub cmd_remote_push_build_host {
2203 my ($nrargs) = shift @ARGV;
2204 my (@rargs) = @ARGV[0..$nrargs-1];
2205 @ARGV = @ARGV[$nrargs..$#ARGV];
2207 my ($dir,$vsnwant) = @rargs;
2208 # vsnwant is a comma-separated list; we report which we have
2209 # chosen in our ready response (so other end can tell if they
2212 $we_are_responder = 1;
2213 $us .= " (build host)";
2217 open PI, "<&STDIN" or die $!;
2218 open STDIN, "/dev/null" or die $!;
2219 open PO, ">&STDOUT" or die $!;
2221 open STDOUT, ">&STDERR" or die $!;
2225 ($protovsn) = grep {
2226 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2227 } @rpushprotovsn_support;
2229 fail "build host has dgit rpush protocol versions ".
2230 (join ",", @rpushprotovsn_support).
2231 " but invocation host has $vsnwant"
2232 unless defined $protovsn;
2234 responder_send_command("dgit-remote-push-ready $protovsn");
2240 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2241 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2242 # a good error message)
2248 my $report = i_child_report();
2249 if (defined $report) {
2250 printdebug "($report)\n";
2251 } elsif ($i_child_pid) {
2252 printdebug "(killing build host child $i_child_pid)\n";
2253 kill 15, $i_child_pid;
2255 if (defined $i_tmp && !defined $initiator_tempdir) {
2257 eval { rmtree $i_tmp; };
2261 END { i_cleanup(); }
2264 my ($base,$selector,@args) = @_;
2265 $selector =~ s/\-/_/g;
2266 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2273 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2281 push @rargs, join ",", @rpushprotovsn_support;
2284 push @rdgit, @ropts;
2285 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2287 my @cmd = (@ssh, $host, shellquote @rdgit);
2290 if (defined $initiator_tempdir) {
2291 rmtree $initiator_tempdir;
2292 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2293 $i_tmp = $initiator_tempdir;
2297 $i_child_pid = open2(\*RO, \*RI, @cmd);
2299 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2300 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2301 $supplementary_message = '' unless $protovsn >= 3;
2303 my ($icmd,$iargs) = initiator_expect {
2304 m/^(\S+)(?: (.*))?$/;
2307 i_method "i_resp", $icmd, $iargs;
2311 sub i_resp_progress ($) {
2313 my $msg = protocol_read_bytes \*RO, $rhs;
2317 sub i_resp_supplementary_message ($) {
2319 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2322 sub i_resp_complete {
2323 my $pid = $i_child_pid;
2324 $i_child_pid = undef; # prevents killing some other process with same pid
2325 printdebug "waiting for build host child $pid...\n";
2326 my $got = waitpid $pid, 0;
2327 die $! unless $got == $pid;
2328 die "build host child failed $?" if $?;
2331 printdebug "all done\n";
2335 sub i_resp_file ($) {
2337 my $localname = i_method "i_localname", $keyword;
2338 my $localpath = "$i_tmp/$localname";
2339 stat_exists $localpath and
2340 badproto \*RO, "file $keyword ($localpath) twice";
2341 protocol_receive_file \*RO, $localpath;
2342 i_method "i_file", $keyword;
2347 sub i_resp_param ($) {
2348 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2352 sub i_resp_previously ($) {
2353 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2354 or badproto \*RO, "bad previously spec";
2355 my $r = system qw(git check-ref-format), $1;
2356 die "bad previously ref spec ($r)" if $r;
2357 $previously{$1} = $2;
2362 sub i_resp_want ($) {
2364 die "$keyword ?" if $i_wanted{$keyword}++;
2365 my @localpaths = i_method "i_want", $keyword;
2366 printdebug "[[ $keyword @localpaths\n";
2367 foreach my $localpath (@localpaths) {
2368 protocol_send_file \*RI, $localpath;
2370 print RI "files-end\n" or die $!;
2373 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2375 sub i_localname_parsed_changelog {
2376 return "remote-changelog.822";
2378 sub i_file_parsed_changelog {
2379 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2380 push_parse_changelog "$i_tmp/remote-changelog.822";
2381 die if $i_dscfn =~ m#/|^\W#;
2384 sub i_localname_dsc {
2385 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2390 sub i_localname_changes {
2391 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2392 $i_changesfn = $i_dscfn;
2393 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2394 return $i_changesfn;
2396 sub i_file_changes { }
2398 sub i_want_signed_tag {
2399 printdebug Dumper(\%i_param, $i_dscfn);
2400 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2401 && defined $i_param{'csuite'}
2402 or badproto \*RO, "premature desire for signed-tag";
2403 my $head = $i_param{'head'};
2404 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2406 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2408 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2411 push_mktag $head, $i_clogp, $i_tag,
2413 $i_changesfn, 'remote changes',
2414 sub { "tag$_[0]"; };
2419 sub i_want_signed_dsc_changes {
2420 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2421 sign_changes $i_changesfn;
2422 return ($i_dscfn, $i_changesfn);
2425 #---------- building etc. ----------
2431 #----- `3.0 (quilt)' handling -----
2433 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2435 sub quiltify_dpkg_commit ($$$;$) {
2436 my ($patchname,$author,$msg, $xinfo) = @_;
2440 my $descfn = ".git/dgit/quilt-description.tmp";
2441 open O, '>', $descfn or die "$descfn: $!";
2444 $msg =~ s/^\s+$/ ./mg;
2445 print O <<END or die $!;
2455 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2456 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2457 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2458 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2462 sub quiltify_trees_differ ($$) {
2464 # returns 1 iff the two tree objects differ other than in debian/
2466 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2467 my $diffs= cmdoutput @cmd;
2468 foreach my $f (split /\0/, $diffs) {
2469 next if $f eq 'debian';
2475 sub quiltify_tree_sentinelfiles ($) {
2476 # lists the `sentinel' files present in the tree
2478 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2479 qw(-- debian/rules debian/control);
2485 my ($clogp,$target) = @_;
2487 # Quilt patchification algorithm
2489 # We search backwards through the history of the main tree's HEAD
2490 # (T) looking for a start commit S whose tree object is identical
2491 # to to the patch tip tree (ie the tree corresponding to the
2492 # current dpkg-committed patch series). For these purposes
2493 # `identical' disregards anything in debian/ - this wrinkle is
2494 # necessary because dpkg-source treates debian/ specially.
2496 # We can only traverse edges where at most one of the ancestors'
2497 # trees differs (in changes outside in debian/). And we cannot
2498 # handle edges which change .pc/ or debian/patches. To avoid
2499 # going down a rathole we avoid traversing edges which introduce
2500 # debian/rules or debian/control. And we set a limit on the
2501 # number of edges we are willing to look at.
2503 # If we succeed, we walk forwards again. For each traversed edge
2504 # PC (with P parent, C child) (starting with P=S and ending with
2505 # C=T) to we do this:
2507 # - dpkg-source --commit with a patch name and message derived from C
2508 # After traversing PT, we git commit the changes which
2509 # should be contained within debian/patches.
2511 changedir '../fake';
2512 mktree_in_ud_here();
2514 runcmd @git, 'add', '.';
2515 my $oldtiptree=git_write_tree();
2516 changedir '../work';
2518 # The search for the path S..T is breadth-first. We maintain a
2519 # todo list containing search nodes. A search node identifies a
2520 # commit, and looks something like this:
2522 # Commit => $git_commit_id,
2523 # Child => $c, # or undef if P=T
2524 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2525 # Nontrivial => true iff $p..$c has relevant changes
2532 my %considered; # saves being exponential on some weird graphs
2534 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2537 my ($search,$whynot) = @_;
2538 printdebug " search NOT $search->{Commit} $whynot\n";
2539 $search->{Whynot} = $whynot;
2540 push @nots, $search;
2541 no warnings qw(exiting);
2550 my $c = shift @todo;
2551 next if $considered{$c->{Commit}}++;
2553 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2555 printdebug "quiltify investigate $c->{Commit}\n";
2558 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2559 printdebug " search finished hooray!\n";
2564 if ($quilt_mode eq 'nofix') {
2565 fail "quilt fixup required but quilt mode is \`nofix'\n".
2566 "HEAD commit $c->{Commit} differs from tree implied by ".
2567 " debian/patches (tree object $oldtiptree)";
2569 if ($quilt_mode eq 'smash') {
2570 printdebug " search quitting smash\n";
2574 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2575 $not->($c, "has $c_sentinels not $t_sentinels")
2576 if $c_sentinels ne $t_sentinels;
2578 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2579 $commitdata =~ m/\n\n/;
2581 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2582 @parents = map { { Commit => $_, Child => $c } } @parents;
2584 $not->($c, "root commit") if !@parents;
2586 foreach my $p (@parents) {
2587 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2589 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2590 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2592 foreach my $p (@parents) {
2593 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2595 my @cmd= (@git, qw(diff-tree -r --name-only),
2596 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2597 my $patchstackchange = cmdoutput @cmd;
2598 if (length $patchstackchange) {
2599 $patchstackchange =~ s/\n/,/g;
2600 $not->($p, "changed $patchstackchange");
2603 printdebug " search queue P=$p->{Commit} ",
2604 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2610 printdebug "quiltify want to smash\n";
2613 my $x = $_[0]{Commit};
2614 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2617 my $reportnot = sub {
2619 my $s = $abbrev->($notp);
2620 my $c = $notp->{Child};
2621 $s .= "..".$abbrev->($c) if $c;
2622 $s .= ": ".$notp->{Whynot};
2625 if ($quilt_mode eq 'linear') {
2626 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2627 foreach my $notp (@nots) {
2628 print STDERR "$us: ", $reportnot->($notp), "\n";
2630 fail "quilt fixup naive history linearisation failed.\n".
2631 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2632 } elsif ($quilt_mode eq 'smash') {
2633 } elsif ($quilt_mode eq 'auto') {
2634 progress "quilt fixup cannot be linear, smashing...";
2636 die "$quilt_mode ?";
2641 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2643 quiltify_dpkg_commit "auto-$version-$target-$time",
2644 (getfield $clogp, 'Maintainer'),
2645 "Automatically generated patch ($clogp->{Version})\n".
2646 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2650 progress "quiltify linearisation planning successful, executing...";
2652 for (my $p = $sref_S;
2653 my $c = $p->{Child};
2655 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2656 next unless $p->{Nontrivial};
2658 my $cc = $c->{Commit};
2660 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2661 $commitdata =~ m/\n\n/ or die "$c ?";
2664 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2667 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2670 my $patchname = $title;
2671 $patchname =~ s/[.:]$//;
2672 $patchname =~ y/ A-Z/-a-z/;
2673 $patchname =~ y/-a-z0-9_.+=~//cd;
2674 $patchname =~ s/^\W/x-$&/;
2675 $patchname = substr($patchname,0,40);
2678 stat "debian/patches/$patchname$index";
2680 $!==ENOENT or die "$patchname$index $!";
2682 runcmd @git, qw(checkout -q), $cc;
2684 # We use the tip's changelog so that dpkg-source doesn't
2685 # produce complaining messages from dpkg-parsechangelog. None
2686 # of the information dpkg-source gets from the changelog is
2687 # actually relevant - it gets put into the original message
2688 # which dpkg-source provides our stunt editor, and then
2690 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2692 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2693 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2695 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2698 runcmd @git, qw(checkout -q master);
2701 sub build_maybe_quilt_fixup () {
2702 my $format=get_source_format;
2703 return unless madformat $format;
2706 check_for_vendor_patches();
2709 # - honour any existing .pc in case it has any strangeness
2710 # - determine the git commit corresponding to the tip of
2711 # the patch stack (if there is one)
2712 # - if there is such a git commit, convert each subsequent
2713 # git commit into a quilt patch with dpkg-source --commit
2714 # - otherwise convert all the differences in the tree into
2715 # a single git commit
2719 # Our git tree doesn't necessarily contain .pc. (Some versions of
2720 # dgit would include the .pc in the git tree.) If there isn't
2721 # one, we need to generate one by unpacking the patches that we
2724 # We first look for a .pc in the git tree. If there is one, we
2725 # will use it. (This is not the normal case.)
2727 # Otherwise need to regenerate .pc so that dpkg-source --commit
2728 # can work. We do this as follows:
2729 # 1. Collect all relevant .orig from parent directory
2730 # 2. Generate a debian.tar.gz out of
2731 # debian/{patches,rules,source/format}
2732 # 3. Generate a fake .dsc containing just these fields:
2733 # Format Source Version Files
2734 # 4. Extract the fake .dsc
2735 # Now the fake .dsc has a .pc directory.
2736 # (In fact we do this in every case, because in future we will
2737 # want to search for a good base commit for generating patches.)
2739 # Then we can actually do the dpkg-source --commit
2740 # 1. Make a new working tree with the same object
2741 # store as our main tree and check out the main
2743 # 2. Copy .pc from the fake's extraction, if necessary
2744 # 3. Run dpkg-source --commit
2745 # 4. If the result has changes to debian/, then
2746 # - git-add them them
2747 # - git-add .pc if we had a .pc in-tree
2749 # 5. If we had a .pc in-tree, delete it, and git-commit
2750 # 6. Back in the main tree, fast forward to the new HEAD
2752 my $clogp = parsechangelog();
2753 my $headref = git_rev_parse('HEAD');
2758 my $upstreamversion=$version;
2759 $upstreamversion =~ s/-[^-]*$//;
2761 my $fakeversion="$upstreamversion-~~DGITFAKE";
2763 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2764 print $fakedsc <<END or die $!;
2767 Version: $fakeversion
2771 my $dscaddfile=sub {
2774 my $md = new Digest::MD5;
2776 my $fh = new IO::File $b, '<' or die "$b $!";
2781 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2784 foreach my $f (<../../../../*>) { #/){
2785 my $b=$f; $b =~ s{.*/}{};
2786 next unless is_orig_file $b, srcfn $upstreamversion,'';
2787 link $f, $b or die "$b $!";
2791 my @files=qw(debian/source/format debian/rules);
2792 if (stat_exists '../../../debian/patches') {
2793 push @files, 'debian/patches';
2796 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2797 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2799 $dscaddfile->($debtar);
2800 close $fakedsc or die $!;
2802 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2804 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2805 rename $fakexdir, "fake" or die "$fakexdir $!";
2807 mkdir "work" or die $!;
2809 mktree_in_ud_here();
2810 runcmd @git, qw(reset --hard), $headref;
2813 if (stat_exists ".pc") {
2815 progress "Tree already contains .pc - will use it then delete it.";
2818 rename '../fake/.pc','.pc' or die $!;
2821 quiltify($clogp,$headref);
2823 if (!open P, '>>', ".pc/applied-patches") {
2824 $!==&ENOENT or die $!;
2829 commit_quilty_patch();
2831 if ($mustdeletepc) {
2832 runcmd @git, qw(rm -rqf .pc);
2833 commit_admin "Commit removal of .pc (quilt series tracking data)";
2836 changedir '../../../..';
2837 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2840 sub quilt_fixup_editor () {
2841 my $descfn = $ENV{$fakeeditorenv};
2842 my $editing = $ARGV[$#ARGV];
2843 open I1, '<', $descfn or die "$descfn: $!";
2844 open I2, '<', $editing or die "$editing: $!";
2845 unlink $editing or die "$editing: $!";
2846 open O, '>', $editing or die "$editing: $!";
2847 while (<I1>) { print O or die $!; } I1->error and die $!;
2850 $copying ||= m/^\-\-\- /;
2851 next unless $copying;
2854 I2->error and die $!;
2859 #----- other building -----
2862 if ($cleanmode eq 'dpkg-source') {
2863 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2864 } elsif ($cleanmode eq 'dpkg-source-d') {
2865 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2866 } elsif ($cleanmode eq 'git') {
2867 runcmd_ordryrun_local @git, qw(clean -xdf);
2868 } elsif ($cleanmode eq 'git-ff') {
2869 runcmd_ordryrun_local @git, qw(clean -xdff);
2870 } elsif ($cleanmode eq 'check') {
2871 my $leftovers = cmdoutput @git, qw(clean -xdn);
2872 if (length $leftovers) {
2873 print STDERR $leftovers, "\n" or die $!;
2874 fail "tree contains uncommitted files and --clean=check specified";
2876 } elsif ($cleanmode eq 'none') {
2883 badusage "clean takes no additional arguments" if @ARGV;
2890 badusage "-p is not allowed when building" if defined $package;
2893 my $clogp = parsechangelog();
2894 $isuite = getfield $clogp, 'Distribution';
2895 $package = getfield $clogp, 'Source';
2896 $version = getfield $clogp, 'Version';
2897 build_maybe_quilt_fixup();
2900 sub changesopts () {
2901 my @opts =@changesopts[1..$#changesopts];
2902 if (!defined $changes_since_version) {
2903 my @vsns = archive_query('archive_query');
2904 my @quirk = access_quirk();
2905 if ($quirk[0] eq 'backports') {
2906 local $isuite = $quirk[2];
2908 canonicalise_suite();
2909 push @vsns, archive_query('archive_query');
2912 @vsns = map { $_->[0] } @vsns;
2913 @vsns = sort { -version_compare($a, $b) } @vsns;
2914 $changes_since_version = $vsns[0];
2915 progress "changelog will contain changes since $vsns[0]";
2917 $changes_since_version = '_';
2918 progress "package seems new, not specifying -v<version>";
2921 if ($changes_since_version ne '_') {
2922 unshift @opts, "-v$changes_since_version";
2927 sub massage_dbp_args ($) {
2929 return unless $cleanmode =~ m/git|none/;
2930 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2931 my @newcmd = shift @$cmd;
2932 # -nc has the side effect of specifying -b if nothing else specified
2933 push @newcmd, '-nc';
2934 # and some combinations of -S, -b, et al, are errors, rather than
2935 # later simply overriding earlier
2936 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2937 push @newcmd, @$cmd;
2943 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2944 massage_dbp_args \@dbp;
2945 runcmd_ordryrun_local @dbp;
2946 printdone "build successful\n";
2951 my @dbp = @dpkgbuildpackage;
2952 massage_dbp_args \@dbp;
2954 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2955 "--git-builder=@dbp");
2956 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2957 canonicalise_suite();
2958 push @cmd, "--git-debian-branch=".lbranch();
2960 push @cmd, changesopts();
2961 runcmd_ordryrun_local @cmd, @ARGV;
2962 printdone "build successful\n";
2967 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2968 $dscfn = dscfn($version);
2969 if ($cleanmode eq 'dpkg-source') {
2970 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2972 } elsif ($cleanmode eq 'dpkg-source-d') {
2973 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2976 my $pwd = must_getcwd();
2977 my $leafdir = basename $pwd;
2979 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2981 runcmd_ordryrun_local qw(sh -ec),
2982 'exec >$1; shift; exec "$@"','x',
2983 "../$sourcechanges",
2984 @dpkggenchanges, qw(-S), changesopts();
2988 sub cmd_build_source {
2989 badusage "build-source takes no additional arguments" if @ARGV;
2991 printdone "source built, results in $dscfn and $sourcechanges";
2997 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2999 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3000 stat_exists $sourcechanges
3001 or fail "$sourcechanges (in parent directory): $!";
3002 foreach my $cf (glob $pat) {
3003 next if $cf eq $sourcechanges;
3004 unlink $cf or fail "remove $cf: $!";
3007 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
3008 my @changesfiles = glob $pat;
3009 @changesfiles = sort {
3010 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3013 fail "wrong number of different changes files (@changesfiles)"
3014 unless @changesfiles;
3015 runcmd_ordryrun_local @mergechanges, @changesfiles;
3016 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
3018 stat_exists $multichanges or fail "$multichanges: $!";
3020 printdone "build successful, results in $multichanges\n" or die $!;
3023 sub cmd_quilt_fixup {
3024 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3025 my $clogp = parsechangelog();
3026 $version = getfield $clogp, 'Version';
3027 $package = getfield $clogp, 'Source';
3028 build_maybe_quilt_fixup();
3031 sub cmd_archive_api_query {
3032 badusage "need only 1 subpath argument" unless @ARGV==1;
3033 my ($subpath) = @ARGV;
3034 my @cmd = archive_api_query_cmd($subpath);
3036 exec @cmd or fail "exec curl: $!\n";
3039 sub cmd_clone_dgit_repos_server {
3040 badusage "need destination argument" unless @ARGV==1;
3041 my ($destdir) = @ARGV;
3042 $package = '_dgit-repos-server';
3043 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3045 exec @cmd or fail "exec git clone: $!\n";
3048 sub cmd_setup_mergechangelogs {
3049 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3050 setup_mergechangelogs(1);
3053 sub cmd_setup_useremail {
3054 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3058 sub cmd_setup_new_tree {
3059 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3063 #---------- argument parsing and main program ----------
3066 print "dgit version $our_version\n" or die $!;
3073 if (defined $ENV{'DGIT_SSH'}) {
3074 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3075 } elsif (defined $ENV{'GIT_SSH'}) {
3076 @ssh = ($ENV{'GIT_SSH'});
3080 last unless $ARGV[0] =~ m/^-/;
3084 if (m/^--dry-run$/) {
3087 } elsif (m/^--damp-run$/) {
3090 } elsif (m/^--no-sign$/) {
3093 } elsif (m/^--help$/) {
3095 } elsif (m/^--version$/) {
3097 } elsif (m/^--new$/) {
3100 } elsif (m/^--since-version=([^_]+|_)$/) {
3102 $changes_since_version = $1;
3103 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3104 ($om = $opts_opt_map{$1}) &&
3108 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3109 !$opts_opt_cmdonly{$1} &&
3110 ($om = $opts_opt_map{$1})) {
3113 } elsif (m/^--existing-package=(.*)/s) {
3115 $existing_package = $1;
3116 } elsif (m/^--initiator-tempdir=(.*)/s) {
3117 $initiator_tempdir = $1;
3118 $initiator_tempdir =~ m#^/# or
3119 badusage "--initiator-tempdir must be used specify an".
3120 " absolute, not relative, directory."
3121 } elsif (m/^--distro=(.*)/s) {
3124 } elsif (m/^--build-products-dir=(.*)/s) {
3126 $buildproductsdir = $1;
3127 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3130 } elsif (m/^--clean=(.*)$/s) {
3131 badusage "unknown cleaning mode \`$1'";
3132 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3135 } elsif (m/^--quilt=(.*)$/s) {
3136 badusage "unknown quilt fixup mode \`$1'";
3137 } elsif (m/^--ignore-dirty$/s) {
3140 } elsif (m/^--no-quilt-fixup$/s) {
3142 $quilt_mode = 'nocheck';
3143 } elsif (m/^--no-rm-on-error$/s) {
3146 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3148 push @deliberatelies, $&;
3150 badusage "unknown long option \`$_'";
3157 } elsif (s/^-L/-/) {
3160 } elsif (s/^-h/-/) {
3162 } elsif (s/^-D/-/) {
3166 } elsif (s/^-N/-/) {
3169 } elsif (s/^-v([^_]+|_)$//s) {
3171 $changes_since_version = $1;
3174 push @changesopts, $_;
3176 } elsif (s/^-c(.*=.*)//s) {
3178 push @git, '-c', $1;
3179 } elsif (s/^-d(.+)//s) {
3182 } elsif (s/^-C(.+)//s) {
3185 if ($changesfile =~ s#^(.*)/##) {
3186 $buildproductsdir = $1;
3188 } elsif (s/^-k(.+)//s) {
3190 } elsif (m/^-[vdCk]$/) {
3192 "option \`$_' requires an argument (and no space before the argument)";
3193 } elsif (s/^-wn$//s) {
3195 $cleanmode = 'none';
3196 } elsif (s/^-wg$//s) {
3199 } elsif (s/^-wgf$//s) {
3201 $cleanmode = 'git-ff';
3202 } elsif (s/^-wd$//s) {
3204 $cleanmode = 'dpkg-source';
3205 } elsif (s/^-wdd$//s) {
3207 $cleanmode = 'dpkg-source-d';
3208 } elsif (s/^-wc$//s) {
3210 $cleanmode = 'check';
3212 badusage "unknown short option \`$_'";
3219 sub finalise_opts_opts () {
3220 foreach my $k (keys %opts_opt_map) {
3221 my $om = $opts_opt_map{$k};
3223 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3225 badcfg "cannot set command for $k"
3226 unless length $om->[0];
3230 foreach my $c (access_cfg_cfgs("opts-$k")) {
3231 my $vl = $gitcfg{$c};
3232 printdebug "CL $c ",
3233 ($vl ? join " ", map { shellquote } @$vl : ""),
3234 "\n" if $debuglevel >= 4;
3236 badcfg "cannot configure options for $k"
3237 if $opts_opt_cmdonly{$k};
3238 my $insertpos = $opts_cfg_insertpos{$k};
3239 @$om = ( @$om[0..$insertpos-1],
3241 @$om[$insertpos..$#$om] );
3246 if ($ENV{$fakeeditorenv}) {
3248 quilt_fixup_editor();
3254 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3255 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3256 if $dryrun_level == 1;
3258 print STDERR $helpmsg or die $!;
3261 my $cmd = shift @ARGV;
3264 if (!defined $quilt_mode) {
3265 local $access_forpush;
3266 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3267 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3269 $quilt_mode =~ m/^($quilt_modes_re)$/
3270 or badcfg "unknown quilt-mode \`$quilt_mode'";
3274 my $fn = ${*::}{"cmd_$cmd"};
3275 $fn or badusage "unknown operation $cmd";