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 my $specre = join '|', map {
2301 printdebug "git_fetch_us specre=$specre\n";
2302 my $wanted_rref = sub {
2304 return m/^(?:$specre)$/o;
2307 my $fetch_iteration = 0;
2310 if (++$fetch_iteration > 10) {
2311 fail "too many iterations trying to get sane fetch!";
2314 my @look = map { "refs/$_" } @specs;
2315 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2319 open GITLS, "-|", @lcmd or die $!;
2321 printdebug "=> ", $_;
2322 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2323 my ($objid,$rrefname) = ($1,$2);
2324 if (!$wanted_rref->($rrefname)) {
2326 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2330 $wantr{$rrefname} = $objid;
2333 close GITLS or failedcmd @lcmd;
2335 # OK, now %want is exactly what we want for refs in @specs
2337 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2338 "+refs/$_:".lrfetchrefs."/$_";
2341 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2342 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2345 %lrfetchrefs_f = ();
2348 git_for_each_ref(lrfetchrefs, sub {
2349 my ($objid,$objtype,$lrefname,$reftail) = @_;
2350 $lrfetchrefs_f{$lrefname} = $objid;
2351 $objgot{$objid} = 1;
2354 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2355 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2356 if (!exists $wantr{$rrefname}) {
2357 if ($wanted_rref->($rrefname)) {
2359 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2363 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2366 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2367 delete $lrfetchrefs_f{$lrefname};
2371 foreach my $rrefname (sort keys %wantr) {
2372 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2373 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2374 my $want = $wantr{$rrefname};
2375 next if $got eq $want;
2376 if (!defined $objgot{$want}) {
2378 warning: git ls-remote suggests we want $lrefname
2379 warning: and it should refer to $want
2380 warning: but git fetch didn't fetch that object to any relevant ref.
2381 warning: This may be due to a race with someone updating the server.
2382 warning: Will try again...
2384 next FETCH_ITERATION;
2387 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2389 runcmd_ordryrun_local @git, qw(update-ref -m),
2390 "dgit fetch git fetch fixup", $lrefname, $want;
2391 $lrfetchrefs_f{$lrefname} = $want;
2395 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2396 Dumper(\%lrfetchrefs_f);
2399 my @tagpats = debiantags('*',access_basedistro);
2401 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2402 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2403 printdebug "currently $fullrefname=$objid\n";
2404 $here{$fullrefname} = $objid;
2406 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2408 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2409 printdebug "offered $lref=$objid\n";
2410 if (!defined $here{$lref}) {
2411 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2412 runcmd_ordryrun_local @upd;
2413 lrfetchref_used $fullrefname;
2414 } elsif ($here{$lref} eq $objid) {
2415 lrfetchref_used $fullrefname;
2418 "Not updateting $lref from $here{$lref} to $objid.\n";
2423 sub mergeinfo_getclogp ($) {
2424 # Ensures thit $mi->{Clogp} exists and returns it
2426 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2429 sub mergeinfo_version ($) {
2430 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2433 sub fetch_from_archive () {
2434 ensure_setup_existing_tree();
2436 # Ensures that lrref() is what is actually in the archive, one way
2437 # or another, according to us - ie this client's
2438 # appropritaely-updated archive view. Also returns the commit id.
2439 # If there is nothing in the archive, leaves lrref alone and
2440 # returns undef. git_fetch_us must have already been called.
2444 foreach my $field (@ourdscfield) {
2445 $dsc_hash = $dsc->{$field};
2446 last if defined $dsc_hash;
2448 if (defined $dsc_hash) {
2449 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2451 progress "last upload to archive specified git hash";
2453 progress "last upload to archive has NO git hash";
2456 progress "no version available from the archive";
2459 # If the archive's .dsc has a Dgit field, there are three
2460 # relevant git commitids we need to choose between and/or merge
2462 # 1. $dsc_hash: the Dgit field from the archive
2463 # 2. $lastpush_hash: the suite branch on the dgit git server
2464 # 3. $lastfetch_hash: our local tracking brach for the suite
2466 # These may all be distinct and need not be in any fast forward
2469 # If the dsc was pushed to this suite, then the server suite
2470 # branch will have been updated; but it might have been pushed to
2471 # a different suite and copied by the archive. Conversely a more
2472 # recent version may have been pushed with dgit but not appeared
2473 # in the archive (yet).
2475 # $lastfetch_hash may be awkward because archive imports
2476 # (particularly, imports of Dgit-less .dscs) are performed only as
2477 # needed on individual clients, so different clients may perform a
2478 # different subset of them - and these imports are only made
2479 # public during push. So $lastfetch_hash may represent a set of
2480 # imports different to a subsequent upload by a different dgit
2483 # Our approach is as follows:
2485 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2486 # descendant of $dsc_hash, then it was pushed by a dgit user who
2487 # had based their work on $dsc_hash, so we should prefer it.
2488 # Otherwise, $dsc_hash was installed into this suite in the
2489 # archive other than by a dgit push, and (necessarily) after the
2490 # last dgit push into that suite (since a dgit push would have
2491 # been descended from the dgit server git branch); thus, in that
2492 # case, we prefer the archive's version (and produce a
2493 # pseudo-merge to overwrite the dgit server git branch).
2495 # (If there is no Dgit field in the archive's .dsc then
2496 # generate_commit_from_dsc uses the version numbers to decide
2497 # whether the suite branch or the archive is newer. If the suite
2498 # branch is newer it ignores the archive's .dsc; otherwise it
2499 # generates an import of the .dsc, and produces a pseudo-merge to
2500 # overwrite the suite branch with the archive contents.)
2502 # The outcome of that part of the algorithm is the `public view',
2503 # and is same for all dgit clients: it does not depend on any
2504 # unpublished history in the local tracking branch.
2506 # As between the public view and the local tracking branch: The
2507 # local tracking branch is only updated by dgit fetch, and
2508 # whenever dgit fetch runs it includes the public view in the
2509 # local tracking branch. Therefore if the public view is not
2510 # descended from the local tracking branch, the local tracking
2511 # branch must contain history which was imported from the archive
2512 # but never pushed; and, its tip is now out of date. So, we make
2513 # a pseudo-merge to overwrite the old imports and stitch the old
2516 # Finally: we do not necessarily reify the public view (as
2517 # described above). This is so that we do not end up stacking two
2518 # pseudo-merges. So what we actually do is figure out the inputs
2519 # to any public view pseudo-merge and put them in @mergeinputs.
2522 # $mergeinputs[]{Commit}
2523 # $mergeinputs[]{Info}
2524 # $mergeinputs[0] is the one whose tree we use
2525 # @mergeinputs is in the order we use in the actual commit)
2528 # $mergeinputs[]{Message} is a commit message to use
2529 # $mergeinputs[]{ReverseParents} if def specifies that parent
2530 # list should be in opposite order
2531 # Such an entry has no Commit or Info. It applies only when found
2532 # in the last entry. (This ugliness is to support making
2533 # identical imports to previous dgit versions.)
2535 my $lastpush_hash = git_get_ref(lrfetchref());
2536 printdebug "previous reference hash=$lastpush_hash\n";
2537 $lastpush_mergeinput = $lastpush_hash && {
2538 Commit => $lastpush_hash,
2539 Info => "dgit suite branch on dgit git server",
2542 my $lastfetch_hash = git_get_ref(lrref());
2543 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2544 my $lastfetch_mergeinput = $lastfetch_hash && {
2545 Commit => $lastfetch_hash,
2546 Info => "dgit client's archive history view",
2549 my $dsc_mergeinput = $dsc_hash && {
2550 Commit => $dsc_hash,
2551 Info => "Dgit field in .dsc from archive",
2555 my $del_lrfetchrefs = sub {
2558 printdebug "del_lrfetchrefs...\n";
2559 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2560 my $objid = $lrfetchrefs_d{$fullrefname};
2561 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2563 $gur ||= new IO::Handle;
2564 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2566 printf $gur "delete %s %s\n", $fullrefname, $objid;
2569 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2573 if (defined $dsc_hash) {
2574 fail "missing remote git history even though dsc has hash -".
2575 " could not find ref ".rref()." at ".access_giturl()
2576 unless $lastpush_hash;
2577 ensure_we_have_orig();
2578 if ($dsc_hash eq $lastpush_hash) {
2579 @mergeinputs = $dsc_mergeinput
2580 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2581 print STDERR <<END or die $!;
2583 Git commit in archive is behind the last version allegedly pushed/uploaded.
2584 Commit referred to by archive: $dsc_hash
2585 Last version pushed with dgit: $lastpush_hash
2588 @mergeinputs = ($lastpush_mergeinput);
2590 # Archive has .dsc which is not a descendant of the last dgit
2591 # push. This can happen if the archive moves .dscs about.
2592 # Just follow its lead.
2593 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2594 progress "archive .dsc names newer git commit";
2595 @mergeinputs = ($dsc_mergeinput);
2597 progress "archive .dsc names other git commit, fixing up";
2598 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2602 @mergeinputs = generate_commits_from_dsc();
2603 # We have just done an import. Now, our import algorithm might
2604 # have been improved. But even so we do not want to generate
2605 # a new different import of the same package. So if the
2606 # version numbers are the same, just use our existing version.
2607 # If the version numbers are different, the archive has changed
2608 # (perhaps, rewound).
2609 if ($lastfetch_mergeinput &&
2610 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2611 (mergeinfo_version $mergeinputs[0]) )) {
2612 @mergeinputs = ($lastfetch_mergeinput);
2614 } elsif ($lastpush_hash) {
2615 # only in git, not in the archive yet
2616 @mergeinputs = ($lastpush_mergeinput);
2617 print STDERR <<END or die $!;
2619 Package not found in the archive, but has allegedly been pushed using dgit.
2623 printdebug "nothing found!\n";
2624 if (defined $skew_warning_vsn) {
2625 print STDERR <<END or die $!;
2627 Warning: relevant archive skew detected.
2628 Archive allegedly contains $skew_warning_vsn
2629 But we were not able to obtain any version from the archive or git.
2633 unshift @end, $del_lrfetchrefs;
2637 if ($lastfetch_hash &&
2639 my $h = $_->{Commit};
2640 $h and is_fast_fwd($lastfetch_hash, $h);
2641 # If true, one of the existing parents of this commit
2642 # is a descendant of the $lastfetch_hash, so we'll
2643 # be ff from that automatically.
2647 push @mergeinputs, $lastfetch_mergeinput;
2650 printdebug "fetch mergeinfos:\n";
2651 foreach my $mi (@mergeinputs) {
2653 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2655 printdebug sprintf " ReverseParents=%d Message=%s",
2656 $mi->{ReverseParents}, $mi->{Message};
2660 my $compat_info= pop @mergeinputs
2661 if $mergeinputs[$#mergeinputs]{Message};
2663 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2666 if (@mergeinputs > 1) {
2668 my $tree_commit = $mergeinputs[0]{Commit};
2670 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2671 $tree =~ m/\n\n/; $tree = $`;
2672 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2675 # We use the changelog author of the package in question the
2676 # author of this pseudo-merge. This is (roughly) correct if
2677 # this commit is simply representing aa non-dgit upload.
2678 # (Roughly because it does not record sponsorship - but we
2679 # don't have sponsorship info because that's in the .changes,
2680 # which isn't in the archivw.)
2682 # But, it might be that we are representing archive history
2683 # updates (including in-archive copies). These are not really
2684 # the responsibility of the person who created the .dsc, but
2685 # there is no-one whose name we should better use. (The
2686 # author of the .dsc-named commit is clearly worse.)
2688 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2689 my $author = clogp_authline $useclogp;
2690 my $cversion = getfield $useclogp, 'Version';
2692 my $mcf = ".git/dgit/mergecommit";
2693 open MC, ">", $mcf or die "$mcf $!";
2694 print MC <<END or die $!;
2698 my @parents = grep { $_->{Commit} } @mergeinputs;
2699 @parents = reverse @parents if $compat_info->{ReverseParents};
2700 print MC <<END or die $! foreach @parents;
2704 print MC <<END or die $!;
2710 if (defined $compat_info->{Message}) {
2711 print MC $compat_info->{Message} or die $!;
2713 print MC <<END or die $!;
2714 Record $package ($cversion) in archive suite $csuite
2718 my $message_add_info = sub {
2720 my $mversion = mergeinfo_version $mi;
2721 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2725 $message_add_info->($mergeinputs[0]);
2726 print MC <<END or die $!;
2727 should be treated as descended from
2729 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2733 $hash = make_commit $mcf;
2735 $hash = $mergeinputs[0]{Commit};
2737 printdebug "fetch hash=$hash\n";
2740 my ($lasth, $what) = @_;
2741 return unless $lasth;
2742 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2745 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2746 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2748 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2749 'DGIT_ARCHIVE', $hash;
2750 cmdoutput @git, qw(log -n2), $hash;
2751 # ... gives git a chance to complain if our commit is malformed
2753 if (defined $skew_warning_vsn) {
2755 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2756 my $gotclogp = commit_getclogp($hash);
2757 my $got_vsn = getfield $gotclogp, 'Version';
2758 printdebug "SKEW CHECK GOT $got_vsn\n";
2759 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2760 print STDERR <<END or die $!;
2762 Warning: archive skew detected. Using the available version:
2763 Archive allegedly contains $skew_warning_vsn
2764 We were able to obtain only $got_vsn
2770 if ($lastfetch_hash ne $hash) {
2771 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2775 dryrun_report @upd_cmd;
2779 lrfetchref_used lrfetchref();
2781 unshift @end, $del_lrfetchrefs;
2785 sub set_local_git_config ($$) {
2787 runcmd @git, qw(config), $k, $v;
2790 sub setup_mergechangelogs (;$) {
2792 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2794 my $driver = 'dpkg-mergechangelogs';
2795 my $cb = "merge.$driver";
2796 my $attrs = '.git/info/attributes';
2797 ensuredir '.git/info';
2799 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2800 if (!open ATTRS, "<", $attrs) {
2801 $!==ENOENT or die "$attrs: $!";
2805 next if m{^debian/changelog\s};
2806 print NATTRS $_, "\n" or die $!;
2808 ATTRS->error and die $!;
2811 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2814 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2815 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2817 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2820 sub setup_useremail (;$) {
2822 return unless $always || access_cfg_bool(1, 'setup-useremail');
2825 my ($k, $envvar) = @_;
2826 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2827 return unless defined $v;
2828 set_local_git_config "user.$k", $v;
2831 $setup->('email', 'DEBEMAIL');
2832 $setup->('name', 'DEBFULLNAME');
2835 sub ensure_setup_existing_tree () {
2836 my $k = "remote.$remotename.skipdefaultupdate";
2837 my $c = git_get_config $k;
2838 return if defined $c;
2839 set_local_git_config $k, 'true';
2842 sub setup_new_tree () {
2843 setup_mergechangelogs();
2849 canonicalise_suite();
2850 badusage "dry run makes no sense with clone" unless act_local();
2851 my $hasgit = check_for_git();
2852 mkdir $dstdir or fail "create \`$dstdir': $!";
2854 runcmd @git, qw(init -q);
2855 my $giturl = access_giturl(1);
2856 if (defined $giturl) {
2857 open H, "> .git/HEAD" or die $!;
2858 print H "ref: ".lref()."\n" or die $!;
2860 runcmd @git, qw(remote add), 'origin', $giturl;
2863 progress "fetching existing git history";
2865 runcmd_ordryrun_local @git, qw(fetch origin);
2867 progress "starting new git history";
2869 fetch_from_archive() or no_such_package;
2870 my $vcsgiturl = $dsc->{'Vcs-Git'};
2871 if (length $vcsgiturl) {
2872 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2873 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2876 runcmd @git, qw(reset --hard), lrref();
2877 runcmd qw(bash -ec), <<'END';
2879 git ls-tree -r --name-only -z HEAD | \
2880 xargs -0r touch -r . --
2882 printdone "ready for work in $dstdir";
2886 if (check_for_git()) {
2889 fetch_from_archive() or no_such_package();
2890 printdone "fetched into ".lrref();
2895 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2897 printdone "fetched to ".lrref()." and merged into HEAD";
2900 sub check_not_dirty () {
2901 foreach my $f (qw(local-options local-patch-header)) {
2902 if (stat_exists "debian/source/$f") {
2903 fail "git tree contains debian/source/$f";
2907 return if $ignoredirty;
2909 my @cmd = (@git, qw(diff --quiet HEAD));
2911 $!=0; $?=-1; system @cmd;
2914 fail "working tree is dirty (does not match HEAD)";
2920 sub commit_admin ($) {
2923 runcmd_ordryrun_local @git, qw(commit -m), $m;
2926 sub commit_quilty_patch () {
2927 my $output = cmdoutput @git, qw(status --porcelain);
2929 foreach my $l (split /\n/, $output) {
2930 next unless $l =~ m/\S/;
2931 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2935 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2937 progress "nothing quilty to commit, ok.";
2940 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2941 runcmd_ordryrun_local @git, qw(add -f), @adds;
2943 Commit Debian 3.0 (quilt) metadata
2945 [dgit ($our_version) quilt-fixup]
2949 sub get_source_format () {
2951 if (open F, "debian/source/options") {
2955 s/\s+$//; # ignore missing final newline
2957 my ($k, $v) = ($`, $'); #');
2958 $v =~ s/^"(.*)"$/$1/;
2964 F->error and die $!;
2967 die $! unless $!==&ENOENT;
2970 if (!open F, "debian/source/format") {
2971 die $! unless $!==&ENOENT;
2975 F->error and die $!;
2977 return ($_, \%options);
2980 sub madformat_wantfixup ($) {
2982 return 0 unless $format eq '3.0 (quilt)';
2983 our $quilt_mode_warned;
2984 if ($quilt_mode eq 'nocheck') {
2985 progress "Not doing any fixup of \`$format' due to".
2986 " ----no-quilt-fixup or --quilt=nocheck"
2987 unless $quilt_mode_warned++;
2990 progress "Format \`$format', need to check/update patch stack"
2991 unless $quilt_mode_warned++;
2995 sub maybe_split_brain_save ($$$) {
2996 my ($headref, $dgitview, $msg) = @_;
2997 # => message fragment "$saved" describing disposition of $dgitview
2998 return "commit id $dgitview" unless defined $split_brain_save;
2999 my @cmd = (shell_cmd "cd ../../../..",
3000 @git, qw(update-ref -m),
3001 "dgit --dgit-view-save $msg HEAD=$headref",
3002 $split_brain_save, $dgitview);
3004 return "and left in $split_brain_save";
3007 # An "infopair" is a tuple [ $thing, $what ]
3008 # (often $thing is a commit hash; $what is a description)
3010 sub infopair_cond_equal ($$) {
3012 $x->[0] eq $y->[0] or fail <<END;
3013 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3017 sub infopair_lrf_tag_lookup ($$) {
3018 my ($tagnames, $what) = @_;
3019 # $tagname may be an array ref
3020 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3021 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3022 foreach my $tagname (@tagnames) {
3023 my $lrefname = lrfetchrefs."/tags/$tagname";
3024 my $tagobj = $lrfetchrefs_f{$lrefname};
3025 next unless defined $tagobj;
3026 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3027 return [ git_rev_parse($tagobj), $what ];
3029 fail @tagnames==1 ? <<END : <<END;
3030 Wanted tag $what (@tagnames) on dgit server, but not found
3032 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3036 sub infopair_cond_ff ($$) {
3037 my ($anc,$desc) = @_;
3038 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3039 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3043 sub pseudomerge_version_check ($$) {
3044 my ($clogp, $archive_hash) = @_;
3046 my $arch_clogp = commit_getclogp $archive_hash;
3047 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3048 'version currently in archive' ];
3049 if (defined $overwrite_version) {
3050 if (length $overwrite_version) {
3051 infopair_cond_equal([ $overwrite_version,
3052 '--overwrite= version' ],
3055 my $v = $i_arch_v->[0];
3056 progress "Checking package changelog for archive version $v ...";
3058 my @xa = ("-f$v", "-t$v");
3059 my $vclogp = parsechangelog @xa;
3060 my $cv = [ (getfield $vclogp, 'Version'),
3061 "Version field from dpkg-parsechangelog @xa" ];
3062 infopair_cond_equal($i_arch_v, $cv);
3065 $@ =~ s/^dgit: //gm;
3067 "Perhaps debian/changelog does not mention $v ?";
3072 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3076 sub pseudomerge_make_commit ($$$$ $$) {
3077 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3078 $msg_cmd, $msg_msg) = @_;
3079 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3081 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3082 my $authline = clogp_authline $clogp;
3086 !defined $overwrite_version ? ""
3087 : !length $overwrite_version ? " --overwrite"
3088 : " --overwrite=".$overwrite_version;
3091 my $pmf = ".git/dgit/pseudomerge";
3092 open MC, ">", $pmf or die "$pmf $!";
3093 print MC <<END or die $!;
3096 parent $archive_hash
3106 return make_commit($pmf);
3109 sub splitbrain_pseudomerge ($$$$) {
3110 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3111 # => $merged_dgitview
3112 printdebug "splitbrain_pseudomerge...\n";
3114 # We: debian/PREVIOUS HEAD($maintview)
3115 # expect: o ----------------- o
3118 # a/d/PREVIOUS $dgitview
3121 # we do: `------------------ o
3125 return $dgitview unless defined $archive_hash;
3127 printdebug "splitbrain_pseudomerge...\n";
3129 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3131 if (!defined $overwrite_version) {
3132 progress "Checking that HEAD inciudes all changes in archive...";
3135 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3137 if (defined $overwrite_version) {
3139 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3140 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3141 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3142 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3143 my $i_archive = [ $archive_hash, "current archive contents" ];
3145 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3147 infopair_cond_equal($i_dgit, $i_archive);
3148 infopair_cond_ff($i_dep14, $i_dgit);
3149 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3153 $us: check failed (maybe --overwrite is needed, consult documentation)
3158 my $r = pseudomerge_make_commit
3159 $clogp, $dgitview, $archive_hash, $i_arch_v,
3160 "dgit --quilt=$quilt_mode",
3161 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3162 Declare fast forward from $i_arch_v->[0]
3164 Make fast forward from $i_arch_v->[0]
3167 maybe_split_brain_save $maintview, $r, "pseudomerge";
3169 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3173 sub plain_overwrite_pseudomerge ($$$) {
3174 my ($clogp, $head, $archive_hash) = @_;
3176 printdebug "plain_overwrite_pseudomerge...";
3178 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3180 return $head if is_fast_fwd $archive_hash, $head;
3182 my $m = "Declare fast forward from $i_arch_v->[0]";
3184 my $r = pseudomerge_make_commit
3185 $clogp, $head, $archive_hash, $i_arch_v,
3188 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3190 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3194 sub push_parse_changelog ($) {
3197 my $clogp = Dpkg::Control::Hash->new();
3198 $clogp->load($clogpfn) or die;
3200 $package = getfield $clogp, 'Source';
3201 my $cversion = getfield $clogp, 'Version';
3202 my $tag = debiantag($cversion, access_basedistro);
3203 runcmd @git, qw(check-ref-format), $tag;
3205 my $dscfn = dscfn($cversion);
3207 return ($clogp, $cversion, $dscfn);
3210 sub push_parse_dsc ($$$) {
3211 my ($dscfn,$dscfnwhat, $cversion) = @_;
3212 $dsc = parsecontrol($dscfn,$dscfnwhat);
3213 my $dversion = getfield $dsc, 'Version';
3214 my $dscpackage = getfield $dsc, 'Source';
3215 ($dscpackage eq $package && $dversion eq $cversion) or
3216 fail "$dscfn is for $dscpackage $dversion".
3217 " but debian/changelog is for $package $cversion";
3220 sub push_tagwants ($$$$) {
3221 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3224 TagFn => \&debiantag,
3229 if (defined $maintviewhead) {
3231 TagFn => \&debiantag_maintview,
3232 Objid => $maintviewhead,
3233 TfSuffix => '-maintview',
3237 foreach my $tw (@tagwants) {
3238 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3239 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3241 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3245 sub push_mktags ($$ $$ $) {
3247 $changesfile,$changesfilewhat,
3250 die unless $tagwants->[0]{View} eq 'dgit';
3252 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3253 $dsc->save("$dscfn.tmp") or die $!;
3255 my $changes = parsecontrol($changesfile,$changesfilewhat);
3256 foreach my $field (qw(Source Distribution Version)) {
3257 $changes->{$field} eq $clogp->{$field} or
3258 fail "changes field $field \`$changes->{$field}'".
3259 " does not match changelog \`$clogp->{$field}'";
3262 my $cversion = getfield $clogp, 'Version';
3263 my $clogsuite = getfield $clogp, 'Distribution';
3265 # We make the git tag by hand because (a) that makes it easier
3266 # to control the "tagger" (b) we can do remote signing
3267 my $authline = clogp_authline $clogp;
3268 my $delibs = join(" ", "",@deliberatelies);
3269 my $declaredistro = access_basedistro();
3273 my $tfn = $tw->{Tfn};
3274 my $head = $tw->{Objid};
3275 my $tag = $tw->{Tag};
3277 open TO, '>', $tfn->('.tmp') or die $!;
3278 print TO <<END or die $!;
3285 if ($tw->{View} eq 'dgit') {
3286 print TO <<END or die $!;
3287 $package release $cversion for $clogsuite ($csuite) [dgit]
3288 [dgit distro=$declaredistro$delibs]
3290 foreach my $ref (sort keys %previously) {
3291 print TO <<END or die $!;
3292 [dgit previously:$ref=$previously{$ref}]
3295 } elsif ($tw->{View} eq 'maint') {
3296 print TO <<END or die $!;
3297 $package release $cversion for $clogsuite ($csuite)
3298 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3301 die Dumper($tw)."?";
3306 my $tagobjfn = $tfn->('.tmp');
3308 if (!defined $keyid) {
3309 $keyid = access_cfg('keyid','RETURN-UNDEF');
3311 if (!defined $keyid) {
3312 $keyid = getfield $clogp, 'Maintainer';
3314 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3315 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3316 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3317 push @sign_cmd, $tfn->('.tmp');
3318 runcmd_ordryrun @sign_cmd;
3320 $tagobjfn = $tfn->('.signed.tmp');
3321 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3322 $tfn->('.tmp'), $tfn->('.tmp.asc');
3328 my @r = map { $mktag->($_); } @$tagwants;
3332 sub sign_changes ($) {
3333 my ($changesfile) = @_;
3335 my @debsign_cmd = @debsign;
3336 push @debsign_cmd, "-k$keyid" if defined $keyid;
3337 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3338 push @debsign_cmd, $changesfile;
3339 runcmd_ordryrun @debsign_cmd;
3344 printdebug "actually entering push\n";
3346 supplementary_message(<<'END');
3347 Push failed, while checking state of the archive.
3348 You can retry the push, after fixing the problem, if you like.
3350 if (check_for_git()) {
3353 my $archive_hash = fetch_from_archive();
3354 if (!$archive_hash) {
3356 fail "package appears to be new in this suite;".
3357 " if this is intentional, use --new";
3360 supplementary_message(<<'END');
3361 Push failed, while preparing your push.
3362 You can retry the push, after fixing the problem, if you like.
3365 need_tagformat 'new', "quilt mode $quilt_mode"
3366 if quiltmode_splitbrain;
3370 access_giturl(); # check that success is vaguely likely
3373 my $clogpfn = ".git/dgit/changelog.822.tmp";
3374 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3376 responder_send_file('parsed-changelog', $clogpfn);
3378 my ($clogp, $cversion, $dscfn) =
3379 push_parse_changelog("$clogpfn");
3381 my $dscpath = "$buildproductsdir/$dscfn";
3382 stat_exists $dscpath or
3383 fail "looked for .dsc $dscfn, but $!;".
3384 " maybe you forgot to build";
3386 responder_send_file('dsc', $dscpath);
3388 push_parse_dsc($dscpath, $dscfn, $cversion);
3390 my $format = getfield $dsc, 'Format';
3391 printdebug "format $format\n";
3393 my $actualhead = git_rev_parse('HEAD');
3394 my $dgithead = $actualhead;
3395 my $maintviewhead = undef;
3397 my $upstreamversion = upstreamversion $clogp->{Version};
3399 if (madformat_wantfixup($format)) {
3400 # user might have not used dgit build, so maybe do this now:
3401 if (quiltmode_splitbrain()) {
3403 quilt_make_fake_dsc($upstreamversion);
3405 ($dgithead, $cachekey) =
3406 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3408 "--quilt=$quilt_mode but no cached dgit view:
3409 perhaps tree changed since dgit build[-source] ?";
3411 $dgithead = splitbrain_pseudomerge($clogp,
3412 $actualhead, $dgithead,
3414 $maintviewhead = $actualhead;
3415 changedir '../../../..';
3416 prep_ud(); # so _only_subdir() works, below
3418 commit_quilty_patch();
3422 if (defined $overwrite_version && !defined $maintviewhead) {
3423 $dgithead = plain_overwrite_pseudomerge($clogp,
3431 if ($archive_hash) {
3432 if (is_fast_fwd($archive_hash, $dgithead)) {
3434 } elsif (deliberately_not_fast_forward) {
3437 fail "dgit push: HEAD is not a descendant".
3438 " of the archive's version.\n".
3439 "To overwrite the archive's contents,".
3440 " pass --overwrite[=VERSION].\n".
3441 "To rewind history, if permitted by the archive,".
3442 " use --deliberately-not-fast-forward.";
3447 progress "checking that $dscfn corresponds to HEAD";
3448 runcmd qw(dpkg-source -x --),
3449 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3450 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3451 check_for_vendor_patches() if madformat($dsc->{format});
3452 changedir '../../../..';
3453 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3454 debugcmd "+",@diffcmd;
3456 my $r = system @diffcmd;
3459 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3461 HEAD specifies a different tree to $dscfn:
3463 Perhaps you forgot to build. Or perhaps there is a problem with your
3464 source tree (see dgit(7) for some hints). To see a full diff, run
3471 if (!$changesfile) {
3472 my $pat = changespat $cversion;
3473 my @cs = glob "$buildproductsdir/$pat";
3474 fail "failed to find unique changes file".
3475 " (looked for $pat in $buildproductsdir);".
3476 " perhaps you need to use dgit -C"
3478 ($changesfile) = @cs;
3480 $changesfile = "$buildproductsdir/$changesfile";
3483 # Check that changes and .dsc agree enough
3484 $changesfile =~ m{[^/]*$};
3485 my $changes = parsecontrol($changesfile,$&);
3486 files_compare_inputs($dsc, $changes)
3487 unless forceing [qw(dsc-changes-mismatch)];
3489 # Perhaps adjust .dsc to contain right set of origs
3490 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3492 unless forceing [qw(changes-origs-exactly)];
3494 # Checks complete, we're going to try and go ahead:
3496 responder_send_file('changes',$changesfile);
3497 responder_send_command("param head $dgithead");
3498 responder_send_command("param csuite $csuite");
3499 responder_send_command("param tagformat $tagformat");
3500 if (defined $maintviewhead) {
3501 die unless ($protovsn//4) >= 4;
3502 responder_send_command("param maint-view $maintviewhead");
3505 if (deliberately_not_fast_forward) {
3506 git_for_each_ref(lrfetchrefs, sub {
3507 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3508 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3509 responder_send_command("previously $rrefname=$objid");
3510 $previously{$rrefname} = $objid;
3514 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3518 supplementary_message(<<'END');
3519 Push failed, while signing the tag.
3520 You can retry the push, after fixing the problem, if you like.
3522 # If we manage to sign but fail to record it anywhere, it's fine.
3523 if ($we_are_responder) {
3524 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3525 responder_receive_files('signed-tag', @tagobjfns);
3527 @tagobjfns = push_mktags($clogp,$dscpath,
3528 $changesfile,$changesfile,
3531 supplementary_message(<<'END');
3532 Push failed, *after* signing the tag.
3533 If you want to try again, you should use a new version number.
3536 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3538 foreach my $tw (@tagwants) {
3539 my $tag = $tw->{Tag};
3540 my $tagobjfn = $tw->{TagObjFn};
3542 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3543 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3544 runcmd_ordryrun_local
3545 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3548 supplementary_message(<<'END');
3549 Push failed, while updating the remote git repository - see messages above.
3550 If you want to try again, you should use a new version number.
3552 if (!check_for_git()) {
3553 create_remote_git_repo();
3556 my @pushrefs = $forceflag.$dgithead.":".rrref();
3557 foreach my $tw (@tagwants) {
3558 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3561 runcmd_ordryrun @git,
3562 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3563 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3565 supplementary_message(<<'END');
3566 Push failed, after updating the remote git repository.
3567 If you want to try again, you must use a new version number.
3569 if ($we_are_responder) {
3570 my $dryrunsuffix = act_local() ? "" : ".tmp";
3571 responder_receive_files('signed-dsc-changes',
3572 "$dscpath$dryrunsuffix",
3573 "$changesfile$dryrunsuffix");
3576 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3578 progress "[new .dsc left in $dscpath.tmp]";
3580 sign_changes $changesfile;
3583 supplementary_message(<<END);
3584 Push failed, while uploading package(s) to the archive server.
3585 You can retry the upload of exactly these same files with dput of:
3587 If that .changes file is broken, you will need to use a new version
3588 number for your next attempt at the upload.
3590 my $host = access_cfg('upload-host','RETURN-UNDEF');
3591 my @hostarg = defined($host) ? ($host,) : ();
3592 runcmd_ordryrun @dput, @hostarg, $changesfile;
3593 printdone "pushed and uploaded $cversion";
3595 supplementary_message('');
3596 responder_send_command("complete");
3603 badusage "-p is not allowed with clone; specify as argument instead"
3604 if defined $package;
3607 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3608 ($package,$isuite) = @ARGV;
3609 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3610 ($package,$dstdir) = @ARGV;
3611 } elsif (@ARGV==3) {
3612 ($package,$isuite,$dstdir) = @ARGV;
3614 badusage "incorrect arguments to dgit clone";
3616 $dstdir ||= "$package";
3618 if (stat_exists $dstdir) {
3619 fail "$dstdir already exists";
3623 if ($rmonerror && !$dryrun_level) {
3624 $cwd_remove= getcwd();
3626 return unless defined $cwd_remove;
3627 if (!chdir "$cwd_remove") {
3628 return if $!==&ENOENT;
3629 die "chdir $cwd_remove: $!";
3632 rmtree($dstdir) or die "remove $dstdir: $!\n";
3633 } elsif (grep { $! == $_ }
3634 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3636 print STDERR "check whether to remove $dstdir: $!\n";
3642 $cwd_remove = undef;
3645 sub branchsuite () {
3646 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3647 if ($branch =~ m#$lbranch_re#o) {
3654 sub fetchpullargs () {
3656 if (!defined $package) {
3657 my $sourcep = parsecontrol('debian/control','debian/control');
3658 $package = getfield $sourcep, 'Source';
3661 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3663 my $clogp = parsechangelog();
3664 $isuite = getfield $clogp, 'Distribution';
3666 canonicalise_suite();
3667 progress "fetching from suite $csuite";
3668 } elsif (@ARGV==1) {
3670 canonicalise_suite();
3672 badusage "incorrect arguments to dgit fetch or dgit pull";
3691 badusage "-p is not allowed with dgit push" if defined $package;
3693 my $clogp = parsechangelog();
3694 $package = getfield $clogp, 'Source';
3697 } elsif (@ARGV==1) {
3698 ($specsuite) = (@ARGV);
3700 badusage "incorrect arguments to dgit push";
3702 $isuite = getfield $clogp, 'Distribution';
3704 local ($package) = $existing_package; # this is a hack
3705 canonicalise_suite();
3707 canonicalise_suite();
3709 if (defined $specsuite &&
3710 $specsuite ne $isuite &&
3711 $specsuite ne $csuite) {
3712 fail "dgit push: changelog specifies $isuite ($csuite)".
3713 " but command line specifies $specsuite";
3718 #---------- remote commands' implementation ----------
3720 sub cmd_remote_push_build_host {
3721 my ($nrargs) = shift @ARGV;
3722 my (@rargs) = @ARGV[0..$nrargs-1];
3723 @ARGV = @ARGV[$nrargs..$#ARGV];
3725 my ($dir,$vsnwant) = @rargs;
3726 # vsnwant is a comma-separated list; we report which we have
3727 # chosen in our ready response (so other end can tell if they
3730 $we_are_responder = 1;
3731 $us .= " (build host)";
3735 open PI, "<&STDIN" or die $!;
3736 open STDIN, "/dev/null" or die $!;
3737 open PO, ">&STDOUT" or die $!;
3739 open STDOUT, ">&STDERR" or die $!;
3743 ($protovsn) = grep {
3744 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3745 } @rpushprotovsn_support;
3747 fail "build host has dgit rpush protocol versions ".
3748 (join ",", @rpushprotovsn_support).
3749 " but invocation host has $vsnwant"
3750 unless defined $protovsn;
3752 responder_send_command("dgit-remote-push-ready $protovsn");
3753 rpush_handle_protovsn_bothends();
3758 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3759 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3760 # a good error message)
3762 sub rpush_handle_protovsn_bothends () {
3763 if ($protovsn < 4) {
3764 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3773 my $report = i_child_report();
3774 if (defined $report) {
3775 printdebug "($report)\n";
3776 } elsif ($i_child_pid) {
3777 printdebug "(killing build host child $i_child_pid)\n";
3778 kill 15, $i_child_pid;
3780 if (defined $i_tmp && !defined $initiator_tempdir) {
3782 eval { rmtree $i_tmp; };
3786 END { i_cleanup(); }
3789 my ($base,$selector,@args) = @_;
3790 $selector =~ s/\-/_/g;
3791 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3798 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3806 push @rargs, join ",", @rpushprotovsn_support;
3809 push @rdgit, @ropts;
3810 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3812 my @cmd = (@ssh, $host, shellquote @rdgit);
3815 if (defined $initiator_tempdir) {
3816 rmtree $initiator_tempdir;
3817 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3818 $i_tmp = $initiator_tempdir;
3822 $i_child_pid = open2(\*RO, \*RI, @cmd);
3824 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3825 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3826 $supplementary_message = '' unless $protovsn >= 3;
3828 fail "rpush negotiated protocol version $protovsn".
3829 " which does not support quilt mode $quilt_mode"
3830 if quiltmode_splitbrain;
3832 rpush_handle_protovsn_bothends();
3834 my ($icmd,$iargs) = initiator_expect {
3835 m/^(\S+)(?: (.*))?$/;
3838 i_method "i_resp", $icmd, $iargs;
3842 sub i_resp_progress ($) {
3844 my $msg = protocol_read_bytes \*RO, $rhs;
3848 sub i_resp_supplementary_message ($) {
3850 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3853 sub i_resp_complete {
3854 my $pid = $i_child_pid;
3855 $i_child_pid = undef; # prevents killing some other process with same pid
3856 printdebug "waiting for build host child $pid...\n";
3857 my $got = waitpid $pid, 0;
3858 die $! unless $got == $pid;
3859 die "build host child failed $?" if $?;
3862 printdebug "all done\n";
3866 sub i_resp_file ($) {
3868 my $localname = i_method "i_localname", $keyword;
3869 my $localpath = "$i_tmp/$localname";
3870 stat_exists $localpath and
3871 badproto \*RO, "file $keyword ($localpath) twice";
3872 protocol_receive_file \*RO, $localpath;
3873 i_method "i_file", $keyword;
3878 sub i_resp_param ($) {
3879 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3883 sub i_resp_previously ($) {
3884 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3885 or badproto \*RO, "bad previously spec";
3886 my $r = system qw(git check-ref-format), $1;
3887 die "bad previously ref spec ($r)" if $r;
3888 $previously{$1} = $2;
3893 sub i_resp_want ($) {
3895 die "$keyword ?" if $i_wanted{$keyword}++;
3896 my @localpaths = i_method "i_want", $keyword;
3897 printdebug "[[ $keyword @localpaths\n";
3898 foreach my $localpath (@localpaths) {
3899 protocol_send_file \*RI, $localpath;
3901 print RI "files-end\n" or die $!;
3904 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3906 sub i_localname_parsed_changelog {
3907 return "remote-changelog.822";
3909 sub i_file_parsed_changelog {
3910 ($i_clogp, $i_version, $i_dscfn) =
3911 push_parse_changelog "$i_tmp/remote-changelog.822";
3912 die if $i_dscfn =~ m#/|^\W#;
3915 sub i_localname_dsc {
3916 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3921 sub i_localname_changes {
3922 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3923 $i_changesfn = $i_dscfn;
3924 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3925 return $i_changesfn;
3927 sub i_file_changes { }
3929 sub i_want_signed_tag {
3930 printdebug Dumper(\%i_param, $i_dscfn);
3931 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3932 && defined $i_param{'csuite'}
3933 or badproto \*RO, "premature desire for signed-tag";
3934 my $head = $i_param{'head'};
3935 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3937 my $maintview = $i_param{'maint-view'};
3938 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3941 if ($protovsn >= 4) {
3942 my $p = $i_param{'tagformat'} // '<undef>';
3944 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3947 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3949 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3951 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3954 push_mktags $i_clogp, $i_dscfn,
3955 $i_changesfn, 'remote changes',
3959 sub i_want_signed_dsc_changes {
3960 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3961 sign_changes $i_changesfn;
3962 return ($i_dscfn, $i_changesfn);
3965 #---------- building etc. ----------
3971 #----- `3.0 (quilt)' handling -----
3973 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3975 sub quiltify_dpkg_commit ($$$;$) {
3976 my ($patchname,$author,$msg, $xinfo) = @_;
3980 my $descfn = ".git/dgit/quilt-description.tmp";
3981 open O, '>', $descfn or die "$descfn: $!";
3982 $msg =~ s/\n+/\n\n/;
3983 print O <<END or die $!;
3985 ${xinfo}Subject: $msg
3992 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3993 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3994 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3995 runcmd @dpkgsource, qw(--commit .), $patchname;
3999 sub quiltify_trees_differ ($$;$$$) {
4000 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4001 # returns true iff the two tree objects differ other than in debian/
4002 # with $finegrained,
4003 # returns bitmask 01 - differ in upstream files except .gitignore
4004 # 02 - differ in .gitignore
4005 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4006 # is set for each modified .gitignore filename $fn
4007 # if $unrepres is defined, array ref to which is appeneded
4008 # a list of unrepresentable changes (removals of upstream files
4011 my @cmd = (@git, qw(diff-tree -z));
4012 push @cmd, qw(--name-only) unless $unrepres;
4013 push @cmd, qw(-r) if $finegrained || $unrepres;
4015 my $diffs= cmdoutput @cmd;
4018 foreach my $f (split /\0/, $diffs) {
4019 if ($unrepres && !@lmodes) {
4020 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4023 my ($oldmode,$newmode) = @lmodes;
4026 next if $f =~ m#^debian(?:/.*)?$#s;
4030 die "deleted\n" unless $newmode =~ m/[^0]/;
4031 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4032 if ($oldmode =~ m/[^0]/) {
4033 die "mode changed\n" if $oldmode ne $newmode;
4035 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4039 local $/="\n"; chomp $@;
4040 push @$unrepres, [ $f, $@ ];
4044 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4045 $r |= $isignore ? 02 : 01;
4046 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4048 printdebug "quiltify_trees_differ $x $y => $r\n";
4052 sub quiltify_tree_sentinelfiles ($) {
4053 # lists the `sentinel' files present in the tree
4055 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4056 qw(-- debian/rules debian/control);
4061 sub quiltify_splitbrain_needed () {
4062 if (!$split_brain) {
4063 progress "dgit view: changes are required...";
4064 runcmd @git, qw(checkout -q -b dgit-view);
4069 sub quiltify_splitbrain ($$$$$$) {
4070 my ($clogp, $unapplied, $headref, $diffbits,
4071 $editedignores, $cachekey) = @_;
4072 if ($quilt_mode !~ m/gbp|dpm/) {
4073 # treat .gitignore just like any other upstream file
4074 $diffbits = { %$diffbits };
4075 $_ = !!$_ foreach values %$diffbits;
4077 # We would like any commits we generate to be reproducible
4078 my @authline = clogp_authline($clogp);
4079 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4080 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4081 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4082 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4083 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4084 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4086 if ($quilt_mode =~ m/gbp|unapplied/ &&
4087 ($diffbits->{O2H} & 01)) {
4089 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4090 " but git tree differs from orig in upstream files.";
4091 if (!stat_exists "debian/patches") {
4093 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4097 if ($quilt_mode =~ m/dpm/ &&
4098 ($diffbits->{H2A} & 01)) {
4100 --quilt=$quilt_mode specified, implying patches-applied git tree
4101 but git tree differs from result of applying debian/patches to upstream
4104 if ($quilt_mode =~ m/gbp|unapplied/ &&
4105 ($diffbits->{O2A} & 01)) { # some patches
4106 quiltify_splitbrain_needed();
4107 progress "dgit view: creating patches-applied version using gbp pq";
4108 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4109 # gbp pq import creates a fresh branch; push back to dgit-view
4110 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4111 runcmd @git, qw(checkout -q dgit-view);
4113 if ($quilt_mode =~ m/gbp|dpm/ &&
4114 ($diffbits->{O2A} & 02)) {
4116 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4117 tool which does not create patches for changes to upstream
4118 .gitignores: but, such patches exist in debian/patches.
4121 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4122 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4123 quiltify_splitbrain_needed();
4124 progress "dgit view: creating patch to represent .gitignore changes";
4125 ensuredir "debian/patches";
4126 my $gipatch = "debian/patches/auto-gitignore";
4127 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4128 stat GIPATCH or die "$gipatch: $!";
4129 fail "$gipatch already exists; but want to create it".
4130 " to record .gitignore changes" if (stat _)[7];
4131 print GIPATCH <<END or die "$gipatch: $!";
4132 Subject: Update .gitignore from Debian packaging branch
4134 The Debian packaging git branch contains these updates to the upstream
4135 .gitignore file(s). This patch is autogenerated, to provide these
4136 updates to users of the official Debian archive view of the package.
4138 [dgit ($our_version) update-gitignore]
4141 close GIPATCH or die "$gipatch: $!";
4142 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4143 $unapplied, $headref, "--", sort keys %$editedignores;
4144 open SERIES, "+>>", "debian/patches/series" or die $!;
4145 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4147 defined read SERIES, $newline, 1 or die $!;
4148 print SERIES "\n" or die $! unless $newline eq "\n";
4149 print SERIES "auto-gitignore\n" or die $!;
4150 close SERIES or die $!;
4151 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4153 Commit patch to update .gitignore
4155 [dgit ($our_version) update-gitignore-quilt-fixup]
4159 my $dgitview = git_rev_parse 'HEAD';
4161 changedir '../../../..';
4162 # When we no longer need to support squeeze, use --create-reflog
4164 ensuredir ".git/logs/refs/dgit-intern";
4165 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4168 my $oldcache = git_get_ref "refs/$splitbraincache";
4169 if ($oldcache eq $dgitview) {
4170 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4171 # git update-ref doesn't always update, in this case. *sigh*
4172 my $dummy = make_commit_text <<END;
4175 author Dgit <dgit\@example.com> 1000000000 +0000
4176 committer Dgit <dgit\@example.com> 1000000000 +0000
4178 Dummy commit - do not use
4180 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4181 "refs/$splitbraincache", $dummy;
4183 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4186 changedir '.git/dgit/unpack/work';
4188 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4189 progress "dgit view: created ($saved)";
4192 sub quiltify ($$$$) {
4193 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4195 # Quilt patchification algorithm
4197 # We search backwards through the history of the main tree's HEAD
4198 # (T) looking for a start commit S whose tree object is identical
4199 # to to the patch tip tree (ie the tree corresponding to the
4200 # current dpkg-committed patch series). For these purposes
4201 # `identical' disregards anything in debian/ - this wrinkle is
4202 # necessary because dpkg-source treates debian/ specially.
4204 # We can only traverse edges where at most one of the ancestors'
4205 # trees differs (in changes outside in debian/). And we cannot
4206 # handle edges which change .pc/ or debian/patches. To avoid
4207 # going down a rathole we avoid traversing edges which introduce
4208 # debian/rules or debian/control. And we set a limit on the
4209 # number of edges we are willing to look at.
4211 # If we succeed, we walk forwards again. For each traversed edge
4212 # PC (with P parent, C child) (starting with P=S and ending with
4213 # C=T) to we do this:
4215 # - dpkg-source --commit with a patch name and message derived from C
4216 # After traversing PT, we git commit the changes which
4217 # should be contained within debian/patches.
4219 # The search for the path S..T is breadth-first. We maintain a
4220 # todo list containing search nodes. A search node identifies a
4221 # commit, and looks something like this:
4223 # Commit => $git_commit_id,
4224 # Child => $c, # or undef if P=T
4225 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4226 # Nontrivial => true iff $p..$c has relevant changes
4233 my %considered; # saves being exponential on some weird graphs
4235 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4238 my ($search,$whynot) = @_;
4239 printdebug " search NOT $search->{Commit} $whynot\n";
4240 $search->{Whynot} = $whynot;
4241 push @nots, $search;
4242 no warnings qw(exiting);
4251 my $c = shift @todo;
4252 next if $considered{$c->{Commit}}++;
4254 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4256 printdebug "quiltify investigate $c->{Commit}\n";
4259 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4260 printdebug " search finished hooray!\n";
4265 if ($quilt_mode eq 'nofix') {
4266 fail "quilt fixup required but quilt mode is \`nofix'\n".
4267 "HEAD commit $c->{Commit} differs from tree implied by ".
4268 " debian/patches (tree object $oldtiptree)";
4270 if ($quilt_mode eq 'smash') {
4271 printdebug " search quitting smash\n";
4275 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4276 $not->($c, "has $c_sentinels not $t_sentinels")
4277 if $c_sentinels ne $t_sentinels;
4279 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4280 $commitdata =~ m/\n\n/;
4282 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4283 @parents = map { { Commit => $_, Child => $c } } @parents;
4285 $not->($c, "root commit") if !@parents;
4287 foreach my $p (@parents) {
4288 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4290 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4291 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4293 foreach my $p (@parents) {
4294 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4296 my @cmd= (@git, qw(diff-tree -r --name-only),
4297 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4298 my $patchstackchange = cmdoutput @cmd;
4299 if (length $patchstackchange) {
4300 $patchstackchange =~ s/\n/,/g;
4301 $not->($p, "changed $patchstackchange");
4304 printdebug " search queue P=$p->{Commit} ",
4305 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4311 printdebug "quiltify want to smash\n";
4314 my $x = $_[0]{Commit};
4315 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4318 my $reportnot = sub {
4320 my $s = $abbrev->($notp);
4321 my $c = $notp->{Child};
4322 $s .= "..".$abbrev->($c) if $c;
4323 $s .= ": ".$notp->{Whynot};
4326 if ($quilt_mode eq 'linear') {
4327 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4328 foreach my $notp (@nots) {
4329 print STDERR "$us: ", $reportnot->($notp), "\n";
4331 print STDERR "$us: $_\n" foreach @$failsuggestion;
4332 fail "quilt fixup naive history linearisation failed.\n".
4333 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4334 } elsif ($quilt_mode eq 'smash') {
4335 } elsif ($quilt_mode eq 'auto') {
4336 progress "quilt fixup cannot be linear, smashing...";
4338 die "$quilt_mode ?";
4341 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4342 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4344 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4346 quiltify_dpkg_commit "auto-$version-$target-$time",
4347 (getfield $clogp, 'Maintainer'),
4348 "Automatically generated patch ($clogp->{Version})\n".
4349 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4353 progress "quiltify linearisation planning successful, executing...";
4355 for (my $p = $sref_S;
4356 my $c = $p->{Child};
4358 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4359 next unless $p->{Nontrivial};
4361 my $cc = $c->{Commit};
4363 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4364 $commitdata =~ m/\n\n/ or die "$c ?";
4367 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4370 my $commitdate = cmdoutput
4371 @git, qw(log -n1 --pretty=format:%aD), $cc;
4373 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4375 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4382 my $gbp_check_suitable = sub {
4387 die "contains unexpected slashes\n" if m{//} || m{/$};
4388 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4389 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4390 die "too long" if length > 200;
4392 return $_ unless $@;
4393 print STDERR "quiltifying commit $cc:".
4394 " ignoring/dropping Gbp-Pq $what: $@";
4398 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4400 (\S+) \s* \n //ixm) {
4401 $patchname = $gbp_check_suitable->($1, 'Name');
4403 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4405 (\S+) \s* \n //ixm) {
4406 $patchdir = $gbp_check_suitable->($1, 'Topic');
4411 if (!defined $patchname) {
4412 $patchname = $title;
4413 $patchname =~ s/[.:]$//;
4416 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4417 my $translitname = $converter->convert($patchname);
4418 die unless defined $translitname;
4419 $patchname = $translitname;
4422 "dgit: patch title transliteration error: $@"
4424 $patchname =~ y/ A-Z/-a-z/;
4425 $patchname =~ y/-a-z0-9_.+=~//cd;
4426 $patchname =~ s/^\W/x-$&/;
4427 $patchname = substr($patchname,0,40);
4429 if (!defined $patchdir) {
4432 if (length $patchdir) {
4433 $patchname = "$patchdir/$patchname";
4435 if ($patchname =~ m{^(.*)/}) {
4436 mkpath "debian/patches/$1";
4441 stat "debian/patches/$patchname$index";
4443 $!==ENOENT or die "$patchname$index $!";
4445 runcmd @git, qw(checkout -q), $cc;
4447 # We use the tip's changelog so that dpkg-source doesn't
4448 # produce complaining messages from dpkg-parsechangelog. None
4449 # of the information dpkg-source gets from the changelog is
4450 # actually relevant - it gets put into the original message
4451 # which dpkg-source provides our stunt editor, and then
4453 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4455 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4456 "Date: $commitdate\n".
4457 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4459 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4462 runcmd @git, qw(checkout -q master);
4465 sub build_maybe_quilt_fixup () {
4466 my ($format,$fopts) = get_source_format;
4467 return unless madformat_wantfixup $format;
4470 check_for_vendor_patches();
4472 if (quiltmode_splitbrain) {
4473 foreach my $needtf (qw(new maint)) {
4474 next if grep { $_ eq $needtf } access_cfg_tagformats;
4476 quilt mode $quilt_mode requires split view so server needs to support
4477 both "new" and "maint" tag formats, but config says it doesn't.
4482 my $clogp = parsechangelog();
4483 my $headref = git_rev_parse('HEAD');
4488 my $upstreamversion = upstreamversion $version;
4490 if ($fopts->{'single-debian-patch'}) {
4491 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4493 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4496 die 'bug' if $split_brain && !$need_split_build_invocation;
4498 changedir '../../../..';
4499 runcmd_ordryrun_local
4500 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4503 sub quilt_fixup_mkwork ($) {
4506 mkdir "work" or die $!;
4508 mktree_in_ud_here();
4509 runcmd @git, qw(reset -q --hard), $headref;
4512 sub quilt_fixup_linkorigs ($$) {
4513 my ($upstreamversion, $fn) = @_;
4514 # calls $fn->($leafname);
4516 foreach my $f (<../../../../*>) { #/){
4517 my $b=$f; $b =~ s{.*/}{};
4519 local ($debuglevel) = $debuglevel-1;
4520 printdebug "QF linkorigs $b, $f ?\n";
4522 next unless is_orig_file_of_vsn $b, $upstreamversion;
4523 printdebug "QF linkorigs $b, $f Y\n";
4524 link_ltarget $f, $b or die "$b $!";
4529 sub quilt_fixup_delete_pc () {
4530 runcmd @git, qw(rm -rqf .pc);
4532 Commit removal of .pc (quilt series tracking data)
4534 [dgit ($our_version) upgrade quilt-remove-pc]
4538 sub quilt_fixup_singlepatch ($$$) {
4539 my ($clogp, $headref, $upstreamversion) = @_;
4541 progress "starting quiltify (single-debian-patch)";
4543 # dpkg-source --commit generates new patches even if
4544 # single-debian-patch is in debian/source/options. In order to
4545 # get it to generate debian/patches/debian-changes, it is
4546 # necessary to build the source package.
4548 quilt_fixup_linkorigs($upstreamversion, sub { });
4549 quilt_fixup_mkwork($headref);
4551 rmtree("debian/patches");
4553 runcmd @dpkgsource, qw(-b .);
4555 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4556 rename srcfn("$upstreamversion", "/debian/patches"),
4557 "work/debian/patches";
4560 commit_quilty_patch();
4563 sub quilt_make_fake_dsc ($) {
4564 my ($upstreamversion) = @_;
4566 my $fakeversion="$upstreamversion-~~DGITFAKE";
4568 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4569 print $fakedsc <<END or die $!;
4572 Version: $fakeversion
4576 my $dscaddfile=sub {
4579 my $md = new Digest::MD5;
4581 my $fh = new IO::File $b, '<' or die "$b $!";
4586 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4589 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4591 my @files=qw(debian/source/format debian/rules
4592 debian/control debian/changelog);
4593 foreach my $maybe (qw(debian/patches debian/source/options
4594 debian/tests/control)) {
4595 next unless stat_exists "../../../$maybe";
4596 push @files, $maybe;
4599 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4600 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4602 $dscaddfile->($debtar);
4603 close $fakedsc or die $!;
4606 sub quilt_check_splitbrain_cache ($$) {
4607 my ($headref, $upstreamversion) = @_;
4608 # Called only if we are in (potentially) split brain mode.
4610 # Computes the cache key and looks in the cache.
4611 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4613 my $splitbrain_cachekey;
4616 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4617 # we look in the reflog of dgit-intern/quilt-cache
4618 # we look for an entry whose message is the key for the cache lookup
4619 my @cachekey = (qw(dgit), $our_version);
4620 push @cachekey, $upstreamversion;
4621 push @cachekey, $quilt_mode;
4622 push @cachekey, $headref;
4624 push @cachekey, hashfile('fake.dsc');
4626 my $srcshash = Digest::SHA->new(256);
4627 my %sfs = ( %INC, '$0(dgit)' => $0 );
4628 foreach my $sfk (sort keys %sfs) {
4629 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4630 $srcshash->add($sfk," ");
4631 $srcshash->add(hashfile($sfs{$sfk}));
4632 $srcshash->add("\n");
4634 push @cachekey, $srcshash->hexdigest();
4635 $splitbrain_cachekey = "@cachekey";
4637 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4639 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4640 debugcmd "|(probably)",@cmd;
4641 my $child = open GC, "-|"; defined $child or die $!;
4643 chdir '../../..' or die $!;
4644 if (!stat ".git/logs/refs/$splitbraincache") {
4645 $! == ENOENT or die $!;
4646 printdebug ">(no reflog)\n";
4653 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4654 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4657 quilt_fixup_mkwork($headref);
4658 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4659 if ($cachehit ne $headref) {
4660 progress "dgit view: found cached ($saved)";
4661 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4663 return ($cachehit, $splitbrain_cachekey);
4665 progress "dgit view: found cached, no changes required";
4666 return ($headref, $splitbrain_cachekey);
4668 die $! if GC->error;
4669 failedcmd unless close GC;
4671 printdebug "splitbrain cache miss\n";
4672 return (undef, $splitbrain_cachekey);
4675 sub quilt_fixup_multipatch ($$$) {
4676 my ($clogp, $headref, $upstreamversion) = @_;
4678 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4681 # - honour any existing .pc in case it has any strangeness
4682 # - determine the git commit corresponding to the tip of
4683 # the patch stack (if there is one)
4684 # - if there is such a git commit, convert each subsequent
4685 # git commit into a quilt patch with dpkg-source --commit
4686 # - otherwise convert all the differences in the tree into
4687 # a single git commit
4691 # Our git tree doesn't necessarily contain .pc. (Some versions of
4692 # dgit would include the .pc in the git tree.) If there isn't
4693 # one, we need to generate one by unpacking the patches that we
4696 # We first look for a .pc in the git tree. If there is one, we
4697 # will use it. (This is not the normal case.)
4699 # Otherwise need to regenerate .pc so that dpkg-source --commit
4700 # can work. We do this as follows:
4701 # 1. Collect all relevant .orig from parent directory
4702 # 2. Generate a debian.tar.gz out of
4703 # debian/{patches,rules,source/format,source/options}
4704 # 3. Generate a fake .dsc containing just these fields:
4705 # Format Source Version Files
4706 # 4. Extract the fake .dsc
4707 # Now the fake .dsc has a .pc directory.
4708 # (In fact we do this in every case, because in future we will
4709 # want to search for a good base commit for generating patches.)
4711 # Then we can actually do the dpkg-source --commit
4712 # 1. Make a new working tree with the same object
4713 # store as our main tree and check out the main
4715 # 2. Copy .pc from the fake's extraction, if necessary
4716 # 3. Run dpkg-source --commit
4717 # 4. If the result has changes to debian/, then
4718 # - git add them them
4719 # - git add .pc if we had a .pc in-tree
4721 # 5. If we had a .pc in-tree, delete it, and git commit
4722 # 6. Back in the main tree, fast forward to the new HEAD
4724 # Another situation we may have to cope with is gbp-style
4725 # patches-unapplied trees.
4727 # We would want to detect these, so we know to escape into
4728 # quilt_fixup_gbp. However, this is in general not possible.
4729 # Consider a package with a one patch which the dgit user reverts
4730 # (with git revert or the moral equivalent).
4732 # That is indistinguishable in contents from a patches-unapplied
4733 # tree. And looking at the history to distinguish them is not
4734 # useful because the user might have made a confusing-looking git
4735 # history structure (which ought to produce an error if dgit can't
4736 # cope, not a silent reintroduction of an unwanted patch).
4738 # So gbp users will have to pass an option. But we can usually
4739 # detect their failure to do so: if the tree is not a clean
4740 # patches-applied tree, quilt linearisation fails, but the tree
4741 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4742 # they want --quilt=unapplied.
4744 # To help detect this, when we are extracting the fake dsc, we
4745 # first extract it with --skip-patches, and then apply the patches
4746 # afterwards with dpkg-source --before-build. That lets us save a
4747 # tree object corresponding to .origs.
4749 my $splitbrain_cachekey;
4751 quilt_make_fake_dsc($upstreamversion);
4753 if (quiltmode_splitbrain()) {
4755 ($cachehit, $splitbrain_cachekey) =
4756 quilt_check_splitbrain_cache($headref, $upstreamversion);
4757 return if $cachehit;
4761 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4763 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4764 rename $fakexdir, "fake" or die "$fakexdir $!";
4768 remove_stray_gits();
4769 mktree_in_ud_here();
4773 runcmd @git, qw(add -Af .);
4774 my $unapplied=git_write_tree();
4775 printdebug "fake orig tree object $unapplied\n";
4779 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4781 if (system @bbcmd) {
4782 failedcmd @bbcmd if $? < 0;
4784 failed to apply your git tree's patch stack (from debian/patches/) to
4785 the corresponding upstream tarball(s). Your source tree and .orig
4786 are probably too inconsistent. dgit can only fix up certain kinds of
4787 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4793 quilt_fixup_mkwork($headref);
4796 if (stat_exists ".pc") {
4798 progress "Tree already contains .pc - will use it then delete it.";
4801 rename '../fake/.pc','.pc' or die $!;
4804 changedir '../fake';
4806 runcmd @git, qw(add -Af .);
4807 my $oldtiptree=git_write_tree();
4808 printdebug "fake o+d/p tree object $unapplied\n";
4809 changedir '../work';
4812 # We calculate some guesswork now about what kind of tree this might
4813 # be. This is mostly for error reporting.
4819 # O = orig, without patches applied
4820 # A = "applied", ie orig with H's debian/patches applied
4821 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4822 \%editedignores, \@unrepres),
4823 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4824 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4828 foreach my $b (qw(01 02)) {
4829 foreach my $v (qw(O2H O2A H2A)) {
4830 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4833 printdebug "differences \@dl @dl.\n";
4836 "$us: base trees orig=%.20s o+d/p=%.20s",
4837 $unapplied, $oldtiptree;
4839 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4840 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4841 $dl[0], $dl[1], $dl[3], $dl[4],
4845 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4847 forceable_fail [qw(unrepresentable)], <<END;
4848 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4853 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4854 push @failsuggestion, "This might be a patches-unapplied branch.";
4855 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4856 push @failsuggestion, "This might be a patches-applied branch.";
4858 push @failsuggestion, "Maybe you need to specify one of".
4859 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4861 if (quiltmode_splitbrain()) {
4862 quiltify_splitbrain($clogp, $unapplied, $headref,
4863 $diffbits, \%editedignores,
4864 $splitbrain_cachekey);
4868 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4869 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4871 if (!open P, '>>', ".pc/applied-patches") {
4872 $!==&ENOENT or die $!;
4877 commit_quilty_patch();
4879 if ($mustdeletepc) {
4880 quilt_fixup_delete_pc();
4884 sub quilt_fixup_editor () {
4885 my $descfn = $ENV{$fakeeditorenv};
4886 my $editing = $ARGV[$#ARGV];
4887 open I1, '<', $descfn or die "$descfn: $!";
4888 open I2, '<', $editing or die "$editing: $!";
4889 unlink $editing or die "$editing: $!";
4890 open O, '>', $editing or die "$editing: $!";
4891 while (<I1>) { print O or die $!; } I1->error and die $!;
4894 $copying ||= m/^\-\-\- /;
4895 next unless $copying;
4898 I2->error and die $!;
4903 sub maybe_apply_patches_dirtily () {
4904 return unless $quilt_mode =~ m/gbp|unapplied/;
4905 print STDERR <<END or die $!;
4907 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4908 dgit: Have to apply the patches - making the tree dirty.
4909 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4912 $patches_applied_dirtily = 01;
4913 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4914 runcmd qw(dpkg-source --before-build .);
4917 sub maybe_unapply_patches_again () {
4918 progress "dgit: Unapplying patches again to tidy up the tree."
4919 if $patches_applied_dirtily;
4920 runcmd qw(dpkg-source --after-build .)
4921 if $patches_applied_dirtily & 01;
4923 if $patches_applied_dirtily & 02;
4924 $patches_applied_dirtily = 0;
4927 #----- other building -----
4929 our $clean_using_builder;
4930 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4931 # clean the tree before building (perhaps invoked indirectly by
4932 # whatever we are using to run the build), rather than separately
4933 # and explicitly by us.
4936 return if $clean_using_builder;
4937 if ($cleanmode eq 'dpkg-source') {
4938 maybe_apply_patches_dirtily();
4939 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4940 } elsif ($cleanmode eq 'dpkg-source-d') {
4941 maybe_apply_patches_dirtily();
4942 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4943 } elsif ($cleanmode eq 'git') {
4944 runcmd_ordryrun_local @git, qw(clean -xdf);
4945 } elsif ($cleanmode eq 'git-ff') {
4946 runcmd_ordryrun_local @git, qw(clean -xdff);
4947 } elsif ($cleanmode eq 'check') {
4948 my $leftovers = cmdoutput @git, qw(clean -xdn);
4949 if (length $leftovers) {
4950 print STDERR $leftovers, "\n" or die $!;
4951 fail "tree contains uncommitted files and --clean=check specified";
4953 } elsif ($cleanmode eq 'none') {
4960 badusage "clean takes no additional arguments" if @ARGV;
4963 maybe_unapply_patches_again();
4966 sub build_prep_early () {
4967 our $build_prep_early_done //= 0;
4968 return if $build_prep_early_done++;
4970 badusage "-p is not allowed when building" if defined $package;
4971 my $clogp = parsechangelog();
4972 $isuite = getfield $clogp, 'Distribution';
4973 $package = getfield $clogp, 'Source';
4974 $version = getfield $clogp, 'Version';
4981 build_maybe_quilt_fixup();
4983 my $pat = changespat $version;
4984 foreach my $f (glob "$buildproductsdir/$pat") {
4986 unlink $f or fail "remove old changes file $f: $!";
4988 progress "would remove $f";
4994 sub changesopts_initial () {
4995 my @opts =@changesopts[1..$#changesopts];
4998 sub changesopts_version () {
4999 if (!defined $changes_since_version) {
5000 my @vsns = archive_query('archive_query');
5001 my @quirk = access_quirk();
5002 if ($quirk[0] eq 'backports') {
5003 local $isuite = $quirk[2];
5005 canonicalise_suite();
5006 push @vsns, archive_query('archive_query');
5009 @vsns = map { $_->[0] } @vsns;
5010 @vsns = sort { -version_compare($a, $b) } @vsns;
5011 $changes_since_version = $vsns[0];
5012 progress "changelog will contain changes since $vsns[0]";
5014 $changes_since_version = '_';
5015 progress "package seems new, not specifying -v<version>";
5018 if ($changes_since_version ne '_') {
5019 return ("-v$changes_since_version");
5025 sub changesopts () {
5026 return (changesopts_initial(), changesopts_version());
5029 sub massage_dbp_args ($;$) {
5030 my ($cmd,$xargs) = @_;
5033 # - if we're going to split the source build out so we can
5034 # do strange things to it, massage the arguments to dpkg-buildpackage
5035 # so that the main build doessn't build source (or add an argument
5036 # to stop it building source by default).
5038 # - add -nc to stop dpkg-source cleaning the source tree,
5039 # unless we're not doing a split build and want dpkg-source
5040 # as cleanmode, in which case we can do nothing
5043 # 0 - source will NOT need to be built separately by caller
5044 # +1 - source will need to be built separately by caller
5045 # +2 - source will need to be built separately by caller AND
5046 # dpkg-buildpackage should not in fact be run at all!
5047 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5048 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5049 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5050 $clean_using_builder = 1;
5053 # -nc has the side effect of specifying -b if nothing else specified
5054 # and some combinations of -S, -b, et al, are errors, rather than
5055 # later simply overriding earlie. So we need to:
5056 # - search the command line for these options
5057 # - pick the last one
5058 # - perhaps add our own as a default
5059 # - perhaps adjust it to the corresponding non-source-building version
5061 foreach my $l ($cmd, $xargs) {
5063 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5066 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5068 if ($need_split_build_invocation) {
5069 printdebug "massage split $dmode.\n";
5070 $r = $dmode =~ m/[S]/ ? +2 :
5071 $dmode =~ y/gGF/ABb/ ? +1 :
5072 $dmode =~ m/[ABb]/ ? 0 :
5075 printdebug "massage done $r $dmode.\n";
5077 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5083 my $wasdir = must_getcwd();
5089 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5090 my ($msg_if_onlyone) = @_;
5091 # If there is only one .changes file, fail with $msg_if_onlyone,
5092 # or if that is undef, be a no-op.
5093 # Returns the changes file to report to the user.
5094 my $pat = changespat $version;
5095 my @changesfiles = glob $pat;
5096 @changesfiles = sort {
5097 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5101 if (@changesfiles==1) {
5102 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5103 only one changes file from build (@changesfiles)
5105 $result = $changesfiles[0];
5106 } elsif (@changesfiles==2) {
5107 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5108 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5109 fail "$l found in binaries changes file $binchanges"
5112 runcmd_ordryrun_local @mergechanges, @changesfiles;
5113 my $multichanges = changespat $version,'multi';
5115 stat_exists $multichanges or fail "$multichanges: $!";
5116 foreach my $cf (glob $pat) {
5117 next if $cf eq $multichanges;
5118 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5121 $result = $multichanges;
5123 fail "wrong number of different changes files (@changesfiles)";
5125 printdone "build successful, results in $result\n" or die $!;
5128 sub midbuild_checkchanges () {
5129 my $pat = changespat $version;
5130 return if $rmchanges;
5131 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5132 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5134 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5135 Suggest you delete @unwanted.
5140 sub midbuild_checkchanges_vanilla ($) {
5142 midbuild_checkchanges() if $wantsrc == 1;
5145 sub postbuild_mergechanges_vanilla ($) {
5147 if ($wantsrc == 1) {
5149 postbuild_mergechanges(undef);
5152 printdone "build successful\n";
5157 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5158 my $wantsrc = massage_dbp_args \@dbp;
5161 midbuild_checkchanges_vanilla $wantsrc;
5166 push @dbp, changesopts_version();
5167 maybe_apply_patches_dirtily();
5168 runcmd_ordryrun_local @dbp;
5170 maybe_unapply_patches_again();
5171 postbuild_mergechanges_vanilla $wantsrc;
5175 $quilt_mode //= 'gbp';
5181 # gbp can make .origs out of thin air. In my tests it does this
5182 # even for a 1.0 format package, with no origs present. So I
5183 # guess it keys off just the version number. We don't know
5184 # exactly what .origs ought to exist, but let's assume that we
5185 # should run gbp if: the version has an upstream part and the main
5187 my $upstreamversion = upstreamversion $version;
5188 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5189 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5191 if ($gbp_make_orig) {
5193 $cleanmode = 'none'; # don't do it again
5194 $need_split_build_invocation = 1;
5197 my @dbp = @dpkgbuildpackage;
5199 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5201 if (!length $gbp_build[0]) {
5202 if (length executable_on_path('git-buildpackage')) {
5203 $gbp_build[0] = qw(git-buildpackage);
5205 $gbp_build[0] = 'gbp buildpackage';
5208 my @cmd = opts_opt_multi_cmd @gbp_build;
5210 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5212 if ($gbp_make_orig) {
5213 ensuredir '.git/dgit';
5214 my $ok = '.git/dgit/origs-gen-ok';
5215 unlink $ok or $!==&ENOENT or die $!;
5216 my @origs_cmd = @cmd;
5217 push @origs_cmd, qw(--git-cleaner=true);
5218 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5219 push @origs_cmd, @ARGV;
5221 debugcmd @origs_cmd;
5223 do { local $!; stat_exists $ok; }
5224 or failedcmd @origs_cmd;
5226 dryrun_report @origs_cmd;
5232 midbuild_checkchanges_vanilla $wantsrc;
5234 if (!$clean_using_builder) {
5235 push @cmd, '--git-cleaner=true';
5239 maybe_unapply_patches_again();
5241 push @cmd, changesopts();
5242 runcmd_ordryrun_local @cmd, @ARGV;
5244 postbuild_mergechanges_vanilla $wantsrc;
5246 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5249 my $our_cleanmode = $cleanmode;
5250 if ($need_split_build_invocation) {
5251 # Pretend that clean is being done some other way. This
5252 # forces us not to try to use dpkg-buildpackage to clean and
5253 # build source all in one go; and instead we run dpkg-source
5254 # (and build_prep() will do the clean since $clean_using_builder
5256 $our_cleanmode = 'ELSEWHERE';
5258 if ($our_cleanmode =~ m/^dpkg-source/) {
5259 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5260 $clean_using_builder = 1;
5263 $sourcechanges = changespat $version,'source';
5265 unlink "../$sourcechanges" or $!==ENOENT
5266 or fail "remove $sourcechanges: $!";
5268 $dscfn = dscfn($version);
5269 if ($our_cleanmode eq 'dpkg-source') {
5270 maybe_apply_patches_dirtily();
5271 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5273 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5274 maybe_apply_patches_dirtily();
5275 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5278 my @cmd = (@dpkgsource, qw(-b --));
5281 runcmd_ordryrun_local @cmd, "work";
5282 my @udfiles = <${package}_*>;
5283 changedir "../../..";
5284 foreach my $f (@udfiles) {
5285 printdebug "source copy, found $f\n";
5288 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5289 $f eq srcfn($version, $&));
5290 printdebug "source copy, found $f - renaming\n";
5291 rename "$ud/$f", "../$f" or $!==ENOENT
5292 or fail "put in place new source file ($f): $!";
5295 my $pwd = must_getcwd();
5296 my $leafdir = basename $pwd;
5298 runcmd_ordryrun_local @cmd, $leafdir;
5301 runcmd_ordryrun_local qw(sh -ec),
5302 'exec >$1; shift; exec "$@"','x',
5303 "../$sourcechanges",
5304 @dpkggenchanges, qw(-S), changesopts();
5308 sub cmd_build_source {
5309 badusage "build-source takes no additional arguments" if @ARGV;
5311 maybe_unapply_patches_again();
5312 printdone "source built, results in $dscfn and $sourcechanges";
5317 midbuild_checkchanges();
5320 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5321 stat_exists $sourcechanges
5322 or fail "$sourcechanges (in parent directory): $!";
5324 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5326 maybe_unapply_patches_again();
5328 postbuild_mergechanges(<<END);
5329 perhaps you need to pass -A ? (sbuild's default is to build only
5330 arch-specific binaries; dgit 1.4 used to override that.)
5335 sub cmd_quilt_fixup {
5336 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5337 my $clogp = parsechangelog();
5338 $version = getfield $clogp, 'Version';
5339 $package = getfield $clogp, 'Source';
5342 build_maybe_quilt_fixup();
5345 sub cmd_import_dsc {
5349 last unless $ARGV[0] =~ m/^-/;
5352 if (m/^--require-valid-signature$/) {
5355 badusage "unknown dgit import-dsc sub-option \`$_'";
5359 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5360 my ($dscfn, $dstbranch) = @ARGV;
5362 badusage "dry run makes no sense with import-dsc" unless act_local();
5364 my $force = $dstbranch =~ s/^\+// ? +1 :
5365 $dstbranch =~ s/^\.\.// ? -1 :
5367 my $info = $force ? " $&" : '';
5368 $info = "$dscfn$info";
5370 my $specbranch = $dstbranch;
5371 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5372 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5374 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5375 my $chead = cmdoutput_errok @symcmd;
5376 defined $chead or $?==256 or failedcmd @symcmd;
5378 fail "$dstbranch is checked out - will not update it"
5379 if defined $chead and $chead eq $dstbranch;
5381 my $oldhash = git_get_ref $dstbranch;
5383 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5384 $dscdata = do { local $/ = undef; <D>; };
5385 D->error and fail "read $dscfn: $!";
5388 # we don't normally need this so import it here
5389 use Dpkg::Source::Package;
5390 my $dp = new Dpkg::Source::Package filename => $dscfn,
5391 require_valid_signature => $needsig;
5393 local $SIG{__WARN__} = sub {
5395 return unless $needsig;
5396 fail "import-dsc signature check failed";
5398 if (!$dp->is_signed()) {
5399 warn "$us: warning: importing unsigned .dsc\n";
5401 my $r = $dp->check_signature();
5402 die "->check_signature => $r" if $needsig && $r;
5408 my $dgit_commit = $dsc->{$ourdscfield[0]};
5409 if (defined $dgit_commit &&
5410 !forceing [qw(import-dsc-with-dgit-field)]) {
5411 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5412 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5413 my @cmd = (qw(sh -ec),
5414 "echo $dgit_commit | git cat-file --batch-check");
5415 my $objgot = cmdoutput @cmd;
5416 if ($objgot =~ m#^\w+ missing\b#) {
5418 .dsc contains Dgit field referring to object $dgit_commit
5419 Your git tree does not have that object. Try `git fetch' from a
5420 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5423 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5425 progress "Not fast forward, forced update.";
5427 fail "Not fast forward to $dgit_commit";
5430 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5431 $dstbranch, $dgit_commit);
5433 progress "dgit: import-dsc updated git ref $dstbranch";
5438 Branch $dstbranch already exists
5439 Specify ..$specbranch for a pseudo-merge, binding in existing history
5440 Specify +$specbranch to overwrite, discarding existing history
5442 if $oldhash && !$force;
5444 $package = getfield $dsc, 'Source';
5445 my @dfi = dsc_files_info();
5446 foreach my $fi (@dfi) {
5447 my $f = $fi->{Filename};
5449 next if lstat $here;
5450 fail "stat $here: $!" unless $! == ENOENT;
5452 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5454 } elsif ($dscfn =~ m#^/#) {
5457 fail "cannot import $dscfn which seems to be inside working tree!";
5459 $there =~ s#/+[^/]+$## or
5460 fail "cannot import $dscfn which seems to not have a basename";
5462 symlink $there, $here or fail "symlink $there to $here: $!";
5463 progress "made symlink $here -> $there";
5464 print STDERR Dumper($fi);
5466 my @mergeinputs = generate_commits_from_dsc();
5467 die unless @mergeinputs == 1;
5469 my $newhash = $mergeinputs[0]{Commit};
5473 progress "Import, forced update - synthetic orphan git history.";
5474 } elsif ($force < 0) {
5475 progress "Import, merging.";
5476 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5477 my $version = getfield $dsc, 'Version';
5478 $newhash = make_commit_text <<END;
5483 Merge $package ($version) import into $dstbranch
5486 die; # caught earlier
5490 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5491 $dstbranch, $newhash);
5493 progress "dgit: import-dsc results are in in git ref $dstbranch";
5496 sub cmd_archive_api_query {
5497 badusage "need only 1 subpath argument" unless @ARGV==1;
5498 my ($subpath) = @ARGV;
5499 my @cmd = archive_api_query_cmd($subpath);
5502 exec @cmd or fail "exec curl: $!\n";
5505 sub cmd_clone_dgit_repos_server {
5506 badusage "need destination argument" unless @ARGV==1;
5507 my ($destdir) = @ARGV;
5508 $package = '_dgit-repos-server';
5509 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5511 exec @cmd or fail "exec git clone: $!\n";
5514 sub cmd_setup_mergechangelogs {
5515 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5516 setup_mergechangelogs(1);
5519 sub cmd_setup_useremail {
5520 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5524 sub cmd_setup_new_tree {
5525 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5529 #---------- argument parsing and main program ----------
5532 print "dgit version $our_version\n" or die $!;
5536 our (%valopts_long, %valopts_short);
5539 sub defvalopt ($$$$) {
5540 my ($long,$short,$val_re,$how) = @_;
5541 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5542 $valopts_long{$long} = $oi;
5543 $valopts_short{$short} = $oi;
5544 # $how subref should:
5545 # do whatever assignemnt or thing it likes with $_[0]
5546 # if the option should not be passed on to remote, @rvalopts=()
5547 # or $how can be a scalar ref, meaning simply assign the value
5550 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5551 defvalopt '--distro', '-d', '.+', \$idistro;
5552 defvalopt '', '-k', '.+', \$keyid;
5553 defvalopt '--existing-package','', '.*', \$existing_package;
5554 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5555 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5556 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5558 defvalopt '', '-C', '.+', sub {
5559 ($changesfile) = (@_);
5560 if ($changesfile =~ s#^(.*)/##) {
5561 $buildproductsdir = $1;
5565 defvalopt '--initiator-tempdir','','.*', sub {
5566 ($initiator_tempdir) = (@_);
5567 $initiator_tempdir =~ m#^/# or
5568 badusage "--initiator-tempdir must be used specify an".
5569 " absolute, not relative, directory."
5575 if (defined $ENV{'DGIT_SSH'}) {
5576 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5577 } elsif (defined $ENV{'GIT_SSH'}) {
5578 @ssh = ($ENV{'GIT_SSH'});
5586 if (!defined $val) {
5587 badusage "$what needs a value" unless @ARGV;
5589 push @rvalopts, $val;
5591 badusage "bad value \`$val' for $what" unless
5592 $val =~ m/^$oi->{Re}$(?!\n)/s;
5593 my $how = $oi->{How};
5594 if (ref($how) eq 'SCALAR') {
5599 push @ropts, @rvalopts;
5603 last unless $ARGV[0] =~ m/^-/;
5607 if (m/^--dry-run$/) {
5610 } elsif (m/^--damp-run$/) {
5613 } elsif (m/^--no-sign$/) {
5616 } elsif (m/^--help$/) {
5618 } elsif (m/^--version$/) {
5620 } elsif (m/^--new$/) {
5623 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5624 ($om = $opts_opt_map{$1}) &&
5628 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5629 !$opts_opt_cmdonly{$1} &&
5630 ($om = $opts_opt_map{$1})) {
5633 } elsif (m/^--(gbp|dpm)$/s) {
5634 push @ropts, "--quilt=$1";
5636 } elsif (m/^--ignore-dirty$/s) {
5639 } elsif (m/^--no-quilt-fixup$/s) {
5641 $quilt_mode = 'nocheck';
5642 } elsif (m/^--no-rm-on-error$/s) {
5645 } elsif (m/^--overwrite$/s) {
5647 $overwrite_version = '';
5648 } elsif (m/^--overwrite=(.+)$/s) {
5650 $overwrite_version = $1;
5651 } elsif (m/^--delayed=(\d+)$/s) {
5654 } elsif (m/^--dgit-view-save=(.+)$/s) {
5656 $split_brain_save = $1;
5657 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5658 } elsif (m/^--(no-)?rm-old-changes$/s) {
5661 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5663 push @deliberatelies, $&;
5664 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5668 } elsif (m/^--force-/) {
5670 "$us: warning: ignoring unknown force option $_\n";
5672 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5673 # undocumented, for testing
5675 $tagformat_want = [ $1, 'command line', 1 ];
5676 # 1 menas overrides distro configuration
5677 } elsif (m/^--always-split-source-build$/s) {
5678 # undocumented, for testing
5680 $need_split_build_invocation = 1;
5681 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5682 $val = $2 ? $' : undef; #';
5683 $valopt->($oi->{Long});
5685 badusage "unknown long option \`$_'";
5692 } elsif (s/^-L/-/) {
5695 } elsif (s/^-h/-/) {
5697 } elsif (s/^-D/-/) {
5701 } elsif (s/^-N/-/) {
5706 push @changesopts, $_;
5708 } elsif (s/^-wn$//s) {
5710 $cleanmode = 'none';
5711 } elsif (s/^-wg$//s) {
5714 } elsif (s/^-wgf$//s) {
5716 $cleanmode = 'git-ff';
5717 } elsif (s/^-wd$//s) {
5719 $cleanmode = 'dpkg-source';
5720 } elsif (s/^-wdd$//s) {
5722 $cleanmode = 'dpkg-source-d';
5723 } elsif (s/^-wc$//s) {
5725 $cleanmode = 'check';
5726 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5727 push @git, '-c', $&;
5728 $gitcfgs{cmdline}{$1} = [ $2 ];
5729 } elsif (s/^-c([^=]+)$//s) {
5730 push @git, '-c', $&;
5731 $gitcfgs{cmdline}{$1} = [ 'true' ];
5732 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5734 $val = undef unless length $val;
5735 $valopt->($oi->{Short});
5738 badusage "unknown short option \`$_'";
5745 sub check_env_sanity () {
5746 my $blocked = new POSIX::SigSet;
5747 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5750 foreach my $name (qw(PIPE CHLD)) {
5751 my $signame = "SIG$name";
5752 my $signum = eval "POSIX::$signame" // die;
5753 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5754 die "$signame is set to something other than SIG_DFL\n";
5755 $blocked->ismember($signum) and
5756 die "$signame is blocked\n";
5762 On entry to dgit, $@
5763 This is a bug produced by something in in your execution environment.
5769 sub finalise_opts_opts () {
5770 foreach my $k (keys %opts_opt_map) {
5771 my $om = $opts_opt_map{$k};
5773 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5775 badcfg "cannot set command for $k"
5776 unless length $om->[0];
5780 foreach my $c (access_cfg_cfgs("opts-$k")) {
5782 map { $_ ? @$_ : () }
5783 map { $gitcfgs{$_}{$c} }
5784 reverse @gitcfgsources;
5785 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5786 "\n" if $debuglevel >= 4;
5788 badcfg "cannot configure options for $k"
5789 if $opts_opt_cmdonly{$k};
5790 my $insertpos = $opts_cfg_insertpos{$k};
5791 @$om = ( @$om[0..$insertpos-1],
5793 @$om[$insertpos..$#$om] );
5798 if ($ENV{$fakeeditorenv}) {
5800 quilt_fixup_editor();
5807 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5808 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5809 if $dryrun_level == 1;
5811 print STDERR $helpmsg or die $!;
5814 my $cmd = shift @ARGV;
5817 my $pre_fn = ${*::}{"pre_$cmd"};
5818 $pre_fn->() if $pre_fn;
5820 if (!defined $rmchanges) {
5821 local $access_forpush;
5822 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5825 if (!defined $quilt_mode) {
5826 local $access_forpush;
5827 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5828 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5830 $quilt_mode =~ m/^($quilt_modes_re)$/
5831 or badcfg "unknown quilt-mode \`$quilt_mode'";
5835 $need_split_build_invocation ||= quiltmode_splitbrain();
5837 if (!defined $cleanmode) {
5838 local $access_forpush;
5839 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5840 $cleanmode //= 'dpkg-source';
5842 badcfg "unknown clean-mode \`$cleanmode'" unless
5843 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5846 my $fn = ${*::}{"cmd_$cmd"};
5847 $fn or badusage "unknown operation $cmd";