3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 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);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Text::Glob qw(match_glob);
44 our $our_version = 'UNRELEASED'; ###substituted###
45 our $absurdity = undef; ###substituted###
47 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
50 our $isuite = 'unstable';
56 our $dryrun_level = 0;
58 our $buildproductsdir = '..';
64 our $existing_package = 'dpkg';
66 our $changes_since_version;
68 our $overwrite_version; # undef: not specified; '': check changelog
70 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
71 our $split_brain_save;
72 our $we_are_responder;
73 our $initiator_tempdir;
74 our $patches_applied_dirtily = 00;
79 our %forceopts = map { $_=>0 }
80 qw(unrepresentable unsupported-source-format
81 dsc-changes-mismatch changes-origs-exactly
82 import-gitapply-absurd
83 import-gitapply-no-absurd
84 import-dsc-with-dgit-field);
86 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
88 our $suite_re = '[-+.0-9a-z]+';
89 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
90 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
91 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
92 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
94 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
95 our $splitbraincache = 'dgit-intern/quilt-cache';
98 our (@dget) = qw(dget);
99 our (@curl) = qw(curl);
100 our (@dput) = qw(dput);
101 our (@debsign) = qw(debsign);
102 our (@gpg) = qw(gpg);
103 our (@sbuild) = qw(sbuild);
105 our (@dgit) = qw(dgit);
106 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
107 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
108 our (@dpkggenchanges) = qw(dpkg-genchanges);
109 our (@mergechanges) = qw(mergechanges -f);
110 our (@gbp_build) = ('');
111 our (@gbp_pq) = ('gbp pq');
112 our (@changesopts) = ('');
114 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
117 'debsign' => \@debsign,
119 'sbuild' => \@sbuild,
123 'dpkg-source' => \@dpkgsource,
124 'dpkg-buildpackage' => \@dpkgbuildpackage,
125 'dpkg-genchanges' => \@dpkggenchanges,
126 'gbp-build' => \@gbp_build,
127 'gbp-pq' => \@gbp_pq,
128 'ch' => \@changesopts,
129 'mergechanges' => \@mergechanges);
131 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
132 our %opts_cfg_insertpos = map {
134 scalar @{ $opts_opt_map{$_} }
135 } keys %opts_opt_map;
137 sub finalise_opts_opts();
143 our $supplementary_message = '';
144 our $need_split_build_invocation = 0;
145 our $split_brain = 0;
149 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
152 our $remotename = 'dgit';
153 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
157 if (!defined $absurdity) {
159 $absurdity =~ s{/[^/]+$}{/absurd} or die;
163 my ($v,$distro) = @_;
164 return $tagformatfn->($v, $distro);
167 sub debiantag_maintview ($$) {
168 my ($v,$distro) = @_;
173 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
175 sub lbranch () { return "$branchprefix/$csuite"; }
176 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
177 sub lref () { return "refs/heads/".lbranch(); }
178 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
179 sub rrref () { return server_ref($csuite); }
181 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
182 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
184 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
185 # locally fetched refs because they have unhelpful names and clutter
186 # up gitk etc. So we track whether we have "used up" head ref (ie,
187 # whether we have made another local ref which refers to this object).
189 # (If we deleted them unconditionally, then we might end up
190 # re-fetching the same git objects each time dgit fetch was run.)
192 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
193 # in git_fetch_us to fetch the refs in question, and possibly a call
194 # to lrfetchref_used.
196 our (%lrfetchrefs_f, %lrfetchrefs_d);
197 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
199 sub lrfetchref_used ($) {
200 my ($fullrefname) = @_;
201 my $objid = $lrfetchrefs_f{$fullrefname};
202 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
213 return "${package}_".(stripepoch $vsn).$sfx
218 return srcfn($vsn,".dsc");
221 sub changespat ($;$) {
222 my ($vsn, $arch) = @_;
223 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
226 sub upstreamversion ($) {
238 foreach my $f (@end) {
240 print STDERR "$us: cleanup: $@" if length $@;
244 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
246 sub forceable_fail ($$) {
247 my ($forceoptsl, $msg) = @_;
248 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
249 print STDERR "warning: overriding problem due to --force:\n". $msg;
253 my ($forceoptsl) = @_;
254 my @got = grep { $forceopts{$_} } @$forceoptsl;
255 return 0 unless @got;
257 "warning: skipping checks or functionality due to --force-$got[0]\n";
260 sub no_such_package () {
261 print STDERR "$us: package $package does not exist in suite $isuite\n";
267 printdebug "CD $newdir\n";
268 chdir $newdir or confess "chdir: $newdir: $!";
271 sub deliberately ($) {
273 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
276 sub deliberately_not_fast_forward () {
277 foreach (qw(not-fast-forward fresh-repo)) {
278 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
282 sub quiltmode_splitbrain () {
283 $quilt_mode =~ m/gbp|dpm|unapplied/;
286 sub opts_opt_multi_cmd {
288 push @cmd, split /\s+/, shift @_;
294 return opts_opt_multi_cmd @gbp_pq;
297 #---------- remote protocol support, common ----------
299 # remote push initiator/responder protocol:
300 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
301 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
302 # < dgit-remote-push-ready <actual-proto-vsn>
309 # > supplementary-message NBYTES # $protovsn >= 3
314 # > file parsed-changelog
315 # [indicates that output of dpkg-parsechangelog follows]
316 # > data-block NBYTES
317 # > [NBYTES bytes of data (no newline)]
318 # [maybe some more blocks]
327 # > param head DGIT-VIEW-HEAD
328 # > param csuite SUITE
329 # > param tagformat old|new
330 # > param maint-view MAINT-VIEW-HEAD
332 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
333 # # goes into tag, for replay prevention
336 # [indicates that signed tag is wanted]
337 # < data-block NBYTES
338 # < [NBYTES bytes of data (no newline)]
339 # [maybe some more blocks]
343 # > want signed-dsc-changes
344 # < data-block NBYTES [transfer of signed dsc]
346 # < data-block NBYTES [transfer of signed changes]
354 sub i_child_report () {
355 # Sees if our child has died, and reap it if so. Returns a string
356 # describing how it died if it failed, or undef otherwise.
357 return undef unless $i_child_pid;
358 my $got = waitpid $i_child_pid, WNOHANG;
359 return undef if $got <= 0;
360 die unless $got == $i_child_pid;
361 $i_child_pid = undef;
362 return undef unless $?;
363 return "build host child ".waitstatusmsg();
368 fail "connection lost: $!" if $fh->error;
369 fail "protocol violation; $m not expected";
372 sub badproto_badread ($$) {
374 fail "connection lost: $!" if $!;
375 my $report = i_child_report();
376 fail $report if defined $report;
377 badproto $fh, "eof (reading $wh)";
380 sub protocol_expect (&$) {
381 my ($match, $fh) = @_;
384 defined && chomp or badproto_badread $fh, "protocol message";
392 badproto $fh, "\`$_'";
395 sub protocol_send_file ($$) {
396 my ($fh, $ourfn) = @_;
397 open PF, "<", $ourfn or die "$ourfn: $!";
400 my $got = read PF, $d, 65536;
401 die "$ourfn: $!" unless defined $got;
403 print $fh "data-block ".length($d)."\n" or die $!;
404 print $fh $d or die $!;
406 PF->error and die "$ourfn $!";
407 print $fh "data-end\n" or die $!;
411 sub protocol_read_bytes ($$) {
412 my ($fh, $nbytes) = @_;
413 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
415 my $got = read $fh, $d, $nbytes;
416 $got==$nbytes or badproto_badread $fh, "data block";
420 sub protocol_receive_file ($$) {
421 my ($fh, $ourfn) = @_;
422 printdebug "() $ourfn\n";
423 open PF, ">", $ourfn or die "$ourfn: $!";
425 my ($y,$l) = protocol_expect {
426 m/^data-block (.*)$/ ? (1,$1) :
427 m/^data-end$/ ? (0,) :
431 my $d = protocol_read_bytes $fh, $l;
432 print PF $d or die $!;
437 #---------- remote protocol support, responder ----------
439 sub responder_send_command ($) {
441 return unless $we_are_responder;
442 # called even without $we_are_responder
443 printdebug ">> $command\n";
444 print PO $command, "\n" or die $!;
447 sub responder_send_file ($$) {
448 my ($keyword, $ourfn) = @_;
449 return unless $we_are_responder;
450 printdebug "]] $keyword $ourfn\n";
451 responder_send_command "file $keyword";
452 protocol_send_file \*PO, $ourfn;
455 sub responder_receive_files ($@) {
456 my ($keyword, @ourfns) = @_;
457 die unless $we_are_responder;
458 printdebug "[[ $keyword @ourfns\n";
459 responder_send_command "want $keyword";
460 foreach my $fn (@ourfns) {
461 protocol_receive_file \*PI, $fn;
464 protocol_expect { m/^files-end$/ } \*PI;
467 #---------- remote protocol support, initiator ----------
469 sub initiator_expect (&) {
471 protocol_expect { &$match } \*RO;
474 #---------- end remote code ----------
477 if ($we_are_responder) {
479 responder_send_command "progress ".length($m) or die $!;
480 print PO $m or die $!;
490 $ua = LWP::UserAgent->new();
494 progress "downloading $what...";
495 my $r = $ua->get(@_) or die $!;
496 return undef if $r->code == 404;
497 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
498 return $r->decoded_content(charset => 'none');
501 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
506 failedcmd @_ if system @_;
509 sub act_local () { return $dryrun_level <= 1; }
510 sub act_scary () { return !$dryrun_level; }
513 if (!$dryrun_level) {
514 progress "dgit ok: @_";
516 progress "would be ok: @_ (but dry run only)";
521 printcmd(\*STDERR,$debugprefix."#",@_);
524 sub runcmd_ordryrun {
532 sub runcmd_ordryrun_local {
541 my ($first_shell, @cmd) = @_;
542 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
545 our $helpmsg = <<END;
547 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
548 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
549 dgit [dgit-opts] build [dpkg-buildpackage-opts]
550 dgit [dgit-opts] sbuild [sbuild-opts]
551 dgit [dgit-opts] push [dgit-opts] [suite]
552 dgit [dgit-opts] rpush build-host:build-dir ...
553 important dgit options:
554 -k<keyid> sign tag and package with <keyid> instead of default
555 --dry-run -n do not change anything, but go through the motions
556 --damp-run -L like --dry-run but make local changes, without signing
557 --new -N allow introducing a new package
558 --debug -D increase debug level
559 -c<name>=<value> set git config option (used directly by dgit too)
562 our $later_warning_msg = <<END;
563 Perhaps the upload is stuck in incoming. Using the version from git.
567 print STDERR "$us: @_\n", $helpmsg or die $!;
572 @ARGV or badusage "too few arguments";
573 return scalar shift @ARGV;
577 print $helpmsg or die $!;
581 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
583 our %defcfg = ('dgit.default.distro' => 'debian',
584 'dgit.default.username' => '',
585 'dgit.default.archive-query-default-component' => 'main',
586 'dgit.default.ssh' => 'ssh',
587 'dgit.default.archive-query' => 'madison:',
588 'dgit.default.sshpsql-dbname' => 'service=projectb',
589 'dgit.default.dgit-tag-format' => 'new,old,maint',
590 # old means "repo server accepts pushes with old dgit tags"
591 # new means "repo server accepts pushes with new dgit tags"
592 # maint means "repo server accepts split brain pushes"
593 # hist means "repo server may have old pushes without new tag"
594 # ("hist" is implied by "old")
595 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
596 'dgit-distro.debian.git-check' => 'url',
597 'dgit-distro.debian.git-check-suffix' => '/info/refs',
598 'dgit-distro.debian.new-private-pushers' => 't',
599 'dgit-distro.debian/push.git-url' => '',
600 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
601 'dgit-distro.debian/push.git-user-force' => 'dgit',
602 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
603 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
604 'dgit-distro.debian/push.git-create' => 'true',
605 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
606 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
607 # 'dgit-distro.debian.archive-query-tls-key',
608 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
609 # ^ this does not work because curl is broken nowadays
610 # Fixing #790093 properly will involve providing providing the key
611 # in some pacagke and maybe updating these paths.
613 # 'dgit-distro.debian.archive-query-tls-curl-args',
614 # '--ca-path=/etc/ssl/ca-debian',
615 # ^ this is a workaround but works (only) on DSA-administered machines
616 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
617 'dgit-distro.debian.git-url-suffix' => '',
618 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
619 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
620 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
621 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
622 'dgit-distro.ubuntu.git-check' => 'false',
623 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
624 'dgit-distro.test-dummy.ssh' => "$td/ssh",
625 'dgit-distro.test-dummy.username' => "alice",
626 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
628 'dgit-distro.test-dummy.git-url' => "$td/git",
629 'dgit-distro.test-dummy.git-host' => "git",
630 'dgit-distro.test-dummy.git-path' => "$td/git",
631 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
632 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
633 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
634 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
638 our @gitcfgsources = qw(cmdline local global system);
640 sub git_slurp_config () {
641 local ($debuglevel) = $debuglevel-2;
644 # This algoritm is a bit subtle, but this is needed so that for
645 # options which we want to be single-valued, we allow the
646 # different config sources to override properly. See #835858.
647 foreach my $src (@gitcfgsources) {
648 next if $src eq 'cmdline';
649 # we do this ourselves since git doesn't handle it
651 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
654 open GITS, "-|", @cmd or die $!;
657 printdebug "=> ", (messagequote $_), "\n";
659 push @{ $gitcfgs{$src}{$`} }, $'; #';
663 or ($!==0 && $?==256)
668 sub git_get_config ($) {
670 foreach my $src (@gitcfgsources) {
671 my $l = $gitcfgs{$src}{$c};
672 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
675 @$l==1 or badcfg "multiple values for $c".
676 " (in $src git config)" if @$l > 1;
684 return undef if $c =~ /RETURN-UNDEF/;
685 my $v = git_get_config($c);
686 return $v if defined $v;
687 my $dv = $defcfg{$c};
688 return $dv if defined $dv;
690 badcfg "need value for one of: @_\n".
691 "$us: distro or suite appears not to be (properly) supported";
694 sub access_basedistro () {
695 if (defined $idistro) {
698 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
699 return $def if defined $def;
700 foreach my $src (@gitcfgsources, 'internal') {
701 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
703 foreach my $k (keys %$kl) {
704 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
706 next unless match_glob $dpat, $isuite;
710 return cfg("dgit.default.distro");
714 sub access_nomdistro () {
715 my $base = access_basedistro();
716 return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
719 sub access_quirk () {
720 # returns (quirk name, distro to use instead or undef, quirk-specific info)
721 my $basedistro = access_basedistro();
722 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
724 if (defined $backports_quirk) {
725 my $re = $backports_quirk;
726 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
728 $re =~ s/\%/([-0-9a-z_]+)/
729 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
730 if ($isuite =~ m/^$re$/) {
731 return ('backports',"$basedistro-backports",$1);
734 return ('none',undef);
739 sub parse_cfg_bool ($$$) {
740 my ($what,$def,$v) = @_;
743 $v =~ m/^[ty1]/ ? 1 :
744 $v =~ m/^[fn0]/ ? 0 :
745 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
748 sub access_forpush_config () {
749 my $d = access_basedistro();
753 parse_cfg_bool('new-private-pushers', 0,
754 cfg("dgit-distro.$d.new-private-pushers",
757 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
760 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
761 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
762 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
763 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
766 sub access_forpush () {
767 $access_forpush //= access_forpush_config();
768 return $access_forpush;
772 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
773 badcfg "pushing but distro is configured readonly"
774 if access_forpush_config() eq '0';
776 $supplementary_message = <<'END' unless $we_are_responder;
777 Push failed, before we got started.
778 You can retry the push, after fixing the problem, if you like.
780 finalise_opts_opts();
784 finalise_opts_opts();
787 sub supplementary_message ($) {
789 if (!$we_are_responder) {
790 $supplementary_message = $msg;
792 } elsif ($protovsn >= 3) {
793 responder_send_command "supplementary-message ".length($msg)
795 print PO $msg or die $!;
799 sub access_distros () {
800 # Returns list of distros to try, in order
803 # 0. `instead of' distro name(s) we have been pointed to
804 # 1. the access_quirk distro, if any
805 # 2a. the user's specified distro, or failing that } basedistro
806 # 2b. the distro calculated from the suite }
807 my @l = access_basedistro();
809 my (undef,$quirkdistro) = access_quirk();
810 unshift @l, $quirkdistro;
811 unshift @l, $instead_distro;
812 @l = grep { defined } @l;
814 push @l, access_nomdistro();
816 if (access_forpush()) {
817 @l = map { ("$_/push", $_) } @l;
822 sub access_cfg_cfgs (@) {
825 # The nesting of these loops determines the search order. We put
826 # the key loop on the outside so that we search all the distros
827 # for each key, before going on to the next key. That means that
828 # if access_cfg is called with a more specific, and then a less
829 # specific, key, an earlier distro can override the less specific
830 # without necessarily overriding any more specific keys. (If the
831 # distro wants to override the more specific keys it can simply do
832 # so; whereas if we did the loop the other way around, it would be
833 # impossible to for an earlier distro to override a less specific
834 # key but not the more specific ones without restating the unknown
835 # values of the more specific keys.
838 # We have to deal with RETURN-UNDEF specially, so that we don't
839 # terminate the search prematurely.
841 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
844 foreach my $d (access_distros()) {
845 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
847 push @cfgs, map { "dgit.default.$_" } @realkeys;
854 my (@cfgs) = access_cfg_cfgs(@keys);
855 my $value = cfg(@cfgs);
859 sub access_cfg_bool ($$) {
860 my ($def, @keys) = @_;
861 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
864 sub string_to_ssh ($) {
866 if ($spec =~ m/\s/) {
867 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
873 sub access_cfg_ssh () {
874 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
875 if (!defined $gitssh) {
878 return string_to_ssh $gitssh;
882 sub access_runeinfo ($) {
884 return ": dgit ".access_basedistro()." $info ;";
887 sub access_someuserhost ($) {
889 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
890 defined($user) && length($user) or
891 $user = access_cfg("$some-user",'username');
892 my $host = access_cfg("$some-host");
893 return length($user) ? "$user\@$host" : $host;
896 sub access_gituserhost () {
897 return access_someuserhost('git');
900 sub access_giturl (;$) {
902 my $url = access_cfg('git-url','RETURN-UNDEF');
905 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
906 return undef unless defined $proto;
909 access_gituserhost().
910 access_cfg('git-path');
912 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
915 return "$url/$package$suffix";
918 sub parsecontrolfh ($$;$) {
919 my ($fh, $desc, $allowsigned) = @_;
920 our $dpkgcontrolhash_noissigned;
923 my %opts = ('name' => $desc);
924 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
925 $c = Dpkg::Control::Hash->new(%opts);
926 $c->parse($fh,$desc) or die "parsing of $desc failed";
927 last if $allowsigned;
928 last if $dpkgcontrolhash_noissigned;
929 my $issigned= $c->get_option('is_pgp_signed');
930 if (!defined $issigned) {
931 $dpkgcontrolhash_noissigned= 1;
932 seek $fh, 0,0 or die "seek $desc: $!";
933 } elsif ($issigned) {
934 fail "control file $desc is (already) PGP-signed. ".
935 " Note that dgit push needs to modify the .dsc and then".
936 " do the signature itself";
945 my ($file, $desc, $allowsigned) = @_;
946 my $fh = new IO::Handle;
947 open $fh, '<', $file or die "$file: $!";
948 my $c = parsecontrolfh($fh,$desc,$allowsigned);
949 $fh->error and die $!;
955 my ($dctrl,$field) = @_;
956 my $v = $dctrl->{$field};
957 return $v if defined $v;
958 fail "missing field $field in ".$dctrl->get_option('name');
962 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
963 my $p = new IO::Handle;
964 my @cmd = (qw(dpkg-parsechangelog), @_);
965 open $p, '-|', @cmd or die $!;
967 $?=0; $!=0; close $p or failedcmd @cmd;
971 sub commit_getclogp ($) {
972 # Returns the parsed changelog hashref for a particular commit
974 our %commit_getclogp_memo;
975 my $memo = $commit_getclogp_memo{$objid};
976 return $memo if $memo;
978 my $mclog = ".git/dgit/clog-$objid";
979 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
980 "$objid:debian/changelog";
981 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
986 defined $d or fail "getcwd failed: $!";
990 sub parse_dscdata () {
991 my $dscfh = new IO::File \$dscdata, '<' or die $!;
992 printdebug Dumper($dscdata) if $debuglevel>1;
993 $dsc = parsecontrolfh($dscfh,$dscurl,1);
994 printdebug Dumper($dsc) if $debuglevel>1;
999 sub archive_query ($;@) {
1000 my ($method) = shift @_;
1001 my $query = access_cfg('archive-query','RETURN-UNDEF');
1002 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1005 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1008 sub archive_query_prepend_mirror {
1009 my $m = access_cfg('mirror');
1010 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1013 sub pool_dsc_subpath ($$) {
1014 my ($vsn,$component) = @_; # $package is implict arg
1015 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1016 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1019 #---------- `ftpmasterapi' archive query method (nascent) ----------
1021 sub archive_api_query_cmd ($) {
1023 my @cmd = (@curl, qw(-sS));
1024 my $url = access_cfg('archive-query-url');
1025 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1027 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1028 foreach my $key (split /\:/, $keys) {
1029 $key =~ s/\%HOST\%/$host/g;
1031 fail "for $url: stat $key: $!" unless $!==ENOENT;
1034 fail "config requested specific TLS key but do not know".
1035 " how to get curl to use exactly that EE key ($key)";
1036 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1037 # # Sadly the above line does not work because of changes
1038 # # to gnutls. The real fix for #790093 may involve
1039 # # new curl options.
1042 # Fixing #790093 properly will involve providing a value
1043 # for this on clients.
1044 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1045 push @cmd, split / /, $kargs if defined $kargs;
1047 push @cmd, $url.$subpath;
1051 sub api_query ($$;$) {
1053 my ($data, $subpath, $ok404) = @_;
1054 badcfg "ftpmasterapi archive query method takes no data part"
1056 my @cmd = archive_api_query_cmd($subpath);
1057 my $url = $cmd[$#cmd];
1058 push @cmd, qw(-w %{http_code});
1059 my $json = cmdoutput @cmd;
1060 unless ($json =~ s/\d+\d+\d$//) {
1061 failedcmd_report_cmd undef, @cmd;
1062 fail "curl failed to print 3-digit HTTP code";
1065 return undef if $code eq '404' && $ok404;
1066 fail "fetch of $url gave HTTP code $code"
1067 unless $url =~ m#^file://# or $code =~ m/^2/;
1068 return decode_json($json);
1071 sub canonicalise_suite_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $suites = api_query($data, 'suites');
1075 foreach my $entry (@$suites) {
1077 my $v = $entry->{$_};
1078 defined $v && $v eq $isuite;
1079 } qw(codename name);
1080 push @matched, $entry;
1082 fail "unknown suite $isuite" unless @matched;
1085 @matched==1 or die "multiple matches for suite $isuite\n";
1086 $cn = "$matched[0]{codename}";
1087 defined $cn or die "suite $isuite info has no codename\n";
1088 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1090 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1095 sub archive_query_ftpmasterapi {
1096 my ($proto,$data) = @_;
1097 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1099 my $digester = Digest::SHA->new(256);
1100 foreach my $entry (@$info) {
1102 my $vsn = "$entry->{version}";
1103 my ($ok,$msg) = version_check $vsn;
1104 die "bad version: $msg\n" unless $ok;
1105 my $component = "$entry->{component}";
1106 $component =~ m/^$component_re$/ or die "bad component";
1107 my $filename = "$entry->{filename}";
1108 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1109 or die "bad filename";
1110 my $sha256sum = "$entry->{sha256sum}";
1111 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1112 push @rows, [ $vsn, "/pool/$component/$filename",
1113 $digester, $sha256sum ];
1115 die "bad ftpmaster api response: $@\n".Dumper($entry)
1118 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1119 return archive_query_prepend_mirror @rows;
1122 sub file_in_archive_ftpmasterapi {
1123 my ($proto,$data,$filename) = @_;
1124 my $pat = $filename;
1127 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1128 my $info = api_query($data, "file_in_archive/$pat", 1);
1131 #---------- `dummyapicat' archive query method ----------
1133 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1134 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1136 sub file_in_archive_dummycatapi ($$$) {
1137 my ($proto,$data,$filename) = @_;
1138 my $mirror = access_cfg('mirror');
1139 $mirror =~ s#^file://#/# or die "$mirror ?";
1141 my @cmd = (qw(sh -ec), '
1143 find -name "$2" -print0 |
1145 ', qw(x), $mirror, $filename);
1146 debugcmd "-|", @cmd;
1147 open FIA, "-|", @cmd or die $!;
1150 printdebug "| $_\n";
1151 m/^(\w+) (\S+)$/ or die "$_ ?";
1152 push @out, { sha256sum => $1, filename => $2 };
1154 close FIA or die failedcmd @cmd;
1158 #---------- `madison' archive query method ----------
1160 sub archive_query_madison {
1161 return archive_query_prepend_mirror
1162 map { [ @$_[0..1] ] } madison_get_parse(@_);
1165 sub madison_get_parse {
1166 my ($proto,$data) = @_;
1167 die unless $proto eq 'madison';
1168 if (!length $data) {
1169 $data= access_cfg('madison-distro','RETURN-UNDEF');
1170 $data //= access_basedistro();
1172 $rmad{$proto,$data,$package} ||= cmdoutput
1173 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1174 my $rmad = $rmad{$proto,$data,$package};
1177 foreach my $l (split /\n/, $rmad) {
1178 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1179 \s*( [^ \t|]+ )\s* \|
1180 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1181 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1182 $1 eq $package or die "$rmad $package ?";
1189 $component = access_cfg('archive-query-default-component');
1191 $5 eq 'source' or die "$rmad ?";
1192 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1194 return sort { -version_compare($a->[0],$b->[0]); } @out;
1197 sub canonicalise_suite_madison {
1198 # madison canonicalises for us
1199 my @r = madison_get_parse(@_);
1201 "unable to canonicalise suite using package $package".
1202 " which does not appear to exist in suite $isuite;".
1203 " --existing-package may help";
1207 sub file_in_archive_madison { return undef; }
1209 #---------- `sshpsql' archive query method ----------
1212 my ($data,$runeinfo,$sql) = @_;
1213 if (!length $data) {
1214 $data= access_someuserhost('sshpsql').':'.
1215 access_cfg('sshpsql-dbname');
1217 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1218 my ($userhost,$dbname) = ($`,$'); #';
1220 my @cmd = (access_cfg_ssh, $userhost,
1221 access_runeinfo("ssh-psql $runeinfo").
1222 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1223 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1225 open P, "-|", @cmd or die $!;
1228 printdebug(">|$_|\n");
1231 $!=0; $?=0; close P or failedcmd @cmd;
1233 my $nrows = pop @rows;
1234 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1235 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1236 @rows = map { [ split /\|/, $_ ] } @rows;
1237 my $ncols = scalar @{ shift @rows };
1238 die if grep { scalar @$_ != $ncols } @rows;
1242 sub sql_injection_check {
1243 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1246 sub archive_query_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite, $package;
1249 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1250 SELECT source.version, component.name, files.filename, files.sha256sum
1252 JOIN src_associations ON source.id = src_associations.source
1253 JOIN suite ON suite.id = src_associations.suite
1254 JOIN dsc_files ON dsc_files.source = source.id
1255 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1256 JOIN component ON component.id = files_archive_map.component_id
1257 JOIN files ON files.id = dsc_files.file
1258 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1259 AND source.source='$package'
1260 AND files.filename LIKE '%.dsc';
1262 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1263 my $digester = Digest::SHA->new(256);
1265 my ($vsn,$component,$filename,$sha256sum) = @$_;
1266 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1268 return archive_query_prepend_mirror @rows;
1271 sub canonicalise_suite_sshpsql ($$) {
1272 my ($proto,$data) = @_;
1273 sql_injection_check $isuite;
1274 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1275 SELECT suite.codename
1276 FROM suite where suite_name='$isuite' or codename='$isuite';
1278 @rows = map { $_->[0] } @rows;
1279 fail "unknown suite $isuite" unless @rows;
1280 die "ambiguous $isuite: @rows ?" if @rows>1;
1284 sub file_in_archive_sshpsql ($$$) { return undef; }
1286 #---------- `dummycat' archive query method ----------
1288 sub canonicalise_suite_dummycat ($$) {
1289 my ($proto,$data) = @_;
1290 my $dpath = "$data/suite.$isuite";
1291 if (!open C, "<", $dpath) {
1292 $!==ENOENT or die "$dpath: $!";
1293 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1297 chomp or die "$dpath: $!";
1299 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1303 sub archive_query_dummycat ($$) {
1304 my ($proto,$data) = @_;
1305 canonicalise_suite();
1306 my $dpath = "$data/package.$csuite.$package";
1307 if (!open C, "<", $dpath) {
1308 $!==ENOENT or die "$dpath: $!";
1309 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1317 printdebug "dummycat query $csuite $package $dpath | $_\n";
1318 my @row = split /\s+/, $_;
1319 @row==2 or die "$dpath: $_ ?";
1322 C->error and die "$dpath: $!";
1324 return archive_query_prepend_mirror
1325 sort { -version_compare($a->[0],$b->[0]); } @rows;
1328 sub file_in_archive_dummycat () { return undef; }
1330 #---------- tag format handling ----------
1332 sub access_cfg_tagformats () {
1333 split /\,/, access_cfg('dgit-tag-format');
1336 sub need_tagformat ($$) {
1337 my ($fmt, $why) = @_;
1338 fail "need to use tag format $fmt ($why) but also need".
1339 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1340 " - no way to proceed"
1341 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1342 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1345 sub select_tagformat () {
1347 return if $tagformatfn && !$tagformat_want;
1348 die 'bug' if $tagformatfn && $tagformat_want;
1349 # ... $tagformat_want assigned after previous select_tagformat
1351 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1352 printdebug "select_tagformat supported @supported\n";
1354 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1355 printdebug "select_tagformat specified @$tagformat_want\n";
1357 my ($fmt,$why,$override) = @$tagformat_want;
1359 fail "target distro supports tag formats @supported".
1360 " but have to use $fmt ($why)"
1362 or grep { $_ eq $fmt } @supported;
1364 $tagformat_want = undef;
1366 $tagformatfn = ${*::}{"debiantag_$fmt"};
1368 fail "trying to use unknown tag format \`$fmt' ($why) !"
1369 unless $tagformatfn;
1372 #---------- archive query entrypoints and rest of program ----------
1374 sub canonicalise_suite () {
1375 return if defined $csuite;
1376 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1377 $csuite = archive_query('canonicalise_suite');
1378 if ($isuite ne $csuite) {
1379 progress "canonical suite name for $isuite is $csuite";
1383 sub get_archive_dsc () {
1384 canonicalise_suite();
1385 my @vsns = archive_query('archive_query');
1386 foreach my $vinfo (@vsns) {
1387 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1388 $dscurl = $vsn_dscurl;
1389 $dscdata = url_get($dscurl);
1391 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1396 $digester->add($dscdata);
1397 my $got = $digester->hexdigest();
1399 fail "$dscurl has hash $got but".
1400 " archive told us to expect $digest";
1403 my $fmt = getfield $dsc, 'Format';
1404 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1405 "unsupported source format $fmt, sorry";
1407 $dsc_checked = !!$digester;
1408 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1412 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1415 sub check_for_git ();
1416 sub check_for_git () {
1418 my $how = access_cfg('git-check');
1419 if ($how eq 'ssh-cmd') {
1421 (access_cfg_ssh, access_gituserhost(),
1422 access_runeinfo("git-check $package").
1423 " set -e; cd ".access_cfg('git-path').";".
1424 " if test -d $package.git; then echo 1; else echo 0; fi");
1425 my $r= cmdoutput @cmd;
1426 if (defined $r and $r =~ m/^divert (\w+)$/) {
1428 my ($usedistro,) = access_distros();
1429 # NB that if we are pushing, $usedistro will be $distro/push
1430 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1431 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1432 progress "diverting to $divert (using config for $instead_distro)";
1433 return check_for_git();
1435 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1437 } elsif ($how eq 'url') {
1438 my $prefix = access_cfg('git-check-url','git-url');
1439 my $suffix = access_cfg('git-check-suffix','git-suffix',
1440 'RETURN-UNDEF') // '.git';
1441 my $url = "$prefix/$package$suffix";
1442 my @cmd = (@curl, qw(-sS -I), $url);
1443 my $result = cmdoutput @cmd;
1444 $result =~ s/^\S+ 200 .*\n\r?\n//;
1445 # curl -sS -I with https_proxy prints
1446 # HTTP/1.0 200 Connection established
1447 $result =~ m/^\S+ (404|200) /s or
1448 fail "unexpected results from git check query - ".
1449 Dumper($prefix, $result);
1451 if ($code eq '404') {
1453 } elsif ($code eq '200') {
1458 } elsif ($how eq 'true') {
1460 } elsif ($how eq 'false') {
1463 badcfg "unknown git-check \`$how'";
1467 sub create_remote_git_repo () {
1468 my $how = access_cfg('git-create');
1469 if ($how eq 'ssh-cmd') {
1471 (access_cfg_ssh, access_gituserhost(),
1472 access_runeinfo("git-create $package").
1473 "set -e; cd ".access_cfg('git-path').";".
1474 " cp -a _template $package.git");
1475 } elsif ($how eq 'true') {
1478 badcfg "unknown git-create \`$how'";
1482 our ($dsc_hash,$lastpush_mergeinput);
1484 our $ud = '.git/dgit/unpack';
1494 sub mktree_in_ud_here () {
1495 runcmd qw(git init -q);
1496 runcmd qw(git config gc.auto 0);
1497 rmtree('.git/objects');
1498 symlink '../../../../objects','.git/objects' or die $!;
1501 sub git_write_tree () {
1502 my $tree = cmdoutput @git, qw(write-tree);
1503 $tree =~ m/^\w+$/ or die "$tree ?";
1507 sub remove_stray_gits () {
1508 my @gitscmd = qw(find -name .git -prune -print0);
1509 debugcmd "|",@gitscmd;
1510 open GITS, "-|", @gitscmd or die $!;
1515 print STDERR "$us: warning: removing from source package: ",
1516 (messagequote $_), "\n";
1520 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1523 sub mktree_in_ud_from_only_subdir (;$) {
1526 # changes into the subdir
1528 die "expected one subdir but found @dirs ?" unless @dirs==1;
1529 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1533 remove_stray_gits();
1534 mktree_in_ud_here();
1536 my ($format, $fopts) = get_source_format();
1537 if (madformat($format)) {
1542 runcmd @git, qw(add -Af);
1543 my $tree=git_write_tree();
1544 return ($tree,$dir);
1547 our @files_csum_info_fields =
1548 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1549 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1550 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1552 sub dsc_files_info () {
1553 foreach my $csumi (@files_csum_info_fields) {
1554 my ($fname, $module, $method) = @$csumi;
1555 my $field = $dsc->{$fname};
1556 next unless defined $field;
1557 eval "use $module; 1;" or die $@;
1559 foreach (split /\n/, $field) {
1561 m/^(\w+) (\d+) (\S+)$/ or
1562 fail "could not parse .dsc $fname line \`$_'";
1563 my $digester = eval "$module"."->$method;" or die $@;
1568 Digester => $digester,
1573 fail "missing any supported Checksums-* or Files field in ".
1574 $dsc->get_option('name');
1578 map { $_->{Filename} } dsc_files_info();
1581 sub files_compare_inputs (@) {
1586 my $showinputs = sub {
1587 return join "; ", map { $_->get_option('name') } @$inputs;
1590 foreach my $in (@$inputs) {
1592 my $in_name = $in->get_option('name');
1594 printdebug "files_compare_inputs $in_name\n";
1596 foreach my $csumi (@files_csum_info_fields) {
1597 my ($fname) = @$csumi;
1598 printdebug "files_compare_inputs $in_name $fname\n";
1600 my $field = $in->{$fname};
1601 next unless defined $field;
1604 foreach (split /\n/, $field) {
1607 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1608 fail "could not parse $in_name $fname line \`$_'";
1610 printdebug "files_compare_inputs $in_name $fname $f\n";
1614 my $re = \ $record{$f}{$fname};
1616 $fchecked{$f}{$in_name} = 1;
1618 fail "hash or size of $f varies in $fname fields".
1619 " (between: ".$showinputs->().")";
1624 @files = sort @files;
1625 $expected_files //= \@files;
1626 "@$expected_files" eq "@files" or
1627 fail "file list in $in_name varies between hash fields!";
1630 fail "$in_name has no files list field(s)";
1632 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1635 grep { keys %$_ == @$inputs-1 } values %fchecked
1636 or fail "no file appears in all file lists".
1637 " (looked in: ".$showinputs->().")";
1640 sub is_orig_file_in_dsc ($$) {
1641 my ($f, $dsc_files_info) = @_;
1642 return 0 if @$dsc_files_info <= 1;
1643 # One file means no origs, and the filename doesn't have a "what
1644 # part of dsc" component. (Consider versions ending `.orig'.)
1645 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1649 sub is_orig_file_of_vsn ($$) {
1650 my ($f, $upstreamvsn) = @_;
1651 my $base = srcfn $upstreamvsn, '';
1652 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1656 sub changes_update_origs_from_dsc ($$$$) {
1657 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1659 printdebug "checking origs needed ($upstreamvsn)...\n";
1660 $_ = getfield $changes, 'Files';
1661 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1662 fail "cannot find section/priority from .changes Files field";
1663 my $placementinfo = $1;
1665 printdebug "checking origs needed placement '$placementinfo'...\n";
1666 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1667 $l =~ m/\S+$/ or next;
1669 printdebug "origs $file | $l\n";
1670 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1671 printdebug "origs $file is_orig\n";
1672 my $have = archive_query('file_in_archive', $file);
1673 if (!defined $have) {
1675 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1681 printdebug "origs $file \$#\$have=$#$have\n";
1682 foreach my $h (@$have) {
1685 foreach my $csumi (@files_csum_info_fields) {
1686 my ($fname, $module, $method, $archivefield) = @$csumi;
1687 next unless defined $h->{$archivefield};
1688 $_ = $dsc->{$fname};
1689 next unless defined;
1690 m/^(\w+) .* \Q$file\E$/m or
1691 fail ".dsc $fname missing entry for $file";
1692 if ($h->{$archivefield} eq $1) {
1696 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1699 die "$file ".Dumper($h)." ?!" if $same && @differ;
1702 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1705 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1706 if (@found_differ && !$found_same) {
1708 "archive contains $file with different checksum",
1711 # Now we edit the changes file to add or remove it
1712 foreach my $csumi (@files_csum_info_fields) {
1713 my ($fname, $module, $method, $archivefield) = @$csumi;
1714 next unless defined $changes->{$fname};
1716 # in archive, delete from .changes if it's there
1717 $changed{$file} = "removed" if
1718 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1719 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1720 # not in archive, but it's here in the .changes
1722 my $dsc_data = getfield $dsc, $fname;
1723 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1725 $extra =~ s/ \d+ /$&$placementinfo /
1726 or die "$fname $extra >$dsc_data< ?"
1727 if $fname eq 'Files';
1728 $changes->{$fname} .= "\n". $extra;
1729 $changed{$file} = "added";
1734 foreach my $file (keys %changed) {
1736 "edited .changes for archive .orig contents: %s %s",
1737 $changed{$file}, $file;
1739 my $chtmp = "$changesfile.tmp";
1740 $changes->save($chtmp);
1742 rename $chtmp,$changesfile or die "$changesfile $!";
1744 progress "[new .changes left in $changesfile]";
1747 progress "$changesfile already has appropriate .orig(s) (if any)";
1751 sub make_commit ($) {
1753 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1756 sub make_commit_text ($) {
1759 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1761 print Dumper($text) if $debuglevel > 1;
1762 my $child = open2($out, $in, @cmd) or die $!;
1765 print $in $text or die $!;
1766 close $in or die $!;
1768 $h =~ m/^\w+$/ or die;
1770 printdebug "=> $h\n";
1773 waitpid $child, 0 == $child or die "$child $!";
1774 $? and failedcmd @cmd;
1778 sub clogp_authline ($) {
1780 my $author = getfield $clogp, 'Maintainer';
1781 $author =~ s#,.*##ms;
1782 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1783 my $authline = "$author $date";
1784 $authline =~ m/$git_authline_re/o or
1785 fail "unexpected commit author line format \`$authline'".
1786 " (was generated from changelog Maintainer field)";
1787 return ($1,$2,$3) if wantarray;
1791 sub vendor_patches_distro ($$) {
1792 my ($checkdistro, $what) = @_;
1793 return unless defined $checkdistro;
1795 my $series = "debian/patches/\L$checkdistro\E.series";
1796 printdebug "checking for vendor-specific $series ($what)\n";
1798 if (!open SERIES, "<", $series) {
1799 die "$series $!" unless $!==ENOENT;
1808 Unfortunately, this source package uses a feature of dpkg-source where
1809 the same source package unpacks to different source code on different
1810 distros. dgit cannot safely operate on such packages on affected
1811 distros, because the meaning of source packages is not stable.
1813 Please ask the distro/maintainer to remove the distro-specific series
1814 files and use a different technique (if necessary, uploading actually
1815 different packages, if different distros are supposed to have
1819 fail "Found active distro-specific series file for".
1820 " $checkdistro ($what): $series, cannot continue";
1822 die "$series $!" if SERIES->error;
1826 sub check_for_vendor_patches () {
1827 # This dpkg-source feature doesn't seem to be documented anywhere!
1828 # But it can be found in the changelog (reformatted):
1830 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1831 # Author: Raphael Hertzog <hertzog@debian.org>
1832 # Date: Sun Oct 3 09:36:48 2010 +0200
1834 # dpkg-source: correctly create .pc/.quilt_series with alternate
1837 # If you have debian/patches/ubuntu.series and you were
1838 # unpacking the source package on ubuntu, quilt was still
1839 # directed to debian/patches/series instead of
1840 # debian/patches/ubuntu.series.
1842 # debian/changelog | 3 +++
1843 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1844 # 2 files changed, 6 insertions(+), 1 deletion(-)
1847 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1848 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1849 "Dpkg::Vendor \`current vendor'");
1850 vendor_patches_distro(access_basedistro(),
1851 "(base) distro being accessed");
1852 vendor_patches_distro(access_nomdistro(),
1853 "(nominal) distro being accessed");
1856 sub generate_commits_from_dsc () {
1857 # See big comment in fetch_from_archive, below.
1858 # See also README.dsc-import.
1862 my @dfi = dsc_files_info();
1863 foreach my $fi (@dfi) {
1864 my $f = $fi->{Filename};
1865 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1867 printdebug "considering linking $f: ";
1869 link_ltarget "../../../../$f", $f
1870 or ((printdebug "($!) "), 0)
1874 printdebug "linked.\n";
1876 complete_file_from_dsc('.', $fi)
1879 if (is_orig_file_in_dsc($f, \@dfi)) {
1880 link $f, "../../../../$f"
1886 # We unpack and record the orig tarballs first, so that we only
1887 # need disk space for one private copy of the unpacked source.
1888 # But we can't make them into commits until we have the metadata
1889 # from the debian/changelog, so we record the tree objects now and
1890 # make them into commits later.
1892 my $upstreamv = upstreamversion $dsc->{version};
1893 my $orig_f_base = srcfn $upstreamv, '';
1895 foreach my $fi (@dfi) {
1896 # We actually import, and record as a commit, every tarball
1897 # (unless there is only one file, in which case there seems
1900 my $f = $fi->{Filename};
1901 printdebug "import considering $f ";
1902 (printdebug "only one dfi\n"), next if @dfi == 1;
1903 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1904 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1908 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1910 printdebug "Y ", (join ' ', map { $_//"(none)" }
1911 $compr_ext, $orig_f_part
1914 my $input = new IO::File $f, '<' or die "$f $!";
1918 if (defined $compr_ext) {
1920 Dpkg::Compression::compression_guess_from_filename $f;
1921 fail "Dpkg::Compression cannot handle file $f in source package"
1922 if defined $compr_ext && !defined $cname;
1924 new Dpkg::Compression::Process compression => $cname;
1925 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1926 my $compr_fh = new IO::Handle;
1927 my $compr_pid = open $compr_fh, "-|" // die $!;
1929 open STDIN, "<&", $input or die $!;
1931 die "dgit (child): exec $compr_cmd[0]: $!\n";
1936 rmtree "../unpack-tar";
1937 mkdir "../unpack-tar" or die $!;
1938 my @tarcmd = qw(tar -x -f -
1939 --no-same-owner --no-same-permissions
1940 --no-acls --no-xattrs --no-selinux);
1941 my $tar_pid = fork // die $!;
1943 chdir "../unpack-tar" or die $!;
1944 open STDIN, "<&", $input or die $!;
1946 die "dgit (child): exec $tarcmd[0]: $!";
1948 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1949 !$? or failedcmd @tarcmd;
1952 (@compr_cmd ? failedcmd @compr_cmd
1954 # finally, we have the results in "tarball", but maybe
1955 # with the wrong permissions
1957 runcmd qw(chmod -R +rwX ../unpack-tar);
1958 changedir "../unpack-tar";
1959 my ($tree) = mktree_in_ud_from_only_subdir(1);
1960 changedir "../../unpack";
1961 rmtree "../unpack-tar";
1963 my $ent = [ $f, $tree ];
1965 Orig => !!$orig_f_part,
1966 Sort => (!$orig_f_part ? 2 :
1967 $orig_f_part =~ m/-/g ? 1 :
1975 # put any without "_" first (spec is not clear whether files
1976 # are always in the usual order). Tarballs without "_" are
1977 # the main orig or the debian tarball.
1978 $a->{Sort} <=> $b->{Sort} or
1982 my $any_orig = grep { $_->{Orig} } @tartrees;
1984 my $dscfn = "$package.dsc";
1986 my $treeimporthow = 'package';
1988 open D, ">", $dscfn or die "$dscfn: $!";
1989 print D $dscdata or die "$dscfn: $!";
1990 close D or die "$dscfn: $!";
1991 my @cmd = qw(dpkg-source);
1992 push @cmd, '--no-check' if $dsc_checked;
1993 if (madformat $dsc->{format}) {
1994 push @cmd, '--skip-patches';
1995 $treeimporthow = 'unpatched';
1997 push @cmd, qw(-x --), $dscfn;
2000 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2001 if (madformat $dsc->{format}) {
2002 check_for_vendor_patches();
2006 if (madformat $dsc->{format}) {
2007 my @pcmd = qw(dpkg-source --before-build .);
2008 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2010 runcmd @git, qw(add -Af);
2011 $dappliedtree = git_write_tree();
2014 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2015 debugcmd "|",@clogcmd;
2016 open CLOGS, "-|", @clogcmd or die $!;
2021 printdebug "import clog search...\n";
2024 my $stanzatext = do { local $/=""; <CLOGS>; };
2025 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2026 last if !defined $stanzatext;
2028 my $desc = "package changelog, entry no.$.";
2029 open my $stanzafh, "<", \$stanzatext or die;
2030 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2031 $clogp //= $thisstanza;
2033 printdebug "import clog $thisstanza->{version} $desc...\n";
2035 last if !$any_orig; # we don't need $r1clogp
2037 # We look for the first (most recent) changelog entry whose
2038 # version number is lower than the upstream version of this
2039 # package. Then the last (least recent) previous changelog
2040 # entry is treated as the one which introduced this upstream
2041 # version and used for the synthetic commits for the upstream
2044 # One might think that a more sophisticated algorithm would be
2045 # necessary. But: we do not want to scan the whole changelog
2046 # file. Stopping when we see an earlier version, which
2047 # necessarily then is an earlier upstream version, is the only
2048 # realistic way to do that. Then, either the earliest
2049 # changelog entry we have seen so far is indeed the earliest
2050 # upload of this upstream version; or there are only changelog
2051 # entries relating to later upstream versions (which is not
2052 # possible unless the changelog and .dsc disagree about the
2053 # version). Then it remains to choose between the physically
2054 # last entry in the file, and the one with the lowest version
2055 # number. If these are not the same, we guess that the
2056 # versions were created in a non-monotic order rather than
2057 # that the changelog entries have been misordered.
2059 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2061 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2062 $r1clogp = $thisstanza;
2064 printdebug "import clog $r1clogp->{version} becomes r1\n";
2066 die $! if CLOGS->error;
2067 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2069 $clogp or fail "package changelog has no entries!";
2071 my $authline = clogp_authline $clogp;
2072 my $changes = getfield $clogp, 'Changes';
2073 my $cversion = getfield $clogp, 'Version';
2076 $r1clogp //= $clogp; # maybe there's only one entry;
2077 my $r1authline = clogp_authline $r1clogp;
2078 # Strictly, r1authline might now be wrong if it's going to be
2079 # unused because !$any_orig. Whatever.
2081 printdebug "import tartrees authline $authline\n";
2082 printdebug "import tartrees r1authline $r1authline\n";
2084 foreach my $tt (@tartrees) {
2085 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2087 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2090 committer $r1authline
2094 [dgit import orig $tt->{F}]
2102 [dgit import tarball $package $cversion $tt->{F}]
2107 printdebug "import main commit\n";
2109 open C, ">../commit.tmp" or die $!;
2110 print C <<END or die $!;
2113 print C <<END or die $! foreach @tartrees;
2116 print C <<END or die $!;
2122 [dgit import $treeimporthow $package $cversion]
2126 my $rawimport_hash = make_commit qw(../commit.tmp);
2128 if (madformat $dsc->{format}) {
2129 printdebug "import apply patches...\n";
2131 # regularise the state of the working tree so that
2132 # the checkout of $rawimport_hash works nicely.
2133 my $dappliedcommit = make_commit_text(<<END);
2140 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2142 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2144 # We need the answers to be reproducible
2145 my @authline = clogp_authline($clogp);
2146 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2147 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2148 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2149 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2150 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2151 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2153 my $path = $ENV{PATH} or die;
2155 foreach my $use_absurd (qw(0 1)) {
2156 local $ENV{PATH} = $path;
2159 progress "warning: $@";
2160 $path = "$absurdity:$path";
2161 progress "$us: trying slow absurd-git-apply...";
2162 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2167 die "forbid absurd git-apply\n" if $use_absurd
2168 && forceing [qw(import-gitapply-no-absurd)];
2169 die "only absurd git-apply!\n" if !$use_absurd
2170 && forceing [qw(import-gitapply-absurd)];
2172 local $ENV{PATH} = $path if $use_absurd;
2174 my @showcmd = (gbp_pq, qw(import));
2175 my @realcmd = shell_cmd
2176 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2177 debugcmd "+",@realcmd;
2178 if (system @realcmd) {
2179 die +(shellquote @showcmd).
2181 failedcmd_waitstatus()."\n";
2184 my $gapplied = git_rev_parse('HEAD');
2185 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2186 $gappliedtree eq $dappliedtree or
2188 gbp-pq import and dpkg-source disagree!
2189 gbp-pq import gave commit $gapplied
2190 gbp-pq import gave tree $gappliedtree
2191 dpkg-source --before-build gave tree $dappliedtree
2193 $rawimport_hash = $gapplied;
2198 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2203 progress "synthesised git commit from .dsc $cversion";
2205 my $rawimport_mergeinput = {
2206 Commit => $rawimport_hash,
2207 Info => "Import of source package",
2209 my @output = ($rawimport_mergeinput);
2211 if ($lastpush_mergeinput) {
2212 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2213 my $oversion = getfield $oldclogp, 'Version';
2215 version_compare($oversion, $cversion);
2217 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2218 { Message => <<END, ReverseParents => 1 });
2219 Record $package ($cversion) in archive suite $csuite
2221 } elsif ($vcmp > 0) {
2222 print STDERR <<END or die $!;
2224 Version actually in archive: $cversion (older)
2225 Last version pushed with dgit: $oversion (newer or same)
2228 @output = $lastpush_mergeinput;
2230 # Same version. Use what's in the server git branch,
2231 # discarding our own import. (This could happen if the
2232 # server automatically imports all packages into git.)
2233 @output = $lastpush_mergeinput;
2236 changedir '../../../..';
2241 sub complete_file_from_dsc ($$) {
2242 our ($dstdir, $fi) = @_;
2243 # Ensures that we have, in $dir, the file $fi, with the correct
2244 # contents. (Downloading it from alongside $dscurl if necessary.)
2246 my $f = $fi->{Filename};
2247 my $tf = "$dstdir/$f";
2250 if (stat_exists $tf) {
2251 progress "using existing $f";
2253 printdebug "$tf does not exist, need to fetch\n";
2255 $furl =~ s{/[^/]+$}{};
2257 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2258 die "$f ?" if $f =~ m#/#;
2259 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2260 return 0 if !act_local();
2264 open F, "<", "$tf" or die "$tf: $!";
2265 $fi->{Digester}->reset();
2266 $fi->{Digester}->addfile(*F);
2267 F->error and die $!;
2268 my $got = $fi->{Digester}->hexdigest();
2269 $got eq $fi->{Hash} or
2270 fail "file $f has hash $got but .dsc".
2271 " demands hash $fi->{Hash} ".
2272 ($downloaded ? "(got wrong file from archive!)"
2273 : "(perhaps you should delete this file?)");
2278 sub ensure_we_have_orig () {
2279 my @dfi = dsc_files_info();
2280 foreach my $fi (@dfi) {
2281 my $f = $fi->{Filename};
2282 next unless is_orig_file_in_dsc($f, \@dfi);
2283 complete_file_from_dsc('..', $fi)
2288 sub git_fetch_us () {
2289 # Want to fetch only what we are going to use, unless
2290 # deliberately-not-ff, in which case we must fetch everything.
2292 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2294 (quiltmode_splitbrain
2295 ? (map { $_->('*',access_nomdistro) }
2296 \&debiantag_new, \&debiantag_maintview)
2297 : debiantags('*',access_nomdistro));
2298 push @specs, server_branch($csuite);
2299 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2301 # This is rather miserable:
2302 # When git fetch --prune is passed a fetchspec ending with a *,
2303 # it does a plausible thing. If there is no * then:
2304 # - it matches subpaths too, even if the supplied refspec
2305 # starts refs, and behaves completely madly if the source
2306 # has refs/refs/something. (See, for example, Debian #NNNN.)
2307 # - if there is no matching remote ref, it bombs out the whole
2309 # We want to fetch a fixed ref, and we don't know in advance
2310 # if it exists, so this is not suitable.
2312 # Our workaround is to use git ls-remote. git ls-remote has its
2313 # own qairks. Notably, it has the absurd multi-tail-matching
2314 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2315 # refs/refs/foo etc.
2317 # Also, we want an idempotent snapshot, but we have to make two
2318 # calls to the remote: one to git ls-remote and to git fetch. The
2319 # solution is use git ls-remote to obtain a target state, and
2320 # git fetch to try to generate it. If we don't manage to generate
2321 # the target state, we try again.
2323 printdebug "git_fetch_us specs @specs\n";
2325 my $specre = join '|', map {
2331 printdebug "git_fetch_us specre=$specre\n";
2332 my $wanted_rref = sub {
2334 return m/^(?:$specre)$/o;
2337 my $fetch_iteration = 0;
2340 printdebug "git_fetch_us iteration $fetch_iteration\n";
2341 if (++$fetch_iteration > 10) {
2342 fail "too many iterations trying to get sane fetch!";
2345 my @look = map { "refs/$_" } @specs;
2346 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2350 open GITLS, "-|", @lcmd or die $!;
2352 printdebug "=> ", $_;
2353 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2354 my ($objid,$rrefname) = ($1,$2);
2355 if (!$wanted_rref->($rrefname)) {
2357 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2361 $wantr{$rrefname} = $objid;
2364 close GITLS or failedcmd @lcmd;
2366 # OK, now %want is exactly what we want for refs in @specs
2368 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2369 "+refs/$_:".lrfetchrefs."/$_";
2372 printdebug "git_fetch_us fspecs @fspecs\n";
2374 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2375 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2378 %lrfetchrefs_f = ();
2381 git_for_each_ref(lrfetchrefs, sub {
2382 my ($objid,$objtype,$lrefname,$reftail) = @_;
2383 $lrfetchrefs_f{$lrefname} = $objid;
2384 $objgot{$objid} = 1;
2387 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2388 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2389 if (!exists $wantr{$rrefname}) {
2390 if ($wanted_rref->($rrefname)) {
2392 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2396 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2399 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2400 delete $lrfetchrefs_f{$lrefname};
2404 foreach my $rrefname (sort keys %wantr) {
2405 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2406 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2407 my $want = $wantr{$rrefname};
2408 next if $got eq $want;
2409 if (!defined $objgot{$want}) {
2411 warning: git ls-remote suggests we want $lrefname
2412 warning: and it should refer to $want
2413 warning: but git fetch didn't fetch that object to any relevant ref.
2414 warning: This may be due to a race with someone updating the server.
2415 warning: Will try again...
2417 next FETCH_ITERATION;
2420 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2422 runcmd_ordryrun_local @git, qw(update-ref -m),
2423 "dgit fetch git fetch fixup", $lrefname, $want;
2424 $lrfetchrefs_f{$lrefname} = $want;
2428 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2429 Dumper(\%lrfetchrefs_f);
2432 my @tagpats = debiantags('*',access_nomdistro);
2434 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2435 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2436 printdebug "currently $fullrefname=$objid\n";
2437 $here{$fullrefname} = $objid;
2439 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2440 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2441 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2442 printdebug "offered $lref=$objid\n";
2443 if (!defined $here{$lref}) {
2444 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2445 runcmd_ordryrun_local @upd;
2446 lrfetchref_used $fullrefname;
2447 } elsif ($here{$lref} eq $objid) {
2448 lrfetchref_used $fullrefname;
2451 "Not updateting $lref from $here{$lref} to $objid.\n";
2456 sub mergeinfo_getclogp ($) {
2457 # Ensures thit $mi->{Clogp} exists and returns it
2459 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2462 sub mergeinfo_version ($) {
2463 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2466 sub fetch_from_archive () {
2467 ensure_setup_existing_tree();
2469 # Ensures that lrref() is what is actually in the archive, one way
2470 # or another, according to us - ie this client's
2471 # appropritaely-updated archive view. Also returns the commit id.
2472 # If there is nothing in the archive, leaves lrref alone and
2473 # returns undef. git_fetch_us must have already been called.
2477 foreach my $field (@ourdscfield) {
2478 $dsc_hash = $dsc->{$field};
2479 last if defined $dsc_hash;
2481 if (defined $dsc_hash) {
2482 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2484 progress "last upload to archive specified git hash";
2486 progress "last upload to archive has NO git hash";
2489 progress "no version available from the archive";
2492 # If the archive's .dsc has a Dgit field, there are three
2493 # relevant git commitids we need to choose between and/or merge
2495 # 1. $dsc_hash: the Dgit field from the archive
2496 # 2. $lastpush_hash: the suite branch on the dgit git server
2497 # 3. $lastfetch_hash: our local tracking brach for the suite
2499 # These may all be distinct and need not be in any fast forward
2502 # If the dsc was pushed to this suite, then the server suite
2503 # branch will have been updated; but it might have been pushed to
2504 # a different suite and copied by the archive. Conversely a more
2505 # recent version may have been pushed with dgit but not appeared
2506 # in the archive (yet).
2508 # $lastfetch_hash may be awkward because archive imports
2509 # (particularly, imports of Dgit-less .dscs) are performed only as
2510 # needed on individual clients, so different clients may perform a
2511 # different subset of them - and these imports are only made
2512 # public during push. So $lastfetch_hash may represent a set of
2513 # imports different to a subsequent upload by a different dgit
2516 # Our approach is as follows:
2518 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2519 # descendant of $dsc_hash, then it was pushed by a dgit user who
2520 # had based their work on $dsc_hash, so we should prefer it.
2521 # Otherwise, $dsc_hash was installed into this suite in the
2522 # archive other than by a dgit push, and (necessarily) after the
2523 # last dgit push into that suite (since a dgit push would have
2524 # been descended from the dgit server git branch); thus, in that
2525 # case, we prefer the archive's version (and produce a
2526 # pseudo-merge to overwrite the dgit server git branch).
2528 # (If there is no Dgit field in the archive's .dsc then
2529 # generate_commit_from_dsc uses the version numbers to decide
2530 # whether the suite branch or the archive is newer. If the suite
2531 # branch is newer it ignores the archive's .dsc; otherwise it
2532 # generates an import of the .dsc, and produces a pseudo-merge to
2533 # overwrite the suite branch with the archive contents.)
2535 # The outcome of that part of the algorithm is the `public view',
2536 # and is same for all dgit clients: it does not depend on any
2537 # unpublished history in the local tracking branch.
2539 # As between the public view and the local tracking branch: The
2540 # local tracking branch is only updated by dgit fetch, and
2541 # whenever dgit fetch runs it includes the public view in the
2542 # local tracking branch. Therefore if the public view is not
2543 # descended from the local tracking branch, the local tracking
2544 # branch must contain history which was imported from the archive
2545 # but never pushed; and, its tip is now out of date. So, we make
2546 # a pseudo-merge to overwrite the old imports and stitch the old
2549 # Finally: we do not necessarily reify the public view (as
2550 # described above). This is so that we do not end up stacking two
2551 # pseudo-merges. So what we actually do is figure out the inputs
2552 # to any public view pseudo-merge and put them in @mergeinputs.
2555 # $mergeinputs[]{Commit}
2556 # $mergeinputs[]{Info}
2557 # $mergeinputs[0] is the one whose tree we use
2558 # @mergeinputs is in the order we use in the actual commit)
2561 # $mergeinputs[]{Message} is a commit message to use
2562 # $mergeinputs[]{ReverseParents} if def specifies that parent
2563 # list should be in opposite order
2564 # Such an entry has no Commit or Info. It applies only when found
2565 # in the last entry. (This ugliness is to support making
2566 # identical imports to previous dgit versions.)
2568 my $lastpush_hash = git_get_ref(lrfetchref());
2569 printdebug "previous reference hash=$lastpush_hash\n";
2570 $lastpush_mergeinput = $lastpush_hash && {
2571 Commit => $lastpush_hash,
2572 Info => "dgit suite branch on dgit git server",
2575 my $lastfetch_hash = git_get_ref(lrref());
2576 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2577 my $lastfetch_mergeinput = $lastfetch_hash && {
2578 Commit => $lastfetch_hash,
2579 Info => "dgit client's archive history view",
2582 my $dsc_mergeinput = $dsc_hash && {
2583 Commit => $dsc_hash,
2584 Info => "Dgit field in .dsc from archive",
2588 my $del_lrfetchrefs = sub {
2591 printdebug "del_lrfetchrefs...\n";
2592 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2593 my $objid = $lrfetchrefs_d{$fullrefname};
2594 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2596 $gur ||= new IO::Handle;
2597 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2599 printf $gur "delete %s %s\n", $fullrefname, $objid;
2602 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2606 if (defined $dsc_hash) {
2607 ensure_we_have_orig();
2608 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2609 @mergeinputs = $dsc_mergeinput
2610 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2611 print STDERR <<END or die $!;
2613 Git commit in archive is behind the last version allegedly pushed/uploaded.
2614 Commit referred to by archive: $dsc_hash
2615 Last version pushed with dgit: $lastpush_hash
2618 @mergeinputs = ($lastpush_mergeinput);
2620 # Archive has .dsc which is not a descendant of the last dgit
2621 # push. This can happen if the archive moves .dscs about.
2622 # Just follow its lead.
2623 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2624 progress "archive .dsc names newer git commit";
2625 @mergeinputs = ($dsc_mergeinput);
2627 progress "archive .dsc names other git commit, fixing up";
2628 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2632 @mergeinputs = generate_commits_from_dsc();
2633 # We have just done an import. Now, our import algorithm might
2634 # have been improved. But even so we do not want to generate
2635 # a new different import of the same package. So if the
2636 # version numbers are the same, just use our existing version.
2637 # If the version numbers are different, the archive has changed
2638 # (perhaps, rewound).
2639 if ($lastfetch_mergeinput &&
2640 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2641 (mergeinfo_version $mergeinputs[0]) )) {
2642 @mergeinputs = ($lastfetch_mergeinput);
2644 } elsif ($lastpush_hash) {
2645 # only in git, not in the archive yet
2646 @mergeinputs = ($lastpush_mergeinput);
2647 print STDERR <<END or die $!;
2649 Package not found in the archive, but has allegedly been pushed using dgit.
2653 printdebug "nothing found!\n";
2654 if (defined $skew_warning_vsn) {
2655 print STDERR <<END or die $!;
2657 Warning: relevant archive skew detected.
2658 Archive allegedly contains $skew_warning_vsn
2659 But we were not able to obtain any version from the archive or git.
2663 unshift @end, $del_lrfetchrefs;
2667 if ($lastfetch_hash &&
2669 my $h = $_->{Commit};
2670 $h and is_fast_fwd($lastfetch_hash, $h);
2671 # If true, one of the existing parents of this commit
2672 # is a descendant of the $lastfetch_hash, so we'll
2673 # be ff from that automatically.
2677 push @mergeinputs, $lastfetch_mergeinput;
2680 printdebug "fetch mergeinfos:\n";
2681 foreach my $mi (@mergeinputs) {
2683 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2685 printdebug sprintf " ReverseParents=%d Message=%s",
2686 $mi->{ReverseParents}, $mi->{Message};
2690 my $compat_info= pop @mergeinputs
2691 if $mergeinputs[$#mergeinputs]{Message};
2693 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2696 if (@mergeinputs > 1) {
2698 my $tree_commit = $mergeinputs[0]{Commit};
2700 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2701 $tree =~ m/\n\n/; $tree = $`;
2702 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2705 # We use the changelog author of the package in question the
2706 # author of this pseudo-merge. This is (roughly) correct if
2707 # this commit is simply representing aa non-dgit upload.
2708 # (Roughly because it does not record sponsorship - but we
2709 # don't have sponsorship info because that's in the .changes,
2710 # which isn't in the archivw.)
2712 # But, it might be that we are representing archive history
2713 # updates (including in-archive copies). These are not really
2714 # the responsibility of the person who created the .dsc, but
2715 # there is no-one whose name we should better use. (The
2716 # author of the .dsc-named commit is clearly worse.)
2718 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2719 my $author = clogp_authline $useclogp;
2720 my $cversion = getfield $useclogp, 'Version';
2722 my $mcf = ".git/dgit/mergecommit";
2723 open MC, ">", $mcf or die "$mcf $!";
2724 print MC <<END or die $!;
2728 my @parents = grep { $_->{Commit} } @mergeinputs;
2729 @parents = reverse @parents if $compat_info->{ReverseParents};
2730 print MC <<END or die $! foreach @parents;
2734 print MC <<END or die $!;
2740 if (defined $compat_info->{Message}) {
2741 print MC $compat_info->{Message} or die $!;
2743 print MC <<END or die $!;
2744 Record $package ($cversion) in archive suite $csuite
2748 my $message_add_info = sub {
2750 my $mversion = mergeinfo_version $mi;
2751 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2755 $message_add_info->($mergeinputs[0]);
2756 print MC <<END or die $!;
2757 should be treated as descended from
2759 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2763 $hash = make_commit $mcf;
2765 $hash = $mergeinputs[0]{Commit};
2767 printdebug "fetch hash=$hash\n";
2770 my ($lasth, $what) = @_;
2771 return unless $lasth;
2772 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2775 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2777 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2779 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2780 'DGIT_ARCHIVE', $hash;
2781 cmdoutput @git, qw(log -n2), $hash;
2782 # ... gives git a chance to complain if our commit is malformed
2784 if (defined $skew_warning_vsn) {
2786 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2787 my $gotclogp = commit_getclogp($hash);
2788 my $got_vsn = getfield $gotclogp, 'Version';
2789 printdebug "SKEW CHECK GOT $got_vsn\n";
2790 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2791 print STDERR <<END or die $!;
2793 Warning: archive skew detected. Using the available version:
2794 Archive allegedly contains $skew_warning_vsn
2795 We were able to obtain only $got_vsn
2801 if ($lastfetch_hash ne $hash) {
2802 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2806 dryrun_report @upd_cmd;
2810 lrfetchref_used lrfetchref();
2812 unshift @end, $del_lrfetchrefs;
2816 sub set_local_git_config ($$) {
2818 runcmd @git, qw(config), $k, $v;
2821 sub setup_mergechangelogs (;$) {
2823 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2825 my $driver = 'dpkg-mergechangelogs';
2826 my $cb = "merge.$driver";
2827 my $attrs = '.git/info/attributes';
2828 ensuredir '.git/info';
2830 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2831 if (!open ATTRS, "<", $attrs) {
2832 $!==ENOENT or die "$attrs: $!";
2836 next if m{^debian/changelog\s};
2837 print NATTRS $_, "\n" or die $!;
2839 ATTRS->error and die $!;
2842 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2845 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2846 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2848 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2851 sub setup_useremail (;$) {
2853 return unless $always || access_cfg_bool(1, 'setup-useremail');
2856 my ($k, $envvar) = @_;
2857 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2858 return unless defined $v;
2859 set_local_git_config "user.$k", $v;
2862 $setup->('email', 'DEBEMAIL');
2863 $setup->('name', 'DEBFULLNAME');
2866 sub ensure_setup_existing_tree () {
2867 my $k = "remote.$remotename.skipdefaultupdate";
2868 my $c = git_get_config $k;
2869 return if defined $c;
2870 set_local_git_config $k, 'true';
2873 sub setup_new_tree () {
2874 setup_mergechangelogs();
2880 canonicalise_suite();
2881 badusage "dry run makes no sense with clone" unless act_local();
2882 my $hasgit = check_for_git();
2883 mkdir $dstdir or fail "create \`$dstdir': $!";
2885 runcmd @git, qw(init -q);
2886 my $giturl = access_giturl(1);
2887 if (defined $giturl) {
2888 open H, "> .git/HEAD" or die $!;
2889 print H "ref: ".lref()."\n" or die $!;
2891 runcmd @git, qw(remote add), 'origin', $giturl;
2894 progress "fetching existing git history";
2896 runcmd_ordryrun_local @git, qw(fetch origin);
2898 progress "starting new git history";
2900 fetch_from_archive() or no_such_package;
2901 my $vcsgiturl = $dsc->{'Vcs-Git'};
2902 if (length $vcsgiturl) {
2903 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2904 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2907 runcmd @git, qw(reset --hard), lrref();
2908 runcmd qw(bash -ec), <<'END';
2910 git ls-tree -r --name-only -z HEAD | \
2911 xargs -0r touch -r . --
2913 printdone "ready for work in $dstdir";
2917 if (check_for_git()) {
2920 fetch_from_archive() or no_such_package();
2921 printdone "fetched into ".lrref();
2926 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2928 printdone "fetched to ".lrref()." and merged into HEAD";
2931 sub check_not_dirty () {
2932 foreach my $f (qw(local-options local-patch-header)) {
2933 if (stat_exists "debian/source/$f") {
2934 fail "git tree contains debian/source/$f";
2938 return if $ignoredirty;
2940 my @cmd = (@git, qw(diff --quiet HEAD));
2942 $!=0; $?=-1; system @cmd;
2945 fail "working tree is dirty (does not match HEAD)";
2951 sub commit_admin ($) {
2954 runcmd_ordryrun_local @git, qw(commit -m), $m;
2957 sub commit_quilty_patch () {
2958 my $output = cmdoutput @git, qw(status --porcelain);
2960 foreach my $l (split /\n/, $output) {
2961 next unless $l =~ m/\S/;
2962 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2966 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2968 progress "nothing quilty to commit, ok.";
2971 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2972 runcmd_ordryrun_local @git, qw(add -f), @adds;
2974 Commit Debian 3.0 (quilt) metadata
2976 [dgit ($our_version) quilt-fixup]
2980 sub get_source_format () {
2982 if (open F, "debian/source/options") {
2986 s/\s+$//; # ignore missing final newline
2988 my ($k, $v) = ($`, $'); #');
2989 $v =~ s/^"(.*)"$/$1/;
2995 F->error and die $!;
2998 die $! unless $!==&ENOENT;
3001 if (!open F, "debian/source/format") {
3002 die $! unless $!==&ENOENT;
3006 F->error and die $!;
3008 return ($_, \%options);
3011 sub madformat_wantfixup ($) {
3013 return 0 unless $format eq '3.0 (quilt)';
3014 our $quilt_mode_warned;
3015 if ($quilt_mode eq 'nocheck') {
3016 progress "Not doing any fixup of \`$format' due to".
3017 " ----no-quilt-fixup or --quilt=nocheck"
3018 unless $quilt_mode_warned++;
3021 progress "Format \`$format', need to check/update patch stack"
3022 unless $quilt_mode_warned++;
3026 sub maybe_split_brain_save ($$$) {
3027 my ($headref, $dgitview, $msg) = @_;
3028 # => message fragment "$saved" describing disposition of $dgitview
3029 return "commit id $dgitview" unless defined $split_brain_save;
3030 my @cmd = (shell_cmd "cd ../../../..",
3031 @git, qw(update-ref -m),
3032 "dgit --dgit-view-save $msg HEAD=$headref",
3033 $split_brain_save, $dgitview);
3035 return "and left in $split_brain_save";
3038 # An "infopair" is a tuple [ $thing, $what ]
3039 # (often $thing is a commit hash; $what is a description)
3041 sub infopair_cond_equal ($$) {
3043 $x->[0] eq $y->[0] or fail <<END;
3044 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3048 sub infopair_lrf_tag_lookup ($$) {
3049 my ($tagnames, $what) = @_;
3050 # $tagname may be an array ref
3051 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3052 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3053 foreach my $tagname (@tagnames) {
3054 my $lrefname = lrfetchrefs."/tags/$tagname";
3055 my $tagobj = $lrfetchrefs_f{$lrefname};
3056 next unless defined $tagobj;
3057 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3058 return [ git_rev_parse($tagobj), $what ];
3060 fail @tagnames==1 ? <<END : <<END;
3061 Wanted tag $what (@tagnames) on dgit server, but not found
3063 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3067 sub infopair_cond_ff ($$) {
3068 my ($anc,$desc) = @_;
3069 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3070 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3074 sub pseudomerge_version_check ($$) {
3075 my ($clogp, $archive_hash) = @_;
3077 my $arch_clogp = commit_getclogp $archive_hash;
3078 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3079 'version currently in archive' ];
3080 if (defined $overwrite_version) {
3081 if (length $overwrite_version) {
3082 infopair_cond_equal([ $overwrite_version,
3083 '--overwrite= version' ],
3086 my $v = $i_arch_v->[0];
3087 progress "Checking package changelog for archive version $v ...";
3089 my @xa = ("-f$v", "-t$v");
3090 my $vclogp = parsechangelog @xa;
3091 my $cv = [ (getfield $vclogp, 'Version'),
3092 "Version field from dpkg-parsechangelog @xa" ];
3093 infopair_cond_equal($i_arch_v, $cv);
3096 $@ =~ s/^dgit: //gm;
3098 "Perhaps debian/changelog does not mention $v ?";
3103 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3107 sub pseudomerge_make_commit ($$$$ $$) {
3108 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3109 $msg_cmd, $msg_msg) = @_;
3110 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3112 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3113 my $authline = clogp_authline $clogp;
3117 !defined $overwrite_version ? ""
3118 : !length $overwrite_version ? " --overwrite"
3119 : " --overwrite=".$overwrite_version;
3122 my $pmf = ".git/dgit/pseudomerge";
3123 open MC, ">", $pmf or die "$pmf $!";
3124 print MC <<END or die $!;
3127 parent $archive_hash
3137 return make_commit($pmf);
3140 sub splitbrain_pseudomerge ($$$$) {
3141 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3142 # => $merged_dgitview
3143 printdebug "splitbrain_pseudomerge...\n";
3145 # We: debian/PREVIOUS HEAD($maintview)
3146 # expect: o ----------------- o
3149 # a/d/PREVIOUS $dgitview
3152 # we do: `------------------ o
3156 return $dgitview unless defined $archive_hash;
3158 printdebug "splitbrain_pseudomerge...\n";
3160 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3162 if (!defined $overwrite_version) {
3163 progress "Checking that HEAD inciudes all changes in archive...";
3166 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3168 if (defined $overwrite_version) {
3170 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3171 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3172 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3173 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3174 my $i_archive = [ $archive_hash, "current archive contents" ];
3176 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3178 infopair_cond_equal($i_dgit, $i_archive);
3179 infopair_cond_ff($i_dep14, $i_dgit);
3180 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3184 $us: check failed (maybe --overwrite is needed, consult documentation)
3189 my $r = pseudomerge_make_commit
3190 $clogp, $dgitview, $archive_hash, $i_arch_v,
3191 "dgit --quilt=$quilt_mode",
3192 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3193 Declare fast forward from $i_arch_v->[0]
3195 Make fast forward from $i_arch_v->[0]
3198 maybe_split_brain_save $maintview, $r, "pseudomerge";
3200 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3204 sub plain_overwrite_pseudomerge ($$$) {
3205 my ($clogp, $head, $archive_hash) = @_;
3207 printdebug "plain_overwrite_pseudomerge...";
3209 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3211 return $head if is_fast_fwd $archive_hash, $head;
3213 my $m = "Declare fast forward from $i_arch_v->[0]";
3215 my $r = pseudomerge_make_commit
3216 $clogp, $head, $archive_hash, $i_arch_v,
3219 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3221 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3225 sub push_parse_changelog ($) {
3228 my $clogp = Dpkg::Control::Hash->new();
3229 $clogp->load($clogpfn) or die;
3231 my $clogpackage = getfield $clogp, 'Source';
3232 $package //= $clogpackage;
3233 fail "-p specified $package but changelog specified $clogpackage"
3234 unless $package eq $clogpackage;
3235 my $cversion = getfield $clogp, 'Version';
3236 my $tag = debiantag($cversion, access_nomdistro);
3237 runcmd @git, qw(check-ref-format), $tag;
3239 my $dscfn = dscfn($cversion);
3241 return ($clogp, $cversion, $dscfn);
3244 sub push_parse_dsc ($$$) {
3245 my ($dscfn,$dscfnwhat, $cversion) = @_;
3246 $dsc = parsecontrol($dscfn,$dscfnwhat);
3247 my $dversion = getfield $dsc, 'Version';
3248 my $dscpackage = getfield $dsc, 'Source';
3249 ($dscpackage eq $package && $dversion eq $cversion) or
3250 fail "$dscfn is for $dscpackage $dversion".
3251 " but debian/changelog is for $package $cversion";
3254 sub push_tagwants ($$$$) {
3255 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3258 TagFn => \&debiantag,
3263 if (defined $maintviewhead) {
3265 TagFn => \&debiantag_maintview,
3266 Objid => $maintviewhead,
3267 TfSuffix => '-maintview',
3271 foreach my $tw (@tagwants) {
3272 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3273 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3275 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3279 sub push_mktags ($$ $$ $) {
3281 $changesfile,$changesfilewhat,
3284 die unless $tagwants->[0]{View} eq 'dgit';
3286 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3287 $dsc->save("$dscfn.tmp") or die $!;
3289 my $changes = parsecontrol($changesfile,$changesfilewhat);
3290 foreach my $field (qw(Source Distribution Version)) {
3291 $changes->{$field} eq $clogp->{$field} or
3292 fail "changes field $field \`$changes->{$field}'".
3293 " does not match changelog \`$clogp->{$field}'";
3296 my $cversion = getfield $clogp, 'Version';
3297 my $clogsuite = getfield $clogp, 'Distribution';
3299 # We make the git tag by hand because (a) that makes it easier
3300 # to control the "tagger" (b) we can do remote signing
3301 my $authline = clogp_authline $clogp;
3302 my $delibs = join(" ", "",@deliberatelies);
3303 my $declaredistro = access_nomdistro();
3307 my $tfn = $tw->{Tfn};
3308 my $head = $tw->{Objid};
3309 my $tag = $tw->{Tag};
3311 open TO, '>', $tfn->('.tmp') or die $!;
3312 print TO <<END or die $!;
3319 if ($tw->{View} eq 'dgit') {
3320 print TO <<END or die $!;
3321 $package release $cversion for $clogsuite ($csuite) [dgit]
3322 [dgit distro=$declaredistro$delibs]
3324 foreach my $ref (sort keys %previously) {
3325 print TO <<END or die $!;
3326 [dgit previously:$ref=$previously{$ref}]
3329 } elsif ($tw->{View} eq 'maint') {
3330 print TO <<END or die $!;
3331 $package release $cversion for $clogsuite ($csuite)
3332 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3335 die Dumper($tw)."?";
3340 my $tagobjfn = $tfn->('.tmp');
3342 if (!defined $keyid) {
3343 $keyid = access_cfg('keyid','RETURN-UNDEF');
3345 if (!defined $keyid) {
3346 $keyid = getfield $clogp, 'Maintainer';
3348 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3349 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3350 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3351 push @sign_cmd, $tfn->('.tmp');
3352 runcmd_ordryrun @sign_cmd;
3354 $tagobjfn = $tfn->('.signed.tmp');
3355 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3356 $tfn->('.tmp'), $tfn->('.tmp.asc');
3362 my @r = map { $mktag->($_); } @$tagwants;
3366 sub sign_changes ($) {
3367 my ($changesfile) = @_;
3369 my @debsign_cmd = @debsign;
3370 push @debsign_cmd, "-k$keyid" if defined $keyid;
3371 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3372 push @debsign_cmd, $changesfile;
3373 runcmd_ordryrun @debsign_cmd;
3378 printdebug "actually entering push\n";
3380 supplementary_message(<<'END');
3381 Push failed, while checking state of the archive.
3382 You can retry the push, after fixing the problem, if you like.
3384 if (check_for_git()) {
3387 my $archive_hash = fetch_from_archive();
3388 if (!$archive_hash) {
3390 fail "package appears to be new in this suite;".
3391 " if this is intentional, use --new";
3394 supplementary_message(<<'END');
3395 Push failed, while preparing your push.
3396 You can retry the push, after fixing the problem, if you like.
3399 need_tagformat 'new', "quilt mode $quilt_mode"
3400 if quiltmode_splitbrain;
3404 access_giturl(); # check that success is vaguely likely
3407 my $clogpfn = ".git/dgit/changelog.822.tmp";
3408 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3410 responder_send_file('parsed-changelog', $clogpfn);
3412 my ($clogp, $cversion, $dscfn) =
3413 push_parse_changelog("$clogpfn");
3415 my $dscpath = "$buildproductsdir/$dscfn";
3416 stat_exists $dscpath or
3417 fail "looked for .dsc $dscfn, but $!;".
3418 " maybe you forgot to build";
3420 responder_send_file('dsc', $dscpath);
3422 push_parse_dsc($dscpath, $dscfn, $cversion);
3424 my $format = getfield $dsc, 'Format';
3425 printdebug "format $format\n";
3427 my $actualhead = git_rev_parse('HEAD');
3428 my $dgithead = $actualhead;
3429 my $maintviewhead = undef;
3431 my $upstreamversion = upstreamversion $clogp->{Version};
3433 if (madformat_wantfixup($format)) {
3434 # user might have not used dgit build, so maybe do this now:
3435 if (quiltmode_splitbrain()) {
3437 quilt_make_fake_dsc($upstreamversion);
3439 ($dgithead, $cachekey) =
3440 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3442 "--quilt=$quilt_mode but no cached dgit view:
3443 perhaps tree changed since dgit build[-source] ?";
3445 $dgithead = splitbrain_pseudomerge($clogp,
3446 $actualhead, $dgithead,
3448 $maintviewhead = $actualhead;
3449 changedir '../../../..';
3450 prep_ud(); # so _only_subdir() works, below
3452 commit_quilty_patch();
3456 if (defined $overwrite_version && !defined $maintviewhead) {
3457 $dgithead = plain_overwrite_pseudomerge($clogp,
3465 if ($archive_hash) {
3466 if (is_fast_fwd($archive_hash, $dgithead)) {
3468 } elsif (deliberately_not_fast_forward) {
3471 fail "dgit push: HEAD is not a descendant".
3472 " of the archive's version.\n".
3473 "To overwrite the archive's contents,".
3474 " pass --overwrite[=VERSION].\n".
3475 "To rewind history, if permitted by the archive,".
3476 " use --deliberately-not-fast-forward.";
3481 progress "checking that $dscfn corresponds to HEAD";
3482 runcmd qw(dpkg-source -x --),
3483 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3484 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3485 check_for_vendor_patches() if madformat($dsc->{format});
3486 changedir '../../../..';
3487 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3488 debugcmd "+",@diffcmd;
3490 my $r = system @diffcmd;
3493 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3495 HEAD specifies a different tree to $dscfn:
3497 Perhaps you forgot to build. Or perhaps there is a problem with your
3498 source tree (see dgit(7) for some hints). To see a full diff, run
3505 if (!$changesfile) {
3506 my $pat = changespat $cversion;
3507 my @cs = glob "$buildproductsdir/$pat";
3508 fail "failed to find unique changes file".
3509 " (looked for $pat in $buildproductsdir);".
3510 " perhaps you need to use dgit -C"
3512 ($changesfile) = @cs;
3514 $changesfile = "$buildproductsdir/$changesfile";
3517 # Check that changes and .dsc agree enough
3518 $changesfile =~ m{[^/]*$};
3519 my $changes = parsecontrol($changesfile,$&);
3520 files_compare_inputs($dsc, $changes)
3521 unless forceing [qw(dsc-changes-mismatch)];
3523 # Perhaps adjust .dsc to contain right set of origs
3524 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3526 unless forceing [qw(changes-origs-exactly)];
3528 # Checks complete, we're going to try and go ahead:
3530 responder_send_file('changes',$changesfile);
3531 responder_send_command("param head $dgithead");
3532 responder_send_command("param csuite $csuite");
3533 responder_send_command("param tagformat $tagformat");
3534 if (defined $maintviewhead) {
3535 die unless ($protovsn//4) >= 4;
3536 responder_send_command("param maint-view $maintviewhead");
3539 if (deliberately_not_fast_forward) {
3540 git_for_each_ref(lrfetchrefs, sub {
3541 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3542 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3543 responder_send_command("previously $rrefname=$objid");
3544 $previously{$rrefname} = $objid;
3548 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3552 supplementary_message(<<'END');
3553 Push failed, while signing the tag.
3554 You can retry the push, after fixing the problem, if you like.
3556 # If we manage to sign but fail to record it anywhere, it's fine.
3557 if ($we_are_responder) {
3558 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3559 responder_receive_files('signed-tag', @tagobjfns);
3561 @tagobjfns = push_mktags($clogp,$dscpath,
3562 $changesfile,$changesfile,
3565 supplementary_message(<<'END');
3566 Push failed, *after* signing the tag.
3567 If you want to try again, you should use a new version number.
3570 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3572 foreach my $tw (@tagwants) {
3573 my $tag = $tw->{Tag};
3574 my $tagobjfn = $tw->{TagObjFn};
3576 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3577 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3578 runcmd_ordryrun_local
3579 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3582 supplementary_message(<<'END');
3583 Push failed, while updating the remote git repository - see messages above.
3584 If you want to try again, you should use a new version number.
3586 if (!check_for_git()) {
3587 create_remote_git_repo();
3590 my @pushrefs = $forceflag.$dgithead.":".rrref();
3591 foreach my $tw (@tagwants) {
3592 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3595 runcmd_ordryrun @git,
3596 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3597 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3599 supplementary_message(<<'END');
3600 Push failed, after updating the remote git repository.
3601 If you want to try again, you must use a new version number.
3603 if ($we_are_responder) {
3604 my $dryrunsuffix = act_local() ? "" : ".tmp";
3605 responder_receive_files('signed-dsc-changes',
3606 "$dscpath$dryrunsuffix",
3607 "$changesfile$dryrunsuffix");
3610 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3612 progress "[new .dsc left in $dscpath.tmp]";
3614 sign_changes $changesfile;
3617 supplementary_message(<<END);
3618 Push failed, while uploading package(s) to the archive server.
3619 You can retry the upload of exactly these same files with dput of:
3621 If that .changes file is broken, you will need to use a new version
3622 number for your next attempt at the upload.
3624 my $host = access_cfg('upload-host','RETURN-UNDEF');
3625 my @hostarg = defined($host) ? ($host,) : ();
3626 runcmd_ordryrun @dput, @hostarg, $changesfile;
3627 printdone "pushed and uploaded $cversion";
3629 supplementary_message('');
3630 responder_send_command("complete");
3637 badusage "-p is not allowed with clone; specify as argument instead"
3638 if defined $package;
3641 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3642 ($package,$isuite) = @ARGV;
3643 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3644 ($package,$dstdir) = @ARGV;
3645 } elsif (@ARGV==3) {
3646 ($package,$isuite,$dstdir) = @ARGV;
3648 badusage "incorrect arguments to dgit clone";
3650 $dstdir ||= "$package";
3652 if (stat_exists $dstdir) {
3653 fail "$dstdir already exists";
3657 if ($rmonerror && !$dryrun_level) {
3658 $cwd_remove= getcwd();
3660 return unless defined $cwd_remove;
3661 if (!chdir "$cwd_remove") {
3662 return if $!==&ENOENT;
3663 die "chdir $cwd_remove: $!";
3666 rmtree($dstdir) or die "remove $dstdir: $!\n";
3667 } elsif (grep { $! == $_ }
3668 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3670 print STDERR "check whether to remove $dstdir: $!\n";
3676 $cwd_remove = undef;
3679 sub branchsuite () {
3680 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3681 if ($branch =~ m#$lbranch_re#o) {
3688 sub fetchpullargs () {
3690 if (!defined $package) {
3691 my $sourcep = parsecontrol('debian/control','debian/control');
3692 $package = getfield $sourcep, 'Source';
3695 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3697 my $clogp = parsechangelog();
3698 $isuite = getfield $clogp, 'Distribution';
3700 canonicalise_suite();
3701 progress "fetching from suite $csuite";
3702 } elsif (@ARGV==1) {
3704 canonicalise_suite();
3706 badusage "incorrect arguments to dgit fetch or dgit pull";
3719 if (quiltmode_splitbrain()) {
3720 my ($format, $fopts) = get_source_format();
3721 madformat($format) and fail <<END
3722 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3731 badusage "-p is not allowed with dgit push" if defined $package;
3733 my $clogp = parsechangelog();
3734 $package = getfield $clogp, 'Source';
3737 } elsif (@ARGV==1) {
3738 ($specsuite) = (@ARGV);
3740 badusage "incorrect arguments to dgit push";
3742 $isuite = getfield $clogp, 'Distribution';
3744 local ($package) = $existing_package; # this is a hack
3745 canonicalise_suite();
3747 canonicalise_suite();
3749 if (defined $specsuite &&
3750 $specsuite ne $isuite &&
3751 $specsuite ne $csuite) {
3752 fail "dgit push: changelog specifies $isuite ($csuite)".
3753 " but command line specifies $specsuite";
3758 #---------- remote commands' implementation ----------
3760 sub cmd_remote_push_build_host {
3761 my ($nrargs) = shift @ARGV;
3762 my (@rargs) = @ARGV[0..$nrargs-1];
3763 @ARGV = @ARGV[$nrargs..$#ARGV];
3765 my ($dir,$vsnwant) = @rargs;
3766 # vsnwant is a comma-separated list; we report which we have
3767 # chosen in our ready response (so other end can tell if they
3770 $we_are_responder = 1;
3771 $us .= " (build host)";
3775 open PI, "<&STDIN" or die $!;
3776 open STDIN, "/dev/null" or die $!;
3777 open PO, ">&STDOUT" or die $!;
3779 open STDOUT, ">&STDERR" or die $!;
3783 ($protovsn) = grep {
3784 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3785 } @rpushprotovsn_support;
3787 fail "build host has dgit rpush protocol versions ".
3788 (join ",", @rpushprotovsn_support).
3789 " but invocation host has $vsnwant"
3790 unless defined $protovsn;
3792 responder_send_command("dgit-remote-push-ready $protovsn");
3793 rpush_handle_protovsn_bothends();
3798 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3799 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3800 # a good error message)
3802 sub rpush_handle_protovsn_bothends () {
3803 if ($protovsn < 4) {
3804 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3813 my $report = i_child_report();
3814 if (defined $report) {
3815 printdebug "($report)\n";
3816 } elsif ($i_child_pid) {
3817 printdebug "(killing build host child $i_child_pid)\n";
3818 kill 15, $i_child_pid;
3820 if (defined $i_tmp && !defined $initiator_tempdir) {
3822 eval { rmtree $i_tmp; };
3826 END { i_cleanup(); }
3829 my ($base,$selector,@args) = @_;
3830 $selector =~ s/\-/_/g;
3831 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3838 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3846 push @rargs, join ",", @rpushprotovsn_support;
3849 push @rdgit, @ropts;
3850 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3852 my @cmd = (@ssh, $host, shellquote @rdgit);
3855 if (defined $initiator_tempdir) {
3856 rmtree $initiator_tempdir;
3857 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3858 $i_tmp = $initiator_tempdir;
3862 $i_child_pid = open2(\*RO, \*RI, @cmd);
3864 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3865 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3866 $supplementary_message = '' unless $protovsn >= 3;
3868 fail "rpush negotiated protocol version $protovsn".
3869 " which does not support quilt mode $quilt_mode"
3870 if quiltmode_splitbrain;
3872 rpush_handle_protovsn_bothends();
3874 my ($icmd,$iargs) = initiator_expect {
3875 m/^(\S+)(?: (.*))?$/;
3878 i_method "i_resp", $icmd, $iargs;
3882 sub i_resp_progress ($) {
3884 my $msg = protocol_read_bytes \*RO, $rhs;
3888 sub i_resp_supplementary_message ($) {
3890 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3893 sub i_resp_complete {
3894 my $pid = $i_child_pid;
3895 $i_child_pid = undef; # prevents killing some other process with same pid
3896 printdebug "waiting for build host child $pid...\n";
3897 my $got = waitpid $pid, 0;
3898 die $! unless $got == $pid;
3899 die "build host child failed $?" if $?;
3902 printdebug "all done\n";
3906 sub i_resp_file ($) {
3908 my $localname = i_method "i_localname", $keyword;
3909 my $localpath = "$i_tmp/$localname";
3910 stat_exists $localpath and
3911 badproto \*RO, "file $keyword ($localpath) twice";
3912 protocol_receive_file \*RO, $localpath;
3913 i_method "i_file", $keyword;
3918 sub i_resp_param ($) {
3919 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3923 sub i_resp_previously ($) {
3924 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3925 or badproto \*RO, "bad previously spec";
3926 my $r = system qw(git check-ref-format), $1;
3927 die "bad previously ref spec ($r)" if $r;
3928 $previously{$1} = $2;
3933 sub i_resp_want ($) {
3935 die "$keyword ?" if $i_wanted{$keyword}++;
3936 my @localpaths = i_method "i_want", $keyword;
3937 printdebug "[[ $keyword @localpaths\n";
3938 foreach my $localpath (@localpaths) {
3939 protocol_send_file \*RI, $localpath;
3941 print RI "files-end\n" or die $!;
3944 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3946 sub i_localname_parsed_changelog {
3947 return "remote-changelog.822";
3949 sub i_file_parsed_changelog {
3950 ($i_clogp, $i_version, $i_dscfn) =
3951 push_parse_changelog "$i_tmp/remote-changelog.822";
3952 die if $i_dscfn =~ m#/|^\W#;
3955 sub i_localname_dsc {
3956 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3961 sub i_localname_changes {
3962 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3963 $i_changesfn = $i_dscfn;
3964 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3965 return $i_changesfn;
3967 sub i_file_changes { }
3969 sub i_want_signed_tag {
3970 printdebug Dumper(\%i_param, $i_dscfn);
3971 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3972 && defined $i_param{'csuite'}
3973 or badproto \*RO, "premature desire for signed-tag";
3974 my $head = $i_param{'head'};
3975 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3977 my $maintview = $i_param{'maint-view'};
3978 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3981 if ($protovsn >= 4) {
3982 my $p = $i_param{'tagformat'} // '<undef>';
3984 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3987 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3989 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3991 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3994 push_mktags $i_clogp, $i_dscfn,
3995 $i_changesfn, 'remote changes',
3999 sub i_want_signed_dsc_changes {
4000 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4001 sign_changes $i_changesfn;
4002 return ($i_dscfn, $i_changesfn);
4005 #---------- building etc. ----------
4011 #----- `3.0 (quilt)' handling -----
4013 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4015 sub quiltify_dpkg_commit ($$$;$) {
4016 my ($patchname,$author,$msg, $xinfo) = @_;
4020 my $descfn = ".git/dgit/quilt-description.tmp";
4021 open O, '>', $descfn or die "$descfn: $!";
4022 $msg =~ s/\n+/\n\n/;
4023 print O <<END or die $!;
4025 ${xinfo}Subject: $msg
4032 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4033 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4034 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4035 runcmd @dpkgsource, qw(--commit .), $patchname;
4039 sub quiltify_trees_differ ($$;$$$) {
4040 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4041 # returns true iff the two tree objects differ other than in debian/
4042 # with $finegrained,
4043 # returns bitmask 01 - differ in upstream files except .gitignore
4044 # 02 - differ in .gitignore
4045 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4046 # is set for each modified .gitignore filename $fn
4047 # if $unrepres is defined, array ref to which is appeneded
4048 # a list of unrepresentable changes (removals of upstream files
4051 my @cmd = (@git, qw(diff-tree -z));
4052 push @cmd, qw(--name-only) unless $unrepres;
4053 push @cmd, qw(-r) if $finegrained || $unrepres;
4055 my $diffs= cmdoutput @cmd;
4058 foreach my $f (split /\0/, $diffs) {
4059 if ($unrepres && !@lmodes) {
4060 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4063 my ($oldmode,$newmode) = @lmodes;
4066 next if $f =~ m#^debian(?:/.*)?$#s;
4070 die "deleted\n" unless $newmode =~ m/[^0]/;
4071 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4072 if ($oldmode =~ m/[^0]/) {
4073 die "mode changed\n" if $oldmode ne $newmode;
4075 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4079 local $/="\n"; chomp $@;
4080 push @$unrepres, [ $f, $@ ];
4084 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4085 $r |= $isignore ? 02 : 01;
4086 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4088 printdebug "quiltify_trees_differ $x $y => $r\n";
4092 sub quiltify_tree_sentinelfiles ($) {
4093 # lists the `sentinel' files present in the tree
4095 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4096 qw(-- debian/rules debian/control);
4101 sub quiltify_splitbrain_needed () {
4102 if (!$split_brain) {
4103 progress "dgit view: changes are required...";
4104 runcmd @git, qw(checkout -q -b dgit-view);
4109 sub quiltify_splitbrain ($$$$$$) {
4110 my ($clogp, $unapplied, $headref, $diffbits,
4111 $editedignores, $cachekey) = @_;
4112 if ($quilt_mode !~ m/gbp|dpm/) {
4113 # treat .gitignore just like any other upstream file
4114 $diffbits = { %$diffbits };
4115 $_ = !!$_ foreach values %$diffbits;
4117 # We would like any commits we generate to be reproducible
4118 my @authline = clogp_authline($clogp);
4119 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4120 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4121 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4122 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4123 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4124 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4126 if ($quilt_mode =~ m/gbp|unapplied/ &&
4127 ($diffbits->{O2H} & 01)) {
4129 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4130 " but git tree differs from orig in upstream files.";
4131 if (!stat_exists "debian/patches") {
4133 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4137 if ($quilt_mode =~ m/dpm/ &&
4138 ($diffbits->{H2A} & 01)) {
4140 --quilt=$quilt_mode specified, implying patches-applied git tree
4141 but git tree differs from result of applying debian/patches to upstream
4144 if ($quilt_mode =~ m/gbp|unapplied/ &&
4145 ($diffbits->{O2A} & 01)) { # some patches
4146 quiltify_splitbrain_needed();
4147 progress "dgit view: creating patches-applied version using gbp pq";
4148 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4149 # gbp pq import creates a fresh branch; push back to dgit-view
4150 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4151 runcmd @git, qw(checkout -q dgit-view);
4153 if ($quilt_mode =~ m/gbp|dpm/ &&
4154 ($diffbits->{O2A} & 02)) {
4156 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4157 tool which does not create patches for changes to upstream
4158 .gitignores: but, such patches exist in debian/patches.
4161 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4162 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4163 quiltify_splitbrain_needed();
4164 progress "dgit view: creating patch to represent .gitignore changes";
4165 ensuredir "debian/patches";
4166 my $gipatch = "debian/patches/auto-gitignore";
4167 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4168 stat GIPATCH or die "$gipatch: $!";
4169 fail "$gipatch already exists; but want to create it".
4170 " to record .gitignore changes" if (stat _)[7];
4171 print GIPATCH <<END or die "$gipatch: $!";
4172 Subject: Update .gitignore from Debian packaging branch
4174 The Debian packaging git branch contains these updates to the upstream
4175 .gitignore file(s). This patch is autogenerated, to provide these
4176 updates to users of the official Debian archive view of the package.
4178 [dgit ($our_version) update-gitignore]
4181 close GIPATCH or die "$gipatch: $!";
4182 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4183 $unapplied, $headref, "--", sort keys %$editedignores;
4184 open SERIES, "+>>", "debian/patches/series" or die $!;
4185 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4187 defined read SERIES, $newline, 1 or die $!;
4188 print SERIES "\n" or die $! unless $newline eq "\n";
4189 print SERIES "auto-gitignore\n" or die $!;
4190 close SERIES or die $!;
4191 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4193 Commit patch to update .gitignore
4195 [dgit ($our_version) update-gitignore-quilt-fixup]
4199 my $dgitview = git_rev_parse 'HEAD';
4201 changedir '../../../..';
4202 # When we no longer need to support squeeze, use --create-reflog
4204 ensuredir ".git/logs/refs/dgit-intern";
4205 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4208 my $oldcache = git_get_ref "refs/$splitbraincache";
4209 if ($oldcache eq $dgitview) {
4210 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4211 # git update-ref doesn't always update, in this case. *sigh*
4212 my $dummy = make_commit_text <<END;
4215 author Dgit <dgit\@example.com> 1000000000 +0000
4216 committer Dgit <dgit\@example.com> 1000000000 +0000
4218 Dummy commit - do not use
4220 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4221 "refs/$splitbraincache", $dummy;
4223 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4226 changedir '.git/dgit/unpack/work';
4228 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4229 progress "dgit view: created ($saved)";
4232 sub quiltify ($$$$) {
4233 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4235 # Quilt patchification algorithm
4237 # We search backwards through the history of the main tree's HEAD
4238 # (T) looking for a start commit S whose tree object is identical
4239 # to to the patch tip tree (ie the tree corresponding to the
4240 # current dpkg-committed patch series). For these purposes
4241 # `identical' disregards anything in debian/ - this wrinkle is
4242 # necessary because dpkg-source treates debian/ specially.
4244 # We can only traverse edges where at most one of the ancestors'
4245 # trees differs (in changes outside in debian/). And we cannot
4246 # handle edges which change .pc/ or debian/patches. To avoid
4247 # going down a rathole we avoid traversing edges which introduce
4248 # debian/rules or debian/control. And we set a limit on the
4249 # number of edges we are willing to look at.
4251 # If we succeed, we walk forwards again. For each traversed edge
4252 # PC (with P parent, C child) (starting with P=S and ending with
4253 # C=T) to we do this:
4255 # - dpkg-source --commit with a patch name and message derived from C
4256 # After traversing PT, we git commit the changes which
4257 # should be contained within debian/patches.
4259 # The search for the path S..T is breadth-first. We maintain a
4260 # todo list containing search nodes. A search node identifies a
4261 # commit, and looks something like this:
4263 # Commit => $git_commit_id,
4264 # Child => $c, # or undef if P=T
4265 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4266 # Nontrivial => true iff $p..$c has relevant changes
4273 my %considered; # saves being exponential on some weird graphs
4275 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4278 my ($search,$whynot) = @_;
4279 printdebug " search NOT $search->{Commit} $whynot\n";
4280 $search->{Whynot} = $whynot;
4281 push @nots, $search;
4282 no warnings qw(exiting);
4291 my $c = shift @todo;
4292 next if $considered{$c->{Commit}}++;
4294 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4296 printdebug "quiltify investigate $c->{Commit}\n";
4299 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4300 printdebug " search finished hooray!\n";
4305 if ($quilt_mode eq 'nofix') {
4306 fail "quilt fixup required but quilt mode is \`nofix'\n".
4307 "HEAD commit $c->{Commit} differs from tree implied by ".
4308 " debian/patches (tree object $oldtiptree)";
4310 if ($quilt_mode eq 'smash') {
4311 printdebug " search quitting smash\n";
4315 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4316 $not->($c, "has $c_sentinels not $t_sentinels")
4317 if $c_sentinels ne $t_sentinels;
4319 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4320 $commitdata =~ m/\n\n/;
4322 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4323 @parents = map { { Commit => $_, Child => $c } } @parents;
4325 $not->($c, "root commit") if !@parents;
4327 foreach my $p (@parents) {
4328 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4330 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4331 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4333 foreach my $p (@parents) {
4334 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4336 my @cmd= (@git, qw(diff-tree -r --name-only),
4337 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4338 my $patchstackchange = cmdoutput @cmd;
4339 if (length $patchstackchange) {
4340 $patchstackchange =~ s/\n/,/g;
4341 $not->($p, "changed $patchstackchange");
4344 printdebug " search queue P=$p->{Commit} ",
4345 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4351 printdebug "quiltify want to smash\n";
4354 my $x = $_[0]{Commit};
4355 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4358 my $reportnot = sub {
4360 my $s = $abbrev->($notp);
4361 my $c = $notp->{Child};
4362 $s .= "..".$abbrev->($c) if $c;
4363 $s .= ": ".$notp->{Whynot};
4366 if ($quilt_mode eq 'linear') {
4367 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4368 foreach my $notp (@nots) {
4369 print STDERR "$us: ", $reportnot->($notp), "\n";
4371 print STDERR "$us: $_\n" foreach @$failsuggestion;
4372 fail "quilt fixup naive history linearisation failed.\n".
4373 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4374 } elsif ($quilt_mode eq 'smash') {
4375 } elsif ($quilt_mode eq 'auto') {
4376 progress "quilt fixup cannot be linear, smashing...";
4378 die "$quilt_mode ?";
4381 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4382 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4384 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4386 quiltify_dpkg_commit "auto-$version-$target-$time",
4387 (getfield $clogp, 'Maintainer'),
4388 "Automatically generated patch ($clogp->{Version})\n".
4389 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;