3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $split_brain_save;
71 our $we_are_responder;
72 our $initiator_tempdir;
73 our $patches_applied_dirtily = 00;
78 our %forceopts = map { $_=>0 }
79 qw(unrepresentable unsupported-source-format
80 dsc-changes-mismatch changes-origs-exactly
81 import-gitapply-absurd
82 import-gitapply-no-absurd
83 import-dsc-with-dgit-field);
85 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
87 our $suite_re = '[-+.0-9a-z]+';
88 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
89 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
90 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
91 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
93 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
94 our $splitbraincache = 'dgit-intern/quilt-cache';
97 our (@dget) = qw(dget);
98 our (@curl) = qw(curl);
99 our (@dput) = qw(dput);
100 our (@debsign) = qw(debsign);
101 our (@gpg) = qw(gpg);
102 our (@sbuild) = qw(sbuild);
104 our (@dgit) = qw(dgit);
105 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
106 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
107 our (@dpkggenchanges) = qw(dpkg-genchanges);
108 our (@mergechanges) = qw(mergechanges -f);
109 our (@gbp_build) = ('');
110 our (@gbp_pq) = ('gbp pq');
111 our (@changesopts) = ('');
113 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
116 'debsign' => \@debsign,
118 'sbuild' => \@sbuild,
122 'dpkg-source' => \@dpkgsource,
123 'dpkg-buildpackage' => \@dpkgbuildpackage,
124 'dpkg-genchanges' => \@dpkggenchanges,
125 'gbp-build' => \@gbp_build,
126 'gbp-pq' => \@gbp_pq,
127 'ch' => \@changesopts,
128 'mergechanges' => \@mergechanges);
130 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
131 our %opts_cfg_insertpos = map {
133 scalar @{ $opts_opt_map{$_} }
134 } keys %opts_opt_map;
136 sub finalise_opts_opts();
142 our $supplementary_message = '';
143 our $need_split_build_invocation = 0;
144 our $split_brain = 0;
148 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
151 our $remotename = 'dgit';
152 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
156 if (!defined $absurdity) {
158 $absurdity =~ s{/[^/]+$}{/absurd} or die;
162 my ($v,$distro) = @_;
163 return $tagformatfn->($v, $distro);
166 sub debiantag_maintview ($$) {
167 my ($v,$distro) = @_;
172 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
174 sub lbranch () { return "$branchprefix/$csuite"; }
175 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
176 sub lref () { return "refs/heads/".lbranch(); }
177 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
178 sub rrref () { return server_ref($csuite); }
180 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
181 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
183 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
184 # locally fetched refs because they have unhelpful names and clutter
185 # up gitk etc. So we track whether we have "used up" head ref (ie,
186 # whether we have made another local ref which refers to this object).
188 # (If we deleted them unconditionally, then we might end up
189 # re-fetching the same git objects each time dgit fetch was run.)
191 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
192 # in git_fetch_us to fetch the refs in question, and possibly a call
193 # to lrfetchref_used.
195 our (%lrfetchrefs_f, %lrfetchrefs_d);
196 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
198 sub lrfetchref_used ($) {
199 my ($fullrefname) = @_;
200 my $objid = $lrfetchrefs_f{$fullrefname};
201 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
212 return "${package}_".(stripepoch $vsn).$sfx
217 return srcfn($vsn,".dsc");
220 sub changespat ($;$) {
221 my ($vsn, $arch) = @_;
222 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 sub upstreamversion ($) {
237 foreach my $f (@end) {
239 print STDERR "$us: cleanup: $@" if length $@;
243 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
245 sub forceable_fail ($$) {
246 my ($forceoptsl, $msg) = @_;
247 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
248 print STDERR "warning: overriding problem due to --force:\n". $msg;
252 my ($forceoptsl) = @_;
253 my @got = grep { $forceopts{$_} } @$forceoptsl;
254 return 0 unless @got;
256 "warning: skipping checks or functionality due to --force-$got[0]\n";
259 sub no_such_package () {
260 print STDERR "$us: package $package does not exist in suite $isuite\n";
266 printdebug "CD $newdir\n";
267 chdir $newdir or confess "chdir: $newdir: $!";
270 sub deliberately ($) {
272 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
275 sub deliberately_not_fast_forward () {
276 foreach (qw(not-fast-forward fresh-repo)) {
277 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
281 sub quiltmode_splitbrain () {
282 $quilt_mode =~ m/gbp|dpm|unapplied/;
285 sub opts_opt_multi_cmd {
287 push @cmd, split /\s+/, shift @_;
293 return opts_opt_multi_cmd @gbp_pq;
296 #---------- remote protocol support, common ----------
298 # remote push initiator/responder protocol:
299 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
300 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
301 # < dgit-remote-push-ready <actual-proto-vsn>
308 # > supplementary-message NBYTES # $protovsn >= 3
313 # > file parsed-changelog
314 # [indicates that output of dpkg-parsechangelog follows]
315 # > data-block NBYTES
316 # > [NBYTES bytes of data (no newline)]
317 # [maybe some more blocks]
326 # > param head DGIT-VIEW-HEAD
327 # > param csuite SUITE
328 # > param tagformat old|new
329 # > param maint-view MAINT-VIEW-HEAD
331 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
332 # # goes into tag, for replay prevention
335 # [indicates that signed tag is wanted]
336 # < data-block NBYTES
337 # < [NBYTES bytes of data (no newline)]
338 # [maybe some more blocks]
342 # > want signed-dsc-changes
343 # < data-block NBYTES [transfer of signed dsc]
345 # < data-block NBYTES [transfer of signed changes]
353 sub i_child_report () {
354 # Sees if our child has died, and reap it if so. Returns a string
355 # describing how it died if it failed, or undef otherwise.
356 return undef unless $i_child_pid;
357 my $got = waitpid $i_child_pid, WNOHANG;
358 return undef if $got <= 0;
359 die unless $got == $i_child_pid;
360 $i_child_pid = undef;
361 return undef unless $?;
362 return "build host child ".waitstatusmsg();
367 fail "connection lost: $!" if $fh->error;
368 fail "protocol violation; $m not expected";
371 sub badproto_badread ($$) {
373 fail "connection lost: $!" if $!;
374 my $report = i_child_report();
375 fail $report if defined $report;
376 badproto $fh, "eof (reading $wh)";
379 sub protocol_expect (&$) {
380 my ($match, $fh) = @_;
383 defined && chomp or badproto_badread $fh, "protocol message";
391 badproto $fh, "\`$_'";
394 sub protocol_send_file ($$) {
395 my ($fh, $ourfn) = @_;
396 open PF, "<", $ourfn or die "$ourfn: $!";
399 my $got = read PF, $d, 65536;
400 die "$ourfn: $!" unless defined $got;
402 print $fh "data-block ".length($d)."\n" or die $!;
403 print $fh $d or die $!;
405 PF->error and die "$ourfn $!";
406 print $fh "data-end\n" or die $!;
410 sub protocol_read_bytes ($$) {
411 my ($fh, $nbytes) = @_;
412 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
414 my $got = read $fh, $d, $nbytes;
415 $got==$nbytes or badproto_badread $fh, "data block";
419 sub protocol_receive_file ($$) {
420 my ($fh, $ourfn) = @_;
421 printdebug "() $ourfn\n";
422 open PF, ">", $ourfn or die "$ourfn: $!";
424 my ($y,$l) = protocol_expect {
425 m/^data-block (.*)$/ ? (1,$1) :
426 m/^data-end$/ ? (0,) :
430 my $d = protocol_read_bytes $fh, $l;
431 print PF $d or die $!;
436 #---------- remote protocol support, responder ----------
438 sub responder_send_command ($) {
440 return unless $we_are_responder;
441 # called even without $we_are_responder
442 printdebug ">> $command\n";
443 print PO $command, "\n" or die $!;
446 sub responder_send_file ($$) {
447 my ($keyword, $ourfn) = @_;
448 return unless $we_are_responder;
449 printdebug "]] $keyword $ourfn\n";
450 responder_send_command "file $keyword";
451 protocol_send_file \*PO, $ourfn;
454 sub responder_receive_files ($@) {
455 my ($keyword, @ourfns) = @_;
456 die unless $we_are_responder;
457 printdebug "[[ $keyword @ourfns\n";
458 responder_send_command "want $keyword";
459 foreach my $fn (@ourfns) {
460 protocol_receive_file \*PI, $fn;
463 protocol_expect { m/^files-end$/ } \*PI;
466 #---------- remote protocol support, initiator ----------
468 sub initiator_expect (&) {
470 protocol_expect { &$match } \*RO;
473 #---------- end remote code ----------
476 if ($we_are_responder) {
478 responder_send_command "progress ".length($m) or die $!;
479 print PO $m or die $!;
489 $ua = LWP::UserAgent->new();
493 progress "downloading $what...";
494 my $r = $ua->get(@_) or die $!;
495 return undef if $r->code == 404;
496 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
497 return $r->decoded_content(charset => 'none');
500 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
505 failedcmd @_ if system @_;
508 sub act_local () { return $dryrun_level <= 1; }
509 sub act_scary () { return !$dryrun_level; }
512 if (!$dryrun_level) {
513 progress "dgit ok: @_";
515 progress "would be ok: @_ (but dry run only)";
520 printcmd(\*STDERR,$debugprefix."#",@_);
523 sub runcmd_ordryrun {
531 sub runcmd_ordryrun_local {
540 my ($first_shell, @cmd) = @_;
541 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
544 our $helpmsg = <<END;
546 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
547 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
548 dgit [dgit-opts] build [dpkg-buildpackage-opts]
549 dgit [dgit-opts] sbuild [sbuild-opts]
550 dgit [dgit-opts] push [dgit-opts] [suite]
551 dgit [dgit-opts] rpush build-host:build-dir ...
552 important dgit options:
553 -k<keyid> sign tag and package with <keyid> instead of default
554 --dry-run -n do not change anything, but go through the motions
555 --damp-run -L like --dry-run but make local changes, without signing
556 --new -N allow introducing a new package
557 --debug -D increase debug level
558 -c<name>=<value> set git config option (used directly by dgit too)
561 our $later_warning_msg = <<END;
562 Perhaps the upload is stuck in incoming. Using the version from git.
566 print STDERR "$us: @_\n", $helpmsg or die $!;
571 @ARGV or badusage "too few arguments";
572 return scalar shift @ARGV;
576 print $helpmsg or die $!;
580 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
582 our %defcfg = ('dgit.default.distro' => 'debian',
583 'dgit.default.username' => '',
584 'dgit.default.archive-query-default-component' => 'main',
585 'dgit.default.ssh' => 'ssh',
586 'dgit.default.archive-query' => 'madison:',
587 'dgit.default.sshpsql-dbname' => 'service=projectb',
588 'dgit.default.dgit-tag-format' => 'new,old,maint',
589 # old means "repo server accepts pushes with old dgit tags"
590 # new means "repo server accepts pushes with new dgit tags"
591 # maint means "repo server accepts split brain pushes"
592 # hist means "repo server may have old pushes without new tag"
593 # ("hist" is implied by "old")
594 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
595 'dgit-distro.debian.git-check' => 'url',
596 'dgit-distro.debian.git-check-suffix' => '/info/refs',
597 'dgit-distro.debian.new-private-pushers' => 't',
598 'dgit-distro.debian/push.git-url' => '',
599 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
600 'dgit-distro.debian/push.git-user-force' => 'dgit',
601 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
602 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
603 'dgit-distro.debian/push.git-create' => 'true',
604 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
605 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
606 # 'dgit-distro.debian.archive-query-tls-key',
607 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
608 # ^ this does not work because curl is broken nowadays
609 # Fixing #790093 properly will involve providing providing the key
610 # in some pacagke and maybe updating these paths.
612 # 'dgit-distro.debian.archive-query-tls-curl-args',
613 # '--ca-path=/etc/ssl/ca-debian',
614 # ^ this is a workaround but works (only) on DSA-administered machines
615 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
616 'dgit-distro.debian.git-url-suffix' => '',
617 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
618 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
619 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
620 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
621 'dgit-distro.ubuntu.git-check' => 'false',
622 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
623 'dgit-distro.test-dummy.ssh' => "$td/ssh",
624 'dgit-distro.test-dummy.username' => "alice",
625 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
626 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-url' => "$td/git",
628 'dgit-distro.test-dummy.git-host' => "git",
629 'dgit-distro.test-dummy.git-path' => "$td/git",
630 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
631 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
632 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
633 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
637 our @gitcfgsources = qw(cmdline local global system);
639 sub git_slurp_config () {
640 local ($debuglevel) = $debuglevel-2;
643 # This algoritm is a bit subtle, but this is needed so that for
644 # options which we want to be single-valued, we allow the
645 # different config sources to override properly. See #835858.
646 foreach my $src (@gitcfgsources) {
647 next if $src eq 'cmdline';
648 # we do this ourselves since git doesn't handle it
650 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
653 open GITS, "-|", @cmd or die $!;
656 printdebug "=> ", (messagequote $_), "\n";
658 push @{ $gitcfgs{$src}{$`} }, $'; #';
662 or ($!==0 && $?==256)
667 sub git_get_config ($) {
669 foreach my $src (@gitcfgsources) {
670 my $l = $gitcfgs{$src}{$c};
671 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
674 @$l==1 or badcfg "multiple values for $c".
675 " (in $src git config)" if @$l > 1;
683 return undef if $c =~ /RETURN-UNDEF/;
684 my $v = git_get_config($c);
685 return $v if defined $v;
686 my $dv = $defcfg{$c};
687 return $dv if defined $dv;
689 badcfg "need value for one of: @_\n".
690 "$us: distro or suite appears not to be (properly) supported";
693 sub access_basedistro () {
694 if (defined $idistro) {
697 return cfg("dgit-suite.$isuite.distro",
698 "dgit.default.distro");
702 sub access_quirk () {
703 # returns (quirk name, distro to use instead or undef, quirk-specific info)
704 my $basedistro = access_basedistro();
705 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
707 if (defined $backports_quirk) {
708 my $re = $backports_quirk;
709 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
711 $re =~ s/\%/([-0-9a-z_]+)/
712 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
713 if ($isuite =~ m/^$re$/) {
714 return ('backports',"$basedistro-backports",$1);
717 return ('none',undef);
722 sub parse_cfg_bool ($$$) {
723 my ($what,$def,$v) = @_;
726 $v =~ m/^[ty1]/ ? 1 :
727 $v =~ m/^[fn0]/ ? 0 :
728 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
731 sub access_forpush_config () {
732 my $d = access_basedistro();
736 parse_cfg_bool('new-private-pushers', 0,
737 cfg("dgit-distro.$d.new-private-pushers",
740 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
743 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
744 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
745 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
746 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
749 sub access_forpush () {
750 $access_forpush //= access_forpush_config();
751 return $access_forpush;
755 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
756 badcfg "pushing but distro is configured readonly"
757 if access_forpush_config() eq '0';
759 $supplementary_message = <<'END' unless $we_are_responder;
760 Push failed, before we got started.
761 You can retry the push, after fixing the problem, if you like.
763 finalise_opts_opts();
767 finalise_opts_opts();
770 sub supplementary_message ($) {
772 if (!$we_are_responder) {
773 $supplementary_message = $msg;
775 } elsif ($protovsn >= 3) {
776 responder_send_command "supplementary-message ".length($msg)
778 print PO $msg or die $!;
782 sub access_distros () {
783 # Returns list of distros to try, in order
786 # 0. `instead of' distro name(s) we have been pointed to
787 # 1. the access_quirk distro, if any
788 # 2a. the user's specified distro, or failing that } basedistro
789 # 2b. the distro calculated from the suite }
790 my @l = access_basedistro();
792 my (undef,$quirkdistro) = access_quirk();
793 unshift @l, $quirkdistro;
794 unshift @l, $instead_distro;
795 @l = grep { defined } @l;
797 if (access_forpush()) {
798 @l = map { ("$_/push", $_) } @l;
803 sub access_cfg_cfgs (@) {
806 # The nesting of these loops determines the search order. We put
807 # the key loop on the outside so that we search all the distros
808 # for each key, before going on to the next key. That means that
809 # if access_cfg is called with a more specific, and then a less
810 # specific, key, an earlier distro can override the less specific
811 # without necessarily overriding any more specific keys. (If the
812 # distro wants to override the more specific keys it can simply do
813 # so; whereas if we did the loop the other way around, it would be
814 # impossible to for an earlier distro to override a less specific
815 # key but not the more specific ones without restating the unknown
816 # values of the more specific keys.
819 # We have to deal with RETURN-UNDEF specially, so that we don't
820 # terminate the search prematurely.
822 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
825 foreach my $d (access_distros()) {
826 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
828 push @cfgs, map { "dgit.default.$_" } @realkeys;
835 my (@cfgs) = access_cfg_cfgs(@keys);
836 my $value = cfg(@cfgs);
840 sub access_cfg_bool ($$) {
841 my ($def, @keys) = @_;
842 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
845 sub string_to_ssh ($) {
847 if ($spec =~ m/\s/) {
848 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
854 sub access_cfg_ssh () {
855 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
856 if (!defined $gitssh) {
859 return string_to_ssh $gitssh;
863 sub access_runeinfo ($) {
865 return ": dgit ".access_basedistro()." $info ;";
868 sub access_someuserhost ($) {
870 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
871 defined($user) && length($user) or
872 $user = access_cfg("$some-user",'username');
873 my $host = access_cfg("$some-host");
874 return length($user) ? "$user\@$host" : $host;
877 sub access_gituserhost () {
878 return access_someuserhost('git');
881 sub access_giturl (;$) {
883 my $url = access_cfg('git-url','RETURN-UNDEF');
886 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
887 return undef unless defined $proto;
890 access_gituserhost().
891 access_cfg('git-path');
893 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
896 return "$url/$package$suffix";
899 sub parsecontrolfh ($$;$) {
900 my ($fh, $desc, $allowsigned) = @_;
901 our $dpkgcontrolhash_noissigned;
904 my %opts = ('name' => $desc);
905 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
906 $c = Dpkg::Control::Hash->new(%opts);
907 $c->parse($fh,$desc) or die "parsing of $desc failed";
908 last if $allowsigned;
909 last if $dpkgcontrolhash_noissigned;
910 my $issigned= $c->get_option('is_pgp_signed');
911 if (!defined $issigned) {
912 $dpkgcontrolhash_noissigned= 1;
913 seek $fh, 0,0 or die "seek $desc: $!";
914 } elsif ($issigned) {
915 fail "control file $desc is (already) PGP-signed. ".
916 " Note that dgit push needs to modify the .dsc and then".
917 " do the signature itself";
926 my ($file, $desc) = @_;
927 my $fh = new IO::Handle;
928 open $fh, '<', $file or die "$file: $!";
929 my $c = parsecontrolfh($fh,$desc);
930 $fh->error and die $!;
936 my ($dctrl,$field) = @_;
937 my $v = $dctrl->{$field};
938 return $v if defined $v;
939 fail "missing field $field in ".$dctrl->get_option('name');
943 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
944 my $p = new IO::Handle;
945 my @cmd = (qw(dpkg-parsechangelog), @_);
946 open $p, '-|', @cmd or die $!;
948 $?=0; $!=0; close $p or failedcmd @cmd;
952 sub commit_getclogp ($) {
953 # Returns the parsed changelog hashref for a particular commit
955 our %commit_getclogp_memo;
956 my $memo = $commit_getclogp_memo{$objid};
957 return $memo if $memo;
959 my $mclog = ".git/dgit/clog-$objid";
960 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
961 "$objid:debian/changelog";
962 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
967 defined $d or fail "getcwd failed: $!";
971 sub parse_dscdata () {
972 my $dscfh = new IO::File \$dscdata, '<' or die $!;
973 printdebug Dumper($dscdata) if $debuglevel>1;
974 $dsc = parsecontrolfh($dscfh,$dscurl,1);
975 printdebug Dumper($dsc) if $debuglevel>1;
980 sub archive_query ($;@) {
981 my ($method) = shift @_;
982 my $query = access_cfg('archive-query','RETURN-UNDEF');
983 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
986 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
989 sub pool_dsc_subpath ($$) {
990 my ($vsn,$component) = @_; # $package is implict arg
991 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
992 return "/pool/$component/$prefix/$package/".dscfn($vsn);
995 #---------- `ftpmasterapi' archive query method (nascent) ----------
997 sub archive_api_query_cmd ($) {
999 my @cmd = (@curl, qw(-sS));
1000 my $url = access_cfg('archive-query-url');
1001 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1003 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1004 foreach my $key (split /\:/, $keys) {
1005 $key =~ s/\%HOST\%/$host/g;
1007 fail "for $url: stat $key: $!" unless $!==ENOENT;
1010 fail "config requested specific TLS key but do not know".
1011 " how to get curl to use exactly that EE key ($key)";
1012 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1013 # # Sadly the above line does not work because of changes
1014 # # to gnutls. The real fix for #790093 may involve
1015 # # new curl options.
1018 # Fixing #790093 properly will involve providing a value
1019 # for this on clients.
1020 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1021 push @cmd, split / /, $kargs if defined $kargs;
1023 push @cmd, $url.$subpath;
1027 sub api_query ($$;$) {
1029 my ($data, $subpath, $ok404) = @_;
1030 badcfg "ftpmasterapi archive query method takes no data part"
1032 my @cmd = archive_api_query_cmd($subpath);
1033 my $url = $cmd[$#cmd];
1034 push @cmd, qw(-w %{http_code});
1035 my $json = cmdoutput @cmd;
1036 unless ($json =~ s/\d+\d+\d$//) {
1037 failedcmd_report_cmd undef, @cmd;
1038 fail "curl failed to print 3-digit HTTP code";
1041 return undef if $code eq '404' && $ok404;
1042 fail "fetch of $url gave HTTP code $code"
1043 unless $url =~ m#^file://# or $code =~ m/^2/;
1044 return decode_json($json);
1047 sub canonicalise_suite_ftpmasterapi {
1048 my ($proto,$data) = @_;
1049 my $suites = api_query($data, 'suites');
1051 foreach my $entry (@$suites) {
1053 my $v = $entry->{$_};
1054 defined $v && $v eq $isuite;
1055 } qw(codename name);
1056 push @matched, $entry;
1058 fail "unknown suite $isuite" unless @matched;
1061 @matched==1 or die "multiple matches for suite $isuite\n";
1062 $cn = "$matched[0]{codename}";
1063 defined $cn or die "suite $isuite info has no codename\n";
1064 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1066 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1071 sub archive_query_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1075 my $digester = Digest::SHA->new(256);
1076 foreach my $entry (@$info) {
1078 my $vsn = "$entry->{version}";
1079 my ($ok,$msg) = version_check $vsn;
1080 die "bad version: $msg\n" unless $ok;
1081 my $component = "$entry->{component}";
1082 $component =~ m/^$component_re$/ or die "bad component";
1083 my $filename = "$entry->{filename}";
1084 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1085 or die "bad filename";
1086 my $sha256sum = "$entry->{sha256sum}";
1087 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1088 push @rows, [ $vsn, "/pool/$component/$filename",
1089 $digester, $sha256sum ];
1091 die "bad ftpmaster api response: $@\n".Dumper($entry)
1094 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1098 sub file_in_archive_ftpmasterapi {
1099 my ($proto,$data,$filename) = @_;
1100 my $pat = $filename;
1103 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1104 my $info = api_query($data, "file_in_archive/$pat", 1);
1107 #---------- `dummyapicat' archive query method ----------
1109 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1110 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1112 sub file_in_archive_dummycatapi ($$$) {
1113 my ($proto,$data,$filename) = @_;
1114 my $mirror = access_cfg('mirror');
1115 $mirror =~ s#^file://#/# or die "$mirror ?";
1117 my @cmd = (qw(sh -ec), '
1119 find -name "$2" -print0 |
1121 ', qw(x), $mirror, $filename);
1122 debugcmd "-|", @cmd;
1123 open FIA, "-|", @cmd or die $!;
1126 printdebug "| $_\n";
1127 m/^(\w+) (\S+)$/ or die "$_ ?";
1128 push @out, { sha256sum => $1, filename => $2 };
1130 close FIA or die failedcmd @cmd;
1134 #---------- `madison' archive query method ----------
1136 sub archive_query_madison {
1137 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1140 sub madison_get_parse {
1141 my ($proto,$data) = @_;
1142 die unless $proto eq 'madison';
1143 if (!length $data) {
1144 $data= access_cfg('madison-distro','RETURN-UNDEF');
1145 $data //= access_basedistro();
1147 $rmad{$proto,$data,$package} ||= cmdoutput
1148 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1149 my $rmad = $rmad{$proto,$data,$package};
1152 foreach my $l (split /\n/, $rmad) {
1153 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1154 \s*( [^ \t|]+ )\s* \|
1155 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1156 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1157 $1 eq $package or die "$rmad $package ?";
1164 $component = access_cfg('archive-query-default-component');
1166 $5 eq 'source' or die "$rmad ?";
1167 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1169 return sort { -version_compare($a->[0],$b->[0]); } @out;
1172 sub canonicalise_suite_madison {
1173 # madison canonicalises for us
1174 my @r = madison_get_parse(@_);
1176 "unable to canonicalise suite using package $package".
1177 " which does not appear to exist in suite $isuite;".
1178 " --existing-package may help";
1182 sub file_in_archive_madison { return undef; }
1184 #---------- `sshpsql' archive query method ----------
1187 my ($data,$runeinfo,$sql) = @_;
1188 if (!length $data) {
1189 $data= access_someuserhost('sshpsql').':'.
1190 access_cfg('sshpsql-dbname');
1192 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1193 my ($userhost,$dbname) = ($`,$'); #';
1195 my @cmd = (access_cfg_ssh, $userhost,
1196 access_runeinfo("ssh-psql $runeinfo").
1197 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1198 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1200 open P, "-|", @cmd or die $!;
1203 printdebug(">|$_|\n");
1206 $!=0; $?=0; close P or failedcmd @cmd;
1208 my $nrows = pop @rows;
1209 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1210 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1211 @rows = map { [ split /\|/, $_ ] } @rows;
1212 my $ncols = scalar @{ shift @rows };
1213 die if grep { scalar @$_ != $ncols } @rows;
1217 sub sql_injection_check {
1218 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1221 sub archive_query_sshpsql ($$) {
1222 my ($proto,$data) = @_;
1223 sql_injection_check $isuite, $package;
1224 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1225 SELECT source.version, component.name, files.filename, files.sha256sum
1227 JOIN src_associations ON source.id = src_associations.source
1228 JOIN suite ON suite.id = src_associations.suite
1229 JOIN dsc_files ON dsc_files.source = source.id
1230 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1231 JOIN component ON component.id = files_archive_map.component_id
1232 JOIN files ON files.id = dsc_files.file
1233 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1234 AND source.source='$package'
1235 AND files.filename LIKE '%.dsc';
1237 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1238 my $digester = Digest::SHA->new(256);
1240 my ($vsn,$component,$filename,$sha256sum) = @$_;
1241 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1246 sub canonicalise_suite_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite;
1249 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1250 SELECT suite.codename
1251 FROM suite where suite_name='$isuite' or codename='$isuite';
1253 @rows = map { $_->[0] } @rows;
1254 fail "unknown suite $isuite" unless @rows;
1255 die "ambiguous $isuite: @rows ?" if @rows>1;
1259 sub file_in_archive_sshpsql ($$$) { return undef; }
1261 #---------- `dummycat' archive query method ----------
1263 sub canonicalise_suite_dummycat ($$) {
1264 my ($proto,$data) = @_;
1265 my $dpath = "$data/suite.$isuite";
1266 if (!open C, "<", $dpath) {
1267 $!==ENOENT or die "$dpath: $!";
1268 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1272 chomp or die "$dpath: $!";
1274 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1278 sub archive_query_dummycat ($$) {
1279 my ($proto,$data) = @_;
1280 canonicalise_suite();
1281 my $dpath = "$data/package.$csuite.$package";
1282 if (!open C, "<", $dpath) {
1283 $!==ENOENT or die "$dpath: $!";
1284 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1292 printdebug "dummycat query $csuite $package $dpath | $_\n";
1293 my @row = split /\s+/, $_;
1294 @row==2 or die "$dpath: $_ ?";
1297 C->error and die "$dpath: $!";
1299 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1302 sub file_in_archive_dummycat () { return undef; }
1304 #---------- tag format handling ----------
1306 sub access_cfg_tagformats () {
1307 split /\,/, access_cfg('dgit-tag-format');
1310 sub need_tagformat ($$) {
1311 my ($fmt, $why) = @_;
1312 fail "need to use tag format $fmt ($why) but also need".
1313 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1314 " - no way to proceed"
1315 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1316 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1319 sub select_tagformat () {
1321 return if $tagformatfn && !$tagformat_want;
1322 die 'bug' if $tagformatfn && $tagformat_want;
1323 # ... $tagformat_want assigned after previous select_tagformat
1325 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1326 printdebug "select_tagformat supported @supported\n";
1328 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1329 printdebug "select_tagformat specified @$tagformat_want\n";
1331 my ($fmt,$why,$override) = @$tagformat_want;
1333 fail "target distro supports tag formats @supported".
1334 " but have to use $fmt ($why)"
1336 or grep { $_ eq $fmt } @supported;
1338 $tagformat_want = undef;
1340 $tagformatfn = ${*::}{"debiantag_$fmt"};
1342 fail "trying to use unknown tag format \`$fmt' ($why) !"
1343 unless $tagformatfn;
1346 #---------- archive query entrypoints and rest of program ----------
1348 sub canonicalise_suite () {
1349 return if defined $csuite;
1350 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1351 $csuite = archive_query('canonicalise_suite');
1352 if ($isuite ne $csuite) {
1353 progress "canonical suite name for $isuite is $csuite";
1357 sub get_archive_dsc () {
1358 canonicalise_suite();
1359 my @vsns = archive_query('archive_query');
1360 foreach my $vinfo (@vsns) {
1361 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1362 $dscurl = access_cfg('mirror').$subpath;
1363 $dscdata = url_get($dscurl);
1365 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1370 $digester->add($dscdata);
1371 my $got = $digester->hexdigest();
1373 fail "$dscurl has hash $got but".
1374 " archive told us to expect $digest";
1377 my $fmt = getfield $dsc, 'Format';
1378 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1379 "unsupported source format $fmt, sorry";
1381 $dsc_checked = !!$digester;
1382 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1386 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1389 sub check_for_git ();
1390 sub check_for_git () {
1392 my $how = access_cfg('git-check');
1393 if ($how eq 'ssh-cmd') {
1395 (access_cfg_ssh, access_gituserhost(),
1396 access_runeinfo("git-check $package").
1397 " set -e; cd ".access_cfg('git-path').";".
1398 " if test -d $package.git; then echo 1; else echo 0; fi");
1399 my $r= cmdoutput @cmd;
1400 if (defined $r and $r =~ m/^divert (\w+)$/) {
1402 my ($usedistro,) = access_distros();
1403 # NB that if we are pushing, $usedistro will be $distro/push
1404 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1405 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1406 progress "diverting to $divert (using config for $instead_distro)";
1407 return check_for_git();
1409 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1411 } elsif ($how eq 'url') {
1412 my $prefix = access_cfg('git-check-url','git-url');
1413 my $suffix = access_cfg('git-check-suffix','git-suffix',
1414 'RETURN-UNDEF') // '.git';
1415 my $url = "$prefix/$package$suffix";
1416 my @cmd = (@curl, qw(-sS -I), $url);
1417 my $result = cmdoutput @cmd;
1418 $result =~ s/^\S+ 200 .*\n\r?\n//;
1419 # curl -sS -I with https_proxy prints
1420 # HTTP/1.0 200 Connection established
1421 $result =~ m/^\S+ (404|200) /s or
1422 fail "unexpected results from git check query - ".
1423 Dumper($prefix, $result);
1425 if ($code eq '404') {
1427 } elsif ($code eq '200') {
1432 } elsif ($how eq 'true') {
1434 } elsif ($how eq 'false') {
1437 badcfg "unknown git-check \`$how'";
1441 sub create_remote_git_repo () {
1442 my $how = access_cfg('git-create');
1443 if ($how eq 'ssh-cmd') {
1445 (access_cfg_ssh, access_gituserhost(),
1446 access_runeinfo("git-create $package").
1447 "set -e; cd ".access_cfg('git-path').";".
1448 " cp -a _template $package.git");
1449 } elsif ($how eq 'true') {
1452 badcfg "unknown git-create \`$how'";
1456 our ($dsc_hash,$lastpush_mergeinput);
1458 our $ud = '.git/dgit/unpack';
1468 sub mktree_in_ud_here () {
1469 runcmd qw(git init -q);
1470 runcmd qw(git config gc.auto 0);
1471 rmtree('.git/objects');
1472 symlink '../../../../objects','.git/objects' or die $!;
1475 sub git_write_tree () {
1476 my $tree = cmdoutput @git, qw(write-tree);
1477 $tree =~ m/^\w+$/ or die "$tree ?";
1481 sub remove_stray_gits () {
1482 my @gitscmd = qw(find -name .git -prune -print0);
1483 debugcmd "|",@gitscmd;
1484 open GITS, "-|", @gitscmd or die $!;
1489 print STDERR "$us: warning: removing from source package: ",
1490 (messagequote $_), "\n";
1494 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1497 sub mktree_in_ud_from_only_subdir (;$) {
1500 # changes into the subdir
1502 die "expected one subdir but found @dirs ?" unless @dirs==1;
1503 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1507 remove_stray_gits();
1508 mktree_in_ud_here();
1510 my ($format, $fopts) = get_source_format();
1511 if (madformat($format)) {
1516 runcmd @git, qw(add -Af);
1517 my $tree=git_write_tree();
1518 return ($tree,$dir);
1521 our @files_csum_info_fields =
1522 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1523 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1524 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1526 sub dsc_files_info () {
1527 foreach my $csumi (@files_csum_info_fields) {
1528 my ($fname, $module, $method) = @$csumi;
1529 my $field = $dsc->{$fname};
1530 next unless defined $field;
1531 eval "use $module; 1;" or die $@;
1533 foreach (split /\n/, $field) {
1535 m/^(\w+) (\d+) (\S+)$/ or
1536 fail "could not parse .dsc $fname line \`$_'";
1537 my $digester = eval "$module"."->$method;" or die $@;
1542 Digester => $digester,
1547 fail "missing any supported Checksums-* or Files field in ".
1548 $dsc->get_option('name');
1552 map { $_->{Filename} } dsc_files_info();
1555 sub files_compare_inputs (@) {
1560 my $showinputs = sub {
1561 return join "; ", map { $_->get_option('name') } @$inputs;
1564 foreach my $in (@$inputs) {
1566 my $in_name = $in->get_option('name');
1568 printdebug "files_compare_inputs $in_name\n";
1570 foreach my $csumi (@files_csum_info_fields) {
1571 my ($fname) = @$csumi;
1572 printdebug "files_compare_inputs $in_name $fname\n";
1574 my $field = $in->{$fname};
1575 next unless defined $field;
1578 foreach (split /\n/, $field) {
1581 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1582 fail "could not parse $in_name $fname line \`$_'";
1584 printdebug "files_compare_inputs $in_name $fname $f\n";
1588 my $re = \ $record{$f}{$fname};
1590 $fchecked{$f}{$in_name} = 1;
1592 fail "hash or size of $f varies in $fname fields".
1593 " (between: ".$showinputs->().")";
1598 @files = sort @files;
1599 $expected_files //= \@files;
1600 "@$expected_files" eq "@files" or
1601 fail "file list in $in_name varies between hash fields!";
1604 fail "$in_name has no files list field(s)";
1606 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1609 grep { keys %$_ == @$inputs-1 } values %fchecked
1610 or fail "no file appears in all file lists".
1611 " (looked in: ".$showinputs->().")";
1614 sub is_orig_file_in_dsc ($$) {
1615 my ($f, $dsc_files_info) = @_;
1616 return 0 if @$dsc_files_info <= 1;
1617 # One file means no origs, and the filename doesn't have a "what
1618 # part of dsc" component. (Consider versions ending `.orig'.)
1619 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1623 sub is_orig_file_of_vsn ($$) {
1624 my ($f, $upstreamvsn) = @_;
1625 my $base = srcfn $upstreamvsn, '';
1626 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1630 sub changes_update_origs_from_dsc ($$$$) {
1631 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1633 printdebug "checking origs needed ($upstreamvsn)...\n";
1634 $_ = getfield $changes, 'Files';
1635 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1636 fail "cannot find section/priority from .changes Files field";
1637 my $placementinfo = $1;
1639 printdebug "checking origs needed placement '$placementinfo'...\n";
1640 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1641 $l =~ m/\S+$/ or next;
1643 printdebug "origs $file | $l\n";
1644 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1645 printdebug "origs $file is_orig\n";
1646 my $have = archive_query('file_in_archive', $file);
1647 if (!defined $have) {
1649 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1655 printdebug "origs $file \$#\$have=$#$have\n";
1656 foreach my $h (@$have) {
1659 foreach my $csumi (@files_csum_info_fields) {
1660 my ($fname, $module, $method, $archivefield) = @$csumi;
1661 next unless defined $h->{$archivefield};
1662 $_ = $dsc->{$fname};
1663 next unless defined;
1664 m/^(\w+) .* \Q$file\E$/m or
1665 fail ".dsc $fname missing entry for $file";
1666 if ($h->{$archivefield} eq $1) {
1670 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1673 die "$file ".Dumper($h)." ?!" if $same && @differ;
1676 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1679 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1680 if (@found_differ && !$found_same) {
1682 "archive contains $file with different checksum",
1685 # Now we edit the changes file to add or remove it
1686 foreach my $csumi (@files_csum_info_fields) {
1687 my ($fname, $module, $method, $archivefield) = @$csumi;
1688 next unless defined $changes->{$fname};
1690 # in archive, delete from .changes if it's there
1691 $changed{$file} = "removed" if
1692 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1693 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1694 # not in archive, but it's here in the .changes
1696 my $dsc_data = getfield $dsc, $fname;
1697 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1699 $extra =~ s/ \d+ /$&$placementinfo /
1700 or die "$fname $extra >$dsc_data< ?"
1701 if $fname eq 'Files';
1702 $changes->{$fname} .= "\n". $extra;
1703 $changed{$file} = "added";
1708 foreach my $file (keys %changed) {
1710 "edited .changes for archive .orig contents: %s %s",
1711 $changed{$file}, $file;
1713 my $chtmp = "$changesfile.tmp";
1714 $changes->save($chtmp);
1716 rename $chtmp,$changesfile or die "$changesfile $!";
1718 progress "[new .changes left in $changesfile]";
1721 progress "$changesfile already has appropriate .orig(s) (if any)";
1725 sub make_commit ($) {
1727 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1730 sub make_commit_text ($) {
1733 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1735 print Dumper($text) if $debuglevel > 1;
1736 my $child = open2($out, $in, @cmd) or die $!;
1739 print $in $text or die $!;
1740 close $in or die $!;
1742 $h =~ m/^\w+$/ or die;
1744 printdebug "=> $h\n";
1747 waitpid $child, 0 == $child or die "$child $!";
1748 $? and failedcmd @cmd;
1752 sub clogp_authline ($) {
1754 my $author = getfield $clogp, 'Maintainer';
1755 $author =~ s#,.*##ms;
1756 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1757 my $authline = "$author $date";
1758 $authline =~ m/$git_authline_re/o or
1759 fail "unexpected commit author line format \`$authline'".
1760 " (was generated from changelog Maintainer field)";
1761 return ($1,$2,$3) if wantarray;
1765 sub vendor_patches_distro ($$) {
1766 my ($checkdistro, $what) = @_;
1767 return unless defined $checkdistro;
1769 my $series = "debian/patches/\L$checkdistro\E.series";
1770 printdebug "checking for vendor-specific $series ($what)\n";
1772 if (!open SERIES, "<", $series) {
1773 die "$series $!" unless $!==ENOENT;
1782 Unfortunately, this source package uses a feature of dpkg-source where
1783 the same source package unpacks to different source code on different
1784 distros. dgit cannot safely operate on such packages on affected
1785 distros, because the meaning of source packages is not stable.
1787 Please ask the distro/maintainer to remove the distro-specific series
1788 files and use a different technique (if necessary, uploading actually
1789 different packages, if different distros are supposed to have
1793 fail "Found active distro-specific series file for".
1794 " $checkdistro ($what): $series, cannot continue";
1796 die "$series $!" if SERIES->error;
1800 sub check_for_vendor_patches () {
1801 # This dpkg-source feature doesn't seem to be documented anywhere!
1802 # But it can be found in the changelog (reformatted):
1804 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1805 # Author: Raphael Hertzog <hertzog@debian.org>
1806 # Date: Sun Oct 3 09:36:48 2010 +0200
1808 # dpkg-source: correctly create .pc/.quilt_series with alternate
1811 # If you have debian/patches/ubuntu.series and you were
1812 # unpacking the source package on ubuntu, quilt was still
1813 # directed to debian/patches/series instead of
1814 # debian/patches/ubuntu.series.
1816 # debian/changelog | 3 +++
1817 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1818 # 2 files changed, 6 insertions(+), 1 deletion(-)
1821 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1822 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1823 "Dpkg::Vendor \`current vendor'");
1824 vendor_patches_distro(access_basedistro(),
1825 "distro being accessed");
1828 sub generate_commits_from_dsc () {
1829 # See big comment in fetch_from_archive, below.
1830 # See also README.dsc-import.
1834 my @dfi = dsc_files_info();
1835 foreach my $fi (@dfi) {
1836 my $f = $fi->{Filename};
1837 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1839 printdebug "considering linking $f: ";
1841 link_ltarget "../../../../$f", $f
1842 or ((printdebug "($!) "), 0)
1846 printdebug "linked.\n";
1848 complete_file_from_dsc('.', $fi)
1851 if (is_orig_file_in_dsc($f, \@dfi)) {
1852 link $f, "../../../../$f"
1858 # We unpack and record the orig tarballs first, so that we only
1859 # need disk space for one private copy of the unpacked source.
1860 # But we can't make them into commits until we have the metadata
1861 # from the debian/changelog, so we record the tree objects now and
1862 # make them into commits later.
1864 my $upstreamv = upstreamversion $dsc->{version};
1865 my $orig_f_base = srcfn $upstreamv, '';
1867 foreach my $fi (@dfi) {
1868 # We actually import, and record as a commit, every tarball
1869 # (unless there is only one file, in which case there seems
1872 my $f = $fi->{Filename};
1873 printdebug "import considering $f ";
1874 (printdebug "only one dfi\n"), next if @dfi == 1;
1875 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1876 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1880 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1882 printdebug "Y ", (join ' ', map { $_//"(none)" }
1883 $compr_ext, $orig_f_part
1886 my $input = new IO::File $f, '<' or die "$f $!";
1890 if (defined $compr_ext) {
1892 Dpkg::Compression::compression_guess_from_filename $f;
1893 fail "Dpkg::Compression cannot handle file $f in source package"
1894 if defined $compr_ext && !defined $cname;
1896 new Dpkg::Compression::Process compression => $cname;
1897 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1898 my $compr_fh = new IO::Handle;
1899 my $compr_pid = open $compr_fh, "-|" // die $!;
1901 open STDIN, "<&", $input or die $!;
1903 die "dgit (child): exec $compr_cmd[0]: $!\n";
1908 rmtree "../unpack-tar";
1909 mkdir "../unpack-tar" or die $!;
1910 my @tarcmd = qw(tar -x -f -
1911 --no-same-owner --no-same-permissions
1912 --no-acls --no-xattrs --no-selinux);
1913 my $tar_pid = fork // die $!;
1915 chdir "../unpack-tar" or die $!;
1916 open STDIN, "<&", $input or die $!;
1918 die "dgit (child): exec $tarcmd[0]: $!";
1920 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1921 !$? or failedcmd @tarcmd;
1924 (@compr_cmd ? failedcmd @compr_cmd
1926 # finally, we have the results in "tarball", but maybe
1927 # with the wrong permissions
1929 runcmd qw(chmod -R +rwX ../unpack-tar);
1930 changedir "../unpack-tar";
1931 my ($tree) = mktree_in_ud_from_only_subdir(1);
1932 changedir "../../unpack";
1933 rmtree "../unpack-tar";
1935 my $ent = [ $f, $tree ];
1937 Orig => !!$orig_f_part,
1938 Sort => (!$orig_f_part ? 2 :
1939 $orig_f_part =~ m/-/g ? 1 :
1947 # put any without "_" first (spec is not clear whether files
1948 # are always in the usual order). Tarballs without "_" are
1949 # the main orig or the debian tarball.
1950 $a->{Sort} <=> $b->{Sort} or
1954 my $any_orig = grep { $_->{Orig} } @tartrees;
1956 my $dscfn = "$package.dsc";
1958 my $treeimporthow = 'package';
1960 open D, ">", $dscfn or die "$dscfn: $!";
1961 print D $dscdata or die "$dscfn: $!";
1962 close D or die "$dscfn: $!";
1963 my @cmd = qw(dpkg-source);
1964 push @cmd, '--no-check' if $dsc_checked;
1965 if (madformat $dsc->{format}) {
1966 push @cmd, '--skip-patches';
1967 $treeimporthow = 'unpatched';
1969 push @cmd, qw(-x --), $dscfn;
1972 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1973 if (madformat $dsc->{format}) {
1974 check_for_vendor_patches();
1978 if (madformat $dsc->{format}) {
1979 my @pcmd = qw(dpkg-source --before-build .);
1980 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1982 runcmd @git, qw(add -Af);
1983 $dappliedtree = git_write_tree();
1986 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1987 debugcmd "|",@clogcmd;
1988 open CLOGS, "-|", @clogcmd or die $!;
1993 printdebug "import clog search...\n";
1996 my $stanzatext = do { local $/=""; <CLOGS>; };
1997 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1998 last if !defined $stanzatext;
2000 my $desc = "package changelog, entry no.$.";
2001 open my $stanzafh, "<", \$stanzatext or die;
2002 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2003 $clogp //= $thisstanza;
2005 printdebug "import clog $thisstanza->{version} $desc...\n";
2007 last if !$any_orig; # we don't need $r1clogp
2009 # We look for the first (most recent) changelog entry whose
2010 # version number is lower than the upstream version of this
2011 # package. Then the last (least recent) previous changelog
2012 # entry is treated as the one which introduced this upstream
2013 # version and used for the synthetic commits for the upstream
2016 # One might think that a more sophisticated algorithm would be
2017 # necessary. But: we do not want to scan the whole changelog
2018 # file. Stopping when we see an earlier version, which
2019 # necessarily then is an earlier upstream version, is the only
2020 # realistic way to do that. Then, either the earliest
2021 # changelog entry we have seen so far is indeed the earliest
2022 # upload of this upstream version; or there are only changelog
2023 # entries relating to later upstream versions (which is not
2024 # possible unless the changelog and .dsc disagree about the
2025 # version). Then it remains to choose between the physically
2026 # last entry in the file, and the one with the lowest version
2027 # number. If these are not the same, we guess that the
2028 # versions were created in a non-monotic order rather than
2029 # that the changelog entries have been misordered.
2031 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2033 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2034 $r1clogp = $thisstanza;
2036 printdebug "import clog $r1clogp->{version} becomes r1\n";
2038 die $! if CLOGS->error;
2039 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2041 $clogp or fail "package changelog has no entries!";
2043 my $authline = clogp_authline $clogp;
2044 my $changes = getfield $clogp, 'Changes';
2045 my $cversion = getfield $clogp, 'Version';
2048 $r1clogp //= $clogp; # maybe there's only one entry;
2049 my $r1authline = clogp_authline $r1clogp;
2050 # Strictly, r1authline might now be wrong if it's going to be
2051 # unused because !$any_orig. Whatever.
2053 printdebug "import tartrees authline $authline\n";
2054 printdebug "import tartrees r1authline $r1authline\n";
2056 foreach my $tt (@tartrees) {
2057 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2059 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2062 committer $r1authline
2066 [dgit import orig $tt->{F}]
2074 [dgit import tarball $package $cversion $tt->{F}]
2079 printdebug "import main commit\n";
2081 open C, ">../commit.tmp" or die $!;
2082 print C <<END or die $!;
2085 print C <<END or die $! foreach @tartrees;
2088 print C <<END or die $!;
2094 [dgit import $treeimporthow $package $cversion]
2098 my $rawimport_hash = make_commit qw(../commit.tmp);
2100 if (madformat $dsc->{format}) {
2101 printdebug "import apply patches...\n";
2103 # regularise the state of the working tree so that
2104 # the checkout of $rawimport_hash works nicely.
2105 my $dappliedcommit = make_commit_text(<<END);
2112 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2114 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2116 # We need the answers to be reproducible
2117 my @authline = clogp_authline($clogp);
2118 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2119 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2120 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2121 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2122 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2123 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2125 my $path = $ENV{PATH} or die;
2127 foreach my $use_absurd (qw(0 1)) {
2128 local $ENV{PATH} = $path;
2131 progress "warning: $@";
2132 $path = "$absurdity:$path";
2133 progress "$us: trying slow absurd-git-apply...";
2134 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2139 die "forbid absurd git-apply\n" if $use_absurd
2140 && forceing [qw(import-gitapply-no-absurd)];
2141 die "only absurd git-apply!\n" if !$use_absurd
2142 && forceing [qw(import-gitapply-absurd)];
2144 local $ENV{PATH} = $path if $use_absurd;
2146 my @showcmd = (gbp_pq, qw(import));
2147 my @realcmd = shell_cmd
2148 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2149 debugcmd "+",@realcmd;
2150 if (system @realcmd) {
2151 die +(shellquote @showcmd).
2153 failedcmd_waitstatus()."\n";
2156 my $gapplied = git_rev_parse('HEAD');
2157 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2158 $gappliedtree eq $dappliedtree or
2160 gbp-pq import and dpkg-source disagree!
2161 gbp-pq import gave commit $gapplied
2162 gbp-pq import gave tree $gappliedtree
2163 dpkg-source --before-build gave tree $dappliedtree
2165 $rawimport_hash = $gapplied;
2170 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2175 progress "synthesised git commit from .dsc $cversion";
2177 my $rawimport_mergeinput = {
2178 Commit => $rawimport_hash,
2179 Info => "Import of source package",
2181 my @output = ($rawimport_mergeinput);
2183 if ($lastpush_mergeinput) {
2184 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2185 my $oversion = getfield $oldclogp, 'Version';
2187 version_compare($oversion, $cversion);
2189 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2190 { Message => <<END, ReverseParents => 1 });
2191 Record $package ($cversion) in archive suite $csuite
2193 } elsif ($vcmp > 0) {
2194 print STDERR <<END or die $!;
2196 Version actually in archive: $cversion (older)
2197 Last version pushed with dgit: $oversion (newer or same)
2200 @output = $lastpush_mergeinput;
2202 # Same version. Use what's in the server git branch,
2203 # discarding our own import. (This could happen if the
2204 # server automatically imports all packages into git.)
2205 @output = $lastpush_mergeinput;
2208 changedir '../../../..';
2213 sub complete_file_from_dsc ($$) {
2214 our ($dstdir, $fi) = @_;
2215 # Ensures that we have, in $dir, the file $fi, with the correct
2216 # contents. (Downloading it from alongside $dscurl if necessary.)
2218 my $f = $fi->{Filename};
2219 my $tf = "$dstdir/$f";
2222 if (stat_exists $tf) {
2223 progress "using existing $f";
2225 printdebug "$tf does not exist, need to fetch\n";
2227 $furl =~ s{/[^/]+$}{};
2229 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2230 die "$f ?" if $f =~ m#/#;
2231 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2232 return 0 if !act_local();
2236 open F, "<", "$tf" or die "$tf: $!";
2237 $fi->{Digester}->reset();
2238 $fi->{Digester}->addfile(*F);
2239 F->error and die $!;
2240 my $got = $fi->{Digester}->hexdigest();
2241 $got eq $fi->{Hash} or
2242 fail "file $f has hash $got but .dsc".
2243 " demands hash $fi->{Hash} ".
2244 ($downloaded ? "(got wrong file from archive!)"
2245 : "(perhaps you should delete this file?)");
2250 sub ensure_we_have_orig () {
2251 my @dfi = dsc_files_info();
2252 foreach my $fi (@dfi) {
2253 my $f = $fi->{Filename};
2254 next unless is_orig_file_in_dsc($f, \@dfi);
2255 complete_file_from_dsc('..', $fi)
2260 sub git_fetch_us () {
2261 # Want to fetch only what we are going to use, unless
2262 # deliberately-not-ff, in which case we must fetch everything.
2264 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2266 (quiltmode_splitbrain
2267 ? (map { $_->('*',access_basedistro) }
2268 \&debiantag_new, \&debiantag_maintview)
2269 : debiantags('*',access_basedistro));
2270 push @specs, server_branch($csuite);
2271 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2273 # This is rather miserable:
2274 # When git fetch --prune is passed a fetchspec ending with a *,
2275 # it does a plausible thing. If there is no * then:
2276 # - it matches subpaths too, even if the supplied refspec
2277 # starts refs, and behaves completely madly if the source
2278 # has refs/refs/something. (See, for example, Debian #NNNN.)
2279 # - if there is no matching remote ref, it bombs out the whole
2281 # We want to fetch a fixed ref, and we don't know in advance
2282 # if it exists, so this is not suitable.
2284 # Our workaround is to use git ls-remote. git ls-remote has its
2285 # own qairks. Notably, it has the absurd multi-tail-matching
2286 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2287 # refs/refs/foo etc.
2289 # Also, we want an idempotent snapshot, but we have to make two
2290 # calls to the remote: one to git ls-remote and to git fetch. The
2291 # solution is use git ls-remote to obtain a target state, and
2292 # git fetch to try to generate it. If we don't manage to generate
2293 # the target state, we try again.
2295 my $specre = join '|', map {
2301 printdebug "git_fetch_us specre=$specre\n";
2302 my $wanted_rref = sub {
2304 return m/^(?:$specre)$/o;
2307 my $fetch_iteration = 0;
2310 if (++$fetch_iteration > 10) {
2311 fail "too many iterations trying to get sane fetch!";
2314 my @look = map { "refs/$_" } @specs;
2315 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2319 open GITLS, "-|", @lcmd or die $!;
2321 printdebug "=> ", $_;
2322 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2323 my ($objid,$rrefname) = ($1,$2);
2324 if (!$wanted_rref->($rrefname)) {
2326 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2330 $wantr{$rrefname} = $objid;
2333 close GITLS or failedcmd @lcmd;
2335 # OK, now %want is exactly what we want for refs in @specs
2337 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2338 "+refs/$_:".lrfetchrefs."/$_";
2341 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2342 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2345 %lrfetchrefs_f = ();
2348 git_for_each_ref(lrfetchrefs, sub {
2349 my ($objid,$objtype,$lrefname,$reftail) = @_;
2350 $lrfetchrefs_f{$lrefname} = $objid;
2351 $objgot{$objid} = 1;
2354 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2355 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2356 if (!exists $wantr{$rrefname}) {
2357 if ($wanted_rref->($rrefname)) {
2359 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2363 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2366 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2367 delete $lrfetchrefs_f{$lrefname};
2371 foreach my $rrefname (sort keys %wantr) {
2372 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2373 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2374 my $want = $wantr{$rrefname};
2375 next if $got eq $want;
2376 if (!defined $objgot{$want}) {
2378 warning: git ls-remote suggests we want $lrefname
2379 warning: and it should refer to $want
2380 warning: but git fetch didn't fetch that object to any relevant ref.
2381 warning: This may be due to a race with someone updating the server.
2382 warning: Will try again...
2384 next FETCH_ITERATION;
2387 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2389 runcmd_ordryrun_local @git, qw(update-ref -m),
2390 "dgit fetch git fetch fixup", $lrefname, $want;
2391 $lrfetchrefs_f{$lrefname} = $want;
2395 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2396 Dumper(\%lrfetchrefs_f);
2399 my @tagpats = debiantags('*',access_basedistro);
2401 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2402 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2403 printdebug "currently $fullrefname=$objid\n";
2404 $here{$fullrefname} = $objid;
2406 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2408 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2409 printdebug "offered $lref=$objid\n";
2410 if (!defined $here{$lref}) {
2411 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2412 runcmd_ordryrun_local @upd;
2413 lrfetchref_used $fullrefname;
2414 } elsif ($here{$lref} eq $objid) {
2415 lrfetchref_used $fullrefname;
2418 "Not updateting $lref from $here{$lref} to $objid.\n";
2423 sub mergeinfo_getclogp ($) {
2424 # Ensures thit $mi->{Clogp} exists and returns it
2426 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2429 sub mergeinfo_version ($) {
2430 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2433 sub fetch_from_archive () {
2434 ensure_setup_existing_tree();
2436 # Ensures that lrref() is what is actually in the archive, one way
2437 # or another, according to us - ie this client's
2438 # appropritaely-updated archive view. Also returns the commit id.
2439 # If there is nothing in the archive, leaves lrref alone and
2440 # returns undef. git_fetch_us must have already been called.
2444 foreach my $field (@ourdscfield) {
2445 $dsc_hash = $dsc->{$field};
2446 last if defined $dsc_hash;
2448 if (defined $dsc_hash) {
2449 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2451 progress "last upload to archive specified git hash";
2453 progress "last upload to archive has NO git hash";
2456 progress "no version available from the archive";
2459 # If the archive's .dsc has a Dgit field, there are three
2460 # relevant git commitids we need to choose between and/or merge
2462 # 1. $dsc_hash: the Dgit field from the archive
2463 # 2. $lastpush_hash: the suite branch on the dgit git server
2464 # 3. $lastfetch_hash: our local tracking brach for the suite
2466 # These may all be distinct and need not be in any fast forward
2469 # If the dsc was pushed to this suite, then the server suite
2470 # branch will have been updated; but it might have been pushed to
2471 # a different suite and copied by the archive. Conversely a more
2472 # recent version may have been pushed with dgit but not appeared
2473 # in the archive (yet).
2475 # $lastfetch_hash may be awkward because archive imports
2476 # (particularly, imports of Dgit-less .dscs) are performed only as
2477 # needed on individual clients, so different clients may perform a
2478 # different subset of them - and these imports are only made
2479 # public during push. So $lastfetch_hash may represent a set of
2480 # imports different to a subsequent upload by a different dgit
2483 # Our approach is as follows:
2485 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2486 # descendant of $dsc_hash, then it was pushed by a dgit user who
2487 # had based their work on $dsc_hash, so we should prefer it.
2488 # Otherwise, $dsc_hash was installed into this suite in the
2489 # archive other than by a dgit push, and (necessarily) after the
2490 # last dgit push into that suite (since a dgit push would have
2491 # been descended from the dgit server git branch); thus, in that
2492 # case, we prefer the archive's version (and produce a
2493 # pseudo-merge to overwrite the dgit server git branch).
2495 # (If there is no Dgit field in the archive's .dsc then
2496 # generate_commit_from_dsc uses the version numbers to decide
2497 # whether the suite branch or the archive is newer. If the suite
2498 # branch is newer it ignores the archive's .dsc; otherwise it
2499 # generates an import of the .dsc, and produces a pseudo-merge to
2500 # overwrite the suite branch with the archive contents.)
2502 # The outcome of that part of the algorithm is the `public view',
2503 # and is same for all dgit clients: it does not depend on any
2504 # unpublished history in the local tracking branch.
2506 # As between the public view and the local tracking branch: The
2507 # local tracking branch is only updated by dgit fetch, and
2508 # whenever dgit fetch runs it includes the public view in the
2509 # local tracking branch. Therefore if the public view is not
2510 # descended from the local tracking branch, the local tracking
2511 # branch must contain history which was imported from the archive
2512 # but never pushed; and, its tip is now out of date. So, we make
2513 # a pseudo-merge to overwrite the old imports and stitch the old
2516 # Finally: we do not necessarily reify the public view (as
2517 # described above). This is so that we do not end up stacking two
2518 # pseudo-merges. So what we actually do is figure out the inputs
2519 # to any public view pseudo-merge and put them in @mergeinputs.
2522 # $mergeinputs[]{Commit}
2523 # $mergeinputs[]{Info}
2524 # $mergeinputs[0] is the one whose tree we use
2525 # @mergeinputs is in the order we use in the actual commit)
2528 # $mergeinputs[]{Message} is a commit message to use
2529 # $mergeinputs[]{ReverseParents} if def specifies that parent
2530 # list should be in opposite order
2531 # Such an entry has no Commit or Info. It applies only when found
2532 # in the last entry. (This ugliness is to support making
2533 # identical imports to previous dgit versions.)
2535 my $lastpush_hash = git_get_ref(lrfetchref());
2536 printdebug "previous reference hash=$lastpush_hash\n";
2537 $lastpush_mergeinput = $lastpush_hash && {
2538 Commit => $lastpush_hash,
2539 Info => "dgit suite branch on dgit git server",
2542 my $lastfetch_hash = git_get_ref(lrref());
2543 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2544 my $lastfetch_mergeinput = $lastfetch_hash && {
2545 Commit => $lastfetch_hash,
2546 Info => "dgit client's archive history view",
2549 my $dsc_mergeinput = $dsc_hash && {
2550 Commit => $dsc_hash,
2551 Info => "Dgit field in .dsc from archive",
2555 my $del_lrfetchrefs = sub {
2558 printdebug "del_lrfetchrefs...\n";
2559 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2560 my $objid = $lrfetchrefs_d{$fullrefname};
2561 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2563 $gur ||= new IO::Handle;
2564 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2566 printf $gur "delete %s %s\n", $fullrefname, $objid;
2569 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2573 if (defined $dsc_hash) {
2574 fail "missing remote git history even though dsc has hash -".
2575 " could not find ref ".rref()." at ".access_giturl()
2576 unless $lastpush_hash;
2577 ensure_we_have_orig();
2578 if ($dsc_hash eq $lastpush_hash) {
2579 @mergeinputs = $dsc_mergeinput
2580 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2581 print STDERR <<END or die $!;
2583 Git commit in archive is behind the last version allegedly pushed/uploaded.
2584 Commit referred to by archive: $dsc_hash
2585 Last version pushed with dgit: $lastpush_hash
2588 @mergeinputs = ($lastpush_mergeinput);
2590 # Archive has .dsc which is not a descendant of the last dgit
2591 # push. This can happen if the archive moves .dscs about.
2592 # Just follow its lead.
2593 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2594 progress "archive .dsc names newer git commit";
2595 @mergeinputs = ($dsc_mergeinput);
2597 progress "archive .dsc names other git commit, fixing up";
2598 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2602 @mergeinputs = generate_commits_from_dsc();
2603 # We have just done an import. Now, our import algorithm might
2604 # have been improved. But even so we do not want to generate
2605 # a new different import of the same package. So if the
2606 # version numbers are the same, just use our existing version.
2607 # If the version numbers are different, the archive has changed
2608 # (perhaps, rewound).
2609 if ($lastfetch_mergeinput &&
2610 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2611 (mergeinfo_version $mergeinputs[0]) )) {
2612 @mergeinputs = ($lastfetch_mergeinput);
2614 } elsif ($lastpush_hash) {
2615 # only in git, not in the archive yet
2616 @mergeinputs = ($lastpush_mergeinput);
2617 print STDERR <<END or die $!;
2619 Package not found in the archive, but has allegedly been pushed using dgit.
2623 printdebug "nothing found!\n";
2624 if (defined $skew_warning_vsn) {
2625 print STDERR <<END or die $!;
2627 Warning: relevant archive skew detected.
2628 Archive allegedly contains $skew_warning_vsn
2629 But we were not able to obtain any version from the archive or git.
2633 unshift @end, $del_lrfetchrefs;
2637 if ($lastfetch_hash &&
2639 my $h = $_->{Commit};
2640 $h and is_fast_fwd($lastfetch_hash, $h);
2641 # If true, one of the existing parents of this commit
2642 # is a descendant of the $lastfetch_hash, so we'll
2643 # be ff from that automatically.
2647 push @mergeinputs, $lastfetch_mergeinput;
2650 printdebug "fetch mergeinfos:\n";
2651 foreach my $mi (@mergeinputs) {
2653 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2655 printdebug sprintf " ReverseParents=%d Message=%s",
2656 $mi->{ReverseParents}, $mi->{Message};
2660 my $compat_info= pop @mergeinputs
2661 if $mergeinputs[$#mergeinputs]{Message};
2663 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2666 if (@mergeinputs > 1) {
2668 my $tree_commit = $mergeinputs[0]{Commit};
2670 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2671 $tree =~ m/\n\n/; $tree = $`;
2672 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2675 # We use the changelog author of the package in question the
2676 # author of this pseudo-merge. This is (roughly) correct if
2677 # this commit is simply representing aa non-dgit upload.
2678 # (Roughly because it does not record sponsorship - but we
2679 # don't have sponsorship info because that's in the .changes,
2680 # which isn't in the archivw.)
2682 # But, it might be that we are representing archive history
2683 # updates (including in-archive copies). These are not really
2684 # the responsibility of the person who created the .dsc, but
2685 # there is no-one whose name we should better use. (The
2686 # author of the .dsc-named commit is clearly worse.)
2688 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2689 my $author = clogp_authline $useclogp;
2690 my $cversion = getfield $useclogp, 'Version';
2692 my $mcf = ".git/dgit/mergecommit";
2693 open MC, ">", $mcf or die "$mcf $!";
2694 print MC <<END or die $!;
2698 my @parents = grep { $_->{Commit} } @mergeinputs;
2699 @parents = reverse @parents if $compat_info->{ReverseParents};
2700 print MC <<END or die $! foreach @parents;
2704 print MC <<END or die $!;
2710 if (defined $compat_info->{Message}) {
2711 print MC $compat_info->{Message} or die $!;
2713 print MC <<END or die $!;
2714 Record $package ($cversion) in archive suite $csuite
2718 my $message_add_info = sub {
2720 my $mversion = mergeinfo_version $mi;
2721 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2725 $message_add_info->($mergeinputs[0]);
2726 print MC <<END or die $!;
2727 should be treated as descended from
2729 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2733 $hash = make_commit $mcf;
2735 $hash = $mergeinputs[0]{Commit};
2737 printdebug "fetch hash=$hash\n";
2740 my ($lasth, $what) = @_;
2741 return unless $lasth;
2742 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2745 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2746 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2748 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2749 'DGIT_ARCHIVE', $hash;
2750 cmdoutput @git, qw(log -n2), $hash;
2751 # ... gives git a chance to complain if our commit is malformed
2753 if (defined $skew_warning_vsn) {
2755 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2756 my $gotclogp = commit_getclogp($hash);
2757 my $got_vsn = getfield $gotclogp, 'Version';
2758 printdebug "SKEW CHECK GOT $got_vsn\n";
2759 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2760 print STDERR <<END or die $!;
2762 Warning: archive skew detected. Using the available version:
2763 Archive allegedly contains $skew_warning_vsn
2764 We were able to obtain only $got_vsn
2770 if ($lastfetch_hash ne $hash) {
2771 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2775 dryrun_report @upd_cmd;
2779 lrfetchref_used lrfetchref();
2781 unshift @end, $del_lrfetchrefs;
2785 sub set_local_git_config ($$) {
2787 runcmd @git, qw(config), $k, $v;
2790 sub setup_mergechangelogs (;$) {
2792 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2794 my $driver = 'dpkg-mergechangelogs';
2795 my $cb = "merge.$driver";
2796 my $attrs = '.git/info/attributes';
2797 ensuredir '.git/info';
2799 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2800 if (!open ATTRS, "<", $attrs) {
2801 $!==ENOENT or die "$attrs: $!";
2805 next if m{^debian/changelog\s};
2806 print NATTRS $_, "\n" or die $!;
2808 ATTRS->error and die $!;
2811 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2814 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2815 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2817 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2820 sub setup_useremail (;$) {
2822 return unless $always || access_cfg_bool(1, 'setup-useremail');
2825 my ($k, $envvar) = @_;
2826 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2827 return unless defined $v;
2828 set_local_git_config "user.$k", $v;
2831 $setup->('email', 'DEBEMAIL');
2832 $setup->('name', 'DEBFULLNAME');
2835 sub ensure_setup_existing_tree () {
2836 my $k = "remote.$remotename.skipdefaultupdate";
2837 my $c = git_get_config $k;
2838 return if defined $c;
2839 set_local_git_config $k, 'true';
2842 sub setup_new_tree () {
2843 setup_mergechangelogs();
2849 canonicalise_suite();
2850 badusage "dry run makes no sense with clone" unless act_local();
2851 my $hasgit = check_for_git();
2852 mkdir $dstdir or fail "create \`$dstdir': $!";
2854 runcmd @git, qw(init -q);
2855 my $giturl = access_giturl(1);
2856 if (defined $giturl) {
2857 open H, "> .git/HEAD" or die $!;
2858 print H "ref: ".lref()."\n" or die $!;
2860 runcmd @git, qw(remote add), 'origin', $giturl;
2863 progress "fetching existing git history";
2865 runcmd_ordryrun_local @git, qw(fetch origin);
2867 progress "starting new git history";
2869 fetch_from_archive() or no_such_package;
2870 my $vcsgiturl = $dsc->{'Vcs-Git'};
2871 if (length $vcsgiturl) {
2872 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2873 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2876 runcmd @git, qw(reset --hard), lrref();
2877 runcmd qw(bash -ec), <<'END';
2879 git ls-tree -r --name-only -z HEAD | \
2880 xargs -0r touch -r . --
2882 printdone "ready for work in $dstdir";
2886 if (check_for_git()) {
2889 fetch_from_archive() or no_such_package();
2890 printdone "fetched into ".lrref();
2895 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2897 printdone "fetched to ".lrref()." and merged into HEAD";
2900 sub check_not_dirty () {
2901 foreach my $f (qw(local-options local-patch-header)) {
2902 if (stat_exists "debian/source/$f") {
2903 fail "git tree contains debian/source/$f";
2907 return if $ignoredirty;
2909 my @cmd = (@git, qw(diff --quiet HEAD));
2911 $!=0; $?=-1; system @cmd;
2914 fail "working tree is dirty (does not match HEAD)";
2920 sub commit_admin ($) {
2923 runcmd_ordryrun_local @git, qw(commit -m), $m;
2926 sub commit_quilty_patch () {
2927 my $output = cmdoutput @git, qw(status --porcelain);
2929 foreach my $l (split /\n/, $output) {
2930 next unless $l =~ m/\S/;
2931 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2935 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2937 progress "nothing quilty to commit, ok.";
2940 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2941 runcmd_ordryrun_local @git, qw(add -f), @adds;
2943 Commit Debian 3.0 (quilt) metadata
2945 [dgit ($our_version) quilt-fixup]
2949 sub get_source_format () {
2951 if (open F, "debian/source/options") {
2955 s/\s+$//; # ignore missing final newline
2957 my ($k, $v) = ($`, $'); #');
2958 $v =~ s/^"(.*)"$/$1/;
2964 F->error and die $!;
2967 die $! unless $!==&ENOENT;
2970 if (!open F, "debian/source/format") {
2971 die $! unless $!==&ENOENT;
2975 F->error and die $!;
2977 return ($_, \%options);
2980 sub madformat_wantfixup ($) {
2982 return 0 unless $format eq '3.0 (quilt)';
2983 our $quilt_mode_warned;
2984 if ($quilt_mode eq 'nocheck') {
2985 progress "Not doing any fixup of \`$format' due to".
2986 " ----no-quilt-fixup or --quilt=nocheck"
2987 unless $quilt_mode_warned++;
2990 progress "Format \`$format', need to check/update patch stack"
2991 unless $quilt_mode_warned++;
2995 sub maybe_split_brain_save ($$$) {
2996 my ($headref, $dgitview, $msg) = @_;
2997 # => message fragment "$saved" describing disposition of $dgitview
2998 return "commit id $dgitview" unless defined $split_brain_save;
2999 my @cmd = (shell_cmd "cd ../../../..",
3000 @git, qw(update-ref -m),
3001 "dgit --dgit-view-save $msg HEAD=$headref",
3002 $split_brain_save, $dgitview);
3004 return "and left in $split_brain_save";
3007 # An "infopair" is a tuple [ $thing, $what ]
3008 # (often $thing is a commit hash; $what is a description)
3010 sub infopair_cond_equal ($$) {
3012 $x->[0] eq $y->[0] or fail <<END;
3013 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3017 sub infopair_lrf_tag_lookup ($$) {
3018 my ($tagnames, $what) = @_;
3019 # $tagname may be an array ref
3020 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3021 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3022 foreach my $tagname (@tagnames) {
3023 my $lrefname = lrfetchrefs."/tags/$tagname";
3024 my $tagobj = $lrfetchrefs_f{$lrefname};
3025 next unless defined $tagobj;
3026 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3027 return [ git_rev_parse($tagobj), $what ];
3029 fail @tagnames==1 ? <<END : <<END;
3030 Wanted tag $what (@tagnames) on dgit server, but not found
3032 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3036 sub infopair_cond_ff ($$) {
3037 my ($anc,$desc) = @_;
3038 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3039 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3043 sub pseudomerge_version_check ($$) {
3044 my ($clogp, $archive_hash) = @_;
3046 my $arch_clogp = commit_getclogp $archive_hash;
3047 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3048 'version currently in archive' ];
3049 if (defined $overwrite_version) {
3050 if (length $overwrite_version) {
3051 infopair_cond_equal([ $overwrite_version,
3052 '--overwrite= version' ],
3055 my $v = $i_arch_v->[0];
3056 progress "Checking package changelog for archive version $v ...";
3058 my @xa = ("-f$v", "-t$v");
3059 my $vclogp = parsechangelog @xa;
3060 my $cv = [ (getfield $vclogp, 'Version'),
3061 "Version field from dpkg-parsechangelog @xa" ];
3062 infopair_cond_equal($i_arch_v, $cv);
3065 $@ =~ s/^dgit: //gm;
3067 "Perhaps debian/changelog does not mention $v ?";
3072 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3076 sub pseudomerge_make_commit ($$$$ $$) {
3077 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3078 $msg_cmd, $msg_msg) = @_;
3079 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3081 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3082 my $authline = clogp_authline $clogp;
3086 !defined $overwrite_version ? ""
3087 : !length $overwrite_version ? " --overwrite"
3088 : " --overwrite=".$overwrite_version;
3091 my $pmf = ".git/dgit/pseudomerge";
3092 open MC, ">", $pmf or die "$pmf $!";
3093 print MC <<END or die $!;
3096 parent $archive_hash
3106 return make_commit($pmf);
3109 sub splitbrain_pseudomerge ($$$$) {
3110 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3111 # => $merged_dgitview
3112 printdebug "splitbrain_pseudomerge...\n";
3114 # We: debian/PREVIOUS HEAD($maintview)
3115 # expect: o ----------------- o
3118 # a/d/PREVIOUS $dgitview
3121 # we do: `------------------ o
3125 return $dgitview unless defined $archive_hash;
3127 printdebug "splitbrain_pseudomerge...\n";
3129 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3131 if (!defined $overwrite_version) {
3132 progress "Checking that HEAD inciudes all changes in archive...";
3135 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3137 if (defined $overwrite_version) {
3139 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3140 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3141 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3142 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3143 my $i_archive = [ $archive_hash, "current archive contents" ];
3145 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3147 infopair_cond_equal($i_dgit, $i_archive);
3148 infopair_cond_ff($i_dep14, $i_dgit);
3149 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3153 $us: check failed (maybe --overwrite is needed, consult documentation)
3158 my $r = pseudomerge_make_commit
3159 $clogp, $dgitview, $archive_hash, $i_arch_v,
3160 "dgit --quilt=$quilt_mode",
3161 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3162 Declare fast forward from $i_arch_v->[0]
3164 Make fast forward from $i_arch_v->[0]
3167 maybe_split_brain_save $maintview, $r, "pseudomerge";
3169 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3173 sub plain_overwrite_pseudomerge ($$$) {
3174 my ($clogp, $head, $archive_hash) = @_;
3176 printdebug "plain_overwrite_pseudomerge...";
3178 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3180 return $head if is_fast_fwd $archive_hash, $head;
3182 my $m = "Declare fast forward from $i_arch_v->[0]";
3184 my $r = pseudomerge_make_commit
3185 $clogp, $head, $archive_hash, $i_arch_v,
3188 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3190 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3194 sub push_parse_changelog ($) {
3197 my $clogp = Dpkg::Control::Hash->new();
3198 $clogp->load($clogpfn) or die;
3200 $package = getfield $clogp, 'Source';
3201 my $cversion = getfield $clogp, 'Version';
3202 my $tag = debiantag($cversion, access_basedistro);
3203 runcmd @git, qw(check-ref-format), $tag;
3205 my $dscfn = dscfn($cversion);
3207 return ($clogp, $cversion, $dscfn);
3210 sub push_parse_dsc ($$$) {
3211 my ($dscfn,$dscfnwhat, $cversion) = @_;
3212 $dsc = parsecontrol($dscfn,$dscfnwhat);
3213 my $dversion = getfield $dsc, 'Version';
3214 my $dscpackage = getfield $dsc, 'Source';
3215 ($dscpackage eq $package && $dversion eq $cversion) or
3216 fail "$dscfn is for $dscpackage $dversion".
3217 " but debian/changelog is for $package $cversion";
3220 sub push_tagwants ($$$$) {
3221 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3224 TagFn => \&debiantag,
3229 if (defined $maintviewhead) {
3231 TagFn => \&debiantag_maintview,
3232 Objid => $maintviewhead,
3233 TfSuffix => '-maintview',
3237 foreach my $tw (@tagwants) {
3238 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3239 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3241 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3245 sub push_mktags ($$ $$ $) {
3247 $changesfile,$changesfilewhat,
3250 die unless $tagwants->[0]{View} eq 'dgit';
3252 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3253 $dsc->save("$dscfn.tmp") or die $!;
3255 my $changes = parsecontrol($changesfile,$changesfilewhat);
3256 foreach my $field (qw(Source Distribution Version)) {
3257 $changes->{$field} eq $clogp->{$field} or
3258 fail "changes field $field \`$changes->{$field}'".
3259 " does not match changelog \`$clogp->{$field}'";
3262 my $cversion = getfield $clogp, 'Version';
3263 my $clogsuite = getfield $clogp, 'Distribution';
3265 # We make the git tag by hand because (a) that makes it easier
3266 # to control the "tagger" (b) we can do remote signing
3267 my $authline = clogp_authline $clogp;
3268 my $delibs = join(" ", "",@deliberatelies);
3269 my $declaredistro = access_basedistro();
3273 my $tfn = $tw->{Tfn};
3274 my $head = $tw->{Objid};
3275 my $tag = $tw->{Tag};
3277 open TO, '>', $tfn->('.tmp') or die $!;
3278 print TO <<END or die $!;
3285 if ($tw->{View} eq 'dgit') {
3286 print TO <<END or die $!;
3287 $package release $cversion for $clogsuite ($csuite) [dgit]
3288 [dgit distro=$declaredistro$delibs]
3290 foreach my $ref (sort keys %previously) {
3291 print TO <<END or die $!;
3292 [dgit previously:$ref=$previously{$ref}]
3295 } elsif ($tw->{View} eq 'maint') {
3296 print TO <<END or die $!;
3297 $package release $cversion for $clogsuite ($csuite)
3298 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3301 die Dumper($tw)."?";
3306 my $tagobjfn = $tfn->('.tmp');
3308 if (!defined $keyid) {
3309 $keyid = access_cfg('keyid','RETURN-UNDEF');
3311 if (!defined $keyid) {
3312 $keyid = getfield $clogp, 'Maintainer';
3314 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3315 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3316 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3317 push @sign_cmd, $tfn->('.tmp');
3318 runcmd_ordryrun @sign_cmd;
3320 $tagobjfn = $tfn->('.signed.tmp');
3321 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3322 $tfn->('.tmp'), $tfn->('.tmp.asc');
3328 my @r = map { $mktag->($_); } @$tagwants;
3332 sub sign_changes ($) {
3333 my ($changesfile) = @_;
3335 my @debsign_cmd = @debsign;
3336 push @debsign_cmd, "-k$keyid" if defined $keyid;
3337 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3338 push @debsign_cmd, $changesfile;
3339 runcmd_ordryrun @debsign_cmd;
3344 printdebug "actually entering push\n";
3346 supplementary_message(<<'END');
3347 Push failed, while checking state of the archive.
3348 You can retry the push, after fixing the problem, if you like.
3350 if (check_for_git()) {
3353 my $archive_hash = fetch_from_archive();
3354 if (!$archive_hash) {
3356 fail "package appears to be new in this suite;".
3357 " if this is intentional, use --new";
3360 supplementary_message(<<'END');
3361 Push failed, while preparing your push.
3362 You can retry the push, after fixing the problem, if you like.
3365 need_tagformat 'new', "quilt mode $quilt_mode"
3366 if quiltmode_splitbrain;
3370 access_giturl(); # check that success is vaguely likely
3373 my $clogpfn = ".git/dgit/changelog.822.tmp";
3374 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3376 responder_send_file('parsed-changelog', $clogpfn);
3378 my ($clogp, $cversion, $dscfn) =
3379 push_parse_changelog("$clogpfn");
3381 my $dscpath = "$buildproductsdir/$dscfn";
3382 stat_exists $dscpath or
3383 fail "looked for .dsc $dscfn, but $!;".
3384 " maybe you forgot to build";
3386 responder_send_file('dsc', $dscpath);
3388 push_parse_dsc($dscpath, $dscfn, $cversion);
3390 my $format = getfield $dsc, 'Format';
3391 printdebug "format $format\n";
3393 my $actualhead = git_rev_parse('HEAD');
3394 my $dgithead = $actualhead;
3395 my $maintviewhead = undef;
3397 my $upstreamversion = upstreamversion $clogp->{Version};
3399 if (madformat_wantfixup($format)) {
3400 # user might have not used dgit build, so maybe do this now:
3401 if (quiltmode_splitbrain()) {
3403 quilt_make_fake_dsc($upstreamversion);
3405 ($dgithead, $cachekey) =
3406 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3408 "--quilt=$quilt_mode but no cached dgit view:
3409 perhaps tree changed since dgit build[-source] ?";
3411 $dgithead = splitbrain_pseudomerge($clogp,
3412 $actualhead, $dgithead,
3414 $maintviewhead = $actualhead;
3415 changedir '../../../..';
3416 prep_ud(); # so _only_subdir() works, below
3418 commit_quilty_patch();
3422 if (defined $overwrite_version && !defined $maintviewhead) {
3423 $dgithead = plain_overwrite_pseudomerge($clogp,
3431 if ($archive_hash) {
3432 if (is_fast_fwd($archive_hash, $dgithead)) {
3434 } elsif (deliberately_not_fast_forward) {
3437 fail "dgit push: HEAD is not a descendant".
3438 " of the archive's version.\n".
3439 "To overwrite the archive's contents,".
3440 " pass --overwrite[=VERSION].\n".
3441 "To rewind history, if permitted by the archive,".
3442 " use --deliberately-not-fast-forward.";
3447 progress "checking that $dscfn corresponds to HEAD";
3448 runcmd qw(dpkg-source -x --),
3449 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3450 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3451 check_for_vendor_patches() if madformat($dsc->{format});
3452 changedir '../../../..';
3453 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3454 debugcmd "+",@diffcmd;
3456 my $r = system @diffcmd;
3459 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3461 HEAD specifies a different tree to $dscfn:
3463 Perhaps you forgot to build. Or perhaps there is a problem with your
3464 source tree (see dgit(7) for some hints). To see a full diff, run
3471 if (!$changesfile) {
3472 my $pat = changespat $cversion;
3473 my @cs = glob "$buildproductsdir/$pat";
3474 fail "failed to find unique changes file".
3475 " (looked for $pat in $buildproductsdir);".
3476 " perhaps you need to use dgit -C"
3478 ($changesfile) = @cs;
3480 $changesfile = "$buildproductsdir/$changesfile";
3483 # Check that changes and .dsc agree enough
3484 $changesfile =~ m{[^/]*$};
3485 my $changes = parsecontrol($changesfile,$&);
3486 files_compare_inputs($dsc, $changes)
3487 unless forceing [qw(dsc-changes-mismatch)];
3489 # Perhaps adjust .dsc to contain right set of origs
3490 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3492 unless forceing [qw(changes-origs-exactly)];
3494 # Checks complete, we're going to try and go ahead:
3496 responder_send_file('changes',$changesfile);
3497 responder_send_command("param head $dgithead");
3498 responder_send_command("param csuite $csuite");
3499 responder_send_command("param tagformat $tagformat");
3500 if (defined $maintviewhead) {
3501 die unless ($protovsn//4) >= 4;
3502 responder_send_command("param maint-view $maintviewhead");
3505 if (deliberately_not_fast_forward) {
3506 git_for_each_ref(lrfetchrefs, sub {
3507 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3508 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3509 responder_send_command("previously $rrefname=$objid");
3510 $previously{$rrefname} = $objid;
3514 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3518 supplementary_message(<<'END');
3519 Push failed, while signing the tag.
3520 You can retry the push, after fixing the problem, if you like.
3522 # If we manage to sign but fail to record it anywhere, it's fine.
3523 if ($we_are_responder) {
3524 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3525 responder_receive_files('signed-tag', @tagobjfns);
3527 @tagobjfns = push_mktags($clogp,$dscpath,
3528 $changesfile,$changesfile,
3531 supplementary_message(<<'END');
3532 Push failed, *after* signing the tag.
3533 If you want to try again, you should use a new version number.
3536 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3538 foreach my $tw (@tagwants) {
3539 my $tag = $tw->{Tag};
3540 my $tagobjfn = $tw->{TagObjFn};
3542 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3543 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3544 runcmd_ordryrun_local
3545 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3548 supplementary_message(<<'END');
3549 Push failed, while updating the remote git repository - see messages above.
3550 If you want to try again, you should use a new version number.
3552 if (!check_for_git()) {
3553 create_remote_git_repo();
3556 my @pushrefs = $forceflag.$dgithead.":".rrref();
3557 foreach my $tw (@tagwants) {
3558 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3561 runcmd_ordryrun @git,
3562 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3563 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3565 supplementary_message(<<'END');
3566 Push failed, after updating the remote git repository.
3567 If you want to try again, you must use a new version number.
3569 if ($we_are_responder) {
3570 my $dryrunsuffix = act_local() ? "" : ".tmp";
3571 responder_receive_files('signed-dsc-changes',
3572 "$dscpath$dryrunsuffix",
3573 "$changesfile$dryrunsuffix");
3576 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3578 progress "[new .dsc left in $dscpath.tmp]";
3580 sign_changes $changesfile;
3583 supplementary_message(<<END);
3584 Push failed, while uploading package(s) to the archive server.
3585 You can retry the upload of exactly these same files with dput of:
3587 If that .changes file is broken, you will need to use a new version
3588 number for your next attempt at the upload.
3590 my $host = access_cfg('upload-host','RETURN-UNDEF');
3591 my @hostarg = defined($host) ? ($host,) : ();
3592 runcmd_ordryrun @dput, @hostarg, $changesfile;
3593 printdone "pushed and uploaded $cversion";
3595 supplementary_message('');
3596 responder_send_command("complete");
3603 badusage "-p is not allowed with clone; specify as argument instead"
3604 if defined $package;
3607 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3608 ($package,$isuite) = @ARGV;
3609 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3610 ($package,$dstdir) = @ARGV;
3611 } elsif (@ARGV==3) {
3612 ($package,$isuite,$dstdir) = @ARGV;
3614 badusage "incorrect arguments to dgit clone";
3616 $dstdir ||= "$package";
3618 if (stat_exists $dstdir) {
3619 fail "$dstdir already exists";
3623 if ($rmonerror && !$dryrun_level) {
3624 $cwd_remove= getcwd();
3626 return unless defined $cwd_remove;
3627 if (!chdir "$cwd_remove") {
3628 return if $!==&ENOENT;
3629 die "chdir $cwd_remove: $!";
3632 rmtree($dstdir) or die "remove $dstdir: $!\n";
3633 } elsif (grep { $! == $_ }
3634 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3636 print STDERR "check whether to remove $dstdir: $!\n";
3642 $cwd_remove = undef;
3645 sub branchsuite () {
3646 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3647 if ($branch =~ m#$lbranch_re#o) {
3654 sub fetchpullargs () {
3656 if (!defined $package) {
3657 my $sourcep = parsecontrol('debian/control','debian/control');
3658 $package = getfield $sourcep, 'Source';
3661 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3663 my $clogp = parsechangelog();
3664 $isuite = getfield $clogp, 'Distribution';
3666 canonicalise_suite();
3667 progress "fetching from suite $csuite";
3668 } elsif (@ARGV==1) {
3670 canonicalise_suite();
3672 badusage "incorrect arguments to dgit fetch or dgit pull";
3685 if (quiltmode_splitbrain()) {
3686 my ($format, $fopts) = get_source_format();
3687 madformat($format) and fail <<END
3688 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3697 badusage "-p is not allowed with dgit push" if defined $package;
3699 my $clogp = parsechangelog();
3700 $package = getfield $clogp, 'Source';
3703 } elsif (@ARGV==1) {
3704 ($specsuite) = (@ARGV);
3706 badusage "incorrect arguments to dgit push";
3708 $isuite = getfield $clogp, 'Distribution';
3710 local ($package) = $existing_package; # this is a hack
3711 canonicalise_suite();
3713 canonicalise_suite();
3715 if (defined $specsuite &&
3716 $specsuite ne $isuite &&
3717 $specsuite ne $csuite) {
3718 fail "dgit push: changelog specifies $isuite ($csuite)".
3719 " but command line specifies $specsuite";
3724 #---------- remote commands' implementation ----------
3726 sub cmd_remote_push_build_host {
3727 my ($nrargs) = shift @ARGV;
3728 my (@rargs) = @ARGV[0..$nrargs-1];
3729 @ARGV = @ARGV[$nrargs..$#ARGV];
3731 my ($dir,$vsnwant) = @rargs;
3732 # vsnwant is a comma-separated list; we report which we have
3733 # chosen in our ready response (so other end can tell if they
3736 $we_are_responder = 1;
3737 $us .= " (build host)";
3741 open PI, "<&STDIN" or die $!;
3742 open STDIN, "/dev/null" or die $!;
3743 open PO, ">&STDOUT" or die $!;
3745 open STDOUT, ">&STDERR" or die $!;
3749 ($protovsn) = grep {
3750 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3751 } @rpushprotovsn_support;
3753 fail "build host has dgit rpush protocol versions ".
3754 (join ",", @rpushprotovsn_support).
3755 " but invocation host has $vsnwant"
3756 unless defined $protovsn;
3758 responder_send_command("dgit-remote-push-ready $protovsn");
3759 rpush_handle_protovsn_bothends();
3764 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3765 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3766 # a good error message)
3768 sub rpush_handle_protovsn_bothends () {
3769 if ($protovsn < 4) {
3770 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3779 my $report = i_child_report();
3780 if (defined $report) {
3781 printdebug "($report)\n";
3782 } elsif ($i_child_pid) {
3783 printdebug "(killing build host child $i_child_pid)\n";
3784 kill 15, $i_child_pid;
3786 if (defined $i_tmp && !defined $initiator_tempdir) {
3788 eval { rmtree $i_tmp; };
3792 END { i_cleanup(); }
3795 my ($base,$selector,@args) = @_;
3796 $selector =~ s/\-/_/g;
3797 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3804 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3812 push @rargs, join ",", @rpushprotovsn_support;
3815 push @rdgit, @ropts;
3816 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3818 my @cmd = (@ssh, $host, shellquote @rdgit);
3821 if (defined $initiator_tempdir) {
3822 rmtree $initiator_tempdir;
3823 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3824 $i_tmp = $initiator_tempdir;
3828 $i_child_pid = open2(\*RO, \*RI, @cmd);
3830 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3831 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3832 $supplementary_message = '' unless $protovsn >= 3;
3834 fail "rpush negotiated protocol version $protovsn".
3835 " which does not support quilt mode $quilt_mode"
3836 if quiltmode_splitbrain;
3838 rpush_handle_protovsn_bothends();
3840 my ($icmd,$iargs) = initiator_expect {
3841 m/^(\S+)(?: (.*))?$/;
3844 i_method "i_resp", $icmd, $iargs;
3848 sub i_resp_progress ($) {
3850 my $msg = protocol_read_bytes \*RO, $rhs;
3854 sub i_resp_supplementary_message ($) {
3856 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3859 sub i_resp_complete {
3860 my $pid = $i_child_pid;
3861 $i_child_pid = undef; # prevents killing some other process with same pid
3862 printdebug "waiting for build host child $pid...\n";
3863 my $got = waitpid $pid, 0;
3864 die $! unless $got == $pid;
3865 die "build host child failed $?" if $?;
3868 printdebug "all done\n";
3872 sub i_resp_file ($) {
3874 my $localname = i_method "i_localname", $keyword;
3875 my $localpath = "$i_tmp/$localname";
3876 stat_exists $localpath and
3877 badproto \*RO, "file $keyword ($localpath) twice";
3878 protocol_receive_file \*RO, $localpath;
3879 i_method "i_file", $keyword;
3884 sub i_resp_param ($) {
3885 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3889 sub i_resp_previously ($) {
3890 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3891 or badproto \*RO, "bad previously spec";
3892 my $r = system qw(git check-ref-format), $1;
3893 die "bad previously ref spec ($r)" if $r;
3894 $previously{$1} = $2;
3899 sub i_resp_want ($) {
3901 die "$keyword ?" if $i_wanted{$keyword}++;
3902 my @localpaths = i_method "i_want", $keyword;
3903 printdebug "[[ $keyword @localpaths\n";
3904 foreach my $localpath (@localpaths) {
3905 protocol_send_file \*RI, $localpath;
3907 print RI "files-end\n" or die $!;
3910 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3912 sub i_localname_parsed_changelog {
3913 return "remote-changelog.822";
3915 sub i_file_parsed_changelog {
3916 ($i_clogp, $i_version, $i_dscfn) =
3917 push_parse_changelog "$i_tmp/remote-changelog.822";
3918 die if $i_dscfn =~ m#/|^\W#;
3921 sub i_localname_dsc {
3922 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3927 sub i_localname_changes {
3928 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3929 $i_changesfn = $i_dscfn;
3930 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3931 return $i_changesfn;
3933 sub i_file_changes { }
3935 sub i_want_signed_tag {
3936 printdebug Dumper(\%i_param, $i_dscfn);
3937 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3938 && defined $i_param{'csuite'}
3939 or badproto \*RO, "premature desire for signed-tag";
3940 my $head = $i_param{'head'};
3941 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3943 my $maintview = $i_param{'maint-view'};
3944 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3947 if ($protovsn >= 4) {
3948 my $p = $i_param{'tagformat'} // '<undef>';
3950 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3953 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3955 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3957 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3960 push_mktags $i_clogp, $i_dscfn,
3961 $i_changesfn, 'remote changes',
3965 sub i_want_signed_dsc_changes {
3966 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3967 sign_changes $i_changesfn;
3968 return ($i_dscfn, $i_changesfn);
3971 #---------- building etc. ----------
3977 #----- `3.0 (quilt)' handling -----
3979 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3981 sub quiltify_dpkg_commit ($$$;$) {
3982 my ($patchname,$author,$msg, $xinfo) = @_;
3986 my $descfn = ".git/dgit/quilt-description.tmp";
3987 open O, '>', $descfn or die "$descfn: $!";
3988 $msg =~ s/\n+/\n\n/;
3989 print O <<END or die $!;
3991 ${xinfo}Subject: $msg
3998 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3999 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4000 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4001 runcmd @dpkgsource, qw(--commit .), $patchname;
4005 sub quiltify_trees_differ ($$;$$$) {
4006 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4007 # returns true iff the two tree objects differ other than in debian/
4008 # with $finegrained,
4009 # returns bitmask 01 - differ in upstream files except .gitignore
4010 # 02 - differ in .gitignore
4011 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4012 # is set for each modified .gitignore filename $fn
4013 # if $unrepres is defined, array ref to which is appeneded
4014 # a list of unrepresentable changes (removals of upstream files
4017 my @cmd = (@git, qw(diff-tree -z));
4018 push @cmd, qw(--name-only) unless $unrepres;
4019 push @cmd, qw(-r) if $finegrained || $unrepres;
4021 my $diffs= cmdoutput @cmd;
4024 foreach my $f (split /\0/, $diffs) {
4025 if ($unrepres && !@lmodes) {
4026 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4029 my ($oldmode,$newmode) = @lmodes;
4032 next if $f =~ m#^debian(?:/.*)?$#s;
4036 die "deleted\n" unless $newmode =~ m/[^0]/;
4037 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4038 if ($oldmode =~ m/[^0]/) {
4039 die "mode changed\n" if $oldmode ne $newmode;
4041 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4045 local $/="\n"; chomp $@;
4046 push @$unrepres, [ $f, $@ ];
4050 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4051 $r |= $isignore ? 02 : 01;
4052 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4054 printdebug "quiltify_trees_differ $x $y => $r\n";
4058 sub quiltify_tree_sentinelfiles ($) {
4059 # lists the `sentinel' files present in the tree
4061 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4062 qw(-- debian/rules debian/control);
4067 sub quiltify_splitbrain_needed () {
4068 if (!$split_brain) {
4069 progress "dgit view: changes are required...";
4070 runcmd @git, qw(checkout -q -b dgit-view);
4075 sub quiltify_splitbrain ($$$$$$) {
4076 my ($clogp, $unapplied, $headref, $diffbits,
4077 $editedignores, $cachekey) = @_;
4078 if ($quilt_mode !~ m/gbp|dpm/) {
4079 # treat .gitignore just like any other upstream file
4080 $diffbits = { %$diffbits };
4081 $_ = !!$_ foreach values %$diffbits;
4083 # We would like any commits we generate to be reproducible
4084 my @authline = clogp_authline($clogp);
4085 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4086 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4087 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4088 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4089 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4090 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4092 if ($quilt_mode =~ m/gbp|unapplied/ &&
4093 ($diffbits->{O2H} & 01)) {
4095 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4096 " but git tree differs from orig in upstream files.";
4097 if (!stat_exists "debian/patches") {
4099 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4103 if ($quilt_mode =~ m/dpm/ &&
4104 ($diffbits->{H2A} & 01)) {
4106 --quilt=$quilt_mode specified, implying patches-applied git tree
4107 but git tree differs from result of applying debian/patches to upstream
4110 if ($quilt_mode =~ m/gbp|unapplied/ &&
4111 ($diffbits->{O2A} & 01)) { # some patches
4112 quiltify_splitbrain_needed();
4113 progress "dgit view: creating patches-applied version using gbp pq";
4114 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4115 # gbp pq import creates a fresh branch; push back to dgit-view
4116 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4117 runcmd @git, qw(checkout -q dgit-view);
4119 if ($quilt_mode =~ m/gbp|dpm/ &&
4120 ($diffbits->{O2A} & 02)) {
4122 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4123 tool which does not create patches for changes to upstream
4124 .gitignores: but, such patches exist in debian/patches.
4127 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4128 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4129 quiltify_splitbrain_needed();
4130 progress "dgit view: creating patch to represent .gitignore changes";
4131 ensuredir "debian/patches";
4132 my $gipatch = "debian/patches/auto-gitignore";
4133 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4134 stat GIPATCH or die "$gipatch: $!";
4135 fail "$gipatch already exists; but want to create it".
4136 " to record .gitignore changes" if (stat _)[7];
4137 print GIPATCH <<END or die "$gipatch: $!";
4138 Subject: Update .gitignore from Debian packaging branch
4140 The Debian packaging git branch contains these updates to the upstream
4141 .gitignore file(s). This patch is autogenerated, to provide these
4142 updates to users of the official Debian archive view of the package.
4144 [dgit ($our_version) update-gitignore]
4147 close GIPATCH or die "$gipatch: $!";
4148 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4149 $unapplied, $headref, "--", sort keys %$editedignores;
4150 open SERIES, "+>>", "debian/patches/series" or die $!;
4151 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4153 defined read SERIES, $newline, 1 or die $!;
4154 print SERIES "\n" or die $! unless $newline eq "\n";
4155 print SERIES "auto-gitignore\n" or die $!;
4156 close SERIES or die $!;
4157 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4159 Commit patch to update .gitignore
4161 [dgit ($our_version) update-gitignore-quilt-fixup]
4165 my $dgitview = git_rev_parse 'HEAD';
4167 changedir '../../../..';
4168 # When we no longer need to support squeeze, use --create-reflog
4170 ensuredir ".git/logs/refs/dgit-intern";
4171 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4174 my $oldcache = git_get_ref "refs/$splitbraincache";
4175 if ($oldcache eq $dgitview) {
4176 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4177 # git update-ref doesn't always update, in this case. *sigh*
4178 my $dummy = make_commit_text <<END;
4181 author Dgit <dgit\@example.com> 1000000000 +0000
4182 committer Dgit <dgit\@example.com> 1000000000 +0000
4184 Dummy commit - do not use
4186 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4187 "refs/$splitbraincache", $dummy;
4189 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4192 changedir '.git/dgit/unpack/work';
4194 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4195 progress "dgit view: created ($saved)";
4198 sub quiltify ($$$$) {
4199 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4201 # Quilt patchification algorithm
4203 # We search backwards through the history of the main tree's HEAD
4204 # (T) looking for a start commit S whose tree object is identical
4205 # to to the patch tip tree (ie the tree corresponding to the
4206 # current dpkg-committed patch series). For these purposes
4207 # `identical' disregards anything in debian/ - this wrinkle is
4208 # necessary because dpkg-source treates debian/ specially.
4210 # We can only traverse edges where at most one of the ancestors'
4211 # trees differs (in changes outside in debian/). And we cannot
4212 # handle edges which change .pc/ or debian/patches. To avoid
4213 # going down a rathole we avoid traversing edges which introduce
4214 # debian/rules or debian/control. And we set a limit on the
4215 # number of edges we are willing to look at.
4217 # If we succeed, we walk forwards again. For each traversed edge
4218 # PC (with P parent, C child) (starting with P=S and ending with
4219 # C=T) to we do this:
4221 # - dpkg-source --commit with a patch name and message derived from C
4222 # After traversing PT, we git commit the changes which
4223 # should be contained within debian/patches.
4225 # The search for the path S..T is breadth-first. We maintain a
4226 # todo list containing search nodes. A search node identifies a
4227 # commit, and looks something like this:
4229 # Commit => $git_commit_id,
4230 # Child => $c, # or undef if P=T
4231 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4232 # Nontrivial => true iff $p..$c has relevant changes
4239 my %considered; # saves being exponential on some weird graphs
4241 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4244 my ($search,$whynot) = @_;
4245 printdebug " search NOT $search->{Commit} $whynot\n";
4246 $search->{Whynot} = $whynot;
4247 push @nots, $search;
4248 no warnings qw(exiting);
4257 my $c = shift @todo;
4258 next if $considered{$c->{Commit}}++;
4260 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4262 printdebug "quiltify investigate $c->{Commit}\n";
4265 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4266 printdebug " search finished hooray!\n";
4271 if ($quilt_mode eq 'nofix') {
4272 fail "quilt fixup required but quilt mode is \`nofix'\n".
4273 "HEAD commit $c->{Commit} differs from tree implied by ".
4274 " debian/patches (tree object $oldtiptree)";
4276 if ($quilt_mode eq 'smash') {
4277 printdebug " search quitting smash\n";
4281 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4282 $not->($c, "has $c_sentinels not $t_sentinels")
4283 if $c_sentinels ne $t_sentinels;
4285 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4286 $commitdata =~ m/\n\n/;
4288 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4289 @parents = map { { Commit => $_, Child => $c } } @parents;
4291 $not->($c, "root commit") if !@parents;
4293 foreach my $p (@parents) {
4294 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4296 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4297 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4299 foreach my $p (@parents) {
4300 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4302 my @cmd= (@git, qw(diff-tree -r --name-only),
4303 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4304 my $patchstackchange = cmdoutput @cmd;
4305 if (length $patchstackchange) {
4306 $patchstackchange =~ s/\n/,/g;
4307 $not->($p, "changed $patchstackchange");
4310 printdebug " search queue P=$p->{Commit} ",
4311 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4317 printdebug "quiltify want to smash\n";
4320 my $x = $_[0]{Commit};
4321 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4324 my $reportnot = sub {
4326 my $s = $abbrev->($notp);
4327 my $c = $notp->{Child};
4328 $s .= "..".$abbrev->($c) if $c;
4329 $s .= ": ".$notp->{Whynot};
4332 if ($quilt_mode eq 'linear') {
4333 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4334 foreach my $notp (@nots) {
4335 print STDERR "$us: ", $reportnot->($notp), "\n";
4337 print STDERR "$us: $_\n" foreach @$failsuggestion;
4338 fail "quilt fixup naive history linearisation failed.\n".
4339 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4340 } elsif ($quilt_mode eq 'smash') {
4341 } elsif ($quilt_mode eq 'auto') {
4342 progress "quilt fixup cannot be linear, smashing...";
4344 die "$quilt_mode ?";
4347 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4348 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4350 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4352 quiltify_dpkg_commit "auto-$version-$target-$time",
4353 (getfield $clogp, 'Maintainer'),
4354 "Automatically generated patch ($clogp->{Version})\n".
4355 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4359 progress "quiltify linearisation planning successful, executing...";
4361 for (my $p = $sref_S;
4362 my $c = $p->{Child};
4364 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4365 next unless $p->{Nontrivial};
4367 my $cc = $c->{Commit};
4369 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4370 $commitdata =~ m/\n\n/ or die "$c ?";
4373 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4376 my $commitdate = cmdoutput
4377 @git, qw(log -n1 --pretty=format:%aD), $cc;
4379 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4381 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4388 my $gbp_check_suitable = sub {
4393 die "contains unexpected slashes\n" if m{//} || m{/$};
4394 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4395 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4396 die "too long" if length > 200;
4398 return $_ unless $@;
4399 print STDERR "quiltifying commit $cc:".
4400 " ignoring/dropping Gbp-Pq $what: $@";
4404 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4406 (\S+) \s* \n //ixm) {
4407 $patchname = $gbp_check_suitable->($1, 'Name');
4409 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4411 (\S+) \s* \n //ixm) {
4412 $patchdir = $gbp_check_suitable->($1, 'Topic');
4417 if (!defined $patchname) {
4418 $patchname = $title;
4419 $patchname =~ s/[.:]$//;
4422 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4423 my $translitname = $converter->convert($patchname);
4424 die unless defined $translitname;
4425 $patchname = $translitname;
4428 "dgit: patch title transliteration error: $@"
4430 $patchname =~ y/ A-Z/-a-z/;
4431 $patchname =~ y/-a-z0-9_.+=~//cd;
4432 $patchname =~ s/^\W/x-$&/;
4433 $patchname = substr($patchname,0,40);
4435 if (!defined $patchdir) {
4438 if (length $patchdir) {
4439 $patchname = "$patchdir/$patchname";
4441 if ($patchname =~ m{^(.*)/}) {
4442 mkpath "debian/patches/$1";
4447 stat "debian/patches/$patchname$index";
4449 $!==ENOENT or die "$patchname$index $!";
4451 runcmd @git, qw(checkout -q), $cc;
4453 # We use the tip's changelog so that dpkg-source doesn't
4454 # produce complaining messages from dpkg-parsechangelog. None
4455 # of the information dpkg-source gets from the changelog is
4456 # actually relevant - it gets put into the original message
4457 # which dpkg-source provides our stunt editor, and then
4459 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4461 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4462 "Date: $commitdate\n".
4463 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4465 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4468 runcmd @git, qw(checkout -q master);
4471 sub build_maybe_quilt_fixup () {
4472 my ($format,$fopts) = get_source_format;
4473 return unless madformat_wantfixup $format;
4476 check_for_vendor_patches();
4478 if (quiltmode_splitbrain) {
4479 foreach my $needtf (qw(new maint)) {
4480 next if grep { $_ eq $needtf } access_cfg_tagformats;
4482 quilt mode $quilt_mode requires split view so server needs to support
4483 both "new" and "maint" tag formats, but config says it doesn't.
4488 my $clogp = parsechangelog();
4489 my $headref = git_rev_parse('HEAD');
4494 my $upstreamversion = upstreamversion $version;
4496 if ($fopts->{'single-debian-patch'}) {
4497 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4499 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4502 die 'bug' if $split_brain && !$need_split_build_invocation;
4504 changedir '../../../..';
4505 runcmd_ordryrun_local
4506 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4509 sub quilt_fixup_mkwork ($) {
4512 mkdir "work" or die $!;
4514 mktree_in_ud_here();
4515 runcmd @git, qw(reset -q --hard), $headref;
4518 sub quilt_fixup_linkorigs ($$) {
4519 my ($upstreamversion, $fn) = @_;
4520 # calls $fn->($leafname);
4522 foreach my $f (<../../../../*>) { #/){
4523 my $b=$f; $b =~ s{.*/}{};
4525 local ($debuglevel) = $debuglevel-1;
4526 printdebug "QF linkorigs $b, $f ?\n";
4528 next unless is_orig_file_of_vsn $b, $upstreamversion;
4529 printdebug "QF linkorigs $b, $f Y\n";
4530 link_ltarget $f, $b or die "$b $!";
4535 sub quilt_fixup_delete_pc () {
4536 runcmd @git, qw(rm -rqf .pc);
4538 Commit removal of .pc (quilt series tracking data)
4540 [dgit ($our_version) upgrade quilt-remove-pc]
4544 sub quilt_fixup_singlepatch ($$$) {
4545 my ($clogp, $headref, $upstreamversion) = @_;
4547 progress "starting quiltify (single-debian-patch)";
4549 # dpkg-source --commit generates new patches even if
4550 # single-debian-patch is in debian/source/options. In order to
4551 # get it to generate debian/patches/debian-changes, it is
4552 # necessary to build the source package.
4554 quilt_fixup_linkorigs($upstreamversion, sub { });
4555 quilt_fixup_mkwork($headref);
4557 rmtree("debian/patches");
4559 runcmd @dpkgsource, qw(-b .);
4561 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4562 rename srcfn("$upstreamversion", "/debian/patches"),
4563 "work/debian/patches";
4566 commit_quilty_patch();
4569 sub quilt_make_fake_dsc ($) {
4570 my ($upstreamversion) = @_;
4572 my $fakeversion="$upstreamversion-~~DGITFAKE";
4574 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4575 print $fakedsc <<END or die $!;
4578 Version: $fakeversion
4582 my $dscaddfile=sub {
4585 my $md = new Digest::MD5;
4587 my $fh = new IO::File $b, '<' or die "$b $!";
4592 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4595 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4597 my @files=qw(debian/source/format debian/rules
4598 debian/control debian/changelog);
4599 foreach my $maybe (qw(debian/patches debian/source/options
4600 debian/tests/control)) {
4601 next unless stat_exists "../../../$maybe";
4602 push @files, $maybe;
4605 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4606 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4608 $dscaddfile->($debtar);
4609 close $fakedsc or die $!;
4612 sub quilt_check_splitbrain_cache ($$) {
4613 my ($headref, $upstreamversion) = @_;
4614 # Called only if we are in (potentially) split brain mode.
4616 # Computes the cache key and looks in the cache.
4617 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4619 my $splitbrain_cachekey;
4622 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4623 # we look in the reflog of dgit-intern/quilt-cache
4624 # we look for an entry whose message is the key for the cache lookup
4625 my @cachekey = (qw(dgit), $our_version);
4626 push @cachekey, $upstreamversion;
4627 push @cachekey, $quilt_mode;
4628 push @cachekey, $headref;
4630 push @cachekey, hashfile('fake.dsc');
4632 my $srcshash = Digest::SHA->new(256);
4633 my %sfs = ( %INC, '$0(dgit)' => $0 );
4634 foreach my $sfk (sort keys %sfs) {
4635 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4636 $srcshash->add($sfk," ");
4637 $srcshash->add(hashfile($sfs{$sfk}));
4638 $srcshash->add("\n");
4640 push @cachekey, $srcshash->hexdigest();
4641 $splitbrain_cachekey = "@cachekey";
4643 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4645 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4646 debugcmd "|(probably)",@cmd;
4647 my $child = open GC, "-|"; defined $child or die $!;
4649 chdir '../../..' or die $!;
4650 if (!stat ".git/logs/refs/$splitbraincache") {
4651 $! == ENOENT or die $!;
4652 printdebug ">(no reflog)\n";
4659 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4660 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4663 quilt_fixup_mkwork($headref);
4664 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4665 if ($cachehit ne $headref) {
4666 progress "dgit view: found cached ($saved)";
4667 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4669 return ($cachehit, $splitbrain_cachekey);
4671 progress "dgit view: found cached, no changes required";
4672 return ($headref, $splitbrain_cachekey);
4674 die $! if GC->error;
4675 failedcmd unless close GC;
4677 printdebug "splitbrain cache miss\n";
4678 return (undef, $splitbrain_cachekey);
4681 sub quilt_fixup_multipatch ($$$) {
4682 my ($clogp, $headref, $upstreamversion) = @_;
4684 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4687 # - honour any existing .pc in case it has any strangeness
4688 # - determine the git commit corresponding to the tip of
4689 # the patch stack (if there is one)
4690 # - if there is such a git commit, convert each subsequent
4691 # git commit into a quilt patch with dpkg-source --commit
4692 # - otherwise convert all the differences in the tree into
4693 # a single git commit
4697 # Our git tree doesn't necessarily contain .pc. (Some versions of
4698 # dgit would include the .pc in the git tree.) If there isn't
4699 # one, we need to generate one by unpacking the patches that we
4702 # We first look for a .pc in the git tree. If there is one, we
4703 # will use it. (This is not the normal case.)
4705 # Otherwise need to regenerate .pc so that dpkg-source --commit
4706 # can work. We do this as follows:
4707 # 1. Collect all relevant .orig from parent directory
4708 # 2. Generate a debian.tar.gz out of
4709 # debian/{patches,rules,source/format,source/options}
4710 # 3. Generate a fake .dsc containing just these fields:
4711 # Format Source Version Files
4712 # 4. Extract the fake .dsc
4713 # Now the fake .dsc has a .pc directory.
4714 # (In fact we do this in every case, because in future we will
4715 # want to search for a good base commit for generating patches.)
4717 # Then we can actually do the dpkg-source --commit
4718 # 1. Make a new working tree with the same object
4719 # store as our main tree and check out the main
4721 # 2. Copy .pc from the fake's extraction, if necessary
4722 # 3. Run dpkg-source --commit
4723 # 4. If the result has changes to debian/, then
4724 # - git add them them
4725 # - git add .pc if we had a .pc in-tree
4727 # 5. If we had a .pc in-tree, delete it, and git commit
4728 # 6. Back in the main tree, fast forward to the new HEAD
4730 # Another situation we may have to cope with is gbp-style
4731 # patches-unapplied trees.
4733 # We would want to detect these, so we know to escape into
4734 # quilt_fixup_gbp. However, this is in general not possible.
4735 # Consider a package with a one patch which the dgit user reverts
4736 # (with git revert or the moral equivalent).
4738 # That is indistinguishable in contents from a patches-unapplied
4739 # tree. And looking at the history to distinguish them is not
4740 # useful because the user might have made a confusing-looking git
4741 # history structure (which ought to produce an error if dgit can't
4742 # cope, not a silent reintroduction of an unwanted patch).
4744 # So gbp users will have to pass an option. But we can usually
4745 # detect their failure to do so: if the tree is not a clean
4746 # patches-applied tree, quilt linearisation fails, but the tree
4747 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4748 # they want --quilt=unapplied.
4750 # To help detect this, when we are extracting the fake dsc, we
4751 # first extract it with --skip-patches, and then apply the patches
4752 # afterwards with dpkg-source --before-build. That lets us save a
4753 # tree object corresponding to .origs.
4755 my $splitbrain_cachekey;
4757 quilt_make_fake_dsc($upstreamversion);
4759 if (quiltmode_splitbrain()) {
4761 ($cachehit, $splitbrain_cachekey) =
4762 quilt_check_splitbrain_cache($headref, $upstreamversion);
4763 return if $cachehit;
4767 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4769 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4770 rename $fakexdir, "fake" or die "$fakexdir $!";
4774 remove_stray_gits();
4775 mktree_in_ud_here();
4779 runcmd @git, qw(add -Af .);
4780 my $unapplied=git_write_tree();
4781 printdebug "fake orig tree object $unapplied\n";
4785 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4787 if (system @bbcmd) {
4788 failedcmd @bbcmd if $? < 0;
4790 failed to apply your git tree's patch stack (from debian/patches/) to
4791 the corresponding upstream tarball(s). Your source tree and .orig
4792 are probably too inconsistent. dgit can only fix up certain kinds of
4793 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4799 quilt_fixup_mkwork($headref);
4802 if (stat_exists ".pc") {
4804 progress "Tree already contains .pc - will use it then delete it.";
4807 rename '../fake/.pc','.pc' or die $!;
4810 changedir '../fake';
4812 runcmd @git, qw(add -Af .);
4813 my $oldtiptree=git_write_tree();
4814 printdebug "fake o+d/p tree object $unapplied\n";
4815 changedir '../work';
4818 # We calculate some guesswork now about what kind of tree this might
4819 # be. This is mostly for error reporting.
4825 # O = orig, without patches applied
4826 # A = "applied", ie orig with H's debian/patches applied
4827 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4828 \%editedignores, \@unrepres),
4829 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4830 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4834 foreach my $b (qw(01 02)) {
4835 foreach my $v (qw(O2H O2A H2A)) {
4836 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4839 printdebug "differences \@dl @dl.\n";
4842 "$us: base trees orig=%.20s o+d/p=%.20s",
4843 $unapplied, $oldtiptree;
4845 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4846 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4847 $dl[0], $dl[1], $dl[3], $dl[4],
4851 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4853 forceable_fail [qw(unrepresentable)], <<END;
4854 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4859 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4860 push @failsuggestion, "This might be a patches-unapplied branch.";
4861 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4862 push @failsuggestion, "This might be a patches-applied branch.";
4864 push @failsuggestion, "Maybe you need to specify one of".
4865 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4867 if (quiltmode_splitbrain()) {
4868 quiltify_splitbrain($clogp, $unapplied, $headref,
4869 $diffbits, \%editedignores,
4870 $splitbrain_cachekey);
4874 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4875 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4877 if (!open P, '>>', ".pc/applied-patches") {
4878 $!==&ENOENT or die $!;
4883 commit_quilty_patch();
4885 if ($mustdeletepc) {
4886 quilt_fixup_delete_pc();
4890 sub quilt_fixup_editor () {
4891 my $descfn = $ENV{$fakeeditorenv};
4892 my $editing = $ARGV[$#ARGV];
4893 open I1, '<', $descfn or die "$descfn: $!";
4894 open I2, '<', $editing or die "$editing: $!";
4895 unlink $editing or die "$editing: $!";
4896 open O, '>', $editing or die "$editing: $!";
4897 while (<I1>) { print O or die $!; } I1->error and die $!;
4900 $copying ||= m/^\-\-\- /;
4901 next unless $copying;
4904 I2->error and die $!;
4909 sub maybe_apply_patches_dirtily () {
4910 return unless $quilt_mode =~ m/gbp|unapplied/;
4911 print STDERR <<END or die $!;
4913 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4914 dgit: Have to apply the patches - making the tree dirty.
4915 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4918 $patches_applied_dirtily = 01;
4919 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4920 runcmd qw(dpkg-source --before-build .);
4923 sub maybe_unapply_patches_again () {
4924 progress "dgit: Unapplying patches again to tidy up the tree."
4925 if $patches_applied_dirtily;
4926 runcmd qw(dpkg-source --after-build .)
4927 if $patches_applied_dirtily & 01;
4929 if $patches_applied_dirtily & 02;
4930 $patches_applied_dirtily = 0;
4933 #----- other building -----
4935 our $clean_using_builder;
4936 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4937 # clean the tree before building (perhaps invoked indirectly by
4938 # whatever we are using to run the build), rather than separately
4939 # and explicitly by us.
4942 return if $clean_using_builder;
4943 if ($cleanmode eq 'dpkg-source') {
4944 maybe_apply_patches_dirtily();
4945 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4946 } elsif ($cleanmode eq 'dpkg-source-d') {
4947 maybe_apply_patches_dirtily();
4948 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4949 } elsif ($cleanmode eq 'git') {
4950 runcmd_ordryrun_local @git, qw(clean -xdf);
4951 } elsif ($cleanmode eq 'git-ff') {
4952 runcmd_ordryrun_local @git, qw(clean -xdff);
4953 } elsif ($cleanmode eq 'check') {
4954 my $leftovers = cmdoutput @git, qw(clean -xdn);
4955 if (length $leftovers) {
4956 print STDERR $leftovers, "\n" or die $!;
4957 fail "tree contains uncommitted files and --clean=check specified";
4959 } elsif ($cleanmode eq 'none') {
4966 badusage "clean takes no additional arguments" if @ARGV;
4969 maybe_unapply_patches_again();
4972 sub build_prep_early () {
4973 our $build_prep_early_done //= 0;
4974 return if $build_prep_early_done++;
4976 badusage "-p is not allowed when building" if defined $package;
4977 my $clogp = parsechangelog();
4978 $isuite = getfield $clogp, 'Distribution';
4979 $package = getfield $clogp, 'Source';
4980 $version = getfield $clogp, 'Version';
4987 build_maybe_quilt_fixup();
4989 my $pat = changespat $version;
4990 foreach my $f (glob "$buildproductsdir/$pat") {
4992 unlink $f or fail "remove old changes file $f: $!";
4994 progress "would remove $f";
5000 sub changesopts_initial () {
5001 my @opts =@changesopts[1..$#changesopts];
5004 sub changesopts_version () {
5005 if (!defined $changes_since_version) {
5006 my @vsns = archive_query('archive_query');
5007 my @quirk = access_quirk();
5008 if ($quirk[0] eq 'backports') {
5009 local $isuite = $quirk[2];
5011 canonicalise_suite();
5012 push @vsns, archive_query('archive_query');
5015 @vsns = map { $_->[0] } @vsns;
5016 @vsns = sort { -version_compare($a, $b) } @vsns;
5017 $changes_since_version = $vsns[0];
5018 progress "changelog will contain changes since $vsns[0]";
5020 $changes_since_version = '_';
5021 progress "package seems new, not specifying -v<version>";
5024 if ($changes_since_version ne '_') {
5025 return ("-v$changes_since_version");
5031 sub changesopts () {
5032 return (changesopts_initial(), changesopts_version());
5035 sub massage_dbp_args ($;$) {
5036 my ($cmd,$xargs) = @_;
5039 # - if we're going to split the source build out so we can
5040 # do strange things to it, massage the arguments to dpkg-buildpackage
5041 # so that the main build doessn't build source (or add an argument
5042 # to stop it building source by default).
5044 # - add -nc to stop dpkg-source cleaning the source tree,
5045 # unless we're not doing a split build and want dpkg-source
5046 # as cleanmode, in which case we can do nothing
5049 # 0 - source will NOT need to be built separately by caller
5050 # +1 - source will need to be built separately by caller
5051 # +2 - source will need to be built separately by caller AND
5052 # dpkg-buildpackage should not in fact be run at all!
5053 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5054 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5055 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5056 $clean_using_builder = 1;
5059 # -nc has the side effect of specifying -b if nothing else specified
5060 # and some combinations of -S, -b, et al, are errors, rather than
5061 # later simply overriding earlie. So we need to:
5062 # - search the command line for these options
5063 # - pick the last one
5064 # - perhaps add our own as a default
5065 # - perhaps adjust it to the corresponding non-source-building version
5067 foreach my $l ($cmd, $xargs) {
5069 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5072 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5074 if ($need_split_build_invocation) {
5075 printdebug "massage split $dmode.\n";
5076 $r = $dmode =~ m/[S]/ ? +2 :
5077 $dmode =~ y/gGF/ABb/ ? +1 :
5078 $dmode =~ m/[ABb]/ ? 0 :
5081 printdebug "massage done $r $dmode.\n";
5083 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5089 my $wasdir = must_getcwd();
5095 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5096 my ($msg_if_onlyone) = @_;
5097 # If there is only one .changes file, fail with $msg_if_onlyone,
5098 # or if that is undef, be a no-op.
5099 # Returns the changes file to report to the user.
5100 my $pat = changespat $version;
5101 my @changesfiles = glob $pat;
5102 @changesfiles = sort {
5103 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5107 if (@changesfiles==1) {
5108 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5109 only one changes file from build (@changesfiles)
5111 $result = $changesfiles[0];
5112 } elsif (@changesfiles==2) {
5113 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5114 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5115 fail "$l found in binaries changes file $binchanges"
5118 runcmd_ordryrun_local @mergechanges, @changesfiles;
5119 my $multichanges = changespat $version,'multi';
5121 stat_exists $multichanges or fail "$multichanges: $!";
5122 foreach my $cf (glob $pat) {
5123 next if $cf eq $multichanges;
5124 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5127 $result = $multichanges;
5129 fail "wrong number of different changes files (@changesfiles)";
5131 printdone "build successful, results in $result\n" or die $!;
5134 sub midbuild_checkchanges () {
5135 my $pat = changespat $version;
5136 return if $rmchanges;
5137 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5138 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5140 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5141 Suggest you delete @unwanted.
5146 sub midbuild_checkchanges_vanilla ($) {
5148 midbuild_checkchanges() if $wantsrc == 1;
5151 sub postbuild_mergechanges_vanilla ($) {
5153 if ($wantsrc == 1) {
5155 postbuild_mergechanges(undef);
5158 printdone "build successful\n";
5163 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5164 my $wantsrc = massage_dbp_args \@dbp;
5167 midbuild_checkchanges_vanilla $wantsrc;
5172 push @dbp, changesopts_version();
5173 maybe_apply_patches_dirtily();
5174 runcmd_ordryrun_local @dbp;
5176 maybe_unapply_patches_again();
5177 postbuild_mergechanges_vanilla $wantsrc;
5181 $quilt_mode //= 'gbp';
5187 # gbp can make .origs out of thin air. In my tests it does this
5188 # even for a 1.0 format package, with no origs present. So I
5189 # guess it keys off just the version number. We don't know
5190 # exactly what .origs ought to exist, but let's assume that we
5191 # should run gbp if: the version has an upstream part and the main
5193 my $upstreamversion = upstreamversion $version;
5194 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5195 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5197 if ($gbp_make_orig) {
5199 $cleanmode = 'none'; # don't do it again
5200 $need_split_build_invocation = 1;
5203 my @dbp = @dpkgbuildpackage;
5205 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5207 if (!length $gbp_build[0]) {
5208 if (length executable_on_path('git-buildpackage')) {
5209 $gbp_build[0] = qw(git-buildpackage);
5211 $gbp_build[0] = 'gbp buildpackage';
5214 my @cmd = opts_opt_multi_cmd @gbp_build;
5216 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5218 if ($gbp_make_orig) {
5219 ensuredir '.git/dgit';
5220 my $ok = '.git/dgit/origs-gen-ok';
5221 unlink $ok or $!==&ENOENT or die $!;
5222 my @origs_cmd = @cmd;
5223 push @origs_cmd, qw(--git-cleaner=true);
5224 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5225 push @origs_cmd, @ARGV;
5227 debugcmd @origs_cmd;
5229 do { local $!; stat_exists $ok; }
5230 or failedcmd @origs_cmd;
5232 dryrun_report @origs_cmd;
5238 midbuild_checkchanges_vanilla $wantsrc;
5240 if (!$clean_using_builder) {
5241 push @cmd, '--git-cleaner=true';
5245 maybe_unapply_patches_again();
5247 push @cmd, changesopts();
5248 runcmd_ordryrun_local @cmd, @ARGV;
5250 postbuild_mergechanges_vanilla $wantsrc;
5252 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5255 my $our_cleanmode = $cleanmode;
5256 if ($need_split_build_invocation) {
5257 # Pretend that clean is being done some other way. This
5258 # forces us not to try to use dpkg-buildpackage to clean and
5259 # build source all in one go; and instead we run dpkg-source
5260 # (and build_prep() will do the clean since $clean_using_builder
5262 $our_cleanmode = 'ELSEWHERE';
5264 if ($our_cleanmode =~ m/^dpkg-source/) {
5265 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5266 $clean_using_builder = 1;
5269 $sourcechanges = changespat $version,'source';
5271 unlink "../$sourcechanges" or $!==ENOENT
5272 or fail "remove $sourcechanges: $!";
5274 $dscfn = dscfn($version);
5275 if ($our_cleanmode eq 'dpkg-source') {
5276 maybe_apply_patches_dirtily();
5277 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5279 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5280 maybe_apply_patches_dirtily();
5281 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5284 my @cmd = (@dpkgsource, qw(-b --));
5287 runcmd_ordryrun_local @cmd, "work";
5288 my @udfiles = <${package}_*>;
5289 changedir "../../..";
5290 foreach my $f (@udfiles) {
5291 printdebug "source copy, found $f\n";
5294 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5295 $f eq srcfn($version, $&));
5296 printdebug "source copy, found $f - renaming\n";
5297 rename "$ud/$f", "../$f" or $!==ENOENT
5298 or fail "put in place new source file ($f): $!";
5301 my $pwd = must_getcwd();
5302 my $leafdir = basename $pwd;
5304 runcmd_ordryrun_local @cmd, $leafdir;
5307 runcmd_ordryrun_local qw(sh -ec),
5308 'exec >$1; shift; exec "$@"','x',
5309 "../$sourcechanges",
5310 @dpkggenchanges, qw(-S), changesopts();
5314 sub cmd_build_source {
5315 badusage "build-source takes no additional arguments" if @ARGV;
5317 maybe_unapply_patches_again();
5318 printdone "source built, results in $dscfn and $sourcechanges";
5323 midbuild_checkchanges();
5326 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5327 stat_exists $sourcechanges
5328 or fail "$sourcechanges (in parent directory): $!";
5330 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5332 maybe_unapply_patches_again();
5334 postbuild_mergechanges(<<END);
5335 perhaps you need to pass -A ? (sbuild's default is to build only
5336 arch-specific binaries; dgit 1.4 used to override that.)
5341 sub cmd_quilt_fixup {
5342 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5343 my $clogp = parsechangelog();
5344 $version = getfield $clogp, 'Version';
5345 $package = getfield $clogp, 'Source';
5348 build_maybe_quilt_fixup();
5351 sub cmd_import_dsc {
5355 last unless $ARGV[0] =~ m/^-/;
5358 if (m/^--require-valid-signature$/) {
5361 badusage "unknown dgit import-dsc sub-option \`$_'";
5365 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5366 my ($dscfn, $dstbranch) = @ARGV;
5368 badusage "dry run makes no sense with import-dsc" unless act_local();
5370 my $force = $dstbranch =~ s/^\+// ? +1 :
5371 $dstbranch =~ s/^\.\.// ? -1 :
5373 my $info = $force ? " $&" : '';
5374 $info = "$dscfn$info";
5376 my $specbranch = $dstbranch;
5377 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5378 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5380 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5381 my $chead = cmdoutput_errok @symcmd;
5382 defined $chead or $?==256 or failedcmd @symcmd;
5384 fail "$dstbranch is checked out - will not update it"
5385 if defined $chead and $chead eq $dstbranch;
5387 my $oldhash = git_get_ref $dstbranch;
5389 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5390 $dscdata = do { local $/ = undef; <D>; };
5391 D->error and fail "read $dscfn: $!";
5394 # we don't normally need this so import it here
5395 use Dpkg::Source::Package;
5396 my $dp = new Dpkg::Source::Package filename => $dscfn,
5397 require_valid_signature => $needsig;
5399 local $SIG{__WARN__} = sub {
5401 return unless $needsig;
5402 fail "import-dsc signature check failed";
5404 if (!$dp->is_signed()) {
5405 warn "$us: warning: importing unsigned .dsc\n";
5407 my $r = $dp->check_signature();
5408 die "->check_signature => $r" if $needsig && $r;
5414 my $dgit_commit = $dsc->{$ourdscfield[0]};
5415 if (defined $dgit_commit &&
5416 !forceing [qw(import-dsc-with-dgit-field)]) {
5417 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5418 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5419 my @cmd = (qw(sh -ec),
5420 "echo $dgit_commit | git cat-file --batch-check");
5421 my $objgot = cmdoutput @cmd;
5422 if ($objgot =~ m#^\w+ missing\b#) {
5424 .dsc contains Dgit field referring to object $dgit_commit
5425 Your git tree does not have that object. Try `git fetch' from a
5426 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5429 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5431 progress "Not fast forward, forced update.";
5433 fail "Not fast forward to $dgit_commit";
5436 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5437 $dstbranch, $dgit_commit);
5439 progress "dgit: import-dsc updated git ref $dstbranch";
5444 Branch $dstbranch already exists
5445 Specify ..$specbranch for a pseudo-merge, binding in existing history
5446 Specify +$specbranch to overwrite, discarding existing history
5448 if $oldhash && !$force;
5450 $package = getfield $dsc, 'Source';
5451 my @dfi = dsc_files_info();
5452 foreach my $fi (@dfi) {
5453 my $f = $fi->{Filename};
5455 next if lstat $here;
5456 fail "stat $here: $!" unless $! == ENOENT;
5458 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5460 } elsif ($dscfn =~ m#^/#) {
5463 fail "cannot import $dscfn which seems to be inside working tree!";
5465 $there =~ s#/+[^/]+$## or
5466 fail "cannot import $dscfn which seems to not have a basename";
5468 symlink $there, $here or fail "symlink $there to $here: $!";
5469 progress "made symlink $here -> $there";
5470 print STDERR Dumper($fi);
5472 my @mergeinputs = generate_commits_from_dsc();
5473 die unless @mergeinputs == 1;
5475 my $newhash = $mergeinputs[0]{Commit};
5479 progress "Import, forced update - synthetic orphan git history.";
5480 } elsif ($force < 0) {
5481 progress "Import, merging.";
5482 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5483 my $version = getfield $dsc, 'Version';
5484 $newhash = make_commit_text <<END;
5489 Merge $package ($version) import into $dstbranch
5492 die; # caught earlier
5496 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5497 $dstbranch, $newhash);
5499 progress "dgit: import-dsc results are in in git ref $dstbranch";
5502 sub cmd_archive_api_query {
5503 badusage "need only 1 subpath argument" unless @ARGV==1;
5504 my ($subpath) = @ARGV;
5505 my @cmd = archive_api_query_cmd($subpath);
5508 exec @cmd or fail "exec curl: $!\n";
5511 sub cmd_clone_dgit_repos_server {
5512 badusage "need destination argument" unless @ARGV==1;
5513 my ($destdir) = @ARGV;
5514 $package = '_dgit-repos-server';
5515 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5517 exec @cmd or fail "exec git clone: $!\n";
5520 sub cmd_setup_mergechangelogs {
5521 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5522 setup_mergechangelogs(1);
5525 sub cmd_setup_useremail {
5526 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5530 sub cmd_setup_new_tree {
5531 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5535 #---------- argument parsing and main program ----------
5538 print "dgit version $our_version\n" or die $!;
5542 our (%valopts_long, %valopts_short);
5545 sub defvalopt ($$$$) {
5546 my ($long,$short,$val_re,$how) = @_;
5547 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5548 $valopts_long{$long} = $oi;
5549 $valopts_short{$short} = $oi;
5550 # $how subref should:
5551 # do whatever assignemnt or thing it likes with $_[0]
5552 # if the option should not be passed on to remote, @rvalopts=()
5553 # or $how can be a scalar ref, meaning simply assign the value
5556 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5557 defvalopt '--distro', '-d', '.+', \$idistro;
5558 defvalopt '', '-k', '.+', \$keyid;
5559 defvalopt '--existing-package','', '.*', \$existing_package;
5560 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5561 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5562 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5564 defvalopt '', '-C', '.+', sub {
5565 ($changesfile) = (@_);
5566 if ($changesfile =~ s#^(.*)/##) {
5567 $buildproductsdir = $1;
5571 defvalopt '--initiator-tempdir','','.*', sub {
5572 ($initiator_tempdir) = (@_);
5573 $initiator_tempdir =~ m#^/# or
5574 badusage "--initiator-tempdir must be used specify an".
5575 " absolute, not relative, directory."
5581 if (defined $ENV{'DGIT_SSH'}) {
5582 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5583 } elsif (defined $ENV{'GIT_SSH'}) {
5584 @ssh = ($ENV{'GIT_SSH'});
5592 if (!defined $val) {
5593 badusage "$what needs a value" unless @ARGV;
5595 push @rvalopts, $val;
5597 badusage "bad value \`$val' for $what" unless
5598 $val =~ m/^$oi->{Re}$(?!\n)/s;
5599 my $how = $oi->{How};
5600 if (ref($how) eq 'SCALAR') {
5605 push @ropts, @rvalopts;
5609 last unless $ARGV[0] =~ m/^-/;
5613 if (m/^--dry-run$/) {
5616 } elsif (m/^--damp-run$/) {
5619 } elsif (m/^--no-sign$/) {
5622 } elsif (m/^--help$/) {
5624 } elsif (m/^--version$/) {
5626 } elsif (m/^--new$/) {
5629 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5630 ($om = $opts_opt_map{$1}) &&
5634 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5635 !$opts_opt_cmdonly{$1} &&
5636 ($om = $opts_opt_map{$1})) {
5639 } elsif (m/^--(gbp|dpm)$/s) {
5640 push @ropts, "--quilt=$1";
5642 } elsif (m/^--ignore-dirty$/s) {
5645 } elsif (m/^--no-quilt-fixup$/s) {
5647 $quilt_mode = 'nocheck';
5648 } elsif (m/^--no-rm-on-error$/s) {
5651 } elsif (m/^--overwrite$/s) {
5653 $overwrite_version = '';
5654 } elsif (m/^--overwrite=(.+)$/s) {
5656 $overwrite_version = $1;
5657 } elsif (m/^--delayed=(\d+)$/s) {
5660 } elsif (m/^--dgit-view-save=(.+)$/s) {
5662 $split_brain_save = $1;
5663 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5664 } elsif (m/^--(no-)?rm-old-changes$/s) {
5667 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5669 push @deliberatelies, $&;
5670 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5674 } elsif (m/^--force-/) {
5676 "$us: warning: ignoring unknown force option $_\n";
5678 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5679 # undocumented, for testing
5681 $tagformat_want = [ $1, 'command line', 1 ];
5682 # 1 menas overrides distro configuration
5683 } elsif (m/^--always-split-source-build$/s) {
5684 # undocumented, for testing
5686 $need_split_build_invocation = 1;
5687 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5688 $val = $2 ? $' : undef; #';
5689 $valopt->($oi->{Long});
5691 badusage "unknown long option \`$_'";
5698 } elsif (s/^-L/-/) {
5701 } elsif (s/^-h/-/) {
5703 } elsif (s/^-D/-/) {
5707 } elsif (s/^-N/-/) {
5712 push @changesopts, $_;
5714 } elsif (s/^-wn$//s) {
5716 $cleanmode = 'none';
5717 } elsif (s/^-wg$//s) {
5720 } elsif (s/^-wgf$//s) {
5722 $cleanmode = 'git-ff';
5723 } elsif (s/^-wd$//s) {
5725 $cleanmode = 'dpkg-source';
5726 } elsif (s/^-wdd$//s) {
5728 $cleanmode = 'dpkg-source-d';
5729 } elsif (s/^-wc$//s) {
5731 $cleanmode = 'check';
5732 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5733 push @git, '-c', $&;
5734 $gitcfgs{cmdline}{$1} = [ $2 ];
5735 } elsif (s/^-c([^=]+)$//s) {
5736 push @git, '-c', $&;
5737 $gitcfgs{cmdline}{$1} = [ 'true' ];
5738 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5740 $val = undef unless length $val;
5741 $valopt->($oi->{Short});
5744 badusage "unknown short option \`$_'";
5751 sub check_env_sanity () {
5752 my $blocked = new POSIX::SigSet;
5753 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5756 foreach my $name (qw(PIPE CHLD)) {
5757 my $signame = "SIG$name";
5758 my $signum = eval "POSIX::$signame" // die;
5759 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5760 die "$signame is set to something other than SIG_DFL\n";
5761 $blocked->ismember($signum) and
5762 die "$signame is blocked\n";
5768 On entry to dgit, $@
5769 This is a bug produced by something in in your execution environment.
5775 sub finalise_opts_opts () {
5776 foreach my $k (keys %opts_opt_map) {
5777 my $om = $opts_opt_map{$k};
5779 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5781 badcfg "cannot set command for $k"
5782 unless length $om->[0];
5786 foreach my $c (access_cfg_cfgs("opts-$k")) {
5788 map { $_ ? @$_ : () }
5789 map { $gitcfgs{$_}{$c} }
5790 reverse @gitcfgsources;
5791 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5792 "\n" if $debuglevel >= 4;
5794 badcfg "cannot configure options for $k"
5795 if $opts_opt_cmdonly{$k};
5796 my $insertpos = $opts_cfg_insertpos{$k};
5797 @$om = ( @$om[0..$insertpos-1],
5799 @$om[$insertpos..$#$om] );
5804 if ($ENV{$fakeeditorenv}) {
5806 quilt_fixup_editor();
5813 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5814 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5815 if $dryrun_level == 1;
5817 print STDERR $helpmsg or die $!;
5820 my $cmd = shift @ARGV;
5823 my $pre_fn = ${*::}{"pre_$cmd"};
5824 $pre_fn->() if $pre_fn;
5826 if (!defined $rmchanges) {
5827 local $access_forpush;
5828 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5831 if (!defined $quilt_mode) {
5832 local $access_forpush;
5833 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5834 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5836 $quilt_mode =~ m/^($quilt_modes_re)$/
5837 or badcfg "unknown quilt-mode \`$quilt_mode'";
5841 $need_split_build_invocation ||= quiltmode_splitbrain();
5843 if (!defined $cleanmode) {
5844 local $access_forpush;
5845 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5846 $cleanmode //= 'dpkg-source';
5848 badcfg "unknown clean-mode \`$cleanmode'" unless
5849 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5852 my $fn = ${*::}{"cmd_$cmd"};
5853 $fn or badusage "unknown operation $cmd";