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);
39 use Text::Glob qw(match_glob);
44 our $our_version = 'UNRELEASED'; ###substituted###
45 our $absurdity = undef; ###substituted###
47 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
50 our $isuite = 'unstable';
56 our $dryrun_level = 0;
58 our $buildproductsdir = '..';
64 our $existing_package = 'dpkg';
66 our $changes_since_version;
68 our $overwrite_version; # undef: not specified; '': check changelog
70 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
71 our $split_brain_save;
72 our $we_are_responder;
73 our $initiator_tempdir;
74 our $patches_applied_dirtily = 00;
79 our %forceopts = map { $_=>0 }
80 qw(unrepresentable unsupported-source-format
81 dsc-changes-mismatch changes-origs-exactly
82 import-gitapply-absurd
83 import-gitapply-no-absurd
84 import-dsc-with-dgit-field);
86 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
88 our $suite_re = '[-+.0-9a-z]+';
89 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
90 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
91 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
92 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
94 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
95 our $splitbraincache = 'dgit-intern/quilt-cache';
98 our (@dget) = qw(dget);
99 our (@curl) = qw(curl);
100 our (@dput) = qw(dput);
101 our (@debsign) = qw(debsign);
102 our (@gpg) = qw(gpg);
103 our (@sbuild) = qw(sbuild);
105 our (@dgit) = qw(dgit);
106 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
107 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
108 our (@dpkggenchanges) = qw(dpkg-genchanges);
109 our (@mergechanges) = qw(mergechanges -f);
110 our (@gbp_build) = ('');
111 our (@gbp_pq) = ('gbp pq');
112 our (@changesopts) = ('');
114 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
117 'debsign' => \@debsign,
119 'sbuild' => \@sbuild,
123 'dpkg-source' => \@dpkgsource,
124 'dpkg-buildpackage' => \@dpkgbuildpackage,
125 'dpkg-genchanges' => \@dpkggenchanges,
126 'gbp-build' => \@gbp_build,
127 'gbp-pq' => \@gbp_pq,
128 'ch' => \@changesopts,
129 'mergechanges' => \@mergechanges);
131 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
132 our %opts_cfg_insertpos = map {
134 scalar @{ $opts_opt_map{$_} }
135 } keys %opts_opt_map;
137 sub finalise_opts_opts();
143 our $supplementary_message = '';
144 our $need_split_build_invocation = 0;
145 our $split_brain = 0;
149 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
152 our $remotename = 'dgit';
153 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
157 if (!defined $absurdity) {
159 $absurdity =~ s{/[^/]+$}{/absurd} or die;
163 my ($v,$distro) = @_;
164 return $tagformatfn->($v, $distro);
167 sub debiantag_maintview ($$) {
168 my ($v,$distro) = @_;
173 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
175 sub lbranch () { return "$branchprefix/$csuite"; }
176 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
177 sub lref () { return "refs/heads/".lbranch(); }
178 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
179 sub rrref () { return server_ref($csuite); }
181 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
182 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
184 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
185 # locally fetched refs because they have unhelpful names and clutter
186 # up gitk etc. So we track whether we have "used up" head ref (ie,
187 # whether we have made another local ref which refers to this object).
189 # (If we deleted them unconditionally, then we might end up
190 # re-fetching the same git objects each time dgit fetch was run.)
192 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
193 # in git_fetch_us to fetch the refs in question, and possibly a call
194 # to lrfetchref_used.
196 our (%lrfetchrefs_f, %lrfetchrefs_d);
197 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
199 sub lrfetchref_used ($) {
200 my ($fullrefname) = @_;
201 my $objid = $lrfetchrefs_f{$fullrefname};
202 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
213 return "${package}_".(stripepoch $vsn).$sfx
218 return srcfn($vsn,".dsc");
221 sub changespat ($;$) {
222 my ($vsn, $arch) = @_;
223 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
226 sub upstreamversion ($) {
238 foreach my $f (@end) {
240 print STDERR "$us: cleanup: $@" if length $@;
244 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
246 sub forceable_fail ($$) {
247 my ($forceoptsl, $msg) = @_;
248 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
249 print STDERR "warning: overriding problem due to --force:\n". $msg;
253 my ($forceoptsl) = @_;
254 my @got = grep { $forceopts{$_} } @$forceoptsl;
255 return 0 unless @got;
257 "warning: skipping checks or functionality due to --force-$got[0]\n";
260 sub no_such_package () {
261 print STDERR "$us: package $package does not exist in suite $isuite\n";
267 printdebug "CD $newdir\n";
268 chdir $newdir or confess "chdir: $newdir: $!";
271 sub deliberately ($) {
273 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
276 sub deliberately_not_fast_forward () {
277 foreach (qw(not-fast-forward fresh-repo)) {
278 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
282 sub quiltmode_splitbrain () {
283 $quilt_mode =~ m/gbp|dpm|unapplied/;
286 sub opts_opt_multi_cmd {
288 push @cmd, split /\s+/, shift @_;
294 return opts_opt_multi_cmd @gbp_pq;
297 #---------- remote protocol support, common ----------
299 # remote push initiator/responder protocol:
300 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
301 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
302 # < dgit-remote-push-ready <actual-proto-vsn>
309 # > supplementary-message NBYTES # $protovsn >= 3
314 # > file parsed-changelog
315 # [indicates that output of dpkg-parsechangelog follows]
316 # > data-block NBYTES
317 # > [NBYTES bytes of data (no newline)]
318 # [maybe some more blocks]
327 # > param head DGIT-VIEW-HEAD
328 # > param csuite SUITE
329 # > param tagformat old|new
330 # > param maint-view MAINT-VIEW-HEAD
332 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
333 # # goes into tag, for replay prevention
336 # [indicates that signed tag is wanted]
337 # < data-block NBYTES
338 # < [NBYTES bytes of data (no newline)]
339 # [maybe some more blocks]
343 # > want signed-dsc-changes
344 # < data-block NBYTES [transfer of signed dsc]
346 # < data-block NBYTES [transfer of signed changes]
354 sub i_child_report () {
355 # Sees if our child has died, and reap it if so. Returns a string
356 # describing how it died if it failed, or undef otherwise.
357 return undef unless $i_child_pid;
358 my $got = waitpid $i_child_pid, WNOHANG;
359 return undef if $got <= 0;
360 die unless $got == $i_child_pid;
361 $i_child_pid = undef;
362 return undef unless $?;
363 return "build host child ".waitstatusmsg();
368 fail "connection lost: $!" if $fh->error;
369 fail "protocol violation; $m not expected";
372 sub badproto_badread ($$) {
374 fail "connection lost: $!" if $!;
375 my $report = i_child_report();
376 fail $report if defined $report;
377 badproto $fh, "eof (reading $wh)";
380 sub protocol_expect (&$) {
381 my ($match, $fh) = @_;
384 defined && chomp or badproto_badread $fh, "protocol message";
392 badproto $fh, "\`$_'";
395 sub protocol_send_file ($$) {
396 my ($fh, $ourfn) = @_;
397 open PF, "<", $ourfn or die "$ourfn: $!";
400 my $got = read PF, $d, 65536;
401 die "$ourfn: $!" unless defined $got;
403 print $fh "data-block ".length($d)."\n" or die $!;
404 print $fh $d or die $!;
406 PF->error and die "$ourfn $!";
407 print $fh "data-end\n" or die $!;
411 sub protocol_read_bytes ($$) {
412 my ($fh, $nbytes) = @_;
413 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
415 my $got = read $fh, $d, $nbytes;
416 $got==$nbytes or badproto_badread $fh, "data block";
420 sub protocol_receive_file ($$) {
421 my ($fh, $ourfn) = @_;
422 printdebug "() $ourfn\n";
423 open PF, ">", $ourfn or die "$ourfn: $!";
425 my ($y,$l) = protocol_expect {
426 m/^data-block (.*)$/ ? (1,$1) :
427 m/^data-end$/ ? (0,) :
431 my $d = protocol_read_bytes $fh, $l;
432 print PF $d or die $!;
437 #---------- remote protocol support, responder ----------
439 sub responder_send_command ($) {
441 return unless $we_are_responder;
442 # called even without $we_are_responder
443 printdebug ">> $command\n";
444 print PO $command, "\n" or die $!;
447 sub responder_send_file ($$) {
448 my ($keyword, $ourfn) = @_;
449 return unless $we_are_responder;
450 printdebug "]] $keyword $ourfn\n";
451 responder_send_command "file $keyword";
452 protocol_send_file \*PO, $ourfn;
455 sub responder_receive_files ($@) {
456 my ($keyword, @ourfns) = @_;
457 die unless $we_are_responder;
458 printdebug "[[ $keyword @ourfns\n";
459 responder_send_command "want $keyword";
460 foreach my $fn (@ourfns) {
461 protocol_receive_file \*PI, $fn;
464 protocol_expect { m/^files-end$/ } \*PI;
467 #---------- remote protocol support, initiator ----------
469 sub initiator_expect (&) {
471 protocol_expect { &$match } \*RO;
474 #---------- end remote code ----------
477 if ($we_are_responder) {
479 responder_send_command "progress ".length($m) or die $!;
480 print PO $m or die $!;
490 $ua = LWP::UserAgent->new();
494 progress "downloading $what...";
495 my $r = $ua->get(@_) or die $!;
496 return undef if $r->code == 404;
497 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
498 return $r->decoded_content(charset => 'none');
501 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
506 failedcmd @_ if system @_;
509 sub act_local () { return $dryrun_level <= 1; }
510 sub act_scary () { return !$dryrun_level; }
513 if (!$dryrun_level) {
514 progress "dgit ok: @_";
516 progress "would be ok: @_ (but dry run only)";
521 printcmd(\*STDERR,$debugprefix."#",@_);
524 sub runcmd_ordryrun {
532 sub runcmd_ordryrun_local {
541 my ($first_shell, @cmd) = @_;
542 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
545 our $helpmsg = <<END;
547 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
548 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
549 dgit [dgit-opts] build [dpkg-buildpackage-opts]
550 dgit [dgit-opts] sbuild [sbuild-opts]
551 dgit [dgit-opts] push [dgit-opts] [suite]
552 dgit [dgit-opts] rpush build-host:build-dir ...
553 important dgit options:
554 -k<keyid> sign tag and package with <keyid> instead of default
555 --dry-run -n do not change anything, but go through the motions
556 --damp-run -L like --dry-run but make local changes, without signing
557 --new -N allow introducing a new package
558 --debug -D increase debug level
559 -c<name>=<value> set git config option (used directly by dgit too)
562 our $later_warning_msg = <<END;
563 Perhaps the upload is stuck in incoming. Using the version from git.
567 print STDERR "$us: @_\n", $helpmsg or die $!;
572 @ARGV or badusage "too few arguments";
573 return scalar shift @ARGV;
577 print $helpmsg or die $!;
581 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
583 our %defcfg = ('dgit.default.distro' => 'debian',
584 'dgit.default.username' => '',
585 'dgit.default.archive-query-default-component' => 'main',
586 'dgit.default.ssh' => 'ssh',
587 'dgit.default.archive-query' => 'madison:',
588 'dgit.default.sshpsql-dbname' => 'service=projectb',
589 'dgit.default.dgit-tag-format' => 'new,old,maint',
590 # old means "repo server accepts pushes with old dgit tags"
591 # new means "repo server accepts pushes with new dgit tags"
592 # maint means "repo server accepts split brain pushes"
593 # hist means "repo server may have old pushes without new tag"
594 # ("hist" is implied by "old")
595 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
596 'dgit-distro.debian.git-check' => 'url',
597 'dgit-distro.debian.git-check-suffix' => '/info/refs',
598 'dgit-distro.debian.new-private-pushers' => 't',
599 'dgit-distro.debian/push.git-url' => '',
600 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
601 'dgit-distro.debian/push.git-user-force' => 'dgit',
602 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
603 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
604 'dgit-distro.debian/push.git-create' => 'true',
605 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
606 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
607 # 'dgit-distro.debian.archive-query-tls-key',
608 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
609 # ^ this does not work because curl is broken nowadays
610 # Fixing #790093 properly will involve providing providing the key
611 # in some pacagke and maybe updating these paths.
613 # 'dgit-distro.debian.archive-query-tls-curl-args',
614 # '--ca-path=/etc/ssl/ca-debian',
615 # ^ this is a workaround but works (only) on DSA-administered machines
616 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
617 'dgit-distro.debian.git-url-suffix' => '',
618 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
619 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
620 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
621 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
622 'dgit-distro.ubuntu.git-check' => 'false',
623 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
624 'dgit-distro.test-dummy.ssh' => "$td/ssh",
625 'dgit-distro.test-dummy.username' => "alice",
626 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
628 'dgit-distro.test-dummy.git-url' => "$td/git",
629 'dgit-distro.test-dummy.git-host' => "git",
630 'dgit-distro.test-dummy.git-path' => "$td/git",
631 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
632 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
633 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
634 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
638 our @gitcfgsources = qw(cmdline local global system);
640 sub git_slurp_config () {
641 local ($debuglevel) = $debuglevel-2;
644 # This algoritm is a bit subtle, but this is needed so that for
645 # options which we want to be single-valued, we allow the
646 # different config sources to override properly. See #835858.
647 foreach my $src (@gitcfgsources) {
648 next if $src eq 'cmdline';
649 # we do this ourselves since git doesn't handle it
651 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
654 open GITS, "-|", @cmd or die $!;
657 printdebug "=> ", (messagequote $_), "\n";
659 push @{ $gitcfgs{$src}{$`} }, $'; #';
663 or ($!==0 && $?==256)
668 sub git_get_config ($) {
670 foreach my $src (@gitcfgsources) {
671 my $l = $gitcfgs{$src}{$c};
672 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
675 @$l==1 or badcfg "multiple values for $c".
676 " (in $src git config)" if @$l > 1;
684 return undef if $c =~ /RETURN-UNDEF/;
685 my $v = git_get_config($c);
686 return $v if defined $v;
687 my $dv = $defcfg{$c};
688 return $dv if defined $dv;
690 badcfg "need value for one of: @_\n".
691 "$us: distro or suite appears not to be (properly) supported";
694 sub access_basedistro () {
695 if (defined $idistro) {
698 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
699 return $def if defined $def;
700 foreach my $src (@gitcfgsources, 'internal') {
701 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
703 foreach my $k (keys %$kl) {
704 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
706 next unless match_glob $dpat, $isuite;
710 return cfg("dgit.default.distro");
714 sub access_nomdistro () {
715 my $base = access_basedistro();
716 return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
719 sub access_quirk () {
720 # returns (quirk name, distro to use instead or undef, quirk-specific info)
721 my $basedistro = access_basedistro();
722 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
724 if (defined $backports_quirk) {
725 my $re = $backports_quirk;
726 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
728 $re =~ s/\%/([-0-9a-z_]+)/
729 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
730 if ($isuite =~ m/^$re$/) {
731 return ('backports',"$basedistro-backports",$1);
734 return ('none',undef);
739 sub parse_cfg_bool ($$$) {
740 my ($what,$def,$v) = @_;
743 $v =~ m/^[ty1]/ ? 1 :
744 $v =~ m/^[fn0]/ ? 0 :
745 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
748 sub access_forpush_config () {
749 my $d = access_basedistro();
753 parse_cfg_bool('new-private-pushers', 0,
754 cfg("dgit-distro.$d.new-private-pushers",
757 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
760 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
761 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
762 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
763 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
766 sub access_forpush () {
767 $access_forpush //= access_forpush_config();
768 return $access_forpush;
772 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
773 badcfg "pushing but distro is configured readonly"
774 if access_forpush_config() eq '0';
776 $supplementary_message = <<'END' unless $we_are_responder;
777 Push failed, before we got started.
778 You can retry the push, after fixing the problem, if you like.
780 finalise_opts_opts();
784 finalise_opts_opts();
787 sub supplementary_message ($) {
789 if (!$we_are_responder) {
790 $supplementary_message = $msg;
792 } elsif ($protovsn >= 3) {
793 responder_send_command "supplementary-message ".length($msg)
795 print PO $msg or die $!;
799 sub access_distros () {
800 # Returns list of distros to try, in order
803 # 0. `instead of' distro name(s) we have been pointed to
804 # 1. the access_quirk distro, if any
805 # 2a. the user's specified distro, or failing that } basedistro
806 # 2b. the distro calculated from the suite }
807 my @l = access_basedistro();
809 my (undef,$quirkdistro) = access_quirk();
810 unshift @l, $quirkdistro;
811 unshift @l, $instead_distro;
812 @l = grep { defined } @l;
814 push @l, access_nomdistro();
816 if (access_forpush()) {
817 @l = map { ("$_/push", $_) } @l;
822 sub access_cfg_cfgs (@) {
825 # The nesting of these loops determines the search order. We put
826 # the key loop on the outside so that we search all the distros
827 # for each key, before going on to the next key. That means that
828 # if access_cfg is called with a more specific, and then a less
829 # specific, key, an earlier distro can override the less specific
830 # without necessarily overriding any more specific keys. (If the
831 # distro wants to override the more specific keys it can simply do
832 # so; whereas if we did the loop the other way around, it would be
833 # impossible to for an earlier distro to override a less specific
834 # key but not the more specific ones without restating the unknown
835 # values of the more specific keys.
838 # We have to deal with RETURN-UNDEF specially, so that we don't
839 # terminate the search prematurely.
841 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
844 foreach my $d (access_distros()) {
845 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
847 push @cfgs, map { "dgit.default.$_" } @realkeys;
854 my (@cfgs) = access_cfg_cfgs(@keys);
855 my $value = cfg(@cfgs);
859 sub access_cfg_bool ($$) {
860 my ($def, @keys) = @_;
861 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
864 sub string_to_ssh ($) {
866 if ($spec =~ m/\s/) {
867 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
873 sub access_cfg_ssh () {
874 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
875 if (!defined $gitssh) {
878 return string_to_ssh $gitssh;
882 sub access_runeinfo ($) {
884 return ": dgit ".access_basedistro()." $info ;";
887 sub access_someuserhost ($) {
889 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
890 defined($user) && length($user) or
891 $user = access_cfg("$some-user",'username');
892 my $host = access_cfg("$some-host");
893 return length($user) ? "$user\@$host" : $host;
896 sub access_gituserhost () {
897 return access_someuserhost('git');
900 sub access_giturl (;$) {
902 my $url = access_cfg('git-url','RETURN-UNDEF');
905 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
906 return undef unless defined $proto;
909 access_gituserhost().
910 access_cfg('git-path');
912 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
915 return "$url/$package$suffix";
918 sub parsecontrolfh ($$;$) {
919 my ($fh, $desc, $allowsigned) = @_;
920 our $dpkgcontrolhash_noissigned;
923 my %opts = ('name' => $desc);
924 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
925 $c = Dpkg::Control::Hash->new(%opts);
926 $c->parse($fh,$desc) or die "parsing of $desc failed";
927 last if $allowsigned;
928 last if $dpkgcontrolhash_noissigned;
929 my $issigned= $c->get_option('is_pgp_signed');
930 if (!defined $issigned) {
931 $dpkgcontrolhash_noissigned= 1;
932 seek $fh, 0,0 or die "seek $desc: $!";
933 } elsif ($issigned) {
934 fail "control file $desc is (already) PGP-signed. ".
935 " Note that dgit push needs to modify the .dsc and then".
936 " do the signature itself";
945 my ($file, $desc, $allowsigned) = @_;
946 my $fh = new IO::Handle;
947 open $fh, '<', $file or die "$file: $!";
948 my $c = parsecontrolfh($fh,$desc,$allowsigned);
949 $fh->error and die $!;
955 my ($dctrl,$field) = @_;
956 my $v = $dctrl->{$field};
957 return $v if defined $v;
958 fail "missing field $field in ".$dctrl->get_option('name');
962 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
963 my $p = new IO::Handle;
964 my @cmd = (qw(dpkg-parsechangelog), @_);
965 open $p, '-|', @cmd or die $!;
967 $?=0; $!=0; close $p or failedcmd @cmd;
971 sub commit_getclogp ($) {
972 # Returns the parsed changelog hashref for a particular commit
974 our %commit_getclogp_memo;
975 my $memo = $commit_getclogp_memo{$objid};
976 return $memo if $memo;
978 my $mclog = ".git/dgit/clog-$objid";
979 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
980 "$objid:debian/changelog";
981 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
986 defined $d or fail "getcwd failed: $!";
990 sub parse_dscdata () {
991 my $dscfh = new IO::File \$dscdata, '<' or die $!;
992 printdebug Dumper($dscdata) if $debuglevel>1;
993 $dsc = parsecontrolfh($dscfh,$dscurl,1);
994 printdebug Dumper($dsc) if $debuglevel>1;
999 sub archive_query ($;@) {
1000 my ($method) = shift @_;
1001 my $query = access_cfg('archive-query','RETURN-UNDEF');
1002 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1005 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1008 sub archive_query_prepend_mirror {
1009 my $m = access_cfg('mirror');
1010 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1013 sub pool_dsc_subpath ($$) {
1014 my ($vsn,$component) = @_; # $package is implict arg
1015 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1016 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1019 #---------- `ftpmasterapi' archive query method (nascent) ----------
1021 sub archive_api_query_cmd ($) {
1023 my @cmd = (@curl, qw(-sS));
1024 my $url = access_cfg('archive-query-url');
1025 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1027 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1028 foreach my $key (split /\:/, $keys) {
1029 $key =~ s/\%HOST\%/$host/g;
1031 fail "for $url: stat $key: $!" unless $!==ENOENT;
1034 fail "config requested specific TLS key but do not know".
1035 " how to get curl to use exactly that EE key ($key)";
1036 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1037 # # Sadly the above line does not work because of changes
1038 # # to gnutls. The real fix for #790093 may involve
1039 # # new curl options.
1042 # Fixing #790093 properly will involve providing a value
1043 # for this on clients.
1044 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1045 push @cmd, split / /, $kargs if defined $kargs;
1047 push @cmd, $url.$subpath;
1051 sub api_query ($$;$) {
1053 my ($data, $subpath, $ok404) = @_;
1054 badcfg "ftpmasterapi archive query method takes no data part"
1056 my @cmd = archive_api_query_cmd($subpath);
1057 my $url = $cmd[$#cmd];
1058 push @cmd, qw(-w %{http_code});
1059 my $json = cmdoutput @cmd;
1060 unless ($json =~ s/\d+\d+\d$//) {
1061 failedcmd_report_cmd undef, @cmd;
1062 fail "curl failed to print 3-digit HTTP code";
1065 return undef if $code eq '404' && $ok404;
1066 fail "fetch of $url gave HTTP code $code"
1067 unless $url =~ m#^file://# or $code =~ m/^2/;
1068 return decode_json($json);
1071 sub canonicalise_suite_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $suites = api_query($data, 'suites');
1075 foreach my $entry (@$suites) {
1077 my $v = $entry->{$_};
1078 defined $v && $v eq $isuite;
1079 } qw(codename name);
1080 push @matched, $entry;
1082 fail "unknown suite $isuite" unless @matched;
1085 @matched==1 or die "multiple matches for suite $isuite\n";
1086 $cn = "$matched[0]{codename}";
1087 defined $cn or die "suite $isuite info has no codename\n";
1088 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1090 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1095 sub archive_query_ftpmasterapi {
1096 my ($proto,$data) = @_;
1097 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1099 my $digester = Digest::SHA->new(256);
1100 foreach my $entry (@$info) {
1102 my $vsn = "$entry->{version}";
1103 my ($ok,$msg) = version_check $vsn;
1104 die "bad version: $msg\n" unless $ok;
1105 my $component = "$entry->{component}";
1106 $component =~ m/^$component_re$/ or die "bad component";
1107 my $filename = "$entry->{filename}";
1108 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1109 or die "bad filename";
1110 my $sha256sum = "$entry->{sha256sum}";
1111 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1112 push @rows, [ $vsn, "/pool/$component/$filename",
1113 $digester, $sha256sum ];
1115 die "bad ftpmaster api response: $@\n".Dumper($entry)
1118 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1119 return archive_query_prepend_mirror @rows;
1122 sub file_in_archive_ftpmasterapi {
1123 my ($proto,$data,$filename) = @_;
1124 my $pat = $filename;
1127 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1128 my $info = api_query($data, "file_in_archive/$pat", 1);
1131 #---------- `dummyapicat' archive query method ----------
1133 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1134 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1136 sub file_in_archive_dummycatapi ($$$) {
1137 my ($proto,$data,$filename) = @_;
1138 my $mirror = access_cfg('mirror');
1139 $mirror =~ s#^file://#/# or die "$mirror ?";
1141 my @cmd = (qw(sh -ec), '
1143 find -name "$2" -print0 |
1145 ', qw(x), $mirror, $filename);
1146 debugcmd "-|", @cmd;
1147 open FIA, "-|", @cmd or die $!;
1150 printdebug "| $_\n";
1151 m/^(\w+) (\S+)$/ or die "$_ ?";
1152 push @out, { sha256sum => $1, filename => $2 };
1154 close FIA or die failedcmd @cmd;
1158 #---------- `madison' archive query method ----------
1160 sub archive_query_madison {
1161 return archive_query_prepend_mirror
1162 map { [ @$_[0..1] ] } madison_get_parse(@_);
1165 sub madison_get_parse {
1166 my ($proto,$data) = @_;
1167 die unless $proto eq 'madison';
1168 if (!length $data) {
1169 $data= access_cfg('madison-distro','RETURN-UNDEF');
1170 $data //= access_basedistro();
1172 $rmad{$proto,$data,$package} ||= cmdoutput
1173 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1174 my $rmad = $rmad{$proto,$data,$package};
1177 foreach my $l (split /\n/, $rmad) {
1178 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1179 \s*( [^ \t|]+ )\s* \|
1180 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1181 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1182 $1 eq $package or die "$rmad $package ?";
1189 $component = access_cfg('archive-query-default-component');
1191 $5 eq 'source' or die "$rmad ?";
1192 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1194 return sort { -version_compare($a->[0],$b->[0]); } @out;
1197 sub canonicalise_suite_madison {
1198 # madison canonicalises for us
1199 my @r = madison_get_parse(@_);
1201 "unable to canonicalise suite using package $package".
1202 " which does not appear to exist in suite $isuite;".
1203 " --existing-package may help";
1207 sub file_in_archive_madison { return undef; }
1209 #---------- `sshpsql' archive query method ----------
1212 my ($data,$runeinfo,$sql) = @_;
1213 if (!length $data) {
1214 $data= access_someuserhost('sshpsql').':'.
1215 access_cfg('sshpsql-dbname');
1217 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1218 my ($userhost,$dbname) = ($`,$'); #';
1220 my @cmd = (access_cfg_ssh, $userhost,
1221 access_runeinfo("ssh-psql $runeinfo").
1222 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1223 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1225 open P, "-|", @cmd or die $!;
1228 printdebug(">|$_|\n");
1231 $!=0; $?=0; close P or failedcmd @cmd;
1233 my $nrows = pop @rows;
1234 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1235 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1236 @rows = map { [ split /\|/, $_ ] } @rows;
1237 my $ncols = scalar @{ shift @rows };
1238 die if grep { scalar @$_ != $ncols } @rows;
1242 sub sql_injection_check {
1243 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1246 sub archive_query_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite, $package;
1249 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1250 SELECT source.version, component.name, files.filename, files.sha256sum
1252 JOIN src_associations ON source.id = src_associations.source
1253 JOIN suite ON suite.id = src_associations.suite
1254 JOIN dsc_files ON dsc_files.source = source.id
1255 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1256 JOIN component ON component.id = files_archive_map.component_id
1257 JOIN files ON files.id = dsc_files.file
1258 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1259 AND source.source='$package'
1260 AND files.filename LIKE '%.dsc';
1262 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1263 my $digester = Digest::SHA->new(256);
1265 my ($vsn,$component,$filename,$sha256sum) = @$_;
1266 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1268 return archive_query_prepend_mirror @rows;
1271 sub canonicalise_suite_sshpsql ($$) {
1272 my ($proto,$data) = @_;
1273 sql_injection_check $isuite;
1274 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1275 SELECT suite.codename
1276 FROM suite where suite_name='$isuite' or codename='$isuite';
1278 @rows = map { $_->[0] } @rows;
1279 fail "unknown suite $isuite" unless @rows;
1280 die "ambiguous $isuite: @rows ?" if @rows>1;
1284 sub file_in_archive_sshpsql ($$$) { return undef; }
1286 #---------- `dummycat' archive query method ----------
1288 sub canonicalise_suite_dummycat ($$) {
1289 my ($proto,$data) = @_;
1290 my $dpath = "$data/suite.$isuite";
1291 if (!open C, "<", $dpath) {
1292 $!==ENOENT or die "$dpath: $!";
1293 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1297 chomp or die "$dpath: $!";
1299 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1303 sub archive_query_dummycat ($$) {
1304 my ($proto,$data) = @_;
1305 canonicalise_suite();
1306 my $dpath = "$data/package.$csuite.$package";
1307 if (!open C, "<", $dpath) {
1308 $!==ENOENT or die "$dpath: $!";
1309 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1317 printdebug "dummycat query $csuite $package $dpath | $_\n";
1318 my @row = split /\s+/, $_;
1319 @row==2 or die "$dpath: $_ ?";
1322 C->error and die "$dpath: $!";
1324 return archive_query_prepend_mirror
1325 sort { -version_compare($a->[0],$b->[0]); } @rows;
1328 sub file_in_archive_dummycat () { return undef; }
1330 #---------- tag format handling ----------
1332 sub access_cfg_tagformats () {
1333 split /\,/, access_cfg('dgit-tag-format');
1336 sub need_tagformat ($$) {
1337 my ($fmt, $why) = @_;
1338 fail "need to use tag format $fmt ($why) but also need".
1339 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1340 " - no way to proceed"
1341 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1342 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1345 sub select_tagformat () {
1347 return if $tagformatfn && !$tagformat_want;
1348 die 'bug' if $tagformatfn && $tagformat_want;
1349 # ... $tagformat_want assigned after previous select_tagformat
1351 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1352 printdebug "select_tagformat supported @supported\n";
1354 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1355 printdebug "select_tagformat specified @$tagformat_want\n";
1357 my ($fmt,$why,$override) = @$tagformat_want;
1359 fail "target distro supports tag formats @supported".
1360 " but have to use $fmt ($why)"
1362 or grep { $_ eq $fmt } @supported;
1364 $tagformat_want = undef;
1366 $tagformatfn = ${*::}{"debiantag_$fmt"};
1368 fail "trying to use unknown tag format \`$fmt' ($why) !"
1369 unless $tagformatfn;
1372 #---------- archive query entrypoints and rest of program ----------
1374 sub canonicalise_suite () {
1375 return if defined $csuite;
1376 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1377 $csuite = archive_query('canonicalise_suite');
1378 if ($isuite ne $csuite) {
1379 progress "canonical suite name for $isuite is $csuite";
1383 sub get_archive_dsc () {
1384 canonicalise_suite();
1385 my @vsns = archive_query('archive_query');
1386 foreach my $vinfo (@vsns) {
1387 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1388 $dscurl = $vsn_dscurl;
1389 $dscdata = url_get($dscurl);
1391 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1396 $digester->add($dscdata);
1397 my $got = $digester->hexdigest();
1399 fail "$dscurl has hash $got but".
1400 " archive told us to expect $digest";
1403 my $fmt = getfield $dsc, 'Format';
1404 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1405 "unsupported source format $fmt, sorry";
1407 $dsc_checked = !!$digester;
1408 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1412 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1415 sub check_for_git ();
1416 sub check_for_git () {
1418 my $how = access_cfg('git-check');
1419 if ($how eq 'ssh-cmd') {
1421 (access_cfg_ssh, access_gituserhost(),
1422 access_runeinfo("git-check $package").
1423 " set -e; cd ".access_cfg('git-path').";".
1424 " if test -d $package.git; then echo 1; else echo 0; fi");
1425 my $r= cmdoutput @cmd;
1426 if (defined $r and $r =~ m/^divert (\w+)$/) {
1428 my ($usedistro,) = access_distros();
1429 # NB that if we are pushing, $usedistro will be $distro/push
1430 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1431 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1432 progress "diverting to $divert (using config for $instead_distro)";
1433 return check_for_git();
1435 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1437 } elsif ($how eq 'url') {
1438 my $prefix = access_cfg('git-check-url','git-url');
1439 my $suffix = access_cfg('git-check-suffix','git-suffix',
1440 'RETURN-UNDEF') // '.git';
1441 my $url = "$prefix/$package$suffix";
1442 my @cmd = (@curl, qw(-sS -I), $url);
1443 my $result = cmdoutput @cmd;
1444 $result =~ s/^\S+ 200 .*\n\r?\n//;
1445 # curl -sS -I with https_proxy prints
1446 # HTTP/1.0 200 Connection established
1447 $result =~ m/^\S+ (404|200) /s or
1448 fail "unexpected results from git check query - ".
1449 Dumper($prefix, $result);
1451 if ($code eq '404') {
1453 } elsif ($code eq '200') {
1458 } elsif ($how eq 'true') {
1460 } elsif ($how eq 'false') {
1463 badcfg "unknown git-check \`$how'";
1467 sub create_remote_git_repo () {
1468 my $how = access_cfg('git-create');
1469 if ($how eq 'ssh-cmd') {
1471 (access_cfg_ssh, access_gituserhost(),
1472 access_runeinfo("git-create $package").
1473 "set -e; cd ".access_cfg('git-path').";".
1474 " cp -a _template $package.git");
1475 } elsif ($how eq 'true') {
1478 badcfg "unknown git-create \`$how'";
1482 our ($dsc_hash,$lastpush_mergeinput);
1484 our $ud = '.git/dgit/unpack';
1494 sub mktree_in_ud_here () {
1495 runcmd qw(git init -q);
1496 runcmd qw(git config gc.auto 0);
1497 rmtree('.git/objects');
1498 symlink '../../../../objects','.git/objects' or die $!;
1501 sub git_write_tree () {
1502 my $tree = cmdoutput @git, qw(write-tree);
1503 $tree =~ m/^\w+$/ or die "$tree ?";
1507 sub remove_stray_gits () {
1508 my @gitscmd = qw(find -name .git -prune -print0);
1509 debugcmd "|",@gitscmd;
1510 open GITS, "-|", @gitscmd or die $!;
1515 print STDERR "$us: warning: removing from source package: ",
1516 (messagequote $_), "\n";
1520 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1523 sub mktree_in_ud_from_only_subdir (;$) {
1526 # changes into the subdir
1528 die "expected one subdir but found @dirs ?" unless @dirs==1;
1529 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1533 remove_stray_gits();
1534 mktree_in_ud_here();
1536 my ($format, $fopts) = get_source_format();
1537 if (madformat($format)) {
1542 runcmd @git, qw(add -Af);
1543 my $tree=git_write_tree();
1544 return ($tree,$dir);
1547 our @files_csum_info_fields =
1548 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1549 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1550 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1552 sub dsc_files_info () {
1553 foreach my $csumi (@files_csum_info_fields) {
1554 my ($fname, $module, $method) = @$csumi;
1555 my $field = $dsc->{$fname};
1556 next unless defined $field;
1557 eval "use $module; 1;" or die $@;
1559 foreach (split /\n/, $field) {
1561 m/^(\w+) (\d+) (\S+)$/ or
1562 fail "could not parse .dsc $fname line \`$_'";
1563 my $digester = eval "$module"."->$method;" or die $@;
1568 Digester => $digester,
1573 fail "missing any supported Checksums-* or Files field in ".
1574 $dsc->get_option('name');
1578 map { $_->{Filename} } dsc_files_info();
1581 sub files_compare_inputs (@) {
1586 my $showinputs = sub {
1587 return join "; ", map { $_->get_option('name') } @$inputs;
1590 foreach my $in (@$inputs) {
1592 my $in_name = $in->get_option('name');
1594 printdebug "files_compare_inputs $in_name\n";
1596 foreach my $csumi (@files_csum_info_fields) {
1597 my ($fname) = @$csumi;
1598 printdebug "files_compare_inputs $in_name $fname\n";
1600 my $field = $in->{$fname};
1601 next unless defined $field;
1604 foreach (split /\n/, $field) {
1607 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1608 fail "could not parse $in_name $fname line \`$_'";
1610 printdebug "files_compare_inputs $in_name $fname $f\n";
1614 my $re = \ $record{$f}{$fname};
1616 $fchecked{$f}{$in_name} = 1;
1618 fail "hash or size of $f varies in $fname fields".
1619 " (between: ".$showinputs->().")";
1624 @files = sort @files;
1625 $expected_files //= \@files;
1626 "@$expected_files" eq "@files" or
1627 fail "file list in $in_name varies between hash fields!";
1630 fail "$in_name has no files list field(s)";
1632 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1635 grep { keys %$_ == @$inputs-1 } values %fchecked
1636 or fail "no file appears in all file lists".
1637 " (looked in: ".$showinputs->().")";
1640 sub is_orig_file_in_dsc ($$) {
1641 my ($f, $dsc_files_info) = @_;
1642 return 0 if @$dsc_files_info <= 1;
1643 # One file means no origs, and the filename doesn't have a "what
1644 # part of dsc" component. (Consider versions ending `.orig'.)
1645 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1649 sub is_orig_file_of_vsn ($$) {
1650 my ($f, $upstreamvsn) = @_;
1651 my $base = srcfn $upstreamvsn, '';
1652 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1656 sub changes_update_origs_from_dsc ($$$$) {
1657 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1659 printdebug "checking origs needed ($upstreamvsn)...\n";
1660 $_ = getfield $changes, 'Files';
1661 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1662 fail "cannot find section/priority from .changes Files field";
1663 my $placementinfo = $1;
1665 printdebug "checking origs needed placement '$placementinfo'...\n";
1666 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1667 $l =~ m/\S+$/ or next;
1669 printdebug "origs $file | $l\n";
1670 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1671 printdebug "origs $file is_orig\n";
1672 my $have = archive_query('file_in_archive', $file);
1673 if (!defined $have) {
1675 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1681 printdebug "origs $file \$#\$have=$#$have\n";
1682 foreach my $h (@$have) {
1685 foreach my $csumi (@files_csum_info_fields) {
1686 my ($fname, $module, $method, $archivefield) = @$csumi;
1687 next unless defined $h->{$archivefield};
1688 $_ = $dsc->{$fname};
1689 next unless defined;
1690 m/^(\w+) .* \Q$file\E$/m or
1691 fail ".dsc $fname missing entry for $file";
1692 if ($h->{$archivefield} eq $1) {
1696 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1699 die "$file ".Dumper($h)." ?!" if $same && @differ;
1702 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1705 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1706 if (@found_differ && !$found_same) {
1708 "archive contains $file with different checksum",
1711 # Now we edit the changes file to add or remove it
1712 foreach my $csumi (@files_csum_info_fields) {
1713 my ($fname, $module, $method, $archivefield) = @$csumi;
1714 next unless defined $changes->{$fname};
1716 # in archive, delete from .changes if it's there
1717 $changed{$file} = "removed" if
1718 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1719 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1720 # not in archive, but it's here in the .changes
1722 my $dsc_data = getfield $dsc, $fname;
1723 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1725 $extra =~ s/ \d+ /$&$placementinfo /
1726 or die "$fname $extra >$dsc_data< ?"
1727 if $fname eq 'Files';
1728 $changes->{$fname} .= "\n". $extra;
1729 $changed{$file} = "added";
1734 foreach my $file (keys %changed) {
1736 "edited .changes for archive .orig contents: %s %s",
1737 $changed{$file}, $file;
1739 my $chtmp = "$changesfile.tmp";
1740 $changes->save($chtmp);
1742 rename $chtmp,$changesfile or die "$changesfile $!";
1744 progress "[new .changes left in $changesfile]";
1747 progress "$changesfile already has appropriate .orig(s) (if any)";
1751 sub make_commit ($) {
1753 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1756 sub make_commit_text ($) {
1759 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1761 print Dumper($text) if $debuglevel > 1;
1762 my $child = open2($out, $in, @cmd) or die $!;
1765 print $in $text or die $!;
1766 close $in or die $!;
1768 $h =~ m/^\w+$/ or die;
1770 printdebug "=> $h\n";
1773 waitpid $child, 0 == $child or die "$child $!";
1774 $? and failedcmd @cmd;
1778 sub clogp_authline ($) {
1780 my $author = getfield $clogp, 'Maintainer';
1781 $author =~ s#,.*##ms;
1782 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1783 my $authline = "$author $date";
1784 $authline =~ m/$git_authline_re/o or
1785 fail "unexpected commit author line format \`$authline'".
1786 " (was generated from changelog Maintainer field)";
1787 return ($1,$2,$3) if wantarray;
1791 sub vendor_patches_distro ($$) {
1792 my ($checkdistro, $what) = @_;
1793 return unless defined $checkdistro;
1795 my $series = "debian/patches/\L$checkdistro\E.series";
1796 printdebug "checking for vendor-specific $series ($what)\n";
1798 if (!open SERIES, "<", $series) {
1799 die "$series $!" unless $!==ENOENT;
1808 Unfortunately, this source package uses a feature of dpkg-source where
1809 the same source package unpacks to different source code on different
1810 distros. dgit cannot safely operate on such packages on affected
1811 distros, because the meaning of source packages is not stable.
1813 Please ask the distro/maintainer to remove the distro-specific series
1814 files and use a different technique (if necessary, uploading actually
1815 different packages, if different distros are supposed to have
1819 fail "Found active distro-specific series file for".
1820 " $checkdistro ($what): $series, cannot continue";
1822 die "$series $!" if SERIES->error;
1826 sub check_for_vendor_patches () {
1827 # This dpkg-source feature doesn't seem to be documented anywhere!
1828 # But it can be found in the changelog (reformatted):
1830 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1831 # Author: Raphael Hertzog <hertzog@debian.org>
1832 # Date: Sun Oct 3 09:36:48 2010 +0200
1834 # dpkg-source: correctly create .pc/.quilt_series with alternate
1837 # If you have debian/patches/ubuntu.series and you were
1838 # unpacking the source package on ubuntu, quilt was still
1839 # directed to debian/patches/series instead of
1840 # debian/patches/ubuntu.series.
1842 # debian/changelog | 3 +++
1843 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1844 # 2 files changed, 6 insertions(+), 1 deletion(-)
1847 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1848 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1849 "Dpkg::Vendor \`current vendor'");
1850 vendor_patches_distro(access_basedistro(),
1851 "(base) distro being accessed");
1852 vendor_patches_distro(access_nomdistro(),
1853 "(nominal) distro being accessed");
1856 sub generate_commits_from_dsc () {
1857 # See big comment in fetch_from_archive, below.
1858 # See also README.dsc-import.
1862 my @dfi = dsc_files_info();
1863 foreach my $fi (@dfi) {
1864 my $f = $fi->{Filename};
1865 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1867 printdebug "considering linking $f: ";
1869 link_ltarget "../../../../$f", $f
1870 or ((printdebug "($!) "), 0)
1874 printdebug "linked.\n";
1876 complete_file_from_dsc('.', $fi)
1879 if (is_orig_file_in_dsc($f, \@dfi)) {
1880 link $f, "../../../../$f"
1886 # We unpack and record the orig tarballs first, so that we only
1887 # need disk space for one private copy of the unpacked source.
1888 # But we can't make them into commits until we have the metadata
1889 # from the debian/changelog, so we record the tree objects now and
1890 # make them into commits later.
1892 my $upstreamv = upstreamversion $dsc->{version};
1893 my $orig_f_base = srcfn $upstreamv, '';
1895 foreach my $fi (@dfi) {
1896 # We actually import, and record as a commit, every tarball
1897 # (unless there is only one file, in which case there seems
1900 my $f = $fi->{Filename};
1901 printdebug "import considering $f ";
1902 (printdebug "only one dfi\n"), next if @dfi == 1;
1903 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1904 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1908 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1910 printdebug "Y ", (join ' ', map { $_//"(none)" }
1911 $compr_ext, $orig_f_part
1914 my $input = new IO::File $f, '<' or die "$f $!";
1918 if (defined $compr_ext) {
1920 Dpkg::Compression::compression_guess_from_filename $f;
1921 fail "Dpkg::Compression cannot handle file $f in source package"
1922 if defined $compr_ext && !defined $cname;
1924 new Dpkg::Compression::Process compression => $cname;
1925 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1926 my $compr_fh = new IO::Handle;
1927 my $compr_pid = open $compr_fh, "-|" // die $!;
1929 open STDIN, "<&", $input or die $!;
1931 die "dgit (child): exec $compr_cmd[0]: $!\n";
1936 rmtree "../unpack-tar";
1937 mkdir "../unpack-tar" or die $!;
1938 my @tarcmd = qw(tar -x -f -
1939 --no-same-owner --no-same-permissions
1940 --no-acls --no-xattrs --no-selinux);
1941 my $tar_pid = fork // die $!;
1943 chdir "../unpack-tar" or die $!;
1944 open STDIN, "<&", $input or die $!;
1946 die "dgit (child): exec $tarcmd[0]: $!";
1948 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1949 !$? or failedcmd @tarcmd;
1952 (@compr_cmd ? failedcmd @compr_cmd
1954 # finally, we have the results in "tarball", but maybe
1955 # with the wrong permissions
1957 runcmd qw(chmod -R +rwX ../unpack-tar);
1958 changedir "../unpack-tar";
1959 my ($tree) = mktree_in_ud_from_only_subdir(1);
1960 changedir "../../unpack";
1961 rmtree "../unpack-tar";
1963 my $ent = [ $f, $tree ];
1965 Orig => !!$orig_f_part,
1966 Sort => (!$orig_f_part ? 2 :
1967 $orig_f_part =~ m/-/g ? 1 :
1975 # put any without "_" first (spec is not clear whether files
1976 # are always in the usual order). Tarballs without "_" are
1977 # the main orig or the debian tarball.
1978 $a->{Sort} <=> $b->{Sort} or
1982 my $any_orig = grep { $_->{Orig} } @tartrees;
1984 my $dscfn = "$package.dsc";
1986 my $treeimporthow = 'package';
1988 open D, ">", $dscfn or die "$dscfn: $!";
1989 print D $dscdata or die "$dscfn: $!";
1990 close D or die "$dscfn: $!";
1991 my @cmd = qw(dpkg-source);
1992 push @cmd, '--no-check' if $dsc_checked;
1993 if (madformat $dsc->{format}) {
1994 push @cmd, '--skip-patches';
1995 $treeimporthow = 'unpatched';
1997 push @cmd, qw(-x --), $dscfn;
2000 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2001 if (madformat $dsc->{format}) {
2002 check_for_vendor_patches();
2006 if (madformat $dsc->{format}) {
2007 my @pcmd = qw(dpkg-source --before-build .);
2008 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2010 runcmd @git, qw(add -Af);
2011 $dappliedtree = git_write_tree();
2014 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2015 debugcmd "|",@clogcmd;
2016 open CLOGS, "-|", @clogcmd or die $!;
2021 printdebug "import clog search...\n";
2024 my $stanzatext = do { local $/=""; <CLOGS>; };
2025 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2026 last if !defined $stanzatext;
2028 my $desc = "package changelog, entry no.$.";
2029 open my $stanzafh, "<", \$stanzatext or die;
2030 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2031 $clogp //= $thisstanza;
2033 printdebug "import clog $thisstanza->{version} $desc...\n";
2035 last if !$any_orig; # we don't need $r1clogp
2037 # We look for the first (most recent) changelog entry whose
2038 # version number is lower than the upstream version of this
2039 # package. Then the last (least recent) previous changelog
2040 # entry is treated as the one which introduced this upstream
2041 # version and used for the synthetic commits for the upstream
2044 # One might think that a more sophisticated algorithm would be
2045 # necessary. But: we do not want to scan the whole changelog
2046 # file. Stopping when we see an earlier version, which
2047 # necessarily then is an earlier upstream version, is the only
2048 # realistic way to do that. Then, either the earliest
2049 # changelog entry we have seen so far is indeed the earliest
2050 # upload of this upstream version; or there are only changelog
2051 # entries relating to later upstream versions (which is not
2052 # possible unless the changelog and .dsc disagree about the
2053 # version). Then it remains to choose between the physically
2054 # last entry in the file, and the one with the lowest version
2055 # number. If these are not the same, we guess that the
2056 # versions were created in a non-monotic order rather than
2057 # that the changelog entries have been misordered.
2059 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2061 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2062 $r1clogp = $thisstanza;
2064 printdebug "import clog $r1clogp->{version} becomes r1\n";
2066 die $! if CLOGS->error;
2067 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2069 $clogp or fail "package changelog has no entries!";
2071 my $authline = clogp_authline $clogp;
2072 my $changes = getfield $clogp, 'Changes';
2073 my $cversion = getfield $clogp, 'Version';
2076 $r1clogp //= $clogp; # maybe there's only one entry;
2077 my $r1authline = clogp_authline $r1clogp;
2078 # Strictly, r1authline might now be wrong if it's going to be
2079 # unused because !$any_orig. Whatever.
2081 printdebug "import tartrees authline $authline\n";
2082 printdebug "import tartrees r1authline $r1authline\n";
2084 foreach my $tt (@tartrees) {
2085 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2087 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2090 committer $r1authline
2094 [dgit import orig $tt->{F}]
2102 [dgit import tarball $package $cversion $tt->{F}]
2107 printdebug "import main commit\n";
2109 open C, ">../commit.tmp" or die $!;
2110 print C <<END or die $!;
2113 print C <<END or die $! foreach @tartrees;
2116 print C <<END or die $!;
2122 [dgit import $treeimporthow $package $cversion]
2126 my $rawimport_hash = make_commit qw(../commit.tmp);
2128 if (madformat $dsc->{format}) {
2129 printdebug "import apply patches...\n";
2131 # regularise the state of the working tree so that
2132 # the checkout of $rawimport_hash works nicely.
2133 my $dappliedcommit = make_commit_text(<<END);
2140 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2142 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2144 # We need the answers to be reproducible
2145 my @authline = clogp_authline($clogp);
2146 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2147 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2148 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2149 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2150 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2151 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2153 my $path = $ENV{PATH} or die;
2155 foreach my $use_absurd (qw(0 1)) {
2156 local $ENV{PATH} = $path;
2159 progress "warning: $@";
2160 $path = "$absurdity:$path";
2161 progress "$us: trying slow absurd-git-apply...";
2162 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2167 die "forbid absurd git-apply\n" if $use_absurd
2168 && forceing [qw(import-gitapply-no-absurd)];
2169 die "only absurd git-apply!\n" if !$use_absurd
2170 && forceing [qw(import-gitapply-absurd)];
2172 local $ENV{PATH} = $path if $use_absurd;
2174 my @showcmd = (gbp_pq, qw(import));
2175 my @realcmd = shell_cmd
2176 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2177 debugcmd "+",@realcmd;
2178 if (system @realcmd) {
2179 die +(shellquote @showcmd).
2181 failedcmd_waitstatus()."\n";
2184 my $gapplied = git_rev_parse('HEAD');
2185 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2186 $gappliedtree eq $dappliedtree or
2188 gbp-pq import and dpkg-source disagree!
2189 gbp-pq import gave commit $gapplied
2190 gbp-pq import gave tree $gappliedtree
2191 dpkg-source --before-build gave tree $dappliedtree
2193 $rawimport_hash = $gapplied;
2198 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2203 progress "synthesised git commit from .dsc $cversion";
2205 my $rawimport_mergeinput = {
2206 Commit => $rawimport_hash,
2207 Info => "Import of source package",
2209 my @output = ($rawimport_mergeinput);
2211 if ($lastpush_mergeinput) {
2212 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2213 my $oversion = getfield $oldclogp, 'Version';
2215 version_compare($oversion, $cversion);
2217 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2218 { Message => <<END, ReverseParents => 1 });
2219 Record $package ($cversion) in archive suite $csuite
2221 } elsif ($vcmp > 0) {
2222 print STDERR <<END or die $!;
2224 Version actually in archive: $cversion (older)
2225 Last version pushed with dgit: $oversion (newer or same)
2228 @output = $lastpush_mergeinput;
2230 # Same version. Use what's in the server git branch,
2231 # discarding our own import. (This could happen if the
2232 # server automatically imports all packages into git.)
2233 @output = $lastpush_mergeinput;
2236 changedir '../../../..';
2241 sub complete_file_from_dsc ($$) {
2242 our ($dstdir, $fi) = @_;
2243 # Ensures that we have, in $dir, the file $fi, with the correct
2244 # contents. (Downloading it from alongside $dscurl if necessary.)
2246 my $f = $fi->{Filename};
2247 my $tf = "$dstdir/$f";
2250 if (stat_exists $tf) {
2251 progress "using existing $f";
2253 printdebug "$tf does not exist, need to fetch\n";
2255 $furl =~ s{/[^/]+$}{};
2257 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2258 die "$f ?" if $f =~ m#/#;
2259 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2260 return 0 if !act_local();
2264 open F, "<", "$tf" or die "$tf: $!";
2265 $fi->{Digester}->reset();
2266 $fi->{Digester}->addfile(*F);
2267 F->error and die $!;
2268 my $got = $fi->{Digester}->hexdigest();
2269 $got eq $fi->{Hash} or
2270 fail "file $f has hash $got but .dsc".
2271 " demands hash $fi->{Hash} ".
2272 ($downloaded ? "(got wrong file from archive!)"
2273 : "(perhaps you should delete this file?)");
2278 sub ensure_we_have_orig () {
2279 my @dfi = dsc_files_info();
2280 foreach my $fi (@dfi) {
2281 my $f = $fi->{Filename};
2282 next unless is_orig_file_in_dsc($f, \@dfi);
2283 complete_file_from_dsc('..', $fi)
2288 sub git_fetch_us () {
2289 # Want to fetch only what we are going to use, unless
2290 # deliberately-not-ff, in which case we must fetch everything.
2292 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2294 (quiltmode_splitbrain
2295 ? (map { $_->('*',access_nomdistro) }
2296 \&debiantag_new, \&debiantag_maintview)
2297 : debiantags('*',access_nomdistro));
2298 push @specs, server_branch($csuite);
2299 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2301 # This is rather miserable:
2302 # When git fetch --prune is passed a fetchspec ending with a *,
2303 # it does a plausible thing. If there is no * then:
2304 # - it matches subpaths too, even if the supplied refspec
2305 # starts refs, and behaves completely madly if the source
2306 # has refs/refs/something. (See, for example, Debian #NNNN.)
2307 # - if there is no matching remote ref, it bombs out the whole
2309 # We want to fetch a fixed ref, and we don't know in advance
2310 # if it exists, so this is not suitable.
2312 # Our workaround is to use git ls-remote. git ls-remote has its
2313 # own qairks. Notably, it has the absurd multi-tail-matching
2314 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2315 # refs/refs/foo etc.
2317 # Also, we want an idempotent snapshot, but we have to make two
2318 # calls to the remote: one to git ls-remote and to git fetch. The
2319 # solution is use git ls-remote to obtain a target state, and
2320 # git fetch to try to generate it. If we don't manage to generate
2321 # the target state, we try again.
2323 printdebug "git_fetch_us specs @specs\n";
2325 my $specre = join '|', map {
2331 printdebug "git_fetch_us specre=$specre\n";
2332 my $wanted_rref = sub {
2334 return m/^(?:$specre)$/o;
2337 my $fetch_iteration = 0;
2340 printdebug "git_fetch_us iteration $fetch_iteration\n";
2341 if (++$fetch_iteration > 10) {
2342 fail "too many iterations trying to get sane fetch!";
2345 my @look = map { "refs/$_" } @specs;
2346 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2350 open GITLS, "-|", @lcmd or die $!;
2352 printdebug "=> ", $_;
2353 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2354 my ($objid,$rrefname) = ($1,$2);
2355 if (!$wanted_rref->($rrefname)) {
2357 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2361 $wantr{$rrefname} = $objid;
2364 close GITLS or failedcmd @lcmd;
2366 # OK, now %want is exactly what we want for refs in @specs
2368 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2369 "+refs/$_:".lrfetchrefs."/$_";
2372 printdebug "git_fetch_us fspecs @fspecs\n";
2374 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2375 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2378 %lrfetchrefs_f = ();
2381 git_for_each_ref(lrfetchrefs, sub {
2382 my ($objid,$objtype,$lrefname,$reftail) = @_;
2383 $lrfetchrefs_f{$lrefname} = $objid;
2384 $objgot{$objid} = 1;
2387 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2388 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2389 if (!exists $wantr{$rrefname}) {
2390 if ($wanted_rref->($rrefname)) {
2392 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2396 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2399 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2400 delete $lrfetchrefs_f{$lrefname};
2404 foreach my $rrefname (sort keys %wantr) {
2405 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2406 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2407 my $want = $wantr{$rrefname};
2408 next if $got eq $want;
2409 if (!defined $objgot{$want}) {
2411 warning: git ls-remote suggests we want $lrefname
2412 warning: and it should refer to $want
2413 warning: but git fetch didn't fetch that object to any relevant ref.
2414 warning: This may be due to a race with someone updating the server.
2415 warning: Will try again...
2417 next FETCH_ITERATION;
2420 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2422 runcmd_ordryrun_local @git, qw(update-ref -m),
2423 "dgit fetch git fetch fixup", $lrefname, $want;
2424 $lrfetchrefs_f{$lrefname} = $want;
2428 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2429 Dumper(\%lrfetchrefs_f);
2432 my @tagpats = debiantags('*',access_nomdistro);
2434 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2435 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2436 printdebug "currently $fullrefname=$objid\n";
2437 $here{$fullrefname} = $objid;
2439 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2440 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2441 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2442 printdebug "offered $lref=$objid\n";
2443 if (!defined $here{$lref}) {
2444 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2445 runcmd_ordryrun_local @upd;
2446 lrfetchref_used $fullrefname;
2447 } elsif ($here{$lref} eq $objid) {
2448 lrfetchref_used $fullrefname;
2451 "Not updateting $lref from $here{$lref} to $objid.\n";
2456 sub mergeinfo_getclogp ($) {
2457 # Ensures thit $mi->{Clogp} exists and returns it
2459 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2462 sub mergeinfo_version ($) {
2463 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2466 sub fetch_from_archive () {
2467 ensure_setup_existing_tree();
2469 # Ensures that lrref() is what is actually in the archive, one way
2470 # or another, according to us - ie this client's
2471 # appropritaely-updated archive view. Also returns the commit id.
2472 # If there is nothing in the archive, leaves lrref alone and
2473 # returns undef. git_fetch_us must have already been called.
2477 foreach my $field (@ourdscfield) {
2478 $dsc_hash = $dsc->{$field};
2479 last if defined $dsc_hash;
2481 if (defined $dsc_hash) {
2482 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2484 progress "last upload to archive specified git hash";
2486 progress "last upload to archive has NO git hash";
2489 progress "no version available from the archive";
2492 # If the archive's .dsc has a Dgit field, there are three
2493 # relevant git commitids we need to choose between and/or merge
2495 # 1. $dsc_hash: the Dgit field from the archive
2496 # 2. $lastpush_hash: the suite branch on the dgit git server
2497 # 3. $lastfetch_hash: our local tracking brach for the suite
2499 # These may all be distinct and need not be in any fast forward
2502 # If the dsc was pushed to this suite, then the server suite
2503 # branch will have been updated; but it might have been pushed to
2504 # a different suite and copied by the archive. Conversely a more
2505 # recent version may have been pushed with dgit but not appeared
2506 # in the archive (yet).
2508 # $lastfetch_hash may be awkward because archive imports
2509 # (particularly, imports of Dgit-less .dscs) are performed only as
2510 # needed on individual clients, so different clients may perform a
2511 # different subset of them - and these imports are only made
2512 # public during push. So $lastfetch_hash may represent a set of
2513 # imports different to a subsequent upload by a different dgit
2516 # Our approach is as follows:
2518 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2519 # descendant of $dsc_hash, then it was pushed by a dgit user who
2520 # had based their work on $dsc_hash, so we should prefer it.
2521 # Otherwise, $dsc_hash was installed into this suite in the
2522 # archive other than by a dgit push, and (necessarily) after the
2523 # last dgit push into that suite (since a dgit push would have
2524 # been descended from the dgit server git branch); thus, in that
2525 # case, we prefer the archive's version (and produce a
2526 # pseudo-merge to overwrite the dgit server git branch).
2528 # (If there is no Dgit field in the archive's .dsc then
2529 # generate_commit_from_dsc uses the version numbers to decide
2530 # whether the suite branch or the archive is newer. If the suite
2531 # branch is newer it ignores the archive's .dsc; otherwise it
2532 # generates an import of the .dsc, and produces a pseudo-merge to
2533 # overwrite the suite branch with the archive contents.)
2535 # The outcome of that part of the algorithm is the `public view',
2536 # and is same for all dgit clients: it does not depend on any
2537 # unpublished history in the local tracking branch.
2539 # As between the public view and the local tracking branch: The
2540 # local tracking branch is only updated by dgit fetch, and
2541 # whenever dgit fetch runs it includes the public view in the
2542 # local tracking branch. Therefore if the public view is not
2543 # descended from the local tracking branch, the local tracking
2544 # branch must contain history which was imported from the archive
2545 # but never pushed; and, its tip is now out of date. So, we make
2546 # a pseudo-merge to overwrite the old imports and stitch the old
2549 # Finally: we do not necessarily reify the public view (as
2550 # described above). This is so that we do not end up stacking two
2551 # pseudo-merges. So what we actually do is figure out the inputs
2552 # to any public view pseudo-merge and put them in @mergeinputs.
2555 # $mergeinputs[]{Commit}
2556 # $mergeinputs[]{Info}
2557 # $mergeinputs[0] is the one whose tree we use
2558 # @mergeinputs is in the order we use in the actual commit)
2561 # $mergeinputs[]{Message} is a commit message to use
2562 # $mergeinputs[]{ReverseParents} if def specifies that parent
2563 # list should be in opposite order
2564 # Such an entry has no Commit or Info. It applies only when found
2565 # in the last entry. (This ugliness is to support making
2566 # identical imports to previous dgit versions.)
2568 my $lastpush_hash = git_get_ref(lrfetchref());
2569 printdebug "previous reference hash=$lastpush_hash\n";
2570 $lastpush_mergeinput = $lastpush_hash && {
2571 Commit => $lastpush_hash,
2572 Info => "dgit suite branch on dgit git server",
2575 my $lastfetch_hash = git_get_ref(lrref());
2576 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2577 my $lastfetch_mergeinput = $lastfetch_hash && {
2578 Commit => $lastfetch_hash,
2579 Info => "dgit client's archive history view",
2582 my $dsc_mergeinput = $dsc_hash && {
2583 Commit => $dsc_hash,
2584 Info => "Dgit field in .dsc from archive",
2588 my $del_lrfetchrefs = sub {
2591 printdebug "del_lrfetchrefs...\n";
2592 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2593 my $objid = $lrfetchrefs_d{$fullrefname};
2594 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2596 $gur ||= new IO::Handle;
2597 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2599 printf $gur "delete %s %s\n", $fullrefname, $objid;
2602 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2606 if (defined $dsc_hash) {
2607 ensure_we_have_orig();
2608 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2609 @mergeinputs = $dsc_mergeinput
2610 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2611 print STDERR <<END or die $!;
2613 Git commit in archive is behind the last version allegedly pushed/uploaded.
2614 Commit referred to by archive: $dsc_hash
2615 Last version pushed with dgit: $lastpush_hash
2618 @mergeinputs = ($lastpush_mergeinput);
2620 # Archive has .dsc which is not a descendant of the last dgit
2621 # push. This can happen if the archive moves .dscs about.
2622 # Just follow its lead.
2623 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2624 progress "archive .dsc names newer git commit";
2625 @mergeinputs = ($dsc_mergeinput);
2627 progress "archive .dsc names other git commit, fixing up";
2628 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2632 @mergeinputs = generate_commits_from_dsc();
2633 # We have just done an import. Now, our import algorithm might
2634 # have been improved. But even so we do not want to generate
2635 # a new different import of the same package. So if the
2636 # version numbers are the same, just use our existing version.
2637 # If the version numbers are different, the archive has changed
2638 # (perhaps, rewound).
2639 if ($lastfetch_mergeinput &&
2640 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2641 (mergeinfo_version $mergeinputs[0]) )) {
2642 @mergeinputs = ($lastfetch_mergeinput);
2644 } elsif ($lastpush_hash) {
2645 # only in git, not in the archive yet
2646 @mergeinputs = ($lastpush_mergeinput);
2647 print STDERR <<END or die $!;
2649 Package not found in the archive, but has allegedly been pushed using dgit.
2653 printdebug "nothing found!\n";
2654 if (defined $skew_warning_vsn) {
2655 print STDERR <<END or die $!;
2657 Warning: relevant archive skew detected.
2658 Archive allegedly contains $skew_warning_vsn
2659 But we were not able to obtain any version from the archive or git.
2663 unshift @end, $del_lrfetchrefs;
2667 if ($lastfetch_hash &&
2669 my $h = $_->{Commit};
2670 $h and is_fast_fwd($lastfetch_hash, $h);
2671 # If true, one of the existing parents of this commit
2672 # is a descendant of the $lastfetch_hash, so we'll
2673 # be ff from that automatically.
2677 push @mergeinputs, $lastfetch_mergeinput;
2680 printdebug "fetch mergeinfos:\n";
2681 foreach my $mi (@mergeinputs) {
2683 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2685 printdebug sprintf " ReverseParents=%d Message=%s",
2686 $mi->{ReverseParents}, $mi->{Message};
2690 my $compat_info= pop @mergeinputs
2691 if $mergeinputs[$#mergeinputs]{Message};
2693 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2696 if (@mergeinputs > 1) {
2698 my $tree_commit = $mergeinputs[0]{Commit};
2700 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2701 $tree =~ m/\n\n/; $tree = $`;
2702 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2705 # We use the changelog author of the package in question the
2706 # author of this pseudo-merge. This is (roughly) correct if
2707 # this commit is simply representing aa non-dgit upload.
2708 # (Roughly because it does not record sponsorship - but we
2709 # don't have sponsorship info because that's in the .changes,
2710 # which isn't in the archivw.)
2712 # But, it might be that we are representing archive history
2713 # updates (including in-archive copies). These are not really
2714 # the responsibility of the person who created the .dsc, but
2715 # there is no-one whose name we should better use. (The
2716 # author of the .dsc-named commit is clearly worse.)
2718 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2719 my $author = clogp_authline $useclogp;
2720 my $cversion = getfield $useclogp, 'Version';
2722 my $mcf = ".git/dgit/mergecommit";
2723 open MC, ">", $mcf or die "$mcf $!";
2724 print MC <<END or die $!;
2728 my @parents = grep { $_->{Commit} } @mergeinputs;
2729 @parents = reverse @parents if $compat_info->{ReverseParents};
2730 print MC <<END or die $! foreach @parents;
2734 print MC <<END or die $!;
2740 if (defined $compat_info->{Message}) {
2741 print MC $compat_info->{Message} or die $!;
2743 print MC <<END or die $!;
2744 Record $package ($cversion) in archive suite $csuite
2748 my $message_add_info = sub {
2750 my $mversion = mergeinfo_version $mi;
2751 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2755 $message_add_info->($mergeinputs[0]);
2756 print MC <<END or die $!;
2757 should be treated as descended from
2759 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2763 $hash = make_commit $mcf;
2765 $hash = $mergeinputs[0]{Commit};
2767 printdebug "fetch hash=$hash\n";
2770 my ($lasth, $what) = @_;
2771 return unless $lasth;
2772 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2775 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2777 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2779 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2780 'DGIT_ARCHIVE', $hash;
2781 cmdoutput @git, qw(log -n2), $hash;
2782 # ... gives git a chance to complain if our commit is malformed
2784 if (defined $skew_warning_vsn) {
2786 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2787 my $gotclogp = commit_getclogp($hash);
2788 my $got_vsn = getfield $gotclogp, 'Version';
2789 printdebug "SKEW CHECK GOT $got_vsn\n";
2790 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2791 print STDERR <<END or die $!;
2793 Warning: archive skew detected. Using the available version:
2794 Archive allegedly contains $skew_warning_vsn
2795 We were able to obtain only $got_vsn
2801 if ($lastfetch_hash ne $hash) {
2802 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2806 dryrun_report @upd_cmd;
2810 lrfetchref_used lrfetchref();
2812 unshift @end, $del_lrfetchrefs;
2816 sub set_local_git_config ($$) {
2818 runcmd @git, qw(config), $k, $v;
2821 sub setup_mergechangelogs (;$) {
2823 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2825 my $driver = 'dpkg-mergechangelogs';
2826 my $cb = "merge.$driver";
2827 my $attrs = '.git/info/attributes';
2828 ensuredir '.git/info';
2830 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2831 if (!open ATTRS, "<", $attrs) {
2832 $!==ENOENT or die "$attrs: $!";
2836 next if m{^debian/changelog\s};
2837 print NATTRS $_, "\n" or die $!;
2839 ATTRS->error and die $!;
2842 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2845 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2846 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2848 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2851 sub setup_useremail (;$) {
2853 return unless $always || access_cfg_bool(1, 'setup-useremail');
2856 my ($k, $envvar) = @_;
2857 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2858 return unless defined $v;
2859 set_local_git_config "user.$k", $v;
2862 $setup->('email', 'DEBEMAIL');
2863 $setup->('name', 'DEBFULLNAME');
2866 sub ensure_setup_existing_tree () {
2867 my $k = "remote.$remotename.skipdefaultupdate";
2868 my $c = git_get_config $k;
2869 return if defined $c;
2870 set_local_git_config $k, 'true';
2873 sub setup_new_tree () {
2874 setup_mergechangelogs();
2880 canonicalise_suite();
2881 badusage "dry run makes no sense with clone" unless act_local();
2882 my $hasgit = check_for_git();
2883 mkdir $dstdir or fail "create \`$dstdir': $!";
2885 runcmd @git, qw(init -q);
2886 my $giturl = access_giturl(1);
2887 if (defined $giturl) {
2888 open H, "> .git/HEAD" or die $!;
2889 print H "ref: ".lref()."\n" or die $!;
2891 runcmd @git, qw(remote add), 'origin', $giturl;
2894 progress "fetching existing git history";
2896 runcmd_ordryrun_local @git, qw(fetch origin);
2898 progress "starting new git history";
2900 fetch_from_archive() or no_such_package;
2901 my $vcsgiturl = $dsc->{'Vcs-Git'};
2902 if (length $vcsgiturl) {
2903 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2904 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2907 runcmd @git, qw(reset --hard), lrref();
2908 runcmd qw(bash -ec), <<'END';
2910 git ls-tree -r --name-only -z HEAD | \
2911 xargs -0r touch -r . --
2913 printdone "ready for work in $dstdir";
2917 if (check_for_git()) {
2920 fetch_from_archive() or no_such_package();
2921 printdone "fetched into ".lrref();
2926 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2928 printdone "fetched to ".lrref()." and merged into HEAD";
2931 sub check_not_dirty () {
2932 foreach my $f (qw(local-options local-patch-header)) {
2933 if (stat_exists "debian/source/$f") {
2934 fail "git tree contains debian/source/$f";
2938 return if $ignoredirty;
2940 my @cmd = (@git, qw(diff --quiet HEAD));
2942 $!=0; $?=-1; system @cmd;
2945 fail "working tree is dirty (does not match HEAD)";
2951 sub commit_admin ($) {
2954 runcmd_ordryrun_local @git, qw(commit -m), $m;
2957 sub commit_quilty_patch () {
2958 my $output = cmdoutput @git, qw(status --porcelain);
2960 foreach my $l (split /\n/, $output) {
2961 next unless $l =~ m/\S/;
2962 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2966 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2968 progress "nothing quilty to commit, ok.";
2971 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2972 runcmd_ordryrun_local @git, qw(add -f), @adds;
2974 Commit Debian 3.0 (quilt) metadata
2976 [dgit ($our_version) quilt-fixup]
2980 sub get_source_format () {
2982 if (open F, "debian/source/options") {
2986 s/\s+$//; # ignore missing final newline
2988 my ($k, $v) = ($`, $'); #');
2989 $v =~ s/^"(.*)"$/$1/;
2995 F->error and die $!;
2998 die $! unless $!==&ENOENT;
3001 if (!open F, "debian/source/format") {
3002 die $! unless $!==&ENOENT;
3006 F->error and die $!;
3008 return ($_, \%options);
3011 sub madformat_wantfixup ($) {
3013 return 0 unless $format eq '3.0 (quilt)';
3014 our $quilt_mode_warned;
3015 if ($quilt_mode eq 'nocheck') {
3016 progress "Not doing any fixup of \`$format' due to".
3017 " ----no-quilt-fixup or --quilt=nocheck"
3018 unless $quilt_mode_warned++;
3021 progress "Format \`$format', need to check/update patch stack"
3022 unless $quilt_mode_warned++;
3026 sub maybe_split_brain_save ($$$) {
3027 my ($headref, $dgitview, $msg) = @_;
3028 # => message fragment "$saved" describing disposition of $dgitview
3029 return "commit id $dgitview" unless defined $split_brain_save;
3030 my @cmd = (shell_cmd "cd ../../../..",
3031 @git, qw(update-ref -m),
3032 "dgit --dgit-view-save $msg HEAD=$headref",
3033 $split_brain_save, $dgitview);
3035 return "and left in $split_brain_save";
3038 # An "infopair" is a tuple [ $thing, $what ]
3039 # (often $thing is a commit hash; $what is a description)
3041 sub infopair_cond_equal ($$) {
3043 $x->[0] eq $y->[0] or fail <<END;
3044 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3048 sub infopair_lrf_tag_lookup ($$) {
3049 my ($tagnames, $what) = @_;
3050 # $tagname may be an array ref
3051 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3052 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3053 foreach my $tagname (@tagnames) {
3054 my $lrefname = lrfetchrefs."/tags/$tagname";
3055 my $tagobj = $lrfetchrefs_f{$lrefname};
3056 next unless defined $tagobj;
3057 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3058 return [ git_rev_parse($tagobj), $what ];
3060 fail @tagnames==1 ? <<END : <<END;
3061 Wanted tag $what (@tagnames) on dgit server, but not found
3063 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3067 sub infopair_cond_ff ($$) {
3068 my ($anc,$desc) = @_;
3069 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3070 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3074 sub pseudomerge_version_check ($$) {
3075 my ($clogp, $archive_hash) = @_;
3077 my $arch_clogp = commit_getclogp $archive_hash;
3078 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3079 'version currently in archive' ];
3080 if (defined $overwrite_version) {
3081 if (length $overwrite_version) {
3082 infopair_cond_equal([ $overwrite_version,
3083 '--overwrite= version' ],
3086 my $v = $i_arch_v->[0];
3087 progress "Checking package changelog for archive version $v ...";
3089 my @xa = ("-f$v", "-t$v");
3090 my $vclogp = parsechangelog @xa;
3091 my $cv = [ (getfield $vclogp, 'Version'),
3092 "Version field from dpkg-parsechangelog @xa" ];
3093 infopair_cond_equal($i_arch_v, $cv);
3096 $@ =~ s/^dgit: //gm;
3098 "Perhaps debian/changelog does not mention $v ?";
3103 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3107 sub pseudomerge_make_commit ($$$$ $$) {
3108 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3109 $msg_cmd, $msg_msg) = @_;
3110 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3112 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3113 my $authline = clogp_authline $clogp;
3117 !defined $overwrite_version ? ""
3118 : !length $overwrite_version ? " --overwrite"
3119 : " --overwrite=".$overwrite_version;
3122 my $pmf = ".git/dgit/pseudomerge";
3123 open MC, ">", $pmf or die "$pmf $!";
3124 print MC <<END or die $!;
3127 parent $archive_hash
3137 return make_commit($pmf);
3140 sub splitbrain_pseudomerge ($$$$) {
3141 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3142 # => $merged_dgitview
3143 printdebug "splitbrain_pseudomerge...\n";
3145 # We: debian/PREVIOUS HEAD($maintview)
3146 # expect: o ----------------- o
3149 # a/d/PREVIOUS $dgitview
3152 # we do: `------------------ o
3156 return $dgitview unless defined $archive_hash;
3158 printdebug "splitbrain_pseudomerge...\n";
3160 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3162 if (!defined $overwrite_version) {
3163 progress "Checking that HEAD inciudes all changes in archive...";
3166 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3168 if (defined $overwrite_version) {
3170 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3171 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3172 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3173 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3174 my $i_archive = [ $archive_hash, "current archive contents" ];
3176 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3178 infopair_cond_equal($i_dgit, $i_archive);
3179 infopair_cond_ff($i_dep14, $i_dgit);
3180 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3184 $us: check failed (maybe --overwrite is needed, consult documentation)
3189 my $r = pseudomerge_make_commit
3190 $clogp, $dgitview, $archive_hash, $i_arch_v,
3191 "dgit --quilt=$quilt_mode",
3192 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3193 Declare fast forward from $i_arch_v->[0]
3195 Make fast forward from $i_arch_v->[0]
3198 maybe_split_brain_save $maintview, $r, "pseudomerge";
3200 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3204 sub plain_overwrite_pseudomerge ($$$) {
3205 my ($clogp, $head, $archive_hash) = @_;
3207 printdebug "plain_overwrite_pseudomerge...";
3209 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3211 return $head if is_fast_fwd $archive_hash, $head;
3213 my $m = "Declare fast forward from $i_arch_v->[0]";
3215 my $r = pseudomerge_make_commit
3216 $clogp, $head, $archive_hash, $i_arch_v,
3219 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3221 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3225 sub push_parse_changelog ($) {
3228 my $clogp = Dpkg::Control::Hash->new();
3229 $clogp->load($clogpfn) or die;
3231 my $clogpackage = getfield $clogp, 'Source';
3232 $package //= $clogpackage;
3233 fail "-p specified $package but changelog specified $clogpackage"
3234 unless $package eq $clogpackage;
3235 my $cversion = getfield $clogp, 'Version';
3236 my $tag = debiantag($cversion, access_nomdistro);
3237 runcmd @git, qw(check-ref-format), $tag;
3239 my $dscfn = dscfn($cversion);
3241 return ($clogp, $cversion, $dscfn);
3244 sub push_parse_dsc ($$$) {
3245 my ($dscfn,$dscfnwhat, $cversion) = @_;
3246 $dsc = parsecontrol($dscfn,$dscfnwhat);
3247 my $dversion = getfield $dsc, 'Version';
3248 my $dscpackage = getfield $dsc, 'Source';
3249 ($dscpackage eq $package && $dversion eq $cversion) or
3250 fail "$dscfn is for $dscpackage $dversion".
3251 " but debian/changelog is for $package $cversion";
3254 sub push_tagwants ($$$$) {
3255 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3258 TagFn => \&debiantag,
3263 if (defined $maintviewhead) {
3265 TagFn => \&debiantag_maintview,
3266 Objid => $maintviewhead,
3267 TfSuffix => '-maintview',
3271 foreach my $tw (@tagwants) {
3272 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3273 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3275 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3279 sub push_mktags ($$ $$ $) {
3281 $changesfile,$changesfilewhat,
3284 die unless $tagwants->[0]{View} eq 'dgit';
3286 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3287 $dsc->save("$dscfn.tmp") or die $!;
3289 my $changes = parsecontrol($changesfile,$changesfilewhat);
3290 foreach my $field (qw(Source Distribution Version)) {
3291 $changes->{$field} eq $clogp->{$field} or
3292 fail "changes field $field \`$changes->{$field}'".
3293 " does not match changelog \`$clogp->{$field}'";
3296 my $cversion = getfield $clogp, 'Version';
3297 my $clogsuite = getfield $clogp, 'Distribution';
3299 # We make the git tag by hand because (a) that makes it easier
3300 # to control the "tagger" (b) we can do remote signing
3301 my $authline = clogp_authline $clogp;
3302 my $delibs = join(" ", "",@deliberatelies);
3303 my $declaredistro = access_nomdistro();
3307 my $tfn = $tw->{Tfn};
3308 my $head = $tw->{Objid};
3309 my $tag = $tw->{Tag};
3311 open TO, '>', $tfn->('.tmp') or die $!;
3312 print TO <<END or die $!;
3319 if ($tw->{View} eq 'dgit') {
3320 print TO <<END or die $!;
3321 $package release $cversion for $clogsuite ($csuite) [dgit]
3322 [dgit distro=$declaredistro$delibs]
3324 foreach my $ref (sort keys %previously) {
3325 print TO <<END or die $!;
3326 [dgit previously:$ref=$previously{$ref}]
3329 } elsif ($tw->{View} eq 'maint') {
3330 print TO <<END or die $!;
3331 $package release $cversion for $clogsuite ($csuite)
3332 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3335 die Dumper($tw)."?";
3340 my $tagobjfn = $tfn->('.tmp');
3342 if (!defined $keyid) {
3343 $keyid = access_cfg('keyid','RETURN-UNDEF');
3345 if (!defined $keyid) {
3346 $keyid = getfield $clogp, 'Maintainer';
3348 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3349 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3350 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3351 push @sign_cmd, $tfn->('.tmp');
3352 runcmd_ordryrun @sign_cmd;
3354 $tagobjfn = $tfn->('.signed.tmp');
3355 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3356 $tfn->('.tmp'), $tfn->('.tmp.asc');
3362 my @r = map { $mktag->($_); } @$tagwants;
3366 sub sign_changes ($) {
3367 my ($changesfile) = @_;
3369 my @debsign_cmd = @debsign;
3370 push @debsign_cmd, "-k$keyid" if defined $keyid;
3371 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3372 push @debsign_cmd, $changesfile;
3373 runcmd_ordryrun @debsign_cmd;
3378 printdebug "actually entering push\n";
3380 supplementary_message(<<'END');
3381 Push failed, while checking state of the archive.
3382 You can retry the push, after fixing the problem, if you like.
3384 if (check_for_git()) {
3387 my $archive_hash = fetch_from_archive();
3388 if (!$archive_hash) {
3390 fail "package appears to be new in this suite;".
3391 " if this is intentional, use --new";
3394 supplementary_message(<<'END');
3395 Push failed, while preparing your push.
3396 You can retry the push, after fixing the problem, if you like.
3399 need_tagformat 'new', "quilt mode $quilt_mode"
3400 if quiltmode_splitbrain;
3404 access_giturl(); # check that success is vaguely likely
3407 my $clogpfn = ".git/dgit/changelog.822.tmp";
3408 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3410 responder_send_file('parsed-changelog', $clogpfn);
3412 my ($clogp, $cversion, $dscfn) =
3413 push_parse_changelog("$clogpfn");
3415 my $dscpath = "$buildproductsdir/$dscfn";
3416 stat_exists $dscpath or
3417 fail "looked for .dsc $dscfn, but $!;".
3418 " maybe you forgot to build";
3420 responder_send_file('dsc', $dscpath);
3422 push_parse_dsc($dscpath, $dscfn, $cversion);
3424 my $format = getfield $dsc, 'Format';
3425 printdebug "format $format\n";
3427 my $actualhead = git_rev_parse('HEAD');
3428 my $dgithead = $actualhead;
3429 my $maintviewhead = undef;
3431 my $upstreamversion = upstreamversion $clogp->{Version};
3433 if (madformat_wantfixup($format)) {
3434 # user might have not used dgit build, so maybe do this now:
3435 if (quiltmode_splitbrain()) {
3437 quilt_make_fake_dsc($upstreamversion);
3439 ($dgithead, $cachekey) =
3440 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3442 "--quilt=$quilt_mode but no cached dgit view:
3443 perhaps tree changed since dgit build[-source] ?";
3445 $dgithead = splitbrain_pseudomerge($clogp,
3446 $actualhead, $dgithead,
3448 $maintviewhead = $actualhead;
3449 changedir '../../../..';
3450 prep_ud(); # so _only_subdir() works, below
3452 commit_quilty_patch();
3456 if (defined $overwrite_version && !defined $maintviewhead) {
3457 $dgithead = plain_overwrite_pseudomerge($clogp,
3465 if ($archive_hash) {
3466 if (is_fast_fwd($archive_hash, $dgithead)) {
3468 } elsif (deliberately_not_fast_forward) {
3471 fail "dgit push: HEAD is not a descendant".
3472 " of the archive's version.\n".
3473 "To overwrite the archive's contents,".
3474 " pass --overwrite[=VERSION].\n".
3475 "To rewind history, if permitted by the archive,".
3476 " use --deliberately-not-fast-forward.";
3481 progress "checking that $dscfn corresponds to HEAD";
3482 runcmd qw(dpkg-source -x --),
3483 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3484 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3485 check_for_vendor_patches() if madformat($dsc->{format});
3486 changedir '../../../..';
3487 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3488 debugcmd "+",@diffcmd;
3490 my $r = system @diffcmd;
3493 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3495 HEAD specifies a different tree to $dscfn:
3497 Perhaps you forgot to build. Or perhaps there is a problem with your
3498 source tree (see dgit(7) for some hints). To see a full diff, run
3505 if (!$changesfile) {
3506 my $pat = changespat $cversion;
3507 my @cs = glob "$buildproductsdir/$pat";
3508 fail "failed to find unique changes file".
3509 " (looked for $pat in $buildproductsdir);".
3510 " perhaps you need to use dgit -C"
3512 ($changesfile) = @cs;
3514 $changesfile = "$buildproductsdir/$changesfile";
3517 # Check that changes and .dsc agree enough
3518 $changesfile =~ m{[^/]*$};
3519 my $changes = parsecontrol($changesfile,$&);
3520 files_compare_inputs($dsc, $changes)
3521 unless forceing [qw(dsc-changes-mismatch)];
3523 # Perhaps adjust .dsc to contain right set of origs
3524 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3526 unless forceing [qw(changes-origs-exactly)];
3528 # Checks complete, we're going to try and go ahead:
3530 responder_send_file('changes',$changesfile);
3531 responder_send_command("param head $dgithead");
3532 responder_send_command("param csuite $csuite");
3533 responder_send_command("param tagformat $tagformat");
3534 if (defined $maintviewhead) {
3535 die unless ($protovsn//4) >= 4;
3536 responder_send_command("param maint-view $maintviewhead");
3539 if (deliberately_not_fast_forward) {
3540 git_for_each_ref(lrfetchrefs, sub {
3541 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3542 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3543 responder_send_command("previously $rrefname=$objid");
3544 $previously{$rrefname} = $objid;
3548 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3552 supplementary_message(<<'END');
3553 Push failed, while signing the tag.
3554 You can retry the push, after fixing the problem, if you like.
3556 # If we manage to sign but fail to record it anywhere, it's fine.
3557 if ($we_are_responder) {
3558 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3559 responder_receive_files('signed-tag', @tagobjfns);
3561 @tagobjfns = push_mktags($clogp,$dscpath,
3562 $changesfile,$changesfile,
3565 supplementary_message(<<'END');
3566 Push failed, *after* signing the tag.
3567 If you want to try again, you should use a new version number.
3570 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3572 foreach my $tw (@tagwants) {
3573 my $tag = $tw->{Tag};
3574 my $tagobjfn = $tw->{TagObjFn};
3576 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3577 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3578 runcmd_ordryrun_local
3579 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3582 supplementary_message(<<'END');
3583 Push failed, while updating the remote git repository - see messages above.
3584 If you want to try again, you should use a new version number.
3586 if (!check_for_git()) {
3587 create_remote_git_repo();
3590 my @pushrefs = $forceflag.$dgithead.":".rrref();
3591 foreach my $tw (@tagwants) {
3592 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3595 runcmd_ordryrun @git,
3596 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3597 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3599 supplementary_message(<<'END');
3600 Push failed, after updating the remote git repository.
3601 If you want to try again, you must use a new version number.
3603 if ($we_are_responder) {
3604 my $dryrunsuffix = act_local() ? "" : ".tmp";
3605 responder_receive_files('signed-dsc-changes',
3606 "$dscpath$dryrunsuffix",
3607 "$changesfile$dryrunsuffix");
3610 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3612 progress "[new .dsc left in $dscpath.tmp]";
3614 sign_changes $changesfile;
3617 supplementary_message(<<END);
3618 Push failed, while uploading package(s) to the archive server.
3619 You can retry the upload of exactly these same files with dput of:
3621 If that .changes file is broken, you will need to use a new version
3622 number for your next attempt at the upload.
3624 my $host = access_cfg('upload-host','RETURN-UNDEF');
3625 my @hostarg = defined($host) ? ($host,) : ();
3626 runcmd_ordryrun @dput, @hostarg, $changesfile;
3627 printdone "pushed and uploaded $cversion";
3629 supplementary_message('');
3630 responder_send_command("complete");
3637 badusage "-p is not allowed with clone; specify as argument instead"
3638 if defined $package;
3641 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3642 ($package,$isuite) = @ARGV;
3643 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3644 ($package,$dstdir) = @ARGV;
3645 } elsif (@ARGV==3) {
3646 ($package,$isuite,$dstdir) = @ARGV;
3648 badusage "incorrect arguments to dgit clone";
3650 $dstdir ||= "$package";
3652 if (stat_exists $dstdir) {
3653 fail "$dstdir already exists";
3657 if ($rmonerror && !$dryrun_level) {
3658 $cwd_remove= getcwd();
3660 return unless defined $cwd_remove;
3661 if (!chdir "$cwd_remove") {
3662 return if $!==&ENOENT;
3663 die "chdir $cwd_remove: $!";
3666 rmtree($dstdir) or die "remove $dstdir: $!\n";
3667 } elsif (grep { $! == $_ }
3668 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3670 print STDERR "check whether to remove $dstdir: $!\n";
3676 $cwd_remove = undef;
3679 sub branchsuite () {
3680 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3681 if ($branch =~ m#$lbranch_re#o) {
3688 sub fetchpullargs () {
3690 if (!defined $package) {
3691 my $sourcep = parsecontrol('debian/control','debian/control');
3692 $package = getfield $sourcep, 'Source';
3695 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3697 my $clogp = parsechangelog();
3698 $isuite = getfield $clogp, 'Distribution';
3700 canonicalise_suite();
3701 progress "fetching from suite $csuite";
3702 } elsif (@ARGV==1) {
3704 canonicalise_suite();
3706 badusage "incorrect arguments to dgit fetch or dgit pull";
3719 if (quiltmode_splitbrain()) {
3720 my ($format, $fopts) = get_source_format();
3721 madformat($format) and fail <<END
3722 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3731 badusage "-p is not allowed with dgit push" if defined $package;
3733 my $clogp = parsechangelog();
3734 $package = getfield $clogp, 'Source';
3737 } elsif (@ARGV==1) {
3738 ($specsuite) = (@ARGV);
3740 badusage "incorrect arguments to dgit push";
3742 $isuite = getfield $clogp, 'Distribution';
3744 local ($package) = $existing_package; # this is a hack
3745 canonicalise_suite();
3747 canonicalise_suite();
3749 if (defined $specsuite &&
3750 $specsuite ne $isuite &&
3751 $specsuite ne $csuite) {
3752 fail "dgit push: changelog specifies $isuite ($csuite)".
3753 " but command line specifies $specsuite";
3758 #---------- remote commands' implementation ----------
3760 sub cmd_remote_push_build_host {
3761 my ($nrargs) = shift @ARGV;
3762 my (@rargs) = @ARGV[0..$nrargs-1];
3763 @ARGV = @ARGV[$nrargs..$#ARGV];
3765 my ($dir,$vsnwant) = @rargs;
3766 # vsnwant is a comma-separated list; we report which we have
3767 # chosen in our ready response (so other end can tell if they
3770 $we_are_responder = 1;
3771 $us .= " (build host)";
3775 open PI, "<&STDIN" or die $!;
3776 open STDIN, "/dev/null" or die $!;
3777 open PO, ">&STDOUT" or die $!;
3779 open STDOUT, ">&STDERR" or die $!;
3783 ($protovsn) = grep {
3784 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3785 } @rpushprotovsn_support;
3787 fail "build host has dgit rpush protocol versions ".
3788 (join ",", @rpushprotovsn_support).
3789 " but invocation host has $vsnwant"
3790 unless defined $protovsn;
3792 responder_send_command("dgit-remote-push-ready $protovsn");
3793 rpush_handle_protovsn_bothends();
3798 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3799 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3800 # a good error message)
3802 sub rpush_handle_protovsn_bothends () {
3803 if ($protovsn < 4) {
3804 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3813 my $report = i_child_report();
3814 if (defined $report) {
3815 printdebug "($report)\n";
3816 } elsif ($i_child_pid) {
3817 printdebug "(killing build host child $i_child_pid)\n";
3818 kill 15, $i_child_pid;
3820 if (defined $i_tmp && !defined $initiator_tempdir) {
3822 eval { rmtree $i_tmp; };
3826 END { i_cleanup(); }
3829 my ($base,$selector,@args) = @_;
3830 $selector =~ s/\-/_/g;
3831 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3838 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3846 push @rargs, join ",", @rpushprotovsn_support;
3849 push @rdgit, @ropts;
3850 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3852 my @cmd = (@ssh, $host, shellquote @rdgit);
3855 if (defined $initiator_tempdir) {
3856 rmtree $initiator_tempdir;
3857 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3858 $i_tmp = $initiator_tempdir;
3862 $i_child_pid = open2(\*RO, \*RI, @cmd);
3864 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3865 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3866 $supplementary_message = '' unless $protovsn >= 3;
3868 fail "rpush negotiated protocol version $protovsn".
3869 " which does not support quilt mode $quilt_mode"
3870 if quiltmode_splitbrain;
3872 rpush_handle_protovsn_bothends();
3874 my ($icmd,$iargs) = initiator_expect {
3875 m/^(\S+)(?: (.*))?$/;
3878 i_method "i_resp", $icmd, $iargs;
3882 sub i_resp_progress ($) {
3884 my $msg = protocol_read_bytes \*RO, $rhs;
3888 sub i_resp_supplementary_message ($) {
3890 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3893 sub i_resp_complete {
3894 my $pid = $i_child_pid;
3895 $i_child_pid = undef; # prevents killing some other process with same pid
3896 printdebug "waiting for build host child $pid...\n";
3897 my $got = waitpid $pid, 0;
3898 die $! unless $got == $pid;
3899 die "build host child failed $?" if $?;
3902 printdebug "all done\n";
3906 sub i_resp_file ($) {
3908 my $localname = i_method "i_localname", $keyword;
3909 my $localpath = "$i_tmp/$localname";
3910 stat_exists $localpath and
3911 badproto \*RO, "file $keyword ($localpath) twice";
3912 protocol_receive_file \*RO, $localpath;
3913 i_method "i_file", $keyword;
3918 sub i_resp_param ($) {
3919 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3923 sub i_resp_previously ($) {
3924 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3925 or badproto \*RO, "bad previously spec";
3926 my $r = system qw(git check-ref-format), $1;
3927 die "bad previously ref spec ($r)" if $r;
3928 $previously{$1} = $2;
3933 sub i_resp_want ($) {
3935 die "$keyword ?" if $i_wanted{$keyword}++;
3936 my @localpaths = i_method "i_want", $keyword;
3937 printdebug "[[ $keyword @localpaths\n";
3938 foreach my $localpath (@localpaths) {
3939 protocol_send_file \*RI, $localpath;
3941 print RI "files-end\n" or die $!;
3944 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3946 sub i_localname_parsed_changelog {
3947 return "remote-changelog.822";
3949 sub i_file_parsed_changelog {
3950 ($i_clogp, $i_version, $i_dscfn) =
3951 push_parse_changelog "$i_tmp/remote-changelog.822";
3952 die if $i_dscfn =~ m#/|^\W#;
3955 sub i_localname_dsc {
3956 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3961 sub i_localname_changes {
3962 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3963 $i_changesfn = $i_dscfn;
3964 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3965 return $i_changesfn;
3967 sub i_file_changes { }
3969 sub i_want_signed_tag {
3970 printdebug Dumper(\%i_param, $i_dscfn);
3971 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3972 && defined $i_param{'csuite'}
3973 or badproto \*RO, "premature desire for signed-tag";
3974 my $head = $i_param{'head'};
3975 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3977 my $maintview = $i_param{'maint-view'};
3978 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3981 if ($protovsn >= 4) {
3982 my $p = $i_param{'tagformat'} // '<undef>';
3984 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3987 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3989 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3991 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3994 push_mktags $i_clogp, $i_dscfn,
3995 $i_changesfn, 'remote changes',
3999 sub i_want_signed_dsc_changes {
4000 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4001 sign_changes $i_changesfn;
4002 return ($i_dscfn, $i_changesfn);
4005 #---------- building etc. ----------
4011 #----- `3.0 (quilt)' handling -----
4013 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4015 sub quiltify_dpkg_commit ($$$;$) {
4016 my ($patchname,$author,$msg, $xinfo) = @_;
4020 my $descfn = ".git/dgit/quilt-description.tmp";
4021 open O, '>', $descfn or die "$descfn: $!";
4022 $msg =~ s/\n+/\n\n/;
4023 print O <<END or die $!;
4025 ${xinfo}Subject: $msg
4032 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4033 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4034 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4035 runcmd @dpkgsource, qw(--commit .), $patchname;
4039 sub quiltify_trees_differ ($$;$$$) {
4040 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4041 # returns true iff the two tree objects differ other than in debian/
4042 # with $finegrained,
4043 # returns bitmask 01 - differ in upstream files except .gitignore
4044 # 02 - differ in .gitignore
4045 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4046 # is set for each modified .gitignore filename $fn
4047 # if $unrepres is defined, array ref to which is appeneded
4048 # a list of unrepresentable changes (removals of upstream files
4051 my @cmd = (@git, qw(diff-tree -z));
4052 push @cmd, qw(--name-only) unless $unrepres;
4053 push @cmd, qw(-r) if $finegrained || $unrepres;
4055 my $diffs= cmdoutput @cmd;
4058 foreach my $f (split /\0/, $diffs) {
4059 if ($unrepres && !@lmodes) {
4060 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4063 my ($oldmode,$newmode) = @lmodes;
4066 next if $f =~ m#^debian(?:/.*)?$#s;
4070 die "deleted\n" unless $newmode =~ m/[^0]/;
4071 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4072 if ($oldmode =~ m/[^0]/) {
4073 die "mode changed\n" if $oldmode ne $newmode;
4075 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4079 local $/="\n"; chomp $@;
4080 push @$unrepres, [ $f, $@ ];
4084 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4085 $r |= $isignore ? 02 : 01;
4086 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4088 printdebug "quiltify_trees_differ $x $y => $r\n";
4092 sub quiltify_tree_sentinelfiles ($) {
4093 # lists the `sentinel' files present in the tree
4095 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4096 qw(-- debian/rules debian/control);
4101 sub quiltify_splitbrain_needed () {
4102 if (!$split_brain) {
4103 progress "dgit view: changes are required...";
4104 runcmd @git, qw(checkout -q -b dgit-view);
4109 sub quiltify_splitbrain ($$$$$$) {
4110 my ($clogp, $unapplied, $headref, $diffbits,
4111 $editedignores, $cachekey) = @_;
4112 if ($quilt_mode !~ m/gbp|dpm/) {
4113 # treat .gitignore just like any other upstream file
4114 $diffbits = { %$diffbits };
4115 $_ = !!$_ foreach values %$diffbits;
4117 # We would like any commits we generate to be reproducible
4118 my @authline = clogp_authline($clogp);
4119 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4120 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4121 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4122 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4123 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4124 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4126 if ($quilt_mode =~ m/gbp|unapplied/ &&
4127 ($diffbits->{O2H} & 01)) {
4129 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4130 " but git tree differs from orig in upstream files.";
4131 if (!stat_exists "debian/patches") {
4133 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4137 if ($quilt_mode =~ m/dpm/ &&
4138 ($diffbits->{H2A} & 01)) {
4140 --quilt=$quilt_mode specified, implying patches-applied git tree
4141 but git tree differs from result of applying debian/patches to upstream
4144 if ($quilt_mode =~ m/gbp|unapplied/ &&
4145 ($diffbits->{O2A} & 01)) { # some patches
4146 quiltify_splitbrain_needed();
4147 progress "dgit view: creating patches-applied version using gbp pq";
4148 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4149 # gbp pq import creates a fresh branch; push back to dgit-view
4150 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4151 runcmd @git, qw(checkout -q dgit-view);
4153 if ($quilt_mode =~ m/gbp|dpm/ &&
4154 ($diffbits->{O2A} & 02)) {
4156 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4157 tool which does not create patches for changes to upstream
4158 .gitignores: but, such patches exist in debian/patches.
4161 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4162 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4163 quiltify_splitbrain_needed();
4164 progress "dgit view: creating patch to represent .gitignore changes";
4165 ensuredir "debian/patches";
4166 my $gipatch = "debian/patches/auto-gitignore";
4167 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4168 stat GIPATCH or die "$gipatch: $!";
4169 fail "$gipatch already exists; but want to create it".
4170 " to record .gitignore changes" if (stat _)[7];
4171 print GIPATCH <<END or die "$gipatch: $!";
4172 Subject: Update .gitignore from Debian packaging branch
4174 The Debian packaging git branch contains these updates to the upstream
4175 .gitignore file(s). This patch is autogenerated, to provide these
4176 updates to users of the official Debian archive view of the package.
4178 [dgit ($our_version) update-gitignore]
4181 close GIPATCH or die "$gipatch: $!";
4182 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4183 $unapplied, $headref, "--", sort keys %$editedignores;
4184 open SERIES, "+>>", "debian/patches/series" or die $!;
4185 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4187 defined read SERIES, $newline, 1 or die $!;
4188 print SERIES "\n" or die $! unless $newline eq "\n";
4189 print SERIES "auto-gitignore\n" or die $!;
4190 close SERIES or die $!;
4191 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4193 Commit patch to update .gitignore
4195 [dgit ($our_version) update-gitignore-quilt-fixup]
4199 my $dgitview = git_rev_parse 'HEAD';
4201 changedir '../../../..';
4202 # When we no longer need to support squeeze, use --create-reflog
4204 ensuredir ".git/logs/refs/dgit-intern";
4205 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4208 my $oldcache = git_get_ref "refs/$splitbraincache";
4209 if ($oldcache eq $dgitview) {
4210 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4211 # git update-ref doesn't always update, in this case. *sigh*
4212 my $dummy = make_commit_text <<END;
4215 author Dgit <dgit\@example.com> 1000000000 +0000
4216 committer Dgit <dgit\@example.com> 1000000000 +0000
4218 Dummy commit - do not use
4220 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4221 "refs/$splitbraincache", $dummy;
4223 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4226 changedir '.git/dgit/unpack/work';
4228 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4229 progress "dgit view: created ($saved)";
4232 sub quiltify ($$$$) {
4233 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4235 # Quilt patchification algorithm
4237 # We search backwards through the history of the main tree's HEAD
4238 # (T) looking for a start commit S whose tree object is identical
4239 # to to the patch tip tree (ie the tree corresponding to the
4240 # current dpkg-committed patch series). For these purposes
4241 # `identical' disregards anything in debian/ - this wrinkle is
4242 # necessary because dpkg-source treates debian/ specially.
4244 # We can only traverse edges where at most one of the ancestors'
4245 # trees differs (in changes outside in debian/). And we cannot
4246 # handle edges which change .pc/ or debian/patches. To avoid
4247 # going down a rathole we avoid traversing edges which introduce
4248 # debian/rules or debian/control. And we set a limit on the
4249 # number of edges we are willing to look at.
4251 # If we succeed, we walk forwards again. For each traversed edge
4252 # PC (with P parent, C child) (starting with P=S and ending with
4253 # C=T) to we do this:
4255 # - dpkg-source --commit with a patch name and message derived from C
4256 # After traversing PT, we git commit the changes which
4257 # should be contained within debian/patches.
4259 # The search for the path S..T is breadth-first. We maintain a
4260 # todo list containing search nodes. A search node identifies a
4261 # commit, and looks something like this:
4263 # Commit => $git_commit_id,
4264 # Child => $c, # or undef if P=T
4265 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4266 # Nontrivial => true iff $p..$c has relevant changes
4273 my %considered; # saves being exponential on some weird graphs
4275 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4278 my ($search,$whynot) = @_;
4279 printdebug " search NOT $search->{Commit} $whynot\n";
4280 $search->{Whynot} = $whynot;
4281 push @nots, $search;
4282 no warnings qw(exiting);
4291 my $c = shift @todo;
4292 next if $considered{$c->{Commit}}++;
4294 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4296 printdebug "quiltify investigate $c->{Commit}\n";
4299 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4300 printdebug " search finished hooray!\n";
4305 if ($quilt_mode eq 'nofix') {
4306 fail "quilt fixup required but quilt mode is \`nofix'\n".
4307 "HEAD commit $c->{Commit} differs from tree implied by ".
4308 " debian/patches (tree object $oldtiptree)";
4310 if ($quilt_mode eq 'smash') {
4311 printdebug " search quitting smash\n";
4315 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4316 $not->($c, "has $c_sentinels not $t_sentinels")
4317 if $c_sentinels ne $t_sentinels;
4319 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4320 $commitdata =~ m/\n\n/;
4322 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4323 @parents = map { { Commit => $_, Child => $c } } @parents;
4325 $not->($c, "root commit") if !@parents;
4327 foreach my $p (@parents) {
4328 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4330 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4331 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4333 foreach my $p (@parents) {
4334 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4336 my @cmd= (@git, qw(diff-tree -r --name-only),
4337 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4338 my $patchstackchange = cmdoutput @cmd;
4339 if (length $patchstackchange) {
4340 $patchstackchange =~ s/\n/,/g;
4341 $not->($p, "changed $patchstackchange");
4344 printdebug " search queue P=$p->{Commit} ",
4345 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4351 printdebug "quiltify want to smash\n";
4354 my $x = $_[0]{Commit};
4355 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4358 my $reportnot = sub {
4360 my $s = $abbrev->($notp);
4361 my $c = $notp->{Child};
4362 $s .= "..".$abbrev->($c) if $c;
4363 $s .= ": ".$notp->{Whynot};
4366 if ($quilt_mode eq 'linear') {
4367 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4368 foreach my $notp (@nots) {
4369 print STDERR "$us: ", $reportnot->($notp), "\n";
4371 print STDERR "$us: $_\n" foreach @$failsuggestion;
4372 fail "quilt fixup naive history linearisation failed.\n".
4373 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4374 } elsif ($quilt_mode eq 'smash') {
4375 } elsif ($quilt_mode eq 'auto') {
4376 progress "quilt fixup cannot be linear, smashing...";
4378 die "$quilt_mode ?";
4381 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4382 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4384 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4386 quiltify_dpkg_commit "auto-$version-$target-$time",
4387 (getfield $clogp, 'Maintainer'),
4388 "Automatically generated patch ($clogp->{Version})\n".
4389 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4393 progress "quiltify linearisation planning successful, executing...";
4395 for (my $p = $sref_S;
4396 my $c = $p->{Child};
4398 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4399 next unless $p->{Nontrivial};
4401 my $cc = $c->{Commit};
4403 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4404 $commitdata =~ m/\n\n/ or die "$c ?";
4407 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4410 my $commitdate = cmdoutput
4411 @git, qw(log -n1 --pretty=format:%aD), $cc;
4413 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4415 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4422 my $gbp_check_suitable = sub {
4427 die "contains unexpected slashes\n" if m{//} || m{/$};
4428 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4429 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4430 die "too long" if length > 200;
4432 return $_ unless $@;
4433 print STDERR "quiltifying commit $cc:".
4434 " ignoring/dropping Gbp-Pq $what: $@";
4438 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4440 (\S+) \s* \n //ixm) {
4441 $patchname = $gbp_check_suitable->($1, 'Name');
4443 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4445 (\S+) \s* \n //ixm) {
4446 $patchdir = $gbp_check_suitable->($1, 'Topic');
4451 if (!defined $patchname) {
4452 $patchname = $title;
4453 $patchname =~ s/[.:]$//;
4456 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4457 my $translitname = $converter->convert($patchname);
4458 die unless defined $translitname;
4459 $patchname = $translitname;
4462 "dgit: patch title transliteration error: $@"
4464 $patchname =~ y/ A-Z/-a-z/;
4465 $patchname =~ y/-a-z0-9_.+=~//cd;
4466 $patchname =~ s/^\W/x-$&/;
4467 $patchname = substr($patchname,0,40);
4469 if (!defined $patchdir) {
4472 if (length $patchdir) {
4473 $patchname = "$patchdir/$patchname";
4475 if ($patchname =~ m{^(.*)/}) {
4476 mkpath "debian/patches/$1";
4481 stat "debian/patches/$patchname$index";
4483 $!==ENOENT or die "$patchname$index $!";
4485 runcmd @git, qw(checkout -q), $cc;
4487 # We use the tip's changelog so that dpkg-source doesn't
4488 # produce complaining messages from dpkg-parsechangelog. None
4489 # of the information dpkg-source gets from the changelog is
4490 # actually relevant - it gets put into the original message
4491 # which dpkg-source provides our stunt editor, and then
4493 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4495 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4496 "Date: $commitdate\n".
4497 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4499 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4502 runcmd @git, qw(checkout -q master);
4505 sub build_maybe_quilt_fixup () {
4506 my ($format,$fopts) = get_source_format;
4507 return unless madformat_wantfixup $format;
4510 check_for_vendor_patches();
4512 if (quiltmode_splitbrain) {
4513 foreach my $needtf (qw(new maint)) {
4514 next if grep { $_ eq $needtf } access_cfg_tagformats;
4516 quilt mode $quilt_mode requires split view so server needs to support
4517 both "new" and "maint" tag formats, but config says it doesn't.
4522 my $clogp = parsechangelog();
4523 my $headref = git_rev_parse('HEAD');
4528 my $upstreamversion = upstreamversion $version;
4530 if ($fopts->{'single-debian-patch'}) {
4531 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4533 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4536 die 'bug' if $split_brain && !$need_split_build_invocation;
4538 changedir '../../../..';
4539 runcmd_ordryrun_local
4540 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4543 sub quilt_fixup_mkwork ($) {
4546 mkdir "work" or die $!;
4548 mktree_in_ud_here();
4549 runcmd @git, qw(reset -q --hard), $headref;
4552 sub quilt_fixup_linkorigs ($$) {
4553 my ($upstreamversion, $fn) = @_;
4554 # calls $fn->($leafname);
4556 foreach my $f (<../../../../*>) { #/){
4557 my $b=$f; $b =~ s{.*/}{};
4559 local ($debuglevel) = $debuglevel-1;
4560 printdebug "QF linkorigs $b, $f ?\n";
4562 next unless is_orig_file_of_vsn $b, $upstreamversion;
4563 printdebug "QF linkorigs $b, $f Y\n";
4564 link_ltarget $f, $b or die "$b $!";
4569 sub quilt_fixup_delete_pc () {
4570 runcmd @git, qw(rm -rqf .pc);
4572 Commit removal of .pc (quilt series tracking data)
4574 [dgit ($our_version) upgrade quilt-remove-pc]
4578 sub quilt_fixup_singlepatch ($$$) {
4579 my ($clogp, $headref, $upstreamversion) = @_;
4581 progress "starting quiltify (single-debian-patch)";
4583 # dpkg-source --commit generates new patches even if
4584 # single-debian-patch is in debian/source/options. In order to
4585 # get it to generate debian/patches/debian-changes, it is
4586 # necessary to build the source package.
4588 quilt_fixup_linkorigs($upstreamversion, sub { });
4589 quilt_fixup_mkwork($headref);
4591 rmtree("debian/patches");
4593 runcmd @dpkgsource, qw(-b .);
4595 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4596 rename srcfn("$upstreamversion", "/debian/patches"),
4597 "work/debian/patches";
4600 commit_quilty_patch();
4603 sub quilt_make_fake_dsc ($) {
4604 my ($upstreamversion) = @_;
4606 my $fakeversion="$upstreamversion-~~DGITFAKE";
4608 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4609 print $fakedsc <<END or die $!;
4612 Version: $fakeversion
4616 my $dscaddfile=sub {
4619 my $md = new Digest::MD5;
4621 my $fh = new IO::File $b, '<' or die "$b $!";
4626 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4629 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4631 my @files=qw(debian/source/format debian/rules
4632 debian/control debian/changelog);
4633 foreach my $maybe (qw(debian/patches debian/source/options
4634 debian/tests/control)) {
4635 next unless stat_exists "../../../$maybe";
4636 push @files, $maybe;
4639 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4640 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4642 $dscaddfile->($debtar);
4643 close $fakedsc or die $!;
4646 sub quilt_check_splitbrain_cache ($$) {
4647 my ($headref, $upstreamversion) = @_;
4648 # Called only if we are in (potentially) split brain mode.
4650 # Computes the cache key and looks in the cache.
4651 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4653 my $splitbrain_cachekey;
4656 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4657 # we look in the reflog of dgit-intern/quilt-cache
4658 # we look for an entry whose message is the key for the cache lookup
4659 my @cachekey = (qw(dgit), $our_version);
4660 push @cachekey, $upstreamversion;
4661 push @cachekey, $quilt_mode;
4662 push @cachekey, $headref;
4664 push @cachekey, hashfile('fake.dsc');
4666 my $srcshash = Digest::SHA->new(256);
4667 my %sfs = ( %INC, '$0(dgit)' => $0 );
4668 foreach my $sfk (sort keys %sfs) {
4669 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4670 $srcshash->add($sfk," ");
4671 $srcshash->add(hashfile($sfs{$sfk}));
4672 $srcshash->add("\n");
4674 push @cachekey, $srcshash->hexdigest();
4675 $splitbrain_cachekey = "@cachekey";
4677 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4679 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4680 debugcmd "|(probably)",@cmd;
4681 my $child = open GC, "-|"; defined $child or die $!;
4683 chdir '../../..' or die $!;
4684 if (!stat ".git/logs/refs/$splitbraincache") {
4685 $! == ENOENT or die $!;
4686 printdebug ">(no reflog)\n";
4693 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4694 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4697 quilt_fixup_mkwork($headref);
4698 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4699 if ($cachehit ne $headref) {
4700 progress "dgit view: found cached ($saved)";
4701 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4703 return ($cachehit, $splitbrain_cachekey);
4705 progress "dgit view: found cached, no changes required";
4706 return ($headref, $splitbrain_cachekey);
4708 die $! if GC->error;
4709 failedcmd unless close GC;
4711 printdebug "splitbrain cache miss\n";
4712 return (undef, $splitbrain_cachekey);
4715 sub quilt_fixup_multipatch ($$$) {
4716 my ($clogp, $headref, $upstreamversion) = @_;
4718 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4721 # - honour any existing .pc in case it has any strangeness
4722 # - determine the git commit corresponding to the tip of
4723 # the patch stack (if there is one)
4724 # - if there is such a git commit, convert each subsequent
4725 # git commit into a quilt patch with dpkg-source --commit
4726 # - otherwise convert all the differences in the tree into
4727 # a single git commit
4731 # Our git tree doesn't necessarily contain .pc. (Some versions of
4732 # dgit would include the .pc in the git tree.) If there isn't
4733 # one, we need to generate one by unpacking the patches that we
4736 # We first look for a .pc in the git tree. If there is one, we
4737 # will use it. (This is not the normal case.)
4739 # Otherwise need to regenerate .pc so that dpkg-source --commit
4740 # can work. We do this as follows:
4741 # 1. Collect all relevant .orig from parent directory
4742 # 2. Generate a debian.tar.gz out of
4743 # debian/{patches,rules,source/format,source/options}
4744 # 3. Generate a fake .dsc containing just these fields:
4745 # Format Source Version Files
4746 # 4. Extract the fake .dsc
4747 # Now the fake .dsc has a .pc directory.
4748 # (In fact we do this in every case, because in future we will
4749 # want to search for a good base commit for generating patches.)
4751 # Then we can actually do the dpkg-source --commit
4752 # 1. Make a new working tree with the same object
4753 # store as our main tree and check out the main
4755 # 2. Copy .pc from the fake's extraction, if necessary
4756 # 3. Run dpkg-source --commit
4757 # 4. If the result has changes to debian/, then
4758 # - git add them them
4759 # - git add .pc if we had a .pc in-tree
4761 # 5. If we had a .pc in-tree, delete it, and git commit
4762 # 6. Back in the main tree, fast forward to the new HEAD
4764 # Another situation we may have to cope with is gbp-style
4765 # patches-unapplied trees.
4767 # We would want to detect these, so we know to escape into
4768 # quilt_fixup_gbp. However, this is in general not possible.
4769 # Consider a package with a one patch which the dgit user reverts
4770 # (with git revert or the moral equivalent).
4772 # That is indistinguishable in contents from a patches-unapplied
4773 # tree. And looking at the history to distinguish them is not
4774 # useful because the user might have made a confusing-looking git
4775 # history structure (which ought to produce an error if dgit can't
4776 # cope, not a silent reintroduction of an unwanted patch).
4778 # So gbp users will have to pass an option. But we can usually
4779 # detect their failure to do so: if the tree is not a clean
4780 # patches-applied tree, quilt linearisation fails, but the tree
4781 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4782 # they want --quilt=unapplied.
4784 # To help detect this, when we are extracting the fake dsc, we
4785 # first extract it with --skip-patches, and then apply the patches
4786 # afterwards with dpkg-source --before-build. That lets us save a
4787 # tree object corresponding to .origs.
4789 my $splitbrain_cachekey;
4791 quilt_make_fake_dsc($upstreamversion);
4793 if (quiltmode_splitbrain()) {
4795 ($cachehit, $splitbrain_cachekey) =
4796 quilt_check_splitbrain_cache($headref, $upstreamversion);
4797 return if $cachehit;
4801 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4803 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4804 rename $fakexdir, "fake" or die "$fakexdir $!";
4808 remove_stray_gits();
4809 mktree_in_ud_here();
4813 runcmd @git, qw(add -Af .);
4814 my $unapplied=git_write_tree();
4815 printdebug "fake orig tree object $unapplied\n";
4819 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4821 if (system @bbcmd) {
4822 failedcmd @bbcmd if $? < 0;
4824 failed to apply your git tree's patch stack (from debian/patches/) to
4825 the corresponding upstream tarball(s). Your source tree and .orig
4826 are probably too inconsistent. dgit can only fix up certain kinds of
4827 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4833 quilt_fixup_mkwork($headref);
4836 if (stat_exists ".pc") {
4838 progress "Tree already contains .pc - will use it then delete it.";
4841 rename '../fake/.pc','.pc' or die $!;
4844 changedir '../fake';
4846 runcmd @git, qw(add -Af .);
4847 my $oldtiptree=git_write_tree();
4848 printdebug "fake o+d/p tree object $unapplied\n";
4849 changedir '../work';
4852 # We calculate some guesswork now about what kind of tree this might
4853 # be. This is mostly for error reporting.
4859 # O = orig, without patches applied
4860 # A = "applied", ie orig with H's debian/patches applied
4861 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4862 \%editedignores, \@unrepres),
4863 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4864 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4868 foreach my $b (qw(01 02)) {
4869 foreach my $v (qw(O2H O2A H2A)) {
4870 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4873 printdebug "differences \@dl @dl.\n";
4876 "$us: base trees orig=%.20s o+d/p=%.20s",
4877 $unapplied, $oldtiptree;
4879 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4880 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4881 $dl[0], $dl[1], $dl[3], $dl[4],
4885 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4887 forceable_fail [qw(unrepresentable)], <<END;
4888 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4893 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4894 push @failsuggestion, "This might be a patches-unapplied branch.";
4895 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4896 push @failsuggestion, "This might be a patches-applied branch.";
4898 push @failsuggestion, "Maybe you need to specify one of".
4899 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4901 if (quiltmode_splitbrain()) {
4902 quiltify_splitbrain($clogp, $unapplied, $headref,
4903 $diffbits, \%editedignores,
4904 $splitbrain_cachekey);
4908 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4909 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4911 if (!open P, '>>', ".pc/applied-patches") {
4912 $!==&ENOENT or die $!;
4917 commit_quilty_patch();
4919 if ($mustdeletepc) {
4920 quilt_fixup_delete_pc();
4924 sub quilt_fixup_editor () {
4925 my $descfn = $ENV{$fakeeditorenv};
4926 my $editing = $ARGV[$#ARGV];
4927 open I1, '<', $descfn or die "$descfn: $!";
4928 open I2, '<', $editing or die "$editing: $!";
4929 unlink $editing or die "$editing: $!";
4930 open O, '>', $editing or die "$editing: $!";
4931 while (<I1>) { print O or die $!; } I1->error and die $!;
4934 $copying ||= m/^\-\-\- /;
4935 next unless $copying;
4938 I2->error and die $!;
4943 sub maybe_apply_patches_dirtily () {
4944 return unless $quilt_mode =~ m/gbp|unapplied/;
4945 print STDERR <<END or die $!;
4947 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4948 dgit: Have to apply the patches - making the tree dirty.
4949 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4952 $patches_applied_dirtily = 01;
4953 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4954 runcmd qw(dpkg-source --before-build .);
4957 sub maybe_unapply_patches_again () {
4958 progress "dgit: Unapplying patches again to tidy up the tree."
4959 if $patches_applied_dirtily;
4960 runcmd qw(dpkg-source --after-build .)
4961 if $patches_applied_dirtily & 01;
4963 if $patches_applied_dirtily & 02;
4964 $patches_applied_dirtily = 0;
4967 #----- other building -----
4969 our $clean_using_builder;
4970 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4971 # clean the tree before building (perhaps invoked indirectly by
4972 # whatever we are using to run the build), rather than separately
4973 # and explicitly by us.
4976 return if $clean_using_builder;
4977 if ($cleanmode eq 'dpkg-source') {
4978 maybe_apply_patches_dirtily();
4979 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4980 } elsif ($cleanmode eq 'dpkg-source-d') {
4981 maybe_apply_patches_dirtily();
4982 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4983 } elsif ($cleanmode eq 'git') {
4984 runcmd_ordryrun_local @git, qw(clean -xdf);
4985 } elsif ($cleanmode eq 'git-ff') {
4986 runcmd_ordryrun_local @git, qw(clean -xdff);
4987 } elsif ($cleanmode eq 'check') {
4988 my $leftovers = cmdoutput @git, qw(clean -xdn);
4989 if (length $leftovers) {
4990 print STDERR $leftovers, "\n" or die $!;
4991 fail "tree contains uncommitted files and --clean=check specified";
4993 } elsif ($cleanmode eq 'none') {
5000 badusage "clean takes no additional arguments" if @ARGV;
5003 maybe_unapply_patches_again();
5006 sub build_prep_early () {
5007 our $build_prep_early_done //= 0;
5008 return if $build_prep_early_done++;
5010 badusage "-p is not allowed when building" if defined $package;
5011 my $clogp = parsechangelog();
5012 $isuite = getfield $clogp, 'Distribution';
5013 $package = getfield $clogp, 'Source';
5014 $version = getfield $clogp, 'Version';
5021 build_maybe_quilt_fixup();
5023 my $pat = changespat $version;
5024 foreach my $f (glob "$buildproductsdir/$pat") {
5026 unlink $f or fail "remove old changes file $f: $!";
5028 progress "would remove $f";
5034 sub changesopts_initial () {
5035 my @opts =@changesopts[1..$#changesopts];
5038 sub changesopts_version () {
5039 if (!defined $changes_since_version) {
5040 my @vsns = archive_query('archive_query');
5041 my @quirk = access_quirk();
5042 if ($quirk[0] eq 'backports') {
5043 local $isuite = $quirk[2];
5045 canonicalise_suite();
5046 push @vsns, archive_query('archive_query');
5049 @vsns = map { $_->[0] } @vsns;
5050 @vsns = sort { -version_compare($a, $b) } @vsns;
5051 $changes_since_version = $vsns[0];
5052 progress "changelog will contain changes since $vsns[0]";
5054 $changes_since_version = '_';
5055 progress "package seems new, not specifying -v<version>";
5058 if ($changes_since_version ne '_') {
5059 return ("-v$changes_since_version");
5065 sub changesopts () {
5066 return (changesopts_initial(), changesopts_version());
5069 sub massage_dbp_args ($;$) {
5070 my ($cmd,$xargs) = @_;
5073 # - if we're going to split the source build out so we can
5074 # do strange things to it, massage the arguments to dpkg-buildpackage
5075 # so that the main build doessn't build source (or add an argument
5076 # to stop it building source by default).
5078 # - add -nc to stop dpkg-source cleaning the source tree,
5079 # unless we're not doing a split build and want dpkg-source
5080 # as cleanmode, in which case we can do nothing
5083 # 0 - source will NOT need to be built separately by caller
5084 # +1 - source will need to be built separately by caller
5085 # +2 - source will need to be built separately by caller AND
5086 # dpkg-buildpackage should not in fact be run at all!
5087 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5088 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5089 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5090 $clean_using_builder = 1;
5093 # -nc has the side effect of specifying -b if nothing else specified
5094 # and some combinations of -S, -b, et al, are errors, rather than
5095 # later simply overriding earlie. So we need to:
5096 # - search the command line for these options
5097 # - pick the last one
5098 # - perhaps add our own as a default
5099 # - perhaps adjust it to the corresponding non-source-building version
5101 foreach my $l ($cmd, $xargs) {
5103 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5106 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5108 if ($need_split_build_invocation) {
5109 printdebug "massage split $dmode.\n";
5110 $r = $dmode =~ m/[S]/ ? +2 :
5111 $dmode =~ y/gGF/ABb/ ? +1 :
5112 $dmode =~ m/[ABb]/ ? 0 :
5115 printdebug "massage done $r $dmode.\n";
5117 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5123 my $wasdir = must_getcwd();
5129 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5130 my ($msg_if_onlyone) = @_;
5131 # If there is only one .changes file, fail with $msg_if_onlyone,
5132 # or if that is undef, be a no-op.
5133 # Returns the changes file to report to the user.
5134 my $pat = changespat $version;
5135 my @changesfiles = glob $pat;
5136 @changesfiles = sort {
5137 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5141 if (@changesfiles==1) {
5142 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5143 only one changes file from build (@changesfiles)
5145 $result = $changesfiles[0];
5146 } elsif (@changesfiles==2) {
5147 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5148 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5149 fail "$l found in binaries changes file $binchanges"
5152 runcmd_ordryrun_local @mergechanges, @changesfiles;
5153 my $multichanges = changespat $version,'multi';
5155 stat_exists $multichanges or fail "$multichanges: $!";
5156 foreach my $cf (glob $pat) {
5157 next if $cf eq $multichanges;
5158 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5161 $result = $multichanges;
5163 fail "wrong number of different changes files (@changesfiles)";
5165 printdone "build successful, results in $result\n" or die $!;
5168 sub midbuild_checkchanges () {
5169 my $pat = changespat $version;
5170 return if $rmchanges;
5171 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5172 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5174 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5175 Suggest you delete @unwanted.
5180 sub midbuild_checkchanges_vanilla ($) {
5182 midbuild_checkchanges() if $wantsrc == 1;
5185 sub postbuild_mergechanges_vanilla ($) {
5187 if ($wantsrc == 1) {
5189 postbuild_mergechanges(undef);
5192 printdone "build successful\n";
5197 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5198 my $wantsrc = massage_dbp_args \@dbp;
5201 midbuild_checkchanges_vanilla $wantsrc;
5206 push @dbp, changesopts_version();
5207 maybe_apply_patches_dirtily();
5208 runcmd_ordryrun_local @dbp;
5210 maybe_unapply_patches_again();
5211 postbuild_mergechanges_vanilla $wantsrc;
5215 $quilt_mode //= 'gbp';
5221 # gbp can make .origs out of thin air. In my tests it does this
5222 # even for a 1.0 format package, with no origs present. So I
5223 # guess it keys off just the version number. We don't know
5224 # exactly what .origs ought to exist, but let's assume that we
5225 # should run gbp if: the version has an upstream part and the main
5227 my $upstreamversion = upstreamversion $version;
5228 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5229 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5231 if ($gbp_make_orig) {
5233 $cleanmode = 'none'; # don't do it again
5234 $need_split_build_invocation = 1;
5237 my @dbp = @dpkgbuildpackage;
5239 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5241 if (!length $gbp_build[0]) {
5242 if (length executable_on_path('git-buildpackage')) {
5243 $gbp_build[0] = qw(git-buildpackage);
5245 $gbp_build[0] = 'gbp buildpackage';
5248 my @cmd = opts_opt_multi_cmd @gbp_build;
5250 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5252 if ($gbp_make_orig) {
5253 ensuredir '.git/dgit';
5254 my $ok = '.git/dgit/origs-gen-ok';
5255 unlink $ok or $!==&ENOENT or die $!;
5256 my @origs_cmd = @cmd;
5257 push @origs_cmd, qw(--git-cleaner=true);
5258 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5259 push @origs_cmd, @ARGV;
5261 debugcmd @origs_cmd;
5263 do { local $!; stat_exists $ok; }
5264 or failedcmd @origs_cmd;
5266 dryrun_report @origs_cmd;
5272 midbuild_checkchanges_vanilla $wantsrc;
5274 if (!$clean_using_builder) {
5275 push @cmd, '--git-cleaner=true';
5279 maybe_unapply_patches_again();
5281 push @cmd, changesopts();
5282 runcmd_ordryrun_local @cmd, @ARGV;
5284 postbuild_mergechanges_vanilla $wantsrc;
5286 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5289 my $our_cleanmode = $cleanmode;
5290 if ($need_split_build_invocation) {
5291 # Pretend that clean is being done some other way. This
5292 # forces us not to try to use dpkg-buildpackage to clean and
5293 # build source all in one go; and instead we run dpkg-source
5294 # (and build_prep() will do the clean since $clean_using_builder
5296 $our_cleanmode = 'ELSEWHERE';
5298 if ($our_cleanmode =~ m/^dpkg-source/) {
5299 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5300 $clean_using_builder = 1;
5303 $sourcechanges = changespat $version,'source';
5305 unlink "../$sourcechanges" or $!==ENOENT
5306 or fail "remove $sourcechanges: $!";
5308 $dscfn = dscfn($version);
5309 if ($our_cleanmode eq 'dpkg-source') {
5310 maybe_apply_patches_dirtily();
5311 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5313 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5314 maybe_apply_patches_dirtily();
5315 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5318 my @cmd = (@dpkgsource, qw(-b --));
5321 runcmd_ordryrun_local @cmd, "work";
5322 my @udfiles = <${package}_*>;
5323 changedir "../../..";
5324 foreach my $f (@udfiles) {
5325 printdebug "source copy, found $f\n";
5328 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5329 $f eq srcfn($version, $&));
5330 printdebug "source copy, found $f - renaming\n";
5331 rename "$ud/$f", "../$f" or $!==ENOENT
5332 or fail "put in place new source file ($f): $!";
5335 my $pwd = must_getcwd();
5336 my $leafdir = basename $pwd;
5338 runcmd_ordryrun_local @cmd, $leafdir;
5341 runcmd_ordryrun_local qw(sh -ec),
5342 'exec >$1; shift; exec "$@"','x',
5343 "../$sourcechanges",
5344 @dpkggenchanges, qw(-S), changesopts();
5348 sub cmd_build_source {
5349 badusage "build-source takes no additional arguments" if @ARGV;
5351 maybe_unapply_patches_again();
5352 printdone "source built, results in $dscfn and $sourcechanges";
5357 midbuild_checkchanges();
5360 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5361 stat_exists $sourcechanges
5362 or fail "$sourcechanges (in parent directory): $!";
5364 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5366 maybe_unapply_patches_again();
5368 postbuild_mergechanges(<<END);
5369 perhaps you need to pass -A ? (sbuild's default is to build only
5370 arch-specific binaries; dgit 1.4 used to override that.)
5375 sub cmd_quilt_fixup {
5376 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5377 my $clogp = parsechangelog();
5378 $version = getfield $clogp, 'Version';
5379 $package = getfield $clogp, 'Source';
5382 build_maybe_quilt_fixup();
5385 sub cmd_import_dsc {
5389 last unless $ARGV[0] =~ m/^-/;
5392 if (m/^--require-valid-signature$/) {
5395 badusage "unknown dgit import-dsc sub-option \`$_'";
5399 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5400 my ($dscfn, $dstbranch) = @ARGV;
5402 badusage "dry run makes no sense with import-dsc" unless act_local();
5404 my $force = $dstbranch =~ s/^\+// ? +1 :
5405 $dstbranch =~ s/^\.\.// ? -1 :
5407 my $info = $force ? " $&" : '';
5408 $info = "$dscfn$info";
5410 my $specbranch = $dstbranch;
5411 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5412 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5414 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5415 my $chead = cmdoutput_errok @symcmd;
5416 defined $chead or $?==256 or failedcmd @symcmd;
5418 fail "$dstbranch is checked out - will not update it"
5419 if defined $chead and $chead eq $dstbranch;
5421 my $oldhash = git_get_ref $dstbranch;
5423 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5424 $dscdata = do { local $/ = undef; <D>; };
5425 D->error and fail "read $dscfn: $!";
5428 # we don't normally need this so import it here
5429 use Dpkg::Source::Package;
5430 my $dp = new Dpkg::Source::Package filename => $dscfn,
5431 require_valid_signature => $needsig;
5433 local $SIG{__WARN__} = sub {
5435 return unless $needsig;
5436 fail "import-dsc signature check failed";
5438 if (!$dp->is_signed()) {
5439 warn "$us: warning: importing unsigned .dsc\n";
5441 my $r = $dp->check_signature();
5442 die "->check_signature => $r" if $needsig && $r;
5448 my $dgit_commit = $dsc->{$ourdscfield[0]};
5449 if (defined $dgit_commit &&
5450 !forceing [qw(import-dsc-with-dgit-field)]) {
5451 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5452 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5453 my @cmd = (qw(sh -ec),
5454 "echo $dgit_commit | git cat-file --batch-check");
5455 my $objgot = cmdoutput @cmd;
5456 if ($objgot =~ m#^\w+ missing\b#) {
5458 .dsc contains Dgit field referring to object $dgit_commit
5459 Your git tree does not have that object. Try `git fetch' from a
5460 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5463 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5465 progress "Not fast forward, forced update.";
5467 fail "Not fast forward to $dgit_commit";
5470 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5471 $dstbranch, $dgit_commit);
5473 progress "dgit: import-dsc updated git ref $dstbranch";
5478 Branch $dstbranch already exists
5479 Specify ..$specbranch for a pseudo-merge, binding in existing history
5480 Specify +$specbranch to overwrite, discarding existing history
5482 if $oldhash && !$force;
5484 $package = getfield $dsc, 'Source';
5485 my @dfi = dsc_files_info();
5486 foreach my $fi (@dfi) {
5487 my $f = $fi->{Filename};
5489 next if lstat $here;
5490 fail "stat $here: $!" unless $! == ENOENT;
5492 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5494 } elsif ($dscfn =~ m#^/#) {
5497 fail "cannot import $dscfn which seems to be inside working tree!";
5499 $there =~ s#/+[^/]+$## or
5500 fail "cannot import $dscfn which seems to not have a basename";
5502 symlink $there, $here or fail "symlink $there to $here: $!";
5503 progress "made symlink $here -> $there";
5504 print STDERR Dumper($fi);
5506 my @mergeinputs = generate_commits_from_dsc();
5507 die unless @mergeinputs == 1;
5509 my $newhash = $mergeinputs[0]{Commit};
5513 progress "Import, forced update - synthetic orphan git history.";
5514 } elsif ($force < 0) {
5515 progress "Import, merging.";
5516 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5517 my $version = getfield $dsc, 'Version';
5518 $newhash = make_commit_text <<END;
5523 Merge $package ($version) import into $dstbranch
5526 die; # caught earlier
5530 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5531 $dstbranch, $newhash);
5533 progress "dgit: import-dsc results are in in git ref $dstbranch";
5536 sub cmd_archive_api_query {
5537 badusage "need only 1 subpath argument" unless @ARGV==1;
5538 my ($subpath) = @ARGV;
5539 my @cmd = archive_api_query_cmd($subpath);
5542 exec @cmd or fail "exec curl: $!\n";
5545 sub cmd_clone_dgit_repos_server {
5546 badusage "need destination argument" unless @ARGV==1;
5547 my ($destdir) = @ARGV;
5548 $package = '_dgit-repos-server';
5549 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5551 exec @cmd or fail "exec git clone: $!\n";
5554 sub cmd_setup_mergechangelogs {
5555 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5556 setup_mergechangelogs(1);
5559 sub cmd_setup_useremail {
5560 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5564 sub cmd_setup_new_tree {
5565 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5569 #---------- argument parsing and main program ----------
5572 print "dgit version $our_version\n" or die $!;
5576 our (%valopts_long, %valopts_short);
5579 sub defvalopt ($$$$) {
5580 my ($long,$short,$val_re,$how) = @_;
5581 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5582 $valopts_long{$long} = $oi;
5583 $valopts_short{$short} = $oi;
5584 # $how subref should:
5585 # do whatever assignemnt or thing it likes with $_[0]
5586 # if the option should not be passed on to remote, @rvalopts=()
5587 # or $how can be a scalar ref, meaning simply assign the value
5590 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5591 defvalopt '--distro', '-d', '.+', \$idistro;
5592 defvalopt '', '-k', '.+', \$keyid;
5593 defvalopt '--existing-package','', '.*', \$existing_package;
5594 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5595 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5596 defvalopt '--package', '-p', $package_re, \$package;
5597 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5599 defvalopt '', '-C', '.+', sub {
5600 ($changesfile) = (@_);
5601 if ($changesfile =~ s#^(.*)/##) {
5602 $buildproductsdir = $1;
5606 defvalopt '--initiator-tempdir','','.*', sub {
5607 ($initiator_tempdir) = (@_);
5608 $initiator_tempdir =~ m#^/# or
5609 badusage "--initiator-tempdir must be used specify an".
5610 " absolute, not relative, directory."
5616 if (defined $ENV{'DGIT_SSH'}) {
5617 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5618 } elsif (defined $ENV{'GIT_SSH'}) {
5619 @ssh = ($ENV{'GIT_SSH'});
5627 if (!defined $val) {
5628 badusage "$what needs a value" unless @ARGV;
5630 push @rvalopts, $val;
5632 badusage "bad value \`$val' for $what" unless
5633 $val =~ m/^$oi->{Re}$(?!\n)/s;
5634 my $how = $oi->{How};
5635 if (ref($how) eq 'SCALAR') {
5640 push @ropts, @rvalopts;
5644 last unless $ARGV[0] =~ m/^-/;
5648 if (m/^--dry-run$/) {
5651 } elsif (m/^--damp-run$/) {
5654 } elsif (m/^--no-sign$/) {
5657 } elsif (m/^--help$/) {
5659 } elsif (m/^--version$/) {
5661 } elsif (m/^--new$/) {
5664 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5665 ($om = $opts_opt_map{$1}) &&
5669 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5670 !$opts_opt_cmdonly{$1} &&
5671 ($om = $opts_opt_map{$1})) {
5674 } elsif (m/^--(gbp|dpm)$/s) {
5675 push @ropts, "--quilt=$1";
5677 } elsif (m/^--ignore-dirty$/s) {
5680 } elsif (m/^--no-quilt-fixup$/s) {
5682 $quilt_mode = 'nocheck';
5683 } elsif (m/^--no-rm-on-error$/s) {
5686 } elsif (m/^--overwrite$/s) {
5688 $overwrite_version = '';
5689 } elsif (m/^--overwrite=(.+)$/s) {
5691 $overwrite_version = $1;
5692 } elsif (m/^--delayed=(\d+)$/s) {
5695 } elsif (m/^--dgit-view-save=(.+)$/s) {
5697 $split_brain_save = $1;
5698 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5699 } elsif (m/^--(no-)?rm-old-changes$/s) {
5702 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5704 push @deliberatelies, $&;
5705 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5709 } elsif (m/^--force-/) {
5711 "$us: warning: ignoring unknown force option $_\n";
5713 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5714 # undocumented, for testing
5716 $tagformat_want = [ $1, 'command line', 1 ];
5717 # 1 menas overrides distro configuration
5718 } elsif (m/^--always-split-source-build$/s) {
5719 # undocumented, for testing
5721 $need_split_build_invocation = 1;
5722 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5723 $val = $2 ? $' : undef; #';
5724 $valopt->($oi->{Long});
5726 badusage "unknown long option \`$_'";
5733 } elsif (s/^-L/-/) {
5736 } elsif (s/^-h/-/) {
5738 } elsif (s/^-D/-/) {
5742 } elsif (s/^-N/-/) {
5747 push @changesopts, $_;
5749 } elsif (s/^-wn$//s) {
5751 $cleanmode = 'none';
5752 } elsif (s/^-wg$//s) {
5755 } elsif (s/^-wgf$//s) {
5757 $cleanmode = 'git-ff';
5758 } elsif (s/^-wd$//s) {
5760 $cleanmode = 'dpkg-source';
5761 } elsif (s/^-wdd$//s) {
5763 $cleanmode = 'dpkg-source-d';
5764 } elsif (s/^-wc$//s) {
5766 $cleanmode = 'check';
5767 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5768 push @git, '-c', $&;
5769 $gitcfgs{cmdline}{$1} = [ $2 ];
5770 } elsif (s/^-c([^=]+)$//s) {
5771 push @git, '-c', $&;
5772 $gitcfgs{cmdline}{$1} = [ 'true' ];
5773 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5775 $val = undef unless length $val;
5776 $valopt->($oi->{Short});
5779 badusage "unknown short option \`$_'";
5786 sub check_env_sanity () {
5787 my $blocked = new POSIX::SigSet;
5788 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5791 foreach my $name (qw(PIPE CHLD)) {
5792 my $signame = "SIG$name";
5793 my $signum = eval "POSIX::$signame" // die;
5794 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5795 die "$signame is set to something other than SIG_DFL\n";
5796 $blocked->ismember($signum) and
5797 die "$signame is blocked\n";
5803 On entry to dgit, $@
5804 This is a bug produced by something in in your execution environment.
5810 sub finalise_opts_opts () {
5811 foreach my $k (keys %opts_opt_map) {
5812 my $om = $opts_opt_map{$k};
5814 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5816 badcfg "cannot set command for $k"
5817 unless length $om->[0];
5821 foreach my $c (access_cfg_cfgs("opts-$k")) {
5823 map { $_ ? @$_ : () }
5824 map { $gitcfgs{$_}{$c} }
5825 reverse @gitcfgsources;
5826 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5827 "\n" if $debuglevel >= 4;
5829 badcfg "cannot configure options for $k"
5830 if $opts_opt_cmdonly{$k};
5831 my $insertpos = $opts_cfg_insertpos{$k};
5832 @$om = ( @$om[0..$insertpos-1],
5834 @$om[$insertpos..$#$om] );
5839 if ($ENV{$fakeeditorenv}) {
5841 quilt_fixup_editor();
5848 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5849 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5850 if $dryrun_level == 1;
5852 print STDERR $helpmsg or die $!;
5855 my $cmd = shift @ARGV;
5858 my $pre_fn = ${*::}{"pre_$cmd"};
5859 $pre_fn->() if $pre_fn;
5861 if (!defined $rmchanges) {
5862 local $access_forpush;
5863 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5866 if (!defined $quilt_mode) {
5867 local $access_forpush;
5868 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5869 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5871 $quilt_mode =~ m/^($quilt_modes_re)$/
5872 or badcfg "unknown quilt-mode \`$quilt_mode'";
5876 $need_split_build_invocation ||= quiltmode_splitbrain();
5878 if (!defined $cleanmode) {
5879 local $access_forpush;
5880 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5881 $cleanmode //= 'dpkg-source';
5883 badcfg "unknown clean-mode \`$cleanmode'" unless
5884 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5887 my $fn = ${*::}{"cmd_$cmd"};
5888 $fn or badusage "unknown operation $cmd";