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 if (madformat($format)) {
1999 # user might have not used dgit build, so maybe do this now:
2000 commit_quilty_patch();
2003 die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2007 progress "checking that $dscfn corresponds to HEAD";
2008 runcmd qw(dpkg-source -x --),
2009 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2010 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2011 check_for_vendor_patches() if madformat($dsc->{format});
2012 changedir '../../../..';
2013 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2014 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2015 debugcmd "+",@diffcmd;
2017 my $r = system @diffcmd;
2020 fail "$dscfn specifies a different tree to your HEAD commit;".
2021 " perhaps you forgot to build".
2022 ($diffopt eq '--exit-code' ? "" :
2023 " (run with -D to see full diff output)");
2028 my $head = git_rev_parse('HEAD');
2029 if (!$changesfile) {
2030 my $pat = changespat $cversion;
2031 my @cs = glob "$buildproductsdir/$pat";
2032 fail "failed to find unique changes file".
2033 " (looked for $pat in $buildproductsdir);".
2034 " perhaps you need to use dgit -C"
2036 ($changesfile) = @cs;
2038 $changesfile = "$buildproductsdir/$changesfile";
2041 responder_send_file('changes',$changesfile);
2042 responder_send_command("param head $head");
2043 responder_send_command("param csuite $csuite");
2045 if (deliberately_not_fast_forward) {
2046 git_for_each_ref(lrfetchrefs, sub {
2047 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2048 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2049 responder_send_command("previously $rrefname=$objid");
2050 $previously{$rrefname} = $objid;
2054 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2057 supplementary_message(<<'END');
2058 Push failed, while signing the tag.
2059 You can retry the push, after fixing the problem, if you like.
2061 # If we manage to sign but fail to record it anywhere, it's fine.
2062 if ($we_are_responder) {
2063 $tagobjfn = $tfn->('.signed.tmp');
2064 responder_receive_files('signed-tag', $tagobjfn);
2067 push_mktag($head,$clogp,$tag,
2069 $changesfile,$changesfile,
2072 supplementary_message(<<'END');
2073 Push failed, *after* signing the tag.
2074 If you want to try again, you should use a new version number.
2077 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2078 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2079 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2081 supplementary_message(<<'END');
2082 Push failed, while updating the remote git repository - see messages above.
2083 If you want to try again, you should use a new version number.
2085 if (!check_for_git()) {
2086 create_remote_git_repo();
2088 runcmd_ordryrun @git, qw(push),access_giturl(),
2089 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2090 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2092 supplementary_message(<<'END');
2093 Push failed, after updating the remote git repository.
2094 If you want to try again, you must use a new version number.
2096 if ($we_are_responder) {
2097 my $dryrunsuffix = act_local() ? "" : ".tmp";
2098 responder_receive_files('signed-dsc-changes',
2099 "$dscpath$dryrunsuffix",
2100 "$changesfile$dryrunsuffix");
2103 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2105 progress "[new .dsc left in $dscpath.tmp]";
2107 sign_changes $changesfile;
2110 supplementary_message(<<END);
2111 Push failed, while uploading package(s) to the archive server.
2112 You can retry the upload of exactly these same files with dput of:
2114 If that .changes file is broken, you will need to use a new version
2115 number for your next attempt at the upload.
2117 my $host = access_cfg('upload-host','RETURN-UNDEF');
2118 my @hostarg = defined($host) ? ($host,) : ();
2119 runcmd_ordryrun @dput, @hostarg, $changesfile;
2120 printdone "pushed and uploaded $cversion";
2122 supplementary_message('');
2123 responder_send_command("complete");
2130 badusage "-p is not allowed with clone; specify as argument instead"
2131 if defined $package;
2134 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2135 ($package,$isuite) = @ARGV;
2136 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2137 ($package,$dstdir) = @ARGV;
2138 } elsif (@ARGV==3) {
2139 ($package,$isuite,$dstdir) = @ARGV;
2141 badusage "incorrect arguments to dgit clone";
2143 $dstdir ||= "$package";
2145 if (stat_exists $dstdir) {
2146 fail "$dstdir already exists";
2150 if ($rmonerror && !$dryrun_level) {
2151 $cwd_remove= getcwd();
2153 return unless defined $cwd_remove;
2154 if (!chdir "$cwd_remove") {
2155 return if $!==&ENOENT;
2156 die "chdir $cwd_remove: $!";
2159 rmtree($dstdir) or die "remove $dstdir: $!\n";
2160 } elsif (!grep { $! == $_ }
2161 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2163 print STDERR "check whether to remove $dstdir: $!\n";
2169 $cwd_remove = undef;
2172 sub branchsuite () {
2173 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2174 if ($branch =~ m#$lbranch_re#o) {
2181 sub fetchpullargs () {
2183 if (!defined $package) {
2184 my $sourcep = parsecontrol('debian/control','debian/control');
2185 $package = getfield $sourcep, 'Source';
2188 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2190 my $clogp = parsechangelog();
2191 $isuite = getfield $clogp, 'Distribution';
2193 canonicalise_suite();
2194 progress "fetching from suite $csuite";
2195 } elsif (@ARGV==1) {
2197 canonicalise_suite();
2199 badusage "incorrect arguments to dgit fetch or dgit pull";
2218 badusage "-p is not allowed with dgit push" if defined $package;
2220 my $clogp = parsechangelog();
2221 $package = getfield $clogp, 'Source';
2224 } elsif (@ARGV==1) {
2225 ($specsuite) = (@ARGV);
2227 badusage "incorrect arguments to dgit push";
2229 $isuite = getfield $clogp, 'Distribution';
2231 local ($package) = $existing_package; # this is a hack
2232 canonicalise_suite();
2234 canonicalise_suite();
2236 if (defined $specsuite &&
2237 $specsuite ne $isuite &&
2238 $specsuite ne $csuite) {
2239 fail "dgit push: changelog specifies $isuite ($csuite)".
2240 " but command line specifies $specsuite";
2242 supplementary_message(<<'END');
2243 Push failed, while checking state of the archive.
2244 You can retry the push, after fixing the problem, if you like.
2246 if (check_for_git()) {
2250 if (fetch_from_archive()) {
2251 if (is_fast_fwd(lrref(), 'HEAD')) {
2253 } elsif (deliberately_not_fast_forward) {
2256 fail "dgit push: HEAD is not a descendant".
2257 " of the archive's version.\n".
2258 "dgit: To overwrite its contents,".
2259 " use git merge -s ours ".lrref().".\n".
2260 "dgit: To rewind history, if permitted by the archive,".
2261 " use --deliberately-not-fast-forward";
2265 fail "package appears to be new in this suite;".
2266 " if this is intentional, use --new";
2271 #---------- remote commands' implementation ----------
2273 sub cmd_remote_push_build_host {
2274 my ($nrargs) = shift @ARGV;
2275 my (@rargs) = @ARGV[0..$nrargs-1];
2276 @ARGV = @ARGV[$nrargs..$#ARGV];
2278 my ($dir,$vsnwant) = @rargs;
2279 # vsnwant is a comma-separated list; we report which we have
2280 # chosen in our ready response (so other end can tell if they
2283 $we_are_responder = 1;
2284 $us .= " (build host)";
2288 open PI, "<&STDIN" or die $!;
2289 open STDIN, "/dev/null" or die $!;
2290 open PO, ">&STDOUT" or die $!;
2292 open STDOUT, ">&STDERR" or die $!;
2296 ($protovsn) = grep {
2297 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2298 } @rpushprotovsn_support;
2300 fail "build host has dgit rpush protocol versions ".
2301 (join ",", @rpushprotovsn_support).
2302 " but invocation host has $vsnwant"
2303 unless defined $protovsn;
2305 responder_send_command("dgit-remote-push-ready $protovsn");
2311 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2312 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2313 # a good error message)
2319 my $report = i_child_report();
2320 if (defined $report) {
2321 printdebug "($report)\n";
2322 } elsif ($i_child_pid) {
2323 printdebug "(killing build host child $i_child_pid)\n";
2324 kill 15, $i_child_pid;
2326 if (defined $i_tmp && !defined $initiator_tempdir) {
2328 eval { rmtree $i_tmp; };
2332 END { i_cleanup(); }
2335 my ($base,$selector,@args) = @_;
2336 $selector =~ s/\-/_/g;
2337 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2344 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2352 push @rargs, join ",", @rpushprotovsn_support;
2355 push @rdgit, @ropts;
2356 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2358 my @cmd = (@ssh, $host, shellquote @rdgit);
2361 if (defined $initiator_tempdir) {
2362 rmtree $initiator_tempdir;
2363 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2364 $i_tmp = $initiator_tempdir;
2368 $i_child_pid = open2(\*RO, \*RI, @cmd);
2370 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2371 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2372 $supplementary_message = '' unless $protovsn >= 3;
2374 my ($icmd,$iargs) = initiator_expect {
2375 m/^(\S+)(?: (.*))?$/;
2378 i_method "i_resp", $icmd, $iargs;
2382 sub i_resp_progress ($) {
2384 my $msg = protocol_read_bytes \*RO, $rhs;
2388 sub i_resp_supplementary_message ($) {
2390 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2393 sub i_resp_complete {
2394 my $pid = $i_child_pid;
2395 $i_child_pid = undef; # prevents killing some other process with same pid
2396 printdebug "waiting for build host child $pid...\n";
2397 my $got = waitpid $pid, 0;
2398 die $! unless $got == $pid;
2399 die "build host child failed $?" if $?;
2402 printdebug "all done\n";
2406 sub i_resp_file ($) {
2408 my $localname = i_method "i_localname", $keyword;
2409 my $localpath = "$i_tmp/$localname";
2410 stat_exists $localpath and
2411 badproto \*RO, "file $keyword ($localpath) twice";
2412 protocol_receive_file \*RO, $localpath;
2413 i_method "i_file", $keyword;
2418 sub i_resp_param ($) {
2419 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2423 sub i_resp_previously ($) {
2424 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2425 or badproto \*RO, "bad previously spec";
2426 my $r = system qw(git check-ref-format), $1;
2427 die "bad previously ref spec ($r)" if $r;
2428 $previously{$1} = $2;
2433 sub i_resp_want ($) {
2435 die "$keyword ?" if $i_wanted{$keyword}++;
2436 my @localpaths = i_method "i_want", $keyword;
2437 printdebug "[[ $keyword @localpaths\n";
2438 foreach my $localpath (@localpaths) {
2439 protocol_send_file \*RI, $localpath;
2441 print RI "files-end\n" or die $!;
2444 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2446 sub i_localname_parsed_changelog {
2447 return "remote-changelog.822";
2449 sub i_file_parsed_changelog {
2450 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2451 push_parse_changelog "$i_tmp/remote-changelog.822";
2452 die if $i_dscfn =~ m#/|^\W#;
2455 sub i_localname_dsc {
2456 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2461 sub i_localname_changes {
2462 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2463 $i_changesfn = $i_dscfn;
2464 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2465 return $i_changesfn;
2467 sub i_file_changes { }
2469 sub i_want_signed_tag {
2470 printdebug Dumper(\%i_param, $i_dscfn);
2471 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2472 && defined $i_param{'csuite'}
2473 or badproto \*RO, "premature desire for signed-tag";
2474 my $head = $i_param{'head'};
2475 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2477 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2479 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2482 push_mktag $head, $i_clogp, $i_tag,
2484 $i_changesfn, 'remote changes',
2485 sub { "tag$_[0]"; };
2490 sub i_want_signed_dsc_changes {
2491 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2492 sign_changes $i_changesfn;
2493 return ($i_dscfn, $i_changesfn);
2496 #---------- building etc. ----------
2502 #----- `3.0 (quilt)' handling -----
2504 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2506 sub quiltify_dpkg_commit ($$$;$) {
2507 my ($patchname,$author,$msg, $xinfo) = @_;
2511 my $descfn = ".git/dgit/quilt-description.tmp";
2512 open O, '>', $descfn or die "$descfn: $!";
2515 $msg =~ s/^\s+$/ ./mg;
2516 print O <<END or die $!;
2526 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2527 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2528 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2529 runcmd @dpkgsource, qw(--commit .), $patchname;
2533 sub quiltify_trees_differ ($$;$$) {
2534 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2535 # returns true iff the two tree objects differ other than in debian/
2536 # with $finegrained,
2537 # returns bitmask 01 - differ in upstream files except .gitignore
2538 # 02 - differ in .gitignore
2539 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2540 # is set for each modified .gitignore filename $fn
2542 my @cmd = (@git, qw(diff-tree --name-only -z));
2543 push @cmd, qw(-r) if $finegrained;
2545 my $diffs= cmdoutput @cmd;
2547 foreach my $f (split /\0/, $diffs) {
2548 next if $f =~ m#^debian(?:/.*)?$#s;
2549 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2550 $r |= $isignore ? 02 : 01;
2551 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2553 printdebug "quiltify_trees_differ $x $y => $r\n";
2557 sub quiltify_tree_sentinelfiles ($) {
2558 # lists the `sentinel' files present in the tree
2560 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2561 qw(-- debian/rules debian/control);
2566 sub quiltify_splitbrain_needed () {
2567 if (!$split_brain) {
2568 progress "dgit view: changes are required...";
2569 runcmd @git, qw(checkout -q -b dgit-view);
2574 sub quiltify_splitbrain ($$$$$$) {
2575 my ($clogp, $unapplied, $headref, $diffbits,
2576 $editedignores, $cachekey) = @_;
2577 if ($quilt_mode !~ m/gbp|dpm/) {
2578 # treat .gitignore just like any other upstream file
2579 $diffbits = { %$diffbits };
2580 $_ = !!$_ foreach values %$diffbits;
2582 # We would like any commits we generate to be reproducible
2583 my @authline = clogp_authline($clogp);
2584 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2585 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2586 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2588 if ($quilt_mode =~ m/gbp|unapplied/ &&
2589 ($diffbits->{H2O} & 01)) {
2591 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2592 " but git tree differs from orig in upstream files.";
2593 if (!stat_exists "debian/patches") {
2595 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2599 if ($quilt_mode =~ m/gbp|unapplied/ &&
2600 ($diffbits->{O2A} & 01)) { # some patches
2601 quiltify_splitbrain_needed();
2602 progress "dgit view: creating patches-applied version using gbp pq";
2603 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2604 # gbp pq import creates a fresh branch; push back to dgit-view
2605 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2606 runcmd @git, qw(checkout -q dgit-view);
2608 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2609 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2610 quiltify_splitbrain_needed();
2611 progress "dgit view: creating patch to represent .gitignore changes";
2612 ensuredir "debian/patches";
2613 my $gipatch = "debian/patches/auto-gitignore";
2614 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2615 stat GIPATCH or die "$gipatch: $!";
2616 fail "$gipatch already exists; but want to create it".
2617 " to record .gitignore changes" if (stat _)[7];
2618 print GIPATCH <<END or die "$gipatch: $!";
2619 Subject: Update .gitignore from Debian packaging branch
2621 The Debian packaging git branch contains these updates to the upstream
2622 .gitignore file(s). This patch is autogenerated, to provide these
2623 updates to users of the official Debian archive view of the package.
2625 [dgit version $our_version]
2628 close GIPATCH or die "$gipatch: $!";
2629 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2630 $unapplied, $headref, "--", sort keys %$editedignores;
2631 open SERIES, "+>>", "debian/patches/series" or die $!;
2632 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2634 defined read SERIES, $newline, 1 or die $!;
2635 print SERIES "\n" or die $! unless $newline eq "\n";
2636 print SERIES "auto-gitignore\n" or die $!;
2637 close SERIES or die $!;
2638 runcmd @git, qw(add -- debian/patches/series), $gipatch;
2639 commit_admin "Commit patch to update .gitignore";
2642 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2644 changedir '../../../..';
2645 ensuredir ".git/logs/refs/dgit-intern";
2646 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2648 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2651 progress "dgit view: created (commit id $dgitview)";
2653 changedir '.git/dgit/unpack/work';
2656 sub quiltify ($$$$) {
2657 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2659 # Quilt patchification algorithm
2661 # We search backwards through the history of the main tree's HEAD
2662 # (T) looking for a start commit S whose tree object is identical
2663 # to to the patch tip tree (ie the tree corresponding to the
2664 # current dpkg-committed patch series). For these purposes
2665 # `identical' disregards anything in debian/ - this wrinkle is
2666 # necessary because dpkg-source treates debian/ specially.
2668 # We can only traverse edges where at most one of the ancestors'
2669 # trees differs (in changes outside in debian/). And we cannot
2670 # handle edges which change .pc/ or debian/patches. To avoid
2671 # going down a rathole we avoid traversing edges which introduce
2672 # debian/rules or debian/control. And we set a limit on the
2673 # number of edges we are willing to look at.
2675 # If we succeed, we walk forwards again. For each traversed edge
2676 # PC (with P parent, C child) (starting with P=S and ending with
2677 # C=T) to we do this:
2679 # - dpkg-source --commit with a patch name and message derived from C
2680 # After traversing PT, we git commit the changes which
2681 # should be contained within debian/patches.
2683 # The search for the path S..T is breadth-first. We maintain a
2684 # todo list containing search nodes. A search node identifies a
2685 # commit, and looks something like this:
2687 # Commit => $git_commit_id,
2688 # Child => $c, # or undef if P=T
2689 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2690 # Nontrivial => true iff $p..$c has relevant changes
2697 my %considered; # saves being exponential on some weird graphs
2699 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2702 my ($search,$whynot) = @_;
2703 printdebug " search NOT $search->{Commit} $whynot\n";
2704 $search->{Whynot} = $whynot;
2705 push @nots, $search;
2706 no warnings qw(exiting);
2715 my $c = shift @todo;
2716 next if $considered{$c->{Commit}}++;
2718 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2720 printdebug "quiltify investigate $c->{Commit}\n";
2723 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2724 printdebug " search finished hooray!\n";
2729 if ($quilt_mode eq 'nofix') {
2730 fail "quilt fixup required but quilt mode is \`nofix'\n".
2731 "HEAD commit $c->{Commit} differs from tree implied by ".
2732 " debian/patches (tree object $oldtiptree)";
2734 if ($quilt_mode eq 'smash') {
2735 printdebug " search quitting smash\n";
2739 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2740 $not->($c, "has $c_sentinels not $t_sentinels")
2741 if $c_sentinels ne $t_sentinels;
2743 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2744 $commitdata =~ m/\n\n/;
2746 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2747 @parents = map { { Commit => $_, Child => $c } } @parents;
2749 $not->($c, "root commit") if !@parents;
2751 foreach my $p (@parents) {
2752 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2754 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2755 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2757 foreach my $p (@parents) {
2758 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2760 my @cmd= (@git, qw(diff-tree -r --name-only),
2761 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2762 my $patchstackchange = cmdoutput @cmd;
2763 if (length $patchstackchange) {
2764 $patchstackchange =~ s/\n/,/g;
2765 $not->($p, "changed $patchstackchange");
2768 printdebug " search queue P=$p->{Commit} ",
2769 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2775 printdebug "quiltify want to smash\n";
2778 my $x = $_[0]{Commit};
2779 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2782 my $reportnot = sub {
2784 my $s = $abbrev->($notp);
2785 my $c = $notp->{Child};
2786 $s .= "..".$abbrev->($c) if $c;
2787 $s .= ": ".$notp->{Whynot};
2790 if ($quilt_mode eq 'linear') {
2791 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2792 foreach my $notp (@nots) {
2793 print STDERR "$us: ", $reportnot->($notp), "\n";
2795 print STDERR "$us: $_\n" foreach @$failsuggestion;
2796 fail "quilt fixup naive history linearisation failed.\n".
2797 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2798 } elsif ($quilt_mode eq 'smash') {
2799 } elsif ($quilt_mode eq 'auto') {
2800 progress "quilt fixup cannot be linear, smashing...";
2802 die "$quilt_mode ?";
2807 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2809 quiltify_dpkg_commit "auto-$version-$target-$time",
2810 (getfield $clogp, 'Maintainer'),
2811 "Automatically generated patch ($clogp->{Version})\n".
2812 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2816 progress "quiltify linearisation planning successful, executing...";
2818 for (my $p = $sref_S;
2819 my $c = $p->{Child};
2821 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2822 next unless $p->{Nontrivial};
2824 my $cc = $c->{Commit};
2826 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2827 $commitdata =~ m/\n\n/ or die "$c ?";
2830 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2833 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2836 my $patchname = $title;
2837 $patchname =~ s/[.:]$//;
2838 $patchname =~ y/ A-Z/-a-z/;
2839 $patchname =~ y/-a-z0-9_.+=~//cd;
2840 $patchname =~ s/^\W/x-$&/;
2841 $patchname = substr($patchname,0,40);
2844 stat "debian/patches/$patchname$index";
2846 $!==ENOENT or die "$patchname$index $!";
2848 runcmd @git, qw(checkout -q), $cc;
2850 # We use the tip's changelog so that dpkg-source doesn't
2851 # produce complaining messages from dpkg-parsechangelog. None
2852 # of the information dpkg-source gets from the changelog is
2853 # actually relevant - it gets put into the original message
2854 # which dpkg-source provides our stunt editor, and then
2856 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2858 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2859 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2861 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2864 runcmd @git, qw(checkout -q master);
2867 sub build_maybe_quilt_fixup () {
2868 my ($format,$fopts) = get_source_format;
2869 return unless madformat $format;
2872 check_for_vendor_patches();
2874 my $clogp = parsechangelog();
2875 my $headref = git_rev_parse('HEAD');
2880 my $upstreamversion=$version;
2881 $upstreamversion =~ s/-[^-]*$//;
2883 if ($fopts->{'single-debian-patch'}) {
2884 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2886 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2889 die 'bug' if $split_brain && !$need_split_build_invocation;
2891 changedir '../../../..';
2892 runcmd_ordryrun_local
2893 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2896 sub quilt_fixup_mkwork ($) {
2899 mkdir "work" or die $!;
2901 mktree_in_ud_here();
2902 runcmd @git, qw(reset -q --hard), $headref;
2905 sub quilt_fixup_linkorigs ($$) {
2906 my ($upstreamversion, $fn) = @_;
2907 # calls $fn->($leafname);
2909 foreach my $f (<../../../../*>) { #/){
2910 my $b=$f; $b =~ s{.*/}{};
2912 local ($debuglevel) = $debuglevel-1;
2913 printdebug "QF linkorigs $b, $f ?\n";
2915 next unless is_orig_file $b, srcfn $upstreamversion,'';
2916 printdebug "QF linkorigs $b, $f Y\n";
2917 link_ltarget $f, $b or die "$b $!";
2922 sub quilt_fixup_delete_pc () {
2923 runcmd @git, qw(rm -rqf .pc);
2924 commit_admin "Commit removal of .pc (quilt series tracking data)";
2927 sub quilt_fixup_singlepatch ($$$) {
2928 my ($clogp, $headref, $upstreamversion) = @_;
2930 progress "starting quiltify (single-debian-patch)";
2932 # dpkg-source --commit generates new patches even if
2933 # single-debian-patch is in debian/source/options. In order to
2934 # get it to generate debian/patches/debian-changes, it is
2935 # necessary to build the source package.
2937 quilt_fixup_linkorigs($upstreamversion, sub { });
2938 quilt_fixup_mkwork($headref);
2940 rmtree("debian/patches");
2942 runcmd @dpkgsource, qw(-b .);
2944 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2945 rename srcfn("$upstreamversion", "/debian/patches"),
2946 "work/debian/patches";
2949 commit_quilty_patch();
2952 sub quilt_make_fake_dsc ($) {
2953 my ($upstreamversion) = @_;
2955 my $fakeversion="$upstreamversion-~~DGITFAKE";
2957 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2958 print $fakedsc <<END or die $!;
2961 Version: $fakeversion
2965 my $dscaddfile=sub {
2968 my $md = new Digest::MD5;
2970 my $fh = new IO::File $b, '<' or die "$b $!";
2975 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2978 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2980 my @files=qw(debian/source/format debian/rules
2981 debian/control debian/changelog);
2982 foreach my $maybe (qw(debian/patches debian/source/options
2983 debian/tests/control)) {
2984 next unless stat_exists "../../../$maybe";
2985 push @files, $maybe;
2988 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2989 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
2991 $dscaddfile->($debtar);
2992 close $fakedsc or die $!;
2995 sub quilt_check_splitbrain_cache ($$) {
2996 my ($headref, $upstreamversion) = @_;
2997 # Called only if we are in (potentially) split brain mode.
2999 # Computes the cache key and looks in the cache.
3000 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3002 my $splitbrain_cachekey;
3005 "dgit: split brain (separate dgit view) may needed (--quilt=$quilt_mode).";
3006 # we look in the reflog of dgit-intern/quilt-cache
3007 # we look for an entry whose message is the key for the cache lookup
3008 my @cachekey = (qw(dgit), $our_version);
3009 push @cachekey, $upstreamversion;
3010 push @cachekey, $quilt_mode;
3011 push @cachekey, $headref;
3013 push @cachekey, hashfile('fake.dsc');
3015 my $srcshash = Digest::SHA->new(256);
3016 my %sfs = ( %INC, '$0(dgit)' => $0 );
3017 foreach my $sfk (sort keys %sfs) {
3018 $srcshash->add($sfk," ");
3019 $srcshash->add(hashfile($sfs{$sfk}));
3020 $srcshash->add("\n");
3022 push @cachekey, $srcshash->hexdigest();
3023 $splitbrain_cachekey = "@cachekey";
3025 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3027 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3028 debugcmd "|(probably)",@cmd;
3029 my $child = open GC, "-|"; defined $child or die $!;
3031 chdir '../../..' or die $!;
3032 if (!stat ".git/logs/refs/$splitbraincache") {
3033 $! == ENOENT or die $!;
3034 printdebug ">(no reflog)\n";
3041 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3042 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3045 quilt_fixup_mkwork($headref);
3046 if ($cachehit ne $headref) {
3047 progress "dgit view: found cached (commit id $cachehit)";
3048 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3050 return ($cachehit, $splitbrain_cachekey);
3052 progress "dgit view: found cached, no changes required";
3053 return ($headref, $splitbrain_cachekey);
3055 die $! if GC->error;
3056 failedcmd unless close GC;
3058 printdebug "splitbrain cache miss\n";
3059 return (undef, $splitbrain_cachekey);
3062 sub quilt_fixup_multipatch ($$$) {
3063 my ($clogp, $headref, $upstreamversion) = @_;
3065 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3068 # - honour any existing .pc in case it has any strangeness
3069 # - determine the git commit corresponding to the tip of
3070 # the patch stack (if there is one)
3071 # - if there is such a git commit, convert each subsequent
3072 # git commit into a quilt patch with dpkg-source --commit
3073 # - otherwise convert all the differences in the tree into
3074 # a single git commit
3078 # Our git tree doesn't necessarily contain .pc. (Some versions of
3079 # dgit would include the .pc in the git tree.) If there isn't
3080 # one, we need to generate one by unpacking the patches that we
3083 # We first look for a .pc in the git tree. If there is one, we
3084 # will use it. (This is not the normal case.)
3086 # Otherwise need to regenerate .pc so that dpkg-source --commit
3087 # can work. We do this as follows:
3088 # 1. Collect all relevant .orig from parent directory
3089 # 2. Generate a debian.tar.gz out of
3090 # debian/{patches,rules,source/format,source/options}
3091 # 3. Generate a fake .dsc containing just these fields:
3092 # Format Source Version Files
3093 # 4. Extract the fake .dsc
3094 # Now the fake .dsc has a .pc directory.
3095 # (In fact we do this in every case, because in future we will
3096 # want to search for a good base commit for generating patches.)
3098 # Then we can actually do the dpkg-source --commit
3099 # 1. Make a new working tree with the same object
3100 # store as our main tree and check out the main
3102 # 2. Copy .pc from the fake's extraction, if necessary
3103 # 3. Run dpkg-source --commit
3104 # 4. If the result has changes to debian/, then
3105 # - git-add them them
3106 # - git-add .pc if we had a .pc in-tree
3108 # 5. If we had a .pc in-tree, delete it, and git-commit
3109 # 6. Back in the main tree, fast forward to the new HEAD
3111 # Another situation we may have to cope with is gbp-style
3112 # patches-unapplied trees.
3114 # We would want to detect these, so we know to escape into
3115 # quilt_fixup_gbp. However, this is in general not possible.
3116 # Consider a package with a one patch which the dgit user reverts
3117 # (with git-revert or the moral equivalent).
3119 # That is indistinguishable in contents from a patches-unapplied
3120 # tree. And looking at the history to distinguish them is not
3121 # useful because the user might have made a confusing-looking git
3122 # history structure (which ought to produce an error if dgit can't
3123 # cope, not a silent reintroduction of an unwanted patch).
3125 # So gbp users will have to pass an option. But we can usually
3126 # detect their failure to do so: if the tree is not a clean
3127 # patches-applied tree, quilt linearisation fails, but the tree
3128 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3129 # they want --quilt=unapplied.
3131 # To help detect this, when we are extracting the fake dsc, we
3132 # first extract it with --skip-patches, and then apply the patches
3133 # afterwards with dpkg-source --before-build. That lets us save a
3134 # tree object corresponding to .origs.
3136 my $splitbrain_cachekey;
3138 quilt_make_fake_dsc($upstreamversion);
3140 if (quiltmode_splitbrain()) {
3142 ($cachehit, $splitbrain_cachekey) =
3143 quilt_check_splitbrain_cache($headref, $upstreamversion);
3144 return if $cachehit;
3148 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3150 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3151 rename $fakexdir, "fake" or die "$fakexdir $!";
3155 remove_stray_gits();
3156 mktree_in_ud_here();
3160 runcmd @git, qw(add -Af .);
3161 my $unapplied=git_write_tree();
3162 printdebug "fake orig tree object $unapplied\n";
3167 'exec dpkg-source --before-build . >/dev/null';
3171 quilt_fixup_mkwork($headref);
3174 if (stat_exists ".pc") {
3176 progress "Tree already contains .pc - will use it then delete it.";
3179 rename '../fake/.pc','.pc' or die $!;
3182 changedir '../fake';
3184 runcmd @git, qw(add -Af .);
3185 my $oldtiptree=git_write_tree();
3186 printdebug "fake o+d/p tree object $unapplied\n";
3187 changedir '../work';
3190 # We calculate some guesswork now about what kind of tree this might
3191 # be. This is mostly for error reporting.
3196 # O = orig, without patches applied
3197 # A = "applied", ie orig with H's debian/patches applied
3198 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3199 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3200 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3204 foreach my $b (qw(01 02)) {
3205 foreach my $v (qw(H2O O2A H2A)) {
3206 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3209 printdebug "differences \@dl @dl.\n";
3212 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3213 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3214 $dl[0], $dl[1], $dl[3], $dl[4],
3218 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3219 push @failsuggestion, "This might be a patches-unapplied branch.";
3220 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3221 push @failsuggestion, "This might be a patches-applied branch.";
3223 push @failsuggestion, "Maybe you need to specify one of".
3224 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3226 if (quiltmode_splitbrain()) {
3227 quiltify_splitbrain($clogp, $unapplied, $headref,
3228 $diffbits, \%editedignores,
3229 $splitbrain_cachekey);
3233 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3234 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3236 if (!open P, '>>', ".pc/applied-patches") {
3237 $!==&ENOENT or die $!;
3242 commit_quilty_patch();
3244 if ($mustdeletepc) {
3245 quilt_fixup_delete_pc();
3249 sub quilt_fixup_editor () {
3250 my $descfn = $ENV{$fakeeditorenv};
3251 my $editing = $ARGV[$#ARGV];
3252 open I1, '<', $descfn or die "$descfn: $!";
3253 open I2, '<', $editing or die "$editing: $!";
3254 unlink $editing or die "$editing: $!";
3255 open O, '>', $editing or die "$editing: $!";
3256 while (<I1>) { print O or die $!; } I1->error and die $!;
3259 $copying ||= m/^\-\-\- /;
3260 next unless $copying;
3263 I2->error and die $!;
3268 sub maybe_apply_patches_dirtily () {
3269 return unless $quilt_mode =~ m/gbp|unapplied/;
3270 print STDERR <<END or die $!;
3272 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3273 dgit: Have to apply the patches - making the tree dirty.
3274 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3277 $patches_applied_dirtily = 01;
3278 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3279 runcmd qw(dpkg-source --before-build .);
3282 sub maybe_unapply_patches_again () {
3283 progress "dgit: Unapplying patches again to tidy up the tree."
3284 if $patches_applied_dirtily;
3285 runcmd qw(dpkg-source --after-build .)
3286 if $patches_applied_dirtily & 01;
3288 if $patches_applied_dirtily & 02;
3291 #----- other building -----
3293 our $clean_using_builder;
3294 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3295 # clean the tree before building (perhaps invoked indirectly by
3296 # whatever we are using to run the build), rather than separately
3297 # and explicitly by us.
3300 return if $clean_using_builder;
3301 if ($cleanmode eq 'dpkg-source') {
3302 maybe_apply_patches_dirtily();
3303 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3304 } elsif ($cleanmode eq 'dpkg-source-d') {
3305 maybe_apply_patches_dirtily();
3306 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3307 } elsif ($cleanmode eq 'git') {
3308 runcmd_ordryrun_local @git, qw(clean -xdf);
3309 } elsif ($cleanmode eq 'git-ff') {
3310 runcmd_ordryrun_local @git, qw(clean -xdff);
3311 } elsif ($cleanmode eq 'check') {
3312 my $leftovers = cmdoutput @git, qw(clean -xdn);
3313 if (length $leftovers) {
3314 print STDERR $leftovers, "\n" or die $!;
3315 fail "tree contains uncommitted files and --clean=check specified";
3317 } elsif ($cleanmode eq 'none') {
3324 badusage "clean takes no additional arguments" if @ARGV;
3327 maybe_unapply_patches_again();
3332 badusage "-p is not allowed when building" if defined $package;
3335 my $clogp = parsechangelog();
3336 $isuite = getfield $clogp, 'Distribution';
3337 $package = getfield $clogp, 'Source';
3338 $version = getfield $clogp, 'Version';
3339 build_maybe_quilt_fixup();
3341 my $pat = changespat $version;
3342 foreach my $f (glob "$buildproductsdir/$pat") {
3344 unlink $f or fail "remove old changes file $f: $!";
3346 progress "would remove $f";
3352 sub changesopts_initial () {
3353 my @opts =@changesopts[1..$#changesopts];
3356 sub changesopts_version () {
3357 if (!defined $changes_since_version) {
3358 my @vsns = archive_query('archive_query');
3359 my @quirk = access_quirk();
3360 if ($quirk[0] eq 'backports') {
3361 local $isuite = $quirk[2];
3363 canonicalise_suite();
3364 push @vsns, archive_query('archive_query');
3367 @vsns = map { $_->[0] } @vsns;
3368 @vsns = sort { -version_compare($a, $b) } @vsns;
3369 $changes_since_version = $vsns[0];
3370 progress "changelog will contain changes since $vsns[0]";
3372 $changes_since_version = '_';
3373 progress "package seems new, not specifying -v<version>";
3376 if ($changes_since_version ne '_') {
3377 return ("-v$changes_since_version");
3383 sub changesopts () {
3384 return (changesopts_initial(), changesopts_version());
3387 sub massage_dbp_args ($;$) {
3388 my ($cmd,$xargs) = @_;
3391 # - if we're going to split the source build out so we can
3392 # do strange things to it, massage the arguments to dpkg-buildpackage
3393 # so that the main build doessn't build source (or add an argument
3394 # to stop it building source by default).
3396 # - add -nc to stop dpkg-source cleaning the source tree,
3397 # unless we're not doing a split build and want dpkg-source
3398 # as cleanmode, in which case we can do nothing
3401 # 0 - source will NOT need to be built separately by caller
3402 # +1 - source will need to be built separately by caller
3403 # +2 - source will need to be built separately by caller AND
3404 # dpkg-buildpackage should not in fact be run at all!
3405 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3406 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3407 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3408 $clean_using_builder = 1;
3411 # -nc has the side effect of specifying -b if nothing else specified
3412 # and some combinations of -S, -b, et al, are errors, rather than
3413 # later simply overriding earlie. So we need to:
3414 # - search the command line for these options
3415 # - pick the last one
3416 # - perhaps add our own as a default
3417 # - perhaps adjust it to the corresponding non-source-building version
3419 foreach my $l ($cmd, $xargs) {
3421 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3424 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3426 if ($need_split_build_invocation) {
3427 printdebug "massage split $dmode.\n";
3428 $r = $dmode =~ m/[S]/ ? +2 :
3429 $dmode =~ y/gGF/ABb/ ? +1 :
3430 $dmode =~ m/[ABb]/ ? 0 :
3433 printdebug "massage done $r $dmode.\n";
3435 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3440 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3441 my $wantsrc = massage_dbp_args \@dbp;
3448 push @dbp, changesopts_version();
3449 maybe_apply_patches_dirtily();
3450 runcmd_ordryrun_local @dbp;
3452 maybe_unapply_patches_again();
3453 printdone "build successful\n";
3457 my @dbp = @dpkgbuildpackage;
3459 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3462 if (length executable_on_path('git-buildpackage')) {
3463 @cmd = qw(git-buildpackage);
3465 @cmd = qw(gbp buildpackage);
3467 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3472 if (!$clean_using_builder) {
3473 push @cmd, '--git-cleaner=true';
3478 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3479 canonicalise_suite();
3480 push @cmd, "--git-debian-branch=".lbranch();
3482 push @cmd, changesopts();
3483 maybe_apply_patches_dirtily();
3484 runcmd_ordryrun_local @cmd, @ARGV;
3486 maybe_unapply_patches_again();
3487 printdone "build successful\n";
3489 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3492 my $our_cleanmode = $cleanmode;
3493 if ($need_split_build_invocation) {
3494 # Pretend that clean is being done some other way. This
3495 # forces us not to try to use dpkg-buildpackage to clean and
3496 # build source all in one go; and instead we run dpkg-source
3497 # (and build_prep() will do the clean since $clean_using_builder
3499 $our_cleanmode = 'ELSEWHERE';
3501 if ($our_cleanmode =~ m/^dpkg-source/) {
3502 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3503 $clean_using_builder = 1;
3506 $sourcechanges = changespat $version,'source';
3508 unlink "../$sourcechanges" or $!==ENOENT
3509 or fail "remove $sourcechanges: $!";
3511 $dscfn = dscfn($version);
3512 if ($our_cleanmode eq 'dpkg-source') {
3513 maybe_apply_patches_dirtily();
3514 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3516 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3517 maybe_apply_patches_dirtily();
3518 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3521 my @cmd = (@dpkgsource, qw(-b --));
3524 runcmd_ordryrun_local @cmd, "work";
3525 my @udfiles = <${package}_*>;
3526 changedir "../../..";
3527 foreach my $f (@udfiles) {
3528 printdebug "source copy, found $f\n";
3531 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3532 $f eq srcfn($version, $&));
3533 printdebug "source copy, found $f - renaming\n";
3534 rename "$ud/$f", "../$f" or $!==ENOENT
3535 or fail "put in place new source file ($f): $!";
3538 my $pwd = must_getcwd();
3539 my $leafdir = basename $pwd;
3541 runcmd_ordryrun_local @cmd, $leafdir;
3544 runcmd_ordryrun_local qw(sh -ec),
3545 'exec >$1; shift; exec "$@"','x',
3546 "../$sourcechanges",
3547 @dpkggenchanges, qw(-S), changesopts();
3551 sub cmd_build_source {
3552 badusage "build-source takes no additional arguments" if @ARGV;
3554 maybe_unapply_patches_again();
3555 printdone "source built, results in $dscfn and $sourcechanges";
3560 my $pat = changespat $version;
3562 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3563 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3564 fail "changes files other than source matching $pat".
3565 " already present (@unwanted);".
3566 " building would result in ambiguity about the intended results"
3571 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3572 stat_exists $sourcechanges
3573 or fail "$sourcechanges (in parent directory): $!";
3575 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3576 my @changesfiles = glob $pat;
3577 @changesfiles = sort {
3578 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3581 fail "wrong number of different changes files (@changesfiles)"
3582 unless @changesfiles==2;
3583 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3584 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3585 fail "$l found in binaries changes file $binchanges"
3588 runcmd_ordryrun_local @mergechanges, @changesfiles;
3589 my $multichanges = changespat $version,'multi';
3591 stat_exists $multichanges or fail "$multichanges: $!";
3592 foreach my $cf (glob $pat) {
3593 next if $cf eq $multichanges;
3594 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3597 maybe_unapply_patches_again();
3598 printdone "build successful, results in $multichanges\n" or die $!;
3601 sub cmd_quilt_fixup {
3602 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3603 my $clogp = parsechangelog();
3604 $version = getfield $clogp, 'Version';
3605 $package = getfield $clogp, 'Source';
3608 build_maybe_quilt_fixup();
3611 sub cmd_archive_api_query {
3612 badusage "need only 1 subpath argument" unless @ARGV==1;
3613 my ($subpath) = @ARGV;
3614 my @cmd = archive_api_query_cmd($subpath);
3616 exec @cmd or fail "exec curl: $!\n";
3619 sub cmd_clone_dgit_repos_server {
3620 badusage "need destination argument" unless @ARGV==1;
3621 my ($destdir) = @ARGV;
3622 $package = '_dgit-repos-server';
3623 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3625 exec @cmd or fail "exec git clone: $!\n";
3628 sub cmd_setup_mergechangelogs {
3629 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3630 setup_mergechangelogs(1);
3633 sub cmd_setup_useremail {
3634 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3638 sub cmd_setup_new_tree {
3639 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3643 #---------- argument parsing and main program ----------
3646 print "dgit version $our_version\n" or die $!;
3650 our (%valopts_long, %valopts_short);
3653 sub defvalopt ($$$$) {
3654 my ($long,$short,$val_re,$how) = @_;
3655 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3656 $valopts_long{$long} = $oi;
3657 $valopts_short{$short} = $oi;
3658 # $how subref should:
3659 # do whatever assignemnt or thing it likes with $_[0]
3660 # if the option should not be passed on to remote, @rvalopts=()
3661 # or $how can be a scalar ref, meaning simply assign the value
3664 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3665 defvalopt '--distro', '-d', '.+', \$idistro;
3666 defvalopt '', '-k', '.+', \$keyid;
3667 defvalopt '--existing-package','', '.*', \$existing_package;
3668 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3669 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3670 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3672 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3674 defvalopt '', '-C', '.+', sub {
3675 ($changesfile) = (@_);
3676 if ($changesfile =~ s#^(.*)/##) {
3677 $buildproductsdir = $1;
3681 defvalopt '--initiator-tempdir','','.*', sub {
3682 ($initiator_tempdir) = (@_);
3683 $initiator_tempdir =~ m#^/# or
3684 badusage "--initiator-tempdir must be used specify an".
3685 " absolute, not relative, directory."
3691 if (defined $ENV{'DGIT_SSH'}) {
3692 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3693 } elsif (defined $ENV{'GIT_SSH'}) {
3694 @ssh = ($ENV{'GIT_SSH'});
3702 if (!defined $val) {
3703 badusage "$what needs a value" unless @ARGV;
3705 push @rvalopts, $val;
3707 badusage "bad value \`$val' for $what" unless
3708 $val =~ m/^$oi->{Re}$(?!\n)/s;
3709 my $how = $oi->{How};
3710 if (ref($how) eq 'SCALAR') {
3715 push @ropts, @rvalopts;
3719 last unless $ARGV[0] =~ m/^-/;
3723 if (m/^--dry-run$/) {
3726 } elsif (m/^--damp-run$/) {
3729 } elsif (m/^--no-sign$/) {
3732 } elsif (m/^--help$/) {
3734 } elsif (m/^--version$/) {
3736 } elsif (m/^--new$/) {
3739 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3740 ($om = $opts_opt_map{$1}) &&
3744 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3745 !$opts_opt_cmdonly{$1} &&
3746 ($om = $opts_opt_map{$1})) {
3749 } elsif (m/^--ignore-dirty$/s) {
3752 } elsif (m/^--no-quilt-fixup$/s) {
3754 $quilt_mode = 'nocheck';
3755 } elsif (m/^--no-rm-on-error$/s) {
3758 } elsif (m/^--(no-)?rm-old-changes$/s) {
3761 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3763 push @deliberatelies, $&;
3764 } elsif (m/^--always-split-source-build$/s) {
3765 # undocumented, for testing
3767 $need_split_build_invocation = 1;
3768 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3769 $val = $2 ? $' : undef; #';
3770 $valopt->($oi->{Long});
3772 badusage "unknown long option \`$_'";
3779 } elsif (s/^-L/-/) {
3782 } elsif (s/^-h/-/) {
3784 } elsif (s/^-D/-/) {
3788 } elsif (s/^-N/-/) {
3793 push @changesopts, $_;
3795 } elsif (s/^-wn$//s) {
3797 $cleanmode = 'none';
3798 } elsif (s/^-wg$//s) {
3801 } elsif (s/^-wgf$//s) {
3803 $cleanmode = 'git-ff';
3804 } elsif (s/^-wd$//s) {
3806 $cleanmode = 'dpkg-source';
3807 } elsif (s/^-wdd$//s) {
3809 $cleanmode = 'dpkg-source-d';
3810 } elsif (s/^-wc$//s) {
3812 $cleanmode = 'check';
3813 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3815 $val = undef unless length $val;
3816 $valopt->($oi->{Short});
3819 badusage "unknown short option \`$_'";
3826 sub finalise_opts_opts () {
3827 foreach my $k (keys %opts_opt_map) {
3828 my $om = $opts_opt_map{$k};
3830 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3832 badcfg "cannot set command for $k"
3833 unless length $om->[0];
3837 foreach my $c (access_cfg_cfgs("opts-$k")) {
3838 my $vl = $gitcfg{$c};
3839 printdebug "CL $c ",
3840 ($vl ? join " ", map { shellquote } @$vl : ""),
3841 "\n" if $debuglevel >= 4;
3843 badcfg "cannot configure options for $k"
3844 if $opts_opt_cmdonly{$k};
3845 my $insertpos = $opts_cfg_insertpos{$k};
3846 @$om = ( @$om[0..$insertpos-1],
3848 @$om[$insertpos..$#$om] );
3853 if ($ENV{$fakeeditorenv}) {
3855 quilt_fixup_editor();
3861 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3862 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3863 if $dryrun_level == 1;
3865 print STDERR $helpmsg or die $!;
3868 my $cmd = shift @ARGV;
3871 if (!defined $rmchanges) {
3872 local $access_forpush;
3873 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3876 if (!defined $quilt_mode) {
3877 local $access_forpush;
3878 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3879 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3881 $quilt_mode =~ m/^($quilt_modes_re)$/
3882 or badcfg "unknown quilt-mode \`$quilt_mode'";
3886 $need_split_build_invocation ||= quiltmode_splitbrain();
3888 if (!defined $cleanmode) {
3889 local $access_forpush;
3890 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3891 $cleanmode //= 'dpkg-source';
3893 badcfg "unknown clean-mode \`$cleanmode'" unless
3894 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3897 my $fn = ${*::}{"cmd_$cmd"};
3898 $fn or badusage "unknown operation $cmd";