3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $split_brain_save;
71 our $we_are_responder;
72 our $initiator_tempdir;
73 our $patches_applied_dirtily = 00;
78 our %forceopts = map { $_=>0 }
79 qw(unrepresentable unsupported-source-format
80 dsc-changes-mismatch changes-origs-exactly
81 import-gitapply-absurd
82 import-gitapply-no-absurd
83 import-dsc-with-dgit-field);
85 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
87 our $suite_re = '[-+.0-9a-z]+';
88 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
89 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
90 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
91 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
93 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
94 our $splitbraincache = 'dgit-intern/quilt-cache';
97 our (@dget) = qw(dget);
98 our (@curl) = qw(curl);
99 our (@dput) = qw(dput);
100 our (@debsign) = qw(debsign);
101 our (@gpg) = qw(gpg);
102 our (@sbuild) = qw(sbuild);
104 our (@dgit) = qw(dgit);
105 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
106 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
107 our (@dpkggenchanges) = qw(dpkg-genchanges);
108 our (@mergechanges) = qw(mergechanges -f);
109 our (@gbp_build) = ('');
110 our (@gbp_pq) = ('gbp pq');
111 our (@changesopts) = ('');
113 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
116 'debsign' => \@debsign,
118 'sbuild' => \@sbuild,
122 'dpkg-source' => \@dpkgsource,
123 'dpkg-buildpackage' => \@dpkgbuildpackage,
124 'dpkg-genchanges' => \@dpkggenchanges,
125 'gbp-build' => \@gbp_build,
126 'gbp-pq' => \@gbp_pq,
127 'ch' => \@changesopts,
128 'mergechanges' => \@mergechanges);
130 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
131 our %opts_cfg_insertpos = map {
133 scalar @{ $opts_opt_map{$_} }
134 } keys %opts_opt_map;
136 sub finalise_opts_opts();
142 our $supplementary_message = '';
143 our $need_split_build_invocation = 0;
144 our $split_brain = 0;
148 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
151 our $remotename = 'dgit';
152 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
156 if (!defined $absurdity) {
158 $absurdity =~ s{/[^/]+$}{/absurd} or die;
162 my ($v,$distro) = @_;
163 return $tagformatfn->($v, $distro);
166 sub debiantag_maintview ($$) {
167 my ($v,$distro) = @_;
172 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
174 sub lbranch () { return "$branchprefix/$csuite"; }
175 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
176 sub lref () { return "refs/heads/".lbranch(); }
177 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
178 sub rrref () { return server_ref($csuite); }
180 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
181 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
183 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
184 # locally fetched refs because they have unhelpful names and clutter
185 # up gitk etc. So we track whether we have "used up" head ref (ie,
186 # whether we have made another local ref which refers to this object).
188 # (If we deleted them unconditionally, then we might end up
189 # re-fetching the same git objects each time dgit fetch was run.)
191 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
192 # in git_fetch_us to fetch the refs in question, and possibly a call
193 # to lrfetchref_used.
195 our (%lrfetchrefs_f, %lrfetchrefs_d);
196 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
198 sub lrfetchref_used ($) {
199 my ($fullrefname) = @_;
200 my $objid = $lrfetchrefs_f{$fullrefname};
201 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
212 return "${package}_".(stripepoch $vsn).$sfx
217 return srcfn($vsn,".dsc");
220 sub changespat ($;$) {
221 my ($vsn, $arch) = @_;
222 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 sub upstreamversion ($) {
237 foreach my $f (@end) {
239 print STDERR "$us: cleanup: $@" if length $@;
243 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
245 sub forceable_fail ($$) {
246 my ($forceoptsl, $msg) = @_;
247 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
248 print STDERR "warning: overriding problem due to --force:\n". $msg;
252 my ($forceoptsl) = @_;
253 my @got = grep { $forceopts{$_} } @$forceoptsl;
254 return 0 unless @got;
256 "warning: skipping checks or functionality due to --force-$got[0]\n";
259 sub no_such_package () {
260 print STDERR "$us: package $package does not exist in suite $isuite\n";
266 printdebug "CD $newdir\n";
267 chdir $newdir or confess "chdir: $newdir: $!";
270 sub deliberately ($) {
272 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
275 sub deliberately_not_fast_forward () {
276 foreach (qw(not-fast-forward fresh-repo)) {
277 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
281 sub quiltmode_splitbrain () {
282 $quilt_mode =~ m/gbp|dpm|unapplied/;
285 sub opts_opt_multi_cmd {
287 push @cmd, split /\s+/, shift @_;
293 return opts_opt_multi_cmd @gbp_pq;
296 #---------- remote protocol support, common ----------
298 # remote push initiator/responder protocol:
299 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
300 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
301 # < dgit-remote-push-ready <actual-proto-vsn>
308 # > supplementary-message NBYTES # $protovsn >= 3
313 # > file parsed-changelog
314 # [indicates that output of dpkg-parsechangelog follows]
315 # > data-block NBYTES
316 # > [NBYTES bytes of data (no newline)]
317 # [maybe some more blocks]
326 # > param head DGIT-VIEW-HEAD
327 # > param csuite SUITE
328 # > param tagformat old|new
329 # > param maint-view MAINT-VIEW-HEAD
331 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
332 # # goes into tag, for replay prevention
335 # [indicates that signed tag is wanted]
336 # < data-block NBYTES
337 # < [NBYTES bytes of data (no newline)]
338 # [maybe some more blocks]
342 # > want signed-dsc-changes
343 # < data-block NBYTES [transfer of signed dsc]
345 # < data-block NBYTES [transfer of signed changes]
353 sub i_child_report () {
354 # Sees if our child has died, and reap it if so. Returns a string
355 # describing how it died if it failed, or undef otherwise.
356 return undef unless $i_child_pid;
357 my $got = waitpid $i_child_pid, WNOHANG;
358 return undef if $got <= 0;
359 die unless $got == $i_child_pid;
360 $i_child_pid = undef;
361 return undef unless $?;
362 return "build host child ".waitstatusmsg();
367 fail "connection lost: $!" if $fh->error;
368 fail "protocol violation; $m not expected";
371 sub badproto_badread ($$) {
373 fail "connection lost: $!" if $!;
374 my $report = i_child_report();
375 fail $report if defined $report;
376 badproto $fh, "eof (reading $wh)";
379 sub protocol_expect (&$) {
380 my ($match, $fh) = @_;
383 defined && chomp or badproto_badread $fh, "protocol message";
391 badproto $fh, "\`$_'";
394 sub protocol_send_file ($$) {
395 my ($fh, $ourfn) = @_;
396 open PF, "<", $ourfn or die "$ourfn: $!";
399 my $got = read PF, $d, 65536;
400 die "$ourfn: $!" unless defined $got;
402 print $fh "data-block ".length($d)."\n" or die $!;
403 print $fh $d or die $!;
405 PF->error and die "$ourfn $!";
406 print $fh "data-end\n" or die $!;
410 sub protocol_read_bytes ($$) {
411 my ($fh, $nbytes) = @_;
412 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
414 my $got = read $fh, $d, $nbytes;
415 $got==$nbytes or badproto_badread $fh, "data block";
419 sub protocol_receive_file ($$) {
420 my ($fh, $ourfn) = @_;
421 printdebug "() $ourfn\n";
422 open PF, ">", $ourfn or die "$ourfn: $!";
424 my ($y,$l) = protocol_expect {
425 m/^data-block (.*)$/ ? (1,$1) :
426 m/^data-end$/ ? (0,) :
430 my $d = protocol_read_bytes $fh, $l;
431 print PF $d or die $!;
436 #---------- remote protocol support, responder ----------
438 sub responder_send_command ($) {
440 return unless $we_are_responder;
441 # called even without $we_are_responder
442 printdebug ">> $command\n";
443 print PO $command, "\n" or die $!;
446 sub responder_send_file ($$) {
447 my ($keyword, $ourfn) = @_;
448 return unless $we_are_responder;
449 printdebug "]] $keyword $ourfn\n";
450 responder_send_command "file $keyword";
451 protocol_send_file \*PO, $ourfn;
454 sub responder_receive_files ($@) {
455 my ($keyword, @ourfns) = @_;
456 die unless $we_are_responder;
457 printdebug "[[ $keyword @ourfns\n";
458 responder_send_command "want $keyword";
459 foreach my $fn (@ourfns) {
460 protocol_receive_file \*PI, $fn;
463 protocol_expect { m/^files-end$/ } \*PI;
466 #---------- remote protocol support, initiator ----------
468 sub initiator_expect (&) {
470 protocol_expect { &$match } \*RO;
473 #---------- end remote code ----------
476 if ($we_are_responder) {
478 responder_send_command "progress ".length($m) or die $!;
479 print PO $m or die $!;
489 $ua = LWP::UserAgent->new();
493 progress "downloading $what...";
494 my $r = $ua->get(@_) or die $!;
495 return undef if $r->code == 404;
496 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
497 return $r->decoded_content(charset => 'none');
500 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
505 failedcmd @_ if system @_;
508 sub act_local () { return $dryrun_level <= 1; }
509 sub act_scary () { return !$dryrun_level; }
512 if (!$dryrun_level) {
513 progress "dgit ok: @_";
515 progress "would be ok: @_ (but dry run only)";
520 printcmd(\*STDERR,$debugprefix."#",@_);
523 sub runcmd_ordryrun {
531 sub runcmd_ordryrun_local {
540 my ($first_shell, @cmd) = @_;
541 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
544 our $helpmsg = <<END;
546 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
547 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
548 dgit [dgit-opts] build [dpkg-buildpackage-opts]
549 dgit [dgit-opts] sbuild [sbuild-opts]
550 dgit [dgit-opts] push [dgit-opts] [suite]
551 dgit [dgit-opts] rpush build-host:build-dir ...
552 important dgit options:
553 -k<keyid> sign tag and package with <keyid> instead of default
554 --dry-run -n do not change anything, but go through the motions
555 --damp-run -L like --dry-run but make local changes, without signing
556 --new -N allow introducing a new package
557 --debug -D increase debug level
558 -c<name>=<value> set git config option (used directly by dgit too)
561 our $later_warning_msg = <<END;
562 Perhaps the upload is stuck in incoming. Using the version from git.
566 print STDERR "$us: @_\n", $helpmsg or die $!;
571 @ARGV or badusage "too few arguments";
572 return scalar shift @ARGV;
576 print $helpmsg or die $!;
580 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
582 our %defcfg = ('dgit.default.distro' => 'debian',
583 'dgit.default.username' => '',
584 'dgit.default.archive-query-default-component' => 'main',
585 'dgit.default.ssh' => 'ssh',
586 'dgit.default.archive-query' => 'madison:',
587 'dgit.default.sshpsql-dbname' => 'service=projectb',
588 'dgit.default.dgit-tag-format' => 'new,old,maint',
589 # old means "repo server accepts pushes with old dgit tags"
590 # new means "repo server accepts pushes with new dgit tags"
591 # maint means "repo server accepts split brain pushes"
592 # hist means "repo server may have old pushes without new tag"
593 # ("hist" is implied by "old")
594 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
595 'dgit-distro.debian.git-check' => 'url',
596 'dgit-distro.debian.git-check-suffix' => '/info/refs',
597 'dgit-distro.debian.new-private-pushers' => 't',
598 'dgit-distro.debian/push.git-url' => '',
599 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
600 'dgit-distro.debian/push.git-user-force' => 'dgit',
601 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
602 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
603 'dgit-distro.debian/push.git-create' => 'true',
604 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
605 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
606 # 'dgit-distro.debian.archive-query-tls-key',
607 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
608 # ^ this does not work because curl is broken nowadays
609 # Fixing #790093 properly will involve providing providing the key
610 # in some pacagke and maybe updating these paths.
612 # 'dgit-distro.debian.archive-query-tls-curl-args',
613 # '--ca-path=/etc/ssl/ca-debian',
614 # ^ this is a workaround but works (only) on DSA-administered machines
615 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
616 'dgit-distro.debian.git-url-suffix' => '',
617 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
618 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
619 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
620 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
621 'dgit-distro.ubuntu.git-check' => 'false',
622 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
623 'dgit-distro.test-dummy.ssh' => "$td/ssh",
624 'dgit-distro.test-dummy.username' => "alice",
625 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
626 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-url' => "$td/git",
628 'dgit-distro.test-dummy.git-host' => "git",
629 'dgit-distro.test-dummy.git-path' => "$td/git",
630 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
631 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
632 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
633 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
637 our @gitcfgsources = qw(cmdline local global system);
639 sub git_slurp_config () {
640 local ($debuglevel) = $debuglevel-2;
643 # This algoritm is a bit subtle, but this is needed so that for
644 # options which we want to be single-valued, we allow the
645 # different config sources to override properly. See #835858.
646 foreach my $src (@gitcfgsources) {
647 next if $src eq 'cmdline';
648 # we do this ourselves since git doesn't handle it
650 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
653 open GITS, "-|", @cmd or die $!;
656 printdebug "=> ", (messagequote $_), "\n";
658 push @{ $gitcfgs{$src}{$`} }, $'; #';
662 or ($!==0 && $?==256)
667 sub git_get_config ($) {
669 foreach my $src (@gitcfgsources) {
670 my $l = $gitcfgs{$src}{$c};
671 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
674 @$l==1 or badcfg "multiple values for $c".
675 " (in $src git config)" if @$l > 1;
683 return undef if $c =~ /RETURN-UNDEF/;
684 my $v = git_get_config($c);
685 return $v if defined $v;
686 my $dv = $defcfg{$c};
687 return $dv if defined $dv;
689 badcfg "need value for one of: @_\n".
690 "$us: distro or suite appears not to be (properly) supported";
693 sub access_basedistro () {
694 if (defined $idistro) {
697 return cfg("dgit-suite.$isuite.distro",
698 "dgit.default.distro");
702 sub access_quirk () {
703 # returns (quirk name, distro to use instead or undef, quirk-specific info)
704 my $basedistro = access_basedistro();
705 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
707 if (defined $backports_quirk) {
708 my $re = $backports_quirk;
709 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
711 $re =~ s/\%/([-0-9a-z_]+)/
712 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
713 if ($isuite =~ m/^$re$/) {
714 return ('backports',"$basedistro-backports",$1);
717 return ('none',undef);
722 sub parse_cfg_bool ($$$) {
723 my ($what,$def,$v) = @_;
726 $v =~ m/^[ty1]/ ? 1 :
727 $v =~ m/^[fn0]/ ? 0 :
728 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
731 sub access_forpush_config () {
732 my $d = access_basedistro();
736 parse_cfg_bool('new-private-pushers', 0,
737 cfg("dgit-distro.$d.new-private-pushers",
740 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
743 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
744 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
745 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
746 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
749 sub access_forpush () {
750 $access_forpush //= access_forpush_config();
751 return $access_forpush;
755 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
756 badcfg "pushing but distro is configured readonly"
757 if access_forpush_config() eq '0';
759 $supplementary_message = <<'END' unless $we_are_responder;
760 Push failed, before we got started.
761 You can retry the push, after fixing the problem, if you like.
763 finalise_opts_opts();
767 finalise_opts_opts();
770 sub supplementary_message ($) {
772 if (!$we_are_responder) {
773 $supplementary_message = $msg;
775 } elsif ($protovsn >= 3) {
776 responder_send_command "supplementary-message ".length($msg)
778 print PO $msg or die $!;
782 sub access_distros () {
783 # Returns list of distros to try, in order
786 # 0. `instead of' distro name(s) we have been pointed to
787 # 1. the access_quirk distro, if any
788 # 2a. the user's specified distro, or failing that } basedistro
789 # 2b. the distro calculated from the suite }
790 my @l = access_basedistro();
792 my (undef,$quirkdistro) = access_quirk();
793 unshift @l, $quirkdistro;
794 unshift @l, $instead_distro;
795 @l = grep { defined } @l;
797 if (access_forpush()) {
798 @l = map { ("$_/push", $_) } @l;
803 sub access_cfg_cfgs (@) {
806 # The nesting of these loops determines the search order. We put
807 # the key loop on the outside so that we search all the distros
808 # for each key, before going on to the next key. That means that
809 # if access_cfg is called with a more specific, and then a less
810 # specific, key, an earlier distro can override the less specific
811 # without necessarily overriding any more specific keys. (If the
812 # distro wants to override the more specific keys it can simply do
813 # so; whereas if we did the loop the other way around, it would be
814 # impossible to for an earlier distro to override a less specific
815 # key but not the more specific ones without restating the unknown
816 # values of the more specific keys.
819 # We have to deal with RETURN-UNDEF specially, so that we don't
820 # terminate the search prematurely.
822 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
825 foreach my $d (access_distros()) {
826 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
828 push @cfgs, map { "dgit.default.$_" } @realkeys;
835 my (@cfgs) = access_cfg_cfgs(@keys);
836 my $value = cfg(@cfgs);
840 sub access_cfg_bool ($$) {
841 my ($def, @keys) = @_;
842 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
845 sub string_to_ssh ($) {
847 if ($spec =~ m/\s/) {
848 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
854 sub access_cfg_ssh () {
855 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
856 if (!defined $gitssh) {
859 return string_to_ssh $gitssh;
863 sub access_runeinfo ($) {
865 return ": dgit ".access_basedistro()." $info ;";
868 sub access_someuserhost ($) {
870 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
871 defined($user) && length($user) or
872 $user = access_cfg("$some-user",'username');
873 my $host = access_cfg("$some-host");
874 return length($user) ? "$user\@$host" : $host;
877 sub access_gituserhost () {
878 return access_someuserhost('git');
881 sub access_giturl (;$) {
883 my $url = access_cfg('git-url','RETURN-UNDEF');
886 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
887 return undef unless defined $proto;
890 access_gituserhost().
891 access_cfg('git-path');
893 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
896 return "$url/$package$suffix";
899 sub parsecontrolfh ($$;$) {
900 my ($fh, $desc, $allowsigned) = @_;
901 our $dpkgcontrolhash_noissigned;
904 my %opts = ('name' => $desc);
905 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
906 $c = Dpkg::Control::Hash->new(%opts);
907 $c->parse($fh,$desc) or die "parsing of $desc failed";
908 last if $allowsigned;
909 last if $dpkgcontrolhash_noissigned;
910 my $issigned= $c->get_option('is_pgp_signed');
911 if (!defined $issigned) {
912 $dpkgcontrolhash_noissigned= 1;
913 seek $fh, 0,0 or die "seek $desc: $!";
914 } elsif ($issigned) {
915 fail "control file $desc is (already) PGP-signed. ".
916 " Note that dgit push needs to modify the .dsc and then".
917 " do the signature itself";
926 my ($file, $desc) = @_;
927 my $fh = new IO::Handle;
928 open $fh, '<', $file or die "$file: $!";
929 my $c = parsecontrolfh($fh,$desc);
930 $fh->error and die $!;
936 my ($dctrl,$field) = @_;
937 my $v = $dctrl->{$field};
938 return $v if defined $v;
939 fail "missing field $field in ".$dctrl->get_option('name');
943 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
944 my $p = new IO::Handle;
945 my @cmd = (qw(dpkg-parsechangelog), @_);
946 open $p, '-|', @cmd or die $!;
948 $?=0; $!=0; close $p or failedcmd @cmd;
952 sub commit_getclogp ($) {
953 # Returns the parsed changelog hashref for a particular commit
955 our %commit_getclogp_memo;
956 my $memo = $commit_getclogp_memo{$objid};
957 return $memo if $memo;
959 my $mclog = ".git/dgit/clog-$objid";
960 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
961 "$objid:debian/changelog";
962 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
967 defined $d or fail "getcwd failed: $!";
971 sub parse_dscdata () {
972 my $dscfh = new IO::File \$dscdata, '<' or die $!;
973 printdebug Dumper($dscdata) if $debuglevel>1;
974 $dsc = parsecontrolfh($dscfh,$dscurl,1);
975 printdebug Dumper($dsc) if $debuglevel>1;
980 sub archive_query ($;@) {
981 my ($method) = shift @_;
982 my $query = access_cfg('archive-query','RETURN-UNDEF');
983 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
986 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
989 sub pool_dsc_subpath ($$) {
990 my ($vsn,$component) = @_; # $package is implict arg
991 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
992 return "/pool/$component/$prefix/$package/".dscfn($vsn);
995 #---------- `ftpmasterapi' archive query method (nascent) ----------
997 sub archive_api_query_cmd ($) {
999 my @cmd = (@curl, qw(-sS));
1000 my $url = access_cfg('archive-query-url');
1001 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1003 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1004 foreach my $key (split /\:/, $keys) {
1005 $key =~ s/\%HOST\%/$host/g;
1007 fail "for $url: stat $key: $!" unless $!==ENOENT;
1010 fail "config requested specific TLS key but do not know".
1011 " how to get curl to use exactly that EE key ($key)";
1012 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1013 # # Sadly the above line does not work because of changes
1014 # # to gnutls. The real fix for #790093 may involve
1015 # # new curl options.
1018 # Fixing #790093 properly will involve providing a value
1019 # for this on clients.
1020 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1021 push @cmd, split / /, $kargs if defined $kargs;
1023 push @cmd, $url.$subpath;
1027 sub api_query ($$;$) {
1029 my ($data, $subpath, $ok404) = @_;
1030 badcfg "ftpmasterapi archive query method takes no data part"
1032 my @cmd = archive_api_query_cmd($subpath);
1033 my $url = $cmd[$#cmd];
1034 push @cmd, qw(-w %{http_code});
1035 my $json = cmdoutput @cmd;
1036 unless ($json =~ s/\d+\d+\d$//) {
1037 failedcmd_report_cmd undef, @cmd;
1038 fail "curl failed to print 3-digit HTTP code";
1041 return undef if $code eq '404' && $ok404;
1042 fail "fetch of $url gave HTTP code $code"
1043 unless $url =~ m#^file://# or $code =~ m/^2/;
1044 return decode_json($json);
1047 sub canonicalise_suite_ftpmasterapi {
1048 my ($proto,$data) = @_;
1049 my $suites = api_query($data, 'suites');
1051 foreach my $entry (@$suites) {
1053 my $v = $entry->{$_};
1054 defined $v && $v eq $isuite;
1055 } qw(codename name);
1056 push @matched, $entry;
1058 fail "unknown suite $isuite" unless @matched;
1061 @matched==1 or die "multiple matches for suite $isuite\n";
1062 $cn = "$matched[0]{codename}";
1063 defined $cn or die "suite $isuite info has no codename\n";
1064 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1066 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1071 sub archive_query_ftpmasterapi {
1072 my ($proto,$data) = @_;
1073 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1075 my $digester = Digest::SHA->new(256);
1076 foreach my $entry (@$info) {
1078 my $vsn = "$entry->{version}";
1079 my ($ok,$msg) = version_check $vsn;
1080 die "bad version: $msg\n" unless $ok;
1081 my $component = "$entry->{component}";
1082 $component =~ m/^$component_re$/ or die "bad component";
1083 my $filename = "$entry->{filename}";
1084 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1085 or die "bad filename";
1086 my $sha256sum = "$entry->{sha256sum}";
1087 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1088 push @rows, [ $vsn, "/pool/$component/$filename",
1089 $digester, $sha256sum ];
1091 die "bad ftpmaster api response: $@\n".Dumper($entry)
1094 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1098 sub file_in_archive_ftpmasterapi {
1099 my ($proto,$data,$filename) = @_;
1100 my $pat = $filename;
1103 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1104 my $info = api_query($data, "file_in_archive/$pat", 1);
1107 #---------- `dummyapicat' archive query method ----------
1109 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1110 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1112 sub file_in_archive_dummycatapi ($$$) {
1113 my ($proto,$data,$filename) = @_;
1114 my $mirror = access_cfg('mirror');
1115 $mirror =~ s#^file://#/# or die "$mirror ?";
1117 my @cmd = (qw(sh -ec), '
1119 find -name "$2" -print0 |
1121 ', qw(x), $mirror, $filename);
1122 debugcmd "-|", @cmd;
1123 open FIA, "-|", @cmd or die $!;
1126 printdebug "| $_\n";
1127 m/^(\w+) (\S+)$/ or die "$_ ?";
1128 push @out, { sha256sum => $1, filename => $2 };
1130 close FIA or die failedcmd @cmd;
1134 #---------- `madison' archive query method ----------
1136 sub archive_query_madison {
1137 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1140 sub madison_get_parse {
1141 my ($proto,$data) = @_;
1142 die unless $proto eq 'madison';
1143 if (!length $data) {
1144 $data= access_cfg('madison-distro','RETURN-UNDEF');
1145 $data //= access_basedistro();
1147 $rmad{$proto,$data,$package} ||= cmdoutput
1148 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1149 my $rmad = $rmad{$proto,$data,$package};
1152 foreach my $l (split /\n/, $rmad) {
1153 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1154 \s*( [^ \t|]+ )\s* \|
1155 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1156 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1157 $1 eq $package or die "$rmad $package ?";
1164 $component = access_cfg('archive-query-default-component');
1166 $5 eq 'source' or die "$rmad ?";
1167 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1169 return sort { -version_compare($a->[0],$b->[0]); } @out;
1172 sub canonicalise_suite_madison {
1173 # madison canonicalises for us
1174 my @r = madison_get_parse(@_);
1176 "unable to canonicalise suite using package $package".
1177 " which does not appear to exist in suite $isuite;".
1178 " --existing-package may help";
1182 sub file_in_archive_madison { return undef; }
1184 #---------- `sshpsql' archive query method ----------
1187 my ($data,$runeinfo,$sql) = @_;
1188 if (!length $data) {
1189 $data= access_someuserhost('sshpsql').':'.
1190 access_cfg('sshpsql-dbname');
1192 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1193 my ($userhost,$dbname) = ($`,$'); #';
1195 my @cmd = (access_cfg_ssh, $userhost,
1196 access_runeinfo("ssh-psql $runeinfo").
1197 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1198 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1200 open P, "-|", @cmd or die $!;
1203 printdebug(">|$_|\n");
1206 $!=0; $?=0; close P or failedcmd @cmd;
1208 my $nrows = pop @rows;
1209 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1210 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1211 @rows = map { [ split /\|/, $_ ] } @rows;
1212 my $ncols = scalar @{ shift @rows };
1213 die if grep { scalar @$_ != $ncols } @rows;
1217 sub sql_injection_check {
1218 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1221 sub archive_query_sshpsql ($$) {
1222 my ($proto,$data) = @_;
1223 sql_injection_check $isuite, $package;
1224 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1225 SELECT source.version, component.name, files.filename, files.sha256sum
1227 JOIN src_associations ON source.id = src_associations.source
1228 JOIN suite ON suite.id = src_associations.suite
1229 JOIN dsc_files ON dsc_files.source = source.id
1230 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1231 JOIN component ON component.id = files_archive_map.component_id
1232 JOIN files ON files.id = dsc_files.file
1233 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1234 AND source.source='$package'
1235 AND files.filename LIKE '%.dsc';
1237 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1238 my $digester = Digest::SHA->new(256);
1240 my ($vsn,$component,$filename,$sha256sum) = @$_;
1241 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1246 sub canonicalise_suite_sshpsql ($$) {
1247 my ($proto,$data) = @_;
1248 sql_injection_check $isuite;
1249 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1250 SELECT suite.codename
1251 FROM suite where suite_name='$isuite' or codename='$isuite';
1253 @rows = map { $_->[0] } @rows;
1254 fail "unknown suite $isuite" unless @rows;
1255 die "ambiguous $isuite: @rows ?" if @rows>1;
1259 sub file_in_archive_sshpsql ($$$) { return undef; }
1261 #---------- `dummycat' archive query method ----------
1263 sub canonicalise_suite_dummycat ($$) {
1264 my ($proto,$data) = @_;
1265 my $dpath = "$data/suite.$isuite";
1266 if (!open C, "<", $dpath) {
1267 $!==ENOENT or die "$dpath: $!";
1268 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1272 chomp or die "$dpath: $!";
1274 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1278 sub archive_query_dummycat ($$) {
1279 my ($proto,$data) = @_;
1280 canonicalise_suite();
1281 my $dpath = "$data/package.$csuite.$package";
1282 if (!open C, "<", $dpath) {
1283 $!==ENOENT or die "$dpath: $!";
1284 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1292 printdebug "dummycat query $csuite $package $dpath | $_\n";
1293 my @row = split /\s+/, $_;
1294 @row==2 or die "$dpath: $_ ?";
1297 C->error and die "$dpath: $!";
1299 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1302 sub file_in_archive_dummycat () { return undef; }
1304 #---------- tag format handling ----------
1306 sub access_cfg_tagformats () {
1307 split /\,/, access_cfg('dgit-tag-format');
1310 sub need_tagformat ($$) {
1311 my ($fmt, $why) = @_;
1312 fail "need to use tag format $fmt ($why) but also need".
1313 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1314 " - no way to proceed"
1315 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1316 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1319 sub select_tagformat () {
1321 return if $tagformatfn && !$tagformat_want;
1322 die 'bug' if $tagformatfn && $tagformat_want;
1323 # ... $tagformat_want assigned after previous select_tagformat
1325 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1326 printdebug "select_tagformat supported @supported\n";
1328 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1329 printdebug "select_tagformat specified @$tagformat_want\n";
1331 my ($fmt,$why,$override) = @$tagformat_want;
1333 fail "target distro supports tag formats @supported".
1334 " but have to use $fmt ($why)"
1336 or grep { $_ eq $fmt } @supported;
1338 $tagformat_want = undef;
1340 $tagformatfn = ${*::}{"debiantag_$fmt"};
1342 fail "trying to use unknown tag format \`$fmt' ($why) !"
1343 unless $tagformatfn;
1346 #---------- archive query entrypoints and rest of program ----------
1348 sub canonicalise_suite () {
1349 return if defined $csuite;
1350 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1351 $csuite = archive_query('canonicalise_suite');
1352 if ($isuite ne $csuite) {
1353 progress "canonical suite name for $isuite is $csuite";
1357 sub get_archive_dsc () {
1358 canonicalise_suite();
1359 my @vsns = archive_query('archive_query');
1360 foreach my $vinfo (@vsns) {
1361 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1362 $dscurl = access_cfg('mirror').$subpath;
1363 $dscdata = url_get($dscurl);
1365 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1370 $digester->add($dscdata);
1371 my $got = $digester->hexdigest();
1373 fail "$dscurl has hash $got but".
1374 " archive told us to expect $digest";
1377 my $fmt = getfield $dsc, 'Format';
1378 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1379 "unsupported source format $fmt, sorry";
1381 $dsc_checked = !!$digester;
1382 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1386 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1389 sub check_for_git ();
1390 sub check_for_git () {
1392 my $how = access_cfg('git-check');
1393 if ($how eq 'ssh-cmd') {
1395 (access_cfg_ssh, access_gituserhost(),
1396 access_runeinfo("git-check $package").
1397 " set -e; cd ".access_cfg('git-path').";".
1398 " if test -d $package.git; then echo 1; else echo 0; fi");
1399 my $r= cmdoutput @cmd;
1400 if (defined $r and $r =~ m/^divert (\w+)$/) {
1402 my ($usedistro,) = access_distros();
1403 # NB that if we are pushing, $usedistro will be $distro/push
1404 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1405 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1406 progress "diverting to $divert (using config for $instead_distro)";
1407 return check_for_git();
1409 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1411 } elsif ($how eq 'url') {
1412 my $prefix = access_cfg('git-check-url','git-url');
1413 my $suffix = access_cfg('git-check-suffix','git-suffix',
1414 'RETURN-UNDEF') // '.git';
1415 my $url = "$prefix/$package$suffix";
1416 my @cmd = (@curl, qw(-sS -I), $url);
1417 my $result = cmdoutput @cmd;
1418 $result =~ s/^\S+ 200 .*\n\r?\n//;
1419 # curl -sS -I with https_proxy prints
1420 # HTTP/1.0 200 Connection established
1421 $result =~ m/^\S+ (404|200) /s or
1422 fail "unexpected results from git check query - ".
1423 Dumper($prefix, $result);
1425 if ($code eq '404') {
1427 } elsif ($code eq '200') {
1432 } elsif ($how eq 'true') {
1434 } elsif ($how eq 'false') {
1437 badcfg "unknown git-check \`$how'";
1441 sub create_remote_git_repo () {
1442 my $how = access_cfg('git-create');
1443 if ($how eq 'ssh-cmd') {
1445 (access_cfg_ssh, access_gituserhost(),
1446 access_runeinfo("git-create $package").
1447 "set -e; cd ".access_cfg('git-path').";".
1448 " cp -a _template $package.git");
1449 } elsif ($how eq 'true') {
1452 badcfg "unknown git-create \`$how'";
1456 our ($dsc_hash,$lastpush_mergeinput);
1458 our $ud = '.git/dgit/unpack';
1468 sub mktree_in_ud_here () {
1469 runcmd qw(git init -q);
1470 runcmd qw(git config gc.auto 0);
1471 rmtree('.git/objects');
1472 symlink '../../../../objects','.git/objects' or die $!;
1475 sub git_write_tree () {
1476 my $tree = cmdoutput @git, qw(write-tree);
1477 $tree =~ m/^\w+$/ or die "$tree ?";
1481 sub remove_stray_gits () {
1482 my @gitscmd = qw(find -name .git -prune -print0);
1483 debugcmd "|",@gitscmd;
1484 open GITS, "-|", @gitscmd or die $!;
1489 print STDERR "$us: warning: removing from source package: ",
1490 (messagequote $_), "\n";
1494 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1497 sub mktree_in_ud_from_only_subdir (;$) {
1500 # changes into the subdir
1502 die "expected one subdir but found @dirs ?" unless @dirs==1;
1503 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1507 remove_stray_gits();
1508 mktree_in_ud_here();
1510 my ($format, $fopts) = get_source_format();
1511 if (madformat($format)) {
1516 runcmd @git, qw(add -Af);
1517 my $tree=git_write_tree();
1518 return ($tree,$dir);
1521 our @files_csum_info_fields =
1522 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1523 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1524 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1526 sub dsc_files_info () {
1527 foreach my $csumi (@files_csum_info_fields) {
1528 my ($fname, $module, $method) = @$csumi;
1529 my $field = $dsc->{$fname};
1530 next unless defined $field;
1531 eval "use $module; 1;" or die $@;
1533 foreach (split /\n/, $field) {
1535 m/^(\w+) (\d+) (\S+)$/ or
1536 fail "could not parse .dsc $fname line \`$_'";
1537 my $digester = eval "$module"."->$method;" or die $@;
1542 Digester => $digester,
1547 fail "missing any supported Checksums-* or Files field in ".
1548 $dsc->get_option('name');
1552 map { $_->{Filename} } dsc_files_info();
1555 sub files_compare_inputs (@) {
1560 my $showinputs = sub {
1561 return join "; ", map { $_->get_option('name') } @$inputs;
1564 foreach my $in (@$inputs) {
1566 my $in_name = $in->get_option('name');
1568 printdebug "files_compare_inputs $in_name\n";
1570 foreach my $csumi (@files_csum_info_fields) {
1571 my ($fname) = @$csumi;
1572 printdebug "files_compare_inputs $in_name $fname\n";
1574 my $field = $in->{$fname};
1575 next unless defined $field;
1578 foreach (split /\n/, $field) {
1581 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1582 fail "could not parse $in_name $fname line \`$_'";
1584 printdebug "files_compare_inputs $in_name $fname $f\n";
1588 my $re = \ $record{$f}{$fname};
1590 $fchecked{$f}{$in_name} = 1;
1592 fail "hash or size of $f varies in $fname fields".
1593 " (between: ".$showinputs->().")";
1598 @files = sort @files;
1599 $expected_files //= \@files;
1600 "@$expected_files" eq "@files" or
1601 fail "file list in $in_name varies between hash fields!";
1604 fail "$in_name has no files list field(s)";
1606 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1609 grep { keys %$_ == @$inputs-1 } values %fchecked
1610 or fail "no file appears in all file lists".
1611 " (looked in: ".$showinputs->().")";
1614 sub is_orig_file_in_dsc ($$) {
1615 my ($f, $dsc_files_info) = @_;
1616 return 0 if @$dsc_files_info <= 1;
1617 # One file means no origs, and the filename doesn't have a "what
1618 # part of dsc" component. (Consider versions ending `.orig'.)
1619 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1623 sub is_orig_file_of_vsn ($$) {
1624 my ($f, $upstreamvsn) = @_;
1625 my $base = srcfn $upstreamvsn, '';
1626 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1630 sub changes_update_origs_from_dsc ($$$$) {
1631 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1633 printdebug "checking origs needed ($upstreamvsn)...\n";
1634 $_ = getfield $changes, 'Files';
1635 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1636 fail "cannot find section/priority from .changes Files field";
1637 my $placementinfo = $1;
1639 printdebug "checking origs needed placement '$placementinfo'...\n";
1640 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1641 $l =~ m/\S+$/ or next;
1643 printdebug "origs $file | $l\n";
1644 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1645 printdebug "origs $file is_orig\n";
1646 my $have = archive_query('file_in_archive', $file);
1647 if (!defined $have) {
1649 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1655 printdebug "origs $file \$#\$have=$#$have\n";
1656 foreach my $h (@$have) {
1659 foreach my $csumi (@files_csum_info_fields) {
1660 my ($fname, $module, $method, $archivefield) = @$csumi;
1661 next unless defined $h->{$archivefield};
1662 $_ = $dsc->{$fname};
1663 next unless defined;
1664 m/^(\w+) .* \Q$file\E$/m or
1665 fail ".dsc $fname missing entry for $file";
1666 if ($h->{$archivefield} eq $1) {
1670 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1673 die "$file ".Dumper($h)." ?!" if $same && @differ;
1676 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1679 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1680 if (@found_differ && !$found_same) {
1682 "archive contains $file with different checksum",
1685 # Now we edit the changes file to add or remove it
1686 foreach my $csumi (@files_csum_info_fields) {
1687 my ($fname, $module, $method, $archivefield) = @$csumi;
1688 next unless defined $changes->{$fname};
1690 # in archive, delete from .changes if it's there
1691 $changed{$file} = "removed" if
1692 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1693 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1694 # not in archive, but it's here in the .changes
1696 my $dsc_data = getfield $dsc, $fname;
1697 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1699 $extra =~ s/ \d+ /$&$placementinfo /
1700 or die "$fname $extra >$dsc_data< ?"
1701 if $fname eq 'Files';
1702 $changes->{$fname} .= "\n". $extra;
1703 $changed{$file} = "added";
1708 foreach my $file (keys %changed) {
1710 "edited .changes for archive .orig contents: %s %s",
1711 $changed{$file}, $file;
1713 my $chtmp = "$changesfile.tmp";
1714 $changes->save($chtmp);
1716 rename $chtmp,$changesfile or die "$changesfile $!";
1718 progress "[new .changes left in $changesfile]";
1721 progress "$changesfile already has appropriate .orig(s) (if any)";
1725 sub make_commit ($) {
1727 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1730 sub make_commit_text ($) {
1733 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1735 print Dumper($text) if $debuglevel > 1;
1736 my $child = open2($out, $in, @cmd) or die $!;
1739 print $in $text or die $!;
1740 close $in or die $!;
1742 $h =~ m/^\w+$/ or die;
1744 printdebug "=> $h\n";
1747 waitpid $child, 0 == $child or die "$child $!";
1748 $? and failedcmd @cmd;
1752 sub clogp_authline ($) {
1754 my $author = getfield $clogp, 'Maintainer';
1755 $author =~ s#,.*##ms;
1756 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1757 my $authline = "$author $date";
1758 $authline =~ m/$git_authline_re/o or
1759 fail "unexpected commit author line format \`$authline'".
1760 " (was generated from changelog Maintainer field)";
1761 return ($1,$2,$3) if wantarray;
1765 sub vendor_patches_distro ($$) {
1766 my ($checkdistro, $what) = @_;
1767 return unless defined $checkdistro;
1769 my $series = "debian/patches/\L$checkdistro\E.series";
1770 printdebug "checking for vendor-specific $series ($what)\n";
1772 if (!open SERIES, "<", $series) {
1773 die "$series $!" unless $!==ENOENT;
1782 Unfortunately, this source package uses a feature of dpkg-source where
1783 the same source package unpacks to different source code on different
1784 distros. dgit cannot safely operate on such packages on affected
1785 distros, because the meaning of source packages is not stable.
1787 Please ask the distro/maintainer to remove the distro-specific series
1788 files and use a different technique (if necessary, uploading actually
1789 different packages, if different distros are supposed to have
1793 fail "Found active distro-specific series file for".
1794 " $checkdistro ($what): $series, cannot continue";
1796 die "$series $!" if SERIES->error;
1800 sub check_for_vendor_patches () {
1801 # This dpkg-source feature doesn't seem to be documented anywhere!
1802 # But it can be found in the changelog (reformatted):
1804 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1805 # Author: Raphael Hertzog <hertzog@debian.org>
1806 # Date: Sun Oct 3 09:36:48 2010 +0200
1808 # dpkg-source: correctly create .pc/.quilt_series with alternate
1811 # If you have debian/patches/ubuntu.series and you were
1812 # unpacking the source package on ubuntu, quilt was still
1813 # directed to debian/patches/series instead of
1814 # debian/patches/ubuntu.series.
1816 # debian/changelog | 3 +++
1817 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1818 # 2 files changed, 6 insertions(+), 1 deletion(-)
1821 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1822 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1823 "Dpkg::Vendor \`current vendor'");
1824 vendor_patches_distro(access_basedistro(),
1825 "distro being accessed");
1828 sub generate_commits_from_dsc () {
1829 # See big comment in fetch_from_archive, below.
1830 # See also README.dsc-import.
1834 my @dfi = dsc_files_info();
1835 foreach my $fi (@dfi) {
1836 my $f = $fi->{Filename};
1837 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1839 printdebug "considering linking $f: ";
1841 link_ltarget "../../../../$f", $f
1842 or ((printdebug "($!) "), 0)
1846 printdebug "linked.\n";
1848 complete_file_from_dsc('.', $fi)
1851 if (is_orig_file_in_dsc($f, \@dfi)) {
1852 link $f, "../../../../$f"
1858 # We unpack and record the orig tarballs first, so that we only
1859 # need disk space for one private copy of the unpacked source.
1860 # But we can't make them into commits until we have the metadata
1861 # from the debian/changelog, so we record the tree objects now and
1862 # make them into commits later.
1864 my $upstreamv = upstreamversion $dsc->{version};
1865 my $orig_f_base = srcfn $upstreamv, '';
1867 foreach my $fi (@dfi) {
1868 # We actually import, and record as a commit, every tarball
1869 # (unless there is only one file, in which case there seems
1872 my $f = $fi->{Filename};
1873 printdebug "import considering $f ";
1874 (printdebug "only one dfi\n"), next if @dfi == 1;
1875 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1876 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1880 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1882 printdebug "Y ", (join ' ', map { $_//"(none)" }
1883 $compr_ext, $orig_f_part
1886 my $input = new IO::File $f, '<' or die "$f $!";
1890 if (defined $compr_ext) {
1892 Dpkg::Compression::compression_guess_from_filename $f;
1893 fail "Dpkg::Compression cannot handle file $f in source package"
1894 if defined $compr_ext && !defined $cname;
1896 new Dpkg::Compression::Process compression => $cname;
1897 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1898 my $compr_fh = new IO::Handle;
1899 my $compr_pid = open $compr_fh, "-|" // die $!;
1901 open STDIN, "<&", $input or die $!;
1903 die "dgit (child): exec $compr_cmd[0]: $!\n";
1908 rmtree "../unpack-tar";
1909 mkdir "../unpack-tar" or die $!;
1910 my @tarcmd = qw(tar -x -f -
1911 --no-same-owner --no-same-permissions
1912 --no-acls --no-xattrs --no-selinux);
1913 my $tar_pid = fork // die $!;
1915 chdir "../unpack-tar" or die $!;
1916 open STDIN, "<&", $input or die $!;
1918 die "dgit (child): exec $tarcmd[0]: $!";
1920 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1921 !$? or failedcmd @tarcmd;
1924 (@compr_cmd ? failedcmd @compr_cmd
1926 # finally, we have the results in "tarball", but maybe
1927 # with the wrong permissions
1929 runcmd qw(chmod -R +rwX ../unpack-tar);
1930 changedir "../unpack-tar";
1931 my ($tree) = mktree_in_ud_from_only_subdir(1);
1932 changedir "../../unpack";
1933 rmtree "../unpack-tar";
1935 my $ent = [ $f, $tree ];
1937 Orig => !!$orig_f_part,
1938 Sort => (!$orig_f_part ? 2 :
1939 $orig_f_part =~ m/-/g ? 1 :
1947 # put any without "_" first (spec is not clear whether files
1948 # are always in the usual order). Tarballs without "_" are
1949 # the main orig or the debian tarball.
1950 $a->{Sort} <=> $b->{Sort} or
1954 my $any_orig = grep { $_->{Orig} } @tartrees;
1956 my $dscfn = "$package.dsc";
1958 my $treeimporthow = 'package';
1960 open D, ">", $dscfn or die "$dscfn: $!";
1961 print D $dscdata or die "$dscfn: $!";
1962 close D or die "$dscfn: $!";
1963 my @cmd = qw(dpkg-source);
1964 push @cmd, '--no-check' if $dsc_checked;
1965 if (madformat $dsc->{format}) {
1966 push @cmd, '--skip-patches';
1967 $treeimporthow = 'unpatched';
1969 push @cmd, qw(-x --), $dscfn;
1972 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1973 if (madformat $dsc->{format}) {
1974 check_for_vendor_patches();
1978 if (madformat $dsc->{format}) {
1979 my @pcmd = qw(dpkg-source --before-build .);
1980 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1982 runcmd @git, qw(add -Af);
1983 $dappliedtree = git_write_tree();
1986 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1987 debugcmd "|",@clogcmd;
1988 open CLOGS, "-|", @clogcmd or die $!;
1993 printdebug "import clog search...\n";
1996 my $stanzatext = do { local $/=""; <CLOGS>; };
1997 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1998 last if !defined $stanzatext;
2000 my $desc = "package changelog, entry no.$.";
2001 open my $stanzafh, "<", \$stanzatext or die;
2002 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2003 $clogp //= $thisstanza;
2005 printdebug "import clog $thisstanza->{version} $desc...\n";
2007 last if !$any_orig; # we don't need $r1clogp
2009 # We look for the first (most recent) changelog entry whose
2010 # version number is lower than the upstream version of this
2011 # package. Then the last (least recent) previous changelog
2012 # entry is treated as the one which introduced this upstream
2013 # version and used for the synthetic commits for the upstream
2016 # One might think that a more sophisticated algorithm would be
2017 # necessary. But: we do not want to scan the whole changelog
2018 # file. Stopping when we see an earlier version, which
2019 # necessarily then is an earlier upstream version, is the only
2020 # realistic way to do that. Then, either the earliest
2021 # changelog entry we have seen so far is indeed the earliest
2022 # upload of this upstream version; or there are only changelog
2023 # entries relating to later upstream versions (which is not
2024 # possible unless the changelog and .dsc disagree about the
2025 # version). Then it remains to choose between the physically
2026 # last entry in the file, and the one with the lowest version
2027 # number. If these are not the same, we guess that the
2028 # versions were created in a non-monotic order rather than
2029 # that the changelog entries have been misordered.
2031 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2033 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2034 $r1clogp = $thisstanza;
2036 printdebug "import clog $r1clogp->{version} becomes r1\n";
2038 die $! if CLOGS->error;
2039 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2041 $clogp or fail "package changelog has no entries!";
2043 my $authline = clogp_authline $clogp;
2044 my $changes = getfield $clogp, 'Changes';
2045 my $cversion = getfield $clogp, 'Version';
2048 $r1clogp //= $clogp; # maybe there's only one entry;
2049 my $r1authline = clogp_authline $r1clogp;
2050 # Strictly, r1authline might now be wrong if it's going to be
2051 # unused because !$any_orig. Whatever.
2053 printdebug "import tartrees authline $authline\n";
2054 printdebug "import tartrees r1authline $r1authline\n";
2056 foreach my $tt (@tartrees) {
2057 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2059 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2062 committer $r1authline
2066 [dgit import orig $tt->{F}]
2074 [dgit import tarball $package $cversion $tt->{F}]
2079 printdebug "import main commit\n";
2081 open C, ">../commit.tmp" or die $!;
2082 print C <<END or die $!;
2085 print C <<END or die $! foreach @tartrees;
2088 print C <<END or die $!;
2094 [dgit import $treeimporthow $package $cversion]
2098 my $rawimport_hash = make_commit qw(../commit.tmp);
2100 if (madformat $dsc->{format}) {
2101 printdebug "import apply patches...\n";
2103 # regularise the state of the working tree so that
2104 # the checkout of $rawimport_hash works nicely.
2105 my $dappliedcommit = make_commit_text(<<END);
2112 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2114 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2116 # We need the answers to be reproducible
2117 my @authline = clogp_authline($clogp);
2118 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2119 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2120 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2121 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2122 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2123 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2125 my $path = $ENV{PATH} or die;
2127 foreach my $use_absurd (qw(0 1)) {
2128 local $ENV{PATH} = $path;
2131 progress "warning: $@";
2132 $path = "$absurdity:$path";
2133 progress "$us: trying slow absurd-git-apply...";
2134 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2139 die "forbid absurd git-apply\n" if $use_absurd
2140 && forceing [qw(import-gitapply-no-absurd)];
2141 die "only absurd git-apply!\n" if !$use_absurd
2142 && forceing [qw(import-gitapply-absurd)];
2144 local $ENV{PATH} = $path if $use_absurd;
2146 my @showcmd = (gbp_pq, qw(import));
2147 my @realcmd = shell_cmd
2148 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2149 debugcmd "+",@realcmd;
2150 if (system @realcmd) {
2151 die +(shellquote @showcmd).
2153 failedcmd_waitstatus()."\n";
2156 my $gapplied = git_rev_parse('HEAD');
2157 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2158 $gappliedtree eq $dappliedtree or
2160 gbp-pq import and dpkg-source disagree!
2161 gbp-pq import gave commit $gapplied
2162 gbp-pq import gave tree $gappliedtree
2163 dpkg-source --before-build gave tree $dappliedtree
2165 $rawimport_hash = $gapplied;
2170 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2175 progress "synthesised git commit from .dsc $cversion";
2177 my $rawimport_mergeinput = {
2178 Commit => $rawimport_hash,
2179 Info => "Import of source package",
2181 my @output = ($rawimport_mergeinput);
2183 if ($lastpush_mergeinput) {
2184 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2185 my $oversion = getfield $oldclogp, 'Version';
2187 version_compare($oversion, $cversion);
2189 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2190 { Message => <<END, ReverseParents => 1 });
2191 Record $package ($cversion) in archive suite $csuite
2193 } elsif ($vcmp > 0) {
2194 print STDERR <<END or die $!;
2196 Version actually in archive: $cversion (older)
2197 Last version pushed with dgit: $oversion (newer or same)
2200 @output = $lastpush_mergeinput;
2202 # Same version. Use what's in the server git branch,
2203 # discarding our own import. (This could happen if the
2204 # server automatically imports all packages into git.)
2205 @output = $lastpush_mergeinput;
2208 changedir '../../../..';
2213 sub complete_file_from_dsc ($$) {
2214 our ($dstdir, $fi) = @_;
2215 # Ensures that we have, in $dir, the file $fi, with the correct
2216 # contents. (Downloading it from alongside $dscurl if necessary.)
2218 my $f = $fi->{Filename};
2219 my $tf = "$dstdir/$f";
2222 if (stat_exists $tf) {
2223 progress "using existing $f";
2225 printdebug "$tf does not exist, need to fetch\n";
2227 $furl =~ s{/[^/]+$}{};
2229 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2230 die "$f ?" if $f =~ m#/#;
2231 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2232 return 0 if !act_local();
2236 open F, "<", "$tf" or die "$tf: $!";
2237 $fi->{Digester}->reset();
2238 $fi->{Digester}->addfile(*F);
2239 F->error and die $!;
2240 my $got = $fi->{Digester}->hexdigest();
2241 $got eq $fi->{Hash} or
2242 fail "file $f has hash $got but .dsc".
2243 " demands hash $fi->{Hash} ".
2244 ($downloaded ? "(got wrong file from archive!)"
2245 : "(perhaps you should delete this file?)");
2250 sub ensure_we_have_orig () {
2251 my @dfi = dsc_files_info();
2252 foreach my $fi (@dfi) {
2253 my $f = $fi->{Filename};
2254 next unless is_orig_file_in_dsc($f, \@dfi);
2255 complete_file_from_dsc('..', $fi)
2260 sub git_fetch_us () {
2261 # Want to fetch only what we are going to use, unless
2262 # deliberately-not-ff, in which case we must fetch everything.
2264 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2266 (quiltmode_splitbrain
2267 ? (map { $_->('*',access_basedistro) }
2268 \&debiantag_new, \&debiantag_maintview)
2269 : debiantags('*',access_basedistro));
2270 push @specs, server_branch($csuite);
2271 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2273 # This is rather miserable:
2274 # When git fetch --prune is passed a fetchspec ending with a *,
2275 # it does a plausible thing. If there is no * then:
2276 # - it matches subpaths too, even if the supplied refspec
2277 # starts refs, and behaves completely madly if the source
2278 # has refs/refs/something. (See, for example, Debian #NNNN.)
2279 # - if there is no matching remote ref, it bombs out the whole
2281 # We want to fetch a fixed ref, and we don't know in advance
2282 # if it exists, so this is not suitable.
2284 # Our workaround is to use git ls-remote. git ls-remote has its
2285 # own qairks. Notably, it has the absurd multi-tail-matching
2286 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2287 # refs/refs/foo etc.
2289 # Also, we want an idempotent snapshot, but we have to make two
2290 # calls to the remote: one to git ls-remote and to git fetch. The
2291 # solution is use git ls-remote to obtain a target state, and
2292 # git fetch to try to generate it. If we don't manage to generate
2293 # the target state, we try again.
2295 my $specre = join '|', map {
2301 printdebug "git_fetch_us specre=$specre\n";
2302 my $wanted_rref = sub {
2304 return m/^(?:$specre)$/o;
2307 my $fetch_iteration = 0;
2310 if (++$fetch_iteration > 10) {
2311 fail "too many iterations trying to get sane fetch!";
2314 my @look = map { "refs/$_" } @specs;
2315 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2319 open GITLS, "-|", @lcmd or die $!;
2321 printdebug "=> ", $_;
2322 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2323 my ($objid,$rrefname) = ($1,$2);
2324 if (!$wanted_rref->($rrefname)) {
2326 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2330 $wantr{$rrefname} = $objid;
2333 close GITLS or failedcmd @lcmd;
2335 # OK, now %want is exactly what we want for refs in @specs
2337 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2338 "+refs/$_:".lrfetchrefs."/$_";
2341 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2342 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2345 %lrfetchrefs_f = ();
2348 git_for_each_ref(lrfetchrefs, sub {
2349 my ($objid,$objtype,$lrefname,$reftail) = @_;
2350 $lrfetchrefs_f{$lrefname} = $objid;
2351 $objgot{$objid} = 1;
2354 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2355 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2356 if (!exists $wantr{$rrefname}) {
2357 if ($wanted_rref->($rrefname)) {
2359 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2363 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2366 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2367 delete $lrfetchrefs_f{$lrefname};
2371 foreach my $rrefname (sort keys %wantr) {
2372 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2373 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2374 my $want = $wantr{$rrefname};
2375 next if $got eq $want;
2376 if (!defined $objgot{$want}) {
2378 warning: git ls-remote suggests we want $lrefname
2379 warning: and it should refer to $want
2380 warning: but git fetch didn't fetch that object to any relevant ref.
2381 warning: This may be due to a race with someone updating the server.
2382 warning: Will try again...
2384 next FETCH_ITERATION;
2387 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2389 runcmd_ordryrun_local @git, qw(update-ref -m),
2390 "dgit fetch git fetch fixup", $lrefname, $want;
2391 $lrfetchrefs_f{$lrefname} = $want;
2395 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2396 Dumper(\%lrfetchrefs_f);
2399 my @tagpats = debiantags('*',access_basedistro);
2401 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2402 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2403 printdebug "currently $fullrefname=$objid\n";
2404 $here{$fullrefname} = $objid;
2406 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2408 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2409 printdebug "offered $lref=$objid\n";
2410 if (!defined $here{$lref}) {
2411 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2412 runcmd_ordryrun_local @upd;
2413 lrfetchref_used $fullrefname;
2414 } elsif ($here{$lref} eq $objid) {
2415 lrfetchref_used $fullrefname;
2418 "Not updateting $lref from $here{$lref} to $objid.\n";
2423 sub mergeinfo_getclogp ($) {
2424 # Ensures thit $mi->{Clogp} exists and returns it
2426 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2429 sub mergeinfo_version ($) {
2430 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2433 sub fetch_from_archive () {
2434 ensure_setup_existing_tree();
2436 # Ensures that lrref() is what is actually in the archive, one way
2437 # or another, according to us - ie this client's
2438 # appropritaely-updated archive view. Also returns the commit id.
2439 # If there is nothing in the archive, leaves lrref alone and
2440 # returns undef. git_fetch_us must have already been called.
2444 foreach my $field (@ourdscfield) {
2445 $dsc_hash = $dsc->{$field};
2446 last if defined $dsc_hash;
2448 if (defined $dsc_hash) {
2449 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2451 progress "last upload to archive specified git hash";
2453 progress "last upload to archive has NO git hash";
2456 progress "no version available from the archive";
2459 # If the archive's .dsc has a Dgit field, there are three
2460 # relevant git commitids we need to choose between and/or merge
2462 # 1. $dsc_hash: the Dgit field from the archive
2463 # 2. $lastpush_hash: the suite branch on the dgit git server
2464 # 3. $lastfetch_hash: our local tracking brach for the suite
2466 # These may all be distinct and need not be in any fast forward
2469 # If the dsc was pushed to this suite, then the server suite
2470 # branch will have been updated; but it might have been pushed to
2471 # a different suite and copied by the archive. Conversely a more
2472 # recent version may have been pushed with dgit but not appeared
2473 # in the archive (yet).
2475 # $lastfetch_hash may be awkward because archive imports
2476 # (particularly, imports of Dgit-less .dscs) are performed only as
2477 # needed on individual clients, so different clients may perform a
2478 # different subset of them - and these imports are only made
2479 # public during push. So $lastfetch_hash may represent a set of
2480 # imports different to a subsequent upload by a different dgit
2483 # Our approach is as follows:
2485 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2486 # descendant of $dsc_hash, then it was pushed by a dgit user who
2487 # had based their work on $dsc_hash, so we should prefer it.
2488 # Otherwise, $dsc_hash was installed into this suite in the
2489 # archive other than by a dgit push, and (necessarily) after the
2490 # last dgit push into that suite (since a dgit push would have
2491 # been descended from the dgit server git branch); thus, in that
2492 # case, we prefer the archive's version (and produce a
2493 # pseudo-merge to overwrite the dgit server git branch).
2495 # (If there is no Dgit field in the archive's .dsc then
2496 # generate_commit_from_dsc uses the version numbers to decide
2497 # whether the suite branch or the archive is newer. If the suite
2498 # branch is newer it ignores the archive's .dsc; otherwise it
2499 # generates an import of the .dsc, and produces a pseudo-merge to
2500 # overwrite the suite branch with the archive contents.)
2502 # The outcome of that part of the algorithm is the `public view',
2503 # and is same for all dgit clients: it does not depend on any
2504 # unpublished history in the local tracking branch.
2506 # As between the public view and the local tracking branch: The
2507 # local tracking branch is only updated by dgit fetch, and
2508 # whenever dgit fetch runs it includes the public view in the
2509 # local tracking branch. Therefore if the public view is not
2510 # descended from the local tracking branch, the local tracking
2511 # branch must contain history which was imported from the archive
2512 # but never pushed; and, its tip is now out of date. So, we make
2513 # a pseudo-merge to overwrite the old imports and stitch the old
2516 # Finally: we do not necessarily reify the public view (as
2517 # described above). This is so that we do not end up stacking two
2518 # pseudo-merges. So what we actually do is figure out the inputs
2519 # to any public view pseudo-merge and put them in @mergeinputs.
2522 # $mergeinputs[]{Commit}
2523 # $mergeinputs[]{Info}
2524 # $mergeinputs[0] is the one whose tree we use
2525 # @mergeinputs is in the order we use in the actual commit)
2528 # $mergeinputs[]{Message} is a commit message to use
2529 # $mergeinputs[]{ReverseParents} if def specifies that parent
2530 # list should be in opposite order
2531 # Such an entry has no Commit or Info. It applies only when found
2532 # in the last entry. (This ugliness is to support making
2533 # identical imports to previous dgit versions.)
2535 my $lastpush_hash = git_get_ref(lrfetchref());
2536 printdebug "previous reference hash=$lastpush_hash\n";
2537 $lastpush_mergeinput = $lastpush_hash && {
2538 Commit => $lastpush_hash,
2539 Info => "dgit suite branch on dgit git server",
2542 my $lastfetch_hash = git_get_ref(lrref());
2543 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2544 my $lastfetch_mergeinput = $lastfetch_hash && {
2545 Commit => $lastfetch_hash,
2546 Info => "dgit client's archive history view",
2549 my $dsc_mergeinput = $dsc_hash && {
2550 Commit => $dsc_hash,
2551 Info => "Dgit field in .dsc from archive",
2555 my $del_lrfetchrefs = sub {
2558 printdebug "del_lrfetchrefs...\n";
2559 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2560 my $objid = $lrfetchrefs_d{$fullrefname};
2561 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2563 $gur ||= new IO::Handle;
2564 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2566 printf $gur "delete %s %s\n", $fullrefname, $objid;
2569 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2573 if (defined $dsc_hash) {
2574 ensure_we_have_orig();
2575 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2576 @mergeinputs = $dsc_mergeinput
2577 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2578 print STDERR <<END or die $!;
2580 Git commit in archive is behind the last version allegedly pushed/uploaded.
2581 Commit referred to by archive: $dsc_hash
2582 Last version pushed with dgit: $lastpush_hash
2585 @mergeinputs = ($lastpush_mergeinput);
2587 # Archive has .dsc which is not a descendant of the last dgit
2588 # push. This can happen if the archive moves .dscs about.
2589 # Just follow its lead.
2590 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2591 progress "archive .dsc names newer git commit";
2592 @mergeinputs = ($dsc_mergeinput);
2594 progress "archive .dsc names other git commit, fixing up";
2595 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2599 @mergeinputs = generate_commits_from_dsc();
2600 # We have just done an import. Now, our import algorithm might
2601 # have been improved. But even so we do not want to generate
2602 # a new different import of the same package. So if the
2603 # version numbers are the same, just use our existing version.
2604 # If the version numbers are different, the archive has changed
2605 # (perhaps, rewound).
2606 if ($lastfetch_mergeinput &&
2607 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2608 (mergeinfo_version $mergeinputs[0]) )) {
2609 @mergeinputs = ($lastfetch_mergeinput);
2611 } elsif ($lastpush_hash) {
2612 # only in git, not in the archive yet
2613 @mergeinputs = ($lastpush_mergeinput);
2614 print STDERR <<END or die $!;
2616 Package not found in the archive, but has allegedly been pushed using dgit.
2620 printdebug "nothing found!\n";
2621 if (defined $skew_warning_vsn) {
2622 print STDERR <<END or die $!;
2624 Warning: relevant archive skew detected.
2625 Archive allegedly contains $skew_warning_vsn
2626 But we were not able to obtain any version from the archive or git.
2630 unshift @end, $del_lrfetchrefs;
2634 if ($lastfetch_hash &&
2636 my $h = $_->{Commit};
2637 $h and is_fast_fwd($lastfetch_hash, $h);
2638 # If true, one of the existing parents of this commit
2639 # is a descendant of the $lastfetch_hash, so we'll
2640 # be ff from that automatically.
2644 push @mergeinputs, $lastfetch_mergeinput;
2647 printdebug "fetch mergeinfos:\n";
2648 foreach my $mi (@mergeinputs) {
2650 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2652 printdebug sprintf " ReverseParents=%d Message=%s",
2653 $mi->{ReverseParents}, $mi->{Message};
2657 my $compat_info= pop @mergeinputs
2658 if $mergeinputs[$#mergeinputs]{Message};
2660 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2663 if (@mergeinputs > 1) {
2665 my $tree_commit = $mergeinputs[0]{Commit};
2667 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2668 $tree =~ m/\n\n/; $tree = $`;
2669 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2672 # We use the changelog author of the package in question the
2673 # author of this pseudo-merge. This is (roughly) correct if
2674 # this commit is simply representing aa non-dgit upload.
2675 # (Roughly because it does not record sponsorship - but we
2676 # don't have sponsorship info because that's in the .changes,
2677 # which isn't in the archivw.)
2679 # But, it might be that we are representing archive history
2680 # updates (including in-archive copies). These are not really
2681 # the responsibility of the person who created the .dsc, but
2682 # there is no-one whose name we should better use. (The
2683 # author of the .dsc-named commit is clearly worse.)
2685 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2686 my $author = clogp_authline $useclogp;
2687 my $cversion = getfield $useclogp, 'Version';
2689 my $mcf = ".git/dgit/mergecommit";
2690 open MC, ">", $mcf or die "$mcf $!";
2691 print MC <<END or die $!;
2695 my @parents = grep { $_->{Commit} } @mergeinputs;
2696 @parents = reverse @parents if $compat_info->{ReverseParents};
2697 print MC <<END or die $! foreach @parents;
2701 print MC <<END or die $!;
2707 if (defined $compat_info->{Message}) {
2708 print MC $compat_info->{Message} or die $!;
2710 print MC <<END or die $!;
2711 Record $package ($cversion) in archive suite $csuite
2715 my $message_add_info = sub {
2717 my $mversion = mergeinfo_version $mi;
2718 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2722 $message_add_info->($mergeinputs[0]);
2723 print MC <<END or die $!;
2724 should be treated as descended from
2726 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2730 $hash = make_commit $mcf;
2732 $hash = $mergeinputs[0]{Commit};
2734 printdebug "fetch hash=$hash\n";
2737 my ($lasth, $what) = @_;
2738 return unless $lasth;
2739 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2742 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2744 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2746 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2747 'DGIT_ARCHIVE', $hash;
2748 cmdoutput @git, qw(log -n2), $hash;
2749 # ... gives git a chance to complain if our commit is malformed
2751 if (defined $skew_warning_vsn) {
2753 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2754 my $gotclogp = commit_getclogp($hash);
2755 my $got_vsn = getfield $gotclogp, 'Version';
2756 printdebug "SKEW CHECK GOT $got_vsn\n";
2757 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2758 print STDERR <<END or die $!;
2760 Warning: archive skew detected. Using the available version:
2761 Archive allegedly contains $skew_warning_vsn
2762 We were able to obtain only $got_vsn
2768 if ($lastfetch_hash ne $hash) {
2769 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2773 dryrun_report @upd_cmd;
2777 lrfetchref_used lrfetchref();
2779 unshift @end, $del_lrfetchrefs;
2783 sub set_local_git_config ($$) {
2785 runcmd @git, qw(config), $k, $v;
2788 sub setup_mergechangelogs (;$) {
2790 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2792 my $driver = 'dpkg-mergechangelogs';
2793 my $cb = "merge.$driver";
2794 my $attrs = '.git/info/attributes';
2795 ensuredir '.git/info';
2797 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2798 if (!open ATTRS, "<", $attrs) {
2799 $!==ENOENT or die "$attrs: $!";
2803 next if m{^debian/changelog\s};
2804 print NATTRS $_, "\n" or die $!;
2806 ATTRS->error and die $!;
2809 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2812 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2813 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2815 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2818 sub setup_useremail (;$) {
2820 return unless $always || access_cfg_bool(1, 'setup-useremail');
2823 my ($k, $envvar) = @_;
2824 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2825 return unless defined $v;
2826 set_local_git_config "user.$k", $v;
2829 $setup->('email', 'DEBEMAIL');
2830 $setup->('name', 'DEBFULLNAME');
2833 sub ensure_setup_existing_tree () {
2834 my $k = "remote.$remotename.skipdefaultupdate";
2835 my $c = git_get_config $k;
2836 return if defined $c;
2837 set_local_git_config $k, 'true';
2840 sub setup_new_tree () {
2841 setup_mergechangelogs();
2847 canonicalise_suite();
2848 badusage "dry run makes no sense with clone" unless act_local();
2849 my $hasgit = check_for_git();
2850 mkdir $dstdir or fail "create \`$dstdir': $!";
2852 runcmd @git, qw(init -q);
2853 my $giturl = access_giturl(1);
2854 if (defined $giturl) {
2855 open H, "> .git/HEAD" or die $!;
2856 print H "ref: ".lref()."\n" or die $!;
2858 runcmd @git, qw(remote add), 'origin', $giturl;
2861 progress "fetching existing git history";
2863 runcmd_ordryrun_local @git, qw(fetch origin);
2865 progress "starting new git history";
2867 fetch_from_archive() or no_such_package;
2868 my $vcsgiturl = $dsc->{'Vcs-Git'};
2869 if (length $vcsgiturl) {
2870 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2871 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2874 runcmd @git, qw(reset --hard), lrref();
2875 runcmd qw(bash -ec), <<'END';
2877 git ls-tree -r --name-only -z HEAD | \
2878 xargs -0r touch -r . --
2880 printdone "ready for work in $dstdir";
2884 if (check_for_git()) {
2887 fetch_from_archive() or no_such_package();
2888 printdone "fetched into ".lrref();
2893 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2895 printdone "fetched to ".lrref()." and merged into HEAD";
2898 sub check_not_dirty () {
2899 foreach my $f (qw(local-options local-patch-header)) {
2900 if (stat_exists "debian/source/$f") {
2901 fail "git tree contains debian/source/$f";
2905 return if $ignoredirty;
2907 my @cmd = (@git, qw(diff --quiet HEAD));
2909 $!=0; $?=-1; system @cmd;
2912 fail "working tree is dirty (does not match HEAD)";
2918 sub commit_admin ($) {
2921 runcmd_ordryrun_local @git, qw(commit -m), $m;
2924 sub commit_quilty_patch () {
2925 my $output = cmdoutput @git, qw(status --porcelain);
2927 foreach my $l (split /\n/, $output) {
2928 next unless $l =~ m/\S/;
2929 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2933 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2935 progress "nothing quilty to commit, ok.";
2938 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2939 runcmd_ordryrun_local @git, qw(add -f), @adds;
2941 Commit Debian 3.0 (quilt) metadata
2943 [dgit ($our_version) quilt-fixup]
2947 sub get_source_format () {
2949 if (open F, "debian/source/options") {
2953 s/\s+$//; # ignore missing final newline
2955 my ($k, $v) = ($`, $'); #');
2956 $v =~ s/^"(.*)"$/$1/;
2962 F->error and die $!;
2965 die $! unless $!==&ENOENT;
2968 if (!open F, "debian/source/format") {
2969 die $! unless $!==&ENOENT;
2973 F->error and die $!;
2975 return ($_, \%options);
2978 sub madformat_wantfixup ($) {
2980 return 0 unless $format eq '3.0 (quilt)';
2981 our $quilt_mode_warned;
2982 if ($quilt_mode eq 'nocheck') {
2983 progress "Not doing any fixup of \`$format' due to".
2984 " ----no-quilt-fixup or --quilt=nocheck"
2985 unless $quilt_mode_warned++;
2988 progress "Format \`$format', need to check/update patch stack"
2989 unless $quilt_mode_warned++;
2993 sub maybe_split_brain_save ($$$) {
2994 my ($headref, $dgitview, $msg) = @_;
2995 # => message fragment "$saved" describing disposition of $dgitview
2996 return "commit id $dgitview" unless defined $split_brain_save;
2997 my @cmd = (shell_cmd "cd ../../../..",
2998 @git, qw(update-ref -m),
2999 "dgit --dgit-view-save $msg HEAD=$headref",
3000 $split_brain_save, $dgitview);
3002 return "and left in $split_brain_save";
3005 # An "infopair" is a tuple [ $thing, $what ]
3006 # (often $thing is a commit hash; $what is a description)
3008 sub infopair_cond_equal ($$) {
3010 $x->[0] eq $y->[0] or fail <<END;
3011 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3015 sub infopair_lrf_tag_lookup ($$) {
3016 my ($tagnames, $what) = @_;
3017 # $tagname may be an array ref
3018 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3019 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3020 foreach my $tagname (@tagnames) {
3021 my $lrefname = lrfetchrefs."/tags/$tagname";
3022 my $tagobj = $lrfetchrefs_f{$lrefname};
3023 next unless defined $tagobj;
3024 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3025 return [ git_rev_parse($tagobj), $what ];
3027 fail @tagnames==1 ? <<END : <<END;
3028 Wanted tag $what (@tagnames) on dgit server, but not found
3030 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3034 sub infopair_cond_ff ($$) {
3035 my ($anc,$desc) = @_;
3036 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3037 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3041 sub pseudomerge_version_check ($$) {
3042 my ($clogp, $archive_hash) = @_;
3044 my $arch_clogp = commit_getclogp $archive_hash;
3045 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3046 'version currently in archive' ];
3047 if (defined $overwrite_version) {
3048 if (length $overwrite_version) {
3049 infopair_cond_equal([ $overwrite_version,
3050 '--overwrite= version' ],
3053 my $v = $i_arch_v->[0];
3054 progress "Checking package changelog for archive version $v ...";
3056 my @xa = ("-f$v", "-t$v");
3057 my $vclogp = parsechangelog @xa;
3058 my $cv = [ (getfield $vclogp, 'Version'),
3059 "Version field from dpkg-parsechangelog @xa" ];
3060 infopair_cond_equal($i_arch_v, $cv);
3063 $@ =~ s/^dgit: //gm;
3065 "Perhaps debian/changelog does not mention $v ?";
3070 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3074 sub pseudomerge_make_commit ($$$$ $$) {
3075 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3076 $msg_cmd, $msg_msg) = @_;
3077 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3079 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3080 my $authline = clogp_authline $clogp;
3084 !defined $overwrite_version ? ""
3085 : !length $overwrite_version ? " --overwrite"
3086 : " --overwrite=".$overwrite_version;
3089 my $pmf = ".git/dgit/pseudomerge";
3090 open MC, ">", $pmf or die "$pmf $!";
3091 print MC <<END or die $!;
3094 parent $archive_hash
3104 return make_commit($pmf);
3107 sub splitbrain_pseudomerge ($$$$) {
3108 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3109 # => $merged_dgitview
3110 printdebug "splitbrain_pseudomerge...\n";
3112 # We: debian/PREVIOUS HEAD($maintview)
3113 # expect: o ----------------- o
3116 # a/d/PREVIOUS $dgitview
3119 # we do: `------------------ o
3123 return $dgitview unless defined $archive_hash;
3125 printdebug "splitbrain_pseudomerge...\n";
3127 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3129 if (!defined $overwrite_version) {
3130 progress "Checking that HEAD inciudes all changes in archive...";
3133 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3135 if (defined $overwrite_version) {
3137 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3138 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3139 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3140 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3141 my $i_archive = [ $archive_hash, "current archive contents" ];
3143 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3145 infopair_cond_equal($i_dgit, $i_archive);
3146 infopair_cond_ff($i_dep14, $i_dgit);
3147 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3151 $us: check failed (maybe --overwrite is needed, consult documentation)
3156 my $r = pseudomerge_make_commit
3157 $clogp, $dgitview, $archive_hash, $i_arch_v,
3158 "dgit --quilt=$quilt_mode",
3159 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3160 Declare fast forward from $i_arch_v->[0]
3162 Make fast forward from $i_arch_v->[0]
3165 maybe_split_brain_save $maintview, $r, "pseudomerge";
3167 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3171 sub plain_overwrite_pseudomerge ($$$) {
3172 my ($clogp, $head, $archive_hash) = @_;
3174 printdebug "plain_overwrite_pseudomerge...";
3176 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3178 return $head if is_fast_fwd $archive_hash, $head;
3180 my $m = "Declare fast forward from $i_arch_v->[0]";
3182 my $r = pseudomerge_make_commit
3183 $clogp, $head, $archive_hash, $i_arch_v,
3186 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3188 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3192 sub push_parse_changelog ($) {
3195 my $clogp = Dpkg::Control::Hash->new();
3196 $clogp->load($clogpfn) or die;
3198 $package = getfield $clogp, 'Source';
3199 my $cversion = getfield $clogp, 'Version';
3200 my $tag = debiantag($cversion, access_basedistro);
3201 runcmd @git, qw(check-ref-format), $tag;
3203 my $dscfn = dscfn($cversion);
3205 return ($clogp, $cversion, $dscfn);
3208 sub push_parse_dsc ($$$) {
3209 my ($dscfn,$dscfnwhat, $cversion) = @_;
3210 $dsc = parsecontrol($dscfn,$dscfnwhat);
3211 my $dversion = getfield $dsc, 'Version';
3212 my $dscpackage = getfield $dsc, 'Source';
3213 ($dscpackage eq $package && $dversion eq $cversion) or
3214 fail "$dscfn is for $dscpackage $dversion".
3215 " but debian/changelog is for $package $cversion";
3218 sub push_tagwants ($$$$) {
3219 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3222 TagFn => \&debiantag,
3227 if (defined $maintviewhead) {
3229 TagFn => \&debiantag_maintview,
3230 Objid => $maintviewhead,
3231 TfSuffix => '-maintview',
3235 foreach my $tw (@tagwants) {
3236 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3237 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3239 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3243 sub push_mktags ($$ $$ $) {
3245 $changesfile,$changesfilewhat,
3248 die unless $tagwants->[0]{View} eq 'dgit';
3250 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3251 $dsc->save("$dscfn.tmp") or die $!;
3253 my $changes = parsecontrol($changesfile,$changesfilewhat);
3254 foreach my $field (qw(Source Distribution Version)) {
3255 $changes->{$field} eq $clogp->{$field} or
3256 fail "changes field $field \`$changes->{$field}'".
3257 " does not match changelog \`$clogp->{$field}'";
3260 my $cversion = getfield $clogp, 'Version';
3261 my $clogsuite = getfield $clogp, 'Distribution';
3263 # We make the git tag by hand because (a) that makes it easier
3264 # to control the "tagger" (b) we can do remote signing
3265 my $authline = clogp_authline $clogp;
3266 my $delibs = join(" ", "",@deliberatelies);
3267 my $declaredistro = access_basedistro();
3271 my $tfn = $tw->{Tfn};
3272 my $head = $tw->{Objid};
3273 my $tag = $tw->{Tag};
3275 open TO, '>', $tfn->('.tmp') or die $!;
3276 print TO <<END or die $!;
3283 if ($tw->{View} eq 'dgit') {
3284 print TO <<END or die $!;
3285 $package release $cversion for $clogsuite ($csuite) [dgit]
3286 [dgit distro=$declaredistro$delibs]
3288 foreach my $ref (sort keys %previously) {
3289 print TO <<END or die $!;
3290 [dgit previously:$ref=$previously{$ref}]
3293 } elsif ($tw->{View} eq 'maint') {
3294 print TO <<END or die $!;
3295 $package release $cversion for $clogsuite ($csuite)
3296 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3299 die Dumper($tw)."?";
3304 my $tagobjfn = $tfn->('.tmp');
3306 if (!defined $keyid) {
3307 $keyid = access_cfg('keyid','RETURN-UNDEF');
3309 if (!defined $keyid) {
3310 $keyid = getfield $clogp, 'Maintainer';
3312 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3313 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3314 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3315 push @sign_cmd, $tfn->('.tmp');
3316 runcmd_ordryrun @sign_cmd;
3318 $tagobjfn = $tfn->('.signed.tmp');
3319 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3320 $tfn->('.tmp'), $tfn->('.tmp.asc');
3326 my @r = map { $mktag->($_); } @$tagwants;
3330 sub sign_changes ($) {
3331 my ($changesfile) = @_;
3333 my @debsign_cmd = @debsign;
3334 push @debsign_cmd, "-k$keyid" if defined $keyid;
3335 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3336 push @debsign_cmd, $changesfile;
3337 runcmd_ordryrun @debsign_cmd;
3342 printdebug "actually entering push\n";
3344 supplementary_message(<<'END');
3345 Push failed, while checking state of the archive.
3346 You can retry the push, after fixing the problem, if you like.
3348 if (check_for_git()) {
3351 my $archive_hash = fetch_from_archive();
3352 if (!$archive_hash) {
3354 fail "package appears to be new in this suite;".
3355 " if this is intentional, use --new";
3358 supplementary_message(<<'END');
3359 Push failed, while preparing your push.
3360 You can retry the push, after fixing the problem, if you like.
3363 need_tagformat 'new', "quilt mode $quilt_mode"
3364 if quiltmode_splitbrain;
3368 access_giturl(); # check that success is vaguely likely
3371 my $clogpfn = ".git/dgit/changelog.822.tmp";
3372 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3374 responder_send_file('parsed-changelog', $clogpfn);
3376 my ($clogp, $cversion, $dscfn) =
3377 push_parse_changelog("$clogpfn");
3379 my $dscpath = "$buildproductsdir/$dscfn";
3380 stat_exists $dscpath or
3381 fail "looked for .dsc $dscfn, but $!;".
3382 " maybe you forgot to build";
3384 responder_send_file('dsc', $dscpath);
3386 push_parse_dsc($dscpath, $dscfn, $cversion);
3388 my $format = getfield $dsc, 'Format';
3389 printdebug "format $format\n";
3391 my $actualhead = git_rev_parse('HEAD');
3392 my $dgithead = $actualhead;
3393 my $maintviewhead = undef;
3395 my $upstreamversion = upstreamversion $clogp->{Version};
3397 if (madformat_wantfixup($format)) {
3398 # user might have not used dgit build, so maybe do this now:
3399 if (quiltmode_splitbrain()) {
3401 quilt_make_fake_dsc($upstreamversion);
3403 ($dgithead, $cachekey) =
3404 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3406 "--quilt=$quilt_mode but no cached dgit view:
3407 perhaps tree changed since dgit build[-source] ?";
3409 $dgithead = splitbrain_pseudomerge($clogp,
3410 $actualhead, $dgithead,
3412 $maintviewhead = $actualhead;
3413 changedir '../../../..';
3414 prep_ud(); # so _only_subdir() works, below
3416 commit_quilty_patch();
3420 if (defined $overwrite_version && !defined $maintviewhead) {
3421 $dgithead = plain_overwrite_pseudomerge($clogp,
3429 if ($archive_hash) {
3430 if (is_fast_fwd($archive_hash, $dgithead)) {
3432 } elsif (deliberately_not_fast_forward) {
3435 fail "dgit push: HEAD is not a descendant".
3436 " of the archive's version.\n".
3437 "To overwrite the archive's contents,".
3438 " pass --overwrite[=VERSION].\n".
3439 "To rewind history, if permitted by the archive,".
3440 " use --deliberately-not-fast-forward.";
3445 progress "checking that $dscfn corresponds to HEAD";
3446 runcmd qw(dpkg-source -x --),
3447 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3448 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3449 check_for_vendor_patches() if madformat($dsc->{format});
3450 changedir '../../../..';
3451 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3452 debugcmd "+",@diffcmd;
3454 my $r = system @diffcmd;
3457 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3459 HEAD specifies a different tree to $dscfn:
3461 Perhaps you forgot to build. Or perhaps there is a problem with your
3462 source tree (see dgit(7) for some hints). To see a full diff, run
3469 if (!$changesfile) {
3470 my $pat = changespat $cversion;
3471 my @cs = glob "$buildproductsdir/$pat";
3472 fail "failed to find unique changes file".
3473 " (looked for $pat in $buildproductsdir);".
3474 " perhaps you need to use dgit -C"
3476 ($changesfile) = @cs;
3478 $changesfile = "$buildproductsdir/$changesfile";
3481 # Check that changes and .dsc agree enough
3482 $changesfile =~ m{[^/]*$};
3483 my $changes = parsecontrol($changesfile,$&);
3484 files_compare_inputs($dsc, $changes)
3485 unless forceing [qw(dsc-changes-mismatch)];
3487 # Perhaps adjust .dsc to contain right set of origs
3488 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3490 unless forceing [qw(changes-origs-exactly)];
3492 # Checks complete, we're going to try and go ahead:
3494 responder_send_file('changes',$changesfile);
3495 responder_send_command("param head $dgithead");
3496 responder_send_command("param csuite $csuite");
3497 responder_send_command("param tagformat $tagformat");
3498 if (defined $maintviewhead) {
3499 die unless ($protovsn//4) >= 4;
3500 responder_send_command("param maint-view $maintviewhead");
3503 if (deliberately_not_fast_forward) {
3504 git_for_each_ref(lrfetchrefs, sub {
3505 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3506 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3507 responder_send_command("previously $rrefname=$objid");
3508 $previously{$rrefname} = $objid;
3512 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3516 supplementary_message(<<'END');
3517 Push failed, while signing the tag.
3518 You can retry the push, after fixing the problem, if you like.
3520 # If we manage to sign but fail to record it anywhere, it's fine.
3521 if ($we_are_responder) {
3522 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3523 responder_receive_files('signed-tag', @tagobjfns);
3525 @tagobjfns = push_mktags($clogp,$dscpath,
3526 $changesfile,$changesfile,
3529 supplementary_message(<<'END');
3530 Push failed, *after* signing the tag.
3531 If you want to try again, you should use a new version number.
3534 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3536 foreach my $tw (@tagwants) {
3537 my $tag = $tw->{Tag};
3538 my $tagobjfn = $tw->{TagObjFn};
3540 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3541 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3542 runcmd_ordryrun_local
3543 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3546 supplementary_message(<<'END');
3547 Push failed, while updating the remote git repository - see messages above.
3548 If you want to try again, you should use a new version number.
3550 if (!check_for_git()) {
3551 create_remote_git_repo();
3554 my @pushrefs = $forceflag.$dgithead.":".rrref();
3555 foreach my $tw (@tagwants) {
3556 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3559 runcmd_ordryrun @git,
3560 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3561 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3563 supplementary_message(<<'END');
3564 Push failed, after updating the remote git repository.
3565 If you want to try again, you must use a new version number.
3567 if ($we_are_responder) {
3568 my $dryrunsuffix = act_local() ? "" : ".tmp";
3569 responder_receive_files('signed-dsc-changes',
3570 "$dscpath$dryrunsuffix",
3571 "$changesfile$dryrunsuffix");
3574 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3576 progress "[new .dsc left in $dscpath.tmp]";
3578 sign_changes $changesfile;
3581 supplementary_message(<<END);
3582 Push failed, while uploading package(s) to the archive server.
3583 You can retry the upload of exactly these same files with dput of:
3585 If that .changes file is broken, you will need to use a new version
3586 number for your next attempt at the upload.
3588 my $host = access_cfg('upload-host','RETURN-UNDEF');
3589 my @hostarg = defined($host) ? ($host,) : ();
3590 runcmd_ordryrun @dput, @hostarg, $changesfile;
3591 printdone "pushed and uploaded $cversion";
3593 supplementary_message('');
3594 responder_send_command("complete");
3601 badusage "-p is not allowed with clone; specify as argument instead"
3602 if defined $package;
3605 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3606 ($package,$isuite) = @ARGV;
3607 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3608 ($package,$dstdir) = @ARGV;
3609 } elsif (@ARGV==3) {
3610 ($package,$isuite,$dstdir) = @ARGV;
3612 badusage "incorrect arguments to dgit clone";
3614 $dstdir ||= "$package";
3616 if (stat_exists $dstdir) {
3617 fail "$dstdir already exists";
3621 if ($rmonerror && !$dryrun_level) {
3622 $cwd_remove= getcwd();
3624 return unless defined $cwd_remove;
3625 if (!chdir "$cwd_remove") {
3626 return if $!==&ENOENT;
3627 die "chdir $cwd_remove: $!";
3630 rmtree($dstdir) or die "remove $dstdir: $!\n";
3631 } elsif (grep { $! == $_ }
3632 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3634 print STDERR "check whether to remove $dstdir: $!\n";
3640 $cwd_remove = undef;
3643 sub branchsuite () {
3644 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3645 if ($branch =~ m#$lbranch_re#o) {
3652 sub fetchpullargs () {
3654 if (!defined $package) {
3655 my $sourcep = parsecontrol('debian/control','debian/control');
3656 $package = getfield $sourcep, 'Source';
3659 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3661 my $clogp = parsechangelog();
3662 $isuite = getfield $clogp, 'Distribution';
3664 canonicalise_suite();
3665 progress "fetching from suite $csuite";
3666 } elsif (@ARGV==1) {
3668 canonicalise_suite();
3670 badusage "incorrect arguments to dgit fetch or dgit pull";
3683 if (quiltmode_splitbrain()) {
3684 my ($format, $fopts) = get_source_format();
3685 madformat($format) and fail <<END
3686 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3695 badusage "-p is not allowed with dgit push" if defined $package;
3697 my $clogp = parsechangelog();
3698 $package = getfield $clogp, 'Source';
3701 } elsif (@ARGV==1) {
3702 ($specsuite) = (@ARGV);
3704 badusage "incorrect arguments to dgit push";
3706 $isuite = getfield $clogp, 'Distribution';
3708 local ($package) = $existing_package; # this is a hack
3709 canonicalise_suite();
3711 canonicalise_suite();
3713 if (defined $specsuite &&
3714 $specsuite ne $isuite &&
3715 $specsuite ne $csuite) {
3716 fail "dgit push: changelog specifies $isuite ($csuite)".
3717 " but command line specifies $specsuite";
3722 #---------- remote commands' implementation ----------
3724 sub cmd_remote_push_build_host {
3725 my ($nrargs) = shift @ARGV;
3726 my (@rargs) = @ARGV[0..$nrargs-1];
3727 @ARGV = @ARGV[$nrargs..$#ARGV];
3729 my ($dir,$vsnwant) = @rargs;
3730 # vsnwant is a comma-separated list; we report which we have
3731 # chosen in our ready response (so other end can tell if they
3734 $we_are_responder = 1;
3735 $us .= " (build host)";
3739 open PI, "<&STDIN" or die $!;
3740 open STDIN, "/dev/null" or die $!;
3741 open PO, ">&STDOUT" or die $!;
3743 open STDOUT, ">&STDERR" or die $!;
3747 ($protovsn) = grep {
3748 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3749 } @rpushprotovsn_support;
3751 fail "build host has dgit rpush protocol versions ".
3752 (join ",", @rpushprotovsn_support).
3753 " but invocation host has $vsnwant"
3754 unless defined $protovsn;
3756 responder_send_command("dgit-remote-push-ready $protovsn");
3757 rpush_handle_protovsn_bothends();
3762 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3763 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3764 # a good error message)
3766 sub rpush_handle_protovsn_bothends () {
3767 if ($protovsn < 4) {
3768 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3777 my $report = i_child_report();
3778 if (defined $report) {
3779 printdebug "($report)\n";
3780 } elsif ($i_child_pid) {
3781 printdebug "(killing build host child $i_child_pid)\n";
3782 kill 15, $i_child_pid;
3784 if (defined $i_tmp && !defined $initiator_tempdir) {
3786 eval { rmtree $i_tmp; };
3790 END { i_cleanup(); }
3793 my ($base,$selector,@args) = @_;
3794 $selector =~ s/\-/_/g;
3795 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3802 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3810 push @rargs, join ",", @rpushprotovsn_support;
3813 push @rdgit, @ropts;
3814 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3816 my @cmd = (@ssh, $host, shellquote @rdgit);
3819 if (defined $initiator_tempdir) {
3820 rmtree $initiator_tempdir;
3821 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3822 $i_tmp = $initiator_tempdir;
3826 $i_child_pid = open2(\*RO, \*RI, @cmd);
3828 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3829 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3830 $supplementary_message = '' unless $protovsn >= 3;
3832 fail "rpush negotiated protocol version $protovsn".
3833 " which does not support quilt mode $quilt_mode"
3834 if quiltmode_splitbrain;
3836 rpush_handle_protovsn_bothends();
3838 my ($icmd,$iargs) = initiator_expect {
3839 m/^(\S+)(?: (.*))?$/;
3842 i_method "i_resp", $icmd, $iargs;
3846 sub i_resp_progress ($) {
3848 my $msg = protocol_read_bytes \*RO, $rhs;
3852 sub i_resp_supplementary_message ($) {
3854 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3857 sub i_resp_complete {
3858 my $pid = $i_child_pid;
3859 $i_child_pid = undef; # prevents killing some other process with same pid
3860 printdebug "waiting for build host child $pid...\n";
3861 my $got = waitpid $pid, 0;
3862 die $! unless $got == $pid;
3863 die "build host child failed $?" if $?;
3866 printdebug "all done\n";
3870 sub i_resp_file ($) {
3872 my $localname = i_method "i_localname", $keyword;
3873 my $localpath = "$i_tmp/$localname";
3874 stat_exists $localpath and
3875 badproto \*RO, "file $keyword ($localpath) twice";
3876 protocol_receive_file \*RO, $localpath;
3877 i_method "i_file", $keyword;
3882 sub i_resp_param ($) {
3883 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3887 sub i_resp_previously ($) {
3888 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3889 or badproto \*RO, "bad previously spec";
3890 my $r = system qw(git check-ref-format), $1;
3891 die "bad previously ref spec ($r)" if $r;
3892 $previously{$1} = $2;
3897 sub i_resp_want ($) {
3899 die "$keyword ?" if $i_wanted{$keyword}++;
3900 my @localpaths = i_method "i_want", $keyword;
3901 printdebug "[[ $keyword @localpaths\n";
3902 foreach my $localpath (@localpaths) {
3903 protocol_send_file \*RI, $localpath;
3905 print RI "files-end\n" or die $!;
3908 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3910 sub i_localname_parsed_changelog {
3911 return "remote-changelog.822";
3913 sub i_file_parsed_changelog {
3914 ($i_clogp, $i_version, $i_dscfn) =
3915 push_parse_changelog "$i_tmp/remote-changelog.822";
3916 die if $i_dscfn =~ m#/|^\W#;
3919 sub i_localname_dsc {
3920 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3925 sub i_localname_changes {
3926 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3927 $i_changesfn = $i_dscfn;
3928 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3929 return $i_changesfn;
3931 sub i_file_changes { }
3933 sub i_want_signed_tag {
3934 printdebug Dumper(\%i_param, $i_dscfn);
3935 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3936 && defined $i_param{'csuite'}
3937 or badproto \*RO, "premature desire for signed-tag";
3938 my $head = $i_param{'head'};
3939 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3941 my $maintview = $i_param{'maint-view'};
3942 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3945 if ($protovsn >= 4) {
3946 my $p = $i_param{'tagformat'} // '<undef>';
3948 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3951 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3953 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3955 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3958 push_mktags $i_clogp, $i_dscfn,
3959 $i_changesfn, 'remote changes',
3963 sub i_want_signed_dsc_changes {
3964 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3965 sign_changes $i_changesfn;
3966 return ($i_dscfn, $i_changesfn);
3969 #---------- building etc. ----------
3975 #----- `3.0 (quilt)' handling -----
3977 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3979 sub quiltify_dpkg_commit ($$$;$) {
3980 my ($patchname,$author,$msg, $xinfo) = @_;
3984 my $descfn = ".git/dgit/quilt-description.tmp";
3985 open O, '>', $descfn or die "$descfn: $!";
3986 $msg =~ s/\n+/\n\n/;
3987 print O <<END or die $!;
3989 ${xinfo}Subject: $msg
3996 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3997 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3998 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3999 runcmd @dpkgsource, qw(--commit .), $patchname;
4003 sub quiltify_trees_differ ($$;$$$) {
4004 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4005 # returns true iff the two tree objects differ other than in debian/
4006 # with $finegrained,
4007 # returns bitmask 01 - differ in upstream files except .gitignore
4008 # 02 - differ in .gitignore
4009 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4010 # is set for each modified .gitignore filename $fn
4011 # if $unrepres is defined, array ref to which is appeneded
4012 # a list of unrepresentable changes (removals of upstream files
4015 my @cmd = (@git, qw(diff-tree -z));
4016 push @cmd, qw(--name-only) unless $unrepres;
4017 push @cmd, qw(-r) if $finegrained || $unrepres;
4019 my $diffs= cmdoutput @cmd;
4022 foreach my $f (split /\0/, $diffs) {
4023 if ($unrepres && !@lmodes) {
4024 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4027 my ($oldmode,$newmode) = @lmodes;
4030 next if $f =~ m#^debian(?:/.*)?$#s;
4034 die "deleted\n" unless $newmode =~ m/[^0]/;
4035 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4036 if ($oldmode =~ m/[^0]/) {
4037 die "mode changed\n" if $oldmode ne $newmode;
4039 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4043 local $/="\n"; chomp $@;
4044 push @$unrepres, [ $f, $@ ];
4048 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4049 $r |= $isignore ? 02 : 01;
4050 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4052 printdebug "quiltify_trees_differ $x $y => $r\n";
4056 sub quiltify_tree_sentinelfiles ($) {
4057 # lists the `sentinel' files present in the tree
4059 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4060 qw(-- debian/rules debian/control);
4065 sub quiltify_splitbrain_needed () {
4066 if (!$split_brain) {
4067 progress "dgit view: changes are required...";
4068 runcmd @git, qw(checkout -q -b dgit-view);
4073 sub quiltify_splitbrain ($$$$$$) {
4074 my ($clogp, $unapplied, $headref, $diffbits,
4075 $editedignores, $cachekey) = @_;
4076 if ($quilt_mode !~ m/gbp|dpm/) {
4077 # treat .gitignore just like any other upstream file
4078 $diffbits = { %$diffbits };
4079 $_ = !!$_ foreach values %$diffbits;
4081 # We would like any commits we generate to be reproducible
4082 my @authline = clogp_authline($clogp);
4083 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4084 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4085 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4086 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4087 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4088 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4090 if ($quilt_mode =~ m/gbp|unapplied/ &&
4091 ($diffbits->{O2H} & 01)) {
4093 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4094 " but git tree differs from orig in upstream files.";
4095 if (!stat_exists "debian/patches") {
4097 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4101 if ($quilt_mode =~ m/dpm/ &&
4102 ($diffbits->{H2A} & 01)) {
4104 --quilt=$quilt_mode specified, implying patches-applied git tree
4105 but git tree differs from result of applying debian/patches to upstream
4108 if ($quilt_mode =~ m/gbp|unapplied/ &&
4109 ($diffbits->{O2A} & 01)) { # some patches
4110 quiltify_splitbrain_needed();
4111 progress "dgit view: creating patches-applied version using gbp pq";
4112 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4113 # gbp pq import creates a fresh branch; push back to dgit-view
4114 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4115 runcmd @git, qw(checkout -q dgit-view);
4117 if ($quilt_mode =~ m/gbp|dpm/ &&
4118 ($diffbits->{O2A} & 02)) {
4120 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4121 tool which does not create patches for changes to upstream
4122 .gitignores: but, such patches exist in debian/patches.
4125 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4126 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4127 quiltify_splitbrain_needed();
4128 progress "dgit view: creating patch to represent .gitignore changes";
4129 ensuredir "debian/patches";
4130 my $gipatch = "debian/patches/auto-gitignore";
4131 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4132 stat GIPATCH or die "$gipatch: $!";
4133 fail "$gipatch already exists; but want to create it".
4134 " to record .gitignore changes" if (stat _)[7];
4135 print GIPATCH <<END or die "$gipatch: $!";
4136 Subject: Update .gitignore from Debian packaging branch
4138 The Debian packaging git branch contains these updates to the upstream
4139 .gitignore file(s). This patch is autogenerated, to provide these
4140 updates to users of the official Debian archive view of the package.
4142 [dgit ($our_version) update-gitignore]
4145 close GIPATCH or die "$gipatch: $!";
4146 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4147 $unapplied, $headref, "--", sort keys %$editedignores;
4148 open SERIES, "+>>", "debian/patches/series" or die $!;
4149 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4151 defined read SERIES, $newline, 1 or die $!;
4152 print SERIES "\n" or die $! unless $newline eq "\n";
4153 print SERIES "auto-gitignore\n" or die $!;
4154 close SERIES or die $!;
4155 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4157 Commit patch to update .gitignore
4159 [dgit ($our_version) update-gitignore-quilt-fixup]
4163 my $dgitview = git_rev_parse 'HEAD';
4165 changedir '../../../..';
4166 # When we no longer need to support squeeze, use --create-reflog
4168 ensuredir ".git/logs/refs/dgit-intern";
4169 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4172 my $oldcache = git_get_ref "refs/$splitbraincache";
4173 if ($oldcache eq $dgitview) {
4174 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4175 # git update-ref doesn't always update, in this case. *sigh*
4176 my $dummy = make_commit_text <<END;
4179 author Dgit <dgit\@example.com> 1000000000 +0000
4180 committer Dgit <dgit\@example.com> 1000000000 +0000
4182 Dummy commit - do not use
4184 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4185 "refs/$splitbraincache", $dummy;
4187 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4190 changedir '.git/dgit/unpack/work';
4192 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4193 progress "dgit view: created ($saved)";
4196 sub quiltify ($$$$) {
4197 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4199 # Quilt patchification algorithm
4201 # We search backwards through the history of the main tree's HEAD
4202 # (T) looking for a start commit S whose tree object is identical
4203 # to to the patch tip tree (ie the tree corresponding to the
4204 # current dpkg-committed patch series). For these purposes
4205 # `identical' disregards anything in debian/ - this wrinkle is
4206 # necessary because dpkg-source treates debian/ specially.
4208 # We can only traverse edges where at most one of the ancestors'
4209 # trees differs (in changes outside in debian/). And we cannot
4210 # handle edges which change .pc/ or debian/patches. To avoid
4211 # going down a rathole we avoid traversing edges which introduce
4212 # debian/rules or debian/control. And we set a limit on the
4213 # number of edges we are willing to look at.
4215 # If we succeed, we walk forwards again. For each traversed edge
4216 # PC (with P parent, C child) (starting with P=S and ending with
4217 # C=T) to we do this:
4219 # - dpkg-source --commit with a patch name and message derived from C
4220 # After traversing PT, we git commit the changes which
4221 # should be contained within debian/patches.
4223 # The search for the path S..T is breadth-first. We maintain a
4224 # todo list containing search nodes. A search node identifies a
4225 # commit, and looks something like this:
4227 # Commit => $git_commit_id,
4228 # Child => $c, # or undef if P=T
4229 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4230 # Nontrivial => true iff $p..$c has relevant changes
4237 my %considered; # saves being exponential on some weird graphs
4239 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4242 my ($search,$whynot) = @_;
4243 printdebug " search NOT $search->{Commit} $whynot\n";
4244 $search->{Whynot} = $whynot;
4245 push @nots, $search;
4246 no warnings qw(exiting);
4255 my $c = shift @todo;
4256 next if $considered{$c->{Commit}}++;
4258 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4260 printdebug "quiltify investigate $c->{Commit}\n";
4263 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4264 printdebug " search finished hooray!\n";
4269 if ($quilt_mode eq 'nofix') {
4270 fail "quilt fixup required but quilt mode is \`nofix'\n".
4271 "HEAD commit $c->{Commit} differs from tree implied by ".
4272 " debian/patches (tree object $oldtiptree)";
4274 if ($quilt_mode eq 'smash') {
4275 printdebug " search quitting smash\n";
4279 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4280 $not->($c, "has $c_sentinels not $t_sentinels")
4281 if $c_sentinels ne $t_sentinels;
4283 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4284 $commitdata =~ m/\n\n/;
4286 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4287 @parents = map { { Commit => $_, Child => $c } } @parents;
4289 $not->($c, "root commit") if !@parents;
4291 foreach my $p (@parents) {
4292 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4294 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4295 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4297 foreach my $p (@parents) {
4298 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4300 my @cmd= (@git, qw(diff-tree -r --name-only),
4301 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4302 my $patchstackchange = cmdoutput @cmd;
4303 if (length $patchstackchange) {
4304 $patchstackchange =~ s/\n/,/g;
4305 $not->($p, "changed $patchstackchange");
4308 printdebug " search queue P=$p->{Commit} ",
4309 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4315 printdebug "quiltify want to smash\n";
4318 my $x = $_[0]{Commit};
4319 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4322 my $reportnot = sub {
4324 my $s = $abbrev->($notp);
4325 my $c = $notp->{Child};
4326 $s .= "..".$abbrev->($c) if $c;
4327 $s .= ": ".$notp->{Whynot};
4330 if ($quilt_mode eq 'linear') {
4331 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4332 foreach my $notp (@nots) {
4333 print STDERR "$us: ", $reportnot->($notp), "\n";
4335 print STDERR "$us: $_\n" foreach @$failsuggestion;
4336 fail "quilt fixup naive history linearisation failed.\n".
4337 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4338 } elsif ($quilt_mode eq 'smash') {
4339 } elsif ($quilt_mode eq 'auto') {
4340 progress "quilt fixup cannot be linear, smashing...";
4342 die "$quilt_mode ?";
4345 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4346 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4348 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4350 quiltify_dpkg_commit "auto-$version-$target-$time",
4351 (getfield $clogp, 'Maintainer'),
4352 "Automatically generated patch ($clogp->{Version})\n".
4353 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4357 progress "quiltify linearisation planning successful, executing...";
4359 for (my $p = $sref_S;
4360 my $c = $p->{Child};
4362 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4363 next unless $p->{Nontrivial};
4365 my $cc = $c->{Commit};
4367 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4368 $commitdata =~ m/\n\n/ or die "$c ?";
4371 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4374 my $commitdate = cmdoutput
4375 @git, qw(log -n1 --pretty=format:%aD), $cc;
4377 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4379 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4386 my $gbp_check_suitable = sub {
4391 die "contains unexpected slashes\n" if m{//} || m{/$};
4392 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4393 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4394 die "too long" if length > 200;
4396 return $_ unless $@;
4397 print STDERR "quiltifying commit $cc:".
4398 " ignoring/dropping Gbp-Pq $what: $@";
4402 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4404 (\S+) \s* \n //ixm) {
4405 $patchname = $gbp_check_suitable->($1, 'Name');
4407 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4409 (\S+) \s* \n //ixm) {
4410 $patchdir = $gbp_check_suitable->($1, 'Topic');
4415 if (!defined $patchname) {
4416 $patchname = $title;
4417 $patchname =~ s/[.:]$//;
4420 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4421 my $translitname = $converter->convert($patchname);
4422 die unless defined $translitname;
4423 $patchname = $translitname;
4426 "dgit: patch title transliteration error: $@"
4428 $patchname =~ y/ A-Z/-a-z/;
4429 $patchname =~ y/-a-z0-9_.+=~//cd;
4430 $patchname =~ s/^\W/x-$&/;
4431 $patchname = substr($patchname,0,40);
4433 if (!defined $patchdir) {
4436 if (length $patchdir) {
4437 $patchname = "$patchdir/$patchname";
4439 if ($patchname =~ m{^(.*)/}) {
4440 mkpath "debian/patches/$1";
4445 stat "debian/patches/$patchname$index";
4447 $!==ENOENT or die "$patchname$index $!";
4449 runcmd @git, qw(checkout -q), $cc;
4451 # We use the tip's changelog so that dpkg-source doesn't
4452 # produce complaining messages from dpkg-parsechangelog. None
4453 # of the information dpkg-source gets from the changelog is
4454 # actually relevant - it gets put into the original message
4455 # which dpkg-source provides our stunt editor, and then
4457 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4459 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4460 "Date: $commitdate\n".
4461 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4463 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4466 runcmd @git, qw(checkout -q master);
4469 sub build_maybe_quilt_fixup () {
4470 my ($format,$fopts) = get_source_format;
4471 return unless madformat_wantfixup $format;
4474 check_for_vendor_patches();
4476 if (quiltmode_splitbrain) {
4477 foreach my $needtf (qw(new maint)) {
4478 next if grep { $_ eq $needtf } access_cfg_tagformats;
4480 quilt mode $quilt_mode requires split view so server needs to support
4481 both "new" and "maint" tag formats, but config says it doesn't.
4486 my $clogp = parsechangelog();
4487 my $headref = git_rev_parse('HEAD');
4492 my $upstreamversion = upstreamversion $version;
4494 if ($fopts->{'single-debian-patch'}) {
4495 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4497 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4500 die 'bug' if $split_brain && !$need_split_build_invocation;
4502 changedir '../../../..';
4503 runcmd_ordryrun_local
4504 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4507 sub quilt_fixup_mkwork ($) {
4510 mkdir "work" or die $!;
4512 mktree_in_ud_here();
4513 runcmd @git, qw(reset -q --hard), $headref;
4516 sub quilt_fixup_linkorigs ($$) {
4517 my ($upstreamversion, $fn) = @_;
4518 # calls $fn->($leafname);
4520 foreach my $f (<../../../../*>) { #/){
4521 my $b=$f; $b =~ s{.*/}{};
4523 local ($debuglevel) = $debuglevel-1;
4524 printdebug "QF linkorigs $b, $f ?\n";
4526 next unless is_orig_file_of_vsn $b, $upstreamversion;
4527 printdebug "QF linkorigs $b, $f Y\n";
4528 link_ltarget $f, $b or die "$b $!";
4533 sub quilt_fixup_delete_pc () {
4534 runcmd @git, qw(rm -rqf .pc);
4536 Commit removal of .pc (quilt series tracking data)
4538 [dgit ($our_version) upgrade quilt-remove-pc]
4542 sub quilt_fixup_singlepatch ($$$) {
4543 my ($clogp, $headref, $upstreamversion) = @_;
4545 progress "starting quiltify (single-debian-patch)";
4547 # dpkg-source --commit generates new patches even if
4548 # single-debian-patch is in debian/source/options. In order to
4549 # get it to generate debian/patches/debian-changes, it is
4550 # necessary to build the source package.
4552 quilt_fixup_linkorigs($upstreamversion, sub { });
4553 quilt_fixup_mkwork($headref);
4555 rmtree("debian/patches");
4557 runcmd @dpkgsource, qw(-b .);
4559 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4560 rename srcfn("$upstreamversion", "/debian/patches"),
4561 "work/debian/patches";
4564 commit_quilty_patch();
4567 sub quilt_make_fake_dsc ($) {
4568 my ($upstreamversion) = @_;
4570 my $fakeversion="$upstreamversion-~~DGITFAKE";
4572 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4573 print $fakedsc <<END or die $!;
4576 Version: $fakeversion
4580 my $dscaddfile=sub {
4583 my $md = new Digest::MD5;
4585 my $fh = new IO::File $b, '<' or die "$b $!";
4590 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4593 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4595 my @files=qw(debian/source/format debian/rules
4596 debian/control debian/changelog);
4597 foreach my $maybe (qw(debian/patches debian/source/options
4598 debian/tests/control)) {
4599 next unless stat_exists "../../../$maybe";
4600 push @files, $maybe;
4603 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4604 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4606 $dscaddfile->($debtar);
4607 close $fakedsc or die $!;
4610 sub quilt_check_splitbrain_cache ($$) {
4611 my ($headref, $upstreamversion) = @_;
4612 # Called only if we are in (potentially) split brain mode.
4614 # Computes the cache key and looks in the cache.
4615 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4617 my $splitbrain_cachekey;
4620 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4621 # we look in the reflog of dgit-intern/quilt-cache
4622 # we look for an entry whose message is the key for the cache lookup
4623 my @cachekey = (qw(dgit), $our_version);
4624 push @cachekey, $upstreamversion;
4625 push @cachekey, $quilt_mode;
4626 push @cachekey, $headref;
4628 push @cachekey, hashfile('fake.dsc');
4630 my $srcshash = Digest::SHA->new(256);
4631 my %sfs = ( %INC, '$0(dgit)' => $0 );
4632 foreach my $sfk (sort keys %sfs) {
4633 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4634 $srcshash->add($sfk," ");
4635 $srcshash->add(hashfile($sfs{$sfk}));
4636 $srcshash->add("\n");
4638 push @cachekey, $srcshash->hexdigest();
4639 $splitbrain_cachekey = "@cachekey";
4641 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4643 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4644 debugcmd "|(probably)",@cmd;
4645 my $child = open GC, "-|"; defined $child or die $!;
4647 chdir '../../..' or die $!;
4648 if (!stat ".git/logs/refs/$splitbraincache") {
4649 $! == ENOENT or die $!;
4650 printdebug ">(no reflog)\n";
4657 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4658 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4661 quilt_fixup_mkwork($headref);
4662 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4663 if ($cachehit ne $headref) {
4664 progress "dgit view: found cached ($saved)";
4665 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4667 return ($cachehit, $splitbrain_cachekey);
4669 progress "dgit view: found cached, no changes required";
4670 return ($headref, $splitbrain_cachekey);
4672 die $! if GC->error;
4673 failedcmd unless close GC;
4675 printdebug "splitbrain cache miss\n";
4676 return (undef, $splitbrain_cachekey);
4679 sub quilt_fixup_multipatch ($$$) {
4680 my ($clogp, $headref, $upstreamversion) = @_;
4682 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4685 # - honour any existing .pc in case it has any strangeness
4686 # - determine the git commit corresponding to the tip of
4687 # the patch stack (if there is one)
4688 # - if there is such a git commit, convert each subsequent
4689 # git commit into a quilt patch with dpkg-source --commit
4690 # - otherwise convert all the differences in the tree into
4691 # a single git commit
4695 # Our git tree doesn't necessarily contain .pc. (Some versions of
4696 # dgit would include the .pc in the git tree.) If there isn't
4697 # one, we need to generate one by unpacking the patches that we
4700 # We first look for a .pc in the git tree. If there is one, we
4701 # will use it. (This is not the normal case.)
4703 # Otherwise need to regenerate .pc so that dpkg-source --commit
4704 # can work. We do this as follows:
4705 # 1. Collect all relevant .orig from parent directory
4706 # 2. Generate a debian.tar.gz out of
4707 # debian/{patches,rules,source/format,source/options}
4708 # 3. Generate a fake .dsc containing just these fields:
4709 # Format Source Version Files
4710 # 4. Extract the fake .dsc
4711 # Now the fake .dsc has a .pc directory.
4712 # (In fact we do this in every case, because in future we will
4713 # want to search for a good base commit for generating patches.)
4715 # Then we can actually do the dpkg-source --commit
4716 # 1. Make a new working tree with the same object
4717 # store as our main tree and check out the main
4719 # 2. Copy .pc from the fake's extraction, if necessary
4720 # 3. Run dpkg-source --commit
4721 # 4. If the result has changes to debian/, then
4722 # - git add them them
4723 # - git add .pc if we had a .pc in-tree
4725 # 5. If we had a .pc in-tree, delete it, and git commit
4726 # 6. Back in the main tree, fast forward to the new HEAD
4728 # Another situation we may have to cope with is gbp-style
4729 # patches-unapplied trees.
4731 # We would want to detect these, so we know to escape into
4732 # quilt_fixup_gbp. However, this is in general not possible.
4733 # Consider a package with a one patch which the dgit user reverts
4734 # (with git revert or the moral equivalent).
4736 # That is indistinguishable in contents from a patches-unapplied
4737 # tree. And looking at the history to distinguish them is not
4738 # useful because the user might have made a confusing-looking git
4739 # history structure (which ought to produce an error if dgit can't
4740 # cope, not a silent reintroduction of an unwanted patch).
4742 # So gbp users will have to pass an option. But we can usually
4743 # detect their failure to do so: if the tree is not a clean
4744 # patches-applied tree, quilt linearisation fails, but the tree
4745 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4746 # they want --quilt=unapplied.
4748 # To help detect this, when we are extracting the fake dsc, we
4749 # first extract it with --skip-patches, and then apply the patches
4750 # afterwards with dpkg-source --before-build. That lets us save a
4751 # tree object corresponding to .origs.
4753 my $splitbrain_cachekey;
4755 quilt_make_fake_dsc($upstreamversion);
4757 if (quiltmode_splitbrain()) {
4759 ($cachehit, $splitbrain_cachekey) =
4760 quilt_check_splitbrain_cache($headref, $upstreamversion);
4761 return if $cachehit;
4765 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4767 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4768 rename $fakexdir, "fake" or die "$fakexdir $!";
4772 remove_stray_gits();
4773 mktree_in_ud_here();
4777 runcmd @git, qw(add -Af .);
4778 my $unapplied=git_write_tree();
4779 printdebug "fake orig tree object $unapplied\n";
4783 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4785 if (system @bbcmd) {
4786 failedcmd @bbcmd if $? < 0;
4788 failed to apply your git tree's patch stack (from debian/patches/) to
4789 the corresponding upstream tarball(s). Your source tree and .orig
4790 are probably too inconsistent. dgit can only fix up certain kinds of
4791 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4797 quilt_fixup_mkwork($headref);
4800 if (stat_exists ".pc") {
4802 progress "Tree already contains .pc - will use it then delete it.";
4805 rename '../fake/.pc','.pc' or die $!;
4808 changedir '../fake';
4810 runcmd @git, qw(add -Af .);
4811 my $oldtiptree=git_write_tree();
4812 printdebug "fake o+d/p tree object $unapplied\n";
4813 changedir '../work';
4816 # We calculate some guesswork now about what kind of tree this might
4817 # be. This is mostly for error reporting.
4823 # O = orig, without patches applied
4824 # A = "applied", ie orig with H's debian/patches applied
4825 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4826 \%editedignores, \@unrepres),
4827 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4828 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4832 foreach my $b (qw(01 02)) {
4833 foreach my $v (qw(O2H O2A H2A)) {
4834 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4837 printdebug "differences \@dl @dl.\n";
4840 "$us: base trees orig=%.20s o+d/p=%.20s",
4841 $unapplied, $oldtiptree;
4843 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4844 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4845 $dl[0], $dl[1], $dl[3], $dl[4],
4849 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4851 forceable_fail [qw(unrepresentable)], <<END;
4852 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4857 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4858 push @failsuggestion, "This might be a patches-unapplied branch.";
4859 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4860 push @failsuggestion, "This might be a patches-applied branch.";
4862 push @failsuggestion, "Maybe you need to specify one of".
4863 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4865 if (quiltmode_splitbrain()) {
4866 quiltify_splitbrain($clogp, $unapplied, $headref,
4867 $diffbits, \%editedignores,
4868 $splitbrain_cachekey);
4872 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4873 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4875 if (!open P, '>>', ".pc/applied-patches") {
4876 $!==&ENOENT or die $!;
4881 commit_quilty_patch();
4883 if ($mustdeletepc) {
4884 quilt_fixup_delete_pc();
4888 sub quilt_fixup_editor () {
4889 my $descfn = $ENV{$fakeeditorenv};
4890 my $editing = $ARGV[$#ARGV];
4891 open I1, '<', $descfn or die "$descfn: $!";
4892 open I2, '<', $editing or die "$editing: $!";
4893 unlink $editing or die "$editing: $!";
4894 open O, '>', $editing or die "$editing: $!";
4895 while (<I1>) { print O or die $!; } I1->error and die $!;
4898 $copying ||= m/^\-\-\- /;
4899 next unless $copying;
4902 I2->error and die $!;
4907 sub maybe_apply_patches_dirtily () {
4908 return unless $quilt_mode =~ m/gbp|unapplied/;
4909 print STDERR <<END or die $!;
4911 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4912 dgit: Have to apply the patches - making the tree dirty.
4913 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4916 $patches_applied_dirtily = 01;
4917 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4918 runcmd qw(dpkg-source --before-build .);
4921 sub maybe_unapply_patches_again () {
4922 progress "dgit: Unapplying patches again to tidy up the tree."
4923 if $patches_applied_dirtily;
4924 runcmd qw(dpkg-source --after-build .)
4925 if $patches_applied_dirtily & 01;
4927 if $patches_applied_dirtily & 02;
4928 $patches_applied_dirtily = 0;
4931 #----- other building -----
4933 our $clean_using_builder;
4934 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4935 # clean the tree before building (perhaps invoked indirectly by
4936 # whatever we are using to run the build), rather than separately
4937 # and explicitly by us.
4940 return if $clean_using_builder;
4941 if ($cleanmode eq 'dpkg-source') {
4942 maybe_apply_patches_dirtily();
4943 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4944 } elsif ($cleanmode eq 'dpkg-source-d') {
4945 maybe_apply_patches_dirtily();
4946 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4947 } elsif ($cleanmode eq 'git') {
4948 runcmd_ordryrun_local @git, qw(clean -xdf);
4949 } elsif ($cleanmode eq 'git-ff') {
4950 runcmd_ordryrun_local @git, qw(clean -xdff);
4951 } elsif ($cleanmode eq 'check') {
4952 my $leftovers = cmdoutput @git, qw(clean -xdn);
4953 if (length $leftovers) {
4954 print STDERR $leftovers, "\n" or die $!;
4955 fail "tree contains uncommitted files and --clean=check specified";
4957 } elsif ($cleanmode eq 'none') {
4964 badusage "clean takes no additional arguments" if @ARGV;
4967 maybe_unapply_patches_again();
4970 sub build_prep_early () {
4971 our $build_prep_early_done //= 0;
4972 return if $build_prep_early_done++;
4974 badusage "-p is not allowed when building" if defined $package;
4975 my $clogp = parsechangelog();
4976 $isuite = getfield $clogp, 'Distribution';
4977 $package = getfield $clogp, 'Source';
4978 $version = getfield $clogp, 'Version';
4985 build_maybe_quilt_fixup();
4987 my $pat = changespat $version;
4988 foreach my $f (glob "$buildproductsdir/$pat") {
4990 unlink $f or fail "remove old changes file $f: $!";
4992 progress "would remove $f";
4998 sub changesopts_initial () {
4999 my @opts =@changesopts[1..$#changesopts];
5002 sub changesopts_version () {
5003 if (!defined $changes_since_version) {
5004 my @vsns = archive_query('archive_query');
5005 my @quirk = access_quirk();
5006 if ($quirk[0] eq 'backports') {
5007 local $isuite = $quirk[2];
5009 canonicalise_suite();
5010 push @vsns, archive_query('archive_query');
5013 @vsns = map { $_->[0] } @vsns;
5014 @vsns = sort { -version_compare($a, $b) } @vsns;
5015 $changes_since_version = $vsns[0];
5016 progress "changelog will contain changes since $vsns[0]";
5018 $changes_since_version = '_';
5019 progress "package seems new, not specifying -v<version>";
5022 if ($changes_since_version ne '_') {
5023 return ("-v$changes_since_version");
5029 sub changesopts () {
5030 return (changesopts_initial(), changesopts_version());
5033 sub massage_dbp_args ($;$) {
5034 my ($cmd,$xargs) = @_;
5037 # - if we're going to split the source build out so we can
5038 # do strange things to it, massage the arguments to dpkg-buildpackage
5039 # so that the main build doessn't build source (or add an argument
5040 # to stop it building source by default).
5042 # - add -nc to stop dpkg-source cleaning the source tree,
5043 # unless we're not doing a split build and want dpkg-source
5044 # as cleanmode, in which case we can do nothing
5047 # 0 - source will NOT need to be built separately by caller
5048 # +1 - source will need to be built separately by caller
5049 # +2 - source will need to be built separately by caller AND
5050 # dpkg-buildpackage should not in fact be run at all!
5051 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5052 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5053 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5054 $clean_using_builder = 1;
5057 # -nc has the side effect of specifying -b if nothing else specified
5058 # and some combinations of -S, -b, et al, are errors, rather than
5059 # later simply overriding earlie. So we need to:
5060 # - search the command line for these options
5061 # - pick the last one
5062 # - perhaps add our own as a default
5063 # - perhaps adjust it to the corresponding non-source-building version
5065 foreach my $l ($cmd, $xargs) {
5067 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5070 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5072 if ($need_split_build_invocation) {
5073 printdebug "massage split $dmode.\n";
5074 $r = $dmode =~ m/[S]/ ? +2 :
5075 $dmode =~ y/gGF/ABb/ ? +1 :
5076 $dmode =~ m/[ABb]/ ? 0 :
5079 printdebug "massage done $r $dmode.\n";
5081 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5087 my $wasdir = must_getcwd();
5093 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5094 my ($msg_if_onlyone) = @_;
5095 # If there is only one .changes file, fail with $msg_if_onlyone,
5096 # or if that is undef, be a no-op.
5097 # Returns the changes file to report to the user.
5098 my $pat = changespat $version;
5099 my @changesfiles = glob $pat;
5100 @changesfiles = sort {
5101 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5105 if (@changesfiles==1) {
5106 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5107 only one changes file from build (@changesfiles)
5109 $result = $changesfiles[0];
5110 } elsif (@changesfiles==2) {
5111 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5112 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5113 fail "$l found in binaries changes file $binchanges"
5116 runcmd_ordryrun_local @mergechanges, @changesfiles;
5117 my $multichanges = changespat $version,'multi';
5119 stat_exists $multichanges or fail "$multichanges: $!";
5120 foreach my $cf (glob $pat) {
5121 next if $cf eq $multichanges;
5122 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5125 $result = $multichanges;
5127 fail "wrong number of different changes files (@changesfiles)";
5129 printdone "build successful, results in $result\n" or die $!;
5132 sub midbuild_checkchanges () {
5133 my $pat = changespat $version;
5134 return if $rmchanges;
5135 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5136 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5138 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5139 Suggest you delete @unwanted.
5144 sub midbuild_checkchanges_vanilla ($) {
5146 midbuild_checkchanges() if $wantsrc == 1;
5149 sub postbuild_mergechanges_vanilla ($) {
5151 if ($wantsrc == 1) {
5153 postbuild_mergechanges(undef);
5156 printdone "build successful\n";
5161 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5162 my $wantsrc = massage_dbp_args \@dbp;
5165 midbuild_checkchanges_vanilla $wantsrc;
5170 push @dbp, changesopts_version();
5171 maybe_apply_patches_dirtily();
5172 runcmd_ordryrun_local @dbp;
5174 maybe_unapply_patches_again();
5175 postbuild_mergechanges_vanilla $wantsrc;
5179 $quilt_mode //= 'gbp';
5185 # gbp can make .origs out of thin air. In my tests it does this
5186 # even for a 1.0 format package, with no origs present. So I
5187 # guess it keys off just the version number. We don't know
5188 # exactly what .origs ought to exist, but let's assume that we
5189 # should run gbp if: the version has an upstream part and the main
5191 my $upstreamversion = upstreamversion $version;
5192 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5193 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5195 if ($gbp_make_orig) {
5197 $cleanmode = 'none'; # don't do it again
5198 $need_split_build_invocation = 1;
5201 my @dbp = @dpkgbuildpackage;
5203 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5205 if (!length $gbp_build[0]) {
5206 if (length executable_on_path('git-buildpackage')) {
5207 $gbp_build[0] = qw(git-buildpackage);
5209 $gbp_build[0] = 'gbp buildpackage';
5212 my @cmd = opts_opt_multi_cmd @gbp_build;
5214 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5216 if ($gbp_make_orig) {
5217 ensuredir '.git/dgit';
5218 my $ok = '.git/dgit/origs-gen-ok';
5219 unlink $ok or $!==&ENOENT or die $!;
5220 my @origs_cmd = @cmd;
5221 push @origs_cmd, qw(--git-cleaner=true);
5222 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5223 push @origs_cmd, @ARGV;
5225 debugcmd @origs_cmd;
5227 do { local $!; stat_exists $ok; }
5228 or failedcmd @origs_cmd;
5230 dryrun_report @origs_cmd;
5236 midbuild_checkchanges_vanilla $wantsrc;
5238 if (!$clean_using_builder) {
5239 push @cmd, '--git-cleaner=true';
5243 maybe_unapply_patches_again();
5245 push @cmd, changesopts();
5246 runcmd_ordryrun_local @cmd, @ARGV;
5248 postbuild_mergechanges_vanilla $wantsrc;
5250 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5253 my $our_cleanmode = $cleanmode;
5254 if ($need_split_build_invocation) {
5255 # Pretend that clean is being done some other way. This
5256 # forces us not to try to use dpkg-buildpackage to clean and
5257 # build source all in one go; and instead we run dpkg-source
5258 # (and build_prep() will do the clean since $clean_using_builder
5260 $our_cleanmode = 'ELSEWHERE';
5262 if ($our_cleanmode =~ m/^dpkg-source/) {
5263 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5264 $clean_using_builder = 1;
5267 $sourcechanges = changespat $version,'source';
5269 unlink "../$sourcechanges" or $!==ENOENT
5270 or fail "remove $sourcechanges: $!";
5272 $dscfn = dscfn($version);
5273 if ($our_cleanmode eq 'dpkg-source') {
5274 maybe_apply_patches_dirtily();
5275 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5277 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5278 maybe_apply_patches_dirtily();
5279 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5282 my @cmd = (@dpkgsource, qw(-b --));
5285 runcmd_ordryrun_local @cmd, "work";
5286 my @udfiles = <${package}_*>;
5287 changedir "../../..";
5288 foreach my $f (@udfiles) {
5289 printdebug "source copy, found $f\n";
5292 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5293 $f eq srcfn($version, $&));
5294 printdebug "source copy, found $f - renaming\n";
5295 rename "$ud/$f", "../$f" or $!==ENOENT
5296 or fail "put in place new source file ($f): $!";
5299 my $pwd = must_getcwd();
5300 my $leafdir = basename $pwd;
5302 runcmd_ordryrun_local @cmd, $leafdir;
5305 runcmd_ordryrun_local qw(sh -ec),
5306 'exec >$1; shift; exec "$@"','x',
5307 "../$sourcechanges",
5308 @dpkggenchanges, qw(-S), changesopts();
5312 sub cmd_build_source {
5313 badusage "build-source takes no additional arguments" if @ARGV;
5315 maybe_unapply_patches_again();
5316 printdone "source built, results in $dscfn and $sourcechanges";
5321 midbuild_checkchanges();
5324 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5325 stat_exists $sourcechanges
5326 or fail "$sourcechanges (in parent directory): $!";
5328 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5330 maybe_unapply_patches_again();
5332 postbuild_mergechanges(<<END);
5333 perhaps you need to pass -A ? (sbuild's default is to build only
5334 arch-specific binaries; dgit 1.4 used to override that.)
5339 sub cmd_quilt_fixup {
5340 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5341 my $clogp = parsechangelog();
5342 $version = getfield $clogp, 'Version';
5343 $package = getfield $clogp, 'Source';
5346 build_maybe_quilt_fixup();
5349 sub cmd_import_dsc {
5353 last unless $ARGV[0] =~ m/^-/;
5356 if (m/^--require-valid-signature$/) {
5359 badusage "unknown dgit import-dsc sub-option \`$_'";
5363 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5364 my ($dscfn, $dstbranch) = @ARGV;
5366 badusage "dry run makes no sense with import-dsc" unless act_local();
5368 my $force = $dstbranch =~ s/^\+// ? +1 :
5369 $dstbranch =~ s/^\.\.// ? -1 :
5371 my $info = $force ? " $&" : '';
5372 $info = "$dscfn$info";
5374 my $specbranch = $dstbranch;
5375 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5376 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5378 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5379 my $chead = cmdoutput_errok @symcmd;
5380 defined $chead or $?==256 or failedcmd @symcmd;
5382 fail "$dstbranch is checked out - will not update it"
5383 if defined $chead and $chead eq $dstbranch;
5385 my $oldhash = git_get_ref $dstbranch;
5387 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5388 $dscdata = do { local $/ = undef; <D>; };
5389 D->error and fail "read $dscfn: $!";
5392 # we don't normally need this so import it here
5393 use Dpkg::Source::Package;
5394 my $dp = new Dpkg::Source::Package filename => $dscfn,
5395 require_valid_signature => $needsig;
5397 local $SIG{__WARN__} = sub {
5399 return unless $needsig;
5400 fail "import-dsc signature check failed";
5402 if (!$dp->is_signed()) {
5403 warn "$us: warning: importing unsigned .dsc\n";
5405 my $r = $dp->check_signature();
5406 die "->check_signature => $r" if $needsig && $r;
5412 my $dgit_commit = $dsc->{$ourdscfield[0]};
5413 if (defined $dgit_commit &&
5414 !forceing [qw(import-dsc-with-dgit-field)]) {
5415 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5416 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5417 my @cmd = (qw(sh -ec),
5418 "echo $dgit_commit | git cat-file --batch-check");
5419 my $objgot = cmdoutput @cmd;
5420 if ($objgot =~ m#^\w+ missing\b#) {
5422 .dsc contains Dgit field referring to object $dgit_commit
5423 Your git tree does not have that object. Try `git fetch' from a
5424 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5427 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5429 progress "Not fast forward, forced update.";
5431 fail "Not fast forward to $dgit_commit";
5434 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5435 $dstbranch, $dgit_commit);
5437 progress "dgit: import-dsc updated git ref $dstbranch";
5442 Branch $dstbranch already exists
5443 Specify ..$specbranch for a pseudo-merge, binding in existing history
5444 Specify +$specbranch to overwrite, discarding existing history
5446 if $oldhash && !$force;
5448 $package = getfield $dsc, 'Source';
5449 my @dfi = dsc_files_info();
5450 foreach my $fi (@dfi) {
5451 my $f = $fi->{Filename};
5453 next if lstat $here;
5454 fail "stat $here: $!" unless $! == ENOENT;
5456 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5458 } elsif ($dscfn =~ m#^/#) {
5461 fail "cannot import $dscfn which seems to be inside working tree!";
5463 $there =~ s#/+[^/]+$## or
5464 fail "cannot import $dscfn which seems to not have a basename";
5466 symlink $there, $here or fail "symlink $there to $here: $!";
5467 progress "made symlink $here -> $there";
5468 print STDERR Dumper($fi);
5470 my @mergeinputs = generate_commits_from_dsc();
5471 die unless @mergeinputs == 1;
5473 my $newhash = $mergeinputs[0]{Commit};
5477 progress "Import, forced update - synthetic orphan git history.";
5478 } elsif ($force < 0) {
5479 progress "Import, merging.";
5480 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5481 my $version = getfield $dsc, 'Version';
5482 $newhash = make_commit_text <<END;
5487 Merge $package ($version) import into $dstbranch
5490 die; # caught earlier
5494 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5495 $dstbranch, $newhash);
5497 progress "dgit: import-dsc results are in in git ref $dstbranch";
5500 sub cmd_archive_api_query {
5501 badusage "need only 1 subpath argument" unless @ARGV==1;
5502 my ($subpath) = @ARGV;
5503 my @cmd = archive_api_query_cmd($subpath);
5506 exec @cmd or fail "exec curl: $!\n";
5509 sub cmd_clone_dgit_repos_server {
5510 badusage "need destination argument" unless @ARGV==1;
5511 my ($destdir) = @ARGV;
5512 $package = '_dgit-repos-server';
5513 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5515 exec @cmd or fail "exec git clone: $!\n";
5518 sub cmd_setup_mergechangelogs {
5519 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5520 setup_mergechangelogs(1);
5523 sub cmd_setup_useremail {
5524 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5528 sub cmd_setup_new_tree {
5529 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5533 #---------- argument parsing and main program ----------
5536 print "dgit version $our_version\n" or die $!;
5540 our (%valopts_long, %valopts_short);
5543 sub defvalopt ($$$$) {
5544 my ($long,$short,$val_re,$how) = @_;
5545 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5546 $valopts_long{$long} = $oi;
5547 $valopts_short{$short} = $oi;
5548 # $how subref should:
5549 # do whatever assignemnt or thing it likes with $_[0]
5550 # if the option should not be passed on to remote, @rvalopts=()
5551 # or $how can be a scalar ref, meaning simply assign the value
5554 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5555 defvalopt '--distro', '-d', '.+', \$idistro;
5556 defvalopt '', '-k', '.+', \$keyid;
5557 defvalopt '--existing-package','', '.*', \$existing_package;
5558 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5559 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5560 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5562 defvalopt '', '-C', '.+', sub {
5563 ($changesfile) = (@_);
5564 if ($changesfile =~ s#^(.*)/##) {
5565 $buildproductsdir = $1;
5569 defvalopt '--initiator-tempdir','','.*', sub {
5570 ($initiator_tempdir) = (@_);
5571 $initiator_tempdir =~ m#^/# or
5572 badusage "--initiator-tempdir must be used specify an".
5573 " absolute, not relative, directory."
5579 if (defined $ENV{'DGIT_SSH'}) {
5580 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5581 } elsif (defined $ENV{'GIT_SSH'}) {
5582 @ssh = ($ENV{'GIT_SSH'});
5590 if (!defined $val) {
5591 badusage "$what needs a value" unless @ARGV;
5593 push @rvalopts, $val;
5595 badusage "bad value \`$val' for $what" unless
5596 $val =~ m/^$oi->{Re}$(?!\n)/s;
5597 my $how = $oi->{How};
5598 if (ref($how) eq 'SCALAR') {
5603 push @ropts, @rvalopts;
5607 last unless $ARGV[0] =~ m/^-/;
5611 if (m/^--dry-run$/) {
5614 } elsif (m/^--damp-run$/) {
5617 } elsif (m/^--no-sign$/) {
5620 } elsif (m/^--help$/) {
5622 } elsif (m/^--version$/) {
5624 } elsif (m/^--new$/) {
5627 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5628 ($om = $opts_opt_map{$1}) &&
5632 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5633 !$opts_opt_cmdonly{$1} &&
5634 ($om = $opts_opt_map{$1})) {
5637 } elsif (m/^--(gbp|dpm)$/s) {
5638 push @ropts, "--quilt=$1";
5640 } elsif (m/^--ignore-dirty$/s) {
5643 } elsif (m/^--no-quilt-fixup$/s) {
5645 $quilt_mode = 'nocheck';
5646 } elsif (m/^--no-rm-on-error$/s) {
5649 } elsif (m/^--overwrite$/s) {
5651 $overwrite_version = '';
5652 } elsif (m/^--overwrite=(.+)$/s) {
5654 $overwrite_version = $1;
5655 } elsif (m/^--delayed=(\d+)$/s) {
5658 } elsif (m/^--dgit-view-save=(.+)$/s) {
5660 $split_brain_save = $1;
5661 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5662 } elsif (m/^--(no-)?rm-old-changes$/s) {
5665 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5667 push @deliberatelies, $&;
5668 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5672 } elsif (m/^--force-/) {
5674 "$us: warning: ignoring unknown force option $_\n";
5676 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5677 # undocumented, for testing
5679 $tagformat_want = [ $1, 'command line', 1 ];
5680 # 1 menas overrides distro configuration
5681 } elsif (m/^--always-split-source-build$/s) {
5682 # undocumented, for testing
5684 $need_split_build_invocation = 1;
5685 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5686 $val = $2 ? $' : undef; #';
5687 $valopt->($oi->{Long});
5689 badusage "unknown long option \`$_'";
5696 } elsif (s/^-L/-/) {
5699 } elsif (s/^-h/-/) {
5701 } elsif (s/^-D/-/) {
5705 } elsif (s/^-N/-/) {
5710 push @changesopts, $_;
5712 } elsif (s/^-wn$//s) {
5714 $cleanmode = 'none';
5715 } elsif (s/^-wg$//s) {
5718 } elsif (s/^-wgf$//s) {
5720 $cleanmode = 'git-ff';
5721 } elsif (s/^-wd$//s) {
5723 $cleanmode = 'dpkg-source';
5724 } elsif (s/^-wdd$//s) {
5726 $cleanmode = 'dpkg-source-d';
5727 } elsif (s/^-wc$//s) {
5729 $cleanmode = 'check';
5730 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5731 push @git, '-c', $&;
5732 $gitcfgs{cmdline}{$1} = [ $2 ];
5733 } elsif (s/^-c([^=]+)$//s) {
5734 push @git, '-c', $&;
5735 $gitcfgs{cmdline}{$1} = [ 'true' ];
5736 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5738 $val = undef unless length $val;
5739 $valopt->($oi->{Short});
5742 badusage "unknown short option \`$_'";
5749 sub check_env_sanity () {
5750 my $blocked = new POSIX::SigSet;
5751 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5754 foreach my $name (qw(PIPE CHLD)) {
5755 my $signame = "SIG$name";
5756 my $signum = eval "POSIX::$signame" // die;
5757 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5758 die "$signame is set to something other than SIG_DFL\n";
5759 $blocked->ismember($signum) and
5760 die "$signame is blocked\n";
5766 On entry to dgit, $@
5767 This is a bug produced by something in in your execution environment.
5773 sub finalise_opts_opts () {
5774 foreach my $k (keys %opts_opt_map) {
5775 my $om = $opts_opt_map{$k};
5777 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5779 badcfg "cannot set command for $k"
5780 unless length $om->[0];
5784 foreach my $c (access_cfg_cfgs("opts-$k")) {
5786 map { $_ ? @$_ : () }
5787 map { $gitcfgs{$_}{$c} }
5788 reverse @gitcfgsources;
5789 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5790 "\n" if $debuglevel >= 4;
5792 badcfg "cannot configure options for $k"
5793 if $opts_opt_cmdonly{$k};
5794 my $insertpos = $opts_cfg_insertpos{$k};
5795 @$om = ( @$om[0..$insertpos-1],
5797 @$om[$insertpos..$#$om] );
5802 if ($ENV{$fakeeditorenv}) {
5804 quilt_fixup_editor();
5811 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5812 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5813 if $dryrun_level == 1;
5815 print STDERR $helpmsg or die $!;
5818 my $cmd = shift @ARGV;
5821 my $pre_fn = ${*::}{"pre_$cmd"};
5822 $pre_fn->() if $pre_fn;
5824 if (!defined $rmchanges) {
5825 local $access_forpush;
5826 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5829 if (!defined $quilt_mode) {
5830 local $access_forpush;
5831 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5832 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5834 $quilt_mode =~ m/^($quilt_modes_re)$/
5835 or badcfg "unknown quilt-mode \`$quilt_mode'";
5839 $need_split_build_invocation ||= quiltmode_splitbrain();
5841 if (!defined $cleanmode) {
5842 local $access_forpush;
5843 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5844 $cleanmode //= 'dpkg-source';
5846 badcfg "unknown clean-mode \`$cleanmode'" unless
5847 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5850 my $fn = ${*::}{"cmd_$cmd"};
5851 $fn or badusage "unknown operation $cmd";