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);
43 our $our_version = 'UNRELEASED'; ###substituted###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $split_brain_save;
71 our $we_are_responder;
72 our $initiator_tempdir;
73 our $patches_applied_dirtily = 00;
78 our %forceopts = map { $_=>0 }
79 qw(unrepresentable unsupported-source-format
80 dsc-changes-mismatch changes-origs-exactly
81 import-gitapply-absurd
82 import-gitapply-no-absurd
83 import-dsc-with-dgit-field);
85 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
87 our $suite_re = '[-+.0-9a-z]+';
88 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
89 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
90 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
91 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
93 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
94 our $splitbraincache = 'dgit-intern/quilt-cache';
97 our (@dget) = qw(dget);
98 our (@curl) = qw(curl);
99 our (@dput) = qw(dput);
100 our (@debsign) = qw(debsign);
101 our (@gpg) = qw(gpg);
102 our (@sbuild) = qw(sbuild);
104 our (@dgit) = qw(dgit);
105 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
106 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
107 our (@dpkggenchanges) = qw(dpkg-genchanges);
108 our (@mergechanges) = qw(mergechanges -f);
109 our (@gbp_build) = ('');
110 our (@gbp_pq) = ('gbp pq');
111 our (@changesopts) = ('');
113 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
116 'debsign' => \@debsign,
118 'sbuild' => \@sbuild,
122 'dpkg-source' => \@dpkgsource,
123 'dpkg-buildpackage' => \@dpkgbuildpackage,
124 'dpkg-genchanges' => \@dpkggenchanges,
125 'gbp-build' => \@gbp_build,
126 'gbp-pq' => \@gbp_pq,
127 'ch' => \@changesopts,
128 'mergechanges' => \@mergechanges);
130 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
131 our %opts_cfg_insertpos = map {
133 scalar @{ $opts_opt_map{$_} }
134 } keys %opts_opt_map;
136 sub finalise_opts_opts();
142 our $supplementary_message = '';
143 our $need_split_build_invocation = 0;
144 our $split_brain = 0;
148 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
151 our $remotename = 'dgit';
152 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
156 if (!defined $absurdity) {
158 $absurdity =~ s{/[^/]+$}{/absurd} or die;
162 my ($v,$distro) = @_;
163 return $tagformatfn->($v, $distro);
166 sub debiantag_maintview ($$) {
167 my ($v,$distro) = @_;
172 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
174 sub lbranch () { return "$branchprefix/$csuite"; }
175 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
176 sub lref () { return "refs/heads/".lbranch(); }
177 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
178 sub rrref () { return server_ref($csuite); }
180 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
181 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
183 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
184 # locally fetched refs because they have unhelpful names and clutter
185 # up gitk etc. So we track whether we have "used up" head ref (ie,
186 # whether we have made another local ref which refers to this object).
188 # (If we deleted them unconditionally, then we might end up
189 # re-fetching the same git objects each time dgit fetch was run.)
191 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
192 # in git_fetch_us to fetch the refs in question, and possibly a call
193 # to lrfetchref_used.
195 our (%lrfetchrefs_f, %lrfetchrefs_d);
196 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
198 sub lrfetchref_used ($) {
199 my ($fullrefname) = @_;
200 my $objid = $lrfetchrefs_f{$fullrefname};
201 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
212 return "${package}_".(stripepoch $vsn).$sfx
217 return srcfn($vsn,".dsc");
220 sub changespat ($;$) {
221 my ($vsn, $arch) = @_;
222 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 sub upstreamversion ($) {
237 foreach my $f (@end) {
239 print STDERR "$us: cleanup: $@" if length $@;
243 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
245 sub forceable_fail ($$) {
246 my ($forceoptsl, $msg) = @_;
247 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
248 print STDERR "warning: overriding problem due to --force:\n". $msg;
252 my ($forceoptsl) = @_;
253 my @got = grep { $forceopts{$_} } @$forceoptsl;
254 return 0 unless @got;
256 "warning: skipping checks or functionality due to --force-$got[0]\n";
259 sub no_such_package () {
260 print STDERR "$us: package $package does not exist in suite $isuite\n";
266 printdebug "CD $newdir\n";
267 chdir $newdir or confess "chdir: $newdir: $!";
270 sub deliberately ($) {
272 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
275 sub deliberately_not_fast_forward () {
276 foreach (qw(not-fast-forward fresh-repo)) {
277 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
281 sub quiltmode_splitbrain () {
282 $quilt_mode =~ m/gbp|dpm|unapplied/;
285 sub opts_opt_multi_cmd {
287 push @cmd, split /\s+/, shift @_;
293 return opts_opt_multi_cmd @gbp_pq;
296 #---------- remote protocol support, common ----------
298 # remote push initiator/responder protocol:
299 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
300 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
301 # < dgit-remote-push-ready <actual-proto-vsn>
308 # > supplementary-message NBYTES # $protovsn >= 3
313 # > file parsed-changelog
314 # [indicates that output of dpkg-parsechangelog follows]
315 # > data-block NBYTES
316 # > [NBYTES bytes of data (no newline)]
317 # [maybe some more blocks]
326 # > param head DGIT-VIEW-HEAD
327 # > param csuite SUITE
328 # > param tagformat old|new
329 # > param maint-view MAINT-VIEW-HEAD
331 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
332 # # goes into tag, for replay prevention
335 # [indicates that signed tag is wanted]
336 # < data-block NBYTES
337 # < [NBYTES bytes of data (no newline)]
338 # [maybe some more blocks]
342 # > want signed-dsc-changes
343 # < data-block NBYTES [transfer of signed dsc]
345 # < data-block NBYTES [transfer of signed changes]
353 sub i_child_report () {
354 # Sees if our child has died, and reap it if so. Returns a string
355 # describing how it died if it failed, or undef otherwise.
356 return undef unless $i_child_pid;
357 my $got = waitpid $i_child_pid, WNOHANG;
358 return undef if $got <= 0;
359 die unless $got == $i_child_pid;
360 $i_child_pid = undef;
361 return undef unless $?;
362 return "build host child ".waitstatusmsg();
367 fail "connection lost: $!" if $fh->error;
368 fail "protocol violation; $m not expected";
371 sub badproto_badread ($$) {
373 fail "connection lost: $!" if $!;
374 my $report = i_child_report();
375 fail $report if defined $report;
376 badproto $fh, "eof (reading $wh)";
379 sub protocol_expect (&$) {
380 my ($match, $fh) = @_;
383 defined && chomp or badproto_badread $fh, "protocol message";
391 badproto $fh, "\`$_'";
394 sub protocol_send_file ($$) {
395 my ($fh, $ourfn) = @_;
396 open PF, "<", $ourfn or die "$ourfn: $!";
399 my $got = read PF, $d, 65536;
400 die "$ourfn: $!" unless defined $got;
402 print $fh "data-block ".length($d)."\n" or die $!;
403 print $fh $d or die $!;
405 PF->error and die "$ourfn $!";
406 print $fh "data-end\n" or die $!;
410 sub protocol_read_bytes ($$) {
411 my ($fh, $nbytes) = @_;
412 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
414 my $got = read $fh, $d, $nbytes;
415 $got==$nbytes or badproto_badread $fh, "data block";
419 sub protocol_receive_file ($$) {
420 my ($fh, $ourfn) = @_;
421 printdebug "() $ourfn\n";
422 open PF, ">", $ourfn or die "$ourfn: $!";
424 my ($y,$l) = protocol_expect {
425 m/^data-block (.*)$/ ? (1,$1) :
426 m/^data-end$/ ? (0,) :
430 my $d = protocol_read_bytes $fh, $l;
431 print PF $d or die $!;
436 #---------- remote protocol support, responder ----------
438 sub responder_send_command ($) {
440 return unless $we_are_responder;
441 # called even without $we_are_responder
442 printdebug ">> $command\n";
443 print PO $command, "\n" or die $!;
446 sub responder_send_file ($$) {
447 my ($keyword, $ourfn) = @_;
448 return unless $we_are_responder;
449 printdebug "]] $keyword $ourfn\n";
450 responder_send_command "file $keyword";
451 protocol_send_file \*PO, $ourfn;
454 sub responder_receive_files ($@) {
455 my ($keyword, @ourfns) = @_;
456 die unless $we_are_responder;
457 printdebug "[[ $keyword @ourfns\n";
458 responder_send_command "want $keyword";
459 foreach my $fn (@ourfns) {
460 protocol_receive_file \*PI, $fn;
463 protocol_expect { m/^files-end$/ } \*PI;
466 #---------- remote protocol support, initiator ----------
468 sub initiator_expect (&) {
470 protocol_expect { &$match } \*RO;
473 #---------- end remote code ----------
476 if ($we_are_responder) {
478 responder_send_command "progress ".length($m) or die $!;
479 print PO $m or die $!;
489 $ua = LWP::UserAgent->new();
493 progress "downloading $what...";
494 my $r = $ua->get(@_) or die $!;
495 return undef if $r->code == 404;
496 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
497 return $r->decoded_content(charset => 'none');
500 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
505 failedcmd @_ if system @_;
508 sub act_local () { return $dryrun_level <= 1; }
509 sub act_scary () { return !$dryrun_level; }
512 if (!$dryrun_level) {
513 progress "dgit ok: @_";
515 progress "would be ok: @_ (but dry run only)";
520 printcmd(\*STDERR,$debugprefix."#",@_);
523 sub runcmd_ordryrun {
531 sub runcmd_ordryrun_local {
540 my ($first_shell, @cmd) = @_;
541 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
544 our $helpmsg = <<END;
546 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
547 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
548 dgit [dgit-opts] build [dpkg-buildpackage-opts]
549 dgit [dgit-opts] sbuild [sbuild-opts]
550 dgit [dgit-opts] push [dgit-opts] [suite]
551 dgit [dgit-opts] rpush build-host:build-dir ...
552 important dgit options:
553 -k<keyid> sign tag and package with <keyid> instead of default
554 --dry-run -n do not change anything, but go through the motions
555 --damp-run -L like --dry-run but make local changes, without signing
556 --new -N allow introducing a new package
557 --debug -D increase debug level
558 -c<name>=<value> set git config option (used directly by dgit too)
561 our $later_warning_msg = <<END;
562 Perhaps the upload is stuck in incoming. Using the version from git.
566 print STDERR "$us: @_\n", $helpmsg or die $!;
571 @ARGV or badusage "too few arguments";
572 return scalar shift @ARGV;
576 print $helpmsg or die $!;
580 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
582 our %defcfg = ('dgit.default.distro' => 'debian',
583 'dgit.default.username' => '',
584 'dgit.default.archive-query-default-component' => 'main',
585 'dgit.default.ssh' => 'ssh',
586 'dgit.default.archive-query' => 'madison:',
587 'dgit.default.sshpsql-dbname' => 'service=projectb',
588 'dgit.default.dgit-tag-format' => 'new,old,maint',
589 # old means "repo server accepts pushes with old dgit tags"
590 # new means "repo server accepts pushes with new dgit tags"
591 # maint means "repo server accepts split brain pushes"
592 # hist means "repo server may have old pushes without new tag"
593 # ("hist" is implied by "old")
594 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
595 'dgit-distro.debian.git-check' => 'url',
596 'dgit-distro.debian.git-check-suffix' => '/info/refs',
597 'dgit-distro.debian.new-private-pushers' => 't',
598 'dgit-distro.debian/push.git-url' => '',
599 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
600 'dgit-distro.debian/push.git-user-force' => 'dgit',
601 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
602 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
603 'dgit-distro.debian/push.git-create' => 'true',
604 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
605 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
606 # 'dgit-distro.debian.archive-query-tls-key',
607 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
608 # ^ this does not work because curl is broken nowadays
609 # Fixing #790093 properly will involve providing providing the key
610 # in some pacagke and maybe updating these paths.
612 # 'dgit-distro.debian.archive-query-tls-curl-args',
613 # '--ca-path=/etc/ssl/ca-debian',
614 # ^ this is a workaround but works (only) on DSA-administered machines
615 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
616 'dgit-distro.debian.git-url-suffix' => '',
617 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
618 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
619 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
620 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
621 'dgit-distro.ubuntu.git-check' => 'false',
622 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
623 'dgit-distro.test-dummy.ssh' => "$td/ssh",
624 'dgit-distro.test-dummy.username' => "alice",
625 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
626 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-url' => "$td/git",
628 'dgit-distro.test-dummy.git-host' => "git",
629 'dgit-distro.test-dummy.git-path' => "$td/git",
630 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
631 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
632 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
633 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
637 our @gitcfgsources = qw(cmdline local global system);
639 sub git_slurp_config () {
640 local ($debuglevel) = $debuglevel-2;
643 # This algoritm is a bit subtle, but this is needed so that for
644 # options which we want to be single-valued, we allow the
645 # different config sources to override properly. See #835858.
646 foreach my $src (@gitcfgsources) {
647 next if $src eq 'cmdline';
648 # we do this ourselves since git doesn't handle it
650 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
653 open GITS, "-|", @cmd or die $!;
656 printdebug "=> ", (messagequote $_), "\n";
658 push @{ $gitcfgs{$src}{$`} }, $'; #';
662 or ($!==0 && $?==256)
667 sub git_get_config ($) {
669 foreach my $src (@gitcfgsources) {
670 my $l = $gitcfgs{$src}{$c};
671 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
674 @$l==1 or badcfg "multiple values for $c".
675 " (in $src git config)" if @$l > 1;
683 return undef if $c =~ /RETURN-UNDEF/;
684 my $v = git_get_config($c);
685 return $v if defined $v;
686 my $dv = $defcfg{$c};
687 return $dv if defined $dv;
689 badcfg "need value for one of: @_\n".
690 "$us: distro or suite appears not to be (properly) supported";
693 sub access_basedistro () {
694 if (defined $idistro) {
697 return cfg("dgit-suite.$isuite.distro",
698 "dgit.default.distro");
702 sub access_quirk () {
703 # returns (quirk name, distro to use instead or undef, quirk-specific info)
704 my $basedistro = access_basedistro();
705 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
707 if (defined $backports_quirk) {
708 my $re = $backports_quirk;
709 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
711 $re =~ s/\%/([-0-9a-z_]+)/
712 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
713 if ($isuite =~ m/^$re$/) {
714 return ('backports',"$basedistro-backports",$1);
717 return ('none',undef);
722 sub parse_cfg_bool ($$$) {
723 my ($what,$def,$v) = @_;
726 $v =~ m/^[ty1]/ ? 1 :
727 $v =~ m/^[fn0]/ ? 0 :
728 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
731 sub access_forpush_config () {
732 my $d = access_basedistro();
736 parse_cfg_bool('new-private-pushers', 0,
737 cfg("dgit-distro.$d.new-private-pushers",
740 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
743 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
744 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
745 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
746 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
749 sub access_forpush () {
750 $access_forpush //= access_forpush_config();
751 return $access_forpush;
755 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
756 badcfg "pushing but distro is configured readonly"
757 if access_forpush_config() eq '0';
759 $supplementary_message = <<'END' unless $we_are_responder;
760 Push failed, before we got started.
761 You can retry the push, after fixing the problem, if you like.
763 finalise_opts_opts();
767 finalise_opts_opts();
770 sub supplementary_message ($) {
772 if (!$we_are_responder) {
773 $supplementary_message = $msg;
775 } elsif ($protovsn >= 3) {
776 responder_send_command "supplementary-message ".length($msg)
778 print PO $msg or die $!;
782 sub access_distros () {
783 # Returns list of distros to try, in order
786 # 0. `instead of' distro name(s) we have been pointed to
787 # 1. the access_quirk distro, if any
788 # 2a. the user's specified distro, or failing that } basedistro
789 # 2b. the distro calculated from the suite }
790 my @l = access_basedistro();
792 my (undef,$quirkdistro) = access_quirk();
793 unshift @l, $quirkdistro;
794 unshift @l, $instead_distro;
795 @l = grep { defined } @l;
797 if (access_forpush()) {
798 @l = map { ("$_/push", $_) } @l;
803 sub access_cfg_cfgs (@) {
806 # The nesting of these loops determines the search order. We put
807 # the key loop on the outside so that we search all the distros
808 # for each key, before going on to the next key. That means that
809 # if access_cfg is called with a more specific, and then a less
810 # specific, key, an earlier distro can override the less specific
811 # without necessarily overriding any more specific keys. (If the
812 # distro wants to override the more specific keys it can simply do
813 # so; whereas if we did the loop the other way around, it would be
814 # impossible to for an earlier distro to override a less specific
815 # key but not the more specific ones without restating the unknown
816 # values of the more specific keys.
819 # We have to deal with RETURN-UNDEF specially, so that we don't
820 # terminate the search prematurely.
822 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
825 foreach my $d (access_distros()) {
826 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
828 push @cfgs, map { "dgit.default.$_" } @realkeys;
835 my (@cfgs) = access_cfg_cfgs(@keys);
836 my $value = cfg(@cfgs);
840 sub access_cfg_bool ($$) {
841 my ($def, @keys) = @_;
842 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
845 sub string_to_ssh ($) {
847 if ($spec =~ m/\s/) {
848 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
854 sub access_cfg_ssh () {
855 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
856 if (!defined $gitssh) {
859 return string_to_ssh $gitssh;
863 sub access_runeinfo ($) {
865 return ": dgit ".access_basedistro()." $info ;";
868 sub access_someuserhost ($) {
870 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
871 defined($user) && length($user) or
872 $user = access_cfg("$some-user",'username');
873 my $host = access_cfg("$some-host");
874 return length($user) ? "$user\@$host" : $host;
877 sub access_gituserhost () {
878 return access_someuserhost('git');
881 sub access_giturl (;$) {
883 my $url = access_cfg('git-url','RETURN-UNDEF');
886 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
887 return undef unless defined $proto;
890 access_gituserhost().
891 access_cfg('git-path');
893 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
896 return "$url/$package$suffix";
899 sub parsecontrolfh ($$;$) {
900 my ($fh, $desc, $allowsigned) = @_;
901 our $dpkgcontrolhash_noissigned;
904 my %opts = ('name' => $desc);
905 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
906 $c = Dpkg::Control::Hash->new(%opts);
907 $c->parse($fh,$desc) or die "parsing of $desc failed";
908 last if $allowsigned;
909 last if $dpkgcontrolhash_noissigned;
910 my $issigned= $c->get_option('is_pgp_signed');
911 if (!defined $issigned) {
912 $dpkgcontrolhash_noissigned= 1;
913 seek $fh, 0,0 or die "seek $desc: $!";
914 } elsif ($issigned) {
915 fail "control file $desc is (already) PGP-signed. ".
916 " Note that dgit push needs to modify the .dsc and then".
917 " do the signature itself";
926 my ($file, $desc) = @_;
927 my $fh = new IO::Handle;
928 open $fh, '<', $file or die "$file: $!";
929 my $c = parsecontrolfh($fh,$desc);
930 $fh->error and die $!;
936 my ($dctrl,$field) = @_;
937 my $v = $dctrl->{$field};
938 return $v if defined $v;
939 fail "missing field $field in ".$dctrl->get_option('name');
943 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
944 my $p = new IO::Handle;
945 my @cmd = (qw(dpkg-parsechangelog), @_);
946 open $p, '-|', @cmd or die $!;
948 $?=0; $!=0; close $p or failedcmd @cmd;
952 sub commit_getclogp ($) {
953 # Returns the parsed changelog hashref for a particular commit
955 our %commit_getclogp_memo;
956 my $memo = $commit_getclogp_memo{$objid};
957 return $memo if $memo;
959 my $mclog = ".git/dgit/clog-$objid";
960 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
961 "$objid:debian/changelog";
962 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
967 defined $d or fail "getcwd failed: $!";
971 sub parse_dscdata () {
972 my $dscfh = new IO::File \$dscdata, '<' or die $!;
973 printdebug Dumper($dscdata) if $debuglevel>1;
974 $dsc = parsecontrolfh($dscfh,$dscurl,1);
975 printdebug Dumper($dsc) if $debuglevel>1;
980 sub archive_query ($;@) {
981 my ($method) = shift @_;
982 my $query = access_cfg('archive-query','RETURN-UNDEF');
983 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
986 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
989 sub pool_dsc_subpath ($$) {
990 my ($vsn,$component) = @_; # $package is implict arg
991 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
992 return "/pool/$component/$prefix/$package/".dscfn($vsn);
995 #---------- `ftpmasterapi' archive query method (nascent) ----------
997 sub archive_api_query_cmd ($) {
999 my @cmd = (@curl, qw(-sS));
1000 my $url = access_cfg('archive-query-url');
1001 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1003 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1004 foreach my $key (split /\:/, $keys) {
1005 $key =~ s/\%HOST\%/$host/g;
1007 fail "for $url: stat $key: $!" unless $!==ENOENT;
1010 fail "config requested specific TLS key but do not know".
1011 " how to get curl to use exactly that EE key ($key)";
1012 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1013 # # Sadly the above line does not work because of changes
1014 # # to gnutls. The real fix for #790093 may involve
1015 # # new curl options.
1018 # Fixing #790093 properly will involve providing a value
1019 # for this on clients.
1020 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1021 push @cmd, split / /, $kargs if defined $kargs;
1023 push @cmd, $url.$subpath;
1027 sub api_query ($$;$) {
1029 my ($data, $subpath, $ok404) = @_;
1030 badcfg "ftpmasterapi archive query method takes no data part"
1032 my @cmd = archive_api_query_cmd($subpath);
1033 my $url = $cmd[$#cmd];
1034 push @cmd, qw(-w %{http_code});
1035 my $json = cmdoutput @cmd;
1036 unless ($json =~ s/\d+\d+\d$//) {
1037 failedcmd_report_cmd undef, @cmd;
1038 fail "curl failed to print 3-digit HTTP code";
1041 return undef if $code eq '404' && $ok404;
1042 fail "fetch of $url gave HTTP code $code"
1043 unless $url =~ m#^file://# or $code =~ m/^2/;
1044 return decode_json($json);
1047 sub canonicalise_suite_ftpmasterapi {
1048 my ($proto,$data) = @_;
1049 my $suites = api_query($data, 'suites');
1051 foreach my $entry (@$suites) {
1053 my $v = $entry->{$_};
1054 defined $v && $v eq $isuite;
1055 } qw(codename name);
1056 push @matched, $entry;
1058 fail "unknown suite $isuite" unless @matched;
1061 @matched==1 or die "multiple matches for suite $isuite\n";
1062 $cn = "$matched[0]{codename}";
1063 defined $cn or die "suite $isuite info has no codename\n";
1064 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1066 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1071 sub archive_query_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1075 my $digester = Digest::SHA->new(256);
1076 foreach my $entry (@$info) {
1078 my $vsn = "$entry->{version}";
1079 my ($ok,$msg) = version_check $vsn;
1080 die "bad version: $msg\n" unless $ok;
1081 my $component = "$entry->{component}";
1082 $component =~ m/^$component_re$/ or die "bad component";
1083 my $filename = "$entry->{filename}";
1084 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1085 or die "bad filename";
1086 my $sha256sum = "$entry->{sha256sum}";
1087 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1088 push @rows, [ $vsn, "/pool/$component/$filename",
1089 $digester, $sha256sum ];
1091 die "bad ftpmaster api response: $@\n".Dumper($entry)
1094 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1098 sub file_in_archive_ftpmasterapi {
1099 my ($proto,$data,$filename) = @_;
1100 my $pat = $filename;
1103 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1104 my $info = api_query($data, "file_in_archive/$pat", 1);
1107 #---------- `dummyapicat' archive query method ----------
1109 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1110 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1112 sub file_in_archive_dummycatapi ($$$) {
1113 my ($proto,$data,$filename) = @_;
1114 my $mirror = access_cfg('mirror');
1115 $mirror =~ s#^file://#/# or die "$mirror ?";
1117 my @cmd = (qw(sh -ec), '
1119 find -name "$2" -print0 |
1121 ', qw(x), $mirror, $filename);
1122 debugcmd "-|", @cmd;
1123 open FIA, "-|", @cmd or die $!;
1126 printdebug "| $_\n";
1127 m/^(\w+) (\S+)$/ or die "$_ ?";
1128 push @out, { sha256sum => $1, filename => $2 };
1130 close FIA or die failedcmd @cmd;
1134 #---------- `madison' archive query method ----------
1136 sub archive_query_madison {
1137 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1140 sub madison_get_parse {
1141 my ($proto,$data) = @_;
1142 die unless $proto eq 'madison';
1143 if (!length $data) {
1144 $data= access_cfg('madison-distro','RETURN-UNDEF');
1145 $data //= access_basedistro();
1147 $rmad{$proto,$data,$package} ||= cmdoutput
1148 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1149 my $rmad = $rmad{$proto,$data,$package};
1152 foreach my $l (split /\n/, $rmad) {
1153 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1154 \s*( [^ \t|]+ )\s* \|
1155 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1156 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1157 $1 eq $package or die "$rmad $package ?";
1164 $component = access_cfg('archive-query-default-component');
1166 $5 eq 'source' or die "$rmad ?";
1167 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1169 return sort { -version_compare($a->[0],$b->[0]); } @out;
1172 sub canonicalise_suite_madison {
1173 # madison canonicalises for us
1174 my @r = madison_get_parse(@_);
1176 "unable to canonicalise suite using package $package".
1177 " which does not appear to exist in suite $isuite;".
1178 " --existing-package may help";
1182 sub file_in_archive_madison { return undef; }
1184 #---------- `sshpsql' archive query method ----------
1187 my ($data,$runeinfo,$sql) = @_;
1188 if (!length $data) {
1189 $data= access_someuserhost('sshpsql').':'.
1190 access_cfg('sshpsql-dbname');
1192 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1193 my ($userhost,$dbname) = ($`,$'); #';
1195 my @cmd = (access_cfg_ssh, $userhost,
1196 access_runeinfo("ssh-psql $runeinfo").
1197 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1198 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1200 open P, "-|", @cmd or die $!;
1203 printdebug(">|$_|\n");
1206 $!=0; $?=0; close P or failedcmd @cmd;
1208 my $nrows = pop @rows;
1209 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1210 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1211 @rows = map { [ split /\|/, $_ ] } @rows;
1212 my $ncols = scalar @{ shift @rows };
1213 die if grep { scalar @$_ != $ncols } @rows;
1217 sub sql_injection_check {
1218 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1221 sub archive_query_sshpsql ($$) {
1222 my ($proto,$data) = @_;
1223 sql_injection_check $isuite, $package;
1224 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1225 SELECT source.version, component.name, files.filename, files.sha256sum
1227 JOIN src_associations ON source.id = src_associations.source
1228 JOIN suite ON suite.id = src_associations.suite
1229 JOIN dsc_files ON dsc_files.source = source.id
1230 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1231 JOIN component ON component.id = files_archive_map.component_id
1232 JOIN files ON files.id = dsc_files.file
1233 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1234 AND source.source='$package'
1235 AND files.filename LIKE '%.dsc';
1237 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1238 my $digester = Digest::SHA->new(256);
1240 my ($vsn,$component,$filename,$sha256sum) = @$_;
1241 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1246 sub canonicalise_suite_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite;
1249 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1250 SELECT suite.codename
1251 FROM suite where suite_name='$isuite' or codename='$isuite';
1253 @rows = map { $_->[0] } @rows;
1254 fail "unknown suite $isuite" unless @rows;
1255 die "ambiguous $isuite: @rows ?" if @rows>1;
1259 sub file_in_archive_sshpsql ($$$) { return undef; }
1261 #---------- `dummycat' archive query method ----------
1263 sub canonicalise_suite_dummycat ($$) {
1264 my ($proto,$data) = @_;
1265 my $dpath = "$data/suite.$isuite";
1266 if (!open C, "<", $dpath) {
1267 $!==ENOENT or die "$dpath: $!";
1268 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1272 chomp or die "$dpath: $!";
1274 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1278 sub archive_query_dummycat ($$) {
1279 my ($proto,$data) = @_;
1280 canonicalise_suite();
1281 my $dpath = "$data/package.$csuite.$package";
1282 if (!open C, "<", $dpath) {
1283 $!==ENOENT or die "$dpath: $!";
1284 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1292 printdebug "dummycat query $csuite $package $dpath | $_\n";
1293 my @row = split /\s+/, $_;
1294 @row==2 or die "$dpath: $_ ?";
1297 C->error and die "$dpath: $!";
1299 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1302 sub file_in_archive_dummycat () { return undef; }
1304 #---------- tag format handling ----------
1306 sub access_cfg_tagformats () {
1307 split /\,/, access_cfg('dgit-tag-format');
1310 sub need_tagformat ($$) {
1311 my ($fmt, $why) = @_;
1312 fail "need to use tag format $fmt ($why) but also need".
1313 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1314 " - no way to proceed"
1315 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1316 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1319 sub select_tagformat () {
1321 return if $tagformatfn && !$tagformat_want;
1322 die 'bug' if $tagformatfn && $tagformat_want;
1323 # ... $tagformat_want assigned after previous select_tagformat
1325 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1326 printdebug "select_tagformat supported @supported\n";
1328 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1329 printdebug "select_tagformat specified @$tagformat_want\n";
1331 my ($fmt,$why,$override) = @$tagformat_want;
1333 fail "target distro supports tag formats @supported".
1334 " but have to use $fmt ($why)"
1336 or grep { $_ eq $fmt } @supported;
1338 $tagformat_want = undef;
1340 $tagformatfn = ${*::}{"debiantag_$fmt"};
1342 fail "trying to use unknown tag format \`$fmt' ($why) !"
1343 unless $tagformatfn;
1346 #---------- archive query entrypoints and rest of program ----------
1348 sub canonicalise_suite () {
1349 return if defined $csuite;
1350 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1351 $csuite = archive_query('canonicalise_suite');
1352 if ($isuite ne $csuite) {
1353 progress "canonical suite name for $isuite is $csuite";
1357 sub get_archive_dsc () {
1358 canonicalise_suite();
1359 my @vsns = archive_query('archive_query');
1360 foreach my $vinfo (@vsns) {
1361 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1362 $dscurl = access_cfg('mirror').$subpath;
1363 $dscdata = url_get($dscurl);
1365 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1370 $digester->add($dscdata);
1371 my $got = $digester->hexdigest();
1373 fail "$dscurl has hash $got but".
1374 " archive told us to expect $digest";
1377 my $fmt = getfield $dsc, 'Format';
1378 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1379 "unsupported source format $fmt, sorry";
1381 $dsc_checked = !!$digester;
1382 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1386 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1389 sub check_for_git ();
1390 sub check_for_git () {
1392 my $how = access_cfg('git-check');
1393 if ($how eq 'ssh-cmd') {
1395 (access_cfg_ssh, access_gituserhost(),
1396 access_runeinfo("git-check $package").
1397 " set -e; cd ".access_cfg('git-path').";".
1398 " if test -d $package.git; then echo 1; else echo 0; fi");
1399 my $r= cmdoutput @cmd;
1400 if (defined $r and $r =~ m/^divert (\w+)$/) {
1402 my ($usedistro,) = access_distros();
1403 # NB that if we are pushing, $usedistro will be $distro/push
1404 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1405 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1406 progress "diverting to $divert (using config for $instead_distro)";
1407 return check_for_git();
1409 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1411 } elsif ($how eq 'url') {
1412 my $prefix = access_cfg('git-check-url','git-url');
1413 my $suffix = access_cfg('git-check-suffix','git-suffix',
1414 'RETURN-UNDEF') // '.git';
1415 my $url = "$prefix/$package$suffix";
1416 my @cmd = (@curl, qw(-sS -I), $url);
1417 my $result = cmdoutput @cmd;
1418 $result =~ s/^\S+ 200 .*\n\r?\n//;
1419 # curl -sS -I with https_proxy prints
1420 # HTTP/1.0 200 Connection established
1421 $result =~ m/^\S+ (404|200) /s or
1422 fail "unexpected results from git check query - ".
1423 Dumper($prefix, $result);
1425 if ($code eq '404') {
1427 } elsif ($code eq '200') {
1432 } elsif ($how eq 'true') {
1434 } elsif ($how eq 'false') {
1437 badcfg "unknown git-check \`$how'";
1441 sub create_remote_git_repo () {
1442 my $how = access_cfg('git-create');
1443 if ($how eq 'ssh-cmd') {
1445 (access_cfg_ssh, access_gituserhost(),
1446 access_runeinfo("git-create $package").
1447 "set -e; cd ".access_cfg('git-path').";".
1448 " cp -a _template $package.git");
1449 } elsif ($how eq 'true') {
1452 badcfg "unknown git-create \`$how'";
1456 our ($dsc_hash,$lastpush_mergeinput);
1458 our $ud = '.git/dgit/unpack';
1468 sub mktree_in_ud_here () {
1469 runcmd qw(git init -q);
1470 runcmd qw(git config gc.auto 0);
1471 rmtree('.git/objects');
1472 symlink '../../../../objects','.git/objects' or die $!;
1475 sub git_write_tree () {
1476 my $tree = cmdoutput @git, qw(write-tree);
1477 $tree =~ m/^\w+$/ or die "$tree ?";
1481 sub remove_stray_gits () {
1482 my @gitscmd = qw(find -name .git -prune -print0);
1483 debugcmd "|",@gitscmd;
1484 open GITS, "-|", @gitscmd or die $!;
1489 print STDERR "$us: warning: removing from source package: ",
1490 (messagequote $_), "\n";
1494 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1497 sub mktree_in_ud_from_only_subdir (;$) {
1500 # changes into the subdir
1502 die "expected one subdir but found @dirs ?" unless @dirs==1;
1503 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1507 remove_stray_gits();
1508 mktree_in_ud_here();
1510 my ($format, $fopts) = get_source_format();
1511 if (madformat($format)) {
1516 runcmd @git, qw(add -Af);
1517 my $tree=git_write_tree();
1518 return ($tree,$dir);
1521 our @files_csum_info_fields =
1522 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1523 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1524 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1526 sub dsc_files_info () {
1527 foreach my $csumi (@files_csum_info_fields) {
1528 my ($fname, $module, $method) = @$csumi;
1529 my $field = $dsc->{$fname};
1530 next unless defined $field;
1531 eval "use $module; 1;" or die $@;
1533 foreach (split /\n/, $field) {
1535 m/^(\w+) (\d+) (\S+)$/ or
1536 fail "could not parse .dsc $fname line \`$_'";
1537 my $digester = eval "$module"."->$method;" or die $@;
1542 Digester => $digester,
1547 fail "missing any supported Checksums-* or Files field in ".
1548 $dsc->get_option('name');
1552 map { $_->{Filename} } dsc_files_info();
1555 sub files_compare_inputs (@) {
1560 my $showinputs = sub {
1561 return join "; ", map { $_->get_option('name') } @$inputs;
1564 foreach my $in (@$inputs) {
1566 my $in_name = $in->get_option('name');
1568 printdebug "files_compare_inputs $in_name\n";
1570 foreach my $csumi (@files_csum_info_fields) {
1571 my ($fname) = @$csumi;
1572 printdebug "files_compare_inputs $in_name $fname\n";
1574 my $field = $in->{$fname};
1575 next unless defined $field;
1578 foreach (split /\n/, $field) {
1581 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1582 fail "could not parse $in_name $fname line \`$_'";
1584 printdebug "files_compare_inputs $in_name $fname $f\n";
1588 my $re = \ $record{$f}{$fname};
1590 $fchecked{$f}{$in_name} = 1;
1592 fail "hash or size of $f varies in $fname fields".
1593 " (between: ".$showinputs->().")";
1598 @files = sort @files;
1599 $expected_files //= \@files;
1600 "@$expected_files" eq "@files" or
1601 fail "file list in $in_name varies between hash fields!";
1604 fail "$in_name has no files list field(s)";
1606 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1609 grep { keys %$_ == @$inputs-1 } values %fchecked
1610 or fail "no file appears in all file lists".
1611 " (looked in: ".$showinputs->().")";
1614 sub is_orig_file_in_dsc ($$) {
1615 my ($f, $dsc_files_info) = @_;
1616 return 0 if @$dsc_files_info <= 1;
1617 # One file means no origs, and the filename doesn't have a "what
1618 # part of dsc" component. (Consider versions ending `.orig'.)
1619 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1623 sub is_orig_file_of_vsn ($$) {
1624 my ($f, $upstreamvsn) = @_;
1625 my $base = srcfn $upstreamvsn, '';
1626 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1630 sub changes_update_origs_from_dsc ($$$$) {
1631 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1633 printdebug "checking origs needed ($upstreamvsn)...\n";
1634 $_ = getfield $changes, 'Files';
1635 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1636 fail "cannot find section/priority from .changes Files field";
1637 my $placementinfo = $1;
1639 printdebug "checking origs needed placement '$placementinfo'...\n";
1640 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1641 $l =~ m/\S+$/ or next;
1643 printdebug "origs $file | $l\n";
1644 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1645 printdebug "origs $file is_orig\n";
1646 my $have = archive_query('file_in_archive', $file);
1647 if (!defined $have) {
1649 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1655 printdebug "origs $file \$#\$have=$#$have\n";
1656 foreach my $h (@$have) {
1659 foreach my $csumi (@files_csum_info_fields) {
1660 my ($fname, $module, $method, $archivefield) = @$csumi;
1661 next unless defined $h->{$archivefield};
1662 $_ = $dsc->{$fname};
1663 next unless defined;
1664 m/^(\w+) .* \Q$file\E$/m or
1665 fail ".dsc $fname missing entry for $file";
1666 if ($h->{$archivefield} eq $1) {
1670 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1673 die "$file ".Dumper($h)." ?!" if $same && @differ;
1676 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1679 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1680 if (@found_differ && !$found_same) {
1682 "archive contains $file with different checksum",
1685 # Now we edit the changes file to add or remove it
1686 foreach my $csumi (@files_csum_info_fields) {
1687 my ($fname, $module, $method, $archivefield) = @$csumi;
1688 next unless defined $changes->{$fname};
1690 # in archive, delete from .changes if it's there
1691 $changed{$file} = "removed" if
1692 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1693 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1694 # not in archive, but it's here in the .changes
1696 my $dsc_data = getfield $dsc, $fname;
1697 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1699 $extra =~ s/ \d+ /$&$placementinfo /
1700 or die "$fname $extra >$dsc_data< ?"
1701 if $fname eq 'Files';
1702 $changes->{$fname} .= "\n". $extra;
1703 $changed{$file} = "added";
1708 foreach my $file (keys %changed) {
1710 "edited .changes for archive .orig contents: %s %s",
1711 $changed{$file}, $file;
1713 my $chtmp = "$changesfile.tmp";
1714 $changes->save($chtmp);
1716 rename $chtmp,$changesfile or die "$changesfile $!";
1718 progress "[new .changes left in $changesfile]";
1721 progress "$changesfile already has appropriate .orig(s) (if any)";
1725 sub make_commit ($) {
1727 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1730 sub make_commit_text ($) {
1733 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1735 print Dumper($text) if $debuglevel > 1;
1736 my $child = open2($out, $in, @cmd) or die $!;
1739 print $in $text or die $!;
1740 close $in or die $!;
1742 $h =~ m/^\w+$/ or die;
1744 printdebug "=> $h\n";
1747 waitpid $child, 0 == $child or die "$child $!";
1748 $? and failedcmd @cmd;
1752 sub clogp_authline ($) {
1754 my $author = getfield $clogp, 'Maintainer';
1755 $author =~ s#,.*##ms;
1756 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1757 my $authline = "$author $date";
1758 $authline =~ m/$git_authline_re/o or
1759 fail "unexpected commit author line format \`$authline'".
1760 " (was generated from changelog Maintainer field)";
1761 return ($1,$2,$3) if wantarray;
1765 sub vendor_patches_distro ($$) {
1766 my ($checkdistro, $what) = @_;
1767 return unless defined $checkdistro;
1769 my $series = "debian/patches/\L$checkdistro\E.series";
1770 printdebug "checking for vendor-specific $series ($what)\n";
1772 if (!open SERIES, "<", $series) {
1773 die "$series $!" unless $!==ENOENT;
1782 Unfortunately, this source package uses a feature of dpkg-source where
1783 the same source package unpacks to different source code on different
1784 distros. dgit cannot safely operate on such packages on affected
1785 distros, because the meaning of source packages is not stable.
1787 Please ask the distro/maintainer to remove the distro-specific series
1788 files and use a different technique (if necessary, uploading actually
1789 different packages, if different distros are supposed to have
1793 fail "Found active distro-specific series file for".
1794 " $checkdistro ($what): $series, cannot continue";
1796 die "$series $!" if SERIES->error;
1800 sub check_for_vendor_patches () {
1801 # This dpkg-source feature doesn't seem to be documented anywhere!
1802 # But it can be found in the changelog (reformatted):
1804 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1805 # Author: Raphael Hertzog <hertzog@debian.org>
1806 # Date: Sun Oct 3 09:36:48 2010 +0200
1808 # dpkg-source: correctly create .pc/.quilt_series with alternate
1811 # If you have debian/patches/ubuntu.series and you were
1812 # unpacking the source package on ubuntu, quilt was still
1813 # directed to debian/patches/series instead of
1814 # debian/patches/ubuntu.series.
1816 # debian/changelog | 3 +++
1817 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1818 # 2 files changed, 6 insertions(+), 1 deletion(-)
1821 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1822 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1823 "Dpkg::Vendor \`current vendor'");
1824 vendor_patches_distro(access_basedistro(),
1825 "distro being accessed");
1828 sub generate_commits_from_dsc () {
1829 # See big comment in fetch_from_archive, below.
1830 # See also README.dsc-import.
1834 my @dfi = dsc_files_info();
1835 foreach my $fi (@dfi) {
1836 my $f = $fi->{Filename};
1837 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1839 printdebug "considering linking $f: ";
1841 link_ltarget "../../../../$f", $f
1842 or ((printdebug "($!) "), 0)
1846 printdebug "linked.\n";
1848 complete_file_from_dsc('.', $fi)
1851 if (is_orig_file_in_dsc($f, \@dfi)) {
1852 link $f, "../../../../$f"
1858 # We unpack and record the orig tarballs first, so that we only
1859 # need disk space for one private copy of the unpacked source.
1860 # But we can't make them into commits until we have the metadata
1861 # from the debian/changelog, so we record the tree objects now and
1862 # make them into commits later.
1864 my $upstreamv = upstreamversion $dsc->{version};
1865 my $orig_f_base = srcfn $upstreamv, '';
1867 foreach my $fi (@dfi) {
1868 # We actually import, and record as a commit, every tarball
1869 # (unless there is only one file, in which case there seems
1872 my $f = $fi->{Filename};
1873 printdebug "import considering $f ";
1874 (printdebug "only one dfi\n"), next if @dfi == 1;
1875 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1876 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1880 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1882 printdebug "Y ", (join ' ', map { $_//"(none)" }
1883 $compr_ext, $orig_f_part
1886 my $input = new IO::File $f, '<' or die "$f $!";
1890 if (defined $compr_ext) {
1892 Dpkg::Compression::compression_guess_from_filename $f;
1893 fail "Dpkg::Compression cannot handle file $f in source package"
1894 if defined $compr_ext && !defined $cname;
1896 new Dpkg::Compression::Process compression => $cname;
1897 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1898 my $compr_fh = new IO::Handle;
1899 my $compr_pid = open $compr_fh, "-|" // die $!;
1901 open STDIN, "<&", $input or die $!;
1903 die "dgit (child): exec $compr_cmd[0]: $!\n";
1908 rmtree "../unpack-tar";
1909 mkdir "../unpack-tar" or die $!;
1910 my @tarcmd = qw(tar -x -f -
1911 --no-same-owner --no-same-permissions
1912 --no-acls --no-xattrs --no-selinux);
1913 my $tar_pid = fork // die $!;
1915 chdir "../unpack-tar" or die $!;
1916 open STDIN, "<&", $input or die $!;
1918 die "dgit (child): exec $tarcmd[0]: $!";
1920 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1921 !$? or failedcmd @tarcmd;
1924 (@compr_cmd ? failedcmd @compr_cmd
1926 # finally, we have the results in "tarball", but maybe
1927 # with the wrong permissions
1929 runcmd qw(chmod -R +rwX ../unpack-tar);
1930 changedir "../unpack-tar";
1931 my ($tree) = mktree_in_ud_from_only_subdir(1);
1932 changedir "../../unpack";
1933 rmtree "../unpack-tar";
1935 my $ent = [ $f, $tree ];
1937 Orig => !!$orig_f_part,
1938 Sort => (!$orig_f_part ? 2 :
1939 $orig_f_part =~ m/-/g ? 1 :
1947 # put any without "_" first (spec is not clear whether files
1948 # are always in the usual order). Tarballs without "_" are
1949 # the main orig or the debian tarball.
1950 $a->{Sort} <=> $b->{Sort} or
1954 my $any_orig = grep { $_->{Orig} } @tartrees;
1956 my $dscfn = "$package.dsc";
1958 my $treeimporthow = 'package';
1960 open D, ">", $dscfn or die "$dscfn: $!";
1961 print D $dscdata or die "$dscfn: $!";
1962 close D or die "$dscfn: $!";
1963 my @cmd = qw(dpkg-source);
1964 push @cmd, '--no-check' if $dsc_checked;
1965 if (madformat $dsc->{format}) {
1966 push @cmd, '--skip-patches';
1967 $treeimporthow = 'unpatched';
1969 push @cmd, qw(-x --), $dscfn;
1972 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1973 if (madformat $dsc->{format}) {
1974 check_for_vendor_patches();
1978 if (madformat $dsc->{format}) {
1979 my @pcmd = qw(dpkg-source --before-build .);
1980 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1982 runcmd @git, qw(add -Af);
1983 $dappliedtree = git_write_tree();
1986 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1987 debugcmd "|",@clogcmd;
1988 open CLOGS, "-|", @clogcmd or die $!;
1993 printdebug "import clog search...\n";
1996 my $stanzatext = do { local $/=""; <CLOGS>; };
1997 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1998 last if !defined $stanzatext;
2000 my $desc = "package changelog, entry no.$.";
2001 open my $stanzafh, "<", \$stanzatext or die;
2002 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2003 $clogp //= $thisstanza;
2005 printdebug "import clog $thisstanza->{version} $desc...\n";
2007 last if !$any_orig; # we don't need $r1clogp
2009 # We look for the first (most recent) changelog entry whose
2010 # version number is lower than the upstream version of this
2011 # package. Then the last (least recent) previous changelog
2012 # entry is treated as the one which introduced this upstream
2013 # version and used for the synthetic commits for the upstream
2016 # One might think that a more sophisticated algorithm would be
2017 # necessary. But: we do not want to scan the whole changelog
2018 # file. Stopping when we see an earlier version, which
2019 # necessarily then is an earlier upstream version, is the only
2020 # realistic way to do that. Then, either the earliest
2021 # changelog entry we have seen so far is indeed the earliest
2022 # upload of this upstream version; or there are only changelog
2023 # entries relating to later upstream versions (which is not
2024 # possible unless the changelog and .dsc disagree about the
2025 # version). Then it remains to choose between the physically
2026 # last entry in the file, and the one with the lowest version
2027 # number. If these are not the same, we guess that the
2028 # versions were created in a non-monotic order rather than
2029 # that the changelog entries have been misordered.
2031 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2033 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2034 $r1clogp = $thisstanza;
2036 printdebug "import clog $r1clogp->{version} becomes r1\n";
2038 die $! if CLOGS->error;
2039 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2041 $clogp or fail "package changelog has no entries!";
2043 my $authline = clogp_authline $clogp;
2044 my $changes = getfield $clogp, 'Changes';
2045 my $cversion = getfield $clogp, 'Version';
2048 $r1clogp //= $clogp; # maybe there's only one entry;
2049 my $r1authline = clogp_authline $r1clogp;
2050 # Strictly, r1authline might now be wrong if it's going to be
2051 # unused because !$any_orig. Whatever.
2053 printdebug "import tartrees authline $authline\n";
2054 printdebug "import tartrees r1authline $r1authline\n";
2056 foreach my $tt (@tartrees) {
2057 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2059 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2062 committer $r1authline
2066 [dgit import orig $tt->{F}]
2074 [dgit import tarball $package $cversion $tt->{F}]
2079 printdebug "import main commit\n";
2081 open C, ">../commit.tmp" or die $!;
2082 print C <<END or die $!;
2085 print C <<END or die $! foreach @tartrees;
2088 print C <<END or die $!;
2094 [dgit import $treeimporthow $package $cversion]
2098 my $rawimport_hash = make_commit qw(../commit.tmp);
2100 if (madformat $dsc->{format}) {
2101 printdebug "import apply patches...\n";
2103 # regularise the state of the working tree so that
2104 # the checkout of $rawimport_hash works nicely.
2105 my $dappliedcommit = make_commit_text(<<END);
2112 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2114 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2116 # We need the answers to be reproducible
2117 my @authline = clogp_authline($clogp);
2118 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2119 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2120 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2121 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2122 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2123 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2125 my $path = $ENV{PATH} or die;
2127 foreach my $use_absurd (qw(0 1)) {
2128 local $ENV{PATH} = $path;
2131 progress "warning: $@";
2132 $path = "$absurdity:$path";
2133 progress "$us: trying slow absurd-git-apply...";
2134 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2139 die "forbid absurd git-apply\n" if $use_absurd
2140 && forceing [qw(import-gitapply-no-absurd)];
2141 die "only absurd git-apply!\n" if !$use_absurd
2142 && forceing [qw(import-gitapply-absurd)];
2144 local $ENV{PATH} = $path if $use_absurd;
2146 my @showcmd = (gbp_pq, qw(import));
2147 my @realcmd = shell_cmd
2148 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2149 debugcmd "+",@realcmd;
2150 if (system @realcmd) {
2151 die +(shellquote @showcmd).
2153 failedcmd_waitstatus()."\n";
2156 my $gapplied = git_rev_parse('HEAD');
2157 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2158 $gappliedtree eq $dappliedtree or
2160 gbp-pq import and dpkg-source disagree!
2161 gbp-pq import gave commit $gapplied
2162 gbp-pq import gave tree $gappliedtree
2163 dpkg-source --before-build gave tree $dappliedtree
2165 $rawimport_hash = $gapplied;
2170 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2175 progress "synthesised git commit from .dsc $cversion";
2177 my $rawimport_mergeinput = {
2178 Commit => $rawimport_hash,
2179 Info => "Import of source package",
2181 my @output = ($rawimport_mergeinput);
2183 if ($lastpush_mergeinput) {
2184 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2185 my $oversion = getfield $oldclogp, 'Version';
2187 version_compare($oversion, $cversion);
2189 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2190 { Message => <<END, ReverseParents => 1 });
2191 Record $package ($cversion) in archive suite $csuite
2193 } elsif ($vcmp > 0) {
2194 print STDERR <<END or die $!;
2196 Version actually in archive: $cversion (older)
2197 Last version pushed with dgit: $oversion (newer or same)
2200 @output = $lastpush_mergeinput;
2202 # Same version. Use what's in the server git branch,
2203 # discarding our own import. (This could happen if the
2204 # server automatically imports all packages into git.)
2205 @output = $lastpush_mergeinput;
2208 changedir '../../../..';
2213 sub complete_file_from_dsc ($$) {
2214 our ($dstdir, $fi) = @_;
2215 # Ensures that we have, in $dir, the file $fi, with the correct
2216 # contents. (Downloading it from alongside $dscurl if necessary.)
2218 my $f = $fi->{Filename};
2219 my $tf = "$dstdir/$f";
2222 if (stat_exists $tf) {
2223 progress "using existing $f";
2225 printdebug "$tf does not exist, need to fetch\n";
2227 $furl =~ s{/[^/]+$}{};
2229 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2230 die "$f ?" if $f =~ m#/#;
2231 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2232 return 0 if !act_local();
2236 open F, "<", "$tf" or die "$tf: $!";
2237 $fi->{Digester}->reset();
2238 $fi->{Digester}->addfile(*F);
2239 F->error and die $!;
2240 my $got = $fi->{Digester}->hexdigest();
2241 $got eq $fi->{Hash} or
2242 fail "file $f has hash $got but .dsc".
2243 " demands hash $fi->{Hash} ".
2244 ($downloaded ? "(got wrong file from archive!)"
2245 : "(perhaps you should delete this file?)");
2250 sub ensure_we_have_orig () {
2251 my @dfi = dsc_files_info();
2252 foreach my $fi (@dfi) {
2253 my $f = $fi->{Filename};
2254 next unless is_orig_file_in_dsc($f, \@dfi);
2255 complete_file_from_dsc('..', $fi)
2260 sub git_fetch_us () {
2261 # Want to fetch only what we are going to use, unless
2262 # deliberately-not-ff, in which case we must fetch everything.
2264 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2266 (quiltmode_splitbrain
2267 ? (map { $_->('*',access_basedistro) }
2268 \&debiantag_new, \&debiantag_maintview)
2269 : debiantags('*',access_basedistro));
2270 push @specs, server_branch($csuite);
2271 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2273 # This is rather miserable:
2274 # When git fetch --prune is passed a fetchspec ending with a *,
2275 # it does a plausible thing. If there is no * then:
2276 # - it matches subpaths too, even if the supplied refspec
2277 # starts refs, and behaves completely madly if the source
2278 # has refs/refs/something. (See, for example, Debian #NNNN.)
2279 # - if there is no matching remote ref, it bombs out the whole
2281 # We want to fetch a fixed ref, and we don't know in advance
2282 # if it exists, so this is not suitable.
2284 # Our workaround is to use git ls-remote. git ls-remote has its
2285 # own qairks. Notably, it has the absurd multi-tail-matching
2286 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2287 # refs/refs/foo etc.
2289 # Also, we want an idempotent snapshot, but we have to make two
2290 # calls to the remote: one to git ls-remote and to git fetch. The
2291 # solution is use git ls-remote to obtain a target state, and
2292 # git fetch to try to generate it. If we don't manage to generate
2293 # the target state, we try again.
2295 printdebug "git_fetch_us specs @specs\n";
2297 my $specre = join '|', map {
2303 printdebug "git_fetch_us specre=$specre\n";
2304 my $wanted_rref = sub {
2306 return m/^(?:$specre)$/o;
2309 my $fetch_iteration = 0;
2312 printdebug "git_fetch_us iteration $fetch_iteration\n";
2313 if (++$fetch_iteration > 10) {
2314 fail "too many iterations trying to get sane fetch!";
2317 my @look = map { "refs/$_" } @specs;
2318 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2322 open GITLS, "-|", @lcmd or die $!;
2324 printdebug "=> ", $_;
2325 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2326 my ($objid,$rrefname) = ($1,$2);
2327 if (!$wanted_rref->($rrefname)) {
2329 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2333 $wantr{$rrefname} = $objid;
2336 close GITLS or failedcmd @lcmd;
2338 # OK, now %want is exactly what we want for refs in @specs
2340 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2341 "+refs/$_:".lrfetchrefs."/$_";
2344 printdebug "git_fetch_us fspecs @fspecs\n";
2346 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2347 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2350 %lrfetchrefs_f = ();
2353 git_for_each_ref(lrfetchrefs, sub {
2354 my ($objid,$objtype,$lrefname,$reftail) = @_;
2355 $lrfetchrefs_f{$lrefname} = $objid;
2356 $objgot{$objid} = 1;
2359 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2360 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2361 if (!exists $wantr{$rrefname}) {
2362 if ($wanted_rref->($rrefname)) {
2364 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2368 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2371 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2372 delete $lrfetchrefs_f{$lrefname};
2376 foreach my $rrefname (sort keys %wantr) {
2377 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2378 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2379 my $want = $wantr{$rrefname};
2380 next if $got eq $want;
2381 if (!defined $objgot{$want}) {
2383 warning: git ls-remote suggests we want $lrefname
2384 warning: and it should refer to $want
2385 warning: but git fetch didn't fetch that object to any relevant ref.
2386 warning: This may be due to a race with someone updating the server.
2387 warning: Will try again...
2389 next FETCH_ITERATION;
2392 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2394 runcmd_ordryrun_local @git, qw(update-ref -m),
2395 "dgit fetch git fetch fixup", $lrefname, $want;
2396 $lrfetchrefs_f{$lrefname} = $want;
2400 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2401 Dumper(\%lrfetchrefs_f);
2404 my @tagpats = debiantags('*',access_basedistro);
2406 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2408 printdebug "currently $fullrefname=$objid\n";
2409 $here{$fullrefname} = $objid;
2411 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2412 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2413 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2414 printdebug "offered $lref=$objid\n";
2415 if (!defined $here{$lref}) {
2416 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2417 runcmd_ordryrun_local @upd;
2418 lrfetchref_used $fullrefname;
2419 } elsif ($here{$lref} eq $objid) {
2420 lrfetchref_used $fullrefname;
2423 "Not updateting $lref from $here{$lref} to $objid.\n";
2428 sub mergeinfo_getclogp ($) {
2429 # Ensures thit $mi->{Clogp} exists and returns it
2431 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2434 sub mergeinfo_version ($) {
2435 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2438 sub fetch_from_archive () {
2439 ensure_setup_existing_tree();
2441 # Ensures that lrref() is what is actually in the archive, one way
2442 # or another, according to us - ie this client's
2443 # appropritaely-updated archive view. Also returns the commit id.
2444 # If there is nothing in the archive, leaves lrref alone and
2445 # returns undef. git_fetch_us must have already been called.
2449 foreach my $field (@ourdscfield) {
2450 $dsc_hash = $dsc->{$field};
2451 last if defined $dsc_hash;
2453 if (defined $dsc_hash) {
2454 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2456 progress "last upload to archive specified git hash";
2458 progress "last upload to archive has NO git hash";
2461 progress "no version available from the archive";
2464 # If the archive's .dsc has a Dgit field, there are three
2465 # relevant git commitids we need to choose between and/or merge
2467 # 1. $dsc_hash: the Dgit field from the archive
2468 # 2. $lastpush_hash: the suite branch on the dgit git server
2469 # 3. $lastfetch_hash: our local tracking brach for the suite
2471 # These may all be distinct and need not be in any fast forward
2474 # If the dsc was pushed to this suite, then the server suite
2475 # branch will have been updated; but it might have been pushed to
2476 # a different suite and copied by the archive. Conversely a more
2477 # recent version may have been pushed with dgit but not appeared
2478 # in the archive (yet).
2480 # $lastfetch_hash may be awkward because archive imports
2481 # (particularly, imports of Dgit-less .dscs) are performed only as
2482 # needed on individual clients, so different clients may perform a
2483 # different subset of them - and these imports are only made
2484 # public during push. So $lastfetch_hash may represent a set of
2485 # imports different to a subsequent upload by a different dgit
2488 # Our approach is as follows:
2490 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2491 # descendant of $dsc_hash, then it was pushed by a dgit user who
2492 # had based their work on $dsc_hash, so we should prefer it.
2493 # Otherwise, $dsc_hash was installed into this suite in the
2494 # archive other than by a dgit push, and (necessarily) after the
2495 # last dgit push into that suite (since a dgit push would have
2496 # been descended from the dgit server git branch); thus, in that
2497 # case, we prefer the archive's version (and produce a
2498 # pseudo-merge to overwrite the dgit server git branch).
2500 # (If there is no Dgit field in the archive's .dsc then
2501 # generate_commit_from_dsc uses the version numbers to decide
2502 # whether the suite branch or the archive is newer. If the suite
2503 # branch is newer it ignores the archive's .dsc; otherwise it
2504 # generates an import of the .dsc, and produces a pseudo-merge to
2505 # overwrite the suite branch with the archive contents.)
2507 # The outcome of that part of the algorithm is the `public view',
2508 # and is same for all dgit clients: it does not depend on any
2509 # unpublished history in the local tracking branch.
2511 # As between the public view and the local tracking branch: The
2512 # local tracking branch is only updated by dgit fetch, and
2513 # whenever dgit fetch runs it includes the public view in the
2514 # local tracking branch. Therefore if the public view is not
2515 # descended from the local tracking branch, the local tracking
2516 # branch must contain history which was imported from the archive
2517 # but never pushed; and, its tip is now out of date. So, we make
2518 # a pseudo-merge to overwrite the old imports and stitch the old
2521 # Finally: we do not necessarily reify the public view (as
2522 # described above). This is so that we do not end up stacking two
2523 # pseudo-merges. So what we actually do is figure out the inputs
2524 # to any public view pseudo-merge and put them in @mergeinputs.
2527 # $mergeinputs[]{Commit}
2528 # $mergeinputs[]{Info}
2529 # $mergeinputs[0] is the one whose tree we use
2530 # @mergeinputs is in the order we use in the actual commit)
2533 # $mergeinputs[]{Message} is a commit message to use
2534 # $mergeinputs[]{ReverseParents} if def specifies that parent
2535 # list should be in opposite order
2536 # Such an entry has no Commit or Info. It applies only when found
2537 # in the last entry. (This ugliness is to support making
2538 # identical imports to previous dgit versions.)
2540 my $lastpush_hash = git_get_ref(lrfetchref());
2541 printdebug "previous reference hash=$lastpush_hash\n";
2542 $lastpush_mergeinput = $lastpush_hash && {
2543 Commit => $lastpush_hash,
2544 Info => "dgit suite branch on dgit git server",
2547 my $lastfetch_hash = git_get_ref(lrref());
2548 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2549 my $lastfetch_mergeinput = $lastfetch_hash && {
2550 Commit => $lastfetch_hash,
2551 Info => "dgit client's archive history view",
2554 my $dsc_mergeinput = $dsc_hash && {
2555 Commit => $dsc_hash,
2556 Info => "Dgit field in .dsc from archive",
2560 my $del_lrfetchrefs = sub {
2563 printdebug "del_lrfetchrefs...\n";
2564 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2565 my $objid = $lrfetchrefs_d{$fullrefname};
2566 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2568 $gur ||= new IO::Handle;
2569 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2571 printf $gur "delete %s %s\n", $fullrefname, $objid;
2574 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2578 if (defined $dsc_hash) {
2579 ensure_we_have_orig();
2580 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2581 @mergeinputs = $dsc_mergeinput
2582 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2583 print STDERR <<END or die $!;
2585 Git commit in archive is behind the last version allegedly pushed/uploaded.
2586 Commit referred to by archive: $dsc_hash
2587 Last version pushed with dgit: $lastpush_hash
2590 @mergeinputs = ($lastpush_mergeinput);
2592 # Archive has .dsc which is not a descendant of the last dgit
2593 # push. This can happen if the archive moves .dscs about.
2594 # Just follow its lead.
2595 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2596 progress "archive .dsc names newer git commit";
2597 @mergeinputs = ($dsc_mergeinput);
2599 progress "archive .dsc names other git commit, fixing up";
2600 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2604 @mergeinputs = generate_commits_from_dsc();
2605 # We have just done an import. Now, our import algorithm might
2606 # have been improved. But even so we do not want to generate
2607 # a new different import of the same package. So if the
2608 # version numbers are the same, just use our existing version.
2609 # If the version numbers are different, the archive has changed
2610 # (perhaps, rewound).
2611 if ($lastfetch_mergeinput &&
2612 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2613 (mergeinfo_version $mergeinputs[0]) )) {
2614 @mergeinputs = ($lastfetch_mergeinput);
2616 } elsif ($lastpush_hash) {
2617 # only in git, not in the archive yet
2618 @mergeinputs = ($lastpush_mergeinput);
2619 print STDERR <<END or die $!;
2621 Package not found in the archive, but has allegedly been pushed using dgit.
2625 printdebug "nothing found!\n";
2626 if (defined $skew_warning_vsn) {
2627 print STDERR <<END or die $!;
2629 Warning: relevant archive skew detected.
2630 Archive allegedly contains $skew_warning_vsn
2631 But we were not able to obtain any version from the archive or git.
2635 unshift @end, $del_lrfetchrefs;
2639 if ($lastfetch_hash &&
2641 my $h = $_->{Commit};
2642 $h and is_fast_fwd($lastfetch_hash, $h);
2643 # If true, one of the existing parents of this commit
2644 # is a descendant of the $lastfetch_hash, so we'll
2645 # be ff from that automatically.
2649 push @mergeinputs, $lastfetch_mergeinput;
2652 printdebug "fetch mergeinfos:\n";
2653 foreach my $mi (@mergeinputs) {
2655 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2657 printdebug sprintf " ReverseParents=%d Message=%s",
2658 $mi->{ReverseParents}, $mi->{Message};
2662 my $compat_info= pop @mergeinputs
2663 if $mergeinputs[$#mergeinputs]{Message};
2665 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2668 if (@mergeinputs > 1) {
2670 my $tree_commit = $mergeinputs[0]{Commit};
2672 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2673 $tree =~ m/\n\n/; $tree = $`;
2674 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2677 # We use the changelog author of the package in question the
2678 # author of this pseudo-merge. This is (roughly) correct if
2679 # this commit is simply representing aa non-dgit upload.
2680 # (Roughly because it does not record sponsorship - but we
2681 # don't have sponsorship info because that's in the .changes,
2682 # which isn't in the archivw.)
2684 # But, it might be that we are representing archive history
2685 # updates (including in-archive copies). These are not really
2686 # the responsibility of the person who created the .dsc, but
2687 # there is no-one whose name we should better use. (The
2688 # author of the .dsc-named commit is clearly worse.)
2690 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2691 my $author = clogp_authline $useclogp;
2692 my $cversion = getfield $useclogp, 'Version';
2694 my $mcf = ".git/dgit/mergecommit";
2695 open MC, ">", $mcf or die "$mcf $!";
2696 print MC <<END or die $!;
2700 my @parents = grep { $_->{Commit} } @mergeinputs;
2701 @parents = reverse @parents if $compat_info->{ReverseParents};
2702 print MC <<END or die $! foreach @parents;
2706 print MC <<END or die $!;
2712 if (defined $compat_info->{Message}) {
2713 print MC $compat_info->{Message} or die $!;
2715 print MC <<END or die $!;
2716 Record $package ($cversion) in archive suite $csuite
2720 my $message_add_info = sub {
2722 my $mversion = mergeinfo_version $mi;
2723 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2727 $message_add_info->($mergeinputs[0]);
2728 print MC <<END or die $!;
2729 should be treated as descended from
2731 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2735 $hash = make_commit $mcf;
2737 $hash = $mergeinputs[0]{Commit};
2739 printdebug "fetch hash=$hash\n";
2742 my ($lasth, $what) = @_;
2743 return unless $lasth;
2744 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2747 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2749 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2751 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2752 'DGIT_ARCHIVE', $hash;
2753 cmdoutput @git, qw(log -n2), $hash;
2754 # ... gives git a chance to complain if our commit is malformed
2756 if (defined $skew_warning_vsn) {
2758 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2759 my $gotclogp = commit_getclogp($hash);
2760 my $got_vsn = getfield $gotclogp, 'Version';
2761 printdebug "SKEW CHECK GOT $got_vsn\n";
2762 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2763 print STDERR <<END or die $!;
2765 Warning: archive skew detected. Using the available version:
2766 Archive allegedly contains $skew_warning_vsn
2767 We were able to obtain only $got_vsn
2773 if ($lastfetch_hash ne $hash) {
2774 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2778 dryrun_report @upd_cmd;
2782 lrfetchref_used lrfetchref();
2784 unshift @end, $del_lrfetchrefs;
2788 sub set_local_git_config ($$) {
2790 runcmd @git, qw(config), $k, $v;
2793 sub setup_mergechangelogs (;$) {
2795 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2797 my $driver = 'dpkg-mergechangelogs';
2798 my $cb = "merge.$driver";
2799 my $attrs = '.git/info/attributes';
2800 ensuredir '.git/info';
2802 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2803 if (!open ATTRS, "<", $attrs) {
2804 $!==ENOENT or die "$attrs: $!";
2808 next if m{^debian/changelog\s};
2809 print NATTRS $_, "\n" or die $!;
2811 ATTRS->error and die $!;
2814 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2817 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2818 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2820 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2823 sub setup_useremail (;$) {
2825 return unless $always || access_cfg_bool(1, 'setup-useremail');
2828 my ($k, $envvar) = @_;
2829 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2830 return unless defined $v;
2831 set_local_git_config "user.$k", $v;
2834 $setup->('email', 'DEBEMAIL');
2835 $setup->('name', 'DEBFULLNAME');
2838 sub ensure_setup_existing_tree () {
2839 my $k = "remote.$remotename.skipdefaultupdate";
2840 my $c = git_get_config $k;
2841 return if defined $c;
2842 set_local_git_config $k, 'true';
2845 sub setup_new_tree () {
2846 setup_mergechangelogs();
2852 canonicalise_suite();
2853 badusage "dry run makes no sense with clone" unless act_local();
2854 my $hasgit = check_for_git();
2855 mkdir $dstdir or fail "create \`$dstdir': $!";
2857 runcmd @git, qw(init -q);
2858 my $giturl = access_giturl(1);
2859 if (defined $giturl) {
2860 open H, "> .git/HEAD" or die $!;
2861 print H "ref: ".lref()."\n" or die $!;
2863 runcmd @git, qw(remote add), 'origin', $giturl;
2866 progress "fetching existing git history";
2868 runcmd_ordryrun_local @git, qw(fetch origin);
2870 progress "starting new git history";
2872 fetch_from_archive() or no_such_package;
2873 my $vcsgiturl = $dsc->{'Vcs-Git'};
2874 if (length $vcsgiturl) {
2875 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2876 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2879 runcmd @git, qw(reset --hard), lrref();
2880 runcmd qw(bash -ec), <<'END';
2882 git ls-tree -r --name-only -z HEAD | \
2883 xargs -0r touch -r . --
2885 printdone "ready for work in $dstdir";
2889 if (check_for_git()) {
2892 fetch_from_archive() or no_such_package();
2893 printdone "fetched into ".lrref();
2898 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2900 printdone "fetched to ".lrref()." and merged into HEAD";
2903 sub check_not_dirty () {
2904 foreach my $f (qw(local-options local-patch-header)) {
2905 if (stat_exists "debian/source/$f") {
2906 fail "git tree contains debian/source/$f";
2910 return if $ignoredirty;
2912 my @cmd = (@git, qw(diff --quiet HEAD));
2914 $!=0; $?=-1; system @cmd;
2917 fail "working tree is dirty (does not match HEAD)";
2923 sub commit_admin ($) {
2926 runcmd_ordryrun_local @git, qw(commit -m), $m;
2929 sub commit_quilty_patch () {
2930 my $output = cmdoutput @git, qw(status --porcelain);
2932 foreach my $l (split /\n/, $output) {
2933 next unless $l =~ m/\S/;
2934 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2938 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2940 progress "nothing quilty to commit, ok.";
2943 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2944 runcmd_ordryrun_local @git, qw(add -f), @adds;
2946 Commit Debian 3.0 (quilt) metadata
2948 [dgit ($our_version) quilt-fixup]
2952 sub get_source_format () {
2954 if (open F, "debian/source/options") {
2958 s/\s+$//; # ignore missing final newline
2960 my ($k, $v) = ($`, $'); #');
2961 $v =~ s/^"(.*)"$/$1/;
2967 F->error and die $!;
2970 die $! unless $!==&ENOENT;
2973 if (!open F, "debian/source/format") {
2974 die $! unless $!==&ENOENT;
2978 F->error and die $!;
2980 return ($_, \%options);
2983 sub madformat_wantfixup ($) {
2985 return 0 unless $format eq '3.0 (quilt)';
2986 our $quilt_mode_warned;
2987 if ($quilt_mode eq 'nocheck') {
2988 progress "Not doing any fixup of \`$format' due to".
2989 " ----no-quilt-fixup or --quilt=nocheck"
2990 unless $quilt_mode_warned++;
2993 progress "Format \`$format', need to check/update patch stack"
2994 unless $quilt_mode_warned++;
2998 sub maybe_split_brain_save ($$$) {
2999 my ($headref, $dgitview, $msg) = @_;
3000 # => message fragment "$saved" describing disposition of $dgitview
3001 return "commit id $dgitview" unless defined $split_brain_save;
3002 my @cmd = (shell_cmd "cd ../../../..",
3003 @git, qw(update-ref -m),
3004 "dgit --dgit-view-save $msg HEAD=$headref",
3005 $split_brain_save, $dgitview);
3007 return "and left in $split_brain_save";
3010 # An "infopair" is a tuple [ $thing, $what ]
3011 # (often $thing is a commit hash; $what is a description)
3013 sub infopair_cond_equal ($$) {
3015 $x->[0] eq $y->[0] or fail <<END;
3016 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3020 sub infopair_lrf_tag_lookup ($$) {
3021 my ($tagnames, $what) = @_;
3022 # $tagname may be an array ref
3023 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3024 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3025 foreach my $tagname (@tagnames) {
3026 my $lrefname = lrfetchrefs."/tags/$tagname";
3027 my $tagobj = $lrfetchrefs_f{$lrefname};
3028 next unless defined $tagobj;
3029 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3030 return [ git_rev_parse($tagobj), $what ];
3032 fail @tagnames==1 ? <<END : <<END;
3033 Wanted tag $what (@tagnames) on dgit server, but not found
3035 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3039 sub infopair_cond_ff ($$) {
3040 my ($anc,$desc) = @_;
3041 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3042 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3046 sub pseudomerge_version_check ($$) {
3047 my ($clogp, $archive_hash) = @_;
3049 my $arch_clogp = commit_getclogp $archive_hash;
3050 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3051 'version currently in archive' ];
3052 if (defined $overwrite_version) {
3053 if (length $overwrite_version) {
3054 infopair_cond_equal([ $overwrite_version,
3055 '--overwrite= version' ],
3058 my $v = $i_arch_v->[0];
3059 progress "Checking package changelog for archive version $v ...";
3061 my @xa = ("-f$v", "-t$v");
3062 my $vclogp = parsechangelog @xa;
3063 my $cv = [ (getfield $vclogp, 'Version'),
3064 "Version field from dpkg-parsechangelog @xa" ];
3065 infopair_cond_equal($i_arch_v, $cv);
3068 $@ =~ s/^dgit: //gm;
3070 "Perhaps debian/changelog does not mention $v ?";
3075 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3079 sub pseudomerge_make_commit ($$$$ $$) {
3080 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3081 $msg_cmd, $msg_msg) = @_;
3082 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3084 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3085 my $authline = clogp_authline $clogp;
3089 !defined $overwrite_version ? ""
3090 : !length $overwrite_version ? " --overwrite"
3091 : " --overwrite=".$overwrite_version;
3094 my $pmf = ".git/dgit/pseudomerge";
3095 open MC, ">", $pmf or die "$pmf $!";
3096 print MC <<END or die $!;
3099 parent $archive_hash
3109 return make_commit($pmf);
3112 sub splitbrain_pseudomerge ($$$$) {
3113 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3114 # => $merged_dgitview
3115 printdebug "splitbrain_pseudomerge...\n";
3117 # We: debian/PREVIOUS HEAD($maintview)
3118 # expect: o ----------------- o
3121 # a/d/PREVIOUS $dgitview
3124 # we do: `------------------ o
3128 return $dgitview unless defined $archive_hash;
3130 printdebug "splitbrain_pseudomerge...\n";
3132 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3134 if (!defined $overwrite_version) {
3135 progress "Checking that HEAD inciudes all changes in archive...";
3138 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3140 if (defined $overwrite_version) {
3142 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3143 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3144 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3145 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3146 my $i_archive = [ $archive_hash, "current archive contents" ];
3148 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3150 infopair_cond_equal($i_dgit, $i_archive);
3151 infopair_cond_ff($i_dep14, $i_dgit);
3152 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3156 $us: check failed (maybe --overwrite is needed, consult documentation)
3161 my $r = pseudomerge_make_commit
3162 $clogp, $dgitview, $archive_hash, $i_arch_v,
3163 "dgit --quilt=$quilt_mode",
3164 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3165 Declare fast forward from $i_arch_v->[0]
3167 Make fast forward from $i_arch_v->[0]
3170 maybe_split_brain_save $maintview, $r, "pseudomerge";
3172 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3176 sub plain_overwrite_pseudomerge ($$$) {
3177 my ($clogp, $head, $archive_hash) = @_;
3179 printdebug "plain_overwrite_pseudomerge...";
3181 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3183 return $head if is_fast_fwd $archive_hash, $head;
3185 my $m = "Declare fast forward from $i_arch_v->[0]";
3187 my $r = pseudomerge_make_commit
3188 $clogp, $head, $archive_hash, $i_arch_v,
3191 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3193 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3197 sub push_parse_changelog ($) {
3200 my $clogp = Dpkg::Control::Hash->new();
3201 $clogp->load($clogpfn) or die;
3203 my $clogpackage = getfield $clogp, 'Source';
3204 $package //= $clogpackage;
3205 fail "-p specified $package but changelog specified $clogpackage"
3206 unless $package eq $clogpackage;
3207 my $cversion = getfield $clogp, 'Version';
3208 my $tag = debiantag($cversion, access_basedistro);
3209 runcmd @git, qw(check-ref-format), $tag;
3211 my $dscfn = dscfn($cversion);
3213 return ($clogp, $cversion, $dscfn);
3216 sub push_parse_dsc ($$$) {
3217 my ($dscfn,$dscfnwhat, $cversion) = @_;
3218 $dsc = parsecontrol($dscfn,$dscfnwhat);
3219 my $dversion = getfield $dsc, 'Version';
3220 my $dscpackage = getfield $dsc, 'Source';
3221 ($dscpackage eq $package && $dversion eq $cversion) or
3222 fail "$dscfn is for $dscpackage $dversion".
3223 " but debian/changelog is for $package $cversion";
3226 sub push_tagwants ($$$$) {
3227 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3230 TagFn => \&debiantag,
3235 if (defined $maintviewhead) {
3237 TagFn => \&debiantag_maintview,
3238 Objid => $maintviewhead,
3239 TfSuffix => '-maintview',
3243 foreach my $tw (@tagwants) {
3244 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3245 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3247 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3251 sub push_mktags ($$ $$ $) {
3253 $changesfile,$changesfilewhat,
3256 die unless $tagwants->[0]{View} eq 'dgit';
3258 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3259 $dsc->save("$dscfn.tmp") or die $!;
3261 my $changes = parsecontrol($changesfile,$changesfilewhat);
3262 foreach my $field (qw(Source Distribution Version)) {
3263 $changes->{$field} eq $clogp->{$field} or
3264 fail "changes field $field \`$changes->{$field}'".
3265 " does not match changelog \`$clogp->{$field}'";
3268 my $cversion = getfield $clogp, 'Version';
3269 my $clogsuite = getfield $clogp, 'Distribution';
3271 # We make the git tag by hand because (a) that makes it easier
3272 # to control the "tagger" (b) we can do remote signing
3273 my $authline = clogp_authline $clogp;
3274 my $delibs = join(" ", "",@deliberatelies);
3275 my $declaredistro = access_basedistro();
3279 my $tfn = $tw->{Tfn};
3280 my $head = $tw->{Objid};
3281 my $tag = $tw->{Tag};
3283 open TO, '>', $tfn->('.tmp') or die $!;
3284 print TO <<END or die $!;
3291 if ($tw->{View} eq 'dgit') {
3292 print TO <<END or die $!;
3293 $package release $cversion for $clogsuite ($csuite) [dgit]
3294 [dgit distro=$declaredistro$delibs]
3296 foreach my $ref (sort keys %previously) {
3297 print TO <<END or die $!;
3298 [dgit previously:$ref=$previously{$ref}]
3301 } elsif ($tw->{View} eq 'maint') {
3302 print TO <<END or die $!;
3303 $package release $cversion for $clogsuite ($csuite)
3304 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3307 die Dumper($tw)."?";
3312 my $tagobjfn = $tfn->('.tmp');
3314 if (!defined $keyid) {
3315 $keyid = access_cfg('keyid','RETURN-UNDEF');
3317 if (!defined $keyid) {
3318 $keyid = getfield $clogp, 'Maintainer';
3320 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3321 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3322 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3323 push @sign_cmd, $tfn->('.tmp');
3324 runcmd_ordryrun @sign_cmd;
3326 $tagobjfn = $tfn->('.signed.tmp');
3327 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3328 $tfn->('.tmp'), $tfn->('.tmp.asc');
3334 my @r = map { $mktag->($_); } @$tagwants;
3338 sub sign_changes ($) {
3339 my ($changesfile) = @_;
3341 my @debsign_cmd = @debsign;
3342 push @debsign_cmd, "-k$keyid" if defined $keyid;
3343 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3344 push @debsign_cmd, $changesfile;
3345 runcmd_ordryrun @debsign_cmd;
3350 printdebug "actually entering push\n";
3352 supplementary_message(<<'END');
3353 Push failed, while checking state of the archive.
3354 You can retry the push, after fixing the problem, if you like.
3356 if (check_for_git()) {
3359 my $archive_hash = fetch_from_archive();
3360 if (!$archive_hash) {
3362 fail "package appears to be new in this suite;".
3363 " if this is intentional, use --new";
3366 supplementary_message(<<'END');
3367 Push failed, while preparing your push.
3368 You can retry the push, after fixing the problem, if you like.
3371 need_tagformat 'new', "quilt mode $quilt_mode"
3372 if quiltmode_splitbrain;
3376 access_giturl(); # check that success is vaguely likely
3379 my $clogpfn = ".git/dgit/changelog.822.tmp";
3380 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3382 responder_send_file('parsed-changelog', $clogpfn);
3384 my ($clogp, $cversion, $dscfn) =
3385 push_parse_changelog("$clogpfn");
3387 my $dscpath = "$buildproductsdir/$dscfn";
3388 stat_exists $dscpath or
3389 fail "looked for .dsc $dscfn, but $!;".
3390 " maybe you forgot to build";
3392 responder_send_file('dsc', $dscpath);
3394 push_parse_dsc($dscpath, $dscfn, $cversion);
3396 my $format = getfield $dsc, 'Format';
3397 printdebug "format $format\n";
3399 my $actualhead = git_rev_parse('HEAD');
3400 my $dgithead = $actualhead;
3401 my $maintviewhead = undef;
3403 my $upstreamversion = upstreamversion $clogp->{Version};
3405 if (madformat_wantfixup($format)) {
3406 # user might have not used dgit build, so maybe do this now:
3407 if (quiltmode_splitbrain()) {
3409 quilt_make_fake_dsc($upstreamversion);
3411 ($dgithead, $cachekey) =
3412 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3414 "--quilt=$quilt_mode but no cached dgit view:
3415 perhaps tree changed since dgit build[-source] ?";
3417 $dgithead = splitbrain_pseudomerge($clogp,
3418 $actualhead, $dgithead,
3420 $maintviewhead = $actualhead;
3421 changedir '../../../..';
3422 prep_ud(); # so _only_subdir() works, below
3424 commit_quilty_patch();
3428 if (defined $overwrite_version && !defined $maintviewhead) {
3429 $dgithead = plain_overwrite_pseudomerge($clogp,
3437 if ($archive_hash) {
3438 if (is_fast_fwd($archive_hash, $dgithead)) {
3440 } elsif (deliberately_not_fast_forward) {
3443 fail "dgit push: HEAD is not a descendant".
3444 " of the archive's version.\n".
3445 "To overwrite the archive's contents,".
3446 " pass --overwrite[=VERSION].\n".
3447 "To rewind history, if permitted by the archive,".
3448 " use --deliberately-not-fast-forward.";
3453 progress "checking that $dscfn corresponds to HEAD";
3454 runcmd qw(dpkg-source -x --),
3455 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3456 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3457 check_for_vendor_patches() if madformat($dsc->{format});
3458 changedir '../../../..';
3459 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3460 debugcmd "+",@diffcmd;
3462 my $r = system @diffcmd;
3465 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3467 HEAD specifies a different tree to $dscfn:
3469 Perhaps you forgot to build. Or perhaps there is a problem with your
3470 source tree (see dgit(7) for some hints). To see a full diff, run
3477 if (!$changesfile) {
3478 my $pat = changespat $cversion;
3479 my @cs = glob "$buildproductsdir/$pat";
3480 fail "failed to find unique changes file".
3481 " (looked for $pat in $buildproductsdir);".
3482 " perhaps you need to use dgit -C"
3484 ($changesfile) = @cs;
3486 $changesfile = "$buildproductsdir/$changesfile";
3489 # Check that changes and .dsc agree enough
3490 $changesfile =~ m{[^/]*$};
3491 my $changes = parsecontrol($changesfile,$&);
3492 files_compare_inputs($dsc, $changes)
3493 unless forceing [qw(dsc-changes-mismatch)];
3495 # Perhaps adjust .dsc to contain right set of origs
3496 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3498 unless forceing [qw(changes-origs-exactly)];
3500 # Checks complete, we're going to try and go ahead:
3502 responder_send_file('changes',$changesfile);
3503 responder_send_command("param head $dgithead");
3504 responder_send_command("param csuite $csuite");
3505 responder_send_command("param tagformat $tagformat");
3506 if (defined $maintviewhead) {
3507 die unless ($protovsn//4) >= 4;
3508 responder_send_command("param maint-view $maintviewhead");
3511 if (deliberately_not_fast_forward) {
3512 git_for_each_ref(lrfetchrefs, sub {
3513 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3514 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3515 responder_send_command("previously $rrefname=$objid");
3516 $previously{$rrefname} = $objid;
3520 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3524 supplementary_message(<<'END');
3525 Push failed, while signing the tag.
3526 You can retry the push, after fixing the problem, if you like.
3528 # If we manage to sign but fail to record it anywhere, it's fine.
3529 if ($we_are_responder) {
3530 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3531 responder_receive_files('signed-tag', @tagobjfns);
3533 @tagobjfns = push_mktags($clogp,$dscpath,
3534 $changesfile,$changesfile,
3537 supplementary_message(<<'END');
3538 Push failed, *after* signing the tag.
3539 If you want to try again, you should use a new version number.
3542 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3544 foreach my $tw (@tagwants) {
3545 my $tag = $tw->{Tag};
3546 my $tagobjfn = $tw->{TagObjFn};
3548 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3549 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3550 runcmd_ordryrun_local
3551 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3554 supplementary_message(<<'END');
3555 Push failed, while updating the remote git repository - see messages above.
3556 If you want to try again, you should use a new version number.
3558 if (!check_for_git()) {
3559 create_remote_git_repo();
3562 my @pushrefs = $forceflag.$dgithead.":".rrref();
3563 foreach my $tw (@tagwants) {
3564 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3567 runcmd_ordryrun @git,
3568 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3569 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3571 supplementary_message(<<'END');
3572 Push failed, after updating the remote git repository.
3573 If you want to try again, you must use a new version number.
3575 if ($we_are_responder) {
3576 my $dryrunsuffix = act_local() ? "" : ".tmp";
3577 responder_receive_files('signed-dsc-changes',
3578 "$dscpath$dryrunsuffix",
3579 "$changesfile$dryrunsuffix");
3582 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3584 progress "[new .dsc left in $dscpath.tmp]";
3586 sign_changes $changesfile;
3589 supplementary_message(<<END);
3590 Push failed, while uploading package(s) to the archive server.
3591 You can retry the upload of exactly these same files with dput of:
3593 If that .changes file is broken, you will need to use a new version
3594 number for your next attempt at the upload.
3596 my $host = access_cfg('upload-host','RETURN-UNDEF');
3597 my @hostarg = defined($host) ? ($host,) : ();
3598 runcmd_ordryrun @dput, @hostarg, $changesfile;
3599 printdone "pushed and uploaded $cversion";
3601 supplementary_message('');
3602 responder_send_command("complete");
3609 badusage "-p is not allowed with clone; specify as argument instead"
3610 if defined $package;
3613 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3614 ($package,$isuite) = @ARGV;
3615 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3616 ($package,$dstdir) = @ARGV;
3617 } elsif (@ARGV==3) {
3618 ($package,$isuite,$dstdir) = @ARGV;
3620 badusage "incorrect arguments to dgit clone";
3622 $dstdir ||= "$package";
3624 if (stat_exists $dstdir) {
3625 fail "$dstdir already exists";
3629 if ($rmonerror && !$dryrun_level) {
3630 $cwd_remove= getcwd();
3632 return unless defined $cwd_remove;
3633 if (!chdir "$cwd_remove") {
3634 return if $!==&ENOENT;
3635 die "chdir $cwd_remove: $!";
3638 rmtree($dstdir) or die "remove $dstdir: $!\n";
3639 } elsif (grep { $! == $_ }
3640 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3642 print STDERR "check whether to remove $dstdir: $!\n";
3648 $cwd_remove = undef;
3651 sub branchsuite () {
3652 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3653 if ($branch =~ m#$lbranch_re#o) {
3660 sub fetchpullargs () {
3662 if (!defined $package) {
3663 my $sourcep = parsecontrol('debian/control','debian/control');
3664 $package = getfield $sourcep, 'Source';
3667 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3669 my $clogp = parsechangelog();
3670 $isuite = getfield $clogp, 'Distribution';
3672 canonicalise_suite();
3673 progress "fetching from suite $csuite";
3674 } elsif (@ARGV==1) {
3676 canonicalise_suite();
3678 badusage "incorrect arguments to dgit fetch or dgit pull";
3691 if (quiltmode_splitbrain()) {
3692 my ($format, $fopts) = get_source_format();
3693 madformat($format) and fail <<END
3694 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3703 badusage "-p is not allowed with dgit push" if defined $package;
3705 my $clogp = parsechangelog();
3706 $package = getfield $clogp, 'Source';
3709 } elsif (@ARGV==1) {
3710 ($specsuite) = (@ARGV);
3712 badusage "incorrect arguments to dgit push";
3714 $isuite = getfield $clogp, 'Distribution';
3716 local ($package) = $existing_package; # this is a hack
3717 canonicalise_suite();