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 $package = getfield $clogp, 'Source';
3204 my $cversion = getfield $clogp, 'Version';
3205 my $tag = debiantag($cversion, access_basedistro);
3206 runcmd @git, qw(check-ref-format), $tag;
3208 my $dscfn = dscfn($cversion);
3210 return ($clogp, $cversion, $dscfn);
3213 sub push_parse_dsc ($$$) {
3214 my ($dscfn,$dscfnwhat, $cversion) = @_;
3215 $dsc = parsecontrol($dscfn,$dscfnwhat);
3216 my $dversion = getfield $dsc, 'Version';
3217 my $dscpackage = getfield $dsc, 'Source';
3218 ($dscpackage eq $package && $dversion eq $cversion) or
3219 fail "$dscfn is for $dscpackage $dversion".
3220 " but debian/changelog is for $package $cversion";
3223 sub push_tagwants ($$$$) {
3224 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3227 TagFn => \&debiantag,
3232 if (defined $maintviewhead) {
3234 TagFn => \&debiantag_maintview,
3235 Objid => $maintviewhead,
3236 TfSuffix => '-maintview',
3240 foreach my $tw (@tagwants) {
3241 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3242 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3244 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3248 sub push_mktags ($$ $$ $) {
3250 $changesfile,$changesfilewhat,
3253 die unless $tagwants->[0]{View} eq 'dgit';
3255 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3256 $dsc->save("$dscfn.tmp") or die $!;
3258 my $changes = parsecontrol($changesfile,$changesfilewhat);
3259 foreach my $field (qw(Source Distribution Version)) {
3260 $changes->{$field} eq $clogp->{$field} or
3261 fail "changes field $field \`$changes->{$field}'".
3262 " does not match changelog \`$clogp->{$field}'";
3265 my $cversion = getfield $clogp, 'Version';
3266 my $clogsuite = getfield $clogp, 'Distribution';
3268 # We make the git tag by hand because (a) that makes it easier
3269 # to control the "tagger" (b) we can do remote signing
3270 my $authline = clogp_authline $clogp;
3271 my $delibs = join(" ", "",@deliberatelies);
3272 my $declaredistro = access_basedistro();
3276 my $tfn = $tw->{Tfn};
3277 my $head = $tw->{Objid};
3278 my $tag = $tw->{Tag};
3280 open TO, '>', $tfn->('.tmp') or die $!;
3281 print TO <<END or die $!;
3288 if ($tw->{View} eq 'dgit') {
3289 print TO <<END or die $!;
3290 $package release $cversion for $clogsuite ($csuite) [dgit]
3291 [dgit distro=$declaredistro$delibs]
3293 foreach my $ref (sort keys %previously) {
3294 print TO <<END or die $!;
3295 [dgit previously:$ref=$previously{$ref}]
3298 } elsif ($tw->{View} eq 'maint') {
3299 print TO <<END or die $!;
3300 $package release $cversion for $clogsuite ($csuite)
3301 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3304 die Dumper($tw)."?";
3309 my $tagobjfn = $tfn->('.tmp');
3311 if (!defined $keyid) {
3312 $keyid = access_cfg('keyid','RETURN-UNDEF');
3314 if (!defined $keyid) {
3315 $keyid = getfield $clogp, 'Maintainer';
3317 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3318 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3319 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3320 push @sign_cmd, $tfn->('.tmp');
3321 runcmd_ordryrun @sign_cmd;
3323 $tagobjfn = $tfn->('.signed.tmp');
3324 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3325 $tfn->('.tmp'), $tfn->('.tmp.asc');
3331 my @r = map { $mktag->($_); } @$tagwants;
3335 sub sign_changes ($) {
3336 my ($changesfile) = @_;
3338 my @debsign_cmd = @debsign;
3339 push @debsign_cmd, "-k$keyid" if defined $keyid;
3340 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3341 push @debsign_cmd, $changesfile;
3342 runcmd_ordryrun @debsign_cmd;
3347 printdebug "actually entering push\n";
3349 supplementary_message(<<'END');
3350 Push failed, while checking state of the archive.
3351 You can retry the push, after fixing the problem, if you like.
3353 if (check_for_git()) {
3356 my $archive_hash = fetch_from_archive();
3357 if (!$archive_hash) {
3359 fail "package appears to be new in this suite;".
3360 " if this is intentional, use --new";
3363 supplementary_message(<<'END');
3364 Push failed, while preparing your push.
3365 You can retry the push, after fixing the problem, if you like.
3368 need_tagformat 'new', "quilt mode $quilt_mode"
3369 if quiltmode_splitbrain;
3373 access_giturl(); # check that success is vaguely likely
3376 my $clogpfn = ".git/dgit/changelog.822.tmp";
3377 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3379 responder_send_file('parsed-changelog', $clogpfn);
3381 my ($clogp, $cversion, $dscfn) =
3382 push_parse_changelog("$clogpfn");
3384 my $dscpath = "$buildproductsdir/$dscfn";
3385 stat_exists $dscpath or
3386 fail "looked for .dsc $dscfn, but $!;".
3387 " maybe you forgot to build";
3389 responder_send_file('dsc', $dscpath);
3391 push_parse_dsc($dscpath, $dscfn, $cversion);
3393 my $format = getfield $dsc, 'Format';
3394 printdebug "format $format\n";
3396 my $actualhead = git_rev_parse('HEAD');
3397 my $dgithead = $actualhead;
3398 my $maintviewhead = undef;
3400 my $upstreamversion = upstreamversion $clogp->{Version};
3402 if (madformat_wantfixup($format)) {
3403 # user might have not used dgit build, so maybe do this now:
3404 if (quiltmode_splitbrain()) {
3406 quilt_make_fake_dsc($upstreamversion);
3408 ($dgithead, $cachekey) =
3409 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3411 "--quilt=$quilt_mode but no cached dgit view:
3412 perhaps tree changed since dgit build[-source] ?";
3414 $dgithead = splitbrain_pseudomerge($clogp,
3415 $actualhead, $dgithead,
3417 $maintviewhead = $actualhead;
3418 changedir '../../../..';
3419 prep_ud(); # so _only_subdir() works, below
3421 commit_quilty_patch();
3425 if (defined $overwrite_version && !defined $maintviewhead) {
3426 $dgithead = plain_overwrite_pseudomerge($clogp,
3434 if ($archive_hash) {
3435 if (is_fast_fwd($archive_hash, $dgithead)) {
3437 } elsif (deliberately_not_fast_forward) {
3440 fail "dgit push: HEAD is not a descendant".
3441 " of the archive's version.\n".
3442 "To overwrite the archive's contents,".
3443 " pass --overwrite[=VERSION].\n".
3444 "To rewind history, if permitted by the archive,".
3445 " use --deliberately-not-fast-forward.";
3450 progress "checking that $dscfn corresponds to HEAD";
3451 runcmd qw(dpkg-source -x --),
3452 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3453 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3454 check_for_vendor_patches() if madformat($dsc->{format});
3455 changedir '../../../..';
3456 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3457 debugcmd "+",@diffcmd;
3459 my $r = system @diffcmd;
3462 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3464 HEAD specifies a different tree to $dscfn:
3466 Perhaps you forgot to build. Or perhaps there is a problem with your
3467 source tree (see dgit(7) for some hints). To see a full diff, run
3474 if (!$changesfile) {
3475 my $pat = changespat $cversion;
3476 my @cs = glob "$buildproductsdir/$pat";
3477 fail "failed to find unique changes file".
3478 " (looked for $pat in $buildproductsdir);".
3479 " perhaps you need to use dgit -C"
3481 ($changesfile) = @cs;
3483 $changesfile = "$buildproductsdir/$changesfile";
3486 # Check that changes and .dsc agree enough
3487 $changesfile =~ m{[^/]*$};
3488 my $changes = parsecontrol($changesfile,$&);
3489 files_compare_inputs($dsc, $changes)
3490 unless forceing [qw(dsc-changes-mismatch)];
3492 # Perhaps adjust .dsc to contain right set of origs
3493 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3495 unless forceing [qw(changes-origs-exactly)];
3497 # Checks complete, we're going to try and go ahead:
3499 responder_send_file('changes',$changesfile);
3500 responder_send_command("param head $dgithead");
3501 responder_send_command("param csuite $csuite");
3502 responder_send_command("param tagformat $tagformat");
3503 if (defined $maintviewhead) {
3504 die unless ($protovsn//4) >= 4;
3505 responder_send_command("param maint-view $maintviewhead");
3508 if (deliberately_not_fast_forward) {
3509 git_for_each_ref(lrfetchrefs, sub {
3510 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3511 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3512 responder_send_command("previously $rrefname=$objid");
3513 $previously{$rrefname} = $objid;
3517 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3521 supplementary_message(<<'END');
3522 Push failed, while signing the tag.
3523 You can retry the push, after fixing the problem, if you like.
3525 # If we manage to sign but fail to record it anywhere, it's fine.
3526 if ($we_are_responder) {
3527 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3528 responder_receive_files('signed-tag', @tagobjfns);
3530 @tagobjfns = push_mktags($clogp,$dscpath,
3531 $changesfile,$changesfile,
3534 supplementary_message(<<'END');
3535 Push failed, *after* signing the tag.
3536 If you want to try again, you should use a new version number.
3539 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3541 foreach my $tw (@tagwants) {
3542 my $tag = $tw->{Tag};
3543 my $tagobjfn = $tw->{TagObjFn};
3545 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3546 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3547 runcmd_ordryrun_local
3548 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3551 supplementary_message(<<'END');
3552 Push failed, while updating the remote git repository - see messages above.
3553 If you want to try again, you should use a new version number.
3555 if (!check_for_git()) {
3556 create_remote_git_repo();
3559 my @pushrefs = $forceflag.$dgithead.":".rrref();
3560 foreach my $tw (@tagwants) {
3561 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3564 runcmd_ordryrun @git,
3565 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3566 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3568 supplementary_message(<<'END');
3569 Push failed, after updating the remote git repository.
3570 If you want to try again, you must use a new version number.
3572 if ($we_are_responder) {
3573 my $dryrunsuffix = act_local() ? "" : ".tmp";
3574 responder_receive_files('signed-dsc-changes',
3575 "$dscpath$dryrunsuffix",
3576 "$changesfile$dryrunsuffix");
3579 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3581 progress "[new .dsc left in $dscpath.tmp]";
3583 sign_changes $changesfile;
3586 supplementary_message(<<END);
3587 Push failed, while uploading package(s) to the archive server.
3588 You can retry the upload of exactly these same files with dput of:
3590 If that .changes file is broken, you will need to use a new version
3591 number for your next attempt at the upload.
3593 my $host = access_cfg('upload-host','RETURN-UNDEF');
3594 my @hostarg = defined($host) ? ($host,) : ();
3595 runcmd_ordryrun @dput, @hostarg, $changesfile;
3596 printdone "pushed and uploaded $cversion";
3598 supplementary_message('');
3599 responder_send_command("complete");
3606 badusage "-p is not allowed with clone; specify as argument instead"
3607 if defined $package;
3610 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3611 ($package,$isuite) = @ARGV;
3612 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3613 ($package,$dstdir) = @ARGV;
3614 } elsif (@ARGV==3) {
3615 ($package,$isuite,$dstdir) = @ARGV;
3617 badusage "incorrect arguments to dgit clone";
3619 $dstdir ||= "$package";
3621 if (stat_exists $dstdir) {
3622 fail "$dstdir already exists";
3626 if ($rmonerror && !$dryrun_level) {
3627 $cwd_remove= getcwd();
3629 return unless defined $cwd_remove;
3630 if (!chdir "$cwd_remove") {
3631 return if $!==&ENOENT;
3632 die "chdir $cwd_remove: $!";
3635 rmtree($dstdir) or die "remove $dstdir: $!\n";
3636 } elsif (grep { $! == $_ }
3637 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3639 print STDERR "check whether to remove $dstdir: $!\n";
3645 $cwd_remove = undef;
3648 sub branchsuite () {
3649 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3650 if ($branch =~ m#$lbranch_re#o) {
3657 sub fetchpullargs () {
3659 if (!defined $package) {
3660 my $sourcep = parsecontrol('debian/control','debian/control');
3661 $package = getfield $sourcep, 'Source';
3664 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3666 my $clogp = parsechangelog();
3667 $isuite = getfield $clogp, 'Distribution';
3669 canonicalise_suite();
3670 progress "fetching from suite $csuite";
3671 } elsif (@ARGV==1) {
3673 canonicalise_suite();
3675 badusage "incorrect arguments to dgit fetch or dgit pull";
3688 if (quiltmode_splitbrain()) {
3689 my ($format, $fopts) = get_source_format();
3690 madformat($format) and fail <<END
3691 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3700 badusage "-p is not allowed with dgit push" if defined $package;
3702 my $clogp = parsechangelog();
3703 $package = getfield $clogp, 'Source';
3706 } elsif (@ARGV==1) {
3707 ($specsuite) = (@ARGV);
3709 badusage "incorrect arguments to dgit push";
3711 $isuite = getfield $clogp, 'Distribution';
3713 local ($package) = $existing_package; # this is a hack
3714 canonicalise_suite();
3716 canonicalise_suite();
3718 if (defined $specsuite &&
3719 $specsuite ne $isuite &&
3720 $specsuite ne $csuite) {
3721 fail "dgit push: changelog specifies $isuite ($csuite)".
3722 " but command line specifies $specsuite";
3727 #---------- remote commands' implementation ----------
3729 sub cmd_remote_push_build_host {
3730 my ($nrargs) = shift @ARGV;
3731 my (@rargs) = @ARGV[0..$nrargs-1];
3732 @ARGV = @ARGV[$nrargs..$#ARGV];
3734 my ($dir,$vsnwant) = @rargs;
3735 # vsnwant is a comma-separated list; we report which we have
3736 # chosen in our ready response (so other end can tell if they
3739 $we_are_responder = 1;
3740 $us .= " (build host)";
3744 open PI, "<&STDIN" or die $!;
3745 open STDIN, "/dev/null" or die $!;
3746 open PO, ">&STDOUT" or die $!;
3748 open STDOUT, ">&STDERR" or die $!;
3752 ($protovsn) = grep {
3753 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3754 } @rpushprotovsn_support;
3756 fail "build host has dgit rpush protocol versions ".
3757 (join ",", @rpushprotovsn_support).
3758 " but invocation host has $vsnwant"
3759 unless defined $protovsn;
3761 responder_send_command("dgit-remote-push-ready $protovsn");
3762 rpush_handle_protovsn_bothends();
3767 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3768 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3769 # a good error message)
3771 sub rpush_handle_protovsn_bothends () {
3772 if ($protovsn < 4) {
3773 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3782 my $report = i_child_report();
3783 if (defined $report) {
3784 printdebug "($report)\n";
3785 } elsif ($i_child_pid) {
3786 printdebug "(killing build host child $i_child_pid)\n";
3787 kill 15, $i_child_pid;
3789 if (defined $i_tmp && !defined $initiator_tempdir) {
3791 eval { rmtree $i_tmp; };
3795 END { i_cleanup(); }
3798 my ($base,$selector,@args) = @_;
3799 $selector =~ s/\-/_/g;
3800 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3807 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3815 push @rargs, join ",", @rpushprotovsn_support;
3818 push @rdgit, @ropts;
3819 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3821 my @cmd = (@ssh, $host, shellquote @rdgit);
3824 if (defined $initiator_tempdir) {
3825 rmtree $initiator_tempdir;
3826 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3827 $i_tmp = $initiator_tempdir;
3831 $i_child_pid = open2(\*RO, \*RI, @cmd);
3833 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3834 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3835 $supplementary_message = '' unless $protovsn >= 3;
3837 fail "rpush negotiated protocol version $protovsn".
3838 " which does not support quilt mode $quilt_mode"
3839 if quiltmode_splitbrain;
3841 rpush_handle_protovsn_bothends();
3843 my ($icmd,$iargs) = initiator_expect {
3844 m/^(\S+)(?: (.*))?$/;
3847 i_method "i_resp", $icmd, $iargs;
3851 sub i_resp_progress ($) {
3853 my $msg = protocol_read_bytes \*RO, $rhs;
3857 sub i_resp_supplementary_message ($) {
3859 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3862 sub i_resp_complete {
3863 my $pid = $i_child_pid;
3864 $i_child_pid = undef; # prevents killing some other process with same pid
3865 printdebug "waiting for build host child $pid...\n";
3866 my $got = waitpid $pid, 0;
3867 die $! unless $got == $pid;
3868 die "build host child failed $?" if $?;
3871 printdebug "all done\n";
3875 sub i_resp_file ($) {
3877 my $localname = i_method "i_localname", $keyword;
3878 my $localpath = "$i_tmp/$localname";
3879 stat_exists $localpath and
3880 badproto \*RO, "file $keyword ($localpath) twice";
3881 protocol_receive_file \*RO, $localpath;
3882 i_method "i_file", $keyword;
3887 sub i_resp_param ($) {
3888 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3892 sub i_resp_previously ($) {
3893 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3894 or badproto \*RO, "bad previously spec";
3895 my $r = system qw(git check-ref-format), $1;
3896 die "bad previously ref spec ($r)" if $r;
3897 $previously{$1} = $2;
3902 sub i_resp_want ($) {
3904 die "$keyword ?" if $i_wanted{$keyword}++;
3905 my @localpaths = i_method "i_want", $keyword;
3906 printdebug "[[ $keyword @localpaths\n";
3907 foreach my $localpath (@localpaths) {
3908 protocol_send_file \*RI, $localpath;
3910 print RI "files-end\n" or die $!;
3913 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3915 sub i_localname_parsed_changelog {
3916 return "remote-changelog.822";
3918 sub i_file_parsed_changelog {
3919 ($i_clogp, $i_version, $i_dscfn) =
3920 push_parse_changelog "$i_tmp/remote-changelog.822";
3921 die if $i_dscfn =~ m#/|^\W#;
3924 sub i_localname_dsc {
3925 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3930 sub i_localname_changes {
3931 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3932 $i_changesfn = $i_dscfn;
3933 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3934 return $i_changesfn;
3936 sub i_file_changes { }
3938 sub i_want_signed_tag {
3939 printdebug Dumper(\%i_param, $i_dscfn);
3940 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3941 && defined $i_param{'csuite'}
3942 or badproto \*RO, "premature desire for signed-tag";
3943 my $head = $i_param{'head'};
3944 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3946 my $maintview = $i_param{'maint-view'};
3947 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3950 if ($protovsn >= 4) {
3951 my $p = $i_param{'tagformat'} // '<undef>';
3953 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3956 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3958 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3960 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3963 push_mktags $i_clogp, $i_dscfn,
3964 $i_changesfn, 'remote changes',
3968 sub i_want_signed_dsc_changes {
3969 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3970 sign_changes $i_changesfn;
3971 return ($i_dscfn, $i_changesfn);
3974 #---------- building etc. ----------
3980 #----- `3.0 (quilt)' handling -----
3982 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3984 sub quiltify_dpkg_commit ($$$;$) {
3985 my ($patchname,$author,$msg, $xinfo) = @_;
3989 my $descfn = ".git/dgit/quilt-description.tmp";
3990 open O, '>', $descfn or die "$descfn: $!";
3991 $msg =~ s/\n+/\n\n/;
3992 print O <<END or die $!;
3994 ${xinfo}Subject: $msg
4001 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4002 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4003 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4004 runcmd @dpkgsource, qw(--commit .), $patchname;
4008 sub quiltify_trees_differ ($$;$$$) {
4009 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4010 # returns true iff the two tree objects differ other than in debian/
4011 # with $finegrained,
4012 # returns bitmask 01 - differ in upstream files except .gitignore
4013 # 02 - differ in .gitignore
4014 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4015 # is set for each modified .gitignore filename $fn
4016 # if $unrepres is defined, array ref to which is appeneded
4017 # a list of unrepresentable changes (removals of upstream files
4020 my @cmd = (@git, qw(diff-tree -z));
4021 push @cmd, qw(--name-only) unless $unrepres;
4022 push @cmd, qw(-r) if $finegrained || $unrepres;
4024 my $diffs= cmdoutput @cmd;
4027 foreach my $f (split /\0/, $diffs) {
4028 if ($unrepres && !@lmodes) {
4029 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4032 my ($oldmode,$newmode) = @lmodes;
4035 next if $f =~ m#^debian(?:/.*)?$#s;
4039 die "deleted\n" unless $newmode =~ m/[^0]/;
4040 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4041 if ($oldmode =~ m/[^0]/) {
4042 die "mode changed\n" if $oldmode ne $newmode;
4044 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4048 local $/="\n"; chomp $@;
4049 push @$unrepres, [ $f, $@ ];
4053 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4054 $r |= $isignore ? 02 : 01;
4055 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4057 printdebug "quiltify_trees_differ $x $y => $r\n";
4061 sub quiltify_tree_sentinelfiles ($) {
4062 # lists the `sentinel' files present in the tree
4064 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4065 qw(-- debian/rules debian/control);
4070 sub quiltify_splitbrain_needed () {
4071 if (!$split_brain) {
4072 progress "dgit view: changes are required...";
4073 runcmd @git, qw(checkout -q -b dgit-view);
4078 sub quiltify_splitbrain ($$$$$$) {
4079 my ($clogp, $unapplied, $headref, $diffbits,
4080 $editedignores, $cachekey) = @_;
4081 if ($quilt_mode !~ m/gbp|dpm/) {
4082 # treat .gitignore just like any other upstream file
4083 $diffbits = { %$diffbits };
4084 $_ = !!$_ foreach values %$diffbits;
4086 # We would like any commits we generate to be reproducible
4087 my @authline = clogp_authline($clogp);
4088 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4089 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4090 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4091 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4092 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4093 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4095 if ($quilt_mode =~ m/gbp|unapplied/ &&
4096 ($diffbits->{O2H} & 01)) {
4098 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4099 " but git tree differs from orig in upstream files.";
4100 if (!stat_exists "debian/patches") {
4102 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4106 if ($quilt_mode =~ m/dpm/ &&
4107 ($diffbits->{H2A} & 01)) {
4109 --quilt=$quilt_mode specified, implying patches-applied git tree
4110 but git tree differs from result of applying debian/patches to upstream
4113 if ($quilt_mode =~ m/gbp|unapplied/ &&
4114 ($diffbits->{O2A} & 01)) { # some patches
4115 quiltify_splitbrain_needed();
4116 progress "dgit view: creating patches-applied version using gbp pq";
4117 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4118 # gbp pq import creates a fresh branch; push back to dgit-view
4119 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4120 runcmd @git, qw(checkout -q dgit-view);
4122 if ($quilt_mode =~ m/gbp|dpm/ &&
4123 ($diffbits->{O2A} & 02)) {
4125 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4126 tool which does not create patches for changes to upstream
4127 .gitignores: but, such patches exist in debian/patches.
4130 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4131 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4132 quiltify_splitbrain_needed();
4133 progress "dgit view: creating patch to represent .gitignore changes";
4134 ensuredir "debian/patches";
4135 my $gipatch = "debian/patches/auto-gitignore";
4136 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4137 stat GIPATCH or die "$gipatch: $!";
4138 fail "$gipatch already exists; but want to create it".
4139 " to record .gitignore changes" if (stat _)[7];
4140 print GIPATCH <<END or die "$gipatch: $!";
4141 Subject: Update .gitignore from Debian packaging branch
4143 The Debian packaging git branch contains these updates to the upstream
4144 .gitignore file(s). This patch is autogenerated, to provide these
4145 updates to users of the official Debian archive view of the package.
4147 [dgit ($our_version) update-gitignore]
4150 close GIPATCH or die "$gipatch: $!";
4151 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4152 $unapplied, $headref, "--", sort keys %$editedignores;
4153 open SERIES, "+>>", "debian/patches/series" or die $!;
4154 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4156 defined read SERIES, $newline, 1 or die $!;
4157 print SERIES "\n" or die $! unless $newline eq "\n";
4158 print SERIES "auto-gitignore\n" or die $!;
4159 close SERIES or die $!;
4160 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4162 Commit patch to update .gitignore
4164 [dgit ($our_version) update-gitignore-quilt-fixup]
4168 my $dgitview = git_rev_parse 'HEAD';
4170 changedir '../../../..';
4171 # When we no longer need to support squeeze, use --create-reflog
4173 ensuredir ".git/logs/refs/dgit-intern";
4174 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4177 my $oldcache = git_get_ref "refs/$splitbraincache";
4178 if ($oldcache eq $dgitview) {
4179 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4180 # git update-ref doesn't always update, in this case. *sigh*
4181 my $dummy = make_commit_text <<END;
4184 author Dgit <dgit\@example.com> 1000000000 +0000
4185 committer Dgit <dgit\@example.com> 1000000000 +0000
4187 Dummy commit - do not use
4189 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4190 "refs/$splitbraincache", $dummy;
4192 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4195 changedir '.git/dgit/unpack/work';
4197 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4198 progress "dgit view: created ($saved)";
4201 sub quiltify ($$$$) {
4202 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4204 # Quilt patchification algorithm
4206 # We search backwards through the history of the main tree's HEAD
4207 # (T) looking for a start commit S whose tree object is identical
4208 # to to the patch tip tree (ie the tree corresponding to the
4209 # current dpkg-committed patch series). For these purposes
4210 # `identical' disregards anything in debian/ - this wrinkle is
4211 # necessary because dpkg-source treates debian/ specially.
4213 # We can only traverse edges where at most one of the ancestors'
4214 # trees differs (in changes outside in debian/). And we cannot
4215 # handle edges which change .pc/ or debian/patches. To avoid
4216 # going down a rathole we avoid traversing edges which introduce
4217 # debian/rules or debian/control. And we set a limit on the
4218 # number of edges we are willing to look at.
4220 # If we succeed, we walk forwards again. For each traversed edge
4221 # PC (with P parent, C child) (starting with P=S and ending with
4222 # C=T) to we do this:
4224 # - dpkg-source --commit with a patch name and message derived from C
4225 # After traversing PT, we git commit the changes which
4226 # should be contained within debian/patches.
4228 # The search for the path S..T is breadth-first. We maintain a
4229 # todo list containing search nodes. A search node identifies a
4230 # commit, and looks something like this:
4232 # Commit => $git_commit_id,
4233 # Child => $c, # or undef if P=T
4234 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4235 # Nontrivial => true iff $p..$c has relevant changes
4242 my %considered; # saves being exponential on some weird graphs
4244 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4247 my ($search,$whynot) = @_;
4248 printdebug " search NOT $search->{Commit} $whynot\n";
4249 $search->{Whynot} = $whynot;
4250 push @nots, $search;
4251 no warnings qw(exiting);
4260 my $c = shift @todo;
4261 next if $considered{$c->{Commit}}++;
4263 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4265 printdebug "quiltify investigate $c->{Commit}\n";
4268 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4269 printdebug " search finished hooray!\n";
4274 if ($quilt_mode eq 'nofix') {
4275 fail "quilt fixup required but quilt mode is \`nofix'\n".
4276 "HEAD commit $c->{Commit} differs from tree implied by ".
4277 " debian/patches (tree object $oldtiptree)";
4279 if ($quilt_mode eq 'smash') {
4280 printdebug " search quitting smash\n";
4284 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4285 $not->($c, "has $c_sentinels not $t_sentinels")
4286 if $c_sentinels ne $t_sentinels;
4288 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4289 $commitdata =~ m/\n\n/;
4291 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4292 @parents = map { { Commit => $_, Child => $c } } @parents;
4294 $not->($c, "root commit") if !@parents;
4296 foreach my $p (@parents) {
4297 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4299 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4300 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4302 foreach my $p (@parents) {
4303 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4305 my @cmd= (@git, qw(diff-tree -r --name-only),
4306 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4307 my $patchstackchange = cmdoutput @cmd;
4308 if (length $patchstackchange) {
4309 $patchstackchange =~ s/\n/,/g;
4310 $not->($p, "changed $patchstackchange");
4313 printdebug " search queue P=$p->{Commit} ",
4314 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4320 printdebug "quiltify want to smash\n";
4323 my $x = $_[0]{Commit};
4324 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4327 my $reportnot = sub {
4329 my $s = $abbrev->($notp);
4330 my $c = $notp->{Child};
4331 $s .= "..".$abbrev->($c) if $c;
4332 $s .= ": ".$notp->{Whynot};
4335 if ($quilt_mode eq 'linear') {
4336 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4337 foreach my $notp (@nots) {
4338 print STDERR "$us: ", $reportnot->($notp), "\n";
4340 print STDERR "$us: $_\n" foreach @$failsuggestion;
4341 fail "quilt fixup naive history linearisation failed.\n".
4342 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4343 } elsif ($quilt_mode eq 'smash') {
4344 } elsif ($quilt_mode eq 'auto') {
4345 progress "quilt fixup cannot be linear, smashing...";
4347 die "$quilt_mode ?";
4350 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4351 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4353 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4355 quiltify_dpkg_commit "auto-$version-$target-$time",
4356 (getfield $clogp, 'Maintainer'),
4357 "Automatically generated patch ($clogp->{Version})\n".
4358 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4362 progress "quiltify linearisation planning successful, executing...";
4364 for (my $p = $sref_S;
4365 my $c = $p->{Child};
4367 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4368 next unless $p->{Nontrivial};
4370 my $cc = $c->{Commit};
4372 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4373 $commitdata =~ m/\n\n/ or die "$c ?";
4376 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4379 my $commitdate = cmdoutput
4380 @git, qw(log -n1 --pretty=format:%aD), $cc;
4382 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4384 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4391 my $gbp_check_suitable = sub {
4396 die "contains unexpected slashes\n" if m{//} || m{/$};
4397 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4398 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4399 die "too long" if length > 200;
4401 return $_ unless $@;
4402 print STDERR "quiltifying commit $cc:".
4403 " ignoring/dropping Gbp-Pq $what: $@";
4407 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4409 (\S+) \s* \n //ixm) {
4410 $patchname = $gbp_check_suitable->($1, 'Name');
4412 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4414 (\S+) \s* \n //ixm) {
4415 $patchdir = $gbp_check_suitable->($1, 'Topic');
4420 if (!defined $patchname) {
4421 $patchname = $title;
4422 $patchname =~ s/[.:]$//;
4425 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4426 my $translitname = $converter->convert($patchname);
4427 die unless defined $translitname;
4428 $patchname = $translitname;
4431 "dgit: patch title transliteration error: $@"
4433 $patchname =~ y/ A-Z/-a-z/;
4434 $patchname =~ y/-a-z0-9_.+=~//cd;
4435 $patchname =~ s/^\W/x-$&/;
4436 $patchname = substr($patchname,0,40);
4438 if (!defined $patchdir) {
4441 if (length $patchdir) {
4442 $patchname = "$patchdir/$patchname";
4444 if ($patchname =~ m{^(.*)/}) {
4445 mkpath "debian/patches/$1";
4450 stat "debian/patches/$patchname$index";
4452 $!==ENOENT or die "$patchname$index $!";
4454 runcmd @git, qw(checkout -q), $cc;
4456 # We use the tip's changelog so that dpkg-source doesn't
4457 # produce complaining messages from dpkg-parsechangelog. None
4458 # of the information dpkg-source gets from the changelog is
4459 # actually relevant - it gets put into the original message
4460 # which dpkg-source provides our stunt editor, and then
4462 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4464 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4465 "Date: $commitdate\n".
4466 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4468 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4471 runcmd @git, qw(checkout -q master);
4474 sub build_maybe_quilt_fixup () {
4475 my ($format,$fopts) = get_source_format;
4476 return unless madformat_wantfixup $format;
4479 check_for_vendor_patches();
4481 if (quiltmode_splitbrain) {
4482 foreach my $needtf (qw(new maint)) {
4483 next if grep { $_ eq $needtf } access_cfg_tagformats;
4485 quilt mode $quilt_mode requires split view so server needs to support
4486 both "new" and "maint" tag formats, but config says it doesn't.
4491 my $clogp = parsechangelog();
4492 my $headref = git_rev_parse('HEAD');
4497 my $upstreamversion = upstreamversion $version;
4499 if ($fopts->{'single-debian-patch'}) {
4500 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4502 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4505 die 'bug' if $split_brain && !$need_split_build_invocation;
4507 changedir '../../../..';
4508 runcmd_ordryrun_local
4509 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4512 sub quilt_fixup_mkwork ($) {
4515 mkdir "work" or die $!;
4517 mktree_in_ud_here();
4518 runcmd @git, qw(reset -q --hard), $headref;
4521 sub quilt_fixup_linkorigs ($$) {
4522 my ($upstreamversion, $fn) = @_;
4523 # calls $fn->($leafname);
4525 foreach my $f (<../../../../*>) { #/){
4526 my $b=$f; $b =~ s{.*/}{};
4528 local ($debuglevel) = $debuglevel-1;
4529 printdebug "QF linkorigs $b, $f ?\n";
4531 next unless is_orig_file_of_vsn $b, $upstreamversion;
4532 printdebug "QF linkorigs $b, $f Y\n";
4533 link_ltarget $f, $b or die "$b $!";
4538 sub quilt_fixup_delete_pc () {
4539 runcmd @git, qw(rm -rqf .pc);
4541 Commit removal of .pc (quilt series tracking data)
4543 [dgit ($our_version) upgrade quilt-remove-pc]
4547 sub quilt_fixup_singlepatch ($$$) {
4548 my ($clogp, $headref, $upstreamversion) = @_;
4550 progress "starting quiltify (single-debian-patch)";
4552 # dpkg-source --commit generates new patches even if
4553 # single-debian-patch is in debian/source/options. In order to
4554 # get it to generate debian/patches/debian-changes, it is
4555 # necessary to build the source package.
4557 quilt_fixup_linkorigs($upstreamversion, sub { });
4558 quilt_fixup_mkwork($headref);
4560 rmtree("debian/patches");
4562 runcmd @dpkgsource, qw(-b .);
4564 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4565 rename srcfn("$upstreamversion", "/debian/patches"),
4566 "work/debian/patches";
4569 commit_quilty_patch();
4572 sub quilt_make_fake_dsc ($) {
4573 my ($upstreamversion) = @_;
4575 my $fakeversion="$upstreamversion-~~DGITFAKE";
4577 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4578 print $fakedsc <<END or die $!;
4581 Version: $fakeversion
4585 my $dscaddfile=sub {
4588 my $md = new Digest::MD5;
4590 my $fh = new IO::File $b, '<' or die "$b $!";
4595 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4598 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4600 my @files=qw(debian/source/format debian/rules
4601 debian/control debian/changelog);
4602 foreach my $maybe (qw(debian/patches debian/source/options
4603 debian/tests/control)) {
4604 next unless stat_exists "../../../$maybe";
4605 push @files, $maybe;
4608 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4609 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4611 $dscaddfile->($debtar);
4612 close $fakedsc or die $!;
4615 sub quilt_check_splitbrain_cache ($$) {
4616 my ($headref, $upstreamversion) = @_;
4617 # Called only if we are in (potentially) split brain mode.
4619 # Computes the cache key and looks in the cache.
4620 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4622 my $splitbrain_cachekey;
4625 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4626 # we look in the reflog of dgit-intern/quilt-cache
4627 # we look for an entry whose message is the key for the cache lookup
4628 my @cachekey = (qw(dgit), $our_version);
4629 push @cachekey, $upstreamversion;
4630 push @cachekey, $quilt_mode;
4631 push @cachekey, $headref;
4633 push @cachekey, hashfile('fake.dsc');
4635 my $srcshash = Digest::SHA->new(256);
4636 my %sfs = ( %INC, '$0(dgit)' => $0 );
4637 foreach my $sfk (sort keys %sfs) {
4638 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4639 $srcshash->add($sfk," ");
4640 $srcshash->add(hashfile($sfs{$sfk}));
4641 $srcshash->add("\n");
4643 push @cachekey, $srcshash->hexdigest();
4644 $splitbrain_cachekey = "@cachekey";
4646 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4648 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4649 debugcmd "|(probably)",@cmd;
4650 my $child = open GC, "-|"; defined $child or die $!;
4652 chdir '../../..' or die $!;
4653 if (!stat ".git/logs/refs/$splitbraincache") {
4654 $! == ENOENT or die $!;
4655 printdebug ">(no reflog)\n";
4662 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4663 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4666 quilt_fixup_mkwork($headref);
4667 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4668 if ($cachehit ne $headref) {
4669 progress "dgit view: found cached ($saved)";
4670 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4672 return ($cachehit, $splitbrain_cachekey);
4674 progress "dgit view: found cached, no changes required";
4675 return ($headref, $splitbrain_cachekey);
4677 die $! if GC->error;
4678 failedcmd unless close GC;
4680 printdebug "splitbrain cache miss\n";
4681 return (undef, $splitbrain_cachekey);
4684 sub quilt_fixup_multipatch ($$$) {
4685 my ($clogp, $headref, $upstreamversion) = @_;
4687 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4690 # - honour any existing .pc in case it has any strangeness
4691 # - determine the git commit corresponding to the tip of
4692 # the patch stack (if there is one)
4693 # - if there is such a git commit, convert each subsequent
4694 # git commit into a quilt patch with dpkg-source --commit
4695 # - otherwise convert all the differences in the tree into
4696 # a single git commit
4700 # Our git tree doesn't necessarily contain .pc. (Some versions of
4701 # dgit would include the .pc in the git tree.) If there isn't
4702 # one, we need to generate one by unpacking the patches that we
4705 # We first look for a .pc in the git tree. If there is one, we
4706 # will use it. (This is not the normal case.)
4708 # Otherwise need to regenerate .pc so that dpkg-source --commit
4709 # can work. We do this as follows:
4710 # 1. Collect all relevant .orig from parent directory
4711 # 2. Generate a debian.tar.gz out of
4712 # debian/{patches,rules,source/format,source/options}
4713 # 3. Generate a fake .dsc containing just these fields:
4714 # Format Source Version Files
4715 # 4. Extract the fake .dsc
4716 # Now the fake .dsc has a .pc directory.
4717 # (In fact we do this in every case, because in future we will
4718 # want to search for a good base commit for generating patches.)
4720 # Then we can actually do the dpkg-source --commit
4721 # 1. Make a new working tree with the same object
4722 # store as our main tree and check out the main
4724 # 2. Copy .pc from the fake's extraction, if necessary
4725 # 3. Run dpkg-source --commit
4726 # 4. If the result has changes to debian/, then
4727 # - git add them them
4728 # - git add .pc if we had a .pc in-tree
4730 # 5. If we had a .pc in-tree, delete it, and git commit
4731 # 6. Back in the main tree, fast forward to the new HEAD
4733 # Another situation we may have to cope with is gbp-style
4734 # patches-unapplied trees.
4736 # We would want to detect these, so we know to escape into
4737 # quilt_fixup_gbp. However, this is in general not possible.
4738 # Consider a package with a one patch which the dgit user reverts
4739 # (with git revert or the moral equivalent).
4741 # That is indistinguishable in contents from a patches-unapplied
4742 # tree. And looking at the history to distinguish them is not
4743 # useful because the user might have made a confusing-looking git
4744 # history structure (which ought to produce an error if dgit can't
4745 # cope, not a silent reintroduction of an unwanted patch).
4747 # So gbp users will have to pass an option. But we can usually
4748 # detect their failure to do so: if the tree is not a clean
4749 # patches-applied tree, quilt linearisation fails, but the tree
4750 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4751 # they want --quilt=unapplied.
4753 # To help detect this, when we are extracting the fake dsc, we
4754 # first extract it with --skip-patches, and then apply the patches
4755 # afterwards with dpkg-source --before-build. That lets us save a
4756 # tree object corresponding to .origs.
4758 my $splitbrain_cachekey;
4760 quilt_make_fake_dsc($upstreamversion);
4762 if (quiltmode_splitbrain()) {
4764 ($cachehit, $splitbrain_cachekey) =
4765 quilt_check_splitbrain_cache($headref, $upstreamversion);
4766 return if $cachehit;
4770 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4772 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4773 rename $fakexdir, "fake" or die "$fakexdir $!";
4777 remove_stray_gits();
4778 mktree_in_ud_here();
4782 runcmd @git, qw(add -Af .);
4783 my $unapplied=git_write_tree();
4784 printdebug "fake orig tree object $unapplied\n";
4788 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4790 if (system @bbcmd) {
4791 failedcmd @bbcmd if $? < 0;
4793 failed to apply your git tree's patch stack (from debian/patches/) to
4794 the corresponding upstream tarball(s). Your source tree and .orig
4795 are probably too inconsistent. dgit can only fix up certain kinds of
4796 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4802 quilt_fixup_mkwork($headref);
4805 if (stat_exists ".pc") {
4807 progress "Tree already contains .pc - will use it then delete it.";
4810 rename '../fake/.pc','.pc' or die $!;
4813 changedir '../fake';
4815 runcmd @git, qw(add -Af .);
4816 my $oldtiptree=git_write_tree();
4817 printdebug "fake o+d/p tree object $unapplied\n";
4818 changedir '../work';
4821 # We calculate some guesswork now about what kind of tree this might
4822 # be. This is mostly for error reporting.
4828 # O = orig, without patches applied
4829 # A = "applied", ie orig with H's debian/patches applied
4830 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4831 \%editedignores, \@unrepres),
4832 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4833 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4837 foreach my $b (qw(01 02)) {
4838 foreach my $v (qw(O2H O2A H2A)) {
4839 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4842 printdebug "differences \@dl @dl.\n";
4845 "$us: base trees orig=%.20s o+d/p=%.20s",
4846 $unapplied, $oldtiptree;
4848 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4849 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4850 $dl[0], $dl[1], $dl[3], $dl[4],
4854 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4856 forceable_fail [qw(unrepresentable)], <<END;
4857 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4862 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4863 push @failsuggestion, "This might be a patches-unapplied branch.";
4864 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4865 push @failsuggestion, "This might be a patches-applied branch.";
4867 push @failsuggestion, "Maybe you need to specify one of".
4868 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4870 if (quiltmode_splitbrain()) {
4871 quiltify_splitbrain($clogp, $unapplied, $headref,
4872 $diffbits, \%editedignores,
4873 $splitbrain_cachekey);
4877 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4878 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4880 if (!open P, '>>', ".pc/applied-patches") {
4881 $!==&ENOENT or die $!;
4886 commit_quilty_patch();
4888 if ($mustdeletepc) {
4889 quilt_fixup_delete_pc();
4893 sub quilt_fixup_editor () {
4894 my $descfn = $ENV{$fakeeditorenv};
4895 my $editing = $ARGV[$#ARGV];
4896 open I1, '<', $descfn or die "$descfn: $!";
4897 open I2, '<', $editing or die "$editing: $!";
4898 unlink $editing or die "$editing: $!";
4899 open O, '>', $editing or die "$editing: $!";
4900 while (<I1>) { print O or die $!; } I1->error and die $!;
4903 $copying ||= m/^\-\-\- /;
4904 next unless $copying;
4907 I2->error and die $!;
4912 sub maybe_apply_patches_dirtily () {
4913 return unless $quilt_mode =~ m/gbp|unapplied/;
4914 print STDERR <<END or die $!;
4916 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4917 dgit: Have to apply the patches - making the tree dirty.
4918 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4921 $patches_applied_dirtily = 01;
4922 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4923 runcmd qw(dpkg-source --before-build .);
4926 sub maybe_unapply_patches_again () {
4927 progress "dgit: Unapplying patches again to tidy up the tree."
4928 if $patches_applied_dirtily;
4929 runcmd qw(dpkg-source --after-build .)
4930 if $patches_applied_dirtily & 01;
4932 if $patches_applied_dirtily & 02;
4933 $patches_applied_dirtily = 0;
4936 #----- other building -----
4938 our $clean_using_builder;
4939 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4940 # clean the tree before building (perhaps invoked indirectly by
4941 # whatever we are using to run the build), rather than separately
4942 # and explicitly by us.
4945 return if $clean_using_builder;
4946 if ($cleanmode eq 'dpkg-source') {
4947 maybe_apply_patches_dirtily();
4948 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4949 } elsif ($cleanmode eq 'dpkg-source-d') {
4950 maybe_apply_patches_dirtily();
4951 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4952 } elsif ($cleanmode eq 'git') {
4953 runcmd_ordryrun_local @git, qw(clean -xdf);
4954 } elsif ($cleanmode eq 'git-ff') {
4955 runcmd_ordryrun_local @git, qw(clean -xdff);
4956 } elsif ($cleanmode eq 'check') {
4957 my $leftovers = cmdoutput @git, qw(clean -xdn);
4958 if (length $leftovers) {
4959 print STDERR $leftovers, "\n" or die $!;
4960 fail "tree contains uncommitted files and --clean=check specified";
4962 } elsif ($cleanmode eq 'none') {
4969 badusage "clean takes no additional arguments" if @ARGV;
4972 maybe_unapply_patches_again();
4975 sub build_prep_early () {
4976 our $build_prep_early_done //= 0;
4977 return if $build_prep_early_done++;
4979 badusage "-p is not allowed when building" if defined $package;
4980 my $clogp = parsechangelog();
4981 $isuite = getfield $clogp, 'Distribution';
4982 $package = getfield $clogp, 'Source';
4983 $version = getfield $clogp, 'Version';
4990 build_maybe_quilt_fixup();
4992 my $pat = changespat $version;
4993 foreach my $f (glob "$buildproductsdir/$pat") {
4995 unlink $f or fail "remove old changes file $f: $!";
4997 progress "would remove $f";
5003 sub changesopts_initial () {
5004 my @opts =@changesopts[1..$#changesopts];
5007 sub changesopts_version () {
5008 if (!defined $changes_since_version) {
5009 my @vsns = archive_query('archive_query');
5010 my @quirk = access_quirk();
5011 if ($quirk[0] eq 'backports') {
5012 local $isuite = $quirk[2];
5014 canonicalise_suite();
5015 push @vsns, archive_query('archive_query');
5018 @vsns = map { $_->[0] } @vsns;
5019 @vsns = sort { -version_compare($a, $b) } @vsns;
5020 $changes_since_version = $vsns[0];
5021 progress "changelog will contain changes since $vsns[0]";
5023 $changes_since_version = '_';
5024 progress "package seems new, not specifying -v<version>";
5027 if ($changes_since_version ne '_') {
5028 return ("-v$changes_since_version");
5034 sub changesopts () {
5035 return (changesopts_initial(), changesopts_version());
5038 sub massage_dbp_args ($;$) {
5039 my ($cmd,$xargs) = @_;
5042 # - if we're going to split the source build out so we can
5043 # do strange things to it, massage the arguments to dpkg-buildpackage
5044 # so that the main build doessn't build source (or add an argument
5045 # to stop it building source by default).
5047 # - add -nc to stop dpkg-source cleaning the source tree,
5048 # unless we're not doing a split build and want dpkg-source
5049 # as cleanmode, in which case we can do nothing
5052 # 0 - source will NOT need to be built separately by caller
5053 # +1 - source will need to be built separately by caller
5054 # +2 - source will need to be built separately by caller AND
5055 # dpkg-buildpackage should not in fact be run at all!
5056 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5057 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5058 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5059 $clean_using_builder = 1;
5062 # -nc has the side effect of specifying -b if nothing else specified
5063 # and some combinations of -S, -b, et al, are errors, rather than
5064 # later simply overriding earlie. So we need to:
5065 # - search the command line for these options
5066 # - pick the last one
5067 # - perhaps add our own as a default
5068 # - perhaps adjust it to the corresponding non-source-building version
5070 foreach my $l ($cmd, $xargs) {
5072 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5075 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5077 if ($need_split_build_invocation) {
5078 printdebug "massage split $dmode.\n";
5079 $r = $dmode =~ m/[S]/ ? +2 :
5080 $dmode =~ y/gGF/ABb/ ? +1 :
5081 $dmode =~ m/[ABb]/ ? 0 :
5084 printdebug "massage done $r $dmode.\n";
5086 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5092 my $wasdir = must_getcwd();
5098 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5099 my ($msg_if_onlyone) = @_;
5100 # If there is only one .changes file, fail with $msg_if_onlyone,
5101 # or if that is undef, be a no-op.
5102 # Returns the changes file to report to the user.
5103 my $pat = changespat $version;
5104 my @changesfiles = glob $pat;
5105 @changesfiles = sort {
5106 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5110 if (@changesfiles==1) {
5111 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5112 only one changes file from build (@changesfiles)
5114 $result = $changesfiles[0];
5115 } elsif (@changesfiles==2) {
5116 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5117 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5118 fail "$l found in binaries changes file $binchanges"
5121 runcmd_ordryrun_local @mergechanges, @changesfiles;
5122 my $multichanges = changespat $version,'multi';
5124 stat_exists $multichanges or fail "$multichanges: $!";
5125 foreach my $cf (glob $pat) {
5126 next if $cf eq $multichanges;
5127 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5130 $result = $multichanges;
5132 fail "wrong number of different changes files (@changesfiles)";
5134 printdone "build successful, results in $result\n" or die $!;
5137 sub midbuild_checkchanges () {
5138 my $pat = changespat $version;
5139 return if $rmchanges;
5140 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5141 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5143 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5144 Suggest you delete @unwanted.
5149 sub midbuild_checkchanges_vanilla ($) {
5151 midbuild_checkchanges() if $wantsrc == 1;
5154 sub postbuild_mergechanges_vanilla ($) {
5156 if ($wantsrc == 1) {
5158 postbuild_mergechanges(undef);
5161 printdone "build successful\n";
5166 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5167 my $wantsrc = massage_dbp_args \@dbp;
5170 midbuild_checkchanges_vanilla $wantsrc;
5175 push @dbp, changesopts_version();
5176 maybe_apply_patches_dirtily();
5177 runcmd_ordryrun_local @dbp;
5179 maybe_unapply_patches_again();
5180 postbuild_mergechanges_vanilla $wantsrc;
5184 $quilt_mode //= 'gbp';
5190 # gbp can make .origs out of thin air. In my tests it does this
5191 # even for a 1.0 format package, with no origs present. So I
5192 # guess it keys off just the version number. We don't know
5193 # exactly what .origs ought to exist, but let's assume that we
5194 # should run gbp if: the version has an upstream part and the main
5196 my $upstreamversion = upstreamversion $version;
5197 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5198 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5200 if ($gbp_make_orig) {
5202 $cleanmode = 'none'; # don't do it again
5203 $need_split_build_invocation = 1;
5206 my @dbp = @dpkgbuildpackage;
5208 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5210 if (!length $gbp_build[0]) {
5211 if (length executable_on_path('git-buildpackage')) {
5212 $gbp_build[0] = qw(git-buildpackage);
5214 $gbp_build[0] = 'gbp buildpackage';
5217 my @cmd = opts_opt_multi_cmd @gbp_build;
5219 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5221 if ($gbp_make_orig) {
5222 ensuredir '.git/dgit';
5223 my $ok = '.git/dgit/origs-gen-ok';
5224 unlink $ok or $!==&ENOENT or die $!;
5225 my @origs_cmd = @cmd;
5226 push @origs_cmd, qw(--git-cleaner=true);
5227 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5228 push @origs_cmd, @ARGV;
5230 debugcmd @origs_cmd;
5232 do { local $!; stat_exists $ok; }
5233 or failedcmd @origs_cmd;
5235 dryrun_report @origs_cmd;
5241 midbuild_checkchanges_vanilla $wantsrc;
5243 if (!$clean_using_builder) {
5244 push @cmd, '--git-cleaner=true';
5248 maybe_unapply_patches_again();
5250 push @cmd, changesopts();
5251 runcmd_ordryrun_local @cmd, @ARGV;
5253 postbuild_mergechanges_vanilla $wantsrc;
5255 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5258 my $our_cleanmode = $cleanmode;
5259 if ($need_split_build_invocation) {
5260 # Pretend that clean is being done some other way. This
5261 # forces us not to try to use dpkg-buildpackage to clean and
5262 # build source all in one go; and instead we run dpkg-source
5263 # (and build_prep() will do the clean since $clean_using_builder
5265 $our_cleanmode = 'ELSEWHERE';
5267 if ($our_cleanmode =~ m/^dpkg-source/) {
5268 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5269 $clean_using_builder = 1;
5272 $sourcechanges = changespat $version,'source';
5274 unlink "../$sourcechanges" or $!==ENOENT
5275 or fail "remove $sourcechanges: $!";
5277 $dscfn = dscfn($version);
5278 if ($our_cleanmode eq 'dpkg-source') {
5279 maybe_apply_patches_dirtily();
5280 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5282 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5283 maybe_apply_patches_dirtily();
5284 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5287 my @cmd = (@dpkgsource, qw(-b --));
5290 runcmd_ordryrun_local @cmd, "work";
5291 my @udfiles = <${package}_*>;
5292 changedir "../../..";
5293 foreach my $f (@udfiles) {
5294 printdebug "source copy, found $f\n";
5297 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5298 $f eq srcfn($version, $&));
5299 printdebug "source copy, found $f - renaming\n";
5300 rename "$ud/$f", "../$f" or $!==ENOENT
5301 or fail "put in place new source file ($f): $!";
5304 my $pwd = must_getcwd();
5305 my $leafdir = basename $pwd;
5307 runcmd_ordryrun_local @cmd, $leafdir;
5310 runcmd_ordryrun_local qw(sh -ec),
5311 'exec >$1; shift; exec "$@"','x',
5312 "../$sourcechanges",
5313 @dpkggenchanges, qw(-S), changesopts();
5317 sub cmd_build_source {
5318 badusage "build-source takes no additional arguments" if @ARGV;
5320 maybe_unapply_patches_again();
5321 printdone "source built, results in $dscfn and $sourcechanges";
5326 midbuild_checkchanges();
5329 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5330 stat_exists $sourcechanges
5331 or fail "$sourcechanges (in parent directory): $!";
5333 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5335 maybe_unapply_patches_again();
5337 postbuild_mergechanges(<<END);
5338 perhaps you need to pass -A ? (sbuild's default is to build only
5339 arch-specific binaries; dgit 1.4 used to override that.)
5344 sub cmd_quilt_fixup {
5345 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5346 my $clogp = parsechangelog();
5347 $version = getfield $clogp, 'Version';
5348 $package = getfield $clogp, 'Source';
5351 build_maybe_quilt_fixup();
5354 sub cmd_import_dsc {
5358 last unless $ARGV[0] =~ m/^-/;
5361 if (m/^--require-valid-signature$/) {
5364 badusage "unknown dgit import-dsc sub-option \`$_'";
5368 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5369 my ($dscfn, $dstbranch) = @ARGV;
5371 badusage "dry run makes no sense with import-dsc" unless act_local();
5373 my $force = $dstbranch =~ s/^\+// ? +1 :
5374 $dstbranch =~ s/^\.\.// ? -1 :
5376 my $info = $force ? " $&" : '';
5377 $info = "$dscfn$info";
5379 my $specbranch = $dstbranch;
5380 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5381 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5383 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5384 my $chead = cmdoutput_errok @symcmd;
5385 defined $chead or $?==256 or failedcmd @symcmd;
5387 fail "$dstbranch is checked out - will not update it"
5388 if defined $chead and $chead eq $dstbranch;
5390 my $oldhash = git_get_ref $dstbranch;
5392 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5393 $dscdata = do { local $/ = undef; <D>; };
5394 D->error and fail "read $dscfn: $!";
5397 # we don't normally need this so import it here
5398 use Dpkg::Source::Package;
5399 my $dp = new Dpkg::Source::Package filename => $dscfn,
5400 require_valid_signature => $needsig;
5402 local $SIG{__WARN__} = sub {
5404 return unless $needsig;
5405 fail "import-dsc signature check failed";
5407 if (!$dp->is_signed()) {
5408 warn "$us: warning: importing unsigned .dsc\n";
5410 my $r = $dp->check_signature();
5411 die "->check_signature => $r" if $needsig && $r;
5417 my $dgit_commit = $dsc->{$ourdscfield[0]};
5418 if (defined $dgit_commit &&
5419 !forceing [qw(import-dsc-with-dgit-field)]) {
5420 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5421 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5422 my @cmd = (qw(sh -ec),
5423 "echo $dgit_commit | git cat-file --batch-check");
5424 my $objgot = cmdoutput @cmd;
5425 if ($objgot =~ m#^\w+ missing\b#) {
5427 .dsc contains Dgit field referring to object $dgit_commit
5428 Your git tree does not have that object. Try `git fetch' from a
5429 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5432 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5434 progress "Not fast forward, forced update.";
5436 fail "Not fast forward to $dgit_commit";
5439 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5440 $dstbranch, $dgit_commit);
5442 progress "dgit: import-dsc updated git ref $dstbranch";
5447 Branch $dstbranch already exists
5448 Specify ..$specbranch for a pseudo-merge, binding in existing history
5449 Specify +$specbranch to overwrite, discarding existing history
5451 if $oldhash && !$force;
5453 $package = getfield $dsc, 'Source';
5454 my @dfi = dsc_files_info();
5455 foreach my $fi (@dfi) {
5456 my $f = $fi->{Filename};
5458 next if lstat $here;
5459 fail "stat $here: $!" unless $! == ENOENT;
5461 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5463 } elsif ($dscfn =~ m#^/#) {
5466 fail "cannot import $dscfn which seems to be inside working tree!";
5468 $there =~ s#/+[^/]+$## or
5469 fail "cannot import $dscfn which seems to not have a basename";
5471 symlink $there, $here or fail "symlink $there to $here: $!";
5472 progress "made symlink $here -> $there";
5473 print STDERR Dumper($fi);
5475 my @mergeinputs = generate_commits_from_dsc();
5476 die unless @mergeinputs == 1;
5478 my $newhash = $mergeinputs[0]{Commit};
5482 progress "Import, forced update - synthetic orphan git history.";
5483 } elsif ($force < 0) {
5484 progress "Import, merging.";
5485 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5486 my $version = getfield $dsc, 'Version';
5487 $newhash = make_commit_text <<END;
5492 Merge $package ($version) import into $dstbranch
5495 die; # caught earlier
5499 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5500 $dstbranch, $newhash);
5502 progress "dgit: import-dsc results are in in git ref $dstbranch";
5505 sub cmd_archive_api_query {
5506 badusage "need only 1 subpath argument" unless @ARGV==1;
5507 my ($subpath) = @ARGV;
5508 my @cmd = archive_api_query_cmd($subpath);
5511 exec @cmd or fail "exec curl: $!\n";
5514 sub cmd_clone_dgit_repos_server {
5515 badusage "need destination argument" unless @ARGV==1;
5516 my ($destdir) = @ARGV;
5517 $package = '_dgit-repos-server';
5518 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5520 exec @cmd or fail "exec git clone: $!\n";
5523 sub cmd_setup_mergechangelogs {
5524 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5525 setup_mergechangelogs(1);
5528 sub cmd_setup_useremail {
5529 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5533 sub cmd_setup_new_tree {
5534 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5538 #---------- argument parsing and main program ----------
5541 print "dgit version $our_version\n" or die $!;
5545 our (%valopts_long, %valopts_short);
5548 sub defvalopt ($$$$) {
5549 my ($long,$short,$val_re,$how) = @_;
5550 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5551 $valopts_long{$long} = $oi;
5552 $valopts_short{$short} = $oi;
5553 # $how subref should:
5554 # do whatever assignemnt or thing it likes with $_[0]
5555 # if the option should not be passed on to remote, @rvalopts=()
5556 # or $how can be a scalar ref, meaning simply assign the value
5559 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5560 defvalopt '--distro', '-d', '.+', \$idistro;
5561 defvalopt '', '-k', '.+', \$keyid;
5562 defvalopt '--existing-package','', '.*', \$existing_package;
5563 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5564 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5565 defvalopt '--package', '-p', $package_re, \$package;
5566 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5568 defvalopt '', '-C', '.+', sub {
5569 ($changesfile) = (@_);
5570 if ($changesfile =~ s#^(.*)/##) {
5571 $buildproductsdir = $1;
5575 defvalopt '--initiator-tempdir','','.*', sub {
5576 ($initiator_tempdir) = (@_);
5577 $initiator_tempdir =~ m#^/# or
5578 badusage "--initiator-tempdir must be used specify an".
5579 " absolute, not relative, directory."
5585 if (defined $ENV{'DGIT_SSH'}) {
5586 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5587 } elsif (defined $ENV{'GIT_SSH'}) {
5588 @ssh = ($ENV{'GIT_SSH'});
5596 if (!defined $val) {
5597 badusage "$what needs a value" unless @ARGV;
5599 push @rvalopts, $val;
5601 badusage "bad value \`$val' for $what" unless
5602 $val =~ m/^$oi->{Re}$(?!\n)/s;
5603 my $how = $oi->{How};
5604 if (ref($how) eq 'SCALAR') {
5609 push @ropts, @rvalopts;
5613 last unless $ARGV[0] =~ m/^-/;
5617 if (m/^--dry-run$/) {
5620 } elsif (m/^--damp-run$/) {
5623 } elsif (m/^--no-sign$/) {
5626 } elsif (m/^--help$/) {
5628 } elsif (m/^--version$/) {
5630 } elsif (m/^--new$/) {
5633 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5634 ($om = $opts_opt_map{$1}) &&
5638 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5639 !$opts_opt_cmdonly{$1} &&
5640 ($om = $opts_opt_map{$1})) {
5643 } elsif (m/^--(gbp|dpm)$/s) {
5644 push @ropts, "--quilt=$1";
5646 } elsif (m/^--ignore-dirty$/s) {
5649 } elsif (m/^--no-quilt-fixup$/s) {
5651 $quilt_mode = 'nocheck';
5652 } elsif (m/^--no-rm-on-error$/s) {
5655 } elsif (m/^--overwrite$/s) {
5657 $overwrite_version = '';
5658 } elsif (m/^--overwrite=(.+)$/s) {
5660 $overwrite_version = $1;
5661 } elsif (m/^--delayed=(\d+)$/s) {
5664 } elsif (m/^--dgit-view-save=(.+)$/s) {
5666 $split_brain_save = $1;
5667 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5668 } elsif (m/^--(no-)?rm-old-changes$/s) {
5671 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5673 push @deliberatelies, $&;
5674 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5678 } elsif (m/^--force-/) {
5680 "$us: warning: ignoring unknown force option $_\n";
5682 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5683 # undocumented, for testing
5685 $tagformat_want = [ $1, 'command line', 1 ];
5686 # 1 menas overrides distro configuration
5687 } elsif (m/^--always-split-source-build$/s) {
5688 # undocumented, for testing
5690 $need_split_build_invocation = 1;
5691 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5692 $val = $2 ? $' : undef; #';
5693 $valopt->($oi->{Long});
5695 badusage "unknown long option \`$_'";
5702 } elsif (s/^-L/-/) {
5705 } elsif (s/^-h/-/) {
5707 } elsif (s/^-D/-/) {
5711 } elsif (s/^-N/-/) {
5716 push @changesopts, $_;
5718 } elsif (s/^-wn$//s) {
5720 $cleanmode = 'none';
5721 } elsif (s/^-wg$//s) {
5724 } elsif (s/^-wgf$//s) {
5726 $cleanmode = 'git-ff';
5727 } elsif (s/^-wd$//s) {
5729 $cleanmode = 'dpkg-source';
5730 } elsif (s/^-wdd$//s) {
5732 $cleanmode = 'dpkg-source-d';
5733 } elsif (s/^-wc$//s) {
5735 $cleanmode = 'check';
5736 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5737 push @git, '-c', $&;
5738 $gitcfgs{cmdline}{$1} = [ $2 ];
5739 } elsif (s/^-c([^=]+)$//s) {
5740 push @git, '-c', $&;
5741 $gitcfgs{cmdline}{$1} = [ 'true' ];
5742 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5744 $val = undef unless length $val;
5745 $valopt->($oi->{Short});
5748 badusage "unknown short option \`$_'";
5755 sub check_env_sanity () {
5756 my $blocked = new POSIX::SigSet;
5757 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5760 foreach my $name (qw(PIPE CHLD)) {
5761 my $signame = "SIG$name";
5762 my $signum = eval "POSIX::$signame" // die;
5763 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5764 die "$signame is set to something other than SIG_DFL\n";
5765 $blocked->ismember($signum) and
5766 die "$signame is blocked\n";
5772 On entry to dgit, $@
5773 This is a bug produced by something in in your execution environment.
5779 sub finalise_opts_opts () {
5780 foreach my $k (keys %opts_opt_map) {
5781 my $om = $opts_opt_map{$k};
5783 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5785 badcfg "cannot set command for $k"
5786 unless length $om->[0];
5790 foreach my $c (access_cfg_cfgs("opts-$k")) {
5792 map { $_ ? @$_ : () }
5793 map { $gitcfgs{$_}{$c} }
5794 reverse @gitcfgsources;
5795 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5796 "\n" if $debuglevel >= 4;
5798 badcfg "cannot configure options for $k"
5799 if $opts_opt_cmdonly{$k};
5800 my $insertpos = $opts_cfg_insertpos{$k};
5801 @$om = ( @$om[0..$insertpos-1],
5803 @$om[$insertpos..$#$om] );
5808 if ($ENV{$fakeeditorenv}) {
5810 quilt_fixup_editor();
5817 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5818 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5819 if $dryrun_level == 1;
5821 print STDERR $helpmsg or die $!;
5824 my $cmd = shift @ARGV;
5827 my $pre_fn = ${*::}{"pre_$cmd"};
5828 $pre_fn->() if $pre_fn;
5830 if (!defined $rmchanges) {
5831 local $access_forpush;
5832 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5835 if (!defined $quilt_mode) {
5836 local $access_forpush;
5837 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5838 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5840 $quilt_mode =~ m/^($quilt_modes_re)$/
5841 or badcfg "unknown quilt-mode \`$quilt_mode'";
5845 $need_split_build_invocation ||= quiltmode_splitbrain();
5847 if (!defined $cleanmode) {
5848 local $access_forpush;
5849 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5850 $cleanmode //= 'dpkg-source';
5852 badcfg "unknown clean-mode \`$cleanmode'" unless
5853 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5856 my $fn = ${*::}{"cmd_$cmd"};
5857 $fn or badusage "unknown operation $cmd";