3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $split_brain_save;
71 our $we_are_responder;
72 our $initiator_tempdir;
73 our $patches_applied_dirtily = 00;
78 our %forceopts = map { $_=>0 }
79 qw(unrepresentable unsupported-source-format
80 dsc-changes-mismatch changes-origs-exactly
81 import-gitapply-absurd
82 import-gitapply-no-absurd
83 import-dsc-with-dgit-field);
85 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
87 our $suite_re = '[-+.0-9a-z]+';
88 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
89 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
90 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
91 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
93 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
94 our $splitbraincache = 'dgit-intern/quilt-cache';
97 our (@dget) = qw(dget);
98 our (@curl) = qw(curl);
99 our (@dput) = qw(dput);
100 our (@debsign) = qw(debsign);
101 our (@gpg) = qw(gpg);
102 our (@sbuild) = qw(sbuild);
104 our (@dgit) = qw(dgit);
105 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
106 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
107 our (@dpkggenchanges) = qw(dpkg-genchanges);
108 our (@mergechanges) = qw(mergechanges -f);
109 our (@gbp_build) = ('');
110 our (@gbp_pq) = ('gbp pq');
111 our (@changesopts) = ('');
113 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
116 'debsign' => \@debsign,
118 'sbuild' => \@sbuild,
122 'dpkg-source' => \@dpkgsource,
123 'dpkg-buildpackage' => \@dpkgbuildpackage,
124 'dpkg-genchanges' => \@dpkggenchanges,
125 'gbp-build' => \@gbp_build,
126 'gbp-pq' => \@gbp_pq,
127 'ch' => \@changesopts,
128 'mergechanges' => \@mergechanges);
130 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
131 our %opts_cfg_insertpos = map {
133 scalar @{ $opts_opt_map{$_} }
134 } keys %opts_opt_map;
136 sub finalise_opts_opts();
142 our $supplementary_message = '';
143 our $need_split_build_invocation = 0;
144 our $split_brain = 0;
148 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
151 our $remotename = 'dgit';
152 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
156 if (!defined $absurdity) {
158 $absurdity =~ s{/[^/]+$}{/absurd} or die;
162 my ($v,$distro) = @_;
163 return $tagformatfn->($v, $distro);
166 sub debiantag_maintview ($$) {
167 my ($v,$distro) = @_;
172 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
174 sub lbranch () { return "$branchprefix/$csuite"; }
175 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
176 sub lref () { return "refs/heads/".lbranch(); }
177 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
178 sub rrref () { return server_ref($csuite); }
180 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
181 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
183 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
184 # locally fetched refs because they have unhelpful names and clutter
185 # up gitk etc. So we track whether we have "used up" head ref (ie,
186 # whether we have made another local ref which refers to this object).
188 # (If we deleted them unconditionally, then we might end up
189 # re-fetching the same git objects each time dgit fetch was run.)
191 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
192 # in git_fetch_us to fetch the refs in question, and possibly a call
193 # to lrfetchref_used.
195 our (%lrfetchrefs_f, %lrfetchrefs_d);
196 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
198 sub lrfetchref_used ($) {
199 my ($fullrefname) = @_;
200 my $objid = $lrfetchrefs_f{$fullrefname};
201 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
212 return "${package}_".(stripepoch $vsn).$sfx
217 return srcfn($vsn,".dsc");
220 sub changespat ($;$) {
221 my ($vsn, $arch) = @_;
222 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 sub upstreamversion ($) {
237 foreach my $f (@end) {
239 print STDERR "$us: cleanup: $@" if length $@;
243 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
245 sub forceable_fail ($$) {
246 my ($forceoptsl, $msg) = @_;
247 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
248 print STDERR "warning: overriding problem due to --force:\n". $msg;
252 my ($forceoptsl) = @_;
253 my @got = grep { $forceopts{$_} } @$forceoptsl;
254 return 0 unless @got;
256 "warning: skipping checks or functionality due to --force-$got[0]\n";
259 sub no_such_package () {
260 print STDERR "$us: package $package does not exist in suite $isuite\n";
266 printdebug "CD $newdir\n";
267 chdir $newdir or confess "chdir: $newdir: $!";
270 sub deliberately ($) {
272 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
275 sub deliberately_not_fast_forward () {
276 foreach (qw(not-fast-forward fresh-repo)) {
277 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
281 sub quiltmode_splitbrain () {
282 $quilt_mode =~ m/gbp|dpm|unapplied/;
285 sub opts_opt_multi_cmd {
287 push @cmd, split /\s+/, shift @_;
293 return opts_opt_multi_cmd @gbp_pq;
296 #---------- remote protocol support, common ----------
298 # remote push initiator/responder protocol:
299 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
300 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
301 # < dgit-remote-push-ready <actual-proto-vsn>
308 # > supplementary-message NBYTES # $protovsn >= 3
313 # > file parsed-changelog
314 # [indicates that output of dpkg-parsechangelog follows]
315 # > data-block NBYTES
316 # > [NBYTES bytes of data (no newline)]
317 # [maybe some more blocks]
326 # > param head DGIT-VIEW-HEAD
327 # > param csuite SUITE
328 # > param tagformat old|new
329 # > param maint-view MAINT-VIEW-HEAD
331 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
332 # # goes into tag, for replay prevention
335 # [indicates that signed tag is wanted]
336 # < data-block NBYTES
337 # < [NBYTES bytes of data (no newline)]
338 # [maybe some more blocks]
342 # > want signed-dsc-changes
343 # < data-block NBYTES [transfer of signed dsc]
345 # < data-block NBYTES [transfer of signed changes]
353 sub i_child_report () {
354 # Sees if our child has died, and reap it if so. Returns a string
355 # describing how it died if it failed, or undef otherwise.
356 return undef unless $i_child_pid;
357 my $got = waitpid $i_child_pid, WNOHANG;
358 return undef if $got <= 0;
359 die unless $got == $i_child_pid;
360 $i_child_pid = undef;
361 return undef unless $?;
362 return "build host child ".waitstatusmsg();
367 fail "connection lost: $!" if $fh->error;
368 fail "protocol violation; $m not expected";
371 sub badproto_badread ($$) {
373 fail "connection lost: $!" if $!;
374 my $report = i_child_report();
375 fail $report if defined $report;
376 badproto $fh, "eof (reading $wh)";
379 sub protocol_expect (&$) {
380 my ($match, $fh) = @_;
383 defined && chomp or badproto_badread $fh, "protocol message";
391 badproto $fh, "\`$_'";
394 sub protocol_send_file ($$) {
395 my ($fh, $ourfn) = @_;
396 open PF, "<", $ourfn or die "$ourfn: $!";
399 my $got = read PF, $d, 65536;
400 die "$ourfn: $!" unless defined $got;
402 print $fh "data-block ".length($d)."\n" or die $!;
403 print $fh $d or die $!;
405 PF->error and die "$ourfn $!";
406 print $fh "data-end\n" or die $!;
410 sub protocol_read_bytes ($$) {
411 my ($fh, $nbytes) = @_;
412 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
414 my $got = read $fh, $d, $nbytes;
415 $got==$nbytes or badproto_badread $fh, "data block";
419 sub protocol_receive_file ($$) {
420 my ($fh, $ourfn) = @_;
421 printdebug "() $ourfn\n";
422 open PF, ">", $ourfn or die "$ourfn: $!";
424 my ($y,$l) = protocol_expect {
425 m/^data-block (.*)$/ ? (1,$1) :
426 m/^data-end$/ ? (0,) :
430 my $d = protocol_read_bytes $fh, $l;
431 print PF $d or die $!;
436 #---------- remote protocol support, responder ----------
438 sub responder_send_command ($) {
440 return unless $we_are_responder;
441 # called even without $we_are_responder
442 printdebug ">> $command\n";
443 print PO $command, "\n" or die $!;
446 sub responder_send_file ($$) {
447 my ($keyword, $ourfn) = @_;
448 return unless $we_are_responder;
449 printdebug "]] $keyword $ourfn\n";
450 responder_send_command "file $keyword";
451 protocol_send_file \*PO, $ourfn;
454 sub responder_receive_files ($@) {
455 my ($keyword, @ourfns) = @_;
456 die unless $we_are_responder;
457 printdebug "[[ $keyword @ourfns\n";
458 responder_send_command "want $keyword";
459 foreach my $fn (@ourfns) {
460 protocol_receive_file \*PI, $fn;
463 protocol_expect { m/^files-end$/ } \*PI;
466 #---------- remote protocol support, initiator ----------
468 sub initiator_expect (&) {
470 protocol_expect { &$match } \*RO;
473 #---------- end remote code ----------
476 if ($we_are_responder) {
478 responder_send_command "progress ".length($m) or die $!;
479 print PO $m or die $!;
489 $ua = LWP::UserAgent->new();
493 progress "downloading $what...";
494 my $r = $ua->get(@_) or die $!;
495 return undef if $r->code == 404;
496 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
497 return $r->decoded_content(charset => 'none');
500 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
505 failedcmd @_ if system @_;
508 sub act_local () { return $dryrun_level <= 1; }
509 sub act_scary () { return !$dryrun_level; }
512 if (!$dryrun_level) {
513 progress "dgit ok: @_";
515 progress "would be ok: @_ (but dry run only)";
520 printcmd(\*STDERR,$debugprefix."#",@_);
523 sub runcmd_ordryrun {
531 sub runcmd_ordryrun_local {
540 my ($first_shell, @cmd) = @_;
541 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
544 our $helpmsg = <<END;
546 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
547 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
548 dgit [dgit-opts] build [dpkg-buildpackage-opts]
549 dgit [dgit-opts] sbuild [sbuild-opts]
550 dgit [dgit-opts] push [dgit-opts] [suite]
551 dgit [dgit-opts] rpush build-host:build-dir ...
552 important dgit options:
553 -k<keyid> sign tag and package with <keyid> instead of default
554 --dry-run -n do not change anything, but go through the motions
555 --damp-run -L like --dry-run but make local changes, without signing
556 --new -N allow introducing a new package
557 --debug -D increase debug level
558 -c<name>=<value> set git config option (used directly by dgit too)
561 our $later_warning_msg = <<END;
562 Perhaps the upload is stuck in incoming. Using the version from git.
566 print STDERR "$us: @_\n", $helpmsg or die $!;
571 @ARGV or badusage "too few arguments";
572 return scalar shift @ARGV;
576 print $helpmsg or die $!;
580 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
582 our %defcfg = ('dgit.default.distro' => 'debian',
583 'dgit.default.username' => '',
584 'dgit.default.archive-query-default-component' => 'main',
585 'dgit.default.ssh' => 'ssh',
586 'dgit.default.archive-query' => 'madison:',
587 'dgit.default.sshpsql-dbname' => 'service=projectb',
588 'dgit.default.dgit-tag-format' => 'new,old,maint',
589 # old means "repo server accepts pushes with old dgit tags"
590 # new means "repo server accepts pushes with new dgit tags"
591 # maint means "repo server accepts split brain pushes"
592 # hist means "repo server may have old pushes without new tag"
593 # ("hist" is implied by "old")
594 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
595 'dgit-distro.debian.git-check' => 'url',
596 'dgit-distro.debian.git-check-suffix' => '/info/refs',
597 'dgit-distro.debian.new-private-pushers' => 't',
598 'dgit-distro.debian/push.git-url' => '',
599 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
600 'dgit-distro.debian/push.git-user-force' => 'dgit',
601 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
602 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
603 'dgit-distro.debian/push.git-create' => 'true',
604 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
605 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
606 # 'dgit-distro.debian.archive-query-tls-key',
607 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
608 # ^ this does not work because curl is broken nowadays
609 # Fixing #790093 properly will involve providing providing the key
610 # in some pacagke and maybe updating these paths.
612 # 'dgit-distro.debian.archive-query-tls-curl-args',
613 # '--ca-path=/etc/ssl/ca-debian',
614 # ^ this is a workaround but works (only) on DSA-administered machines
615 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
616 'dgit-distro.debian.git-url-suffix' => '',
617 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
618 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
619 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
620 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
621 'dgit-distro.ubuntu.git-check' => 'false',
622 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
623 'dgit-distro.test-dummy.ssh' => "$td/ssh",
624 'dgit-distro.test-dummy.username' => "alice",
625 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
626 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-url' => "$td/git",
628 'dgit-distro.test-dummy.git-host' => "git",
629 'dgit-distro.test-dummy.git-path' => "$td/git",
630 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
631 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
632 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
633 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
637 our @gitcfgsources = qw(cmdline local global system);
639 sub git_slurp_config () {
640 local ($debuglevel) = $debuglevel-2;
643 # This algoritm is a bit subtle, but this is needed so that for
644 # options which we want to be single-valued, we allow the
645 # different config sources to override properly. See #835858.
646 foreach my $src (@gitcfgsources) {
647 next if $src eq 'cmdline';
648 # we do this ourselves since git doesn't handle it
650 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
653 open GITS, "-|", @cmd or die $!;
656 printdebug "=> ", (messagequote $_), "\n";
658 push @{ $gitcfgs{$src}{$`} }, $'; #';
662 or ($!==0 && $?==256)
667 sub git_get_config ($) {
669 foreach my $src (@gitcfgsources) {
670 my $l = $gitcfgs{$src}{$c};
671 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
674 @$l==1 or badcfg "multiple values for $c".
675 " (in $src git config)" if @$l > 1;
683 return undef if $c =~ /RETURN-UNDEF/;
684 my $v = git_get_config($c);
685 return $v if defined $v;
686 my $dv = $defcfg{$c};
687 return $dv if defined $dv;
689 badcfg "need value for one of: @_\n".
690 "$us: distro or suite appears not to be (properly) supported";
693 sub access_basedistro () {
694 if (defined $idistro) {
697 return cfg("dgit-suite.$isuite.distro",
698 "dgit.default.distro");
702 sub access_quirk () {
703 # returns (quirk name, distro to use instead or undef, quirk-specific info)
704 my $basedistro = access_basedistro();
705 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
707 if (defined $backports_quirk) {
708 my $re = $backports_quirk;
709 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
711 $re =~ s/\%/([-0-9a-z_]+)/
712 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
713 if ($isuite =~ m/^$re$/) {
714 return ('backports',"$basedistro-backports",$1);
717 return ('none',undef);
722 sub parse_cfg_bool ($$$) {
723 my ($what,$def,$v) = @_;
726 $v =~ m/^[ty1]/ ? 1 :
727 $v =~ m/^[fn0]/ ? 0 :
728 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
731 sub access_forpush_config () {
732 my $d = access_basedistro();
736 parse_cfg_bool('new-private-pushers', 0,
737 cfg("dgit-distro.$d.new-private-pushers",
740 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
743 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
744 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
745 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
746 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
749 sub access_forpush () {
750 $access_forpush //= access_forpush_config();
751 return $access_forpush;
755 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
756 badcfg "pushing but distro is configured readonly"
757 if access_forpush_config() eq '0';
759 $supplementary_message = <<'END' unless $we_are_responder;
760 Push failed, before we got started.
761 You can retry the push, after fixing the problem, if you like.
763 finalise_opts_opts();
767 finalise_opts_opts();
770 sub supplementary_message ($) {
772 if (!$we_are_responder) {
773 $supplementary_message = $msg;
775 } elsif ($protovsn >= 3) {
776 responder_send_command "supplementary-message ".length($msg)
778 print PO $msg or die $!;
782 sub access_distros () {
783 # Returns list of distros to try, in order
786 # 0. `instead of' distro name(s) we have been pointed to
787 # 1. the access_quirk distro, if any
788 # 2a. the user's specified distro, or failing that } basedistro
789 # 2b. the distro calculated from the suite }
790 my @l = access_basedistro();
792 my (undef,$quirkdistro) = access_quirk();
793 unshift @l, $quirkdistro;
794 unshift @l, $instead_distro;
795 @l = grep { defined } @l;
797 if (access_forpush()) {
798 @l = map { ("$_/push", $_) } @l;
803 sub access_cfg_cfgs (@) {
806 # The nesting of these loops determines the search order. We put
807 # the key loop on the outside so that we search all the distros
808 # for each key, before going on to the next key. That means that
809 # if access_cfg is called with a more specific, and then a less
810 # specific, key, an earlier distro can override the less specific
811 # without necessarily overriding any more specific keys. (If the
812 # distro wants to override the more specific keys it can simply do
813 # so; whereas if we did the loop the other way around, it would be
814 # impossible to for an earlier distro to override a less specific
815 # key but not the more specific ones without restating the unknown
816 # values of the more specific keys.
819 # We have to deal with RETURN-UNDEF specially, so that we don't
820 # terminate the search prematurely.
822 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
825 foreach my $d (access_distros()) {
826 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
828 push @cfgs, map { "dgit.default.$_" } @realkeys;
835 my (@cfgs) = access_cfg_cfgs(@keys);
836 my $value = cfg(@cfgs);
840 sub access_cfg_bool ($$) {
841 my ($def, @keys) = @_;
842 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
845 sub string_to_ssh ($) {
847 if ($spec =~ m/\s/) {
848 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
854 sub access_cfg_ssh () {
855 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
856 if (!defined $gitssh) {
859 return string_to_ssh $gitssh;
863 sub access_runeinfo ($) {
865 return ": dgit ".access_basedistro()." $info ;";
868 sub access_someuserhost ($) {
870 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
871 defined($user) && length($user) or
872 $user = access_cfg("$some-user",'username');
873 my $host = access_cfg("$some-host");
874 return length($user) ? "$user\@$host" : $host;
877 sub access_gituserhost () {
878 return access_someuserhost('git');
881 sub access_giturl (;$) {
883 my $url = access_cfg('git-url','RETURN-UNDEF');
886 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
887 return undef unless defined $proto;
890 access_gituserhost().
891 access_cfg('git-path');
893 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
896 return "$url/$package$suffix";
899 sub parsecontrolfh ($$;$) {
900 my ($fh, $desc, $allowsigned) = @_;
901 our $dpkgcontrolhash_noissigned;
904 my %opts = ('name' => $desc);
905 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
906 $c = Dpkg::Control::Hash->new(%opts);
907 $c->parse($fh,$desc) or die "parsing of $desc failed";
908 last if $allowsigned;
909 last if $dpkgcontrolhash_noissigned;
910 my $issigned= $c->get_option('is_pgp_signed');
911 if (!defined $issigned) {
912 $dpkgcontrolhash_noissigned= 1;
913 seek $fh, 0,0 or die "seek $desc: $!";
914 } elsif ($issigned) {
915 fail "control file $desc is (already) PGP-signed. ".
916 " Note that dgit push needs to modify the .dsc and then".
917 " do the signature itself";
926 my ($file, $desc) = @_;
927 my $fh = new IO::Handle;
928 open $fh, '<', $file or die "$file: $!";
929 my $c = parsecontrolfh($fh,$desc);
930 $fh->error and die $!;
936 my ($dctrl,$field) = @_;
937 my $v = $dctrl->{$field};
938 return $v if defined $v;
939 fail "missing field $field in ".$dctrl->get_option('name');
943 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
944 my $p = new IO::Handle;
945 my @cmd = (qw(dpkg-parsechangelog), @_);
946 open $p, '-|', @cmd or die $!;
948 $?=0; $!=0; close $p or failedcmd @cmd;
952 sub commit_getclogp ($) {
953 # Returns the parsed changelog hashref for a particular commit
955 our %commit_getclogp_memo;
956 my $memo = $commit_getclogp_memo{$objid};
957 return $memo if $memo;
959 my $mclog = ".git/dgit/clog-$objid";
960 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
961 "$objid:debian/changelog";
962 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
967 defined $d or fail "getcwd failed: $!";
971 sub parse_dscdata () {
972 my $dscfh = new IO::File \$dscdata, '<' or die $!;
973 printdebug Dumper($dscdata) if $debuglevel>1;
974 $dsc = parsecontrolfh($dscfh,$dscurl,1);
975 printdebug Dumper($dsc) if $debuglevel>1;
980 sub archive_query ($;@) {
981 my ($method) = shift @_;
982 my $query = access_cfg('archive-query','RETURN-UNDEF');
983 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
986 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
989 sub pool_dsc_subpath ($$) {
990 my ($vsn,$component) = @_; # $package is implict arg
991 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
992 return "/pool/$component/$prefix/$package/".dscfn($vsn);
995 #---------- `ftpmasterapi' archive query method (nascent) ----------
997 sub archive_api_query_cmd ($) {
999 my @cmd = (@curl, qw(-sS));
1000 my $url = access_cfg('archive-query-url');
1001 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1003 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1004 foreach my $key (split /\:/, $keys) {
1005 $key =~ s/\%HOST\%/$host/g;
1007 fail "for $url: stat $key: $!" unless $!==ENOENT;
1010 fail "config requested specific TLS key but do not know".
1011 " how to get curl to use exactly that EE key ($key)";
1012 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1013 # # Sadly the above line does not work because of changes
1014 # # to gnutls. The real fix for #790093 may involve
1015 # # new curl options.
1018 # Fixing #790093 properly will involve providing a value
1019 # for this on clients.
1020 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1021 push @cmd, split / /, $kargs if defined $kargs;
1023 push @cmd, $url.$subpath;
1027 sub api_query ($$;$) {
1029 my ($data, $subpath, $ok404) = @_;
1030 badcfg "ftpmasterapi archive query method takes no data part"
1032 my @cmd = archive_api_query_cmd($subpath);
1033 my $url = $cmd[$#cmd];
1034 push @cmd, qw(-w %{http_code});
1035 my $json = cmdoutput @cmd;
1036 unless ($json =~ s/\d+\d+\d$//) {
1037 failedcmd_report_cmd undef, @cmd;
1038 fail "curl failed to print 3-digit HTTP code";
1041 return undef if $code eq '404' && $ok404;
1042 fail "fetch of $url gave HTTP code $code"
1043 unless $url =~ m#^file://# or $code =~ m/^2/;
1044 return decode_json($json);
1047 sub canonicalise_suite_ftpmasterapi {
1048 my ($proto,$data) = @_;
1049 my $suites = api_query($data, 'suites');
1051 foreach my $entry (@$suites) {
1053 my $v = $entry->{$_};
1054 defined $v && $v eq $isuite;
1055 } qw(codename name);
1056 push @matched, $entry;
1058 fail "unknown suite $isuite" unless @matched;
1061 @matched==1 or die "multiple matches for suite $isuite\n";
1062 $cn = "$matched[0]{codename}";
1063 defined $cn or die "suite $isuite info has no codename\n";
1064 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1066 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1071 sub archive_query_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1075 my $digester = Digest::SHA->new(256);
1076 foreach my $entry (@$info) {
1078 my $vsn = "$entry->{version}";
1079 my ($ok,$msg) = version_check $vsn;
1080 die "bad version: $msg\n" unless $ok;
1081 my $component = "$entry->{component}";
1082 $component =~ m/^$component_re$/ or die "bad component";
1083 my $filename = "$entry->{filename}";
1084 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1085 or die "bad filename";
1086 my $sha256sum = "$entry->{sha256sum}";
1087 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1088 push @rows, [ $vsn, "/pool/$component/$filename",
1089 $digester, $sha256sum ];
1091 die "bad ftpmaster api response: $@\n".Dumper($entry)
1094 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1098 sub file_in_archive_ftpmasterapi {
1099 my ($proto,$data,$filename) = @_;
1100 my $pat = $filename;
1103 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1104 my $info = api_query($data, "file_in_archive/$pat", 1);
1107 #---------- `dummyapicat' archive query method ----------
1109 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1110 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1112 sub file_in_archive_dummycatapi ($$$) {
1113 my ($proto,$data,$filename) = @_;
1114 my $mirror = access_cfg('mirror');
1115 $mirror =~ s#^file://#/# or die "$mirror ?";
1117 my @cmd = (qw(sh -ec), '
1119 find -name "$2" -print0 |
1121 ', qw(x), $mirror, $filename);
1122 debugcmd "-|", @cmd;
1123 open FIA, "-|", @cmd or die $!;
1126 printdebug "| $_\n";
1127 m/^(\w+) (\S+)$/ or die "$_ ?";
1128 push @out, { sha256sum => $1, filename => $2 };
1130 close FIA or die failedcmd @cmd;
1134 #---------- `madison' archive query method ----------
1136 sub archive_query_madison {
1137 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1140 sub madison_get_parse {
1141 my ($proto,$data) = @_;
1142 die unless $proto eq 'madison';
1143 if (!length $data) {
1144 $data= access_cfg('madison-distro','RETURN-UNDEF');
1145 $data //= access_basedistro();
1147 $rmad{$proto,$data,$package} ||= cmdoutput
1148 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1149 my $rmad = $rmad{$proto,$data,$package};
1152 foreach my $l (split /\n/, $rmad) {
1153 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1154 \s*( [^ \t|]+ )\s* \|
1155 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1156 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1157 $1 eq $package or die "$rmad $package ?";
1164 $component = access_cfg('archive-query-default-component');
1166 $5 eq 'source' or die "$rmad ?";
1167 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1169 return sort { -version_compare($a->[0],$b->[0]); } @out;
1172 sub canonicalise_suite_madison {
1173 # madison canonicalises for us
1174 my @r = madison_get_parse(@_);
1176 "unable to canonicalise suite using package $package".
1177 " which does not appear to exist in suite $isuite;".
1178 " --existing-package may help";
1182 sub file_in_archive_madison { return undef; }
1184 #---------- `sshpsql' archive query method ----------
1187 my ($data,$runeinfo,$sql) = @_;
1188 if (!length $data) {
1189 $data= access_someuserhost('sshpsql').':'.
1190 access_cfg('sshpsql-dbname');
1192 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1193 my ($userhost,$dbname) = ($`,$'); #';
1195 my @cmd = (access_cfg_ssh, $userhost,
1196 access_runeinfo("ssh-psql $runeinfo").
1197 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1198 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1200 open P, "-|", @cmd or die $!;
1203 printdebug(">|$_|\n");
1206 $!=0; $?=0; close P or failedcmd @cmd;
1208 my $nrows = pop @rows;
1209 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1210 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1211 @rows = map { [ split /\|/, $_ ] } @rows;
1212 my $ncols = scalar @{ shift @rows };
1213 die if grep { scalar @$_ != $ncols } @rows;
1217 sub sql_injection_check {
1218 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1221 sub archive_query_sshpsql ($$) {
1222 my ($proto,$data) = @_;
1223 sql_injection_check $isuite, $package;
1224 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1225 SELECT source.version, component.name, files.filename, files.sha256sum
1227 JOIN src_associations ON source.id = src_associations.source
1228 JOIN suite ON suite.id = src_associations.suite
1229 JOIN dsc_files ON dsc_files.source = source.id
1230 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1231 JOIN component ON component.id = files_archive_map.component_id
1232 JOIN files ON files.id = dsc_files.file
1233 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1234 AND source.source='$package'
1235 AND files.filename LIKE '%.dsc';
1237 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1238 my $digester = Digest::SHA->new(256);
1240 my ($vsn,$component,$filename,$sha256sum) = @$_;
1241 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1246 sub canonicalise_suite_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite;
1249 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1250 SELECT suite.codename
1251 FROM suite where suite_name='$isuite' or codename='$isuite';
1253 @rows = map { $_->[0] } @rows;
1254 fail "unknown suite $isuite" unless @rows;
1255 die "ambiguous $isuite: @rows ?" if @rows>1;
1259 sub file_in_archive_sshpsql ($$$) { return undef; }
1261 #---------- `dummycat' archive query method ----------
1263 sub canonicalise_suite_dummycat ($$) {
1264 my ($proto,$data) = @_;
1265 my $dpath = "$data/suite.$isuite";
1266 if (!open C, "<", $dpath) {
1267 $!==ENOENT or die "$dpath: $!";
1268 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1272 chomp or die "$dpath: $!";
1274 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1278 sub archive_query_dummycat ($$) {
1279 my ($proto,$data) = @_;
1280 canonicalise_suite();
1281 my $dpath = "$data/package.$csuite.$package";
1282 if (!open C, "<", $dpath) {
1283 $!==ENOENT or die "$dpath: $!";
1284 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1292 printdebug "dummycat query $csuite $package $dpath | $_\n";
1293 my @row = split /\s+/, $_;
1294 @row==2 or die "$dpath: $_ ?";
1297 C->error and die "$dpath: $!";
1299 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1302 sub file_in_archive_dummycat () { return undef; }
1304 #---------- tag format handling ----------
1306 sub access_cfg_tagformats () {
1307 split /\,/, access_cfg('dgit-tag-format');
1310 sub need_tagformat ($$) {
1311 my ($fmt, $why) = @_;
1312 fail "need to use tag format $fmt ($why) but also need".
1313 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1314 " - no way to proceed"
1315 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1316 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1319 sub select_tagformat () {
1321 return if $tagformatfn && !$tagformat_want;
1322 die 'bug' if $tagformatfn && $tagformat_want;
1323 # ... $tagformat_want assigned after previous select_tagformat
1325 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1326 printdebug "select_tagformat supported @supported\n";
1328 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1329 printdebug "select_tagformat specified @$tagformat_want\n";
1331 my ($fmt,$why,$override) = @$tagformat_want;
1333 fail "target distro supports tag formats @supported".
1334 " but have to use $fmt ($why)"
1336 or grep { $_ eq $fmt } @supported;
1338 $tagformat_want = undef;
1340 $tagformatfn = ${*::}{"debiantag_$fmt"};
1342 fail "trying to use unknown tag format \`$fmt' ($why) !"
1343 unless $tagformatfn;
1346 #---------- archive query entrypoints and rest of program ----------
1348 sub canonicalise_suite () {
1349 return if defined $csuite;
1350 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1351 $csuite = archive_query('canonicalise_suite');
1352 if ($isuite ne $csuite) {
1353 progress "canonical suite name for $isuite is $csuite";
1357 sub get_archive_dsc () {
1358 canonicalise_suite();
1359 my @vsns = archive_query('archive_query');
1360 foreach my $vinfo (@vsns) {
1361 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1362 $dscurl = access_cfg('mirror').$subpath;
1363 $dscdata = url_get($dscurl);
1365 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1370 $digester->add($dscdata);
1371 my $got = $digester->hexdigest();
1373 fail "$dscurl has hash $got but".
1374 " archive told us to expect $digest";
1377 my $fmt = getfield $dsc, 'Format';
1378 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1379 "unsupported source format $fmt, sorry";
1381 $dsc_checked = !!$digester;
1382 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1386 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1389 sub check_for_git ();
1390 sub check_for_git () {
1392 my $how = access_cfg('git-check');
1393 if ($how eq 'ssh-cmd') {
1395 (access_cfg_ssh, access_gituserhost(),
1396 access_runeinfo("git-check $package").
1397 " set -e; cd ".access_cfg('git-path').";".
1398 " if test -d $package.git; then echo 1; else echo 0; fi");
1399 my $r= cmdoutput @cmd;
1400 if (defined $r and $r =~ m/^divert (\w+)$/) {
1402 my ($usedistro,) = access_distros();
1403 # NB that if we are pushing, $usedistro will be $distro/push
1404 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1405 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1406 progress "diverting to $divert (using config for $instead_distro)";
1407 return check_for_git();
1409 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1411 } elsif ($how eq 'url') {
1412 my $prefix = access_cfg('git-check-url','git-url');
1413 my $suffix = access_cfg('git-check-suffix','git-suffix',
1414 'RETURN-UNDEF') // '.git';
1415 my $url = "$prefix/$package$suffix";
1416 my @cmd = (@curl, qw(-sS -I), $url);
1417 my $result = cmdoutput @cmd;
1418 $result =~ s/^\S+ 200 .*\n\r?\n//;
1419 # curl -sS -I with https_proxy prints
1420 # HTTP/1.0 200 Connection established
1421 $result =~ m/^\S+ (404|200) /s or
1422 fail "unexpected results from git check query - ".
1423 Dumper($prefix, $result);
1425 if ($code eq '404') {
1427 } elsif ($code eq '200') {
1432 } elsif ($how eq 'true') {
1434 } elsif ($how eq 'false') {
1437 badcfg "unknown git-check \`$how'";
1441 sub create_remote_git_repo () {
1442 my $how = access_cfg('git-create');
1443 if ($how eq 'ssh-cmd') {
1445 (access_cfg_ssh, access_gituserhost(),
1446 access_runeinfo("git-create $package").
1447 "set -e; cd ".access_cfg('git-path').";".
1448 " cp -a _template $package.git");
1449 } elsif ($how eq 'true') {
1452 badcfg "unknown git-create \`$how'";
1456 our ($dsc_hash,$lastpush_mergeinput);
1458 our $ud = '.git/dgit/unpack';
1468 sub mktree_in_ud_here () {
1469 runcmd qw(git init -q);
1470 runcmd qw(git config gc.auto 0);
1471 rmtree('.git/objects');
1472 symlink '../../../../objects','.git/objects' or die $!;
1475 sub git_write_tree () {
1476 my $tree = cmdoutput @git, qw(write-tree);
1477 $tree =~ m/^\w+$/ or die "$tree ?";
1481 sub remove_stray_gits () {
1482 my @gitscmd = qw(find -name .git -prune -print0);
1483 debugcmd "|",@gitscmd;
1484 open GITS, "-|", @gitscmd or die $!;
1489 print STDERR "$us: warning: removing from source package: ",
1490 (messagequote $_), "\n";
1494 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1497 sub mktree_in_ud_from_only_subdir (;$) {
1500 # changes into the subdir
1502 die "expected one subdir but found @dirs ?" unless @dirs==1;
1503 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1507 remove_stray_gits();
1508 mktree_in_ud_here();
1510 my ($format, $fopts) = get_source_format();
1511 if (madformat($format)) {
1516 runcmd @git, qw(add -Af);
1517 my $tree=git_write_tree();
1518 return ($tree,$dir);
1521 our @files_csum_info_fields =
1522 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1523 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1524 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1526 sub dsc_files_info () {
1527 foreach my $csumi (@files_csum_info_fields) {
1528 my ($fname, $module, $method) = @$csumi;
1529 my $field = $dsc->{$fname};
1530 next unless defined $field;
1531 eval "use $module; 1;" or die $@;
1533 foreach (split /\n/, $field) {
1535 m/^(\w+) (\d+) (\S+)$/ or
1536 fail "could not parse .dsc $fname line \`$_'";
1537 my $digester = eval "$module"."->$method;" or die $@;
1542 Digester => $digester,
1547 fail "missing any supported Checksums-* or Files field in ".
1548 $dsc->get_option('name');
1552 map { $_->{Filename} } dsc_files_info();
1555 sub files_compare_inputs (@) {
1560 my $showinputs = sub {
1561 return join "; ", map { $_->get_option('name') } @$inputs;
1564 foreach my $in (@$inputs) {
1566 my $in_name = $in->get_option('name');
1568 printdebug "files_compare_inputs $in_name\n";
1570 foreach my $csumi (@files_csum_info_fields) {
1571 my ($fname) = @$csumi;
1572 printdebug "files_compare_inputs $in_name $fname\n";
1574 my $field = $in->{$fname};
1575 next unless defined $field;
1578 foreach (split /\n/, $field) {
1581 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1582 fail "could not parse $in_name $fname line \`$_'";
1584 printdebug "files_compare_inputs $in_name $fname $f\n";
1588 my $re = \ $record{$f}{$fname};
1590 $fchecked{$f}{$in_name} = 1;
1592 fail "hash or size of $f varies in $fname fields".
1593 " (between: ".$showinputs->().")";
1598 @files = sort @files;
1599 $expected_files //= \@files;
1600 "@$expected_files" eq "@files" or
1601 fail "file list in $in_name varies between hash fields!";
1604 fail "$in_name has no files list field(s)";
1606 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1609 grep { keys %$_ == @$inputs-1 } values %fchecked
1610 or fail "no file appears in all file lists".
1611 " (looked in: ".$showinputs->().")";
1614 sub is_orig_file_in_dsc ($$) {
1615 my ($f, $dsc_files_info) = @_;
1616 return 0 if @$dsc_files_info <= 1;
1617 # One file means no origs, and the filename doesn't have a "what
1618 # part of dsc" component. (Consider versions ending `.orig'.)
1619 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1623 sub is_orig_file_of_vsn ($$) {
1624 my ($f, $upstreamvsn) = @_;
1625 my $base = srcfn $upstreamvsn, '';
1626 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1630 sub changes_update_origs_from_dsc ($$$$) {
1631 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1633 printdebug "checking origs needed ($upstreamvsn)...\n";
1634 $_ = getfield $changes, 'Files';
1635 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1636 fail "cannot find section/priority from .changes Files field";
1637 my $placementinfo = $1;
1639 printdebug "checking origs needed placement '$placementinfo'...\n";
1640 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1641 $l =~ m/\S+$/ or next;
1643 printdebug "origs $file | $l\n";
1644 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1645 printdebug "origs $file is_orig\n";
1646 my $have = archive_query('file_in_archive', $file);
1647 if (!defined $have) {
1649 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1655 printdebug "origs $file \$#\$have=$#$have\n";
1656 foreach my $h (@$have) {
1659 foreach my $csumi (@files_csum_info_fields) {
1660 my ($fname, $module, $method, $archivefield) = @$csumi;
1661 next unless defined $h->{$archivefield};
1662 $_ = $dsc->{$fname};
1663 next unless defined;
1664 m/^(\w+) .* \Q$file\E$/m or
1665 fail ".dsc $fname missing entry for $file";
1666 if ($h->{$archivefield} eq $1) {
1670 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1673 die "$file ".Dumper($h)." ?!" if $same && @differ;
1676 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1679 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1680 if (@found_differ && !$found_same) {
1682 "archive contains $file with different checksum",
1685 # Now we edit the changes file to add or remove it
1686 foreach my $csumi (@files_csum_info_fields) {
1687 my ($fname, $module, $method, $archivefield) = @$csumi;
1688 next unless defined $changes->{$fname};
1690 # in archive, delete from .changes if it's there
1691 $changed{$file} = "removed" if
1692 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1693 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1694 # not in archive, but it's here in the .changes
1696 my $dsc_data = getfield $dsc, $fname;
1697 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1699 $extra =~ s/ \d+ /$&$placementinfo /
1700 or die "$fname $extra >$dsc_data< ?"
1701 if $fname eq 'Files';
1702 $changes->{$fname} .= "\n". $extra;
1703 $changed{$file} = "added";
1708 foreach my $file (keys %changed) {
1710 "edited .changes for archive .orig contents: %s %s",
1711 $changed{$file}, $file;
1713 my $chtmp = "$changesfile.tmp";
1714 $changes->save($chtmp);
1716 rename $chtmp,$changesfile or die "$changesfile $!";
1718 progress "[new .changes left in $changesfile]";
1721 progress "$changesfile already has appropriate .orig(s) (if any)";
1725 sub make_commit ($) {
1727 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1730 sub make_commit_text ($) {
1733 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1735 print Dumper($text) if $debuglevel > 1;
1736 my $child = open2($out, $in, @cmd) or die $!;
1739 print $in $text or die $!;
1740 close $in or die $!;
1742 $h =~ m/^\w+$/ or die;
1744 printdebug "=> $h\n";
1747 waitpid $child, 0 == $child or die "$child $!";
1748 $? and failedcmd @cmd;
1752 sub clogp_authline ($) {
1754 my $author = getfield $clogp, 'Maintainer';
1755 $author =~ s#,.*##ms;
1756 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1757 my $authline = "$author $date";
1758 $authline =~ m/$git_authline_re/o or
1759 fail "unexpected commit author line format \`$authline'".
1760 " (was generated from changelog Maintainer field)";
1761 return ($1,$2,$3) if wantarray;
1765 sub vendor_patches_distro ($$) {
1766 my ($checkdistro, $what) = @_;
1767 return unless defined $checkdistro;
1769 my $series = "debian/patches/\L$checkdistro\E.series";
1770 printdebug "checking for vendor-specific $series ($what)\n";
1772 if (!open SERIES, "<", $series) {
1773 die "$series $!" unless $!==ENOENT;
1782 Unfortunately, this source package uses a feature of dpkg-source where
1783 the same source package unpacks to different source code on different
1784 distros. dgit cannot safely operate on such packages on affected
1785 distros, because the meaning of source packages is not stable.
1787 Please ask the distro/maintainer to remove the distro-specific series
1788 files and use a different technique (if necessary, uploading actually
1789 different packages, if different distros are supposed to have
1793 fail "Found active distro-specific series file for".
1794 " $checkdistro ($what): $series, cannot continue";
1796 die "$series $!" if SERIES->error;
1800 sub check_for_vendor_patches () {
1801 # This dpkg-source feature doesn't seem to be documented anywhere!
1802 # But it can be found in the changelog (reformatted):
1804 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1805 # Author: Raphael Hertzog <hertzog@debian.org>
1806 # Date: Sun Oct 3 09:36:48 2010 +0200
1808 # dpkg-source: correctly create .pc/.quilt_series with alternate
1811 # If you have debian/patches/ubuntu.series and you were
1812 # unpacking the source package on ubuntu, quilt was still
1813 # directed to debian/patches/series instead of
1814 # debian/patches/ubuntu.series.
1816 # debian/changelog | 3 +++
1817 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1818 # 2 files changed, 6 insertions(+), 1 deletion(-)
1821 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1822 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1823 "Dpkg::Vendor \`current vendor'");
1824 vendor_patches_distro(access_basedistro(),
1825 "distro being accessed");
1828 sub generate_commits_from_dsc () {
1829 # See big comment in fetch_from_archive, below.
1830 # See also README.dsc-import.
1834 my @dfi = dsc_files_info();
1835 foreach my $fi (@dfi) {
1836 my $f = $fi->{Filename};
1837 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1839 printdebug "considering linking $f: ";
1841 link_ltarget "../../../../$f", $f
1842 or ((printdebug "($!) "), 0)
1846 printdebug "linked.\n";
1848 complete_file_from_dsc('.', $fi)
1851 if (is_orig_file_in_dsc($f, \@dfi)) {
1852 link $f, "../../../../$f"
1858 # We unpack and record the orig tarballs first, so that we only
1859 # need disk space for one private copy of the unpacked source.
1860 # But we can't make them into commits until we have the metadata
1861 # from the debian/changelog, so we record the tree objects now and
1862 # make them into commits later.
1864 my $upstreamv = upstreamversion $dsc->{version};
1865 my $orig_f_base = srcfn $upstreamv, '';
1867 foreach my $fi (@dfi) {
1868 # We actually import, and record as a commit, every tarball
1869 # (unless there is only one file, in which case there seems
1872 my $f = $fi->{Filename};
1873 printdebug "import considering $f ";
1874 (printdebug "only one dfi\n"), next if @dfi == 1;
1875 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1876 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1880 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1882 printdebug "Y ", (join ' ', map { $_//"(none)" }
1883 $compr_ext, $orig_f_part
1886 my $input = new IO::File $f, '<' or die "$f $!";
1890 if (defined $compr_ext) {
1892 Dpkg::Compression::compression_guess_from_filename $f;
1893 fail "Dpkg::Compression cannot handle file $f in source package"
1894 if defined $compr_ext && !defined $cname;
1896 new Dpkg::Compression::Process compression => $cname;
1897 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1898 my $compr_fh = new IO::Handle;
1899 my $compr_pid = open $compr_fh, "-|" // die $!;
1901 open STDIN, "<&", $input or die $!;
1903 die "dgit (child): exec $compr_cmd[0]: $!\n";
1908 rmtree "../unpack-tar";
1909 mkdir "../unpack-tar" or die $!;
1910 my @tarcmd = qw(tar -x -f -
1911 --no-same-owner --no-same-permissions
1912 --no-acls --no-xattrs --no-selinux);
1913 my $tar_pid = fork // die $!;
1915 chdir "../unpack-tar" or die $!;
1916 open STDIN, "<&", $input or die $!;
1918 die "dgit (child): exec $tarcmd[0]: $!";
1920 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1921 !$? or failedcmd @tarcmd;
1924 (@compr_cmd ? failedcmd @compr_cmd
1926 # finally, we have the results in "tarball", but maybe
1927 # with the wrong permissions
1929 runcmd qw(chmod -R +rwX ../unpack-tar);
1930 changedir "../unpack-tar";
1931 my ($tree) = mktree_in_ud_from_only_subdir(1);
1932 changedir "../../unpack";
1933 rmtree "../unpack-tar";
1935 my $ent = [ $f, $tree ];
1937 Orig => !!$orig_f_part,
1938 Sort => (!$orig_f_part ? 2 :
1939 $orig_f_part =~ m/-/g ? 1 :
1947 # put any without "_" first (spec is not clear whether files
1948 # are always in the usual order). Tarballs without "_" are
1949 # the main orig or the debian tarball.
1950 $a->{Sort} <=> $b->{Sort} or
1954 my $any_orig = grep { $_->{Orig} } @tartrees;
1956 my $dscfn = "$package.dsc";
1958 my $treeimporthow = 'package';
1960 open D, ">", $dscfn or die "$dscfn: $!";
1961 print D $dscdata or die "$dscfn: $!";
1962 close D or die "$dscfn: $!";
1963 my @cmd = qw(dpkg-source);
1964 push @cmd, '--no-check' if $dsc_checked;
1965 if (madformat $dsc->{format}) {
1966 push @cmd, '--skip-patches';
1967 $treeimporthow = 'unpatched';
1969 push @cmd, qw(-x --), $dscfn;
1972 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1973 if (madformat $dsc->{format}) {
1974 check_for_vendor_patches();
1978 if (madformat $dsc->{format}) {
1979 my @pcmd = qw(dpkg-source --before-build .);
1980 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1982 runcmd @git, qw(add -Af);
1983 $dappliedtree = git_write_tree();
1986 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1987 debugcmd "|",@clogcmd;
1988 open CLOGS, "-|", @clogcmd or die $!;
1993 printdebug "import clog search...\n";
1996 my $stanzatext = do { local $/=""; <CLOGS>; };
1997 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1998 last if !defined $stanzatext;
2000 my $desc = "package changelog, entry no.$.";
2001 open my $stanzafh, "<", \$stanzatext or die;
2002 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2003 $clogp //= $thisstanza;
2005 printdebug "import clog $thisstanza->{version} $desc...\n";
2007 last if !$any_orig; # we don't need $r1clogp
2009 # We look for the first (most recent) changelog entry whose
2010 # version number is lower than the upstream version of this
2011 # package. Then the last (least recent) previous changelog
2012 # entry is treated as the one which introduced this upstream
2013 # version and used for the synthetic commits for the upstream
2016 # One might think that a more sophisticated algorithm would be
2017 # necessary. But: we do not want to scan the whole changelog
2018 # file. Stopping when we see an earlier version, which
2019 # necessarily then is an earlier upstream version, is the only
2020 # realistic way to do that. Then, either the earliest
2021 # changelog entry we have seen so far is indeed the earliest
2022 # upload of this upstream version; or there are only changelog
2023 # entries relating to later upstream versions (which is not
2024 # possible unless the changelog and .dsc disagree about the
2025 # version). Then it remains to choose between the physically
2026 # last entry in the file, and the one with the lowest version
2027 # number. If these are not the same, we guess that the
2028 # versions were created in a non-monotic order rather than
2029 # that the changelog entries have been misordered.
2031 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2033 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2034 $r1clogp = $thisstanza;
2036 printdebug "import clog $r1clogp->{version} becomes r1\n";
2038 die $! if CLOGS->error;
2039 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2041 $clogp or fail "package changelog has no entries!";
2043 my $authline = clogp_authline $clogp;
2044 my $changes = getfield $clogp, 'Changes';
2045 my $cversion = getfield $clogp, 'Version';
2048 $r1clogp //= $clogp; # maybe there's only one entry;
2049 my $r1authline = clogp_authline $r1clogp;
2050 # Strictly, r1authline might now be wrong if it's going to be
2051 # unused because !$any_orig. Whatever.
2053 printdebug "import tartrees authline $authline\n";
2054 printdebug "import tartrees r1authline $r1authline\n";
2056 foreach my $tt (@tartrees) {
2057 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2059 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2062 committer $r1authline
2066 [dgit import orig $tt->{F}]
2074 [dgit import tarball $package $cversion $tt->{F}]
2079 printdebug "import main commit\n";
2081 open C, ">../commit.tmp" or die $!;
2082 print C <<END or die $!;
2085 print C <<END or die $! foreach @tartrees;
2088 print C <<END or die $!;
2094 [dgit import $treeimporthow $package $cversion]
2098 my $rawimport_hash = make_commit qw(../commit.tmp);
2100 if (madformat $dsc->{format}) {
2101 printdebug "import apply patches...\n";
2103 # regularise the state of the working tree so that
2104 # the checkout of $rawimport_hash works nicely.
2105 my $dappliedcommit = make_commit_text(<<END);
2112 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2114 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2116 # We need the answers to be reproducible
2117 my @authline = clogp_authline($clogp);
2118 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2119 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2120 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2121 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2122 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2123 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2125 my $path = $ENV{PATH} or die;
2127 foreach my $use_absurd (qw(0 1)) {
2128 local $ENV{PATH} = $path;
2131 progress "warning: $@";
2132 $path = "$absurdity:$path";
2133 progress "$us: trying slow absurd-git-apply...";
2134 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2139 die "forbid absurd git-apply\n" if $use_absurd
2140 && forceing [qw(import-gitapply-no-absurd)];
2141 die "only absurd git-apply!\n" if !$use_absurd
2142 && forceing [qw(import-gitapply-absurd)];
2144 local $ENV{PATH} = $path if $use_absurd;
2146 my @showcmd = (gbp_pq, qw(import));
2147 my @realcmd = shell_cmd
2148 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2149 debugcmd "+",@realcmd;
2150 if (system @realcmd) {
2151 die +(shellquote @showcmd).
2153 failedcmd_waitstatus()."\n";
2156 my $gapplied = git_rev_parse('HEAD');
2157 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2158 $gappliedtree eq $dappliedtree or
2160 gbp-pq import and dpkg-source disagree!
2161 gbp-pq import gave commit $gapplied
2162 gbp-pq import gave tree $gappliedtree
2163 dpkg-source --before-build gave tree $dappliedtree
2165 $rawimport_hash = $gapplied;
2170 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2175 progress "synthesised git commit from .dsc $cversion";
2177 my $rawimport_mergeinput = {
2178 Commit => $rawimport_hash,
2179 Info => "Import of source package",
2181 my @output = ($rawimport_mergeinput);
2183 if ($lastpush_mergeinput) {
2184 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2185 my $oversion = getfield $oldclogp, 'Version';
2187 version_compare($oversion, $cversion);
2189 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2190 { Message => <<END, ReverseParents => 1 });
2191 Record $package ($cversion) in archive suite $csuite
2193 } elsif ($vcmp > 0) {
2194 print STDERR <<END or die $!;
2196 Version actually in archive: $cversion (older)
2197 Last version pushed with dgit: $oversion (newer or same)
2200 @output = $lastpush_mergeinput;
2202 # Same version. Use what's in the server git branch,
2203 # discarding our own import. (This could happen if the
2204 # server automatically imports all packages into git.)
2205 @output = $lastpush_mergeinput;
2208 changedir '../../../..';
2213 sub complete_file_from_dsc ($$) {
2214 our ($dstdir, $fi) = @_;
2215 # Ensures that we have, in $dir, the file $fi, with the correct
2216 # contents. (Downloading it from alongside $dscurl if necessary.)
2218 my $f = $fi->{Filename};
2219 my $tf = "$dstdir/$f";
2222 if (stat_exists $tf) {
2223 progress "using existing $f";
2225 printdebug "$tf does not exist, need to fetch\n";
2227 $furl =~ s{/[^/]+$}{};
2229 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2230 die "$f ?" if $f =~ m#/#;
2231 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2232 return 0 if !act_local();
2236 open F, "<", "$tf" or die "$tf: $!";
2237 $fi->{Digester}->reset();
2238 $fi->{Digester}->addfile(*F);
2239 F->error and die $!;
2240 my $got = $fi->{Digester}->hexdigest();
2241 $got eq $fi->{Hash} or
2242 fail "file $f has hash $got but .dsc".
2243 " demands hash $fi->{Hash} ".
2244 ($downloaded ? "(got wrong file from archive!)"
2245 : "(perhaps you should delete this file?)");
2250 sub ensure_we_have_orig () {
2251 my @dfi = dsc_files_info();
2252 foreach my $fi (@dfi) {
2253 my $f = $fi->{Filename};
2254 next unless is_orig_file_in_dsc($f, \@dfi);
2255 complete_file_from_dsc('..', $fi)
2260 sub git_fetch_us () {
2261 # Want to fetch only what we are going to use, unless
2262 # deliberately-not-ff, in which case we must fetch everything.
2264 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2266 (quiltmode_splitbrain
2267 ? (map { $_->('*',access_basedistro) }
2268 \&debiantag_new, \&debiantag_maintview)
2269 : debiantags('*',access_basedistro));
2270 push @specs, server_branch($csuite);
2271 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2273 # This is rather miserable:
2274 # When git fetch --prune is passed a fetchspec ending with a *,
2275 # it does a plausible thing. If there is no * then:
2276 # - it matches subpaths too, even if the supplied refspec
2277 # starts refs, and behaves completely madly if the source
2278 # has refs/refs/something. (See, for example, Debian #NNNN.)
2279 # - if there is no matching remote ref, it bombs out the whole
2281 # We want to fetch a fixed ref, and we don't know in advance
2282 # if it exists, so this is not suitable.
2284 # Our workaround is to use git ls-remote. git ls-remote has its
2285 # own qairks. Notably, it has the absurd multi-tail-matching
2286 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2287 # refs/refs/foo etc.
2289 # Also, we want an idempotent snapshot, but we have to make two
2290 # calls to the remote: one to git ls-remote and to git fetch. The
2291 # solution is use git ls-remote to obtain a target state, and
2292 # git fetch to try to generate it. If we don't manage to generate
2293 # the target state, we try again.
2295 printdebug "git_fetch_us specs @specs\n";
2297 my $specre = join '|', map {
2303 printdebug "git_fetch_us specre=$specre\n";
2304 my $wanted_rref = sub {
2306 return m/^(?:$specre)$/o;
2309 my $fetch_iteration = 0;
2312 printdebug "git_fetch_us iteration $fetch_iteration\n";
2313 if (++$fetch_iteration > 10) {
2314 fail "too many iterations trying to get sane fetch!";
2317 my @look = map { "refs/$_" } @specs;
2318 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2322 open GITLS, "-|", @lcmd or die $!;
2324 printdebug "=> ", $_;
2325 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2326 my ($objid,$rrefname) = ($1,$2);
2327 if (!$wanted_rref->($rrefname)) {
2329 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2333 $wantr{$rrefname} = $objid;
2336 close GITLS or failedcmd @lcmd;
2338 # OK, now %want is exactly what we want for refs in @specs
2340 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2341 "+refs/$_:".lrfetchrefs."/$_";
2344 printdebug "git_fetch_us fspecs @fspecs\n";
2346 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2347 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2350 %lrfetchrefs_f = ();
2353 git_for_each_ref(lrfetchrefs, sub {
2354 my ($objid,$objtype,$lrefname,$reftail) = @_;
2355 $lrfetchrefs_f{$lrefname} = $objid;
2356 $objgot{$objid} = 1;
2359 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2360 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2361 if (!exists $wantr{$rrefname}) {
2362 if ($wanted_rref->($rrefname)) {
2364 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2368 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2371 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2372 delete $lrfetchrefs_f{$lrefname};
2376 foreach my $rrefname (sort keys %wantr) {
2377 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2378 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2379 my $want = $wantr{$rrefname};
2380 next if $got eq $want;
2381 if (!defined $objgot{$want}) {
2383 warning: git ls-remote suggests we want $lrefname
2384 warning: and it should refer to $want
2385 warning: but git fetch didn't fetch that object to any relevant ref.
2386 warning: This may be due to a race with someone updating the server.
2387 warning: Will try again...
2389 next FETCH_ITERATION;
2392 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2394 runcmd_ordryrun_local @git, qw(update-ref -m),
2395 "dgit fetch git fetch fixup", $lrefname, $want;
2396 $lrfetchrefs_f{$lrefname} = $want;
2400 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2401 Dumper(\%lrfetchrefs_f);
2404 my @tagpats = debiantags('*',access_basedistro);
2406 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2408 printdebug "currently $fullrefname=$objid\n";
2409 $here{$fullrefname} = $objid;
2411 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2412 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2413 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2414 printdebug "offered $lref=$objid\n";
2415 if (!defined $here{$lref}) {
2416 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2417 runcmd_ordryrun_local @upd;
2418 lrfetchref_used $fullrefname;
2419 } elsif ($here{$lref} eq $objid) {
2420 lrfetchref_used $fullrefname;
2423 "Not updateting $lref from $here{$lref} to $objid.\n";
2428 sub mergeinfo_getclogp ($) {
2429 # Ensures thit $mi->{Clogp} exists and returns it
2431 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2434 sub mergeinfo_version ($) {
2435 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2438 sub fetch_from_archive () {
2439 ensure_setup_existing_tree();
2441 # Ensures that lrref() is what is actually in the archive, one way
2442 # or another, according to us - ie this client's
2443 # appropritaely-updated archive view. Also returns the commit id.
2444 # If there is nothing in the archive, leaves lrref alone and
2445 # returns undef. git_fetch_us must have already been called.
2449 foreach my $field (@ourdscfield) {
2450 $dsc_hash = $dsc->{$field};
2451 last if defined $dsc_hash;
2453 if (defined $dsc_hash) {
2454 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2456 progress "last upload to archive specified git hash";
2458 progress "last upload to archive has NO git hash";
2461 progress "no version available from the archive";
2464 # If the archive's .dsc has a Dgit field, there are three
2465 # relevant git commitids we need to choose between and/or merge
2467 # 1. $dsc_hash: the Dgit field from the archive
2468 # 2. $lastpush_hash: the suite branch on the dgit git server
2469 # 3. $lastfetch_hash: our local tracking brach for the suite
2471 # These may all be distinct and need not be in any fast forward
2474 # If the dsc was pushed to this suite, then the server suite
2475 # branch will have been updated; but it might have been pushed to
2476 # a different suite and copied by the archive. Conversely a more
2477 # recent version may have been pushed with dgit but not appeared
2478 # in the archive (yet).
2480 # $lastfetch_hash may be awkward because archive imports
2481 # (particularly, imports of Dgit-less .dscs) are performed only as
2482 # needed on individual clients, so different clients may perform a
2483 # different subset of them - and these imports are only made
2484 # public during push. So $lastfetch_hash may represent a set of
2485 # imports different to a subsequent upload by a different dgit
2488 # Our approach is as follows:
2490 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2491 # descendant of $dsc_hash, then it was pushed by a dgit user who
2492 # had based their work on $dsc_hash, so we should prefer it.
2493 # Otherwise, $dsc_hash was installed into this suite in the
2494 # archive other than by a dgit push, and (necessarily) after the
2495 # last dgit push into that suite (since a dgit push would have
2496 # been descended from the dgit server git branch); thus, in that
2497 # case, we prefer the archive's version (and produce a
2498 # pseudo-merge to overwrite the dgit server git branch).
2500 # (If there is no Dgit field in the archive's .dsc then
2501 # generate_commit_from_dsc uses the version numbers to decide
2502 # whether the suite branch or the archive is newer. If the suite
2503 # branch is newer it ignores the archive's .dsc; otherwise it
2504 # generates an import of the .dsc, and produces a pseudo-merge to
2505 # overwrite the suite branch with the archive contents.)
2507 # The outcome of that part of the algorithm is the `public view',
2508 # and is same for all dgit clients: it does not depend on any
2509 # unpublished history in the local tracking branch.
2511 # As between the public view and the local tracking branch: The
2512 # local tracking branch is only updated by dgit fetch, and
2513 # whenever dgit fetch runs it includes the public view in the
2514 # local tracking branch. Therefore if the public view is not
2515 # descended from the local tracking branch, the local tracking
2516 # branch must contain history which was imported from the archive
2517 # but never pushed; and, its tip is now out of date. So, we make
2518 # a pseudo-merge to overwrite the old imports and stitch the old
2521 # Finally: we do not necessarily reify the public view (as
2522 # described above). This is so that we do not end up stacking two
2523 # pseudo-merges. So what we actually do is figure out the inputs
2524 # to any public view pseudo-merge and put them in @mergeinputs.
2527 # $mergeinputs[]{Commit}
2528 # $mergeinputs[]{Info}
2529 # $mergeinputs[0] is the one whose tree we use
2530 # @mergeinputs is in the order we use in the actual commit)
2533 # $mergeinputs[]{Message} is a commit message to use
2534 # $mergeinputs[]{ReverseParents} if def specifies that parent
2535 # list should be in opposite order
2536 # Such an entry has no Commit or Info. It applies only when found
2537 # in the last entry. (This ugliness is to support making
2538 # identical imports to previous dgit versions.)
2540 my $lastpush_hash = git_get_ref(lrfetchref());
2541 printdebug "previous reference hash=$lastpush_hash\n";
2542 $lastpush_mergeinput = $lastpush_hash && {
2543 Commit => $lastpush_hash,
2544 Info => "dgit suite branch on dgit git server",
2547 my $lastfetch_hash = git_get_ref(lrref());
2548 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2549 my $lastfetch_mergeinput = $lastfetch_hash && {
2550 Commit => $lastfetch_hash,
2551 Info => "dgit client's archive history view",
2554 my $dsc_mergeinput = $dsc_hash && {
2555 Commit => $dsc_hash,
2556 Info => "Dgit field in .dsc from archive",
2560 my $del_lrfetchrefs = sub {
2563 printdebug "del_lrfetchrefs...\n";
2564 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2565 my $objid = $lrfetchrefs_d{$fullrefname};
2566 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2568 $gur ||= new IO::Handle;
2569 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2571 printf $gur "delete %s %s\n", $fullrefname, $objid;
2574 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2578 if (defined $dsc_hash) {
2579 ensure_we_have_orig();
2580 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2581 @mergeinputs = $dsc_mergeinput
2582 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2583 print STDERR <<END or die $!;
2585 Git commit in archive is behind the last version allegedly pushed/uploaded.
2586 Commit referred to by archive: $dsc_hash
2587 Last version pushed with dgit: $lastpush_hash
2590 @mergeinputs = ($lastpush_mergeinput);
2592 # Archive has .dsc which is not a descendant of the last dgit
2593 # push. This can happen if the archive moves .dscs about.
2594 # Just follow its lead.
2595 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2596 progress "archive .dsc names newer git commit";
2597 @mergeinputs = ($dsc_mergeinput);
2599 progress "archive .dsc names other git commit, fixing up";
2600 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2604 @mergeinputs = generate_commits_from_dsc();
2605 # We have just done an import. Now, our import algorithm might
2606 # have been improved. But even so we do not want to generate
2607 # a new different import of the same package. So if the
2608 # version numbers are the same, just use our existing version.
2609 # If the version numbers are different, the archive has changed
2610 # (perhaps, rewound).
2611 if ($lastfetch_mergeinput &&
2612 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2613 (mergeinfo_version $mergeinputs[0]) )) {
2614 @mergeinputs = ($lastfetch_mergeinput);
2616 } elsif ($lastpush_hash) {
2617 # only in git, not in the archive yet
2618 @mergeinputs = ($lastpush_mergeinput);
2619 print STDERR <<END or die $!;
2621 Package not found in the archive, but has allegedly been pushed using dgit.
2625 printdebug "nothing found!\n";
2626 if (defined $skew_warning_vsn) {
2627 print STDERR <<END or die $!;
2629 Warning: relevant archive skew detected.
2630 Archive allegedly contains $skew_warning_vsn
2631 But we were not able to obtain any version from the archive or git.
2635 unshift @end, $del_lrfetchrefs;
2639 if ($lastfetch_hash &&
2641 my $h = $_->{Commit};
2642 $h and is_fast_fwd($lastfetch_hash, $h);
2643 # If true, one of the existing parents of this commit
2644 # is a descendant of the $lastfetch_hash, so we'll
2645 # be ff from that automatically.
2649 push @mergeinputs, $lastfetch_mergeinput;
2652 printdebug "fetch mergeinfos:\n";
2653 foreach my $mi (@mergeinputs) {
2655 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2657 printdebug sprintf " ReverseParents=%d Message=%s",
2658 $mi->{ReverseParents}, $mi->{Message};
2662 my $compat_info= pop @mergeinputs
2663 if $mergeinputs[$#mergeinputs]{Message};
2665 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2668 if (@mergeinputs > 1) {
2670 my $tree_commit = $mergeinputs[0]{Commit};
2672 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2673 $tree =~ m/\n\n/; $tree = $`;
2674 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2677 # We use the changelog author of the package in question the
2678 # author of this pseudo-merge. This is (roughly) correct if
2679 # this commit is simply representing aa non-dgit upload.
2680 # (Roughly because it does not record sponsorship - but we
2681 # don't have sponsorship info because that's in the .changes,
2682 # which isn't in the archivw.)
2684 # But, it might be that we are representing archive history
2685 # updates (including in-archive copies). These are not really
2686 # the responsibility of the person who created the .dsc, but
2687 # there is no-one whose name we should better use. (The
2688 # author of the .dsc-named commit is clearly worse.)
2690 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2691 my $author = clogp_authline $useclogp;
2692 my $cversion = getfield $useclogp, 'Version';
2694 my $mcf = ".git/dgit/mergecommit";
2695 open MC, ">", $mcf or die "$mcf $!";
2696 print MC <<END or die $!;
2700 my @parents = grep { $_->{Commit} } @mergeinputs;
2701 @parents = reverse @parents if $compat_info->{ReverseParents};
2702 print MC <<END or die $! foreach @parents;
2706 print MC <<END or die $!;
2712 if (defined $compat_info->{Message}) {
2713 print MC $compat_info->{Message} or die $!;
2715 print MC <<END or die $!;
2716 Record $package ($cversion) in archive suite $csuite
2720 my $message_add_info = sub {
2722 my $mversion = mergeinfo_version $mi;
2723 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2727 $message_add_info->($mergeinputs[0]);
2728 print MC <<END or die $!;
2729 should be treated as descended from
2731 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2735 $hash = make_commit $mcf;
2737 $hash = $mergeinputs[0]{Commit};
2739 printdebug "fetch hash=$hash\n";
2742 my ($lasth, $what) = @_;
2743 return unless $lasth;
2744 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2747 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2749 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2751 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2752 'DGIT_ARCHIVE', $hash;
2753 cmdoutput @git, qw(log -n2), $hash;
2754 # ... gives git a chance to complain if our commit is malformed
2756 if (defined $skew_warning_vsn) {
2758 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2759 my $gotclogp = commit_getclogp($hash);
2760 my $got_vsn = getfield $gotclogp, 'Version';
2761 printdebug "SKEW CHECK GOT $got_vsn\n";
2762 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2763 print STDERR <<END or die $!;
2765 Warning: archive skew detected. Using the available version:
2766 Archive allegedly contains $skew_warning_vsn
2767 We were able to obtain only $got_vsn
2773 if ($lastfetch_hash ne $hash) {
2774 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2778 dryrun_report @upd_cmd;
2782 lrfetchref_used lrfetchref();
2784 unshift @end, $del_lrfetchrefs;
2788 sub set_local_git_config ($$) {
2790 runcmd @git, qw(config), $k, $v;
2793 sub setup_mergechangelogs (;$) {
2795 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2797 my $driver = 'dpkg-mergechangelogs';
2798 my $cb = "merge.$driver";
2799 my $attrs = '.git/info/attributes';
2800 ensuredir '.git/info';
2802 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2803 if (!open ATTRS, "<", $attrs) {
2804 $!==ENOENT or die "$attrs: $!";
2808 next if m{^debian/changelog\s};
2809 print NATTRS $_, "\n" or die $!;
2811 ATTRS->error and die $!;
2814 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2817 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2818 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2820 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2823 sub setup_useremail (;$) {
2825 return unless $always || access_cfg_bool(1, 'setup-useremail');
2828 my ($k, $envvar) = @_;
2829 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2830 return unless defined $v;
2831 set_local_git_config "user.$k", $v;
2834 $setup->('email', 'DEBEMAIL');
2835 $setup->('name', 'DEBFULLNAME');
2838 sub ensure_setup_existing_tree () {
2839 my $k = "remote.$remotename.skipdefaultupdate";
2840 my $c = git_get_config $k;
2841 return if defined $c;
2842 set_local_git_config $k, 'true';
2845 sub setup_new_tree () {
2846 setup_mergechangelogs();
2852 canonicalise_suite();
2853 badusage "dry run makes no sense with clone" unless act_local();
2854 my $hasgit = check_for_git();
2855 mkdir $dstdir or fail "create \`$dstdir': $!";
2857 runcmd @git, qw(init -q);
2858 my $giturl = access_giturl(1);
2859 if (defined $giturl) {
2860 open H, "> .git/HEAD" or die $!;
2861 print H "ref: ".lref()."\n" or die $!;
2863 runcmd @git, qw(remote add), 'origin', $giturl;
2866 progress "fetching existing git history";
2868 runcmd_ordryrun_local @git, qw(fetch origin);
2870 progress "starting new git history";
2872 fetch_from_archive() or no_such_package;
2873 my $vcsgiturl = $dsc->{'Vcs-Git'};
2874 if (length $vcsgiturl) {
2875 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2876 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2879 runcmd @git, qw(reset --hard), lrref();
2880 runcmd qw(bash -ec), <<'END';
2882 git ls-tree -r --name-only -z HEAD | \
2883 xargs -0r touch -r . --
2885 printdone "ready for work in $dstdir";
2889 if (check_for_git()) {
2892 fetch_from_archive() or no_such_package();
2893 printdone "fetched into ".lrref();
2898 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2900 printdone "fetched to ".lrref()." and merged into HEAD";
2903 sub check_not_dirty () {
2904 foreach my $f (qw(local-options local-patch-header)) {
2905 if (stat_exists "debian/source/$f") {
2906 fail "git tree contains debian/source/$f";
2910 return if $ignoredirty;
2912 my @cmd = (@git, qw(diff --quiet HEAD));
2914 $!=0; $?=-1; system @cmd;
2917 fail "working tree is dirty (does not match HEAD)";
2923 sub commit_admin ($) {
2926 runcmd_ordryrun_local @git, qw(commit -m), $m;
2929 sub commit_quilty_patch () {
2930 my $output = cmdoutput @git, qw(status --porcelain);
2932 foreach my $l (split /\n/, $output) {
2933 next unless $l =~ m/\S/;
2934 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2938 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2940 progress "nothing quilty to commit, ok.";
2943 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2944 runcmd_ordryrun_local @git, qw(add -f), @adds;
2946 Commit Debian 3.0 (quilt) metadata
2948 [dgit ($our_version) quilt-fixup]
2952 sub get_source_format () {
2954 if (open F, "debian/source/options") {
2958 s/\s+$//; # ignore missing final newline
2960 my ($k, $v) = ($`, $'); #');
2961 $v =~ s/^"(.*)"$/$1/;
2967 F->error and die $!;
2970 die $! unless $!==&ENOENT;
2973 if (!open F, "debian/source/format") {
2974 die $! unless $!==&ENOENT;
2978 F->error and die $!;
2980 return ($_, \%options);
2983 sub madformat_wantfixup ($) {
2985 return 0 unless $format eq '3.0 (quilt)';
2986 our $quilt_mode_warned;
2987 if ($quilt_mode eq 'nocheck') {
2988 progress "Not doing any fixup of \`$format' due to".
2989 " ----no-quilt-fixup or --quilt=nocheck"
2990 unless $quilt_mode_warned++;
2993 progress "Format \`$format', need to check/update patch stack"
2994 unless $quilt_mode_warned++;
2998 sub maybe_split_brain_save ($$$) {
2999 my ($headref, $dgitview, $msg) = @_;
3000 # => message fragment "$saved" describing disposition of $dgitview
3001 return "commit id $dgitview" unless defined $split_brain_save;
3002 my @cmd = (shell_cmd "cd ../../../..",
3003 @git, qw(update-ref -m),
3004 "dgit --dgit-view-save $msg HEAD=$headref",
3005 $split_brain_save, $dgitview);
3007 return "and left in $split_brain_save";
3010 # An "infopair" is a tuple [ $thing, $what ]
3011 # (often $thing is a commit hash; $what is a description)
3013 sub infopair_cond_equal ($$) {
3015 $x->[0] eq $y->[0] or fail <<END;
3016 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3020 sub infopair_lrf_tag_lookup ($$) {
3021 my ($tagnames, $what) = @_;
3022 # $tagname may be an array ref
3023 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3024 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3025 foreach my $tagname (@tagnames) {
3026 my $lrefname = lrfetchrefs."/tags/$tagname";
3027 my $tagobj = $lrfetchrefs_f{$lrefname};
3028 next unless defined $tagobj;
3029 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3030 return [ git_rev_parse($tagobj), $what ];
3032 fail @tagnames==1 ? <<END : <<END;
3033 Wanted tag $what (@tagnames) on dgit server, but not found
3035 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3039 sub infopair_cond_ff ($$) {
3040 my ($anc,$desc) = @_;
3041 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3042 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3046 sub pseudomerge_version_check ($$) {
3047 my ($clogp, $archive_hash) = @_;
3049 my $arch_clogp = commit_getclogp $archive_hash;
3050 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3051 'version currently in archive' ];
3052 if (defined $overwrite_version) {
3053 if (length $overwrite_version) {
3054 infopair_cond_equal([ $overwrite_version,
3055 '--overwrite= version' ],
3058 my $v = $i_arch_v->[0];
3059 progress "Checking package changelog for archive version $v ...";
3061 my @xa = ("-f$v", "-t$v");
3062 my $vclogp = parsechangelog @xa;
3063 my $cv = [ (getfield $vclogp, 'Version'),
3064 "Version field from dpkg-parsechangelog @xa" ];
3065 infopair_cond_equal($i_arch_v, $cv);
3068 $@ =~ s/^dgit: //gm;
3070 "Perhaps debian/changelog does not mention $v ?";
3075 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3079 sub pseudomerge_make_commit ($$$$ $$) {
3080 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3081 $msg_cmd, $msg_msg) = @_;
3082 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3084 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3085 my $authline = clogp_authline $clogp;
3089 !defined $overwrite_version ? ""
3090 : !length $overwrite_version ? " --overwrite"
3091 : " --overwrite=".$overwrite_version;
3094 my $pmf = ".git/dgit/pseudomerge";
3095 open MC, ">", $pmf or die "$pmf $!";
3096 print MC <<END or die $!;
3099 parent $archive_hash
3109 return make_commit($pmf);
3112 sub splitbrain_pseudomerge ($$$$) {
3113 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3114 # => $merged_dgitview
3115 printdebug "splitbrain_pseudomerge...\n";
3117 # We: debian/PREVIOUS HEAD($maintview)
3118 # expect: o ----------------- o
3121 # a/d/PREVIOUS $dgitview
3124 # we do: `------------------ o
3128 return $dgitview unless defined $archive_hash;
3130 printdebug "splitbrain_pseudomerge...\n";
3132 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3134 if (!defined $overwrite_version) {
3135 progress "Checking that HEAD inciudes all changes in archive...";
3138 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3140 if (defined $overwrite_version) {
3142 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3143 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3144 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3145 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3146 my $i_archive = [ $archive_hash, "current archive contents" ];
3148 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3150 infopair_cond_equal($i_dgit, $i_archive);
3151 infopair_cond_ff($i_dep14, $i_dgit);
3152 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3156 $us: check failed (maybe --overwrite is needed, consult documentation)
3161 my $r = pseudomerge_make_commit
3162 $clogp, $dgitview, $archive_hash, $i_arch_v,
3163 "dgit --quilt=$quilt_mode",
3164 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3165 Declare fast forward from $i_arch_v->[0]
3167 Make fast forward from $i_arch_v->[0]
3170 maybe_split_brain_save $maintview, $r, "pseudomerge";
3172 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3176 sub plain_overwrite_pseudomerge ($$$) {
3177 my ($clogp, $head, $archive_hash) = @_;
3179 printdebug "plain_overwrite_pseudomerge...";
3181 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3183 return $head if is_fast_fwd $archive_hash, $head;
3185 my $m = "Declare fast forward from $i_arch_v->[0]";
3187 my $r = pseudomerge_make_commit
3188 $clogp, $head, $archive_hash, $i_arch_v,
3191 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3193 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3197 sub push_parse_changelog ($) {
3200 my $clogp = Dpkg::Control::Hash->new();
3201 $clogp->load($clogpfn) or die;
3203 my $clogpackage = getfield $clogp, 'Source';
3204 $package //= $clogpackage;
3205 fail "-p specified $package but changelog specified $clogpackage"
3206 unless $package eq $clogpackage;
3207 my $cversion = getfield $clogp, 'Version';
3208 my $tag = debiantag($cversion, access_basedistro);
3209 runcmd @git, qw(check-ref-format), $tag;
3211 my $dscfn = dscfn($cversion);
3213 return ($clogp, $cversion, $dscfn);
3216 sub push_parse_dsc ($$$) {
3217 my ($dscfn,$dscfnwhat, $cversion) = @_;
3218 $dsc = parsecontrol($dscfn,$dscfnwhat);
3219 my $dversion = getfield $dsc, 'Version';
3220 my $dscpackage = getfield $dsc, 'Source';
3221 ($dscpackage eq $package && $dversion eq $cversion) or
3222 fail "$dscfn is for $dscpackage $dversion".
3223 " but debian/changelog is for $package $cversion";
3226 sub push_tagwants ($$$$) {
3227 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3230 TagFn => \&debiantag,
3235 if (defined $maintviewhead) {
3237 TagFn => \&debiantag_maintview,
3238 Objid => $maintviewhead,
3239 TfSuffix => '-maintview',
3243 foreach my $tw (@tagwants) {
3244 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3245 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3247 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3251 sub push_mktags ($$ $$ $) {
3253 $changesfile,$changesfilewhat,
3256 die unless $tagwants->[0]{View} eq 'dgit';
3258 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3259 $dsc->save("$dscfn.tmp") or die $!;
3261 my $changes = parsecontrol($changesfile,$changesfilewhat);
3262 foreach my $field (qw(Source Distribution Version)) {
3263 $changes->{$field} eq $clogp->{$field} or
3264 fail "changes field $field \`$changes->{$field}'".
3265 " does not match changelog \`$clogp->{$field}'";
3268 my $cversion = getfield $clogp, 'Version';
3269 my $clogsuite = getfield $clogp, 'Distribution';
3271 # We make the git tag by hand because (a) that makes it easier
3272 # to control the "tagger" (b) we can do remote signing
3273 my $authline = clogp_authline $clogp;
3274 my $delibs = join(" ", "",@deliberatelies);
3275 my $declaredistro = access_basedistro();
3279 my $tfn = $tw->{Tfn};
3280 my $head = $tw->{Objid};
3281 my $tag = $tw->{Tag};
3283 open TO, '>', $tfn->('.tmp') or die $!;
3284 print TO <<END or die $!;
3291 if ($tw->{View} eq 'dgit') {
3292 print TO <<END or die $!;
3293 $package release $cversion for $clogsuite ($csuite) [dgit]
3294 [dgit distro=$declaredistro$delibs]
3296 foreach my $ref (sort keys %previously) {
3297 print TO <<END or die $!;
3298 [dgit previously:$ref=$previously{$ref}]
3301 } elsif ($tw->{View} eq 'maint') {
3302 print TO <<END or die $!;
3303 $package release $cversion for $clogsuite ($csuite)
3304 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3307 die Dumper($tw)."?";
3312 my $tagobjfn = $tfn->('.tmp');
3314 if (!defined $keyid) {
3315 $keyid = access_cfg('keyid','RETURN-UNDEF');
3317 if (!defined $keyid) {
3318 $keyid = getfield $clogp, 'Maintainer';
3320 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3321 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3322 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3323 push @sign_cmd, $tfn->('.tmp');
3324 runcmd_ordryrun @sign_cmd;
3326 $tagobjfn = $tfn->('.signed.tmp');
3327 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3328 $tfn->('.tmp'), $tfn->('.tmp.asc');
3334 my @r = map { $mktag->($_); } @$tagwants;
3338 sub sign_changes ($) {
3339 my ($changesfile) = @_;
3341 my @debsign_cmd = @debsign;
3342 push @debsign_cmd, "-k$keyid" if defined $keyid;
3343 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3344 push @debsign_cmd, $changesfile;
3345 runcmd_ordryrun @debsign_cmd;
3350 printdebug "actually entering push\n";
3352 supplementary_message(<<'END');
3353 Push failed, while checking state of the archive.
3354 You can retry the push, after fixing the problem, if you like.
3356 if (check_for_git()) {
3359 my $archive_hash = fetch_from_archive();
3360 if (!$archive_hash) {
3362 fail "package appears to be new in this suite;".
3363 " if this is intentional, use --new";
3366 supplementary_message(<<'END');
3367 Push failed, while preparing your push.
3368 You can retry the push, after fixing the problem, if you like.
3371 need_tagformat 'new', "quilt mode $quilt_mode"
3372 if quiltmode_splitbrain;
3376 access_giturl(); # check that success is vaguely likely
3379 my $clogpfn = ".git/dgit/changelog.822.tmp";
3380 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3382 responder_send_file('parsed-changelog', $clogpfn);
3384 my ($clogp, $cversion, $dscfn) =
3385 push_parse_changelog("$clogpfn");
3387 my $dscpath = "$buildproductsdir/$dscfn";
3388 stat_exists $dscpath or
3389 fail "looked for .dsc $dscfn, but $!;".
3390 " maybe you forgot to build";
3392 responder_send_file('dsc', $dscpath);
3394 push_parse_dsc($dscpath, $dscfn, $cversion);
3396 my $format = getfield $dsc, 'Format';
3397 printdebug "format $format\n";
3399 my $actualhead = git_rev_parse('HEAD');
3400 my $dgithead = $actualhead;
3401 my $maintviewhead = undef;
3403 my $upstreamversion = upstreamversion $clogp->{Version};
3405 if (madformat_wantfixup($format)) {
3406 # user might have not used dgit build, so maybe do this now:
3407 if (quiltmode_splitbrain()) {
3409 quilt_make_fake_dsc($upstreamversion);
3411 ($dgithead, $cachekey) =
3412 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3414 "--quilt=$quilt_mode but no cached dgit view:
3415 perhaps tree changed since dgit build[-source] ?";
3417 $dgithead = splitbrain_pseudomerge($clogp,
3418 $actualhead, $dgithead,
3420 $maintviewhead = $actualhead;
3421 changedir '../../../..';
3422 prep_ud(); # so _only_subdir() works, below
3424 commit_quilty_patch();
3428 if (defined $overwrite_version && !defined $maintviewhead) {
3429 $dgithead = plain_overwrite_pseudomerge($clogp,
3437 if ($archive_hash) {
3438 if (is_fast_fwd($archive_hash, $dgithead)) {
3440 } elsif (deliberately_not_fast_forward) {
3443 fail "dgit push: HEAD is not a descendant".
3444 " of the archive's version.\n".
3445 "To overwrite the archive's contents,".
3446 " pass --overwrite[=VERSION].\n".
3447 "To rewind history, if permitted by the archive,".
3448 " use --deliberately-not-fast-forward.";
3453 progress "checking that $dscfn corresponds to HEAD";
3454 runcmd qw(dpkg-source -x --),
3455 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3456 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3457 check_for_vendor_patches() if madformat($dsc->{format});
3458 changedir '../../../..';
3459 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3460 debugcmd "+",@diffcmd;
3462 my $r = system @diffcmd;
3465 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3467 HEAD specifies a different tree to $dscfn:
3469 Perhaps you forgot to build. Or perhaps there is a problem with your
3470 source tree (see dgit(7) for some hints). To see a full diff, run
3477 if (!$changesfile) {
3478 my $pat = changespat $cversion;
3479 my @cs = glob "$buildproductsdir/$pat";
3480 fail "failed to find unique changes file".
3481 " (looked for $pat in $buildproductsdir);".
3482 " perhaps you need to use dgit -C"
3484 ($changesfile) = @cs;
3486 $changesfile = "$buildproductsdir/$changesfile";
3489 # Check that changes and .dsc agree enough
3490 $changesfile =~ m{[^/]*$};
3491 my $changes = parsecontrol($changesfile,$&);
3492 files_compare_inputs($dsc, $changes)
3493 unless forceing [qw(dsc-changes-mismatch)];
3495 # Perhaps adjust .dsc to contain right set of origs
3496 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3498 unless forceing [qw(changes-origs-exactly)];
3500 # Checks complete, we're going to try and go ahead:
3502 responder_send_file('changes',$changesfile);
3503 responder_send_command("param head $dgithead");
3504 responder_send_command("param csuite $csuite");
3505 responder_send_command("param tagformat $tagformat");
3506 if (defined $maintviewhead) {
3507 die unless ($protovsn//4) >= 4;
3508 responder_send_command("param maint-view $maintviewhead");
3511 if (deliberately_not_fast_forward) {
3512 git_for_each_ref(lrfetchrefs, sub {
3513 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3514 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3515 responder_send_command("previously $rrefname=$objid");
3516 $previously{$rrefname} = $objid;
3520 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3524 supplementary_message(<<'END');
3525 Push failed, while signing the tag.
3526 You can retry the push, after fixing the problem, if you like.
3528 # If we manage to sign but fail to record it anywhere, it's fine.
3529 if ($we_are_responder) {
3530 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3531 responder_receive_files('signed-tag', @tagobjfns);
3533 @tagobjfns = push_mktags($clogp,$dscpath,
3534 $changesfile,$changesfile,
3537 supplementary_message(<<'END');
3538 Push failed, *after* signing the tag.
3539 If you want to try again, you should use a new version number.
3542 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3544 foreach my $tw (@tagwants) {
3545 my $tag = $tw->{Tag};
3546 my $tagobjfn = $tw->{TagObjFn};
3548 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3549 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3550 runcmd_ordryrun_local
3551 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3554 supplementary_message(<<'END');
3555 Push failed, while updating the remote git repository - see messages above.
3556 If you want to try again, you should use a new version number.
3558 if (!check_for_git()) {
3559 create_remote_git_repo();
3562 my @pushrefs = $forceflag.$dgithead.":".rrref();
3563 foreach my $tw (@tagwants) {
3564 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3567 runcmd_ordryrun @git,
3568 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3569 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3571 supplementary_message(<<'END');
3572 Push failed, after updating the remote git repository.
3573 If you want to try again, you must use a new version number.
3575 if ($we_are_responder) {
3576 my $dryrunsuffix = act_local() ? "" : ".tmp";
3577 responder_receive_files('signed-dsc-changes',
3578 "$dscpath$dryrunsuffix",
3579 "$changesfile$dryrunsuffix");
3582 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3584 progress "[new .dsc left in $dscpath.tmp]";
3586 sign_changes $changesfile;
3589 supplementary_message(<<END);
3590 Push failed, while uploading package(s) to the archive server.
3591 You can retry the upload of exactly these same files with dput of:
3593 If that .changes file is broken, you will need to use a new version
3594 number for your next attempt at the upload.
3596 my $host = access_cfg('upload-host','RETURN-UNDEF');
3597 my @hostarg = defined($host) ? ($host,) : ();
3598 runcmd_ordryrun @dput, @hostarg, $changesfile;
3599 printdone "pushed and uploaded $cversion";
3601 supplementary_message('');
3602 responder_send_command("complete");
3609 badusage "-p is not allowed with clone; specify as argument instead"
3610 if defined $package;
3613 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3614 ($package,$isuite) = @ARGV;
3615 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3616 ($package,$dstdir) = @ARGV;
3617 } elsif (@ARGV==3) {
3618 ($package,$isuite,$dstdir) = @ARGV;
3620 badusage "incorrect arguments to dgit clone";
3622 $dstdir ||= "$package";
3624 if (stat_exists $dstdir) {
3625 fail "$dstdir already exists";
3629 if ($rmonerror && !$dryrun_level) {
3630 $cwd_remove= getcwd();
3632 return unless defined $cwd_remove;
3633 if (!chdir "$cwd_remove") {
3634 return if $!==&ENOENT;
3635 die "chdir $cwd_remove: $!";
3638 rmtree($dstdir) or die "remove $dstdir: $!\n";
3639 } elsif (grep { $! == $_ }
3640 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3642 print STDERR "check whether to remove $dstdir: $!\n";
3648 $cwd_remove = undef;
3651 sub branchsuite () {
3652 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3653 if ($branch =~ m#$lbranch_re#o) {
3660 sub fetchpullargs () {
3662 if (!defined $package) {
3663 my $sourcep = parsecontrol('debian/control','debian/control');
3664 $package = getfield $sourcep, 'Source';
3667 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3669 my $clogp = parsechangelog();
3670 $isuite = getfield $clogp, 'Distribution';
3672 canonicalise_suite();
3673 progress "fetching from suite $csuite";
3674 } elsif (@ARGV==1) {
3676 canonicalise_suite();
3678 badusage "incorrect arguments to dgit fetch or dgit pull";
3691 if (quiltmode_splitbrain()) {
3692 my ($format, $fopts) = get_source_format();
3693 madformat($format) and fail <<END
3694 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3703 badusage "-p is not allowed with dgit push" if defined $package;
3705 my $clogp = parsechangelog();
3706 $package = getfield $clogp, 'Source';
3709 } elsif (@ARGV==1) {
3710 ($specsuite) = (@ARGV);
3712 badusage "incorrect arguments to dgit push";
3714 $isuite = getfield $clogp, 'Distribution';
3716 local ($package) = $existing_package; # this is a hack
3717 canonicalise_suite();
3719 canonicalise_suite();
3721 if (defined $specsuite &&
3722 $specsuite ne $isuite &&
3723 $specsuite ne $csuite) {
3724 fail "dgit push: changelog specifies $isuite ($csuite)".
3725 " but command line specifies $specsuite";
3730 #---------- remote commands' implementation ----------
3732 sub cmd_remote_push_build_host {
3733 my ($nrargs) = shift @ARGV;
3734 my (@rargs) = @ARGV[0..$nrargs-1];
3735 @ARGV = @ARGV[$nrargs..$#ARGV];
3737 my ($dir,$vsnwant) = @rargs;
3738 # vsnwant is a comma-separated list; we report which we have
3739 # chosen in our ready response (so other end can tell if they
3742 $we_are_responder = 1;
3743 $us .= " (build host)";
3747 open PI, "<&STDIN" or die $!;
3748 open STDIN, "/dev/null" or die $!;
3749 open PO, ">&STDOUT" or die $!;
3751 open STDOUT, ">&STDERR" or die $!;
3755 ($protovsn) = grep {
3756 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3757 } @rpushprotovsn_support;
3759 fail "build host has dgit rpush protocol versions ".
3760 (join ",", @rpushprotovsn_support).
3761 " but invocation host has $vsnwant"
3762 unless defined $protovsn;
3764 responder_send_command("dgit-remote-push-ready $protovsn");
3765 rpush_handle_protovsn_bothends();
3770 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3771 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3772 # a good error message)
3774 sub rpush_handle_protovsn_bothends () {
3775 if ($protovsn < 4) {
3776 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3785 my $report = i_child_report();
3786 if (defined $report) {
3787 printdebug "($report)\n";
3788 } elsif ($i_child_pid) {
3789 printdebug "(killing build host child $i_child_pid)\n";
3790 kill 15, $i_child_pid;
3792 if (defined $i_tmp && !defined $initiator_tempdir) {
3794 eval { rmtree $i_tmp; };
3798 END { i_cleanup(); }
3801 my ($base,$selector,@args) = @_;
3802 $selector =~ s/\-/_/g;
3803 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3810 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3818 push @rargs, join ",", @rpushprotovsn_support;
3821 push @rdgit, @ropts;
3822 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3824 my @cmd = (@ssh, $host, shellquote @rdgit);
3827 if (defined $initiator_tempdir) {
3828 rmtree $initiator_tempdir;
3829 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3830 $i_tmp = $initiator_tempdir;
3834 $i_child_pid = open2(\*RO, \*RI, @cmd);
3836 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3837 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3838 $supplementary_message = '' unless $protovsn >= 3;
3840 fail "rpush negotiated protocol version $protovsn".
3841 " which does not support quilt mode $quilt_mode"
3842 if quiltmode_splitbrain;
3844 rpush_handle_protovsn_bothends();
3846 my ($icmd,$iargs) = initiator_expect {
3847 m/^(\S+)(?: (.*))?$/;
3850 i_method "i_resp", $icmd, $iargs;
3854 sub i_resp_progress ($) {
3856 my $msg = protocol_read_bytes \*RO, $rhs;
3860 sub i_resp_supplementary_message ($) {
3862 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3865 sub i_resp_complete {
3866 my $pid = $i_child_pid;
3867 $i_child_pid = undef; # prevents killing some other process with same pid
3868 printdebug "waiting for build host child $pid...\n";
3869 my $got = waitpid $pid, 0;
3870 die $! unless $got == $pid;
3871 die "build host child failed $?" if $?;
3874 printdebug "all done\n";
3878 sub i_resp_file ($) {
3880 my $localname = i_method "i_localname", $keyword;
3881 my $localpath = "$i_tmp/$localname";
3882 stat_exists $localpath and
3883 badproto \*RO, "file $keyword ($localpath) twice";
3884 protocol_receive_file \*RO, $localpath;
3885 i_method "i_file", $keyword;
3890 sub i_resp_param ($) {
3891 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3895 sub i_resp_previously ($) {
3896 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3897 or badproto \*RO, "bad previously spec";
3898 my $r = system qw(git check-ref-format), $1;
3899 die "bad previously ref spec ($r)" if $r;
3900 $previously{$1} = $2;
3905 sub i_resp_want ($) {
3907 die "$keyword ?" if $i_wanted{$keyword}++;
3908 my @localpaths = i_method "i_want", $keyword;
3909 printdebug "[[ $keyword @localpaths\n";
3910 foreach my $localpath (@localpaths) {
3911 protocol_send_file \*RI, $localpath;
3913 print RI "files-end\n" or die $!;
3916 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3918 sub i_localname_parsed_changelog {
3919 return "remote-changelog.822";
3921 sub i_file_parsed_changelog {
3922 ($i_clogp, $i_version, $i_dscfn) =
3923 push_parse_changelog "$i_tmp/remote-changelog.822";
3924 die if $i_dscfn =~ m#/|^\W#;
3927 sub i_localname_dsc {
3928 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3933 sub i_localname_changes {
3934 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3935 $i_changesfn = $i_dscfn;
3936 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3937 return $i_changesfn;
3939 sub i_file_changes { }
3941 sub i_want_signed_tag {
3942 printdebug Dumper(\%i_param, $i_dscfn);
3943 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3944 && defined $i_param{'csuite'}
3945 or badproto \*RO, "premature desire for signed-tag";
3946 my $head = $i_param{'head'};
3947 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3949 my $maintview = $i_param{'maint-view'};
3950 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3953 if ($protovsn >= 4) {
3954 my $p = $i_param{'tagformat'} // '<undef>';
3956 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3959 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3961 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3963 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3966 push_mktags $i_clogp, $i_dscfn,
3967 $i_changesfn, 'remote changes',
3971 sub i_want_signed_dsc_changes {
3972 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3973 sign_changes $i_changesfn;
3974 return ($i_dscfn, $i_changesfn);
3977 #---------- building etc. ----------
3983 #----- `3.0 (quilt)' handling -----
3985 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3987 sub quiltify_dpkg_commit ($$$;$) {
3988 my ($patchname,$author,$msg, $xinfo) = @_;
3992 my $descfn = ".git/dgit/quilt-description.tmp";
3993 open O, '>', $descfn or die "$descfn: $!";
3994 $msg =~ s/\n+/\n\n/;
3995 print O <<END or die $!;
3997 ${xinfo}Subject: $msg
4004 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4005 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4006 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4007 runcmd @dpkgsource, qw(--commit .), $patchname;
4011 sub quiltify_trees_differ ($$;$$$) {
4012 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4013 # returns true iff the two tree objects differ other than in debian/
4014 # with $finegrained,
4015 # returns bitmask 01 - differ in upstream files except .gitignore
4016 # 02 - differ in .gitignore
4017 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4018 # is set for each modified .gitignore filename $fn
4019 # if $unrepres is defined, array ref to which is appeneded
4020 # a list of unrepresentable changes (removals of upstream files
4023 my @cmd = (@git, qw(diff-tree -z));
4024 push @cmd, qw(--name-only) unless $unrepres;
4025 push @cmd, qw(-r) if $finegrained || $unrepres;
4027 my $diffs= cmdoutput @cmd;
4030 foreach my $f (split /\0/, $diffs) {
4031 if ($unrepres && !@lmodes) {
4032 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4035 my ($oldmode,$newmode) = @lmodes;
4038 next if $f =~ m#^debian(?:/.*)?$#s;
4042 die "deleted\n" unless $newmode =~ m/[^0]/;
4043 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4044 if ($oldmode =~ m/[^0]/) {
4045 die "mode changed\n" if $oldmode ne $newmode;
4047 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4051 local $/="\n"; chomp $@;
4052 push @$unrepres, [ $f, $@ ];
4056 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4057 $r |= $isignore ? 02 : 01;
4058 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4060 printdebug "quiltify_trees_differ $x $y => $r\n";
4064 sub quiltify_tree_sentinelfiles ($) {
4065 # lists the `sentinel' files present in the tree
4067 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4068 qw(-- debian/rules debian/control);
4073 sub quiltify_splitbrain_needed () {
4074 if (!$split_brain) {
4075 progress "dgit view: changes are required...";
4076 runcmd @git, qw(checkout -q -b dgit-view);
4081 sub quiltify_splitbrain ($$$$$$) {
4082 my ($clogp, $unapplied, $headref, $diffbits,
4083 $editedignores, $cachekey) = @_;
4084 if ($quilt_mode !~ m/gbp|dpm/) {
4085 # treat .gitignore just like any other upstream file
4086 $diffbits = { %$diffbits };
4087 $_ = !!$_ foreach values %$diffbits;
4089 # We would like any commits we generate to be reproducible
4090 my @authline = clogp_authline($clogp);
4091 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4092 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4093 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4094 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4095 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4096 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4098 if ($quilt_mode =~ m/gbp|unapplied/ &&
4099 ($diffbits->{O2H} & 01)) {
4101 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4102 " but git tree differs from orig in upstream files.";
4103 if (!stat_exists "debian/patches") {
4105 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4109 if ($quilt_mode =~ m/dpm/ &&
4110 ($diffbits->{H2A} & 01)) {
4112 --quilt=$quilt_mode specified, implying patches-applied git tree
4113 but git tree differs from result of applying debian/patches to upstream
4116 if ($quilt_mode =~ m/gbp|unapplied/ &&
4117 ($diffbits->{O2A} & 01)) { # some patches
4118 quiltify_splitbrain_needed();
4119 progress "dgit view: creating patches-applied version using gbp pq";
4120 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4121 # gbp pq import creates a fresh branch; push back to dgit-view
4122 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4123 runcmd @git, qw(checkout -q dgit-view);
4125 if ($quilt_mode =~ m/gbp|dpm/ &&
4126 ($diffbits->{O2A} & 02)) {
4128 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4129 tool which does not create patches for changes to upstream
4130 .gitignores: but, such patches exist in debian/patches.
4133 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4134 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4135 quiltify_splitbrain_needed();
4136 progress "dgit view: creating patch to represent .gitignore changes";
4137 ensuredir "debian/patches";
4138 my $gipatch = "debian/patches/auto-gitignore";
4139 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4140 stat GIPATCH or die "$gipatch: $!";
4141 fail "$gipatch already exists; but want to create it".
4142 " to record .gitignore changes" if (stat _)[7];
4143 print GIPATCH <<END or die "$gipatch: $!";
4144 Subject: Update .gitignore from Debian packaging branch
4146 The Debian packaging git branch contains these updates to the upstream
4147 .gitignore file(s). This patch is autogenerated, to provide these
4148 updates to users of the official Debian archive view of the package.
4150 [dgit ($our_version) update-gitignore]
4153 close GIPATCH or die "$gipatch: $!";
4154 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4155 $unapplied, $headref, "--", sort keys %$editedignores;
4156 open SERIES, "+>>", "debian/patches/series" or die $!;
4157 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4159 defined read SERIES, $newline, 1 or die $!;
4160 print SERIES "\n" or die $! unless $newline eq "\n";
4161 print SERIES "auto-gitignore\n" or die $!;
4162 close SERIES or die $!;
4163 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4165 Commit patch to update .gitignore
4167 [dgit ($our_version) update-gitignore-quilt-fixup]
4171 my $dgitview = git_rev_parse 'HEAD';
4173 changedir '../../../..';
4174 # When we no longer need to support squeeze, use --create-reflog
4176 ensuredir ".git/logs/refs/dgit-intern";
4177 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4180 my $oldcache = git_get_ref "refs/$splitbraincache";
4181 if ($oldcache eq $dgitview) {
4182 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4183 # git update-ref doesn't always update, in this case. *sigh*
4184 my $dummy = make_commit_text <<END;
4187 author Dgit <dgit\@example.com> 1000000000 +0000
4188 committer Dgit <dgit\@example.com> 1000000000 +0000
4190 Dummy commit - do not use
4192 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4193 "refs/$splitbraincache", $dummy;
4195 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4198 changedir '.git/dgit/unpack/work';
4200 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4201 progress "dgit view: created ($saved)";
4204 sub quiltify ($$$$) {
4205 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4207 # Quilt patchification algorithm
4209 # We search backwards through the history of the main tree's HEAD
4210 # (T) looking for a start commit S whose tree object is identical
4211 # to to the patch tip tree (ie the tree corresponding to the
4212 # current dpkg-committed patch series). For these purposes
4213 # `identical' disregards anything in debian/ - this wrinkle is
4214 # necessary because dpkg-source treates debian/ specially.
4216 # We can only traverse edges where at most one of the ancestors'
4217 # trees differs (in changes outside in debian/). And we cannot
4218 # handle edges which change .pc/ or debian/patches. To avoid
4219 # going down a rathole we avoid traversing edges which introduce
4220 # debian/rules or debian/control. And we set a limit on the
4221 # number of edges we are willing to look at.
4223 # If we succeed, we walk forwards again. For each traversed edge
4224 # PC (with P parent, C child) (starting with P=S and ending with
4225 # C=T) to we do this:
4227 # - dpkg-source --commit with a patch name and message derived from C
4228 # After traversing PT, we git commit the changes which
4229 # should be contained within debian/patches.
4231 # The search for the path S..T is breadth-first. We maintain a
4232 # todo list containing search nodes. A search node identifies a
4233 # commit, and looks something like this:
4235 # Commit => $git_commit_id,
4236 # Child => $c, # or undef if P=T
4237 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4238 # Nontrivial => true iff $p..$c has relevant changes
4245 my %considered; # saves being exponential on some weird graphs
4247 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4250 my ($search,$whynot) = @_;
4251 printdebug " search NOT $search->{Commit} $whynot\n";
4252 $search->{Whynot} = $whynot;
4253 push @nots, $search;
4254 no warnings qw(exiting);
4263 my $c = shift @todo;
4264 next if $considered{$c->{Commit}}++;
4266 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4268 printdebug "quiltify investigate $c->{Commit}\n";
4271 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4272 printdebug " search finished hooray!\n";
4277 if ($quilt_mode eq 'nofix') {
4278 fail "quilt fixup required but quilt mode is \`nofix'\n".
4279 "HEAD commit $c->{Commit} differs from tree implied by ".
4280 " debian/patches (tree object $oldtiptree)";
4282 if ($quilt_mode eq 'smash') {
4283 printdebug " search quitting smash\n";
4287 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4288 $not->($c, "has $c_sentinels not $t_sentinels")
4289 if $c_sentinels ne $t_sentinels;
4291 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4292 $commitdata =~ m/\n\n/;
4294 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4295 @parents = map { { Commit => $_, Child => $c } } @parents;
4297 $not->($c, "root commit") if !@parents;
4299 foreach my $p (@parents) {
4300 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4302 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4303 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4305 foreach my $p (@parents) {
4306 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4308 my @cmd= (@git, qw(diff-tree -r --name-only),
4309 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4310 my $patchstackchange = cmdoutput @cmd;
4311 if (length $patchstackchange) {
4312 $patchstackchange =~ s/\n/,/g;
4313 $not->($p, "changed $patchstackchange");
4316 printdebug " search queue P=$p->{Commit} ",
4317 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4323 printdebug "quiltify want to smash\n";
4326 my $x = $_[0]{Commit};
4327 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4330 my $reportnot = sub {
4332 my $s = $abbrev->($notp);
4333 my $c = $notp->{Child};
4334 $s .= "..".$abbrev->($c) if $c;
4335 $s .= ": ".$notp->{Whynot};
4338 if ($quilt_mode eq 'linear') {
4339 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4340 foreach my $notp (@nots) {
4341 print STDERR "$us: ", $reportnot->($notp), "\n";
4343 print STDERR "$us: $_\n" foreach @$failsuggestion;
4344 fail "quilt fixup naive history linearisation failed.\n".
4345 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4346 } elsif ($quilt_mode eq 'smash') {
4347 } elsif ($quilt_mode eq 'auto') {
4348 progress "quilt fixup cannot be linear, smashing...";
4350 die "$quilt_mode ?";
4353 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4354 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4356 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4358 quiltify_dpkg_commit "auto-$version-$target-$time",
4359 (getfield $clogp, 'Maintainer'),
4360 "Automatically generated patch ($clogp->{Version})\n".
4361 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4365 progress "quiltify linearisation planning successful, executing...";
4367 for (my $p = $sref_S;
4368 my $c = $p->{Child};
4370 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4371 next unless $p->{Nontrivial};
4373 my $cc = $c->{Commit};
4375 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4376 $commitdata =~ m/\n\n/ or die "$c ?";
4379 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4382 my $commitdate = cmdoutput
4383 @git, qw(log -n1 --pretty=format:%aD), $cc;
4385 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4387 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4394 my $gbp_check_suitable = sub {
4399 die "contains unexpected slashes\n" if m{//} || m{/$};
4400 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4401 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4402 die "too long" if length > 200;
4404 return $_ unless $@;
4405 print STDERR "quiltifying commit $cc:".
4406 " ignoring/dropping Gbp-Pq $what: $@";
4410 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4412 (\S+) \s* \n //ixm) {
4413 $patchname = $gbp_check_suitable->($1, 'Name');
4415 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4417 (\S+) \s* \n //ixm) {
4418 $patchdir = $gbp_check_suitable->($1, 'Topic');
4423 if (!defined $patchname) {
4424 $patchname = $title;
4425 $patchname =~ s/[.:]$//;
4428 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4429 my $translitname = $converter->convert($patchname);
4430 die unless defined $translitname;
4431 $patchname = $translitname;
4434 "dgit: patch title transliteration error: $@"
4436 $patchname =~ y/ A-Z/-a-z/;
4437 $patchname =~ y/-a-z0-9_.+=~//cd;
4438 $patchname =~ s/^\W/x-$&/;
4439 $patchname = substr($patchname,0,40);
4441 if (!defined $patchdir) {
4444 if (length $patchdir) {
4445 $patchname = "$patchdir/$patchname";
4447 if ($patchname =~ m{^(.*)/}) {
4448 mkpath "debian/patches/$1";
4453 stat "debian/patches/$patchname$index";
4455 $!==ENOENT or die "$patchname$index $!";
4457 runcmd @git, qw(checkout -q), $cc;
4459 # We use the tip's changelog so that dpkg-source doesn't
4460 # produce complaining messages from dpkg-parsechangelog. None
4461 # of the information dpkg-source gets from the changelog is
4462 # actually relevant - it gets put into the original message
4463 # which dpkg-source provides our stunt editor, and then
4465 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4467 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4468 "Date: $commitdate\n".
4469 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4471 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4474 runcmd @git, qw(checkout -q master);
4477 sub build_maybe_quilt_fixup () {
4478 my ($format,$fopts) = get_source_format;
4479 return unless madformat_wantfixup $format;
4482 check_for_vendor_patches();
4484 if (quiltmode_splitbrain) {
4485 foreach my $needtf (qw(new maint)) {
4486 next if grep { $_ eq $needtf } access_cfg_tagformats;
4488 quilt mode $quilt_mode requires split view so server needs to support
4489 both "new" and "maint" tag formats, but config says it doesn't.
4494 my $clogp = parsechangelog();
4495 my $headref = git_rev_parse('HEAD');
4500 my $upstreamversion = upstreamversion $version;
4502 if ($fopts->{'single-debian-patch'}) {
4503 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4505 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4508 die 'bug' if $split_brain && !$need_split_build_invocation;
4510 changedir '../../../..';
4511 runcmd_ordryrun_local
4512 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4515 sub quilt_fixup_mkwork ($) {
4518 mkdir "work" or die $!;
4520 mktree_in_ud_here();
4521 runcmd @git, qw(reset -q --hard), $headref;
4524 sub quilt_fixup_linkorigs ($$) {
4525 my ($upstreamversion, $fn) = @_;
4526 # calls $fn->($leafname);
4528 foreach my $f (<../../../../*>) { #/){
4529 my $b=$f; $b =~ s{.*/}{};
4531 local ($debuglevel) = $debuglevel-1;
4532 printdebug "QF linkorigs $b, $f ?\n";
4534 next unless is_orig_file_of_vsn $b, $upstreamversion;
4535 printdebug "QF linkorigs $b, $f Y\n";
4536 link_ltarget $f, $b or die "$b $!";
4541 sub quilt_fixup_delete_pc () {
4542 runcmd @git, qw(rm -rqf .pc);
4544 Commit removal of .pc (quilt series tracking data)
4546 [dgit ($our_version) upgrade quilt-remove-pc]
4550 sub quilt_fixup_singlepatch ($$$) {
4551 my ($clogp, $headref, $upstreamversion) = @_;
4553 progress "starting quiltify (single-debian-patch)";
4555 # dpkg-source --commit generates new patches even if
4556 # single-debian-patch is in debian/source/options. In order to
4557 # get it to generate debian/patches/debian-changes, it is
4558 # necessary to build the source package.
4560 quilt_fixup_linkorigs($upstreamversion, sub { });
4561 quilt_fixup_mkwork($headref);
4563 rmtree("debian/patches");
4565 runcmd @dpkgsource, qw(-b .);
4567 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4568 rename srcfn("$upstreamversion", "/debian/patches"),
4569 "work/debian/patches";
4572 commit_quilty_patch();
4575 sub quilt_make_fake_dsc ($) {
4576 my ($upstreamversion) = @_;
4578 my $fakeversion="$upstreamversion-~~DGITFAKE";
4580 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4581 print $fakedsc <<END or die $!;
4584 Version: $fakeversion
4588 my $dscaddfile=sub {
4591 my $md = new Digest::MD5;
4593 my $fh = new IO::File $b, '<' or die "$b $!";
4598 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4601 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4603 my @files=qw(debian/source/format debian/rules
4604 debian/control debian/changelog);
4605 foreach my $maybe (qw(debian/patches debian/source/options
4606 debian/tests/control)) {
4607 next unless stat_exists "../../../$maybe";
4608 push @files, $maybe;
4611 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4612 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4614 $dscaddfile->($debtar);
4615 close $fakedsc or die $!;
4618 sub quilt_check_splitbrain_cache ($$) {
4619 my ($headref, $upstreamversion) = @_;
4620 # Called only if we are in (potentially) split brain mode.
4622 # Computes the cache key and looks in the cache.
4623 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4625 my $splitbrain_cachekey;
4628 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4629 # we look in the reflog of dgit-intern/quilt-cache
4630 # we look for an entry whose message is the key for the cache lookup
4631 my @cachekey = (qw(dgit), $our_version);
4632 push @cachekey, $upstreamversion;
4633 push @cachekey, $quilt_mode;
4634 push @cachekey, $headref;
4636 push @cachekey, hashfile('fake.dsc');
4638 my $srcshash = Digest::SHA->new(256);
4639 my %sfs = ( %INC, '$0(dgit)' => $0 );
4640 foreach my $sfk (sort keys %sfs) {
4641 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4642 $srcshash->add($sfk," ");
4643 $srcshash->add(hashfile($sfs{$sfk}));
4644 $srcshash->add("\n");
4646 push @cachekey, $srcshash->hexdigest();
4647 $splitbrain_cachekey = "@cachekey";
4649 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4651 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4652 debugcmd "|(probably)",@cmd;
4653 my $child = open GC, "-|"; defined $child or die $!;
4655 chdir '../../..' or die $!;
4656 if (!stat ".git/logs/refs/$splitbraincache") {
4657 $! == ENOENT or die $!;
4658 printdebug ">(no reflog)\n";
4665 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4666 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4669 quilt_fixup_mkwork($headref);
4670 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4671 if ($cachehit ne $headref) {
4672 progress "dgit view: found cached ($saved)";
4673 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4675 return ($cachehit, $splitbrain_cachekey);
4677 progress "dgit view: found cached, no changes required";
4678 return ($headref, $splitbrain_cachekey);
4680 die $! if GC->error;
4681 failedcmd unless close GC;
4683 printdebug "splitbrain cache miss\n";
4684 return (undef, $splitbrain_cachekey);
4687 sub quilt_fixup_multipatch ($$$) {
4688 my ($clogp, $headref, $upstreamversion) = @_;
4690 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4693 # - honour any existing .pc in case it has any strangeness
4694 # - determine the git commit corresponding to the tip of
4695 # the patch stack (if there is one)
4696 # - if there is such a git commit, convert each subsequent
4697 # git commit into a quilt patch with dpkg-source --commit
4698 # - otherwise convert all the differences in the tree into
4699 # a single git commit
4703 # Our git tree doesn't necessarily contain .pc. (Some versions of
4704 # dgit would include the .pc in the git tree.) If there isn't
4705 # one, we need to generate one by unpacking the patches that we
4708 # We first look for a .pc in the git tree. If there is one, we
4709 # will use it. (This is not the normal case.)
4711 # Otherwise need to regenerate .pc so that dpkg-source --commit
4712 # can work. We do this as follows:
4713 # 1. Collect all relevant .orig from parent directory
4714 # 2. Generate a debian.tar.gz out of
4715 # debian/{patches,rules,source/format,source/options}
4716 # 3. Generate a fake .dsc containing just these fields:
4717 # Format Source Version Files
4718 # 4. Extract the fake .dsc
4719 # Now the fake .dsc has a .pc directory.
4720 # (In fact we do this in every case, because in future we will
4721 # want to search for a good base commit for generating patches.)
4723 # Then we can actually do the dpkg-source --commit
4724 # 1. Make a new working tree with the same object
4725 # store as our main tree and check out the main
4727 # 2. Copy .pc from the fake's extraction, if necessary
4728 # 3. Run dpkg-source --commit
4729 # 4. If the result has changes to debian/, then
4730 # - git add them them
4731 # - git add .pc if we had a .pc in-tree
4733 # 5. If we had a .pc in-tree, delete it, and git commit
4734 # 6. Back in the main tree, fast forward to the new HEAD
4736 # Another situation we may have to cope with is gbp-style
4737 # patches-unapplied trees.
4739 # We would want to detect these, so we know to escape into
4740 # quilt_fixup_gbp. However, this is in general not possible.
4741 # Consider a package with a one patch which the dgit user reverts
4742 # (with git revert or the moral equivalent).
4744 # That is indistinguishable in contents from a patches-unapplied
4745 # tree. And looking at the history to distinguish them is not
4746 # useful because the user might have made a confusing-looking git
4747 # history structure (which ought to produce an error if dgit can't
4748 # cope, not a silent reintroduction of an unwanted patch).
4750 # So gbp users will have to pass an option. But we can usually
4751 # detect their failure to do so: if the tree is not a clean
4752 # patches-applied tree, quilt linearisation fails, but the tree
4753 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4754 # they want --quilt=unapplied.
4756 # To help detect this, when we are extracting the fake dsc, we
4757 # first extract it with --skip-patches, and then apply the patches
4758 # afterwards with dpkg-source --before-build. That lets us save a
4759 # tree object corresponding to .origs.
4761 my $splitbrain_cachekey;
4763 quilt_make_fake_dsc($upstreamversion);
4765 if (quiltmode_splitbrain()) {
4767 ($cachehit, $splitbrain_cachekey) =
4768 quilt_check_splitbrain_cache($headref, $upstreamversion);
4769 return if $cachehit;
4773 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4775 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4776 rename $fakexdir, "fake" or die "$fakexdir $!";
4780 remove_stray_gits();
4781 mktree_in_ud_here();
4785 runcmd @git, qw(add -Af .);
4786 my $unapplied=git_write_tree();
4787 printdebug "fake orig tree object $unapplied\n";
4791 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4793 if (system @bbcmd) {
4794 failedcmd @bbcmd if $? < 0;
4796 failed to apply your git tree's patch stack (from debian/patches/) to
4797 the corresponding upstream tarball(s). Your source tree and .orig
4798 are probably too inconsistent. dgit can only fix up certain kinds of
4799 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4805 quilt_fixup_mkwork($headref);
4808 if (stat_exists ".pc") {
4810 progress "Tree already contains .pc - will use it then delete it.";
4813 rename '../fake/.pc','.pc' or die $!;
4816 changedir '../fake';
4818 runcmd @git, qw(add -Af .);
4819 my $oldtiptree=git_write_tree();
4820 printdebug "fake o+d/p tree object $unapplied\n";
4821 changedir '../work';
4824 # We calculate some guesswork now about what kind of tree this might
4825 # be. This is mostly for error reporting.
4831 # O = orig, without patches applied
4832 # A = "applied", ie orig with H's debian/patches applied
4833 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4834 \%editedignores, \@unrepres),
4835 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4836 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4840 foreach my $b (qw(01 02)) {
4841 foreach my $v (qw(O2H O2A H2A)) {
4842 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4845 printdebug "differences \@dl @dl.\n";
4848 "$us: base trees orig=%.20s o+d/p=%.20s",
4849 $unapplied, $oldtiptree;
4851 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4852 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4853 $dl[0], $dl[1], $dl[3], $dl[4],
4857 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4859 forceable_fail [qw(unrepresentable)], <<END;
4860 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4865 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4866 push @failsuggestion, "This might be a patches-unapplied branch.";
4867 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4868 push @failsuggestion, "This might be a patches-applied branch.";
4870 push @failsuggestion, "Maybe you need to specify one of".
4871 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4873 if (quiltmode_splitbrain()) {
4874 quiltify_splitbrain($clogp, $unapplied, $headref,
4875 $diffbits, \%editedignores,
4876 $splitbrain_cachekey);
4880 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4881 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4883 if (!open P, '>>', ".pc/applied-patches") {
4884 $!==&ENOENT or die $!;
4889 commit_quilty_patch();
4891 if ($mustdeletepc) {
4892 quilt_fixup_delete_pc();
4896 sub quilt_fixup_editor () {
4897 my $descfn = $ENV{$fakeeditorenv};
4898 my $editing = $ARGV[$#ARGV];
4899 open I1, '<', $descfn or die "$descfn: $!";
4900 open I2, '<', $editing or die "$editing: $!";
4901 unlink $editing or die "$editing: $!";
4902 open O, '>', $editing or die "$editing: $!";
4903 while (<I1>) { print O or die $!; } I1->error and die $!;
4906 $copying ||= m/^\-\-\- /;
4907 next unless $copying;
4910 I2->error and die $!;
4915 sub maybe_apply_patches_dirtily () {
4916 return unless $quilt_mode =~ m/gbp|unapplied/;
4917 print STDERR <<END or die $!;
4919 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4920 dgit: Have to apply the patches - making the tree dirty.
4921 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4924 $patches_applied_dirtily = 01;
4925 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4926 runcmd qw(dpkg-source --before-build .);
4929 sub maybe_unapply_patches_again () {
4930 progress "dgit: Unapplying patches again to tidy up the tree."
4931 if $patches_applied_dirtily;
4932 runcmd qw(dpkg-source --after-build .)
4933 if $patches_applied_dirtily & 01;
4935 if $patches_applied_dirtily & 02;
4936 $patches_applied_dirtily = 0;
4939 #----- other building -----
4941 our $clean_using_builder;
4942 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4943 # clean the tree before building (perhaps invoked indirectly by
4944 # whatever we are using to run the build), rather than separately
4945 # and explicitly by us.
4948 return if $clean_using_builder;
4949 if ($cleanmode eq 'dpkg-source') {
4950 maybe_apply_patches_dirtily();
4951 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4952 } elsif ($cleanmode eq 'dpkg-source-d') {
4953 maybe_apply_patches_dirtily();
4954 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4955 } elsif ($cleanmode eq 'git') {
4956 runcmd_ordryrun_local @git, qw(clean -xdf);
4957 } elsif ($cleanmode eq 'git-ff') {
4958 runcmd_ordryrun_local @git, qw(clean -xdff);
4959 } elsif ($cleanmode eq 'check') {
4960 my $leftovers = cmdoutput @git, qw(clean -xdn);
4961 if (length $leftovers) {
4962 print STDERR $leftovers, "\n" or die $!;
4963 fail "tree contains uncommitted files and --clean=check specified";
4965 } elsif ($cleanmode eq 'none') {
4972 badusage "clean takes no additional arguments" if @ARGV;
4975 maybe_unapply_patches_again();
4978 sub build_prep_early () {
4979 our $build_prep_early_done //= 0;
4980 return if $build_prep_early_done++;
4982 badusage "-p is not allowed when building" if defined $package;
4983 my $clogp = parsechangelog();
4984 $isuite = getfield $clogp, 'Distribution';
4985 $package = getfield $clogp, 'Source';
4986 $version = getfield $clogp, 'Version';
4993 build_maybe_quilt_fixup();
4995 my $pat = changespat $version;
4996 foreach my $f (glob "$buildproductsdir/$pat") {
4998 unlink $f or fail "remove old changes file $f: $!";
5000 progress "would remove $f";
5006 sub changesopts_initial () {
5007 my @opts =@changesopts[1..$#changesopts];
5010 sub changesopts_version () {
5011 if (!defined $changes_since_version) {
5012 my @vsns = archive_query('archive_query');
5013 my @quirk = access_quirk();
5014 if ($quirk[0] eq 'backports') {
5015 local $isuite = $quirk[2];
5017 canonicalise_suite();
5018 push @vsns, archive_query('archive_query');
5021 @vsns = map { $_->[0] } @vsns;
5022 @vsns = sort { -version_compare($a, $b) } @vsns;
5023 $changes_since_version = $vsns[0];
5024 progress "changelog will contain changes since $vsns[0]";
5026 $changes_since_version = '_';
5027 progress "package seems new, not specifying -v<version>";
5030 if ($changes_since_version ne '_') {
5031 return ("-v$changes_since_version");
5037 sub changesopts () {
5038 return (changesopts_initial(), changesopts_version());
5041 sub massage_dbp_args ($;$) {
5042 my ($cmd,$xargs) = @_;
5045 # - if we're going to split the source build out so we can
5046 # do strange things to it, massage the arguments to dpkg-buildpackage
5047 # so that the main build doessn't build source (or add an argument
5048 # to stop it building source by default).
5050 # - add -nc to stop dpkg-source cleaning the source tree,
5051 # unless we're not doing a split build and want dpkg-source
5052 # as cleanmode, in which case we can do nothing
5055 # 0 - source will NOT need to be built separately by caller
5056 # +1 - source will need to be built separately by caller
5057 # +2 - source will need to be built separately by caller AND
5058 # dpkg-buildpackage should not in fact be run at all!
5059 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5060 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5061 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5062 $clean_using_builder = 1;
5065 # -nc has the side effect of specifying -b if nothing else specified
5066 # and some combinations of -S, -b, et al, are errors, rather than
5067 # later simply overriding earlie. So we need to:
5068 # - search the command line for these options
5069 # - pick the last one
5070 # - perhaps add our own as a default
5071 # - perhaps adjust it to the corresponding non-source-building version
5073 foreach my $l ($cmd, $xargs) {
5075 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5078 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5080 if ($need_split_build_invocation) {
5081 printdebug "massage split $dmode.\n";
5082 $r = $dmode =~ m/[S]/ ? +2 :
5083 $dmode =~ y/gGF/ABb/ ? +1 :
5084 $dmode =~ m/[ABb]/ ? 0 :
5087 printdebug "massage done $r $dmode.\n";
5089 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5095 my $wasdir = must_getcwd();
5101 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5102 my ($msg_if_onlyone) = @_;
5103 # If there is only one .changes file, fail with $msg_if_onlyone,
5104 # or if that is undef, be a no-op.
5105 # Returns the changes file to report to the user.
5106 my $pat = changespat $version;
5107 my @changesfiles = glob $pat;
5108 @changesfiles = sort {
5109 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5113 if (@changesfiles==1) {
5114 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5115 only one changes file from build (@changesfiles)
5117 $result = $changesfiles[0];
5118 } elsif (@changesfiles==2) {
5119 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5120 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5121 fail "$l found in binaries changes file $binchanges"
5124 runcmd_ordryrun_local @mergechanges, @changesfiles;
5125 my $multichanges = changespat $version,'multi';
5127 stat_exists $multichanges or fail "$multichanges: $!";
5128 foreach my $cf (glob $pat) {
5129 next if $cf eq $multichanges;
5130 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5133 $result = $multichanges;
5135 fail "wrong number of different changes files (@changesfiles)";
5137 printdone "build successful, results in $result\n" or die $!;
5140 sub midbuild_checkchanges () {
5141 my $pat = changespat $version;
5142 return if $rmchanges;
5143 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5144 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5146 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5147 Suggest you delete @unwanted.
5152 sub midbuild_checkchanges_vanilla ($) {
5154 midbuild_checkchanges() if $wantsrc == 1;
5157 sub postbuild_mergechanges_vanilla ($) {
5159 if ($wantsrc == 1) {
5161 postbuild_mergechanges(undef);
5164 printdone "build successful\n";
5169 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5170 my $wantsrc = massage_dbp_args \@dbp;
5173 midbuild_checkchanges_vanilla $wantsrc;
5178 push @dbp, changesopts_version();
5179 maybe_apply_patches_dirtily();
5180 runcmd_ordryrun_local @dbp;
5182 maybe_unapply_patches_again();
5183 postbuild_mergechanges_vanilla $wantsrc;
5187 $quilt_mode //= 'gbp';
5193 # gbp can make .origs out of thin air. In my tests it does this
5194 # even for a 1.0 format package, with no origs present. So I
5195 # guess it keys off just the version number. We don't know
5196 # exactly what .origs ought to exist, but let's assume that we
5197 # should run gbp if: the version has an upstream part and the main
5199 my $upstreamversion = upstreamversion $version;
5200 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5201 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5203 if ($gbp_make_orig) {
5205 $cleanmode = 'none'; # don't do it again
5206 $need_split_build_invocation = 1;
5209 my @dbp = @dpkgbuildpackage;
5211 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5213 if (!length $gbp_build[0]) {
5214 if (length executable_on_path('git-buildpackage')) {
5215 $gbp_build[0] = qw(git-buildpackage);
5217 $gbp_build[0] = 'gbp buildpackage';
5220 my @cmd = opts_opt_multi_cmd @gbp_build;
5222 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5224 if ($gbp_make_orig) {
5225 ensuredir '.git/dgit';
5226 my $ok = '.git/dgit/origs-gen-ok';
5227 unlink $ok or $!==&ENOENT or die $!;
5228 my @origs_cmd = @cmd;
5229 push @origs_cmd, qw(--git-cleaner=true);
5230 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5231 push @origs_cmd, @ARGV;
5233 debugcmd @origs_cmd;
5235 do { local $!; stat_exists $ok; }
5236 or failedcmd @origs_cmd;
5238 dryrun_report @origs_cmd;
5244 midbuild_checkchanges_vanilla $wantsrc;
5246 if (!$clean_using_builder) {
5247 push @cmd, '--git-cleaner=true';
5251 maybe_unapply_patches_again();
5253 push @cmd, changesopts();
5254 runcmd_ordryrun_local @cmd, @ARGV;
5256 postbuild_mergechanges_vanilla $wantsrc;
5258 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5261 my $our_cleanmode = $cleanmode;
5262 if ($need_split_build_invocation) {
5263 # Pretend that clean is being done some other way. This
5264 # forces us not to try to use dpkg-buildpackage to clean and
5265 # build source all in one go; and instead we run dpkg-source
5266 # (and build_prep() will do the clean since $clean_using_builder
5268 $our_cleanmode = 'ELSEWHERE';
5270 if ($our_cleanmode =~ m/^dpkg-source/) {
5271 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5272 $clean_using_builder = 1;
5275 $sourcechanges = changespat $version,'source';
5277 unlink "../$sourcechanges" or $!==ENOENT
5278 or fail "remove $sourcechanges: $!";
5280 $dscfn = dscfn($version);
5281 if ($our_cleanmode eq 'dpkg-source') {
5282 maybe_apply_patches_dirtily();
5283 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5285 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5286 maybe_apply_patches_dirtily();
5287 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5290 my @cmd = (@dpkgsource, qw(-b --));
5293 runcmd_ordryrun_local @cmd, "work";
5294 my @udfiles = <${package}_*>;
5295 changedir "../../..";
5296 foreach my $f (@udfiles) {
5297 printdebug "source copy, found $f\n";
5300 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5301 $f eq srcfn($version, $&));
5302 printdebug "source copy, found $f - renaming\n";
5303 rename "$ud/$f", "../$f" or $!==ENOENT
5304 or fail "put in place new source file ($f): $!";
5307 my $pwd = must_getcwd();
5308 my $leafdir = basename $pwd;
5310 runcmd_ordryrun_local @cmd, $leafdir;
5313 runcmd_ordryrun_local qw(sh -ec),
5314 'exec >$1; shift; exec "$@"','x',
5315 "../$sourcechanges",
5316 @dpkggenchanges, qw(-S), changesopts();
5320 sub cmd_build_source {
5321 badusage "build-source takes no additional arguments" if @ARGV;
5323 maybe_unapply_patches_again();
5324 printdone "source built, results in $dscfn and $sourcechanges";
5329 midbuild_checkchanges();
5332 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5333 stat_exists $sourcechanges
5334 or fail "$sourcechanges (in parent directory): $!";
5336 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5338 maybe_unapply_patches_again();
5340 postbuild_mergechanges(<<END);
5341 perhaps you need to pass -A ? (sbuild's default is to build only
5342 arch-specific binaries; dgit 1.4 used to override that.)
5347 sub cmd_quilt_fixup {
5348 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5349 my $clogp = parsechangelog();
5350 $version = getfield $clogp, 'Version';
5351 $package = getfield $clogp, 'Source';
5354 build_maybe_quilt_fixup();
5357 sub cmd_import_dsc {
5361 last unless $ARGV[0] =~ m/^-/;
5364 if (m/^--require-valid-signature$/) {
5367 badusage "unknown dgit import-dsc sub-option \`$_'";
5371 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5372 my ($dscfn, $dstbranch) = @ARGV;
5374 badusage "dry run makes no sense with import-dsc" unless act_local();
5376 my $force = $dstbranch =~ s/^\+// ? +1 :
5377 $dstbranch =~ s/^\.\.// ? -1 :
5379 my $info = $force ? " $&" : '';
5380 $info = "$dscfn$info";
5382 my $specbranch = $dstbranch;
5383 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5384 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5386 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5387 my $chead = cmdoutput_errok @symcmd;
5388 defined $chead or $?==256 or failedcmd @symcmd;
5390 fail "$dstbranch is checked out - will not update it"
5391 if defined $chead and $chead eq $dstbranch;
5393 my $oldhash = git_get_ref $dstbranch;
5395 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5396 $dscdata = do { local $/ = undef; <D>; };
5397 D->error and fail "read $dscfn: $!";
5400 # we don't normally need this so import it here
5401 use Dpkg::Source::Package;
5402 my $dp = new Dpkg::Source::Package filename => $dscfn,
5403 require_valid_signature => $needsig;
5405 local $SIG{__WARN__} = sub {
5407 return unless $needsig;
5408 fail "import-dsc signature check failed";
5410 if (!$dp->is_signed()) {
5411 warn "$us: warning: importing unsigned .dsc\n";
5413 my $r = $dp->check_signature();
5414 die "->check_signature => $r" if $needsig && $r;
5420 my $dgit_commit = $dsc->{$ourdscfield[0]};
5421 if (defined $dgit_commit &&
5422 !forceing [qw(import-dsc-with-dgit-field)]) {
5423 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5424 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5425 my @cmd = (qw(sh -ec),
5426 "echo $dgit_commit | git cat-file --batch-check");
5427 my $objgot = cmdoutput @cmd;
5428 if ($objgot =~ m#^\w+ missing\b#) {
5430 .dsc contains Dgit field referring to object $dgit_commit
5431 Your git tree does not have that object. Try `git fetch' from a
5432 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5435 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5437 progress "Not fast forward, forced update.";
5439 fail "Not fast forward to $dgit_commit";
5442 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5443 $dstbranch, $dgit_commit);
5445 progress "dgit: import-dsc updated git ref $dstbranch";
5450 Branch $dstbranch already exists
5451 Specify ..$specbranch for a pseudo-merge, binding in existing history
5452 Specify +$specbranch to overwrite, discarding existing history
5454 if $oldhash && !$force;
5456 $package = getfield $dsc, 'Source';
5457 my @dfi = dsc_files_info();
5458 foreach my $fi (@dfi) {
5459 my $f = $fi->{Filename};
5461 next if lstat $here;
5462 fail "stat $here: $!" unless $! == ENOENT;
5464 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5466 } elsif ($dscfn =~ m#^/#) {
5469 fail "cannot import $dscfn which seems to be inside working tree!";
5471 $there =~ s#/+[^/]+$## or
5472 fail "cannot import $dscfn which seems to not have a basename";
5474 symlink $there, $here or fail "symlink $there to $here: $!";
5475 progress "made symlink $here -> $there";
5476 print STDERR Dumper($fi);
5478 my @mergeinputs = generate_commits_from_dsc();
5479 die unless @mergeinputs == 1;
5481 my $newhash = $mergeinputs[0]{Commit};
5485 progress "Import, forced update - synthetic orphan git history.";
5486 } elsif ($force < 0) {
5487 progress "Import, merging.";
5488 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5489 my $version = getfield $dsc, 'Version';
5490 $newhash = make_commit_text <<END;
5495 Merge $package ($version) import into $dstbranch
5498 die; # caught earlier
5502 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5503 $dstbranch, $newhash);
5505 progress "dgit: import-dsc results are in in git ref $dstbranch";
5508 sub cmd_archive_api_query {
5509 badusage "need only 1 subpath argument" unless @ARGV==1;
5510 my ($subpath) = @ARGV;
5511 my @cmd = archive_api_query_cmd($subpath);
5514 exec @cmd or fail "exec curl: $!\n";
5517 sub cmd_clone_dgit_repos_server {
5518 badusage "need destination argument" unless @ARGV==1;
5519 my ($destdir) = @ARGV;
5520 $package = '_dgit-repos-server';
5521 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5523 exec @cmd or fail "exec git clone: $!\n";
5526 sub cmd_setup_mergechangelogs {
5527 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5528 setup_mergechangelogs(1);
5531 sub cmd_setup_useremail {
5532 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5536 sub cmd_setup_new_tree {
5537 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5541 #---------- argument parsing and main program ----------
5544 print "dgit version $our_version\n" or die $!;
5548 our (%valopts_long, %valopts_short);
5551 sub defvalopt ($$$$) {
5552 my ($long,$short,$val_re,$how) = @_;
5553 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5554 $valopts_long{$long} = $oi;
5555 $valopts_short{$short} = $oi;
5556 # $how subref should:
5557 # do whatever assignemnt or thing it likes with $_[0]
5558 # if the option should not be passed on to remote, @rvalopts=()
5559 # or $how can be a scalar ref, meaning simply assign the value
5562 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5563 defvalopt '--distro', '-d', '.+', \$idistro;
5564 defvalopt '', '-k', '.+', \$keyid;
5565 defvalopt '--existing-package','', '.*', \$existing_package;
5566 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5567 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5568 defvalopt '--package', '-p', $package_re, \$package;
5569 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5571 defvalopt '', '-C', '.+', sub {
5572 ($changesfile) = (@_);
5573 if ($changesfile =~ s#^(.*)/##) {
5574 $buildproductsdir = $1;
5578 defvalopt '--initiator-tempdir','','.*', sub {
5579 ($initiator_tempdir) = (@_);
5580 $initiator_tempdir =~ m#^/# or
5581 badusage "--initiator-tempdir must be used specify an".
5582 " absolute, not relative, directory."
5588 if (defined $ENV{'DGIT_SSH'}) {
5589 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5590 } elsif (defined $ENV{'GIT_SSH'}) {
5591 @ssh = ($ENV{'GIT_SSH'});
5599 if (!defined $val) {
5600 badusage "$what needs a value" unless @ARGV;
5602 push @rvalopts, $val;
5604 badusage "bad value \`$val' for $what" unless
5605 $val =~ m/^$oi->{Re}$(?!\n)/s;
5606 my $how = $oi->{How};
5607 if (ref($how) eq 'SCALAR') {
5612 push @ropts, @rvalopts;
5616 last unless $ARGV[0] =~ m/^-/;
5620 if (m/^--dry-run$/) {
5623 } elsif (m/^--damp-run$/) {
5626 } elsif (m/^--no-sign$/) {
5629 } elsif (m/^--help$/) {
5631 } elsif (m/^--version$/) {
5633 } elsif (m/^--new$/) {
5636 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5637 ($om = $opts_opt_map{$1}) &&
5641 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5642 !$opts_opt_cmdonly{$1} &&
5643 ($om = $opts_opt_map{$1})) {
5646 } elsif (m/^--(gbp|dpm)$/s) {
5647 push @ropts, "--quilt=$1";
5649 } elsif (m/^--ignore-dirty$/s) {
5652 } elsif (m/^--no-quilt-fixup$/s) {
5654 $quilt_mode = 'nocheck';
5655 } elsif (m/^--no-rm-on-error$/s) {
5658 } elsif (m/^--overwrite$/s) {
5660 $overwrite_version = '';
5661 } elsif (m/^--overwrite=(.+)$/s) {
5663 $overwrite_version = $1;
5664 } elsif (m/^--delayed=(\d+)$/s) {
5667 } elsif (m/^--dgit-view-save=(.+)$/s) {
5669 $split_brain_save = $1;
5670 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5671 } elsif (m/^--(no-)?rm-old-changes$/s) {
5674 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5676 push @deliberatelies, $&;
5677 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5681 } elsif (m/^--force-/) {
5683 "$us: warning: ignoring unknown force option $_\n";
5685 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5686 # undocumented, for testing
5688 $tagformat_want = [ $1, 'command line', 1 ];
5689 # 1 menas overrides distro configuration
5690 } elsif (m/^--always-split-source-build$/s) {
5691 # undocumented, for testing
5693 $need_split_build_invocation = 1;
5694 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5695 $val = $2 ? $' : undef; #';
5696 $valopt->($oi->{Long});
5698 badusage "unknown long option \`$_'";
5705 } elsif (s/^-L/-/) {
5708 } elsif (s/^-h/-/) {
5710 } elsif (s/^-D/-/) {
5714 } elsif (s/^-N/-/) {
5719 push @changesopts, $_;
5721 } elsif (s/^-wn$//s) {
5723 $cleanmode = 'none';
5724 } elsif (s/^-wg$//s) {
5727 } elsif (s/^-wgf$//s) {
5729 $cleanmode = 'git-ff';
5730 } elsif (s/^-wd$//s) {
5732 $cleanmode = 'dpkg-source';
5733 } elsif (s/^-wdd$//s) {
5735 $cleanmode = 'dpkg-source-d';
5736 } elsif (s/^-wc$//s) {
5738 $cleanmode = 'check';
5739 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5740 push @git, '-c', $&;
5741 $gitcfgs{cmdline}{$1} = [ $2 ];
5742 } elsif (s/^-c([^=]+)$//s) {
5743 push @git, '-c', $&;
5744 $gitcfgs{cmdline}{$1} = [ 'true' ];
5745 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5747 $val = undef unless length $val;
5748 $valopt->($oi->{Short});
5751 badusage "unknown short option \`$_'";
5758 sub check_env_sanity () {
5759 my $blocked = new POSIX::SigSet;
5760 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5763 foreach my $name (qw(PIPE CHLD)) {
5764 my $signame = "SIG$name";
5765 my $signum = eval "POSIX::$signame" // die;
5766 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5767 die "$signame is set to something other than SIG_DFL\n";
5768 $blocked->ismember($signum) and
5769 die "$signame is blocked\n";
5775 On entry to dgit, $@
5776 This is a bug produced by something in in your execution environment.
5782 sub finalise_opts_opts () {
5783 foreach my $k (keys %opts_opt_map) {
5784 my $om = $opts_opt_map{$k};
5786 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5788 badcfg "cannot set command for $k"
5789 unless length $om->[0];
5793 foreach my $c (access_cfg_cfgs("opts-$k")) {
5795 map { $_ ? @$_ : () }
5796 map { $gitcfgs{$_}{$c} }
5797 reverse @gitcfgsources;
5798 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5799 "\n" if $debuglevel >= 4;
5801 badcfg "cannot configure options for $k"
5802 if $opts_opt_cmdonly{$k};
5803 my $insertpos = $opts_cfg_insertpos{$k};
5804 @$om = ( @$om[0..$insertpos-1],
5806 @$om[$insertpos..$#$om] );
5811 if ($ENV{$fakeeditorenv}) {
5813 quilt_fixup_editor();
5820 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5821 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5822 if $dryrun_level == 1;
5824 print STDERR $helpmsg or die $!;
5827 my $cmd = shift @ARGV;
5830 my $pre_fn = ${*::}{"pre_$cmd"};
5831 $pre_fn->() if $pre_fn;
5833 if (!defined $rmchanges) {
5834 local $access_forpush;
5835 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5838 if (!defined $quilt_mode) {
5839 local $access_forpush;
5840 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5841 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5843 $quilt_mode =~ m/^($quilt_modes_re)$/
5844 or badcfg "unknown quilt-mode \`$quilt_mode'";
5848 $need_split_build_invocation ||= quiltmode_splitbrain();
5850 if (!defined $cleanmode) {
5851 local $access_forpush;
5852 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5853 $cleanmode //= 'dpkg-source';
5855 badcfg "unknown clean-mode \`$cleanmode'" unless
5856 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5859 my $fn = ${*::}{"cmd_$cmd"};
5860 $fn or badusage "unknown operation $cmd";