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';
61 our $changes_since_version;
64 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
65 our $we_are_responder;
66 our $initiator_tempdir;
67 our $patches_applied_dirtily = 00;
69 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
71 our $suite_re = '[-+.0-9a-z]+';
72 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
74 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
75 our $splitbraincache = 'dgit-intern/quilt-cache';
78 our (@dget) = qw(dget);
79 our (@curl) = qw(curl -f);
80 our (@dput) = qw(dput);
81 our (@debsign) = qw(debsign);
83 our (@sbuild) = qw(sbuild);
85 our (@dgit) = qw(dgit);
86 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
87 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
88 our (@dpkggenchanges) = qw(dpkg-genchanges);
89 our (@mergechanges) = qw(mergechanges -f);
91 our (@changesopts) = ('');
93 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
96 'debsign' => \@debsign,
102 'dpkg-source' => \@dpkgsource,
103 'dpkg-buildpackage' => \@dpkgbuildpackage,
104 'dpkg-genchanges' => \@dpkggenchanges,
106 'ch' => \@changesopts,
107 'mergechanges' => \@mergechanges);
109 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
110 our %opts_cfg_insertpos = map {
112 scalar @{ $opts_opt_map{$_} }
113 } keys %opts_opt_map;
115 sub finalise_opts_opts();
121 our $supplementary_message = '';
122 our $need_split_build_invocation = 0;
123 our $split_brain = 0;
127 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
130 our $remotename = 'dgit';
131 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
135 sub lbranch () { return "$branchprefix/$csuite"; }
136 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
137 sub lref () { return "refs/heads/".lbranch(); }
138 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
139 sub rrref () { return server_ref($csuite); }
141 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
151 return "${package}_".(stripepoch $vsn).$sfx
156 return srcfn($vsn,".dsc");
159 sub changespat ($;$) {
160 my ($vsn, $arch) = @_;
161 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
170 foreach my $f (@end) {
172 print STDERR "$us: cleanup: $@" if length $@;
176 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
178 sub no_such_package () {
179 print STDERR "$us: package $package does not exist in suite $isuite\n";
185 return "+".rrref().":".lrref();
190 printdebug "CD $newdir\n";
191 chdir $newdir or die "chdir: $newdir: $!";
194 sub deliberately ($) {
196 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
199 sub deliberately_not_fast_forward () {
200 foreach (qw(not-fast-forward fresh-repo)) {
201 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
205 sub quiltmode_splitbrain () {
206 $quilt_mode =~ m/gbp|dpm|unapplied/;
209 #---------- remote protocol support, common ----------
211 # remote push initiator/responder protocol:
212 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
213 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
214 # < dgit-remote-push-ready <actual-proto-vsn>
216 # > file parsed-changelog
217 # [indicates that output of dpkg-parsechangelog follows]
218 # > data-block NBYTES
219 # > [NBYTES bytes of data (no newline)]
220 # [maybe some more blocks]
232 # [indicates that signed tag is wanted]
233 # < data-block NBYTES
234 # < [NBYTES bytes of data (no newline)]
235 # [maybe some more blocks]
239 # > want signed-dsc-changes
240 # < data-block NBYTES [transfer of signed dsc]
242 # < data-block NBYTES [transfer of signed changes]
250 sub i_child_report () {
251 # Sees if our child has died, and reap it if so. Returns a string
252 # describing how it died if it failed, or undef otherwise.
253 return undef unless $i_child_pid;
254 my $got = waitpid $i_child_pid, WNOHANG;
255 return undef if $got <= 0;
256 die unless $got == $i_child_pid;
257 $i_child_pid = undef;
258 return undef unless $?;
259 return "build host child ".waitstatusmsg();
264 fail "connection lost: $!" if $fh->error;
265 fail "protocol violation; $m not expected";
268 sub badproto_badread ($$) {
270 fail "connection lost: $!" if $!;
271 my $report = i_child_report();
272 fail $report if defined $report;
273 badproto $fh, "eof (reading $wh)";
276 sub protocol_expect (&$) {
277 my ($match, $fh) = @_;
280 defined && chomp or badproto_badread $fh, "protocol message";
288 badproto $fh, "\`$_'";
291 sub protocol_send_file ($$) {
292 my ($fh, $ourfn) = @_;
293 open PF, "<", $ourfn or die "$ourfn: $!";
296 my $got = read PF, $d, 65536;
297 die "$ourfn: $!" unless defined $got;
299 print $fh "data-block ".length($d)."\n" or die $!;
300 print $fh $d or die $!;
302 PF->error and die "$ourfn $!";
303 print $fh "data-end\n" or die $!;
307 sub protocol_read_bytes ($$) {
308 my ($fh, $nbytes) = @_;
309 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
311 my $got = read $fh, $d, $nbytes;
312 $got==$nbytes or badproto_badread $fh, "data block";
316 sub protocol_receive_file ($$) {
317 my ($fh, $ourfn) = @_;
318 printdebug "() $ourfn\n";
319 open PF, ">", $ourfn or die "$ourfn: $!";
321 my ($y,$l) = protocol_expect {
322 m/^data-block (.*)$/ ? (1,$1) :
323 m/^data-end$/ ? (0,) :
327 my $d = protocol_read_bytes $fh, $l;
328 print PF $d or die $!;
333 #---------- remote protocol support, responder ----------
335 sub responder_send_command ($) {
337 return unless $we_are_responder;
338 # called even without $we_are_responder
339 printdebug ">> $command\n";
340 print PO $command, "\n" or die $!;
343 sub responder_send_file ($$) {
344 my ($keyword, $ourfn) = @_;
345 return unless $we_are_responder;
346 printdebug "]] $keyword $ourfn\n";
347 responder_send_command "file $keyword";
348 protocol_send_file \*PO, $ourfn;
351 sub responder_receive_files ($@) {
352 my ($keyword, @ourfns) = @_;
353 die unless $we_are_responder;
354 printdebug "[[ $keyword @ourfns\n";
355 responder_send_command "want $keyword";
356 foreach my $fn (@ourfns) {
357 protocol_receive_file \*PI, $fn;
360 protocol_expect { m/^files-end$/ } \*PI;
363 #---------- remote protocol support, initiator ----------
365 sub initiator_expect (&) {
367 protocol_expect { &$match } \*RO;
370 #---------- end remote code ----------
373 if ($we_are_responder) {
375 responder_send_command "progress ".length($m) or die $!;
376 print PO $m or die $!;
386 $ua = LWP::UserAgent->new();
390 progress "downloading $what...";
391 my $r = $ua->get(@_) or die $!;
392 return undef if $r->code == 404;
393 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
394 return $r->decoded_content(charset => 'none');
397 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
402 failedcmd @_ if system @_;
405 sub act_local () { return $dryrun_level <= 1; }
406 sub act_scary () { return !$dryrun_level; }
409 if (!$dryrun_level) {
410 progress "dgit ok: @_";
412 progress "would be ok: @_ (but dry run only)";
417 printcmd(\*STDERR,$debugprefix."#",@_);
420 sub runcmd_ordryrun {
428 sub runcmd_ordryrun_local {
437 my ($first_shell, @cmd) = @_;
438 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
441 our $helpmsg = <<END;
443 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
444 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
445 dgit [dgit-opts] build [dpkg-buildpackage-opts]
446 dgit [dgit-opts] sbuild [sbuild-opts]
447 dgit [dgit-opts] push [dgit-opts] [suite]
448 dgit [dgit-opts] rpush build-host:build-dir ...
449 important dgit options:
450 -k<keyid> sign tag and package with <keyid> instead of default
451 --dry-run -n do not change anything, but go through the motions
452 --damp-run -L like --dry-run but make local changes, without signing
453 --new -N allow introducing a new package
454 --debug -D increase debug level
455 -c<name>=<value> set git config option (used directly by dgit too)
458 our $later_warning_msg = <<END;
459 Perhaps the upload is stuck in incoming. Using the version from git.
463 print STDERR "$us: @_\n", $helpmsg or die $!;
468 @ARGV or badusage "too few arguments";
469 return scalar shift @ARGV;
473 print $helpmsg or die $!;
477 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
479 our %defcfg = ('dgit.default.distro' => 'debian',
480 'dgit.default.username' => '',
481 'dgit.default.archive-query-default-component' => 'main',
482 'dgit.default.ssh' => 'ssh',
483 'dgit.default.archive-query' => 'madison:',
484 'dgit.default.sshpsql-dbname' => 'service=projectb',
485 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
486 'dgit-distro.debian.git-check' => 'url',
487 'dgit-distro.debian.git-check-suffix' => '/info/refs',
488 'dgit-distro.debian.new-private-pushers' => 't',
489 'dgit-distro.debian/push.git-url' => '',
490 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
491 'dgit-distro.debian/push.git-user-force' => 'dgit',
492 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
493 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
494 'dgit-distro.debian/push.git-create' => 'true',
495 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
496 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
497 # 'dgit-distro.debian.archive-query-tls-key',
498 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
499 # ^ this does not work because curl is broken nowadays
500 # Fixing #790093 properly will involve providing providing the key
501 # in some pacagke and maybe updating these paths.
503 # 'dgit-distro.debian.archive-query-tls-curl-args',
504 # '--ca-path=/etc/ssl/ca-debian',
505 # ^ this is a workaround but works (only) on DSA-administered machines
506 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
507 'dgit-distro.debian.git-url-suffix' => '',
508 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
509 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
510 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
511 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
512 'dgit-distro.ubuntu.git-check' => 'false',
513 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
514 'dgit-distro.test-dummy.ssh' => "$td/ssh",
515 'dgit-distro.test-dummy.username' => "alice",
516 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
517 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
518 'dgit-distro.test-dummy.git-url' => "$td/git",
519 'dgit-distro.test-dummy.git-host' => "git",
520 'dgit-distro.test-dummy.git-path' => "$td/git",
521 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
522 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
523 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
524 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
529 sub git_slurp_config () {
530 local ($debuglevel) = $debuglevel-2;
533 my @cmd = (@git, qw(config -z --get-regexp .*));
536 open GITS, "-|", @cmd or failedcmd @cmd;
539 printdebug "=> ", (messagequote $_), "\n";
541 push @{ $gitcfg{$`} }, $'; #';
545 or ($!==0 && $?==256)
549 sub git_get_config ($) {
552 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
555 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
561 return undef if $c =~ /RETURN-UNDEF/;
562 my $v = git_get_config($c);
563 return $v if defined $v;
564 my $dv = $defcfg{$c};
565 return $dv if defined $dv;
567 badcfg "need value for one of: @_\n".
568 "$us: distro or suite appears not to be (properly) supported";
571 sub access_basedistro () {
572 if (defined $idistro) {
575 return cfg("dgit-suite.$isuite.distro",
576 "dgit.default.distro");
580 sub access_quirk () {
581 # returns (quirk name, distro to use instead or undef, quirk-specific info)
582 my $basedistro = access_basedistro();
583 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
585 if (defined $backports_quirk) {
586 my $re = $backports_quirk;
587 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
589 $re =~ s/\%/([-0-9a-z_]+)/
590 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
591 if ($isuite =~ m/^$re$/) {
592 return ('backports',"$basedistro-backports",$1);
595 return ('none',undef);
600 sub parse_cfg_bool ($$$) {
601 my ($what,$def,$v) = @_;
604 $v =~ m/^[ty1]/ ? 1 :
605 $v =~ m/^[fn0]/ ? 0 :
606 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
609 sub access_forpush_config () {
610 my $d = access_basedistro();
614 parse_cfg_bool('new-private-pushers', 0,
615 cfg("dgit-distro.$d.new-private-pushers",
618 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
621 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
622 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
623 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
624 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
627 sub access_forpush () {
628 $access_forpush //= access_forpush_config();
629 return $access_forpush;
633 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
634 badcfg "pushing but distro is configured readonly"
635 if access_forpush_config() eq '0';
637 $supplementary_message = <<'END' unless $we_are_responder;
638 Push failed, before we got started.
639 You can retry the push, after fixing the problem, if you like.
641 finalise_opts_opts();
645 finalise_opts_opts();
648 sub supplementary_message ($) {
650 if (!$we_are_responder) {
651 $supplementary_message = $msg;
653 } elsif ($protovsn >= 3) {
654 responder_send_command "supplementary-message ".length($msg)
656 print PO $msg or die $!;
660 sub access_distros () {
661 # Returns list of distros to try, in order
664 # 0. `instead of' distro name(s) we have been pointed to
665 # 1. the access_quirk distro, if any
666 # 2a. the user's specified distro, or failing that } basedistro
667 # 2b. the distro calculated from the suite }
668 my @l = access_basedistro();
670 my (undef,$quirkdistro) = access_quirk();
671 unshift @l, $quirkdistro;
672 unshift @l, $instead_distro;
673 @l = grep { defined } @l;
675 if (access_forpush()) {
676 @l = map { ("$_/push", $_) } @l;
681 sub access_cfg_cfgs (@) {
684 # The nesting of these loops determines the search order. We put
685 # the key loop on the outside so that we search all the distros
686 # for each key, before going on to the next key. That means that
687 # if access_cfg is called with a more specific, and then a less
688 # specific, key, an earlier distro can override the less specific
689 # without necessarily overriding any more specific keys. (If the
690 # distro wants to override the more specific keys it can simply do
691 # so; whereas if we did the loop the other way around, it would be
692 # impossible to for an earlier distro to override a less specific
693 # key but not the more specific ones without restating the unknown
694 # values of the more specific keys.
697 # We have to deal with RETURN-UNDEF specially, so that we don't
698 # terminate the search prematurely.
700 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
703 foreach my $d (access_distros()) {
704 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
706 push @cfgs, map { "dgit.default.$_" } @realkeys;
713 my (@cfgs) = access_cfg_cfgs(@keys);
714 my $value = cfg(@cfgs);
718 sub access_cfg_bool ($$) {
719 my ($def, @keys) = @_;
720 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
723 sub string_to_ssh ($) {
725 if ($spec =~ m/\s/) {
726 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
732 sub access_cfg_ssh () {
733 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
734 if (!defined $gitssh) {
737 return string_to_ssh $gitssh;
741 sub access_runeinfo ($) {
743 return ": dgit ".access_basedistro()." $info ;";
746 sub access_someuserhost ($) {
748 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
749 defined($user) && length($user) or
750 $user = access_cfg("$some-user",'username');
751 my $host = access_cfg("$some-host");
752 return length($user) ? "$user\@$host" : $host;
755 sub access_gituserhost () {
756 return access_someuserhost('git');
759 sub access_giturl (;$) {
761 my $url = access_cfg('git-url','RETURN-UNDEF');
764 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
765 return undef unless defined $proto;
768 access_gituserhost().
769 access_cfg('git-path');
771 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
774 return "$url/$package$suffix";
777 sub parsecontrolfh ($$;$) {
778 my ($fh, $desc, $allowsigned) = @_;
779 our $dpkgcontrolhash_noissigned;
782 my %opts = ('name' => $desc);
783 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
784 $c = Dpkg::Control::Hash->new(%opts);
785 $c->parse($fh,$desc) or die "parsing of $desc failed";
786 last if $allowsigned;
787 last if $dpkgcontrolhash_noissigned;
788 my $issigned= $c->get_option('is_pgp_signed');
789 if (!defined $issigned) {
790 $dpkgcontrolhash_noissigned= 1;
791 seek $fh, 0,0 or die "seek $desc: $!";
792 } elsif ($issigned) {
793 fail "control file $desc is (already) PGP-signed. ".
794 " Note that dgit push needs to modify the .dsc and then".
795 " do the signature itself";
804 my ($file, $desc) = @_;
805 my $fh = new IO::Handle;
806 open $fh, '<', $file or die "$file: $!";
807 my $c = parsecontrolfh($fh,$desc);
808 $fh->error and die $!;
814 my ($dctrl,$field) = @_;
815 my $v = $dctrl->{$field};
816 return $v if defined $v;
817 fail "missing field $field in ".$v->get_option('name');
821 my $c = Dpkg::Control::Hash->new();
822 my $p = new IO::Handle;
823 my @cmd = (qw(dpkg-parsechangelog), @_);
824 open $p, '-|', @cmd or die $!;
826 $?=0; $!=0; close $p or failedcmd @cmd;
832 defined $d or fail "getcwd failed: $!";
838 sub archive_query ($) {
840 my $query = access_cfg('archive-query','RETURN-UNDEF');
841 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
844 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
847 sub pool_dsc_subpath ($$) {
848 my ($vsn,$component) = @_; # $package is implict arg
849 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
850 return "/pool/$component/$prefix/$package/".dscfn($vsn);
853 #---------- `ftpmasterapi' archive query method (nascent) ----------
855 sub archive_api_query_cmd ($) {
857 my @cmd = qw(curl -sS);
858 my $url = access_cfg('archive-query-url');
859 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
861 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
862 foreach my $key (split /\:/, $keys) {
863 $key =~ s/\%HOST\%/$host/g;
865 fail "for $url: stat $key: $!" unless $!==ENOENT;
868 fail "config requested specific TLS key but do not know".
869 " how to get curl to use exactly that EE key ($key)";
870 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
871 # # Sadly the above line does not work because of changes
872 # # to gnutls. The real fix for #790093 may involve
873 # # new curl options.
876 # Fixing #790093 properly will involve providing a value
877 # for this on clients.
878 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
879 push @cmd, split / /, $kargs if defined $kargs;
881 push @cmd, $url.$subpath;
887 my ($data, $subpath) = @_;
888 badcfg "ftpmasterapi archive query method takes no data part"
890 my @cmd = archive_api_query_cmd($subpath);
891 my $json = cmdoutput @cmd;
892 return decode_json($json);
895 sub canonicalise_suite_ftpmasterapi () {
896 my ($proto,$data) = @_;
897 my $suites = api_query($data, 'suites');
899 foreach my $entry (@$suites) {
901 my $v = $entry->{$_};
902 defined $v && $v eq $isuite;
904 push @matched, $entry;
906 fail "unknown suite $isuite" unless @matched;
909 @matched==1 or die "multiple matches for suite $isuite\n";
910 $cn = "$matched[0]{codename}";
911 defined $cn or die "suite $isuite info has no codename\n";
912 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
914 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
919 sub archive_query_ftpmasterapi () {
920 my ($proto,$data) = @_;
921 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
923 my $digester = Digest::SHA->new(256);
924 foreach my $entry (@$info) {
926 my $vsn = "$entry->{version}";
927 my ($ok,$msg) = version_check $vsn;
928 die "bad version: $msg\n" unless $ok;
929 my $component = "$entry->{component}";
930 $component =~ m/^$component_re$/ or die "bad component";
931 my $filename = "$entry->{filename}";
932 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
933 or die "bad filename";
934 my $sha256sum = "$entry->{sha256sum}";
935 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
936 push @rows, [ $vsn, "/pool/$component/$filename",
937 $digester, $sha256sum ];
939 die "bad ftpmaster api response: $@\n".Dumper($entry)
942 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
946 #---------- `madison' archive query method ----------
948 sub archive_query_madison {
949 return map { [ @$_[0..1] ] } madison_get_parse(@_);
952 sub madison_get_parse {
953 my ($proto,$data) = @_;
954 die unless $proto eq 'madison';
956 $data= access_cfg('madison-distro','RETURN-UNDEF');
957 $data //= access_basedistro();
959 $rmad{$proto,$data,$package} ||= cmdoutput
960 qw(rmadison -asource),"-s$isuite","-u$data",$package;
961 my $rmad = $rmad{$proto,$data,$package};
964 foreach my $l (split /\n/, $rmad) {
965 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
966 \s*( [^ \t|]+ )\s* \|
967 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
968 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
969 $1 eq $package or die "$rmad $package ?";
976 $component = access_cfg('archive-query-default-component');
978 $5 eq 'source' or die "$rmad ?";
979 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
981 return sort { -version_compare($a->[0],$b->[0]); } @out;
984 sub canonicalise_suite_madison {
985 # madison canonicalises for us
986 my @r = madison_get_parse(@_);
988 "unable to canonicalise suite using package $package".
989 " which does not appear to exist in suite $isuite;".
990 " --existing-package may help";
994 #---------- `sshpsql' archive query method ----------
997 my ($data,$runeinfo,$sql) = @_;
999 $data= access_someuserhost('sshpsql').':'.
1000 access_cfg('sshpsql-dbname');
1002 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1003 my ($userhost,$dbname) = ($`,$'); #';
1005 my @cmd = (access_cfg_ssh, $userhost,
1006 access_runeinfo("ssh-psql $runeinfo").
1007 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1008 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1010 open P, "-|", @cmd or die $!;
1013 printdebug(">|$_|\n");
1016 $!=0; $?=0; close P or failedcmd @cmd;
1018 my $nrows = pop @rows;
1019 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1020 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1021 @rows = map { [ split /\|/, $_ ] } @rows;
1022 my $ncols = scalar @{ shift @rows };
1023 die if grep { scalar @$_ != $ncols } @rows;
1027 sub sql_injection_check {
1028 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1031 sub archive_query_sshpsql ($$) {
1032 my ($proto,$data) = @_;
1033 sql_injection_check $isuite, $package;
1034 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1035 SELECT source.version, component.name, files.filename, files.sha256sum
1037 JOIN src_associations ON source.id = src_associations.source
1038 JOIN suite ON suite.id = src_associations.suite
1039 JOIN dsc_files ON dsc_files.source = source.id
1040 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1041 JOIN component ON component.id = files_archive_map.component_id
1042 JOIN files ON files.id = dsc_files.file
1043 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1044 AND source.source='$package'
1045 AND files.filename LIKE '%.dsc';
1047 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1048 my $digester = Digest::SHA->new(256);
1050 my ($vsn,$component,$filename,$sha256sum) = @$_;
1051 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1056 sub canonicalise_suite_sshpsql ($$) {
1057 my ($proto,$data) = @_;
1058 sql_injection_check $isuite;
1059 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1060 SELECT suite.codename
1061 FROM suite where suite_name='$isuite' or codename='$isuite';
1063 @rows = map { $_->[0] } @rows;
1064 fail "unknown suite $isuite" unless @rows;
1065 die "ambiguous $isuite: @rows ?" if @rows>1;
1069 #---------- `dummycat' archive query method ----------
1071 sub canonicalise_suite_dummycat ($$) {
1072 my ($proto,$data) = @_;
1073 my $dpath = "$data/suite.$isuite";
1074 if (!open C, "<", $dpath) {
1075 $!==ENOENT or die "$dpath: $!";
1076 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1080 chomp or die "$dpath: $!";
1082 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1086 sub archive_query_dummycat ($$) {
1087 my ($proto,$data) = @_;
1088 canonicalise_suite();
1089 my $dpath = "$data/package.$csuite.$package";
1090 if (!open C, "<", $dpath) {
1091 $!==ENOENT or die "$dpath: $!";
1092 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1100 printdebug "dummycat query $csuite $package $dpath | $_\n";
1101 my @row = split /\s+/, $_;
1102 @row==2 or die "$dpath: $_ ?";
1105 C->error and die "$dpath: $!";
1107 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1110 #---------- archive query entrypoints and rest of program ----------
1112 sub canonicalise_suite () {
1113 return if defined $csuite;
1114 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1115 $csuite = archive_query('canonicalise_suite');
1116 if ($isuite ne $csuite) {
1117 progress "canonical suite name for $isuite is $csuite";
1121 sub get_archive_dsc () {
1122 canonicalise_suite();
1123 my @vsns = archive_query('archive_query');
1124 foreach my $vinfo (@vsns) {
1125 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1126 $dscurl = access_cfg('mirror').$subpath;
1127 $dscdata = url_get($dscurl);
1129 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1134 $digester->add($dscdata);
1135 my $got = $digester->hexdigest();
1137 fail "$dscurl has hash $got but".
1138 " archive told us to expect $digest";
1140 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1141 printdebug Dumper($dscdata) if $debuglevel>1;
1142 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1143 printdebug Dumper($dsc) if $debuglevel>1;
1144 my $fmt = getfield $dsc, 'Format';
1145 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1146 $dsc_checked = !!$digester;
1152 sub check_for_git ();
1153 sub check_for_git () {
1155 my $how = access_cfg('git-check');
1156 if ($how eq 'ssh-cmd') {
1158 (access_cfg_ssh, access_gituserhost(),
1159 access_runeinfo("git-check $package").
1160 " set -e; cd ".access_cfg('git-path').";".
1161 " if test -d $package.git; then echo 1; else echo 0; fi");
1162 my $r= cmdoutput @cmd;
1163 if ($r =~ m/^divert (\w+)$/) {
1165 my ($usedistro,) = access_distros();
1166 # NB that if we are pushing, $usedistro will be $distro/push
1167 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1168 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1169 progress "diverting to $divert (using config for $instead_distro)";
1170 return check_for_git();
1172 failedcmd @cmd unless $r =~ m/^[01]$/;
1174 } elsif ($how eq 'url') {
1175 my $prefix = access_cfg('git-check-url','git-url');
1176 my $suffix = access_cfg('git-check-suffix','git-suffix',
1177 'RETURN-UNDEF') // '.git';
1178 my $url = "$prefix/$package$suffix";
1179 my @cmd = (qw(curl -sS -I), $url);
1180 my $result = cmdoutput @cmd;
1181 $result =~ s/^\S+ 200 .*\n\r?\n//;
1182 # curl -sS -I with https_proxy prints
1183 # HTTP/1.0 200 Connection established
1184 $result =~ m/^\S+ (404|200) /s or
1185 fail "unexpected results from git check query - ".
1186 Dumper($prefix, $result);
1188 if ($code eq '404') {
1190 } elsif ($code eq '200') {
1195 } elsif ($how eq 'true') {
1197 } elsif ($how eq 'false') {
1200 badcfg "unknown git-check \`$how'";
1204 sub create_remote_git_repo () {
1205 my $how = access_cfg('git-create');
1206 if ($how eq 'ssh-cmd') {
1208 (access_cfg_ssh, access_gituserhost(),
1209 access_runeinfo("git-create $package").
1210 "set -e; cd ".access_cfg('git-path').";".
1211 " cp -a _template $package.git");
1212 } elsif ($how eq 'true') {
1215 badcfg "unknown git-create \`$how'";
1219 our ($dsc_hash,$lastpush_hash);
1221 our $ud = '.git/dgit/unpack';
1231 sub mktree_in_ud_here () {
1232 runcmd qw(git init -q);
1233 rmtree('.git/objects');
1234 symlink '../../../../objects','.git/objects' or die $!;
1237 sub git_write_tree () {
1238 my $tree = cmdoutput @git, qw(write-tree);
1239 $tree =~ m/^\w+$/ or die "$tree ?";
1243 sub remove_stray_gits () {
1244 my @gitscmd = qw(find -name .git -prune -print0);
1245 debugcmd "|",@gitscmd;
1246 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1251 print STDERR "$us: warning: removing from source package: ",
1252 (messagequote $_), "\n";
1256 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1259 sub mktree_in_ud_from_only_subdir () {
1260 # changes into the subdir
1262 die unless @dirs==1;
1263 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1267 remove_stray_gits();
1268 mktree_in_ud_here();
1269 my ($format, $fopts) = get_source_format();
1270 if (madformat($format)) {
1273 runcmd @git, qw(add -Af);
1274 my $tree=git_write_tree();
1275 return ($tree,$dir);
1278 sub dsc_files_info () {
1279 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1280 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1281 ['Files', 'Digest::MD5', 'new()']) {
1282 my ($fname, $module, $method) = @$csumi;
1283 my $field = $dsc->{$fname};
1284 next unless defined $field;
1285 eval "use $module; 1;" or die $@;
1287 foreach (split /\n/, $field) {
1289 m/^(\w+) (\d+) (\S+)$/ or
1290 fail "could not parse .dsc $fname line \`$_'";
1291 my $digester = eval "$module"."->$method;" or die $@;
1296 Digester => $digester,
1301 fail "missing any supported Checksums-* or Files field in ".
1302 $dsc->get_option('name');
1306 map { $_->{Filename} } dsc_files_info();
1309 sub is_orig_file ($;$) {
1312 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1313 defined $base or return 1;
1317 sub make_commit ($) {
1319 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1322 sub clogp_authline ($) {
1324 my $author = getfield $clogp, 'Maintainer';
1325 $author =~ s#,.*##ms;
1326 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1327 my $authline = "$author $date";
1328 $authline =~ m/$git_authline_re/o or
1329 fail "unexpected commit author line format \`$authline'".
1330 " (was generated from changelog Maintainer field)";
1331 return ($1,$2,$3) if wantarray;
1335 sub vendor_patches_distro ($$) {
1336 my ($checkdistro, $what) = @_;
1337 return unless defined $checkdistro;
1339 my $series = "debian/patches/\L$checkdistro\E.series";
1340 printdebug "checking for vendor-specific $series ($what)\n";
1342 if (!open SERIES, "<", $series) {
1343 die "$series $!" unless $!==ENOENT;
1352 Unfortunately, this source package uses a feature of dpkg-source where
1353 the same source package unpacks to different source code on different
1354 distros. dgit cannot safely operate on such packages on affected
1355 distros, because the meaning of source packages is not stable.
1357 Please ask the distro/maintainer to remove the distro-specific series
1358 files and use a different technique (if necessary, uploading actually
1359 different packages, if different distros are supposed to have
1363 fail "Found active distro-specific series file for".
1364 " $checkdistro ($what): $series, cannot continue";
1366 die "$series $!" if SERIES->error;
1370 sub check_for_vendor_patches () {
1371 # This dpkg-source feature doesn't seem to be documented anywhere!
1372 # But it can be found in the changelog (reformatted):
1374 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1375 # Author: Raphael Hertzog <hertzog@debian.org>
1376 # Date: Sun Oct 3 09:36:48 2010 +0200
1378 # dpkg-source: correctly create .pc/.quilt_series with alternate
1381 # If you have debian/patches/ubuntu.series and you were
1382 # unpacking the source package on ubuntu, quilt was still
1383 # directed to debian/patches/series instead of
1384 # debian/patches/ubuntu.series.
1386 # debian/changelog | 3 +++
1387 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1388 # 2 files changed, 6 insertions(+), 1 deletion(-)
1391 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1392 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1393 "Dpkg::Vendor \`current vendor'");
1394 vendor_patches_distro(access_basedistro(),
1395 "distro being accessed");
1398 sub generate_commit_from_dsc () {
1402 foreach my $fi (dsc_files_info()) {
1403 my $f = $fi->{Filename};
1404 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1406 link_ltarget "../../../$f", $f
1410 complete_file_from_dsc('.', $fi)
1413 if (is_orig_file($f)) {
1414 link $f, "../../../../$f"
1420 my $dscfn = "$package.dsc";
1422 open D, ">", $dscfn or die "$dscfn: $!";
1423 print D $dscdata or die "$dscfn: $!";
1424 close D or die "$dscfn: $!";
1425 my @cmd = qw(dpkg-source);
1426 push @cmd, '--no-check' if $dsc_checked;
1427 push @cmd, qw(-x --), $dscfn;
1430 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1431 check_for_vendor_patches() if madformat($dsc->{format});
1432 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1433 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1434 my $authline = clogp_authline $clogp;
1435 my $changes = getfield $clogp, 'Changes';
1436 open C, ">../commit.tmp" or die $!;
1437 print C <<END or die $!;
1444 # imported from the archive
1447 my $outputhash = make_commit qw(../commit.tmp);
1448 my $cversion = getfield $clogp, 'Version';
1449 progress "synthesised git commit from .dsc $cversion";
1450 if ($lastpush_hash) {
1451 runcmd @git, qw(reset -q --hard), $lastpush_hash;
1452 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1453 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1454 my $oversion = getfield $oldclogp, 'Version';
1456 version_compare($oversion, $cversion);
1458 # git upload/ is earlier vsn than archive, use archive
1459 open C, ">../commit2.tmp" or die $!;
1460 print C <<END or die $!;
1462 parent $lastpush_hash
1467 Record $package ($cversion) in archive suite $csuite
1469 $outputhash = make_commit qw(../commit2.tmp);
1470 } elsif ($vcmp > 0) {
1471 print STDERR <<END or die $!;
1473 Version actually in archive: $cversion (older)
1474 Last allegedly pushed/uploaded: $oversion (newer or same)
1477 $outputhash = $lastpush_hash;
1479 $outputhash = $lastpush_hash;
1482 changedir '../../../..';
1483 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1484 'DGIT_ARCHIVE', $outputhash;
1485 cmdoutput @git, qw(log -n2), $outputhash;
1486 # ... gives git a chance to complain if our commit is malformed
1491 sub complete_file_from_dsc ($$) {
1492 our ($dstdir, $fi) = @_;
1493 # Ensures that we have, in $dir, the file $fi, with the correct
1494 # contents. (Downloading it from alongside $dscurl if necessary.)
1496 my $f = $fi->{Filename};
1497 my $tf = "$dstdir/$f";
1500 if (stat_exists $tf) {
1501 progress "using existing $f";
1504 $furl =~ s{/[^/]+$}{};
1506 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1507 die "$f ?" if $f =~ m#/#;
1508 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1509 return 0 if !act_local();
1513 open F, "<", "$tf" or die "$tf: $!";
1514 $fi->{Digester}->reset();
1515 $fi->{Digester}->addfile(*F);
1516 F->error and die $!;
1517 my $got = $fi->{Digester}->hexdigest();
1518 $got eq $fi->{Hash} or
1519 fail "file $f has hash $got but .dsc".
1520 " demands hash $fi->{Hash} ".
1521 ($downloaded ? "(got wrong file from archive!)"
1522 : "(perhaps you should delete this file?)");
1527 sub ensure_we_have_orig () {
1528 foreach my $fi (dsc_files_info()) {
1529 my $f = $fi->{Filename};
1530 next unless is_orig_file($f);
1531 complete_file_from_dsc('..', $fi)
1536 sub git_fetch_us () {
1537 my @specs = (fetchspec());
1539 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1541 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1544 my $tagpat = debiantag('*',access_basedistro);
1546 git_for_each_ref("refs/tags/".$tagpat, sub {
1547 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1548 printdebug "currently $fullrefname=$objid\n";
1549 $here{$fullrefname} = $objid;
1551 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1552 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1553 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1554 printdebug "offered $lref=$objid\n";
1555 if (!defined $here{$lref}) {
1556 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1557 runcmd_ordryrun_local @upd;
1558 } elsif ($here{$lref} eq $objid) {
1561 "Not updateting $lref from $here{$lref} to $objid.\n";
1566 sub fetch_from_archive () {
1567 # ensures that lrref() is what is actually in the archive,
1568 # one way or another
1572 foreach my $field (@ourdscfield) {
1573 $dsc_hash = $dsc->{$field};
1574 last if defined $dsc_hash;
1576 if (defined $dsc_hash) {
1577 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1579 progress "last upload to archive specified git hash";
1581 progress "last upload to archive has NO git hash";
1584 progress "no version available from the archive";
1587 $lastpush_hash = git_get_ref(lrref());
1588 printdebug "previous reference hash=$lastpush_hash\n";
1590 if (defined $dsc_hash) {
1591 fail "missing remote git history even though dsc has hash -".
1592 " could not find ref ".lrref().
1593 " (should have been fetched from ".access_giturl()."#".rrref().")"
1594 unless $lastpush_hash;
1596 ensure_we_have_orig();
1597 if ($dsc_hash eq $lastpush_hash) {
1598 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1599 print STDERR <<END or die $!;
1601 Git commit in archive is behind the last version allegedly pushed/uploaded.
1602 Commit referred to by archive: $dsc_hash
1603 Last allegedly pushed/uploaded: $lastpush_hash
1606 $hash = $lastpush_hash;
1608 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1609 "descendant of archive's .dsc hash ($dsc_hash)";
1612 $hash = generate_commit_from_dsc();
1613 } elsif ($lastpush_hash) {
1614 # only in git, not in the archive yet
1615 $hash = $lastpush_hash;
1616 print STDERR <<END or die $!;
1618 Package not found in the archive, but has allegedly been pushed using dgit.
1622 printdebug "nothing found!\n";
1623 if (defined $skew_warning_vsn) {
1624 print STDERR <<END or die $!;
1626 Warning: relevant archive skew detected.
1627 Archive allegedly contains $skew_warning_vsn
1628 But we were not able to obtain any version from the archive or git.
1634 printdebug "current hash=$hash\n";
1635 if ($lastpush_hash) {
1636 fail "not fast forward on last upload branch!".
1637 " (archive's version left in DGIT_ARCHIVE)"
1638 unless is_fast_fwd($lastpush_hash, $hash);
1640 if (defined $skew_warning_vsn) {
1642 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1643 my $clogf = ".git/dgit/changelog.tmp";
1644 runcmd shell_cmd "exec >$clogf",
1645 @git, qw(cat-file blob), "$hash:debian/changelog";
1646 my $gotclogp = parsechangelog("-l$clogf");
1647 my $got_vsn = getfield $gotclogp, 'Version';
1648 printdebug "SKEW CHECK GOT $got_vsn\n";
1649 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1650 print STDERR <<END or die $!;
1652 Warning: archive skew detected. Using the available version:
1653 Archive allegedly contains $skew_warning_vsn
1654 We were able to obtain only $got_vsn
1659 if ($lastpush_hash ne $hash) {
1660 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1664 dryrun_report @upd_cmd;
1670 sub set_local_git_config ($$) {
1672 runcmd @git, qw(config), $k, $v;
1675 sub setup_mergechangelogs (;$) {
1677 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1679 my $driver = 'dpkg-mergechangelogs';
1680 my $cb = "merge.$driver";
1681 my $attrs = '.git/info/attributes';
1682 ensuredir '.git/info';
1684 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1685 if (!open ATTRS, "<", $attrs) {
1686 $!==ENOENT or die "$attrs: $!";
1690 next if m{^debian/changelog\s};
1691 print NATTRS $_, "\n" or die $!;
1693 ATTRS->error and die $!;
1696 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1699 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1700 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1702 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1705 sub setup_useremail (;$) {
1707 return unless $always || access_cfg_bool(1, 'setup-useremail');
1710 my ($k, $envvar) = @_;
1711 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1712 return unless defined $v;
1713 set_local_git_config "user.$k", $v;
1716 $setup->('email', 'DEBEMAIL');
1717 $setup->('name', 'DEBFULLNAME');
1720 sub setup_new_tree () {
1721 setup_mergechangelogs();
1727 canonicalise_suite();
1728 badusage "dry run makes no sense with clone" unless act_local();
1729 my $hasgit = check_for_git();
1730 mkdir $dstdir or fail "create \`$dstdir': $!";
1732 runcmd @git, qw(init -q);
1733 my $giturl = access_giturl(1);
1734 if (defined $giturl) {
1735 set_local_git_config "remote.$remotename.fetch", fetchspec();
1736 open H, "> .git/HEAD" or die $!;
1737 print H "ref: ".lref()."\n" or die $!;
1739 runcmd @git, qw(remote add), 'origin', $giturl;
1742 progress "fetching existing git history";
1744 runcmd_ordryrun_local @git, qw(fetch origin);
1746 progress "starting new git history";
1748 fetch_from_archive() or no_such_package;
1749 my $vcsgiturl = $dsc->{'Vcs-Git'};
1750 if (length $vcsgiturl) {
1751 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1752 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1755 runcmd @git, qw(reset --hard), lrref();
1756 printdone "ready for work in $dstdir";
1760 if (check_for_git()) {
1763 fetch_from_archive() or no_such_package();
1764 printdone "fetched into ".lrref();
1769 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1771 printdone "fetched to ".lrref()." and merged into HEAD";
1774 sub check_not_dirty () {
1775 foreach my $f (qw(local-options local-patch-header)) {
1776 if (stat_exists "debian/source/$f") {
1777 fail "git tree contains debian/source/$f";
1781 return if $ignoredirty;
1783 my @cmd = (@git, qw(diff --quiet HEAD));
1785 $!=0; $?=0; system @cmd;
1786 return if !$! && !$?;
1787 if (!$! && $?==256) {
1788 fail "working tree is dirty (does not match HEAD)";
1794 sub commit_admin ($) {
1797 runcmd_ordryrun_local @git, qw(commit -m), $m;
1800 sub commit_quilty_patch () {
1801 my $output = cmdoutput @git, qw(status --porcelain);
1803 foreach my $l (split /\n/, $output) {
1804 next unless $l =~ m/\S/;
1805 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1809 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1811 progress "nothing quilty to commit, ok.";
1814 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1815 runcmd_ordryrun_local @git, qw(add -f), @adds;
1816 commit_admin "Commit Debian 3.0 (quilt) metadata";
1819 sub get_source_format () {
1821 if (open F, "debian/source/options") {
1825 s/\s+$//; # ignore missing final newline
1827 my ($k, $v) = ($`, $'); #');
1828 $v =~ s/^"(.*)"$/$1/;
1834 F->error and die $!;
1837 die $! unless $!==&ENOENT;
1840 if (!open F, "debian/source/format") {
1841 die $! unless $!==&ENOENT;
1845 F->error and die $!;
1847 return ($_, \%options);
1852 return 0 unless $format eq '3.0 (quilt)';
1853 our $quilt_mode_warned;
1854 if ($quilt_mode eq 'nocheck') {
1855 progress "Not doing any fixup of \`$format' due to".
1856 " ----no-quilt-fixup or --quilt=nocheck"
1857 unless $quilt_mode_warned++;
1860 progress "Format \`$format', need to check/update patch stack"
1861 unless $quilt_mode_warned++;
1865 sub push_parse_changelog ($) {
1868 my $clogp = Dpkg::Control::Hash->new();
1869 $clogp->load($clogpfn) or die;
1871 $package = getfield $clogp, 'Source';
1872 my $cversion = getfield $clogp, 'Version';
1873 my $tag = debiantag($cversion, access_basedistro);
1874 runcmd @git, qw(check-ref-format), $tag;
1876 my $dscfn = dscfn($cversion);
1878 return ($clogp, $cversion, $tag, $dscfn);
1881 sub push_parse_dsc ($$$) {
1882 my ($dscfn,$dscfnwhat, $cversion) = @_;
1883 $dsc = parsecontrol($dscfn,$dscfnwhat);
1884 my $dversion = getfield $dsc, 'Version';
1885 my $dscpackage = getfield $dsc, 'Source';
1886 ($dscpackage eq $package && $dversion eq $cversion) or
1887 fail "$dscfn is for $dscpackage $dversion".
1888 " but debian/changelog is for $package $cversion";
1891 sub push_mktag ($$$$$$$) {
1892 my ($head,$clogp,$tag,
1894 $changesfile,$changesfilewhat,
1897 $dsc->{$ourdscfield[0]} = $head;
1898 $dsc->save("$dscfn.tmp") or die $!;
1900 my $changes = parsecontrol($changesfile,$changesfilewhat);
1901 foreach my $field (qw(Source Distribution Version)) {
1902 $changes->{$field} eq $clogp->{$field} or
1903 fail "changes field $field \`$changes->{$field}'".
1904 " does not match changelog \`$clogp->{$field}'";
1907 my $cversion = getfield $clogp, 'Version';
1908 my $clogsuite = getfield $clogp, 'Distribution';
1910 # We make the git tag by hand because (a) that makes it easier
1911 # to control the "tagger" (b) we can do remote signing
1912 my $authline = clogp_authline $clogp;
1913 my $delibs = join(" ", "",@deliberatelies);
1914 my $declaredistro = access_basedistro();
1915 open TO, '>', $tfn->('.tmp') or die $!;
1916 print TO <<END or die $!;
1922 $package release $cversion for $clogsuite ($csuite) [dgit]
1923 [dgit distro=$declaredistro$delibs]
1925 foreach my $ref (sort keys %previously) {
1926 print TO <<END or die $!;
1927 [dgit previously:$ref=$previously{$ref}]
1933 my $tagobjfn = $tfn->('.tmp');
1935 if (!defined $keyid) {
1936 $keyid = access_cfg('keyid','RETURN-UNDEF');
1938 if (!defined $keyid) {
1939 $keyid = getfield $clogp, 'Maintainer';
1941 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1942 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1943 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1944 push @sign_cmd, $tfn->('.tmp');
1945 runcmd_ordryrun @sign_cmd;
1947 $tagobjfn = $tfn->('.signed.tmp');
1948 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1949 $tfn->('.tmp'), $tfn->('.tmp.asc');
1956 sub sign_changes ($) {
1957 my ($changesfile) = @_;
1959 my @debsign_cmd = @debsign;
1960 push @debsign_cmd, "-k$keyid" if defined $keyid;
1961 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1962 push @debsign_cmd, $changesfile;
1963 runcmd_ordryrun @debsign_cmd;
1968 my ($forceflag) = @_;
1969 printdebug "actually entering push\n";
1970 supplementary_message(<<'END');
1971 Push failed, while preparing your push.
1972 You can retry the push, after fixing the problem, if you like.
1976 access_giturl(); # check that success is vaguely likely
1978 my $clogpfn = ".git/dgit/changelog.822.tmp";
1979 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1981 responder_send_file('parsed-changelog', $clogpfn);
1983 my ($clogp, $cversion, $tag, $dscfn) =
1984 push_parse_changelog("$clogpfn");
1986 my $dscpath = "$buildproductsdir/$dscfn";
1987 stat_exists $dscpath or
1988 fail "looked for .dsc $dscfn, but $!;".
1989 " maybe you forgot to build";
1991 responder_send_file('dsc', $dscpath);
1993 push_parse_dsc($dscpath, $dscfn, $cversion);
1995 my $format = getfield $dsc, 'Format';
1996 printdebug "format $format\n";
1998 my $head = git_rev_parse('HEAD');
2000 if (madformat($format)) {
2001 # user might have not used dgit build, so maybe do this now:
2002 commit_quilty_patch();
2005 die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2009 progress "checking that $dscfn corresponds to HEAD";
2010 runcmd qw(dpkg-source -x --),
2011 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2012 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2013 check_for_vendor_patches() if madformat($dsc->{format});
2014 changedir '../../../..';
2015 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2016 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2017 debugcmd "+",@diffcmd;
2019 my $r = system @diffcmd;
2022 fail "$dscfn specifies a different tree to your HEAD commit;".
2023 " perhaps you forgot to build".
2024 ($diffopt eq '--exit-code' ? "" :
2025 " (run with -D to see full diff output)");
2030 if (!$changesfile) {
2031 my $pat = changespat $cversion;
2032 my @cs = glob "$buildproductsdir/$pat";
2033 fail "failed to find unique changes file".
2034 " (looked for $pat in $buildproductsdir);".
2035 " perhaps you need to use dgit -C"
2037 ($changesfile) = @cs;
2039 $changesfile = "$buildproductsdir/$changesfile";
2042 responder_send_file('changes',$changesfile);
2043 responder_send_command("param head $head");
2044 responder_send_command("param csuite $csuite");
2046 if (deliberately_not_fast_forward) {
2047 git_for_each_ref(lrfetchrefs, sub {
2048 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2049 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2050 responder_send_command("previously $rrefname=$objid");
2051 $previously{$rrefname} = $objid;
2055 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2058 supplementary_message(<<'END');
2059 Push failed, while signing the tag.
2060 You can retry the push, after fixing the problem, if you like.
2062 # If we manage to sign but fail to record it anywhere, it's fine.
2063 if ($we_are_responder) {
2064 $tagobjfn = $tfn->('.signed.tmp');
2065 responder_receive_files('signed-tag', $tagobjfn);
2068 push_mktag($head,$clogp,$tag,
2070 $changesfile,$changesfile,
2073 supplementary_message(<<'END');
2074 Push failed, *after* signing the tag.
2075 If you want to try again, you should use a new version number.
2078 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2079 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2080 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2082 supplementary_message(<<'END');
2083 Push failed, while updating the remote git repository - see messages above.
2084 If you want to try again, you should use a new version number.
2086 if (!check_for_git()) {
2087 create_remote_git_repo();
2089 runcmd_ordryrun @git, qw(push),access_giturl(),
2090 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2091 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2093 supplementary_message(<<'END');
2094 Push failed, after updating the remote git repository.
2095 If you want to try again, you must use a new version number.
2097 if ($we_are_responder) {
2098 my $dryrunsuffix = act_local() ? "" : ".tmp";
2099 responder_receive_files('signed-dsc-changes',
2100 "$dscpath$dryrunsuffix",
2101 "$changesfile$dryrunsuffix");
2104 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2106 progress "[new .dsc left in $dscpath.tmp]";
2108 sign_changes $changesfile;
2111 supplementary_message(<<END);
2112 Push failed, while uploading package(s) to the archive server.
2113 You can retry the upload of exactly these same files with dput of:
2115 If that .changes file is broken, you will need to use a new version
2116 number for your next attempt at the upload.
2118 my $host = access_cfg('upload-host','RETURN-UNDEF');
2119 my @hostarg = defined($host) ? ($host,) : ();
2120 runcmd_ordryrun @dput, @hostarg, $changesfile;
2121 printdone "pushed and uploaded $cversion";
2123 supplementary_message('');
2124 responder_send_command("complete");
2131 badusage "-p is not allowed with clone; specify as argument instead"
2132 if defined $package;
2135 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2136 ($package,$isuite) = @ARGV;
2137 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2138 ($package,$dstdir) = @ARGV;
2139 } elsif (@ARGV==3) {
2140 ($package,$isuite,$dstdir) = @ARGV;
2142 badusage "incorrect arguments to dgit clone";
2144 $dstdir ||= "$package";
2146 if (stat_exists $dstdir) {
2147 fail "$dstdir already exists";
2151 if ($rmonerror && !$dryrun_level) {
2152 $cwd_remove= getcwd();
2154 return unless defined $cwd_remove;
2155 if (!chdir "$cwd_remove") {
2156 return if $!==&ENOENT;
2157 die "chdir $cwd_remove: $!";
2160 rmtree($dstdir) or die "remove $dstdir: $!\n";
2161 } elsif (!grep { $! == $_ }
2162 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2164 print STDERR "check whether to remove $dstdir: $!\n";
2170 $cwd_remove = undef;
2173 sub branchsuite () {
2174 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2175 if ($branch =~ m#$lbranch_re#o) {
2182 sub fetchpullargs () {
2184 if (!defined $package) {
2185 my $sourcep = parsecontrol('debian/control','debian/control');
2186 $package = getfield $sourcep, 'Source';
2189 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2191 my $clogp = parsechangelog();
2192 $isuite = getfield $clogp, 'Distribution';
2194 canonicalise_suite();
2195 progress "fetching from suite $csuite";
2196 } elsif (@ARGV==1) {
2198 canonicalise_suite();
2200 badusage "incorrect arguments to dgit fetch or dgit pull";
2219 badusage "-p is not allowed with dgit push" if defined $package;
2221 my $clogp = parsechangelog();
2222 $package = getfield $clogp, 'Source';
2225 } elsif (@ARGV==1) {
2226 ($specsuite) = (@ARGV);
2228 badusage "incorrect arguments to dgit push";
2230 $isuite = getfield $clogp, 'Distribution';
2232 local ($package) = $existing_package; # this is a hack
2233 canonicalise_suite();
2235 canonicalise_suite();
2237 if (defined $specsuite &&
2238 $specsuite ne $isuite &&
2239 $specsuite ne $csuite) {
2240 fail "dgit push: changelog specifies $isuite ($csuite)".
2241 " but command line specifies $specsuite";
2243 supplementary_message(<<'END');
2244 Push failed, while checking state of the archive.
2245 You can retry the push, after fixing the problem, if you like.
2247 if (check_for_git()) {
2251 if (fetch_from_archive()) {
2252 if (is_fast_fwd(lrref(), 'HEAD')) {
2254 } elsif (deliberately_not_fast_forward) {
2257 fail "dgit push: HEAD is not a descendant".
2258 " of the archive's version.\n".
2259 "dgit: To overwrite its contents,".
2260 " use git merge -s ours ".lrref().".\n".
2261 "dgit: To rewind history, if permitted by the archive,".
2262 " use --deliberately-not-fast-forward";
2266 fail "package appears to be new in this suite;".
2267 " if this is intentional, use --new";
2272 #---------- remote commands' implementation ----------
2274 sub cmd_remote_push_build_host {
2275 my ($nrargs) = shift @ARGV;
2276 my (@rargs) = @ARGV[0..$nrargs-1];
2277 @ARGV = @ARGV[$nrargs..$#ARGV];
2279 my ($dir,$vsnwant) = @rargs;
2280 # vsnwant is a comma-separated list; we report which we have
2281 # chosen in our ready response (so other end can tell if they
2284 $we_are_responder = 1;
2285 $us .= " (build host)";
2289 open PI, "<&STDIN" or die $!;
2290 open STDIN, "/dev/null" or die $!;
2291 open PO, ">&STDOUT" or die $!;
2293 open STDOUT, ">&STDERR" or die $!;
2297 ($protovsn) = grep {
2298 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2299 } @rpushprotovsn_support;
2301 fail "build host has dgit rpush protocol versions ".
2302 (join ",", @rpushprotovsn_support).
2303 " but invocation host has $vsnwant"
2304 unless defined $protovsn;
2306 responder_send_command("dgit-remote-push-ready $protovsn");
2312 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2313 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2314 # a good error message)
2320 my $report = i_child_report();
2321 if (defined $report) {
2322 printdebug "($report)\n";
2323 } elsif ($i_child_pid) {
2324 printdebug "(killing build host child $i_child_pid)\n";
2325 kill 15, $i_child_pid;
2327 if (defined $i_tmp && !defined $initiator_tempdir) {
2329 eval { rmtree $i_tmp; };
2333 END { i_cleanup(); }
2336 my ($base,$selector,@args) = @_;
2337 $selector =~ s/\-/_/g;
2338 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2345 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2353 push @rargs, join ",", @rpushprotovsn_support;
2356 push @rdgit, @ropts;
2357 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2359 my @cmd = (@ssh, $host, shellquote @rdgit);
2362 if (defined $initiator_tempdir) {
2363 rmtree $initiator_tempdir;
2364 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2365 $i_tmp = $initiator_tempdir;
2369 $i_child_pid = open2(\*RO, \*RI, @cmd);
2371 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2372 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2373 $supplementary_message = '' unless $protovsn >= 3;
2375 my ($icmd,$iargs) = initiator_expect {
2376 m/^(\S+)(?: (.*))?$/;
2379 i_method "i_resp", $icmd, $iargs;
2383 sub i_resp_progress ($) {
2385 my $msg = protocol_read_bytes \*RO, $rhs;
2389 sub i_resp_supplementary_message ($) {
2391 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2394 sub i_resp_complete {
2395 my $pid = $i_child_pid;
2396 $i_child_pid = undef; # prevents killing some other process with same pid
2397 printdebug "waiting for build host child $pid...\n";
2398 my $got = waitpid $pid, 0;
2399 die $! unless $got == $pid;
2400 die "build host child failed $?" if $?;
2403 printdebug "all done\n";
2407 sub i_resp_file ($) {
2409 my $localname = i_method "i_localname", $keyword;
2410 my $localpath = "$i_tmp/$localname";
2411 stat_exists $localpath and
2412 badproto \*RO, "file $keyword ($localpath) twice";
2413 protocol_receive_file \*RO, $localpath;
2414 i_method "i_file", $keyword;
2419 sub i_resp_param ($) {
2420 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2424 sub i_resp_previously ($) {
2425 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2426 or badproto \*RO, "bad previously spec";
2427 my $r = system qw(git check-ref-format), $1;
2428 die "bad previously ref spec ($r)" if $r;
2429 $previously{$1} = $2;
2434 sub i_resp_want ($) {
2436 die "$keyword ?" if $i_wanted{$keyword}++;
2437 my @localpaths = i_method "i_want", $keyword;
2438 printdebug "[[ $keyword @localpaths\n";
2439 foreach my $localpath (@localpaths) {
2440 protocol_send_file \*RI, $localpath;
2442 print RI "files-end\n" or die $!;
2445 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2447 sub i_localname_parsed_changelog {
2448 return "remote-changelog.822";
2450 sub i_file_parsed_changelog {
2451 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2452 push_parse_changelog "$i_tmp/remote-changelog.822";
2453 die if $i_dscfn =~ m#/|^\W#;
2456 sub i_localname_dsc {
2457 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2462 sub i_localname_changes {
2463 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2464 $i_changesfn = $i_dscfn;
2465 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2466 return $i_changesfn;
2468 sub i_file_changes { }
2470 sub i_want_signed_tag {
2471 printdebug Dumper(\%i_param, $i_dscfn);
2472 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2473 && defined $i_param{'csuite'}
2474 or badproto \*RO, "premature desire for signed-tag";
2475 my $head = $i_param{'head'};
2476 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2478 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2480 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2483 push_mktag $head, $i_clogp, $i_tag,
2485 $i_changesfn, 'remote changes',
2486 sub { "tag$_[0]"; };
2491 sub i_want_signed_dsc_changes {
2492 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2493 sign_changes $i_changesfn;
2494 return ($i_dscfn, $i_changesfn);
2497 #---------- building etc. ----------
2503 #----- `3.0 (quilt)' handling -----
2505 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2507 sub quiltify_dpkg_commit ($$$;$) {
2508 my ($patchname,$author,$msg, $xinfo) = @_;
2512 my $descfn = ".git/dgit/quilt-description.tmp";
2513 open O, '>', $descfn or die "$descfn: $!";
2516 $msg =~ s/^\s+$/ ./mg;
2517 print O <<END or die $!;
2527 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2528 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2529 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2530 runcmd @dpkgsource, qw(--commit .), $patchname;
2534 sub quiltify_trees_differ ($$;$$) {
2535 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2536 # returns true iff the two tree objects differ other than in debian/
2537 # with $finegrained,
2538 # returns bitmask 01 - differ in upstream files except .gitignore
2539 # 02 - differ in .gitignore
2540 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2541 # is set for each modified .gitignore filename $fn
2543 my @cmd = (@git, qw(diff-tree --name-only -z));
2544 push @cmd, qw(-r) if $finegrained;
2546 my $diffs= cmdoutput @cmd;
2548 foreach my $f (split /\0/, $diffs) {
2549 next if $f =~ m#^debian(?:/.*)?$#s;
2550 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2551 $r |= $isignore ? 02 : 01;
2552 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2554 printdebug "quiltify_trees_differ $x $y => $r\n";
2558 sub quiltify_tree_sentinelfiles ($) {
2559 # lists the `sentinel' files present in the tree
2561 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2562 qw(-- debian/rules debian/control);
2567 sub quiltify_splitbrain_needed () {
2568 if (!$split_brain) {
2569 progress "dgit view: changes are required...";
2570 runcmd @git, qw(checkout -q -b dgit-view);
2575 sub quiltify_splitbrain ($$$$$$) {
2576 my ($clogp, $unapplied, $headref, $diffbits,
2577 $editedignores, $cachekey) = @_;
2578 if ($quilt_mode !~ m/gbp|dpm/) {
2579 # treat .gitignore just like any other upstream file
2580 $diffbits = { %$diffbits };
2581 $_ = !!$_ foreach values %$diffbits;
2583 # We would like any commits we generate to be reproducible
2584 my @authline = clogp_authline($clogp);
2585 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2586 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2587 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2589 if ($quilt_mode =~ m/gbp|unapplied/ &&
2590 ($diffbits->{H2O} & 01)) {
2592 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2593 " but git tree differs from orig in upstream files.";
2594 if (!stat_exists "debian/patches") {
2596 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2600 if ($quilt_mode =~ m/gbp|unapplied/ &&
2601 ($diffbits->{O2A} & 01)) { # some patches
2602 quiltify_splitbrain_needed();
2603 progress "dgit view: creating patches-applied version using gbp pq";
2604 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2605 # gbp pq import creates a fresh branch; push back to dgit-view
2606 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2607 runcmd @git, qw(checkout -q dgit-view);
2609 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2610 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2611 quiltify_splitbrain_needed();
2612 progress "dgit view: creating patch to represent .gitignore changes";
2613 ensuredir "debian/patches";
2614 my $gipatch = "debian/patches/auto-gitignore";
2615 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2616 stat GIPATCH or die "$gipatch: $!";
2617 fail "$gipatch already exists; but want to create it".
2618 " to record .gitignore changes" if (stat _)[7];
2619 print GIPATCH <<END or die "$gipatch: $!";
2620 Subject: Update .gitignore from Debian packaging branch
2622 The Debian packaging git branch contains these updates to the upstream
2623 .gitignore file(s). This patch is autogenerated, to provide these
2624 updates to users of the official Debian archive view of the package.
2626 [dgit version $our_version]
2629 close GIPATCH or die "$gipatch: $!";
2630 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2631 $unapplied, $headref, "--", sort keys %$editedignores;
2632 open SERIES, "+>>", "debian/patches/series" or die $!;
2633 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2635 defined read SERIES, $newline, 1 or die $!;
2636 print SERIES "\n" or die $! unless $newline eq "\n";
2637 print SERIES "auto-gitignore\n" or die $!;
2638 close SERIES or die $!;
2639 runcmd @git, qw(add -- debian/patches/series), $gipatch;
2640 commit_admin "Commit patch to update .gitignore";
2643 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2645 changedir '../../../..';
2646 ensuredir ".git/logs/refs/dgit-intern";
2647 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2649 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2652 progress "dgit view: created (commit id $dgitview)";
2654 changedir '.git/dgit/unpack/work';
2657 sub quiltify ($$$$) {
2658 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2660 # Quilt patchification algorithm
2662 # We search backwards through the history of the main tree's HEAD
2663 # (T) looking for a start commit S whose tree object is identical
2664 # to to the patch tip tree (ie the tree corresponding to the
2665 # current dpkg-committed patch series). For these purposes
2666 # `identical' disregards anything in debian/ - this wrinkle is
2667 # necessary because dpkg-source treates debian/ specially.
2669 # We can only traverse edges where at most one of the ancestors'
2670 # trees differs (in changes outside in debian/). And we cannot
2671 # handle edges which change .pc/ or debian/patches. To avoid
2672 # going down a rathole we avoid traversing edges which introduce
2673 # debian/rules or debian/control. And we set a limit on the
2674 # number of edges we are willing to look at.
2676 # If we succeed, we walk forwards again. For each traversed edge
2677 # PC (with P parent, C child) (starting with P=S and ending with
2678 # C=T) to we do this:
2680 # - dpkg-source --commit with a patch name and message derived from C
2681 # After traversing PT, we git commit the changes which
2682 # should be contained within debian/patches.
2684 # The search for the path S..T is breadth-first. We maintain a
2685 # todo list containing search nodes. A search node identifies a
2686 # commit, and looks something like this:
2688 # Commit => $git_commit_id,
2689 # Child => $c, # or undef if P=T
2690 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2691 # Nontrivial => true iff $p..$c has relevant changes
2698 my %considered; # saves being exponential on some weird graphs
2700 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2703 my ($search,$whynot) = @_;
2704 printdebug " search NOT $search->{Commit} $whynot\n";
2705 $search->{Whynot} = $whynot;
2706 push @nots, $search;
2707 no warnings qw(exiting);
2716 my $c = shift @todo;
2717 next if $considered{$c->{Commit}}++;
2719 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2721 printdebug "quiltify investigate $c->{Commit}\n";
2724 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2725 printdebug " search finished hooray!\n";
2730 if ($quilt_mode eq 'nofix') {
2731 fail "quilt fixup required but quilt mode is \`nofix'\n".
2732 "HEAD commit $c->{Commit} differs from tree implied by ".
2733 " debian/patches (tree object $oldtiptree)";
2735 if ($quilt_mode eq 'smash') {
2736 printdebug " search quitting smash\n";
2740 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2741 $not->($c, "has $c_sentinels not $t_sentinels")
2742 if $c_sentinels ne $t_sentinels;
2744 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2745 $commitdata =~ m/\n\n/;
2747 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2748 @parents = map { { Commit => $_, Child => $c } } @parents;
2750 $not->($c, "root commit") if !@parents;
2752 foreach my $p (@parents) {
2753 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2755 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2756 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2758 foreach my $p (@parents) {
2759 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2761 my @cmd= (@git, qw(diff-tree -r --name-only),
2762 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2763 my $patchstackchange = cmdoutput @cmd;
2764 if (length $patchstackchange) {
2765 $patchstackchange =~ s/\n/,/g;
2766 $not->($p, "changed $patchstackchange");
2769 printdebug " search queue P=$p->{Commit} ",
2770 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2776 printdebug "quiltify want to smash\n";
2779 my $x = $_[0]{Commit};
2780 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2783 my $reportnot = sub {
2785 my $s = $abbrev->($notp);
2786 my $c = $notp->{Child};
2787 $s .= "..".$abbrev->($c) if $c;
2788 $s .= ": ".$notp->{Whynot};
2791 if ($quilt_mode eq 'linear') {
2792 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2793 foreach my $notp (@nots) {
2794 print STDERR "$us: ", $reportnot->($notp), "\n";
2796 print STDERR "$us: $_\n" foreach @$failsuggestion;
2797 fail "quilt fixup naive history linearisation failed.\n".
2798 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2799 } elsif ($quilt_mode eq 'smash') {
2800 } elsif ($quilt_mode eq 'auto') {
2801 progress "quilt fixup cannot be linear, smashing...";
2803 die "$quilt_mode ?";
2808 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2810 quiltify_dpkg_commit "auto-$version-$target-$time",
2811 (getfield $clogp, 'Maintainer'),
2812 "Automatically generated patch ($clogp->{Version})\n".
2813 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2817 progress "quiltify linearisation planning successful, executing...";
2819 for (my $p = $sref_S;
2820 my $c = $p->{Child};
2822 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2823 next unless $p->{Nontrivial};
2825 my $cc = $c->{Commit};
2827 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2828 $commitdata =~ m/\n\n/ or die "$c ?";
2831 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2834 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2837 my $patchname = $title;
2838 $patchname =~ s/[.:]$//;
2839 $patchname =~ y/ A-Z/-a-z/;
2840 $patchname =~ y/-a-z0-9_.+=~//cd;
2841 $patchname =~ s/^\W/x-$&/;
2842 $patchname = substr($patchname,0,40);
2845 stat "debian/patches/$patchname$index";
2847 $!==ENOENT or die "$patchname$index $!";
2849 runcmd @git, qw(checkout -q), $cc;
2851 # We use the tip's changelog so that dpkg-source doesn't
2852 # produce complaining messages from dpkg-parsechangelog. None
2853 # of the information dpkg-source gets from the changelog is
2854 # actually relevant - it gets put into the original message
2855 # which dpkg-source provides our stunt editor, and then
2857 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2859 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2860 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2862 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2865 runcmd @git, qw(checkout -q master);
2868 sub build_maybe_quilt_fixup () {
2869 my ($format,$fopts) = get_source_format;
2870 return unless madformat $format;
2873 check_for_vendor_patches();
2875 my $clogp = parsechangelog();
2876 my $headref = git_rev_parse('HEAD');
2881 my $upstreamversion=$version;
2882 $upstreamversion =~ s/-[^-]*$//;
2884 if ($fopts->{'single-debian-patch'}) {
2885 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2887 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2890 die 'bug' if $split_brain && !$need_split_build_invocation;
2892 changedir '../../../..';
2893 runcmd_ordryrun_local
2894 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2897 sub quilt_fixup_mkwork ($) {
2900 mkdir "work" or die $!;
2902 mktree_in_ud_here();
2903 runcmd @git, qw(reset -q --hard), $headref;
2906 sub quilt_fixup_linkorigs ($$) {
2907 my ($upstreamversion, $fn) = @_;
2908 # calls $fn->($leafname);
2910 foreach my $f (<../../../../*>) { #/){
2911 my $b=$f; $b =~ s{.*/}{};
2913 local ($debuglevel) = $debuglevel-1;
2914 printdebug "QF linkorigs $b, $f ?\n";
2916 next unless is_orig_file $b, srcfn $upstreamversion,'';
2917 printdebug "QF linkorigs $b, $f Y\n";
2918 link_ltarget $f, $b or die "$b $!";
2923 sub quilt_fixup_delete_pc () {
2924 runcmd @git, qw(rm -rqf .pc);
2925 commit_admin "Commit removal of .pc (quilt series tracking data)";
2928 sub quilt_fixup_singlepatch ($$$) {
2929 my ($clogp, $headref, $upstreamversion) = @_;
2931 progress "starting quiltify (single-debian-patch)";
2933 # dpkg-source --commit generates new patches even if
2934 # single-debian-patch is in debian/source/options. In order to
2935 # get it to generate debian/patches/debian-changes, it is
2936 # necessary to build the source package.
2938 quilt_fixup_linkorigs($upstreamversion, sub { });
2939 quilt_fixup_mkwork($headref);
2941 rmtree("debian/patches");
2943 runcmd @dpkgsource, qw(-b .);
2945 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2946 rename srcfn("$upstreamversion", "/debian/patches"),
2947 "work/debian/patches";
2950 commit_quilty_patch();
2953 sub quilt_make_fake_dsc ($) {
2954 my ($upstreamversion) = @_;
2956 my $fakeversion="$upstreamversion-~~DGITFAKE";
2958 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2959 print $fakedsc <<END or die $!;
2962 Version: $fakeversion
2966 my $dscaddfile=sub {
2969 my $md = new Digest::MD5;
2971 my $fh = new IO::File $b, '<' or die "$b $!";
2976 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2979 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2981 my @files=qw(debian/source/format debian/rules
2982 debian/control debian/changelog);
2983 foreach my $maybe (qw(debian/patches debian/source/options
2984 debian/tests/control)) {
2985 next unless stat_exists "../../../$maybe";
2986 push @files, $maybe;
2989 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2990 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
2992 $dscaddfile->($debtar);
2993 close $fakedsc or die $!;
2996 sub quilt_check_splitbrain_cache ($$) {
2997 my ($headref, $upstreamversion) = @_;
2998 # Called only if we are in (potentially) split brain mode.
3000 # Computes the cache key and looks in the cache.
3001 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3003 my $splitbrain_cachekey;
3006 "dgit: split brain (separate dgit view) may needed (--quilt=$quilt_mode).";
3007 # we look in the reflog of dgit-intern/quilt-cache
3008 # we look for an entry whose message is the key for the cache lookup
3009 my @cachekey = (qw(dgit), $our_version);
3010 push @cachekey, $upstreamversion;
3011 push @cachekey, $quilt_mode;
3012 push @cachekey, $headref;
3014 push @cachekey, hashfile('fake.dsc');
3016 my $srcshash = Digest::SHA->new(256);
3017 my %sfs = ( %INC, '$0(dgit)' => $0 );
3018 foreach my $sfk (sort keys %sfs) {
3019 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3020 $srcshash->add($sfk," ");
3021 $srcshash->add(hashfile($sfs{$sfk}));
3022 $srcshash->add("\n");
3024 push @cachekey, $srcshash->hexdigest();
3025 $splitbrain_cachekey = "@cachekey";
3027 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3029 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3030 debugcmd "|(probably)",@cmd;
3031 my $child = open GC, "-|"; defined $child or die $!;
3033 chdir '../../..' or die $!;
3034 if (!stat ".git/logs/refs/$splitbraincache") {
3035 $! == ENOENT or die $!;
3036 printdebug ">(no reflog)\n";
3043 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3044 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3047 quilt_fixup_mkwork($headref);
3048 if ($cachehit ne $headref) {
3049 progress "dgit view: found cached (commit id $cachehit)";
3050 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3052 return ($cachehit, $splitbrain_cachekey);
3054 progress "dgit view: found cached, no changes required";
3055 return ($headref, $splitbrain_cachekey);
3057 die $! if GC->error;
3058 failedcmd unless close GC;
3060 printdebug "splitbrain cache miss\n";
3061 return (undef, $splitbrain_cachekey);
3064 sub quilt_fixup_multipatch ($$$) {
3065 my ($clogp, $headref, $upstreamversion) = @_;
3067 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3070 # - honour any existing .pc in case it has any strangeness
3071 # - determine the git commit corresponding to the tip of
3072 # the patch stack (if there is one)
3073 # - if there is such a git commit, convert each subsequent
3074 # git commit into a quilt patch with dpkg-source --commit
3075 # - otherwise convert all the differences in the tree into
3076 # a single git commit
3080 # Our git tree doesn't necessarily contain .pc. (Some versions of
3081 # dgit would include the .pc in the git tree.) If there isn't
3082 # one, we need to generate one by unpacking the patches that we
3085 # We first look for a .pc in the git tree. If there is one, we
3086 # will use it. (This is not the normal case.)
3088 # Otherwise need to regenerate .pc so that dpkg-source --commit
3089 # can work. We do this as follows:
3090 # 1. Collect all relevant .orig from parent directory
3091 # 2. Generate a debian.tar.gz out of
3092 # debian/{patches,rules,source/format,source/options}
3093 # 3. Generate a fake .dsc containing just these fields:
3094 # Format Source Version Files
3095 # 4. Extract the fake .dsc
3096 # Now the fake .dsc has a .pc directory.
3097 # (In fact we do this in every case, because in future we will
3098 # want to search for a good base commit for generating patches.)
3100 # Then we can actually do the dpkg-source --commit
3101 # 1. Make a new working tree with the same object
3102 # store as our main tree and check out the main
3104 # 2. Copy .pc from the fake's extraction, if necessary
3105 # 3. Run dpkg-source --commit
3106 # 4. If the result has changes to debian/, then
3107 # - git-add them them
3108 # - git-add .pc if we had a .pc in-tree
3110 # 5. If we had a .pc in-tree, delete it, and git-commit
3111 # 6. Back in the main tree, fast forward to the new HEAD
3113 # Another situation we may have to cope with is gbp-style
3114 # patches-unapplied trees.
3116 # We would want to detect these, so we know to escape into
3117 # quilt_fixup_gbp. However, this is in general not possible.
3118 # Consider a package with a one patch which the dgit user reverts
3119 # (with git-revert or the moral equivalent).
3121 # That is indistinguishable in contents from a patches-unapplied
3122 # tree. And looking at the history to distinguish them is not
3123 # useful because the user might have made a confusing-looking git
3124 # history structure (which ought to produce an error if dgit can't
3125 # cope, not a silent reintroduction of an unwanted patch).
3127 # So gbp users will have to pass an option. But we can usually
3128 # detect their failure to do so: if the tree is not a clean
3129 # patches-applied tree, quilt linearisation fails, but the tree
3130 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3131 # they want --quilt=unapplied.
3133 # To help detect this, when we are extracting the fake dsc, we
3134 # first extract it with --skip-patches, and then apply the patches
3135 # afterwards with dpkg-source --before-build. That lets us save a
3136 # tree object corresponding to .origs.
3138 my $splitbrain_cachekey;
3140 quilt_make_fake_dsc($upstreamversion);
3142 if (quiltmode_splitbrain()) {
3144 ($cachehit, $splitbrain_cachekey) =
3145 quilt_check_splitbrain_cache($headref, $upstreamversion);
3146 return if $cachehit;
3150 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3152 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3153 rename $fakexdir, "fake" or die "$fakexdir $!";
3157 remove_stray_gits();
3158 mktree_in_ud_here();
3162 runcmd @git, qw(add -Af .);
3163 my $unapplied=git_write_tree();
3164 printdebug "fake orig tree object $unapplied\n";
3169 'exec dpkg-source --before-build . >/dev/null';
3173 quilt_fixup_mkwork($headref);
3176 if (stat_exists ".pc") {
3178 progress "Tree already contains .pc - will use it then delete it.";
3181 rename '../fake/.pc','.pc' or die $!;
3184 changedir '../fake';
3186 runcmd @git, qw(add -Af .);
3187 my $oldtiptree=git_write_tree();
3188 printdebug "fake o+d/p tree object $unapplied\n";
3189 changedir '../work';
3192 # We calculate some guesswork now about what kind of tree this might
3193 # be. This is mostly for error reporting.
3198 # O = orig, without patches applied
3199 # A = "applied", ie orig with H's debian/patches applied
3200 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3201 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3202 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3206 foreach my $b (qw(01 02)) {
3207 foreach my $v (qw(H2O O2A H2A)) {
3208 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3211 printdebug "differences \@dl @dl.\n";
3214 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3215 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3216 $dl[0], $dl[1], $dl[3], $dl[4],
3220 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3221 push @failsuggestion, "This might be a patches-unapplied branch.";
3222 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3223 push @failsuggestion, "This might be a patches-applied branch.";
3225 push @failsuggestion, "Maybe you need to specify one of".
3226 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3228 if (quiltmode_splitbrain()) {
3229 quiltify_splitbrain($clogp, $unapplied, $headref,
3230 $diffbits, \%editedignores,
3231 $splitbrain_cachekey);
3235 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3236 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3238 if (!open P, '>>', ".pc/applied-patches") {
3239 $!==&ENOENT or die $!;
3244 commit_quilty_patch();
3246 if ($mustdeletepc) {
3247 quilt_fixup_delete_pc();
3251 sub quilt_fixup_editor () {
3252 my $descfn = $ENV{$fakeeditorenv};
3253 my $editing = $ARGV[$#ARGV];
3254 open I1, '<', $descfn or die "$descfn: $!";
3255 open I2, '<', $editing or die "$editing: $!";
3256 unlink $editing or die "$editing: $!";
3257 open O, '>', $editing or die "$editing: $!";
3258 while (<I1>) { print O or die $!; } I1->error and die $!;
3261 $copying ||= m/^\-\-\- /;
3262 next unless $copying;
3265 I2->error and die $!;
3270 sub maybe_apply_patches_dirtily () {
3271 return unless $quilt_mode =~ m/gbp|unapplied/;
3272 print STDERR <<END or die $!;
3274 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3275 dgit: Have to apply the patches - making the tree dirty.
3276 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3279 $patches_applied_dirtily = 01;
3280 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3281 runcmd qw(dpkg-source --before-build .);
3284 sub maybe_unapply_patches_again () {
3285 progress "dgit: Unapplying patches again to tidy up the tree."
3286 if $patches_applied_dirtily;
3287 runcmd qw(dpkg-source --after-build .)
3288 if $patches_applied_dirtily & 01;
3290 if $patches_applied_dirtily & 02;
3293 #----- other building -----
3295 our $clean_using_builder;
3296 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3297 # clean the tree before building (perhaps invoked indirectly by
3298 # whatever we are using to run the build), rather than separately
3299 # and explicitly by us.
3302 return if $clean_using_builder;
3303 if ($cleanmode eq 'dpkg-source') {
3304 maybe_apply_patches_dirtily();
3305 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3306 } elsif ($cleanmode eq 'dpkg-source-d') {
3307 maybe_apply_patches_dirtily();
3308 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3309 } elsif ($cleanmode eq 'git') {
3310 runcmd_ordryrun_local @git, qw(clean -xdf);
3311 } elsif ($cleanmode eq 'git-ff') {
3312 runcmd_ordryrun_local @git, qw(clean -xdff);
3313 } elsif ($cleanmode eq 'check') {
3314 my $leftovers = cmdoutput @git, qw(clean -xdn);
3315 if (length $leftovers) {
3316 print STDERR $leftovers, "\n" or die $!;
3317 fail "tree contains uncommitted files and --clean=check specified";
3319 } elsif ($cleanmode eq 'none') {
3326 badusage "clean takes no additional arguments" if @ARGV;
3329 maybe_unapply_patches_again();
3334 badusage "-p is not allowed when building" if defined $package;
3337 my $clogp = parsechangelog();
3338 $isuite = getfield $clogp, 'Distribution';
3339 $package = getfield $clogp, 'Source';
3340 $version = getfield $clogp, 'Version';
3341 build_maybe_quilt_fixup();
3343 my $pat = changespat $version;
3344 foreach my $f (glob "$buildproductsdir/$pat") {
3346 unlink $f or fail "remove old changes file $f: $!";
3348 progress "would remove $f";
3354 sub changesopts_initial () {
3355 my @opts =@changesopts[1..$#changesopts];
3358 sub changesopts_version () {
3359 if (!defined $changes_since_version) {
3360 my @vsns = archive_query('archive_query');
3361 my @quirk = access_quirk();
3362 if ($quirk[0] eq 'backports') {
3363 local $isuite = $quirk[2];
3365 canonicalise_suite();
3366 push @vsns, archive_query('archive_query');
3369 @vsns = map { $_->[0] } @vsns;
3370 @vsns = sort { -version_compare($a, $b) } @vsns;
3371 $changes_since_version = $vsns[0];
3372 progress "changelog will contain changes since $vsns[0]";
3374 $changes_since_version = '_';
3375 progress "package seems new, not specifying -v<version>";
3378 if ($changes_since_version ne '_') {
3379 return ("-v$changes_since_version");
3385 sub changesopts () {
3386 return (changesopts_initial(), changesopts_version());
3389 sub massage_dbp_args ($;$) {
3390 my ($cmd,$xargs) = @_;
3393 # - if we're going to split the source build out so we can
3394 # do strange things to it, massage the arguments to dpkg-buildpackage
3395 # so that the main build doessn't build source (or add an argument
3396 # to stop it building source by default).
3398 # - add -nc to stop dpkg-source cleaning the source tree,
3399 # unless we're not doing a split build and want dpkg-source
3400 # as cleanmode, in which case we can do nothing
3403 # 0 - source will NOT need to be built separately by caller
3404 # +1 - source will need to be built separately by caller
3405 # +2 - source will need to be built separately by caller AND
3406 # dpkg-buildpackage should not in fact be run at all!
3407 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3408 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3409 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3410 $clean_using_builder = 1;
3413 # -nc has the side effect of specifying -b if nothing else specified
3414 # and some combinations of -S, -b, et al, are errors, rather than
3415 # later simply overriding earlie. So we need to:
3416 # - search the command line for these options
3417 # - pick the last one
3418 # - perhaps add our own as a default
3419 # - perhaps adjust it to the corresponding non-source-building version
3421 foreach my $l ($cmd, $xargs) {
3423 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3426 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3428 if ($need_split_build_invocation) {
3429 printdebug "massage split $dmode.\n";
3430 $r = $dmode =~ m/[S]/ ? +2 :
3431 $dmode =~ y/gGF/ABb/ ? +1 :
3432 $dmode =~ m/[ABb]/ ? 0 :
3435 printdebug "massage done $r $dmode.\n";
3437 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3442 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3443 my $wantsrc = massage_dbp_args \@dbp;
3450 push @dbp, changesopts_version();
3451 maybe_apply_patches_dirtily();
3452 runcmd_ordryrun_local @dbp;
3454 maybe_unapply_patches_again();
3455 printdone "build successful\n";
3459 my @dbp = @dpkgbuildpackage;
3461 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3464 if (length executable_on_path('git-buildpackage')) {
3465 @cmd = qw(git-buildpackage);
3467 @cmd = qw(gbp buildpackage);
3469 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3474 if (!$clean_using_builder) {
3475 push @cmd, '--git-cleaner=true';
3480 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3481 canonicalise_suite();
3482 push @cmd, "--git-debian-branch=".lbranch();
3484 push @cmd, changesopts();
3485 maybe_apply_patches_dirtily();
3486 runcmd_ordryrun_local @cmd, @ARGV;
3488 maybe_unapply_patches_again();
3489 printdone "build successful\n";
3491 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3494 my $our_cleanmode = $cleanmode;
3495 if ($need_split_build_invocation) {
3496 # Pretend that clean is being done some other way. This
3497 # forces us not to try to use dpkg-buildpackage to clean and
3498 # build source all in one go; and instead we run dpkg-source
3499 # (and build_prep() will do the clean since $clean_using_builder
3501 $our_cleanmode = 'ELSEWHERE';
3503 if ($our_cleanmode =~ m/^dpkg-source/) {
3504 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3505 $clean_using_builder = 1;
3508 $sourcechanges = changespat $version,'source';
3510 unlink "../$sourcechanges" or $!==ENOENT
3511 or fail "remove $sourcechanges: $!";
3513 $dscfn = dscfn($version);
3514 if ($our_cleanmode eq 'dpkg-source') {
3515 maybe_apply_patches_dirtily();
3516 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3518 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3519 maybe_apply_patches_dirtily();
3520 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3523 my @cmd = (@dpkgsource, qw(-b --));
3526 runcmd_ordryrun_local @cmd, "work";
3527 my @udfiles = <${package}_*>;
3528 changedir "../../..";
3529 foreach my $f (@udfiles) {
3530 printdebug "source copy, found $f\n";
3533 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3534 $f eq srcfn($version, $&));
3535 printdebug "source copy, found $f - renaming\n";
3536 rename "$ud/$f", "../$f" or $!==ENOENT
3537 or fail "put in place new source file ($f): $!";
3540 my $pwd = must_getcwd();
3541 my $leafdir = basename $pwd;
3543 runcmd_ordryrun_local @cmd, $leafdir;
3546 runcmd_ordryrun_local qw(sh -ec),
3547 'exec >$1; shift; exec "$@"','x',
3548 "../$sourcechanges",
3549 @dpkggenchanges, qw(-S), changesopts();
3553 sub cmd_build_source {
3554 badusage "build-source takes no additional arguments" if @ARGV;
3556 maybe_unapply_patches_again();
3557 printdone "source built, results in $dscfn and $sourcechanges";
3562 my $pat = changespat $version;
3564 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3565 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3566 fail "changes files other than source matching $pat".
3567 " already present (@unwanted);".
3568 " building would result in ambiguity about the intended results"
3573 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3574 stat_exists $sourcechanges
3575 or fail "$sourcechanges (in parent directory): $!";
3577 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3578 my @changesfiles = glob $pat;
3579 @changesfiles = sort {
3580 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3583 fail "wrong number of different changes files (@changesfiles)"
3584 unless @changesfiles==2;
3585 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3586 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3587 fail "$l found in binaries changes file $binchanges"
3590 runcmd_ordryrun_local @mergechanges, @changesfiles;
3591 my $multichanges = changespat $version,'multi';
3593 stat_exists $multichanges or fail "$multichanges: $!";
3594 foreach my $cf (glob $pat) {
3595 next if $cf eq $multichanges;
3596 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3599 maybe_unapply_patches_again();
3600 printdone "build successful, results in $multichanges\n" or die $!;
3603 sub cmd_quilt_fixup {
3604 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3605 my $clogp = parsechangelog();
3606 $version = getfield $clogp, 'Version';
3607 $package = getfield $clogp, 'Source';
3610 build_maybe_quilt_fixup();
3613 sub cmd_archive_api_query {
3614 badusage "need only 1 subpath argument" unless @ARGV==1;
3615 my ($subpath) = @ARGV;
3616 my @cmd = archive_api_query_cmd($subpath);
3618 exec @cmd or fail "exec curl: $!\n";
3621 sub cmd_clone_dgit_repos_server {
3622 badusage "need destination argument" unless @ARGV==1;
3623 my ($destdir) = @ARGV;
3624 $package = '_dgit-repos-server';
3625 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3627 exec @cmd or fail "exec git clone: $!\n";
3630 sub cmd_setup_mergechangelogs {
3631 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3632 setup_mergechangelogs(1);
3635 sub cmd_setup_useremail {
3636 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3640 sub cmd_setup_new_tree {
3641 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3645 #---------- argument parsing and main program ----------
3648 print "dgit version $our_version\n" or die $!;
3652 our (%valopts_long, %valopts_short);
3655 sub defvalopt ($$$$) {
3656 my ($long,$short,$val_re,$how) = @_;
3657 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3658 $valopts_long{$long} = $oi;
3659 $valopts_short{$short} = $oi;
3660 # $how subref should:
3661 # do whatever assignemnt or thing it likes with $_[0]
3662 # if the option should not be passed on to remote, @rvalopts=()
3663 # or $how can be a scalar ref, meaning simply assign the value
3666 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3667 defvalopt '--distro', '-d', '.+', \$idistro;
3668 defvalopt '', '-k', '.+', \$keyid;
3669 defvalopt '--existing-package','', '.*', \$existing_package;
3670 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3671 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3672 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3674 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3676 defvalopt '', '-C', '.+', sub {
3677 ($changesfile) = (@_);
3678 if ($changesfile =~ s#^(.*)/##) {
3679 $buildproductsdir = $1;
3683 defvalopt '--initiator-tempdir','','.*', sub {
3684 ($initiator_tempdir) = (@_);
3685 $initiator_tempdir =~ m#^/# or
3686 badusage "--initiator-tempdir must be used specify an".
3687 " absolute, not relative, directory."
3693 if (defined $ENV{'DGIT_SSH'}) {
3694 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3695 } elsif (defined $ENV{'GIT_SSH'}) {
3696 @ssh = ($ENV{'GIT_SSH'});
3704 if (!defined $val) {
3705 badusage "$what needs a value" unless @ARGV;
3707 push @rvalopts, $val;
3709 badusage "bad value \`$val' for $what" unless
3710 $val =~ m/^$oi->{Re}$(?!\n)/s;
3711 my $how = $oi->{How};
3712 if (ref($how) eq 'SCALAR') {
3717 push @ropts, @rvalopts;
3721 last unless $ARGV[0] =~ m/^-/;
3725 if (m/^--dry-run$/) {
3728 } elsif (m/^--damp-run$/) {
3731 } elsif (m/^--no-sign$/) {
3734 } elsif (m/^--help$/) {
3736 } elsif (m/^--version$/) {
3738 } elsif (m/^--new$/) {
3741 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3742 ($om = $opts_opt_map{$1}) &&
3746 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3747 !$opts_opt_cmdonly{$1} &&
3748 ($om = $opts_opt_map{$1})) {
3751 } elsif (m/^--ignore-dirty$/s) {
3754 } elsif (m/^--no-quilt-fixup$/s) {
3756 $quilt_mode = 'nocheck';
3757 } elsif (m/^--no-rm-on-error$/s) {
3760 } elsif (m/^--(no-)?rm-old-changes$/s) {
3763 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3765 push @deliberatelies, $&;
3766 } elsif (m/^--always-split-source-build$/s) {
3767 # undocumented, for testing
3769 $need_split_build_invocation = 1;
3770 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3771 $val = $2 ? $' : undef; #';
3772 $valopt->($oi->{Long});
3774 badusage "unknown long option \`$_'";
3781 } elsif (s/^-L/-/) {
3784 } elsif (s/^-h/-/) {
3786 } elsif (s/^-D/-/) {
3790 } elsif (s/^-N/-/) {
3795 push @changesopts, $_;
3797 } elsif (s/^-wn$//s) {
3799 $cleanmode = 'none';
3800 } elsif (s/^-wg$//s) {
3803 } elsif (s/^-wgf$//s) {
3805 $cleanmode = 'git-ff';
3806 } elsif (s/^-wd$//s) {
3808 $cleanmode = 'dpkg-source';
3809 } elsif (s/^-wdd$//s) {
3811 $cleanmode = 'dpkg-source-d';
3812 } elsif (s/^-wc$//s) {
3814 $cleanmode = 'check';
3815 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3817 $val = undef unless length $val;
3818 $valopt->($oi->{Short});
3821 badusage "unknown short option \`$_'";
3828 sub finalise_opts_opts () {
3829 foreach my $k (keys %opts_opt_map) {
3830 my $om = $opts_opt_map{$k};
3832 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3834 badcfg "cannot set command for $k"
3835 unless length $om->[0];
3839 foreach my $c (access_cfg_cfgs("opts-$k")) {
3840 my $vl = $gitcfg{$c};
3841 printdebug "CL $c ",
3842 ($vl ? join " ", map { shellquote } @$vl : ""),
3843 "\n" if $debuglevel >= 4;
3845 badcfg "cannot configure options for $k"
3846 if $opts_opt_cmdonly{$k};
3847 my $insertpos = $opts_cfg_insertpos{$k};
3848 @$om = ( @$om[0..$insertpos-1],
3850 @$om[$insertpos..$#$om] );
3855 if ($ENV{$fakeeditorenv}) {
3857 quilt_fixup_editor();
3863 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3864 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3865 if $dryrun_level == 1;
3867 print STDERR $helpmsg or die $!;
3870 my $cmd = shift @ARGV;
3873 if (!defined $rmchanges) {
3874 local $access_forpush;
3875 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3878 if (!defined $quilt_mode) {
3879 local $access_forpush;
3880 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3881 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3883 $quilt_mode =~ m/^($quilt_modes_re)$/
3884 or badcfg "unknown quilt-mode \`$quilt_mode'";
3888 $need_split_build_invocation ||= quiltmode_splitbrain();
3890 if (!defined $cleanmode) {
3891 local $access_forpush;
3892 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3893 $cleanmode //= 'dpkg-source';
3895 badcfg "unknown clean-mode \`$cleanmode'" unless
3896 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3899 my $fn = ${*::}{"cmd_$cmd"};
3900 $fn or badusage "unknown operation $cmd";