3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
26 use Debian::Dgit qw(:DEFAULT :playground);
32 use Dpkg::Control::Hash;
34 use File::Temp qw(tempdir);
37 use Dpkg::Compression;
38 use Dpkg::Compression::Process;
43 use List::MoreUtils qw(pairwise);
44 use Text::Glob qw(match_glob);
45 use Fcntl qw(:DEFAULT :flock);
50 our $our_version = 'UNRELEASED'; ###substituted###
51 our $absurdity = undef; ###substituted###
53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
64 our $dryrun_level = 0;
66 our $buildproductsdir;
69 our $includedirty = 0;
73 our $existing_package = 'dpkg';
75 our $changes_since_version;
77 our $overwrite_version; # undef: not specified; '': check changelog
79 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
81 our $split_brain_save;
82 our $we_are_responder;
83 our $we_are_initiator;
84 our $initiator_tempdir;
85 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
103 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
104 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
105 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
107 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
108 our $splitbraincache = 'dgit-intern/quilt-cache';
109 our $rewritemap = 'dgit-rewrite/map';
111 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
113 our (@git) = qw(git);
114 our (@dget) = qw(dget);
115 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
116 our (@dput) = qw(dput);
117 our (@debsign) = qw(debsign);
118 our (@gpg) = qw(gpg);
119 our (@sbuild) = qw(sbuild);
121 our (@dgit) = qw(dgit);
122 our (@git_debrebase) = qw(git-debrebase);
123 our (@aptget) = qw(apt-get);
124 our (@aptcache) = qw(apt-cache);
125 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
126 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
127 our (@dpkggenchanges) = qw(dpkg-genchanges);
128 our (@mergechanges) = qw(mergechanges -f);
129 our (@gbp_build) = ('');
130 our (@gbp_pq) = ('gbp pq');
131 our (@changesopts) = ('');
133 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
136 'debsign' => \@debsign,
138 'sbuild' => \@sbuild,
142 'git-debrebase' => \@git_debrebase,
143 'apt-get' => \@aptget,
144 'apt-cache' => \@aptcache,
145 'dpkg-source' => \@dpkgsource,
146 'dpkg-buildpackage' => \@dpkgbuildpackage,
147 'dpkg-genchanges' => \@dpkggenchanges,
148 'gbp-build' => \@gbp_build,
149 'gbp-pq' => \@gbp_pq,
150 'ch' => \@changesopts,
151 'mergechanges' => \@mergechanges);
153 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
154 our %opts_cfg_insertpos = map {
156 scalar @{ $opts_opt_map{$_} }
157 } keys %opts_opt_map;
159 sub parseopts_late_defaults();
160 sub setup_gitattrs(;$);
161 sub check_gitattrs($$);
168 our $supplementary_message = '';
169 our $need_split_build_invocation = 1;
170 our $split_brain = 0;
174 return unless forkcheck_mainprocess();
175 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
178 our $remotename = 'dgit';
179 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
183 if (!defined $absurdity) {
185 $absurdity =~ s{/[^/]+$}{/absurd} or die;
189 my ($v,$distro) = @_;
190 return $tagformatfn->($v, $distro);
193 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
195 sub lbranch () { return "$branchprefix/$csuite"; }
196 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
197 sub lref () { return "refs/heads/".lbranch(); }
198 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
199 sub rrref () { return server_ref($csuite); }
209 return "${package}_".(stripepoch $vsn).$sfx
214 return srcfn($vsn,".dsc");
217 sub changespat ($;$) {
218 my ($vsn, $arch) = @_;
219 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
222 sub upstreamversion ($) {
234 return unless forkcheck_mainprocess();
235 foreach my $f (@end) {
237 print STDERR "$us: cleanup: $@" if length $@;
241 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
243 sub forceable_fail ($$) {
244 my ($forceoptsl, $msg) = @_;
245 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
246 print STDERR "warning: overriding problem due to --force:\n". $msg;
250 my ($forceoptsl) = @_;
251 my @got = grep { $forceopts{$_} } @$forceoptsl;
252 return 0 unless @got;
254 "warning: skipping checks or functionality due to --force-$got[0]\n";
257 sub no_such_package () {
258 print STDERR "$us: package $package does not exist in suite $isuite\n";
262 sub deliberately ($) {
264 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
267 sub deliberately_not_fast_forward () {
268 foreach (qw(not-fast-forward fresh-repo)) {
269 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
273 sub quiltmode_splitbrain () {
274 $quilt_mode =~ m/gbp|dpm|unapplied/;
277 sub opts_opt_multi_cmd {
280 push @cmd, split /\s+/, shift @_;
287 return opts_opt_multi_cmd [], @gbp_pq;
290 sub dgit_privdir () {
291 our $dgit_privdir_made //= ensure_a_playground 'dgit';
295 my $r = $buildproductsdir;
296 $r = "$maindir/$r" unless $r =~ m{^/};
300 sub branch_gdr_info ($$) {
301 my ($symref, $head) = @_;
302 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
303 gdr_ffq_prev_branchinfo($symref);
304 return () unless $status eq 'branch';
305 $ffq_prev = git_get_ref $ffq_prev;
306 $gdrlast = git_get_ref $gdrlast;
307 $gdrlast &&= is_fast_fwd $gdrlast, $head;
308 return ($ffq_prev, $gdrlast);
311 sub branch_is_gdr ($$) {
312 my ($symref, $head) = @_;
313 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
314 return 0 unless $ffq_prev || $gdrlast;
318 sub branch_is_gdr_unstitched_ff ($$$) {
319 my ($symref, $head, $ancestor) = @_;
320 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
321 return 0 unless $ffq_prev;
322 return 0 unless is_fast_fwd $ancestor, $ffq_prev;
326 #---------- remote protocol support, common ----------
328 # remote push initiator/responder protocol:
329 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
330 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
331 # < dgit-remote-push-ready <actual-proto-vsn>
338 # > supplementary-message NBYTES # $protovsn >= 3
343 # > file parsed-changelog
344 # [indicates that output of dpkg-parsechangelog follows]
345 # > data-block NBYTES
346 # > [NBYTES bytes of data (no newline)]
347 # [maybe some more blocks]
356 # > param head DGIT-VIEW-HEAD
357 # > param csuite SUITE
358 # > param tagformat old|new
359 # > param maint-view MAINT-VIEW-HEAD
361 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
362 # > file buildinfo # for buildinfos to sign
364 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
365 # # goes into tag, for replay prevention
368 # [indicates that signed tag is wanted]
369 # < data-block NBYTES
370 # < [NBYTES bytes of data (no newline)]
371 # [maybe some more blocks]
375 # > want signed-dsc-changes
376 # < data-block NBYTES [transfer of signed dsc]
378 # < data-block NBYTES [transfer of signed changes]
380 # < data-block NBYTES [transfer of each signed buildinfo
381 # [etc] same number and order as "file buildinfo"]
389 sub i_child_report () {
390 # Sees if our child has died, and reap it if so. Returns a string
391 # describing how it died if it failed, or undef otherwise.
392 return undef unless $i_child_pid;
393 my $got = waitpid $i_child_pid, WNOHANG;
394 return undef if $got <= 0;
395 die unless $got == $i_child_pid;
396 $i_child_pid = undef;
397 return undef unless $?;
398 return "build host child ".waitstatusmsg();
403 fail "connection lost: $!" if $fh->error;
404 fail "protocol violation; $m not expected";
407 sub badproto_badread ($$) {
409 fail "connection lost: $!" if $!;
410 my $report = i_child_report();
411 fail $report if defined $report;
412 badproto $fh, "eof (reading $wh)";
415 sub protocol_expect (&$) {
416 my ($match, $fh) = @_;
419 defined && chomp or badproto_badread $fh, "protocol message";
427 badproto $fh, "\`$_'";
430 sub protocol_send_file ($$) {
431 my ($fh, $ourfn) = @_;
432 open PF, "<", $ourfn or die "$ourfn: $!";
435 my $got = read PF, $d, 65536;
436 die "$ourfn: $!" unless defined $got;
438 print $fh "data-block ".length($d)."\n" or die $!;
439 print $fh $d or die $!;
441 PF->error and die "$ourfn $!";
442 print $fh "data-end\n" or die $!;
446 sub protocol_read_bytes ($$) {
447 my ($fh, $nbytes) = @_;
448 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
450 my $got = read $fh, $d, $nbytes;
451 $got==$nbytes or badproto_badread $fh, "data block";
455 sub protocol_receive_file ($$) {
456 my ($fh, $ourfn) = @_;
457 printdebug "() $ourfn\n";
458 open PF, ">", $ourfn or die "$ourfn: $!";
460 my ($y,$l) = protocol_expect {
461 m/^data-block (.*)$/ ? (1,$1) :
462 m/^data-end$/ ? (0,) :
466 my $d = protocol_read_bytes $fh, $l;
467 print PF $d or die $!;
472 #---------- remote protocol support, responder ----------
474 sub responder_send_command ($) {
476 return unless $we_are_responder;
477 # called even without $we_are_responder
478 printdebug ">> $command\n";
479 print PO $command, "\n" or die $!;
482 sub responder_send_file ($$) {
483 my ($keyword, $ourfn) = @_;
484 return unless $we_are_responder;
485 printdebug "]] $keyword $ourfn\n";
486 responder_send_command "file $keyword";
487 protocol_send_file \*PO, $ourfn;
490 sub responder_receive_files ($@) {
491 my ($keyword, @ourfns) = @_;
492 die unless $we_are_responder;
493 printdebug "[[ $keyword @ourfns\n";
494 responder_send_command "want $keyword";
495 foreach my $fn (@ourfns) {
496 protocol_receive_file \*PI, $fn;
499 protocol_expect { m/^files-end$/ } \*PI;
502 #---------- remote protocol support, initiator ----------
504 sub initiator_expect (&) {
506 protocol_expect { &$match } \*RO;
509 #---------- end remote code ----------
512 if ($we_are_responder) {
514 responder_send_command "progress ".length($m) or die $!;
515 print PO $m or die $!;
525 $ua = LWP::UserAgent->new();
529 progress "downloading $what...";
530 my $r = $ua->get(@_) or die $!;
531 return undef if $r->code == 404;
532 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
533 return $r->decoded_content(charset => 'none');
536 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
538 sub act_local () { return $dryrun_level <= 1; }
539 sub act_scary () { return !$dryrun_level; }
542 if (!$dryrun_level) {
543 progress "$us ok: @_";
545 progress "would be ok: @_ (but dry run only)";
550 printcmd(\*STDERR,$debugprefix."#",@_);
553 sub runcmd_ordryrun {
561 sub runcmd_ordryrun_local {
569 our $helpmsg = <<END;
571 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
572 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
573 dgit [dgit-opts] build [dpkg-buildpackage-opts]
574 dgit [dgit-opts] sbuild [sbuild-opts]
575 dgit [dgit-opts] push [dgit-opts] [suite]
576 dgit [dgit-opts] push-source [dgit-opts] [suite]
577 dgit [dgit-opts] rpush build-host:build-dir ...
578 important dgit options:
579 -k<keyid> sign tag and package with <keyid> instead of default
580 --dry-run -n do not change anything, but go through the motions
581 --damp-run -L like --dry-run but make local changes, without signing
582 --new -N allow introducing a new package
583 --debug -D increase debug level
584 -c<name>=<value> set git config option (used directly by dgit too)
587 our $later_warning_msg = <<END;
588 Perhaps the upload is stuck in incoming. Using the version from git.
592 print STDERR "$us: @_\n", $helpmsg or die $!;
597 @ARGV or badusage "too few arguments";
598 return scalar shift @ARGV;
602 not_necessarily_a_tree();
605 print $helpmsg or die $!;
609 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
611 our %defcfg = ('dgit.default.distro' => 'debian',
612 'dgit.default.default-suite' => 'unstable',
613 'dgit.default.old-dsc-distro' => 'debian',
614 'dgit-suite.*-security.distro' => 'debian-security',
615 'dgit.default.username' => '',
616 'dgit.default.archive-query-default-component' => 'main',
617 'dgit.default.ssh' => 'ssh',
618 'dgit.default.archive-query' => 'madison:',
619 'dgit.default.sshpsql-dbname' => 'service=projectb',
620 'dgit.default.aptget-components' => 'main',
621 'dgit.default.dgit-tag-format' => 'new,old,maint',
622 'dgit.default.source-only-uploads' => 'ok',
623 'dgit.dsc-url-proto-ok.http' => 'true',
624 'dgit.dsc-url-proto-ok.https' => 'true',
625 'dgit.dsc-url-proto-ok.git' => 'true',
626 'dgit.vcs-git.suites', => 'sid', # ;-separated
627 'dgit.default.dsc-url-proto-ok' => 'false',
628 # old means "repo server accepts pushes with old dgit tags"
629 # new means "repo server accepts pushes with new dgit tags"
630 # maint means "repo server accepts split brain pushes"
631 # hist means "repo server may have old pushes without new tag"
632 # ("hist" is implied by "old")
633 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
634 'dgit-distro.debian.git-check' => 'url',
635 'dgit-distro.debian.git-check-suffix' => '/info/refs',
636 'dgit-distro.debian.new-private-pushers' => 't',
637 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
638 'dgit-distro.debian/push.git-url' => '',
639 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
640 'dgit-distro.debian/push.git-user-force' => 'dgit',
641 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
642 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
643 'dgit-distro.debian/push.git-create' => 'true',
644 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
645 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
646 # 'dgit-distro.debian.archive-query-tls-key',
647 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
648 # ^ this does not work because curl is broken nowadays
649 # Fixing #790093 properly will involve providing providing the key
650 # in some pacagke and maybe updating these paths.
652 # 'dgit-distro.debian.archive-query-tls-curl-args',
653 # '--ca-path=/etc/ssl/ca-debian',
654 # ^ this is a workaround but works (only) on DSA-administered machines
655 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
656 'dgit-distro.debian.git-url-suffix' => '',
657 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
658 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
659 'dgit-distro.debian-security.archive-query' => 'aptget:',
660 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
661 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
662 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
663 'dgit-distro.debian-security.nominal-distro' => 'debian',
664 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
665 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
666 'dgit-distro.ubuntu.git-check' => 'false',
667 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
668 'dgit-distro.test-dummy.ssh' => "$td/ssh",
669 'dgit-distro.test-dummy.username' => "alice",
670 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
671 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
672 'dgit-distro.test-dummy.git-url' => "$td/git",
673 'dgit-distro.test-dummy.git-host' => "git",
674 'dgit-distro.test-dummy.git-path' => "$td/git",
675 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
676 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
677 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
678 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
682 our @gitcfgsources = qw(cmdline local global system);
683 our $invoked_in_git_tree = 1;
685 sub git_slurp_config () {
686 # This algoritm is a bit subtle, but this is needed so that for
687 # options which we want to be single-valued, we allow the
688 # different config sources to override properly. See #835858.
689 foreach my $src (@gitcfgsources) {
690 next if $src eq 'cmdline';
691 # we do this ourselves since git doesn't handle it
693 $gitcfgs{$src} = git_slurp_config_src $src;
697 sub git_get_config ($) {
699 foreach my $src (@gitcfgsources) {
700 my $l = $gitcfgs{$src}{$c};
701 confess "internal error ($l $c)" if $l && !ref $l;
702 printdebug"C $c ".(defined $l ?
703 join " ", map { messagequote "'$_'" } @$l :
707 @$l==1 or badcfg "multiple values for $c".
708 " (in $src git config)" if @$l > 1;
716 return undef if $c =~ /RETURN-UNDEF/;
717 printdebug "C? $c\n" if $debuglevel >= 5;
718 my $v = git_get_config($c);
719 return $v if defined $v;
720 my $dv = $defcfg{$c};
722 printdebug "CD $c $dv\n" if $debuglevel >= 4;
726 badcfg "need value for one of: @_\n".
727 "$us: distro or suite appears not to be (properly) supported";
730 sub not_necessarily_a_tree () {
731 # needs to be called from pre_*
732 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
733 $invoked_in_git_tree = 0;
736 sub access_basedistro__noalias () {
737 if (defined $idistro) {
740 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
741 return $def if defined $def;
742 foreach my $src (@gitcfgsources, 'internal') {
743 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
745 foreach my $k (keys %$kl) {
746 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
748 next unless match_glob $dpat, $isuite;
752 return cfg("dgit.default.distro");
756 sub access_basedistro () {
757 my $noalias = access_basedistro__noalias();
758 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
759 return $canon // $noalias;
762 sub access_nomdistro () {
763 my $base = access_basedistro();
764 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
765 $r =~ m/^$distro_re$/ or badcfg
766 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
770 sub access_quirk () {
771 # returns (quirk name, distro to use instead or undef, quirk-specific info)
772 my $basedistro = access_basedistro();
773 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
775 if (defined $backports_quirk) {
776 my $re = $backports_quirk;
777 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
779 $re =~ s/\%/([-0-9a-z_]+)/
780 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
781 if ($isuite =~ m/^$re$/) {
782 return ('backports',"$basedistro-backports",$1);
785 return ('none',undef);
790 sub parse_cfg_bool ($$$) {
791 my ($what,$def,$v) = @_;
794 $v =~ m/^[ty1]/ ? 1 :
795 $v =~ m/^[fn0]/ ? 0 :
796 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
799 sub access_forpush_config () {
800 my $d = access_basedistro();
804 parse_cfg_bool('new-private-pushers', 0,
805 cfg("dgit-distro.$d.new-private-pushers",
808 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
811 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
812 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
813 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
814 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
817 sub access_forpush () {
818 $access_forpush //= access_forpush_config();
819 return $access_forpush;
823 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
824 badcfg "pushing but distro is configured readonly"
825 if access_forpush_config() eq '0';
827 $supplementary_message = <<'END' unless $we_are_responder;
828 Push failed, before we got started.
829 You can retry the push, after fixing the problem, if you like.
831 parseopts_late_defaults();
835 parseopts_late_defaults();
838 sub supplementary_message ($) {
840 if (!$we_are_responder) {
841 $supplementary_message = $msg;
843 } elsif ($protovsn >= 3) {
844 responder_send_command "supplementary-message ".length($msg)
846 print PO $msg or die $!;
850 sub access_distros () {
851 # Returns list of distros to try, in order
854 # 0. `instead of' distro name(s) we have been pointed to
855 # 1. the access_quirk distro, if any
856 # 2a. the user's specified distro, or failing that } basedistro
857 # 2b. the distro calculated from the suite }
858 my @l = access_basedistro();
860 my (undef,$quirkdistro) = access_quirk();
861 unshift @l, $quirkdistro;
862 unshift @l, $instead_distro;
863 @l = grep { defined } @l;
865 push @l, access_nomdistro();
867 if (access_forpush()) {
868 @l = map { ("$_/push", $_) } @l;
873 sub access_cfg_cfgs (@) {
876 # The nesting of these loops determines the search order. We put
877 # the key loop on the outside so that we search all the distros
878 # for each key, before going on to the next key. That means that
879 # if access_cfg is called with a more specific, and then a less
880 # specific, key, an earlier distro can override the less specific
881 # without necessarily overriding any more specific keys. (If the
882 # distro wants to override the more specific keys it can simply do
883 # so; whereas if we did the loop the other way around, it would be
884 # impossible to for an earlier distro to override a less specific
885 # key but not the more specific ones without restating the unknown
886 # values of the more specific keys.
889 # We have to deal with RETURN-UNDEF specially, so that we don't
890 # terminate the search prematurely.
892 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
895 foreach my $d (access_distros()) {
896 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
898 push @cfgs, map { "dgit.default.$_" } @realkeys;
905 my (@cfgs) = access_cfg_cfgs(@keys);
906 my $value = cfg(@cfgs);
910 sub access_cfg_bool ($$) {
911 my ($def, @keys) = @_;
912 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
915 sub string_to_ssh ($) {
917 if ($spec =~ m/\s/) {
918 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
924 sub access_cfg_ssh () {
925 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
926 if (!defined $gitssh) {
929 return string_to_ssh $gitssh;
933 sub access_runeinfo ($) {
935 return ": dgit ".access_basedistro()." $info ;";
938 sub access_someuserhost ($) {
940 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
941 defined($user) && length($user) or
942 $user = access_cfg("$some-user",'username');
943 my $host = access_cfg("$some-host");
944 return length($user) ? "$user\@$host" : $host;
947 sub access_gituserhost () {
948 return access_someuserhost('git');
951 sub access_giturl (;$) {
953 my $url = access_cfg('git-url','RETURN-UNDEF');
956 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
957 return undef unless defined $proto;
960 access_gituserhost().
961 access_cfg('git-path');
963 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
966 return "$url/$package$suffix";
969 sub commit_getclogp ($) {
970 # Returns the parsed changelog hashref for a particular commit
972 our %commit_getclogp_memo;
973 my $memo = $commit_getclogp_memo{$objid};
974 return $memo if $memo;
976 my $mclog = dgit_privdir()."clog";
977 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
978 "$objid:debian/changelog";
979 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
982 sub parse_dscdata () {
983 my $dscfh = new IO::File \$dscdata, '<' or die $!;
984 printdebug Dumper($dscdata) if $debuglevel>1;
985 $dsc = parsecontrolfh($dscfh,$dscurl,1);
986 printdebug Dumper($dsc) if $debuglevel>1;
991 sub archive_query ($;@) {
992 my ($method) = shift @_;
993 fail "this operation does not support multiple comma-separated suites"
995 my $query = access_cfg('archive-query','RETURN-UNDEF');
996 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
999 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1002 sub archive_query_prepend_mirror {
1003 my $m = access_cfg('mirror');
1004 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1007 sub pool_dsc_subpath ($$) {
1008 my ($vsn,$component) = @_; # $package is implict arg
1009 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1010 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1013 sub cfg_apply_map ($$$) {
1014 my ($varref, $what, $mapspec) = @_;
1015 return unless $mapspec;
1017 printdebug "config $what EVAL{ $mapspec; }\n";
1019 eval "package Dgit::Config; $mapspec;";
1024 #---------- `ftpmasterapi' archive query method (nascent) ----------
1026 sub archive_api_query_cmd ($) {
1028 my @cmd = (@curl, qw(-sS));
1029 my $url = access_cfg('archive-query-url');
1030 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1032 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1033 foreach my $key (split /\:/, $keys) {
1034 $key =~ s/\%HOST\%/$host/g;
1036 fail "for $url: stat $key: $!" unless $!==ENOENT;
1039 fail "config requested specific TLS key but do not know".
1040 " how to get curl to use exactly that EE key ($key)";
1041 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1042 # # Sadly the above line does not work because of changes
1043 # # to gnutls. The real fix for #790093 may involve
1044 # # new curl options.
1047 # Fixing #790093 properly will involve providing a value
1048 # for this on clients.
1049 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1050 push @cmd, split / /, $kargs if defined $kargs;
1052 push @cmd, $url.$subpath;
1056 sub api_query ($$;$) {
1058 my ($data, $subpath, $ok404) = @_;
1059 badcfg "ftpmasterapi archive query method takes no data part"
1061 my @cmd = archive_api_query_cmd($subpath);
1062 my $url = $cmd[$#cmd];
1063 push @cmd, qw(-w %{http_code});
1064 my $json = cmdoutput @cmd;
1065 unless ($json =~ s/\d+\d+\d$//) {
1066 failedcmd_report_cmd undef, @cmd;
1067 fail "curl failed to print 3-digit HTTP code";
1070 return undef if $code eq '404' && $ok404;
1071 fail "fetch of $url gave HTTP code $code"
1072 unless $url =~ m#^file://# or $code =~ m/^2/;
1073 return decode_json($json);
1076 sub canonicalise_suite_ftpmasterapi {
1077 my ($proto,$data) = @_;
1078 my $suites = api_query($data, 'suites');
1080 foreach my $entry (@$suites) {
1082 my $v = $entry->{$_};
1083 defined $v && $v eq $isuite;
1084 } qw(codename name);
1085 push @matched, $entry;
1087 fail "unknown suite $isuite" unless @matched;
1090 @matched==1 or die "multiple matches for suite $isuite\n";
1091 $cn = "$matched[0]{codename}";
1092 defined $cn or die "suite $isuite info has no codename\n";
1093 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1095 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1100 sub archive_query_ftpmasterapi {
1101 my ($proto,$data) = @_;
1102 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1104 my $digester = Digest::SHA->new(256);
1105 foreach my $entry (@$info) {
1107 my $vsn = "$entry->{version}";
1108 my ($ok,$msg) = version_check $vsn;
1109 die "bad version: $msg\n" unless $ok;
1110 my $component = "$entry->{component}";
1111 $component =~ m/^$component_re$/ or die "bad component";
1112 my $filename = "$entry->{filename}";
1113 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1114 or die "bad filename";
1115 my $sha256sum = "$entry->{sha256sum}";
1116 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1117 push @rows, [ $vsn, "/pool/$component/$filename",
1118 $digester, $sha256sum ];
1120 die "bad ftpmaster api response: $@\n".Dumper($entry)
1123 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1124 return archive_query_prepend_mirror @rows;
1127 sub file_in_archive_ftpmasterapi {
1128 my ($proto,$data,$filename) = @_;
1129 my $pat = $filename;
1132 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1133 my $info = api_query($data, "file_in_archive/$pat", 1);
1136 sub package_not_wholly_new_ftpmasterapi {
1137 my ($proto,$data,$pkg) = @_;
1138 my $info = api_query($data,"madison?package=${pkg}&f=json");
1142 #---------- `aptget' archive query method ----------
1145 our $aptget_releasefile;
1146 our $aptget_configpath;
1148 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1149 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1151 sub aptget_cache_clean {
1152 runcmd_ordryrun_local qw(sh -ec),
1153 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1157 sub aptget_lock_acquire () {
1158 my $lockfile = "$aptget_base/lock";
1159 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1160 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1163 sub aptget_prep ($) {
1165 return if defined $aptget_base;
1167 badcfg "aptget archive query method takes no data part"
1170 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1173 ensuredir "$cache/dgit";
1175 access_cfg('aptget-cachekey','RETURN-UNDEF')
1176 // access_nomdistro();
1178 $aptget_base = "$cache/dgit/aptget";
1179 ensuredir $aptget_base;
1181 my $quoted_base = $aptget_base;
1182 die "$quoted_base contains bad chars, cannot continue"
1183 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1185 ensuredir $aptget_base;
1187 aptget_lock_acquire();
1189 aptget_cache_clean();
1191 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1192 my $sourceslist = "source.list#$cachekey";
1194 my $aptsuites = $isuite;
1195 cfg_apply_map(\$aptsuites, 'suite map',
1196 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1198 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1199 printf SRCS "deb-src %s %s %s\n",
1200 access_cfg('mirror'),
1202 access_cfg('aptget-components')
1205 ensuredir "$aptget_base/cache";
1206 ensuredir "$aptget_base/lists";
1208 open CONF, ">", $aptget_configpath or die $!;
1210 Debug::NoLocking "true";
1211 APT::Get::List-Cleanup "false";
1212 #clear APT::Update::Post-Invoke-Success;
1213 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1214 Dir::State::Lists "$quoted_base/lists";
1215 Dir::Etc::preferences "$quoted_base/preferences";
1216 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1217 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1220 foreach my $key (qw(
1223 Dir::Cache::Archives
1224 Dir::Etc::SourceParts
1225 Dir::Etc::preferencesparts
1227 ensuredir "$aptget_base/$key";
1228 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1231 my $oldatime = (time // die $!) - 1;
1232 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1233 next unless stat_exists $oldlist;
1234 my ($mtime) = (stat _)[9];
1235 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1238 runcmd_ordryrun_local aptget_aptget(), qw(update);
1241 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1242 next unless stat_exists $oldlist;
1243 my ($atime) = (stat _)[8];
1244 next if $atime == $oldatime;
1245 push @releasefiles, $oldlist;
1247 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1248 @releasefiles = @inreleasefiles if @inreleasefiles;
1249 if (!@releasefiles) {
1251 apt seemed to not to update dgit's cached Release files for $isuite.
1253 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1256 die "apt updated too many Release files (@releasefiles), erk"
1257 unless @releasefiles == 1;
1259 ($aptget_releasefile) = @releasefiles;
1262 sub canonicalise_suite_aptget {
1263 my ($proto,$data) = @_;
1266 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1268 foreach my $name (qw(Codename Suite)) {
1269 my $val = $release->{$name};
1271 printdebug "release file $name: $val\n";
1272 $val =~ m/^$suite_re$/o or fail
1273 "Release file ($aptget_releasefile) specifies intolerable $name";
1274 cfg_apply_map(\$val, 'suite rmap',
1275 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1282 sub archive_query_aptget {
1283 my ($proto,$data) = @_;
1286 ensuredir "$aptget_base/source";
1287 foreach my $old (<$aptget_base/source/*.dsc>) {
1288 unlink $old or die "$old: $!";
1291 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1292 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1293 # avoids apt-get source failing with ambiguous error code
1295 runcmd_ordryrun_local
1296 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1297 aptget_aptget(), qw(--download-only --only-source source), $package;
1299 my @dscs = <$aptget_base/source/*.dsc>;
1300 fail "apt-get source did not produce a .dsc" unless @dscs;
1301 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1303 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1306 my $uri = "file://". uri_escape $dscs[0];
1307 $uri =~ s{\%2f}{/}gi;
1308 return [ (getfield $pre_dsc, 'Version'), $uri ];
1311 sub file_in_archive_aptget () { return undef; }
1312 sub package_not_wholly_new_aptget () { return undef; }
1314 #---------- `dummyapicat' archive query method ----------
1316 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1317 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1319 sub dummycatapi_run_in_mirror ($@) {
1320 # runs $fn with FIA open onto rune
1321 my ($rune, $argl, $fn) = @_;
1323 my $mirror = access_cfg('mirror');
1324 $mirror =~ s#^file://#/# or die "$mirror ?";
1325 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1326 qw(x), $mirror, @$argl);
1327 debugcmd "-|", @cmd;
1328 open FIA, "-|", @cmd or die $!;
1330 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1334 sub file_in_archive_dummycatapi ($$$) {
1335 my ($proto,$data,$filename) = @_;
1337 dummycatapi_run_in_mirror '
1338 find -name "$1" -print0 |
1340 ', [$filename], sub {
1343 printdebug "| $_\n";
1344 m/^(\w+) (\S+)$/ or die "$_ ?";
1345 push @out, { sha256sum => $1, filename => $2 };
1351 sub package_not_wholly_new_dummycatapi {
1352 my ($proto,$data,$pkg) = @_;
1353 dummycatapi_run_in_mirror "
1354 find -name ${pkg}_*.dsc
1361 #---------- `madison' archive query method ----------
1363 sub archive_query_madison {
1364 return archive_query_prepend_mirror
1365 map { [ @$_[0..1] ] } madison_get_parse(@_);
1368 sub madison_get_parse {
1369 my ($proto,$data) = @_;
1370 die unless $proto eq 'madison';
1371 if (!length $data) {
1372 $data= access_cfg('madison-distro','RETURN-UNDEF');
1373 $data //= access_basedistro();
1375 $rmad{$proto,$data,$package} ||= cmdoutput
1376 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1377 my $rmad = $rmad{$proto,$data,$package};
1380 foreach my $l (split /\n/, $rmad) {
1381 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1382 \s*( [^ \t|]+ )\s* \|
1383 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1384 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1385 $1 eq $package or die "$rmad $package ?";
1392 $component = access_cfg('archive-query-default-component');
1394 $5 eq 'source' or die "$rmad ?";
1395 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1397 return sort { -version_compare($a->[0],$b->[0]); } @out;
1400 sub canonicalise_suite_madison {
1401 # madison canonicalises for us
1402 my @r = madison_get_parse(@_);
1404 "unable to canonicalise suite using package $package".
1405 " which does not appear to exist in suite $isuite;".
1406 " --existing-package may help";
1410 sub file_in_archive_madison { return undef; }
1411 sub package_not_wholly_new_madison { return undef; }
1413 #---------- `sshpsql' archive query method ----------
1416 my ($data,$runeinfo,$sql) = @_;
1417 if (!length $data) {
1418 $data= access_someuserhost('sshpsql').':'.
1419 access_cfg('sshpsql-dbname');
1421 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1422 my ($userhost,$dbname) = ($`,$'); #';
1424 my @cmd = (access_cfg_ssh, $userhost,
1425 access_runeinfo("ssh-psql $runeinfo").
1426 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1427 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1429 open P, "-|", @cmd or die $!;
1432 printdebug(">|$_|\n");
1435 $!=0; $?=0; close P or failedcmd @cmd;
1437 my $nrows = pop @rows;
1438 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1439 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1440 @rows = map { [ split /\|/, $_ ] } @rows;
1441 my $ncols = scalar @{ shift @rows };
1442 die if grep { scalar @$_ != $ncols } @rows;
1446 sub sql_injection_check {
1447 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1450 sub archive_query_sshpsql ($$) {
1451 my ($proto,$data) = @_;
1452 sql_injection_check $isuite, $package;
1453 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1454 SELECT source.version, component.name, files.filename, files.sha256sum
1456 JOIN src_associations ON source.id = src_associations.source
1457 JOIN suite ON suite.id = src_associations.suite
1458 JOIN dsc_files ON dsc_files.source = source.id
1459 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1460 JOIN component ON component.id = files_archive_map.component_id
1461 JOIN files ON files.id = dsc_files.file
1462 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1463 AND source.source='$package'
1464 AND files.filename LIKE '%.dsc';
1466 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1467 my $digester = Digest::SHA->new(256);
1469 my ($vsn,$component,$filename,$sha256sum) = @$_;
1470 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1472 return archive_query_prepend_mirror @rows;
1475 sub canonicalise_suite_sshpsql ($$) {
1476 my ($proto,$data) = @_;
1477 sql_injection_check $isuite;
1478 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1479 SELECT suite.codename
1480 FROM suite where suite_name='$isuite' or codename='$isuite';
1482 @rows = map { $_->[0] } @rows;
1483 fail "unknown suite $isuite" unless @rows;
1484 die "ambiguous $isuite: @rows ?" if @rows>1;
1488 sub file_in_archive_sshpsql ($$$) { return undef; }
1489 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1491 #---------- `dummycat' archive query method ----------
1493 sub canonicalise_suite_dummycat ($$) {
1494 my ($proto,$data) = @_;
1495 my $dpath = "$data/suite.$isuite";
1496 if (!open C, "<", $dpath) {
1497 $!==ENOENT or die "$dpath: $!";
1498 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1502 chomp or die "$dpath: $!";
1504 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1508 sub archive_query_dummycat ($$) {
1509 my ($proto,$data) = @_;
1510 canonicalise_suite();
1511 my $dpath = "$data/package.$csuite.$package";
1512 if (!open C, "<", $dpath) {
1513 $!==ENOENT or die "$dpath: $!";
1514 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1522 printdebug "dummycat query $csuite $package $dpath | $_\n";
1523 my @row = split /\s+/, $_;
1524 @row==2 or die "$dpath: $_ ?";
1527 C->error and die "$dpath: $!";
1529 return archive_query_prepend_mirror
1530 sort { -version_compare($a->[0],$b->[0]); } @rows;
1533 sub file_in_archive_dummycat () { return undef; }
1534 sub package_not_wholly_new_dummycat () { return undef; }
1536 #---------- tag format handling ----------
1538 sub access_cfg_tagformats () {
1539 split /\,/, access_cfg('dgit-tag-format');
1542 sub access_cfg_tagformats_can_splitbrain () {
1543 my %y = map { $_ => 1 } access_cfg_tagformats;
1544 foreach my $needtf (qw(new maint)) {
1545 next if $y{$needtf};
1551 sub need_tagformat ($$) {
1552 my ($fmt, $why) = @_;
1553 fail "need to use tag format $fmt ($why) but also need".
1554 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1555 " - no way to proceed"
1556 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1557 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1560 sub select_tagformat () {
1562 return if $tagformatfn && !$tagformat_want;
1563 die 'bug' if $tagformatfn && $tagformat_want;
1564 # ... $tagformat_want assigned after previous select_tagformat
1566 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1567 printdebug "select_tagformat supported @supported\n";
1569 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1570 printdebug "select_tagformat specified @$tagformat_want\n";
1572 my ($fmt,$why,$override) = @$tagformat_want;
1574 fail "target distro supports tag formats @supported".
1575 " but have to use $fmt ($why)"
1577 or grep { $_ eq $fmt } @supported;
1579 $tagformat_want = undef;
1581 $tagformatfn = ${*::}{"debiantag_$fmt"};
1583 fail "trying to use unknown tag format \`$fmt' ($why) !"
1584 unless $tagformatfn;
1587 #---------- archive query entrypoints and rest of program ----------
1589 sub canonicalise_suite () {
1590 return if defined $csuite;
1591 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1592 $csuite = archive_query('canonicalise_suite');
1593 if ($isuite ne $csuite) {
1594 progress "canonical suite name for $isuite is $csuite";
1596 progress "canonical suite name is $csuite";
1600 sub get_archive_dsc () {
1601 canonicalise_suite();
1602 my @vsns = archive_query('archive_query');
1603 foreach my $vinfo (@vsns) {
1604 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1605 $dscurl = $vsn_dscurl;
1606 $dscdata = url_get($dscurl);
1608 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1613 $digester->add($dscdata);
1614 my $got = $digester->hexdigest();
1616 fail "$dscurl has hash $got but".
1617 " archive told us to expect $digest";
1620 my $fmt = getfield $dsc, 'Format';
1621 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1622 "unsupported source format $fmt, sorry";
1624 $dsc_checked = !!$digester;
1625 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1629 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1632 sub check_for_git ();
1633 sub check_for_git () {
1635 my $how = access_cfg('git-check');
1636 if ($how eq 'ssh-cmd') {
1638 (access_cfg_ssh, access_gituserhost(),
1639 access_runeinfo("git-check $package").
1640 " set -e; cd ".access_cfg('git-path').";".
1641 " if test -d $package.git; then echo 1; else echo 0; fi");
1642 my $r= cmdoutput @cmd;
1643 if (defined $r and $r =~ m/^divert (\w+)$/) {
1645 my ($usedistro,) = access_distros();
1646 # NB that if we are pushing, $usedistro will be $distro/push
1647 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1648 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1649 progress "diverting to $divert (using config for $instead_distro)";
1650 return check_for_git();
1652 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1654 } elsif ($how eq 'url') {
1655 my $prefix = access_cfg('git-check-url','git-url');
1656 my $suffix = access_cfg('git-check-suffix','git-suffix',
1657 'RETURN-UNDEF') // '.git';
1658 my $url = "$prefix/$package$suffix";
1659 my @cmd = (@curl, qw(-sS -I), $url);
1660 my $result = cmdoutput @cmd;
1661 $result =~ s/^\S+ 200 .*\n\r?\n//;
1662 # curl -sS -I with https_proxy prints
1663 # HTTP/1.0 200 Connection established
1664 $result =~ m/^\S+ (404|200) /s or
1665 fail "unexpected results from git check query - ".
1666 Dumper($prefix, $result);
1668 if ($code eq '404') {
1670 } elsif ($code eq '200') {
1675 } elsif ($how eq 'true') {
1677 } elsif ($how eq 'false') {
1680 badcfg "unknown git-check \`$how'";
1684 sub create_remote_git_repo () {
1685 my $how = access_cfg('git-create');
1686 if ($how eq 'ssh-cmd') {
1688 (access_cfg_ssh, access_gituserhost(),
1689 access_runeinfo("git-create $package").
1690 "set -e; cd ".access_cfg('git-path').";".
1691 " cp -a _template $package.git");
1692 } elsif ($how eq 'true') {
1695 badcfg "unknown git-create \`$how'";
1699 our ($dsc_hash,$lastpush_mergeinput);
1700 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1704 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1705 $playground = fresh_playground 'dgit/unpack';
1708 sub mktree_in_ud_here () {
1709 playtree_setup $gitcfgs{local};
1712 sub git_write_tree () {
1713 my $tree = cmdoutput @git, qw(write-tree);
1714 $tree =~ m/^\w+$/ or die "$tree ?";
1718 sub git_add_write_tree () {
1719 runcmd @git, qw(add -Af .);
1720 return git_write_tree();
1723 sub remove_stray_gits ($) {
1725 my @gitscmd = qw(find -name .git -prune -print0);
1726 debugcmd "|",@gitscmd;
1727 open GITS, "-|", @gitscmd or die $!;
1732 print STDERR "$us: warning: removing from $what: ",
1733 (messagequote $_), "\n";
1737 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1740 sub mktree_in_ud_from_only_subdir ($;$) {
1741 my ($what,$raw) = @_;
1742 # changes into the subdir
1745 die "expected one subdir but found @dirs ?" unless @dirs==1;
1746 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1750 remove_stray_gits($what);
1751 mktree_in_ud_here();
1753 my ($format, $fopts) = get_source_format();
1754 if (madformat($format)) {
1759 my $tree=git_add_write_tree();
1760 return ($tree,$dir);
1763 our @files_csum_info_fields =
1764 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1765 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1766 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1768 sub dsc_files_info () {
1769 foreach my $csumi (@files_csum_info_fields) {
1770 my ($fname, $module, $method) = @$csumi;
1771 my $field = $dsc->{$fname};
1772 next unless defined $field;
1773 eval "use $module; 1;" or die $@;
1775 foreach (split /\n/, $field) {
1777 m/^(\w+) (\d+) (\S+)$/ or
1778 fail "could not parse .dsc $fname line \`$_'";
1779 my $digester = eval "$module"."->$method;" or die $@;
1784 Digester => $digester,
1789 fail "missing any supported Checksums-* or Files field in ".
1790 $dsc->get_option('name');
1794 map { $_->{Filename} } dsc_files_info();
1797 sub files_compare_inputs (@) {
1802 my $showinputs = sub {
1803 return join "; ", map { $_->get_option('name') } @$inputs;
1806 foreach my $in (@$inputs) {
1808 my $in_name = $in->get_option('name');
1810 printdebug "files_compare_inputs $in_name\n";
1812 foreach my $csumi (@files_csum_info_fields) {
1813 my ($fname) = @$csumi;
1814 printdebug "files_compare_inputs $in_name $fname\n";
1816 my $field = $in->{$fname};
1817 next unless defined $field;
1820 foreach (split /\n/, $field) {
1823 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1824 fail "could not parse $in_name $fname line \`$_'";
1826 printdebug "files_compare_inputs $in_name $fname $f\n";
1830 my $re = \ $record{$f}{$fname};
1832 $fchecked{$f}{$in_name} = 1;
1834 fail "hash or size of $f varies in $fname fields".
1835 " (between: ".$showinputs->().")";
1840 @files = sort @files;
1841 $expected_files //= \@files;
1842 "@$expected_files" eq "@files" or
1843 fail "file list in $in_name varies between hash fields!";
1846 fail "$in_name has no files list field(s)";
1848 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1851 grep { keys %$_ == @$inputs-1 } values %fchecked
1852 or fail "no file appears in all file lists".
1853 " (looked in: ".$showinputs->().")";
1856 sub is_orig_file_in_dsc ($$) {
1857 my ($f, $dsc_files_info) = @_;
1858 return 0 if @$dsc_files_info <= 1;
1859 # One file means no origs, and the filename doesn't have a "what
1860 # part of dsc" component. (Consider versions ending `.orig'.)
1861 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1865 sub is_orig_file_of_vsn ($$) {
1866 my ($f, $upstreamvsn) = @_;
1867 my $base = srcfn $upstreamvsn, '';
1868 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1872 # This function determines whether a .changes file is source-only from
1873 # the point of view of dak. Thus, it permits *_source.buildinfo
1876 # It does not, however, permit any other buildinfo files. After a
1877 # source-only upload, the buildds will try to upload files like
1878 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1879 # named like this in their (otherwise) source-only upload, the uploads
1880 # of the buildd can be rejected by dak. Fixing the resultant
1881 # situation can require manual intervention. So we block such
1882 # .buildinfo files when the user tells us to perform a source-only
1883 # upload (such as when using the push-source subcommand with the -C
1884 # option, which calls this function).
1886 # Note, though, that when dgit is told to prepare a source-only
1887 # upload, such as when subcommands like build-source and push-source
1888 # without -C are used, dgit has a more restrictive notion of
1889 # source-only .changes than dak: such uploads will never include
1890 # *_source.buildinfo files. This is because there is no use for such
1891 # files when using a tool like dgit to produce the source package, as
1892 # dgit ensures the source is identical to git HEAD.
1893 sub test_source_only_changes ($) {
1895 foreach my $l (split /\n/, getfield $changes, 'Files') {
1896 $l =~ m/\S+$/ or next;
1897 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1898 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1899 print "purportedly source-only changes polluted by $&\n";
1906 sub changes_update_origs_from_dsc ($$$$) {
1907 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1909 printdebug "checking origs needed ($upstreamvsn)...\n";
1910 $_ = getfield $changes, 'Files';
1911 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1912 fail "cannot find section/priority from .changes Files field";
1913 my $placementinfo = $1;
1915 printdebug "checking origs needed placement '$placementinfo'...\n";
1916 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1917 $l =~ m/\S+$/ or next;
1919 printdebug "origs $file | $l\n";
1920 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1921 printdebug "origs $file is_orig\n";
1922 my $have = archive_query('file_in_archive', $file);
1923 if (!defined $have) {
1925 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1931 printdebug "origs $file \$#\$have=$#$have\n";
1932 foreach my $h (@$have) {
1935 foreach my $csumi (@files_csum_info_fields) {
1936 my ($fname, $module, $method, $archivefield) = @$csumi;
1937 next unless defined $h->{$archivefield};
1938 $_ = $dsc->{$fname};
1939 next unless defined;
1940 m/^(\w+) .* \Q$file\E$/m or
1941 fail ".dsc $fname missing entry for $file";
1942 if ($h->{$archivefield} eq $1) {
1946 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1949 die "$file ".Dumper($h)." ?!" if $same && @differ;
1952 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1955 printdebug "origs $file f.same=$found_same".
1956 " #f._differ=$#found_differ\n";
1957 if (@found_differ && !$found_same) {
1959 "archive contains $file with different checksum",
1962 # Now we edit the changes file to add or remove it
1963 foreach my $csumi (@files_csum_info_fields) {
1964 my ($fname, $module, $method, $archivefield) = @$csumi;
1965 next unless defined $changes->{$fname};
1967 # in archive, delete from .changes if it's there
1968 $changed{$file} = "removed" if
1969 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
1970 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
1971 # not in archive, but it's here in the .changes
1973 my $dsc_data = getfield $dsc, $fname;
1974 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
1976 $extra =~ s/ \d+ /$&$placementinfo /
1977 or die "$fname $extra >$dsc_data< ?"
1978 if $fname eq 'Files';
1979 $changes->{$fname} .= "\n". $extra;
1980 $changed{$file} = "added";
1985 foreach my $file (keys %changed) {
1987 "edited .changes for archive .orig contents: %s %s",
1988 $changed{$file}, $file;
1990 my $chtmp = "$changesfile.tmp";
1991 $changes->save($chtmp);
1993 rename $chtmp,$changesfile or die "$changesfile $!";
1995 progress "[new .changes left in $changesfile]";
1998 progress "$changesfile already has appropriate .orig(s) (if any)";
2002 sub make_commit ($) {
2004 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2007 sub make_commit_text ($) {
2010 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
2012 print Dumper($text) if $debuglevel > 1;
2013 my $child = open2($out, $in, @cmd) or die $!;
2016 print $in $text or die $!;
2017 close $in or die $!;
2019 $h =~ m/^\w+$/ or die;
2021 printdebug "=> $h\n";
2024 waitpid $child, 0 == $child or die "$child $!";
2025 $? and failedcmd @cmd;
2029 sub clogp_authline ($) {
2031 my $author = getfield $clogp, 'Maintainer';
2032 if ($author =~ m/^[^"\@]+\,/) {
2033 # single entry Maintainer field with unquoted comma
2034 $author = ($& =~ y/,//rd).$'; # strip the comma
2036 # git wants a single author; any remaining commas in $author
2037 # are by now preceded by @ (or "). It seems safer to punt on
2038 # "..." for now rather than attempting to dequote or something.
2039 $author =~ s#,.*##ms unless $author =~ m/"/;
2040 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2041 my $authline = "$author $date";
2042 $authline =~ m/$git_authline_re/o or
2043 fail "unexpected commit author line format \`$authline'".
2044 " (was generated from changelog Maintainer field)";
2045 return ($1,$2,$3) if wantarray;
2049 sub vendor_patches_distro ($$) {
2050 my ($checkdistro, $what) = @_;
2051 return unless defined $checkdistro;
2053 my $series = "debian/patches/\L$checkdistro\E.series";
2054 printdebug "checking for vendor-specific $series ($what)\n";
2056 if (!open SERIES, "<", $series) {
2057 die "$series $!" unless $!==ENOENT;
2066 Unfortunately, this source package uses a feature of dpkg-source where
2067 the same source package unpacks to different source code on different
2068 distros. dgit cannot safely operate on such packages on affected
2069 distros, because the meaning of source packages is not stable.
2071 Please ask the distro/maintainer to remove the distro-specific series
2072 files and use a different technique (if necessary, uploading actually
2073 different packages, if different distros are supposed to have
2077 fail "Found active distro-specific series file for".
2078 " $checkdistro ($what): $series, cannot continue";
2080 die "$series $!" if SERIES->error;
2084 sub check_for_vendor_patches () {
2085 # This dpkg-source feature doesn't seem to be documented anywhere!
2086 # But it can be found in the changelog (reformatted):
2088 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2089 # Author: Raphael Hertzog <hertzog@debian.org>
2090 # Date: Sun Oct 3 09:36:48 2010 +0200
2092 # dpkg-source: correctly create .pc/.quilt_series with alternate
2095 # If you have debian/patches/ubuntu.series and you were
2096 # unpacking the source package on ubuntu, quilt was still
2097 # directed to debian/patches/series instead of
2098 # debian/patches/ubuntu.series.
2100 # debian/changelog | 3 +++
2101 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2102 # 2 files changed, 6 insertions(+), 1 deletion(-)
2105 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2106 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2107 "Dpkg::Vendor \`current vendor'");
2108 vendor_patches_distro(access_basedistro(),
2109 "(base) distro being accessed");
2110 vendor_patches_distro(access_nomdistro(),
2111 "(nominal) distro being accessed");
2114 sub generate_commits_from_dsc () {
2115 # See big comment in fetch_from_archive, below.
2116 # See also README.dsc-import.
2118 changedir $playground;
2120 my @dfi = dsc_files_info();
2121 foreach my $fi (@dfi) {
2122 my $f = $fi->{Filename};
2123 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2124 my $upper_f = (bpd_abs()."/$f");
2126 printdebug "considering reusing $f: ";
2128 if (link_ltarget "$upper_f,fetch", $f) {
2129 printdebug "linked (using ...,fetch).\n";
2130 } elsif ((printdebug "($!) "),
2132 fail "accessing $buildproductsdir/$f,fetch: $!";
2133 } elsif (link_ltarget $upper_f, $f) {
2134 printdebug "linked.\n";
2135 } elsif ((printdebug "($!) "),
2137 fail "accessing $buildproductsdir/$f: $!";
2139 printdebug "absent.\n";
2143 complete_file_from_dsc('.', $fi, \$refetched)
2146 printdebug "considering saving $f: ";
2148 if (link $f, $upper_f) {
2149 printdebug "linked.\n";
2150 } elsif ((printdebug "($!) "),
2152 fail "saving $buildproductsdir/$f: $!";
2153 } elsif (!$refetched) {
2154 printdebug "no need.\n";
2155 } elsif (link $f, "$upper_f,fetch") {
2156 printdebug "linked (using ...,fetch).\n";
2157 } elsif ((printdebug "($!) "),
2159 fail "saving $buildproductsdir/$f,fetch: $!";
2161 printdebug "cannot.\n";
2165 # We unpack and record the orig tarballs first, so that we only
2166 # need disk space for one private copy of the unpacked source.
2167 # But we can't make them into commits until we have the metadata
2168 # from the debian/changelog, so we record the tree objects now and
2169 # make them into commits later.
2171 my $upstreamv = upstreamversion $dsc->{version};
2172 my $orig_f_base = srcfn $upstreamv, '';
2174 foreach my $fi (@dfi) {
2175 # We actually import, and record as a commit, every tarball
2176 # (unless there is only one file, in which case there seems
2179 my $f = $fi->{Filename};
2180 printdebug "import considering $f ";
2181 (printdebug "only one dfi\n"), next if @dfi == 1;
2182 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2183 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2187 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2189 printdebug "Y ", (join ' ', map { $_//"(none)" }
2190 $compr_ext, $orig_f_part
2193 my $input = new IO::File $f, '<' or die "$f $!";
2197 if (defined $compr_ext) {
2199 Dpkg::Compression::compression_guess_from_filename $f;
2200 fail "Dpkg::Compression cannot handle file $f in source package"
2201 if defined $compr_ext && !defined $cname;
2203 new Dpkg::Compression::Process compression => $cname;
2204 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2205 my $compr_fh = new IO::Handle;
2206 my $compr_pid = open $compr_fh, "-|" // die $!;
2208 open STDIN, "<&", $input or die $!;
2210 die "dgit (child): exec $compr_cmd[0]: $!\n";
2215 rmtree "_unpack-tar";
2216 mkdir "_unpack-tar" or die $!;
2217 my @tarcmd = qw(tar -x -f -
2218 --no-same-owner --no-same-permissions
2219 --no-acls --no-xattrs --no-selinux);
2220 my $tar_pid = fork // die $!;
2222 chdir "_unpack-tar" or die $!;
2223 open STDIN, "<&", $input or die $!;
2225 die "dgit (child): exec $tarcmd[0]: $!";
2227 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2228 !$? or failedcmd @tarcmd;
2231 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2233 # finally, we have the results in "tarball", but maybe
2234 # with the wrong permissions
2236 runcmd qw(chmod -R +rwX _unpack-tar);
2237 changedir "_unpack-tar";
2238 remove_stray_gits($f);
2239 mktree_in_ud_here();
2241 my ($tree) = git_add_write_tree();
2242 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2243 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2245 printdebug "one subtree $1\n";
2247 printdebug "multiple subtrees\n";
2250 rmtree "_unpack-tar";
2252 my $ent = [ $f, $tree ];
2254 Orig => !!$orig_f_part,
2255 Sort => (!$orig_f_part ? 2 :
2256 $orig_f_part =~ m/-/g ? 1 :
2264 # put any without "_" first (spec is not clear whether files
2265 # are always in the usual order). Tarballs without "_" are
2266 # the main orig or the debian tarball.
2267 $a->{Sort} <=> $b->{Sort} or
2271 my $any_orig = grep { $_->{Orig} } @tartrees;
2273 my $dscfn = "$package.dsc";
2275 my $treeimporthow = 'package';
2277 open D, ">", $dscfn or die "$dscfn: $!";
2278 print D $dscdata or die "$dscfn: $!";
2279 close D or die "$dscfn: $!";
2280 my @cmd = qw(dpkg-source);
2281 push @cmd, '--no-check' if $dsc_checked;
2282 if (madformat $dsc->{format}) {
2283 push @cmd, '--skip-patches';
2284 $treeimporthow = 'unpatched';
2286 push @cmd, qw(-x --), $dscfn;
2289 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2290 if (madformat $dsc->{format}) {
2291 check_for_vendor_patches();
2295 if (madformat $dsc->{format}) {
2296 my @pcmd = qw(dpkg-source --before-build .);
2297 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2299 $dappliedtree = git_add_write_tree();
2302 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2306 printdebug "import clog search...\n";
2307 parsechangelog_loop \@clogcmd, "package changelog", sub {
2308 my ($thisstanza, $desc) = @_;
2309 no warnings qw(exiting);
2311 $clogp //= $thisstanza;
2313 printdebug "import clog $thisstanza->{version} $desc...\n";
2315 last if !$any_orig; # we don't need $r1clogp
2317 # We look for the first (most recent) changelog entry whose
2318 # version number is lower than the upstream version of this
2319 # package. Then the last (least recent) previous changelog
2320 # entry is treated as the one which introduced this upstream
2321 # version and used for the synthetic commits for the upstream
2324 # One might think that a more sophisticated algorithm would be
2325 # necessary. But: we do not want to scan the whole changelog
2326 # file. Stopping when we see an earlier version, which
2327 # necessarily then is an earlier upstream version, is the only
2328 # realistic way to do that. Then, either the earliest
2329 # changelog entry we have seen so far is indeed the earliest
2330 # upload of this upstream version; or there are only changelog
2331 # entries relating to later upstream versions (which is not
2332 # possible unless the changelog and .dsc disagree about the
2333 # version). Then it remains to choose between the physically
2334 # last entry in the file, and the one with the lowest version
2335 # number. If these are not the same, we guess that the
2336 # versions were created in a non-monotonic order rather than
2337 # that the changelog entries have been misordered.
2339 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2341 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2342 $r1clogp = $thisstanza;
2344 printdebug "import clog $r1clogp->{version} becomes r1\n";
2347 $clogp or fail "package changelog has no entries!";
2349 my $authline = clogp_authline $clogp;
2350 my $changes = getfield $clogp, 'Changes';
2351 $changes =~ s/^\n//; # Changes: \n
2352 my $cversion = getfield $clogp, 'Version';
2355 $r1clogp //= $clogp; # maybe there's only one entry;
2356 my $r1authline = clogp_authline $r1clogp;
2357 # Strictly, r1authline might now be wrong if it's going to be
2358 # unused because !$any_orig. Whatever.
2360 printdebug "import tartrees authline $authline\n";
2361 printdebug "import tartrees r1authline $r1authline\n";
2363 foreach my $tt (@tartrees) {
2364 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2366 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2369 committer $r1authline
2373 [dgit import orig $tt->{F}]
2381 [dgit import tarball $package $cversion $tt->{F}]
2386 printdebug "import main commit\n";
2388 open C, ">../commit.tmp" or die $!;
2389 print C <<END or die $!;
2392 print C <<END or die $! foreach @tartrees;
2395 print C <<END or die $!;
2401 [dgit import $treeimporthow $package $cversion]
2405 my $rawimport_hash = make_commit qw(../commit.tmp);
2407 if (madformat $dsc->{format}) {
2408 printdebug "import apply patches...\n";
2410 # regularise the state of the working tree so that
2411 # the checkout of $rawimport_hash works nicely.
2412 my $dappliedcommit = make_commit_text(<<END);
2419 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2421 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2423 # We need the answers to be reproducible
2424 my @authline = clogp_authline($clogp);
2425 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2426 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2427 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2428 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2429 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2430 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2432 my $path = $ENV{PATH} or die;
2434 # we use ../../gbp-pq-output, which (given that we are in
2435 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2438 foreach my $use_absurd (qw(0 1)) {
2439 runcmd @git, qw(checkout -q unpa);
2440 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2441 local $ENV{PATH} = $path;
2444 progress "warning: $@";
2445 $path = "$absurdity:$path";
2446 progress "$us: trying slow absurd-git-apply...";
2447 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2452 die "forbid absurd git-apply\n" if $use_absurd
2453 && forceing [qw(import-gitapply-no-absurd)];
2454 die "only absurd git-apply!\n" if !$use_absurd
2455 && forceing [qw(import-gitapply-absurd)];
2457 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2458 local $ENV{PATH} = $path if $use_absurd;
2460 my @showcmd = (gbp_pq, qw(import));
2461 my @realcmd = shell_cmd
2462 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2463 debugcmd "+",@realcmd;
2464 if (system @realcmd) {
2465 die +(shellquote @showcmd).
2467 failedcmd_waitstatus()."\n";
2470 my $gapplied = git_rev_parse('HEAD');
2471 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2472 $gappliedtree eq $dappliedtree or
2474 gbp-pq import and dpkg-source disagree!
2475 gbp-pq import gave commit $gapplied
2476 gbp-pq import gave tree $gappliedtree
2477 dpkg-source --before-build gave tree $dappliedtree
2479 $rawimport_hash = $gapplied;
2484 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2489 progress "synthesised git commit from .dsc $cversion";
2491 my $rawimport_mergeinput = {
2492 Commit => $rawimport_hash,
2493 Info => "Import of source package",
2495 my @output = ($rawimport_mergeinput);
2497 if ($lastpush_mergeinput) {
2498 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2499 my $oversion = getfield $oldclogp, 'Version';
2501 version_compare($oversion, $cversion);
2503 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2504 { Message => <<END, ReverseParents => 1 });
2505 Record $package ($cversion) in archive suite $csuite
2507 } elsif ($vcmp > 0) {
2508 print STDERR <<END or die $!;
2510 Version actually in archive: $cversion (older)
2511 Last version pushed with dgit: $oversion (newer or same)
2514 @output = $lastpush_mergeinput;
2516 # Same version. Use what's in the server git branch,
2517 # discarding our own import. (This could happen if the
2518 # server automatically imports all packages into git.)
2519 @output = $lastpush_mergeinput;
2527 sub complete_file_from_dsc ($$;$) {
2528 our ($dstdir, $fi, $refetched) = @_;
2529 # Ensures that we have, in $dstdir, the file $fi, with the correct
2530 # contents. (Downloading it from alongside $dscurl if necessary.)
2531 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2532 # and will set $$refetched=1 if it did so (or tried to).
2534 my $f = $fi->{Filename};
2535 my $tf = "$dstdir/$f";
2539 my $checkhash = sub {
2540 open F, "<", "$tf" or die "$tf: $!";
2541 $fi->{Digester}->reset();
2542 $fi->{Digester}->addfile(*F);
2543 F->error and die $!;
2544 $got = $fi->{Digester}->hexdigest();
2545 return $got eq $fi->{Hash};
2548 if (stat_exists $tf) {
2549 if ($checkhash->()) {
2550 progress "using existing $f";
2554 fail "file $f has hash $got but .dsc".
2555 " demands hash $fi->{Hash} ".
2556 "(perhaps you should delete this file?)";
2558 progress "need to fetch correct version of $f";
2559 unlink $tf or die "$tf $!";
2562 printdebug "$tf does not exist, need to fetch\n";
2566 $furl =~ s{/[^/]+$}{};
2568 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2569 die "$f ?" if $f =~ m#/#;
2570 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2571 return 0 if !act_local();
2574 fail "file $f has hash $got but .dsc".
2575 " demands hash $fi->{Hash} ".
2576 "(got wrong file from archive!)";
2581 sub ensure_we_have_orig () {
2582 my @dfi = dsc_files_info();
2583 foreach my $fi (@dfi) {
2584 my $f = $fi->{Filename};
2585 next unless is_orig_file_in_dsc($f, \@dfi);
2586 complete_file_from_dsc($buildproductsdir, $fi)
2591 #---------- git fetch ----------
2593 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2594 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2596 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2597 # locally fetched refs because they have unhelpful names and clutter
2598 # up gitk etc. So we track whether we have "used up" head ref (ie,
2599 # whether we have made another local ref which refers to this object).
2601 # (If we deleted them unconditionally, then we might end up
2602 # re-fetching the same git objects each time dgit fetch was run.)
2604 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2605 # in git_fetch_us to fetch the refs in question, and possibly a call
2606 # to lrfetchref_used.
2608 our (%lrfetchrefs_f, %lrfetchrefs_d);
2609 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2611 sub lrfetchref_used ($) {
2612 my ($fullrefname) = @_;
2613 my $objid = $lrfetchrefs_f{$fullrefname};
2614 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2617 sub git_lrfetch_sane {
2618 my ($url, $supplementary, @specs) = @_;
2619 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2620 # at least as regards @specs. Also leave the results in
2621 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2622 # able to clean these up.
2624 # With $supplementary==1, @specs must not contain wildcards
2625 # and we add to our previous fetches (non-atomically).
2627 # This is rather miserable:
2628 # When git fetch --prune is passed a fetchspec ending with a *,
2629 # it does a plausible thing. If there is no * then:
2630 # - it matches subpaths too, even if the supplied refspec
2631 # starts refs, and behaves completely madly if the source
2632 # has refs/refs/something. (See, for example, Debian #NNNN.)
2633 # - if there is no matching remote ref, it bombs out the whole
2635 # We want to fetch a fixed ref, and we don't know in advance
2636 # if it exists, so this is not suitable.
2638 # Our workaround is to use git ls-remote. git ls-remote has its
2639 # own qairks. Notably, it has the absurd multi-tail-matching
2640 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2641 # refs/refs/foo etc.
2643 # Also, we want an idempotent snapshot, but we have to make two
2644 # calls to the remote: one to git ls-remote and to git fetch. The
2645 # solution is use git ls-remote to obtain a target state, and
2646 # git fetch to try to generate it. If we don't manage to generate
2647 # the target state, we try again.
2649 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2651 my $specre = join '|', map {
2654 my $wildcard = $x =~ s/\\\*$/.*/;
2655 die if $wildcard && $supplementary;
2658 printdebug "git_lrfetch_sane specre=$specre\n";
2659 my $wanted_rref = sub {
2661 return m/^(?:$specre)$/;
2664 my $fetch_iteration = 0;
2667 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2668 if (++$fetch_iteration > 10) {
2669 fail "too many iterations trying to get sane fetch!";
2672 my @look = map { "refs/$_" } @specs;
2673 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2677 open GITLS, "-|", @lcmd or die $!;
2679 printdebug "=> ", $_;
2680 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2681 my ($objid,$rrefname) = ($1,$2);
2682 if (!$wanted_rref->($rrefname)) {
2684 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2688 $wantr{$rrefname} = $objid;
2691 close GITLS or failedcmd @lcmd;
2693 # OK, now %want is exactly what we want for refs in @specs
2695 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2696 "+refs/$_:".lrfetchrefs."/$_";
2699 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2701 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2702 runcmd_ordryrun_local @fcmd if @fspecs;
2704 if (!$supplementary) {
2705 %lrfetchrefs_f = ();
2709 git_for_each_ref(lrfetchrefs, sub {
2710 my ($objid,$objtype,$lrefname,$reftail) = @_;
2711 $lrfetchrefs_f{$lrefname} = $objid;
2712 $objgot{$objid} = 1;
2715 if ($supplementary) {
2719 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2720 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2721 if (!exists $wantr{$rrefname}) {
2722 if ($wanted_rref->($rrefname)) {
2724 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2728 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2731 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2732 delete $lrfetchrefs_f{$lrefname};
2736 foreach my $rrefname (sort keys %wantr) {
2737 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2738 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2739 my $want = $wantr{$rrefname};
2740 next if $got eq $want;
2741 if (!defined $objgot{$want}) {
2742 fail <<END unless act_local();
2743 --dry-run specified but we actually wanted the results of git fetch,
2744 so this is not going to work. Try running dgit fetch first,
2745 or using --damp-run instead of --dry-run.
2748 warning: git ls-remote suggests we want $lrefname
2749 warning: and it should refer to $want
2750 warning: but git fetch didn't fetch that object to any relevant ref.
2751 warning: This may be due to a race with someone updating the server.
2752 warning: Will try again...
2754 next FETCH_ITERATION;
2757 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2759 runcmd_ordryrun_local @git, qw(update-ref -m),
2760 "dgit fetch git fetch fixup", $lrefname, $want;
2761 $lrfetchrefs_f{$lrefname} = $want;
2766 if (defined $csuite) {
2767 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2768 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2769 my ($objid,$objtype,$lrefname,$reftail) = @_;
2770 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2771 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2775 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2776 Dumper(\%lrfetchrefs_f);
2779 sub git_fetch_us () {
2780 # Want to fetch only what we are going to use, unless
2781 # deliberately-not-ff, in which case we must fetch everything.
2783 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2785 (quiltmode_splitbrain
2786 ? (map { $_->('*',access_nomdistro) }
2787 \&debiantag_new, \&debiantag_maintview)
2788 : debiantags('*',access_nomdistro));
2789 push @specs, server_branch($csuite);
2790 push @specs, $rewritemap;
2791 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2793 my $url = access_giturl();
2794 git_lrfetch_sane $url, 0, @specs;
2797 my @tagpats = debiantags('*',access_nomdistro);
2799 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2800 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2801 printdebug "currently $fullrefname=$objid\n";
2802 $here{$fullrefname} = $objid;
2804 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2805 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2806 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2807 printdebug "offered $lref=$objid\n";
2808 if (!defined $here{$lref}) {
2809 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2810 runcmd_ordryrun_local @upd;
2811 lrfetchref_used $fullrefname;
2812 } elsif ($here{$lref} eq $objid) {
2813 lrfetchref_used $fullrefname;
2816 "Not updating $lref from $here{$lref} to $objid.\n";
2821 #---------- dsc and archive handling ----------
2823 sub mergeinfo_getclogp ($) {
2824 # Ensures thit $mi->{Clogp} exists and returns it
2826 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2829 sub mergeinfo_version ($) {
2830 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2833 sub fetch_from_archive_record_1 ($) {
2835 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2836 cmdoutput @git, qw(log -n2), $hash;
2837 # ... gives git a chance to complain if our commit is malformed
2840 sub fetch_from_archive_record_2 ($) {
2842 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2846 dryrun_report @upd_cmd;
2850 sub parse_dsc_field_def_dsc_distro () {
2851 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2852 dgit.default.distro);
2855 sub parse_dsc_field ($$) {
2856 my ($dsc, $what) = @_;
2858 foreach my $field (@ourdscfield) {
2859 $f = $dsc->{$field};
2864 progress "$what: NO git hash";
2865 parse_dsc_field_def_dsc_distro();
2866 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2867 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2868 progress "$what: specified git info ($dsc_distro)";
2869 $dsc_hint_tag = [ $dsc_hint_tag ];
2870 } elsif ($f =~ m/^\w+\s*$/) {
2872 parse_dsc_field_def_dsc_distro();
2873 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2875 progress "$what: specified git hash";
2877 fail "$what: invalid Dgit info";
2881 sub resolve_dsc_field_commit ($$) {
2882 my ($already_distro, $already_mapref) = @_;
2884 return unless defined $dsc_hash;
2887 defined $already_mapref &&
2888 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2889 ? $already_mapref : undef;
2893 my ($what, @fetch) = @_;
2895 local $idistro = $dsc_distro;
2896 my $lrf = lrfetchrefs;
2898 if (!$chase_dsc_distro) {
2900 "not chasing .dsc distro $dsc_distro: not fetching $what";
2905 ".dsc names distro $dsc_distro: fetching $what";
2907 my $url = access_giturl();
2908 if (!defined $url) {
2909 defined $dsc_hint_url or fail <<END;
2910 .dsc Dgit metadata is in context of distro $dsc_distro
2911 for which we have no configured url and .dsc provides no hint
2914 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2915 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2916 parse_cfg_bool "dsc-url-proto-ok", 'false',
2917 cfg("dgit.dsc-url-proto-ok.$proto",
2918 "dgit.default.dsc-url-proto-ok")
2920 .dsc Dgit metadata is in context of distro $dsc_distro
2921 for which we have no configured url;
2922 .dsc provides hinted url with protocol $proto which is unsafe.
2923 (can be overridden by config - consult documentation)
2925 $url = $dsc_hint_url;
2928 git_lrfetch_sane $url, 1, @fetch;
2933 my $rewrite_enable = do {
2934 local $idistro = $dsc_distro;
2935 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2938 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2939 if (!defined $mapref) {
2940 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2941 $mapref = $lrf.'/'.$rewritemap;
2943 my $rewritemapdata = git_cat_file $mapref.':map';
2944 if (defined $rewritemapdata
2945 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2947 "server's git history rewrite map contains a relevant entry!";
2950 if (defined $dsc_hash) {
2951 progress "using rewritten git hash in place of .dsc value";
2953 progress "server data says .dsc hash is to be disregarded";
2958 if (!defined git_cat_file $dsc_hash) {
2959 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2960 my $lrf = $do_fetch->("additional commits", @tags) &&
2961 defined git_cat_file $dsc_hash
2963 .dsc Dgit metadata requires commit $dsc_hash
2964 but we could not obtain that object anywhere.
2966 foreach my $t (@tags) {
2967 my $fullrefname = $lrf.'/'.$t;
2968 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2969 next unless $lrfetchrefs_f{$fullrefname};
2970 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2971 lrfetchref_used $fullrefname;
2976 sub fetch_from_archive () {
2977 ensure_setup_existing_tree();
2979 # Ensures that lrref() is what is actually in the archive, one way
2980 # or another, according to us - ie this client's
2981 # appropritaely-updated archive view. Also returns the commit id.
2982 # If there is nothing in the archive, leaves lrref alone and
2983 # returns undef. git_fetch_us must have already been called.
2987 parse_dsc_field($dsc, 'last upload to archive');
2988 resolve_dsc_field_commit access_basedistro,
2989 lrfetchrefs."/".$rewritemap
2991 progress "no version available from the archive";
2994 # If the archive's .dsc has a Dgit field, there are three
2995 # relevant git commitids we need to choose between and/or merge
2997 # 1. $dsc_hash: the Dgit field from the archive
2998 # 2. $lastpush_hash: the suite branch on the dgit git server
2999 # 3. $lastfetch_hash: our local tracking brach for the suite
3001 # These may all be distinct and need not be in any fast forward
3004 # If the dsc was pushed to this suite, then the server suite
3005 # branch will have been updated; but it might have been pushed to
3006 # a different suite and copied by the archive. Conversely a more
3007 # recent version may have been pushed with dgit but not appeared
3008 # in the archive (yet).
3010 # $lastfetch_hash may be awkward because archive imports
3011 # (particularly, imports of Dgit-less .dscs) are performed only as
3012 # needed on individual clients, so different clients may perform a
3013 # different subset of them - and these imports are only made
3014 # public during push. So $lastfetch_hash may represent a set of
3015 # imports different to a subsequent upload by a different dgit
3018 # Our approach is as follows:
3020 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3021 # descendant of $dsc_hash, then it was pushed by a dgit user who
3022 # had based their work on $dsc_hash, so we should prefer it.
3023 # Otherwise, $dsc_hash was installed into this suite in the
3024 # archive other than by a dgit push, and (necessarily) after the
3025 # last dgit push into that suite (since a dgit push would have
3026 # been descended from the dgit server git branch); thus, in that
3027 # case, we prefer the archive's version (and produce a
3028 # pseudo-merge to overwrite the dgit server git branch).
3030 # (If there is no Dgit field in the archive's .dsc then
3031 # generate_commit_from_dsc uses the version numbers to decide
3032 # whether the suite branch or the archive is newer. If the suite
3033 # branch is newer it ignores the archive's .dsc; otherwise it
3034 # generates an import of the .dsc, and produces a pseudo-merge to
3035 # overwrite the suite branch with the archive contents.)
3037 # The outcome of that part of the algorithm is the `public view',
3038 # and is same for all dgit clients: it does not depend on any
3039 # unpublished history in the local tracking branch.
3041 # As between the public view and the local tracking branch: The
3042 # local tracking branch is only updated by dgit fetch, and
3043 # whenever dgit fetch runs it includes the public view in the
3044 # local tracking branch. Therefore if the public view is not
3045 # descended from the local tracking branch, the local tracking
3046 # branch must contain history which was imported from the archive
3047 # but never pushed; and, its tip is now out of date. So, we make
3048 # a pseudo-merge to overwrite the old imports and stitch the old
3051 # Finally: we do not necessarily reify the public view (as
3052 # described above). This is so that we do not end up stacking two
3053 # pseudo-merges. So what we actually do is figure out the inputs
3054 # to any public view pseudo-merge and put them in @mergeinputs.
3057 # $mergeinputs[]{Commit}
3058 # $mergeinputs[]{Info}
3059 # $mergeinputs[0] is the one whose tree we use
3060 # @mergeinputs is in the order we use in the actual commit)
3063 # $mergeinputs[]{Message} is a commit message to use
3064 # $mergeinputs[]{ReverseParents} if def specifies that parent
3065 # list should be in opposite order
3066 # Such an entry has no Commit or Info. It applies only when found
3067 # in the last entry. (This ugliness is to support making
3068 # identical imports to previous dgit versions.)
3070 my $lastpush_hash = git_get_ref(lrfetchref());
3071 printdebug "previous reference hash=$lastpush_hash\n";
3072 $lastpush_mergeinput = $lastpush_hash && {
3073 Commit => $lastpush_hash,
3074 Info => "dgit suite branch on dgit git server",
3077 my $lastfetch_hash = git_get_ref(lrref());
3078 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3079 my $lastfetch_mergeinput = $lastfetch_hash && {
3080 Commit => $lastfetch_hash,
3081 Info => "dgit client's archive history view",
3084 my $dsc_mergeinput = $dsc_hash && {
3085 Commit => $dsc_hash,
3086 Info => "Dgit field in .dsc from archive",
3090 my $del_lrfetchrefs = sub {
3093 printdebug "del_lrfetchrefs...\n";
3094 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3095 my $objid = $lrfetchrefs_d{$fullrefname};
3096 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3098 $gur ||= new IO::Handle;
3099 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3101 printf $gur "delete %s %s\n", $fullrefname, $objid;
3104 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3108 if (defined $dsc_hash) {
3109 ensure_we_have_orig();
3110 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3111 @mergeinputs = $dsc_mergeinput
3112 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3113 print STDERR <<END or die $!;
3115 Git commit in archive is behind the last version allegedly pushed/uploaded.
3116 Commit referred to by archive: $dsc_hash
3117 Last version pushed with dgit: $lastpush_hash
3120 @mergeinputs = ($lastpush_mergeinput);
3122 # Archive has .dsc which is not a descendant of the last dgit
3123 # push. This can happen if the archive moves .dscs about.
3124 # Just follow its lead.
3125 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3126 progress "archive .dsc names newer git commit";
3127 @mergeinputs = ($dsc_mergeinput);
3129 progress "archive .dsc names other git commit, fixing up";
3130 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3134 @mergeinputs = generate_commits_from_dsc();
3135 # We have just done an import. Now, our import algorithm might
3136 # have been improved. But even so we do not want to generate
3137 # a new different import of the same package. So if the
3138 # version numbers are the same, just use our existing version.
3139 # If the version numbers are different, the archive has changed
3140 # (perhaps, rewound).
3141 if ($lastfetch_mergeinput &&
3142 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3143 (mergeinfo_version $mergeinputs[0]) )) {
3144 @mergeinputs = ($lastfetch_mergeinput);
3146 } elsif ($lastpush_hash) {
3147 # only in git, not in the archive yet
3148 @mergeinputs = ($lastpush_mergeinput);
3149 print STDERR <<END or die $!;
3151 Package not found in the archive, but has allegedly been pushed using dgit.
3155 printdebug "nothing found!\n";
3156 if (defined $skew_warning_vsn) {
3157 print STDERR <<END or die $!;
3159 Warning: relevant archive skew detected.
3160 Archive allegedly contains $skew_warning_vsn
3161 But we were not able to obtain any version from the archive or git.
3165 unshift @end, $del_lrfetchrefs;
3169 if ($lastfetch_hash &&
3171 my $h = $_->{Commit};
3172 $h and is_fast_fwd($lastfetch_hash, $h);
3173 # If true, one of the existing parents of this commit
3174 # is a descendant of the $lastfetch_hash, so we'll
3175 # be ff from that automatically.
3179 push @mergeinputs, $lastfetch_mergeinput;
3182 printdebug "fetch mergeinfos:\n";
3183 foreach my $mi (@mergeinputs) {
3185 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3187 printdebug sprintf " ReverseParents=%d Message=%s",
3188 $mi->{ReverseParents}, $mi->{Message};
3192 my $compat_info= pop @mergeinputs
3193 if $mergeinputs[$#mergeinputs]{Message};
3195 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3198 if (@mergeinputs > 1) {
3200 my $tree_commit = $mergeinputs[0]{Commit};
3202 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3203 $tree =~ m/\n\n/; $tree = $`;
3204 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3207 # We use the changelog author of the package in question the
3208 # author of this pseudo-merge. This is (roughly) correct if
3209 # this commit is simply representing aa non-dgit upload.
3210 # (Roughly because it does not record sponsorship - but we
3211 # don't have sponsorship info because that's in the .changes,
3212 # which isn't in the archivw.)
3214 # But, it might be that we are representing archive history
3215 # updates (including in-archive copies). These are not really
3216 # the responsibility of the person who created the .dsc, but
3217 # there is no-one whose name we should better use. (The
3218 # author of the .dsc-named commit is clearly worse.)
3220 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3221 my $author = clogp_authline $useclogp;
3222 my $cversion = getfield $useclogp, 'Version';
3224 my $mcf = dgit_privdir()."/mergecommit";
3225 open MC, ">", $mcf or die "$mcf $!";
3226 print MC <<END or die $!;
3230 my @parents = grep { $_->{Commit} } @mergeinputs;
3231 @parents = reverse @parents if $compat_info->{ReverseParents};
3232 print MC <<END or die $! foreach @parents;
3236 print MC <<END or die $!;
3242 if (defined $compat_info->{Message}) {
3243 print MC $compat_info->{Message} or die $!;
3245 print MC <<END or die $!;
3246 Record $package ($cversion) in archive suite $csuite
3250 my $message_add_info = sub {
3252 my $mversion = mergeinfo_version $mi;
3253 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3257 $message_add_info->($mergeinputs[0]);
3258 print MC <<END or die $!;
3259 should be treated as descended from
3261 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3265 $hash = make_commit $mcf;
3267 $hash = $mergeinputs[0]{Commit};
3269 printdebug "fetch hash=$hash\n";
3272 my ($lasth, $what) = @_;
3273 return unless $lasth;
3274 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3277 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3279 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3281 fetch_from_archive_record_1($hash);
3283 if (defined $skew_warning_vsn) {
3284 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3285 my $gotclogp = commit_getclogp($hash);
3286 my $got_vsn = getfield $gotclogp, 'Version';
3287 printdebug "SKEW CHECK GOT $got_vsn\n";
3288 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3289 print STDERR <<END or die $!;
3291 Warning: archive skew detected. Using the available version:
3292 Archive allegedly contains $skew_warning_vsn
3293 We were able to obtain only $got_vsn
3299 if ($lastfetch_hash ne $hash) {
3300 fetch_from_archive_record_2($hash);
3303 lrfetchref_used lrfetchref();
3305 check_gitattrs($hash, "fetched source tree");
3307 unshift @end, $del_lrfetchrefs;
3311 sub set_local_git_config ($$) {
3313 runcmd @git, qw(config), $k, $v;
3316 sub setup_mergechangelogs (;$) {
3318 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3320 my $driver = 'dpkg-mergechangelogs';
3321 my $cb = "merge.$driver";
3322 confess unless defined $maindir;
3323 my $attrs = "$maindir_gitcommon/info/attributes";
3324 ensuredir "$maindir_gitcommon/info";
3326 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3327 if (!open ATTRS, "<", $attrs) {
3328 $!==ENOENT or die "$attrs: $!";
3332 next if m{^debian/changelog\s};
3333 print NATTRS $_, "\n" or die $!;
3335 ATTRS->error and die $!;
3338 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3341 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3342 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3344 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3347 sub setup_useremail (;$) {
3349 return unless $always || access_cfg_bool(1, 'setup-useremail');
3352 my ($k, $envvar) = @_;
3353 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3354 return unless defined $v;
3355 set_local_git_config "user.$k", $v;
3358 $setup->('email', 'DEBEMAIL');
3359 $setup->('name', 'DEBFULLNAME');
3362 sub ensure_setup_existing_tree () {
3363 my $k = "remote.$remotename.skipdefaultupdate";
3364 my $c = git_get_config $k;
3365 return if defined $c;
3366 set_local_git_config $k, 'true';
3369 sub open_main_gitattrs () {
3370 confess 'internal error no maindir' unless defined $maindir;
3371 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3373 or die "open $maindir_gitcommon/info/attributes: $!";
3377 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3379 sub is_gitattrs_setup () {
3382 # 1: gitattributes set up and should be left alone
3384 # 0: there is a dgit-defuse-attrs but it needs fixing
3385 # undef: there is none
3386 my $gai = open_main_gitattrs();
3387 return 0 unless $gai;
3389 next unless m{$gitattrs_ourmacro_re};
3390 return 1 if m{\s-working-tree-encoding\s};
3391 printdebug "is_gitattrs_setup: found old macro\n";
3394 $gai->error and die $!;
3395 printdebug "is_gitattrs_setup: found nothing\n";
3399 sub setup_gitattrs (;$) {
3401 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3403 my $already = is_gitattrs_setup();
3406 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3407 not doing further gitattributes setup
3411 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3412 my $af = "$maindir_gitcommon/info/attributes";
3413 ensuredir "$maindir_gitcommon/info";
3415 open GAO, "> $af.new" or die $!;
3416 print GAO <<END or die $! unless defined $already;
3419 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3421 my $gai = open_main_gitattrs();
3424 if (m{$gitattrs_ourmacro_re}) {
3425 die unless defined $already;
3429 print GAO $_, "\n" or die $!;
3431 $gai->error and die $!;
3433 close GAO or die $!;
3434 rename "$af.new", "$af" or die "install $af: $!";
3437 sub setup_new_tree () {
3438 setup_mergechangelogs();
3443 sub check_gitattrs ($$) {
3444 my ($treeish, $what) = @_;
3446 return if is_gitattrs_setup;
3449 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3451 my $gafl = new IO::File;
3452 open $gafl, "-|", @cmd or die $!;
3455 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3457 next unless m{(?:^|/)\.gitattributes$};
3459 # oh dear, found one
3461 dgit: warning: $what contains .gitattributes
3462 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3467 # tree contains no .gitattributes files
3468 $?=0; $!=0; close $gafl or failedcmd @cmd;
3472 sub multisuite_suite_child ($$$) {
3473 my ($tsuite, $merginputs, $fn) = @_;
3474 # in child, sets things up, calls $fn->(), and returns undef
3475 # in parent, returns canonical suite name for $tsuite
3476 my $canonsuitefh = IO::File::new_tmpfile;
3477 my $pid = fork // die $!;
3481 $us .= " [$isuite]";
3482 $debugprefix .= " ";
3483 progress "fetching $tsuite...";
3484 canonicalise_suite();
3485 print $canonsuitefh $csuite, "\n" or die $!;
3486 close $canonsuitefh or die $!;
3490 waitpid $pid,0 == $pid or die $!;
3491 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3492 seek $canonsuitefh,0,0 or die $!;
3493 local $csuite = <$canonsuitefh>;
3494 die $! unless defined $csuite && chomp $csuite;
3496 printdebug "multisuite $tsuite missing\n";
3499 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3500 push @$merginputs, {
3507 sub fork_for_multisuite ($) {
3508 my ($before_fetch_merge) = @_;
3509 # if nothing unusual, just returns ''
3512 # returns 0 to caller in child, to do first of the specified suites
3513 # in child, $csuite is not yet set
3515 # returns 1 to caller in parent, to finish up anything needed after
3516 # in parent, $csuite is set to canonicalised portmanteau
3518 my $org_isuite = $isuite;
3519 my @suites = split /\,/, $isuite;
3520 return '' unless @suites > 1;
3521 printdebug "fork_for_multisuite: @suites\n";
3525 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3527 return 0 unless defined $cbasesuite;
3529 fail "package $package missing in (base suite) $cbasesuite"
3530 unless @mergeinputs;
3532 my @csuites = ($cbasesuite);
3534 $before_fetch_merge->();
3536 foreach my $tsuite (@suites[1..$#suites]) {
3537 $tsuite =~ s/^-/$cbasesuite-/;
3538 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3544 # xxx collecte the ref here
3546 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3547 push @csuites, $csubsuite;
3550 foreach my $mi (@mergeinputs) {
3551 my $ref = git_get_ref $mi->{Ref};
3552 die "$mi->{Ref} ?" unless length $ref;
3553 $mi->{Commit} = $ref;
3556 $csuite = join ",", @csuites;
3558 my $previous = git_get_ref lrref;
3560 unshift @mergeinputs, {
3561 Commit => $previous,
3562 Info => "local combined tracking branch",
3564 "archive seems to have rewound: local tracking branch is ahead!",
3568 foreach my $ix (0..$#mergeinputs) {
3569 $mergeinputs[$ix]{Index} = $ix;
3572 @mergeinputs = sort {
3573 -version_compare(mergeinfo_version $a,
3574 mergeinfo_version $b) # highest version first
3576 $a->{Index} <=> $b->{Index}; # earliest in spec first
3582 foreach my $mi (@mergeinputs) {
3583 printdebug "multisuite merge check $mi->{Info}\n";
3584 foreach my $previous (@needed) {
3585 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3586 printdebug "multisuite merge un-needed $previous->{Info}\n";
3590 printdebug "multisuite merge this-needed\n";
3591 $mi->{Character} = '+';
3594 $needed[0]{Character} = '*';
3596 my $output = $needed[0]{Commit};
3599 printdebug "multisuite merge nontrivial\n";
3600 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3602 my $commit = "tree $tree\n";
3603 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3604 "Input branches:\n";
3606 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3607 printdebug "multisuite merge include $mi->{Info}\n";
3608 $mi->{Character} //= ' ';
3609 $commit .= "parent $mi->{Commit}\n";
3610 $msg .= sprintf " %s %-25s %s\n",
3612 (mergeinfo_version $mi),
3615 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3617 " * marks the highest version branch, which choose to use\n".
3618 " + marks each branch which was not already an ancestor\n\n".
3619 "[dgit multi-suite $csuite]\n";
3621 "author $authline\n".
3622 "committer $authline\n\n";
3623 $output = make_commit_text $commit.$msg;
3624 printdebug "multisuite merge generated $output\n";
3627 fetch_from_archive_record_1($output);
3628 fetch_from_archive_record_2($output);
3630 progress "calculated combined tracking suite $csuite";
3635 sub clone_set_head () {
3636 open H, "> .git/HEAD" or die $!;
3637 print H "ref: ".lref()."\n" or die $!;
3640 sub clone_finish ($) {
3642 runcmd @git, qw(reset --hard), lrref();
3643 runcmd qw(bash -ec), <<'END';
3645 git ls-tree -r --name-only -z HEAD | \
3646 xargs -0r touch -h -r . --
3648 printdone "ready for work in $dstdir";
3652 # in multisuite, returns twice!
3653 # once in parent after first suite fetched,
3654 # and then again in child after everything is finished
3656 badusage "dry run makes no sense with clone" unless act_local();
3658 my $multi_fetched = fork_for_multisuite(sub {
3659 printdebug "multi clone before fetch merge\n";
3663 if ($multi_fetched) {
3664 printdebug "multi clone after fetch merge\n";
3666 clone_finish($dstdir);
3669 printdebug "clone main body\n";
3671 canonicalise_suite();
3672 my $hasgit = check_for_git();
3673 mkdir $dstdir or fail "create \`$dstdir': $!";
3675 runcmd @git, qw(init -q);
3679 my $giturl = access_giturl(1);
3680 if (defined $giturl) {
3681 runcmd @git, qw(remote add), 'origin', $giturl;
3684 progress "fetching existing git history";
3686 runcmd_ordryrun_local @git, qw(fetch origin);
3688 progress "starting new git history";
3690 fetch_from_archive() or no_such_package;
3691 my $vcsgiturl = $dsc->{'Vcs-Git'};
3692 if (length $vcsgiturl) {
3693 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3694 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3696 clone_finish($dstdir);
3700 canonicalise_suite();
3701 if (check_for_git()) {
3704 fetch_from_archive() or no_such_package();
3706 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3707 if (length $vcsgiturl and
3708 (grep { $csuite eq $_ }
3710 cfg 'dgit.vcs-git.suites')) {
3711 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3712 if (defined $current && $current ne $vcsgiturl) {
3714 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3715 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3719 printdone "fetched into ".lrref();
3723 my $multi_fetched = fork_for_multisuite(sub { });
3724 fetch_one() unless $multi_fetched; # parent
3725 finish 0 if $multi_fetched eq '0'; # child
3730 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3732 printdone "fetched to ".lrref()." and merged into HEAD";
3735 sub check_not_dirty () {
3736 foreach my $f (qw(local-options local-patch-header)) {
3737 if (stat_exists "debian/source/$f") {
3738 fail "git tree contains debian/source/$f";
3742 return if $includedirty;
3744 git_check_unmodified();
3747 sub commit_admin ($) {
3750 runcmd_ordryrun_local @git, qw(commit -m), $m;
3753 sub quiltify_nofix_bail ($$) {
3754 my ($headinfo, $xinfo) = @_;
3755 if ($quilt_mode eq 'nofix') {
3756 fail "quilt fixup required but quilt mode is \`nofix'\n".
3757 "HEAD commit".$headinfo." differs from tree implied by ".
3758 " debian/patches".$xinfo;
3762 sub commit_quilty_patch () {
3763 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3765 foreach my $l (split /\n/, $output) {
3766 next unless $l =~ m/\S/;
3767 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3771 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3773 progress "nothing quilty to commit, ok.";
3776 quiltify_nofix_bail "", " (wanted to commit patch update)";
3777 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3778 runcmd_ordryrun_local @git, qw(add -f), @adds;
3780 Commit Debian 3.0 (quilt) metadata
3782 [dgit ($our_version) quilt-fixup]
3786 sub get_source_format () {
3788 if (open F, "debian/source/options") {
3792 s/\s+$//; # ignore missing final newline
3794 my ($k, $v) = ($`, $'); #');
3795 $v =~ s/^"(.*)"$/$1/;
3801 F->error and die $!;
3804 die $! unless $!==&ENOENT;
3807 if (!open F, "debian/source/format") {
3808 die $! unless $!==&ENOENT;
3812 F->error and die $!;
3814 return ($_, \%options);
3817 sub madformat_wantfixup ($) {
3819 return 0 unless $format eq '3.0 (quilt)';
3820 our $quilt_mode_warned;
3821 if ($quilt_mode eq 'nocheck') {
3822 progress "Not doing any fixup of \`$format' due to".
3823 " ----no-quilt-fixup or --quilt=nocheck"
3824 unless $quilt_mode_warned++;
3827 progress "Format \`$format', need to check/update patch stack"
3828 unless $quilt_mode_warned++;
3832 sub maybe_split_brain_save ($$$) {
3833 my ($headref, $dgitview, $msg) = @_;
3834 # => message fragment "$saved" describing disposition of $dgitview
3835 return "commit id $dgitview" unless defined $split_brain_save;
3836 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3838 "dgit --dgit-view-save $msg HEAD=$headref",
3839 $split_brain_save, $dgitview);
3841 return "and left in $split_brain_save";
3844 # An "infopair" is a tuple [ $thing, $what ]
3845 # (often $thing is a commit hash; $what is a description)
3847 sub infopair_cond_equal ($$) {
3849 $x->[0] eq $y->[0] or fail <<END;
3850 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3854 sub infopair_lrf_tag_lookup ($$) {
3855 my ($tagnames, $what) = @_;
3856 # $tagname may be an array ref
3857 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3858 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3859 foreach my $tagname (@tagnames) {
3860 my $lrefname = lrfetchrefs."/tags/$tagname";
3861 my $tagobj = $lrfetchrefs_f{$lrefname};
3862 next unless defined $tagobj;
3863 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3864 return [ git_rev_parse($tagobj), $what ];
3866 fail @tagnames==1 ? <<END : <<END;
3867 Wanted tag $what (@tagnames) on dgit server, but not found
3869 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3873 sub infopair_cond_ff ($$) {
3874 my ($anc,$desc) = @_;
3875 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3876 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3880 sub pseudomerge_version_check ($$) {
3881 my ($clogp, $archive_hash) = @_;
3883 my $arch_clogp = commit_getclogp $archive_hash;
3884 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3885 'version currently in archive' ];
3886 if (defined $overwrite_version) {
3887 if (length $overwrite_version) {
3888 infopair_cond_equal([ $overwrite_version,
3889 '--overwrite= version' ],
3892 my $v = $i_arch_v->[0];
3893 progress "Checking package changelog for archive version $v ...";
3896 my @xa = ("-f$v", "-t$v");
3897 my $vclogp = parsechangelog @xa;
3900 [ (getfield $vclogp, $fn),
3901 "$fn field from dpkg-parsechangelog @xa" ];
3903 my $cv = $gf->('Version');
3904 infopair_cond_equal($i_arch_v, $cv);
3905 $cd = $gf->('Distribution');
3908 $@ =~ s/^dgit: //gm;
3910 "Perhaps debian/changelog does not mention $v ?";
3912 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3913 $cd->[1] is $cd->[0]
3914 Your tree seems to based on earlier (not uploaded) $v.
3919 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3923 sub pseudomerge_make_commit ($$$$ $$) {
3924 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3925 $msg_cmd, $msg_msg) = @_;
3926 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3928 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3929 my $authline = clogp_authline $clogp;
3933 !defined $overwrite_version ? ""
3934 : !length $overwrite_version ? " --overwrite"
3935 : " --overwrite=".$overwrite_version;
3937 # Contributing parent is the first parent - that makes
3938 # git rev-list --first-parent DTRT.
3939 my $pmf = dgit_privdir()."/pseudomerge";
3940 open MC, ">", $pmf or die "$pmf $!";
3941 print MC <<END or die $!;
3944 parent $archive_hash
3954 return make_commit($pmf);
3957 sub splitbrain_pseudomerge ($$$$) {
3958 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3959 # => $merged_dgitview
3960 printdebug "splitbrain_pseudomerge...\n";
3962 # We: debian/PREVIOUS HEAD($maintview)
3963 # expect: o ----------------- o
3966 # a/d/PREVIOUS $dgitview
3969 # we do: `------------------ o
3973 return $dgitview unless defined $archive_hash;
3974 return $dgitview if deliberately_not_fast_forward();
3976 printdebug "splitbrain_pseudomerge...\n";
3978 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3980 if (!defined $overwrite_version) {
3981 progress "Checking that HEAD inciudes all changes in archive...";
3984 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3986 if (defined $overwrite_version) {
3988 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3989 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3990 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3991 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3992 my $i_archive = [ $archive_hash, "current archive contents" ];
3994 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3996 infopair_cond_equal($i_dgit, $i_archive);
3997 infopair_cond_ff($i_dep14, $i_dgit);
3998 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4001 $@ =~ s/^\n//; chomp $@;
4004 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4009 my $r = pseudomerge_make_commit
4010 $clogp, $dgitview, $archive_hash, $i_arch_v,
4011 "dgit --quilt=$quilt_mode",
4012 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4013 Declare fast forward from $i_arch_v->[0]
4015 Make fast forward from $i_arch_v->[0]
4018 maybe_split_brain_save $maintview, $r, "pseudomerge";
4020 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4024 sub plain_overwrite_pseudomerge ($$$) {
4025 my ($clogp, $head, $archive_hash) = @_;
4027 printdebug "plain_overwrite_pseudomerge...";
4029 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4031 return $head if is_fast_fwd $archive_hash, $head;
4033 my $m = "Declare fast forward from $i_arch_v->[0]";
4035 my $r = pseudomerge_make_commit
4036 $clogp, $head, $archive_hash, $i_arch_v,
4039 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4041 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4045 sub push_parse_changelog ($) {
4048 my $clogp = Dpkg::Control::Hash->new();
4049 $clogp->load($clogpfn) or die;
4051 my $clogpackage = getfield $clogp, 'Source';
4052 $package //= $clogpackage;
4053 fail "-p specified $package but changelog specified $clogpackage"
4054 unless $package eq $clogpackage;
4055 my $cversion = getfield $clogp, 'Version';
4057 if (!$we_are_initiator) {
4058 # rpush initiator can't do this because it doesn't have $isuite yet
4059 my $tag = debiantag($cversion, access_nomdistro);
4060 runcmd @git, qw(check-ref-format), $tag;
4063 my $dscfn = dscfn($cversion);
4065 return ($clogp, $cversion, $dscfn);
4068 sub push_parse_dsc ($$$) {
4069 my ($dscfn,$dscfnwhat, $cversion) = @_;
4070 $dsc = parsecontrol($dscfn,$dscfnwhat);
4071 my $dversion = getfield $dsc, 'Version';
4072 my $dscpackage = getfield $dsc, 'Source';
4073 ($dscpackage eq $package && $dversion eq $cversion) or
4074 fail "$dscfn is for $dscpackage $dversion".
4075 " but debian/changelog is for $package $cversion";
4078 sub push_tagwants ($$$$) {
4079 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4082 TagFn => \&debiantag,
4087 if (defined $maintviewhead) {
4089 TagFn => \&debiantag_maintview,
4090 Objid => $maintviewhead,
4091 TfSuffix => '-maintview',
4094 } elsif ($dodep14tag eq 'no' ? 0
4095 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4096 : $dodep14tag eq 'always'
4097 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4098 --dep14tag-always (or equivalent in config) means server must support
4099 both "new" and "maint" tag formats, but config says it doesn't.
4101 : die "$dodep14tag ?") {
4103 TagFn => \&debiantag_maintview,
4105 TfSuffix => '-dgit',
4109 foreach my $tw (@tagwants) {
4110 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4111 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4113 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4117 sub push_mktags ($$ $$ $) {
4119 $changesfile,$changesfilewhat,
4122 die unless $tagwants->[0]{View} eq 'dgit';
4124 my $declaredistro = access_nomdistro();
4125 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4126 $dsc->{$ourdscfield[0]} = join " ",
4127 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4129 $dsc->save("$dscfn.tmp") or die $!;
4131 my $changes = parsecontrol($changesfile,$changesfilewhat);
4132 foreach my $field (qw(Source Distribution Version)) {
4133 $changes->{$field} eq $clogp->{$field} or
4134 fail "changes field $field \`$changes->{$field}'".
4135 " does not match changelog \`$clogp->{$field}'";
4138 my $cversion = getfield $clogp, 'Version';
4139 my $clogsuite = getfield $clogp, 'Distribution';
4141 # We make the git tag by hand because (a) that makes it easier
4142 # to control the "tagger" (b) we can do remote signing
4143 my $authline = clogp_authline $clogp;
4144 my $delibs = join(" ", "",@deliberatelies);
4148 my $tfn = $tw->{Tfn};
4149 my $head = $tw->{Objid};
4150 my $tag = $tw->{Tag};
4152 open TO, '>', $tfn->('.tmp') or die $!;
4153 print TO <<END or die $!;
4160 if ($tw->{View} eq 'dgit') {
4161 print TO <<END or die $!;
4162 $package release $cversion for $clogsuite ($csuite) [dgit]
4163 [dgit distro=$declaredistro$delibs]
4165 foreach my $ref (sort keys %previously) {
4166 print TO <<END or die $!;
4167 [dgit previously:$ref=$previously{$ref}]
4170 } elsif ($tw->{View} eq 'maint') {
4171 print TO <<END or die $!;
4172 $package release $cversion for $clogsuite ($csuite)
4173 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4176 die Dumper($tw)."?";
4181 my $tagobjfn = $tfn->('.tmp');
4183 if (!defined $keyid) {
4184 $keyid = access_cfg('keyid','RETURN-UNDEF');
4186 if (!defined $keyid) {
4187 $keyid = getfield $clogp, 'Maintainer';
4189 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4190 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4191 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4192 push @sign_cmd, $tfn->('.tmp');
4193 runcmd_ordryrun @sign_cmd;
4195 $tagobjfn = $tfn->('.signed.tmp');
4196 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4197 $tfn->('.tmp'), $tfn->('.tmp.asc');
4203 my @r = map { $mktag->($_); } @$tagwants;
4207 sub sign_changes ($) {
4208 my ($changesfile) = @_;
4210 my @debsign_cmd = @debsign;
4211 push @debsign_cmd, "-k$keyid" if defined $keyid;
4212 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4213 push @debsign_cmd, $changesfile;
4214 runcmd_ordryrun @debsign_cmd;
4219 printdebug "actually entering push\n";
4221 supplementary_message(<<'END');
4222 Push failed, while checking state of the archive.
4223 You can retry the push, after fixing the problem, if you like.
4225 if (check_for_git()) {
4228 my $archive_hash = fetch_from_archive();
4229 if (!$archive_hash) {
4231 fail "package appears to be new in this suite;".
4232 " if this is intentional, use --new";
4235 supplementary_message(<<'END');
4236 Push failed, while preparing your push.
4237 You can retry the push, after fixing the problem, if you like.
4240 need_tagformat 'new', "quilt mode $quilt_mode"
4241 if quiltmode_splitbrain;
4245 access_giturl(); # check that success is vaguely likely
4246 rpush_handle_protovsn_bothends() if $we_are_initiator;
4249 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4250 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4252 responder_send_file('parsed-changelog', $clogpfn);
4254 my ($clogp, $cversion, $dscfn) =
4255 push_parse_changelog("$clogpfn");
4257 my $dscpath = "$buildproductsdir/$dscfn";
4258 stat_exists $dscpath or
4259 fail "looked for .dsc $dscpath, but $!;".
4260 " maybe you forgot to build";
4262 responder_send_file('dsc', $dscpath);
4264 push_parse_dsc($dscpath, $dscfn, $cversion);
4266 my $format = getfield $dsc, 'Format';
4267 printdebug "format $format\n";
4269 my $symref = git_get_symref();
4270 my $actualhead = git_rev_parse('HEAD');
4272 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4273 runcmd_ordryrun_local @git_debrebase, 'stitch';
4274 $actualhead = git_rev_parse('HEAD');
4277 my $dgithead = $actualhead;
4278 my $maintviewhead = undef;
4280 my $upstreamversion = upstreamversion $clogp->{Version};
4282 if (madformat_wantfixup($format)) {
4283 # user might have not used dgit build, so maybe do this now:
4284 if (quiltmode_splitbrain()) {
4285 changedir $playground;
4286 quilt_make_fake_dsc($upstreamversion);
4288 ($dgithead, $cachekey) =
4289 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4291 "--quilt=$quilt_mode but no cached dgit view:
4292 perhaps HEAD changed since dgit build[-source] ?";
4294 $dgithead = splitbrain_pseudomerge($clogp,
4295 $actualhead, $dgithead,
4297 $maintviewhead = $actualhead;
4299 prep_ud(); # so _only_subdir() works, below
4301 commit_quilty_patch();
4305 if (defined $overwrite_version && !defined $maintviewhead
4307 $dgithead = plain_overwrite_pseudomerge($clogp,
4315 if ($archive_hash) {
4316 if (is_fast_fwd($archive_hash, $dgithead)) {
4318 } elsif (deliberately_not_fast_forward) {
4321 fail "dgit push: HEAD is not a descendant".
4322 " of the archive's version.\n".
4323 "To overwrite the archive's contents,".
4324 " pass --overwrite[=VERSION].\n".
4325 "To rewind history, if permitted by the archive,".
4326 " use --deliberately-not-fast-forward.";
4330 changedir $playground;
4331 progress "checking that $dscfn corresponds to HEAD";
4332 runcmd qw(dpkg-source -x --),
4333 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4334 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4335 check_for_vendor_patches() if madformat($dsc->{format});
4337 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4338 debugcmd "+",@diffcmd;
4340 my $r = system @diffcmd;
4343 my $referent = $split_brain ? $dgithead : 'HEAD';
4344 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4347 my $raw = cmdoutput @git,
4348 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4350 foreach (split /\0/, $raw) {
4351 if (defined $changed) {
4352 push @mode_changes, "$changed: $_\n" if $changed;
4355 } elsif (m/^:0+ 0+ /) {
4357 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4358 $changed = "Mode change from $1 to $2"
4363 if (@mode_changes) {
4364 fail <<END.(join '', @mode_changes).<<END;
4365 HEAD specifies a different tree to $dscfn:
4368 There is a problem with your source tree (see dgit(7) for some hints).
4369 To see a full diff, run git diff $tree $referent
4374 HEAD specifies a different tree to $dscfn:
4376 Perhaps you forgot to build. Or perhaps there is a problem with your
4377 source tree (see dgit(7) for some hints). To see a full diff, run
4378 git diff $tree $referent
4384 if (!$changesfile) {
4385 my $pat = changespat $cversion;
4386 my @cs = glob "$buildproductsdir/$pat";
4387 fail "failed to find unique changes file".
4388 " (looked for $pat in $buildproductsdir);".
4389 " perhaps you need to use dgit -C"
4391 ($changesfile) = @cs;
4393 $changesfile = "$buildproductsdir/$changesfile";
4396 # Check that changes and .dsc agree enough
4397 $changesfile =~ m{[^/]*$};
4398 my $changes = parsecontrol($changesfile,$&);
4399 files_compare_inputs($dsc, $changes)
4400 unless forceing [qw(dsc-changes-mismatch)];
4402 # Check whether this is a source only upload
4403 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4404 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4405 if ($sourceonlypolicy eq 'ok') {
4406 } elsif ($sourceonlypolicy eq 'always') {
4407 forceable_fail [qw(uploading-binaries)],
4408 "uploading binaries, although distroy policy is source only"
4410 } elsif ($sourceonlypolicy eq 'never') {
4411 forceable_fail [qw(uploading-source-only)],
4412 "source-only upload, although distroy policy requires .debs"
4414 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4415 forceable_fail [qw(uploading-source-only)],
4416 "source-only upload, even though package is entirely NEW\n".
4417 "(this is contrary to policy in ".(access_nomdistro()).")"
4420 && !(archive_query('package_not_wholly_new', $package) // 1);
4422 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4425 # Perhaps adjust .dsc to contain right set of origs
4426 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4428 unless forceing [qw(changes-origs-exactly)];
4430 # Checks complete, we're going to try and go ahead:
4432 responder_send_file('changes',$changesfile);
4433 responder_send_command("param head $dgithead");
4434 responder_send_command("param csuite $csuite");
4435 responder_send_command("param isuite $isuite");
4436 responder_send_command("param tagformat $tagformat");
4437 if (defined $maintviewhead) {
4438 die unless ($protovsn//4) >= 4;
4439 responder_send_command("param maint-view $maintviewhead");
4442 # Perhaps send buildinfo(s) for signing
4443 my $changes_files = getfield $changes, 'Files';
4444 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4445 foreach my $bi (@buildinfos) {
4446 responder_send_command("param buildinfo-filename $bi");
4447 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4450 if (deliberately_not_fast_forward) {
4451 git_for_each_ref(lrfetchrefs, sub {
4452 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4453 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4454 responder_send_command("previously $rrefname=$objid");
4455 $previously{$rrefname} = $objid;
4459 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4460 dgit_privdir()."/tag");
4463 supplementary_message(<<'END');
4464 Push failed, while signing the tag.
4465 You can retry the push, after fixing the problem, if you like.
4467 # If we manage to sign but fail to record it anywhere, it's fine.
4468 if ($we_are_responder) {
4469 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4470 responder_receive_files('signed-tag', @tagobjfns);
4472 @tagobjfns = push_mktags($clogp,$dscpath,
4473 $changesfile,$changesfile,
4476 supplementary_message(<<'END');
4477 Push failed, *after* signing the tag.
4478 If you want to try again, you should use a new version number.
4481 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4483 foreach my $tw (@tagwants) {
4484 my $tag = $tw->{Tag};
4485 my $tagobjfn = $tw->{TagObjFn};
4487 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4488 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4489 runcmd_ordryrun_local
4490 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4493 supplementary_message(<<'END');
4494 Push failed, while updating the remote git repository - see messages above.
4495 If you want to try again, you should use a new version number.
4497 if (!check_for_git()) {
4498 create_remote_git_repo();
4501 my @pushrefs = $forceflag.$dgithead.":".rrref();
4502 foreach my $tw (@tagwants) {
4503 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4506 runcmd_ordryrun @git,
4507 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4508 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4510 supplementary_message(<<'END');
4511 Push failed, while obtaining signatures on the .changes and .dsc.
4512 If it was just that the signature failed, you may try again by using
4513 debsign by hand to sign the changes
4515 and then dput to complete the upload.
4516 If you need to change the package, you must use a new version number.
4518 if ($we_are_responder) {
4519 my $dryrunsuffix = act_local() ? "" : ".tmp";
4520 my @rfiles = ($dscpath, $changesfile);
4521 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4522 responder_receive_files('signed-dsc-changes',
4523 map { "$_$dryrunsuffix" } @rfiles);
4526 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4528 progress "[new .dsc left in $dscpath.tmp]";
4530 sign_changes $changesfile;
4533 supplementary_message(<<END);
4534 Push failed, while uploading package(s) to the archive server.
4535 You can retry the upload of exactly these same files with dput of:
4537 If that .changes file is broken, you will need to use a new version
4538 number for your next attempt at the upload.
4540 my $host = access_cfg('upload-host','RETURN-UNDEF');
4541 my @hostarg = defined($host) ? ($host,) : ();
4542 runcmd_ordryrun @dput, @hostarg, $changesfile;
4543 printdone "pushed and uploaded $cversion";
4545 supplementary_message('');
4546 responder_send_command("complete");
4550 not_necessarily_a_tree();
4555 badusage "-p is not allowed with clone; specify as argument instead"
4556 if defined $package;
4559 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4560 ($package,$isuite) = @ARGV;
4561 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4562 ($package,$dstdir) = @ARGV;
4563 } elsif (@ARGV==3) {
4564 ($package,$isuite,$dstdir) = @ARGV;
4566 badusage "incorrect arguments to dgit clone";
4570 $dstdir ||= "$package";
4571 if (stat_exists $dstdir) {
4572 fail "$dstdir already exists";
4576 if ($rmonerror && !$dryrun_level) {
4577 $cwd_remove= getcwd();
4579 return unless defined $cwd_remove;
4580 if (!chdir "$cwd_remove") {
4581 return if $!==&ENOENT;
4582 die "chdir $cwd_remove: $!";
4584 printdebug "clone rmonerror removing $dstdir\n";
4586 rmtree($dstdir) or die "remove $dstdir: $!\n";
4587 } elsif (grep { $! == $_ }
4588 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4590 print STDERR "check whether to remove $dstdir: $!\n";
4596 $cwd_remove = undef;
4599 sub branchsuite () {
4600 my $branch = git_get_symref();
4601 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4608 sub package_from_d_control () {
4609 if (!defined $package) {
4610 my $sourcep = parsecontrol('debian/control','debian/control');
4611 $package = getfield $sourcep, 'Source';
4615 sub fetchpullargs () {
4616 package_from_d_control();
4618 $isuite = branchsuite();
4620 my $clogp = parsechangelog();
4621 my $clogsuite = getfield $clogp, 'Distribution';
4622 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4624 } elsif (@ARGV==1) {
4627 badusage "incorrect arguments to dgit fetch or dgit pull";
4641 if (quiltmode_splitbrain()) {
4642 my ($format, $fopts) = get_source_format();
4643 madformat($format) and fail <<END
4644 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4652 package_from_d_control();
4653 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4657 foreach my $canon (qw(0 1)) {
4662 canonicalise_suite();
4664 if (length git_get_ref lref()) {
4665 # local branch already exists, yay
4668 if (!length git_get_ref lrref()) {
4676 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4679 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4680 "dgit checkout $isuite";
4681 runcmd (@git, qw(checkout), lbranch());
4684 sub cmd_update_vcs_git () {
4686 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4687 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4689 ($specsuite) = (@ARGV);
4694 if ($ARGV[0] eq '-') {
4696 } elsif ($ARGV[0] eq '-') {
4701 package_from_d_control();
4703 if ($specsuite eq '.') {
4704 $ctrl = parsecontrol 'debian/control', 'debian/control';
4706 $isuite = $specsuite;
4710 my $url = getfield $ctrl, 'Vcs-Git';
4713 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4714 if (!defined $orgurl) {
4715 print STDERR "setting up vcs-git: $url\n";
4716 @cmd = (@git, qw(remote add vcs-git), $url);
4717 } elsif ($orgurl eq $url) {
4718 print STDERR "vcs git already configured: $url\n";
4720 print STDERR "changing vcs-git url to: $url\n";
4721 @cmd = (@git, qw(remote set-url vcs-git), $url);
4723 runcmd_ordryrun_local @cmd;
4725 print "fetching (@ARGV)\n";
4726 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4732 build_or_push_prep_early();
4737 } elsif (@ARGV==1) {
4738 ($specsuite) = (@ARGV);
4740 badusage "incorrect arguments to dgit $subcommand";
4743 local ($package) = $existing_package; # this is a hack
4744 canonicalise_suite();
4746 canonicalise_suite();
4748 if (defined $specsuite &&
4749 $specsuite ne $isuite &&
4750 $specsuite ne $csuite) {
4751 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4752 " but command line specifies $specsuite";
4761 #---------- remote commands' implementation ----------
4763 sub pre_remote_push_build_host {
4764 my ($nrargs) = shift @ARGV;
4765 my (@rargs) = @ARGV[0..$nrargs-1];
4766 @ARGV = @ARGV[$nrargs..$#ARGV];
4768 my ($dir,$vsnwant) = @rargs;
4769 # vsnwant is a comma-separated list; we report which we have
4770 # chosen in our ready response (so other end can tell if they
4773 $we_are_responder = 1;
4774 $us .= " (build host)";
4776 open PI, "<&STDIN" or die $!;
4777 open STDIN, "/dev/null" or die $!;
4778 open PO, ">&STDOUT" or die $!;
4780 open STDOUT, ">&STDERR" or die $!;
4784 ($protovsn) = grep {
4785 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4786 } @rpushprotovsn_support;
4788 fail "build host has dgit rpush protocol versions ".
4789 (join ",", @rpushprotovsn_support).
4790 " but invocation host has $vsnwant"
4791 unless defined $protovsn;
4795 sub cmd_remote_push_build_host {
4796 responder_send_command("dgit-remote-push-ready $protovsn");
4800 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4801 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4802 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4803 # a good error message)
4805 sub rpush_handle_protovsn_bothends () {
4806 if ($protovsn < 4) {
4807 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4816 my $report = i_child_report();
4817 if (defined $report) {
4818 printdebug "($report)\n";
4819 } elsif ($i_child_pid) {
4820 printdebug "(killing build host child $i_child_pid)\n";
4821 kill 15, $i_child_pid;
4823 if (defined $i_tmp && !defined $initiator_tempdir) {
4825 eval { rmtree $i_tmp; };
4830 return unless forkcheck_mainprocess();
4835 my ($base,$selector,@args) = @_;
4836 $selector =~ s/\-/_/g;
4837 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4841 not_necessarily_a_tree();
4846 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4854 push @rargs, join ",", @rpushprotovsn_support;
4857 push @rdgit, @ropts;
4858 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4860 my @cmd = (@ssh, $host, shellquote @rdgit);
4863 $we_are_initiator=1;
4865 if (defined $initiator_tempdir) {
4866 rmtree $initiator_tempdir;
4867 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4868 $i_tmp = $initiator_tempdir;
4872 $i_child_pid = open2(\*RO, \*RI, @cmd);
4874 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4875 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4876 $supplementary_message = '' unless $protovsn >= 3;
4879 my ($icmd,$iargs) = initiator_expect {
4880 m/^(\S+)(?: (.*))?$/;
4883 i_method "i_resp", $icmd, $iargs;
4887 sub i_resp_progress ($) {
4889 my $msg = protocol_read_bytes \*RO, $rhs;
4893 sub i_resp_supplementary_message ($) {
4895 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4898 sub i_resp_complete {
4899 my $pid = $i_child_pid;
4900 $i_child_pid = undef; # prevents killing some other process with same pid
4901 printdebug "waiting for build host child $pid...\n";
4902 my $got = waitpid $pid, 0;
4903 die $! unless $got == $pid;
4904 die "build host child failed $?" if $?;
4907 printdebug "all done\n";
4911 sub i_resp_file ($) {
4913 my $localname = i_method "i_localname", $keyword;
4914 my $localpath = "$i_tmp/$localname";
4915 stat_exists $localpath and
4916 badproto \*RO, "file $keyword ($localpath) twice";
4917 protocol_receive_file \*RO, $localpath;
4918 i_method "i_file", $keyword;
4923 sub i_resp_param ($) {
4924 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4928 sub i_resp_previously ($) {
4929 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4930 or badproto \*RO, "bad previously spec";
4931 my $r = system qw(git check-ref-format), $1;
4932 die "bad previously ref spec ($r)" if $r;
4933 $previously{$1} = $2;
4938 sub i_resp_want ($) {
4940 die "$keyword ?" if $i_wanted{$keyword}++;
4942 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4943 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4944 die unless $isuite =~ m/^$suite_re$/;
4947 rpush_handle_protovsn_bothends();
4949 fail "rpush negotiated protocol version $protovsn".
4950 " which does not support quilt mode $quilt_mode"
4951 if quiltmode_splitbrain;
4953 my @localpaths = i_method "i_want", $keyword;
4954 printdebug "[[ $keyword @localpaths\n";
4955 foreach my $localpath (@localpaths) {
4956 protocol_send_file \*RI, $localpath;
4958 print RI "files-end\n" or die $!;
4961 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4963 sub i_localname_parsed_changelog {
4964 return "remote-changelog.822";
4966 sub i_file_parsed_changelog {
4967 ($i_clogp, $i_version, $i_dscfn) =
4968 push_parse_changelog "$i_tmp/remote-changelog.822";
4969 die if $i_dscfn =~ m#/|^\W#;
4972 sub i_localname_dsc {
4973 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4978 sub i_localname_buildinfo ($) {
4979 my $bi = $i_param{'buildinfo-filename'};
4980 defined $bi or badproto \*RO, "buildinfo before filename";
4981 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4982 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4983 or badproto \*RO, "improper buildinfo filename";
4986 sub i_file_buildinfo {
4987 my $bi = $i_param{'buildinfo-filename'};
4988 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4989 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4990 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4991 files_compare_inputs($bd, $ch);
4992 (getfield $bd, $_) eq (getfield $ch, $_) or
4993 fail "buildinfo mismatch $_"
4994 foreach qw(Source Version);
4995 !defined $bd->{$_} or
4996 fail "buildinfo contains $_"
4997 foreach qw(Changes Changed-by Distribution);
4999 push @i_buildinfos, $bi;
5000 delete $i_param{'buildinfo-filename'};
5003 sub i_localname_changes {
5004 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5005 $i_changesfn = $i_dscfn;
5006 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5007 return $i_changesfn;
5009 sub i_file_changes { }
5011 sub i_want_signed_tag {
5012 printdebug Dumper(\%i_param, $i_dscfn);
5013 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5014 && defined $i_param{'csuite'}
5015 or badproto \*RO, "premature desire for signed-tag";
5016 my $head = $i_param{'head'};
5017 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5019 my $maintview = $i_param{'maint-view'};
5020 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5023 if ($protovsn >= 4) {
5024 my $p = $i_param{'tagformat'} // '<undef>';
5026 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5029 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5031 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5033 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5036 push_mktags $i_clogp, $i_dscfn,
5037 $i_changesfn, 'remote changes',
5041 sub i_want_signed_dsc_changes {
5042 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5043 sign_changes $i_changesfn;
5044 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5047 #---------- building etc. ----------
5053 #----- `3.0 (quilt)' handling -----
5055 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5057 sub quiltify_dpkg_commit ($$$;$) {
5058 my ($patchname,$author,$msg, $xinfo) = @_;
5061 mkpath '.git/dgit'; # we are in playtree
5062 my $descfn = ".git/dgit/quilt-description.tmp";
5063 open O, '>', $descfn or die "$descfn: $!";
5064 $msg =~ s/\n+/\n\n/;
5065 print O <<END or die $!;
5067 ${xinfo}Subject: $msg
5074 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5075 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5076 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5077 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5081 sub quiltify_trees_differ ($$;$$$) {
5082 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5083 # returns true iff the two tree objects differ other than in debian/
5084 # with $finegrained,
5085 # returns bitmask 01 - differ in upstream files except .gitignore
5086 # 02 - differ in .gitignore
5087 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5088 # is set for each modified .gitignore filename $fn
5089 # if $unrepres is defined, array ref to which is appeneded
5090 # a list of unrepresentable changes (removals of upstream files
5093 my @cmd = (@git, qw(diff-tree -z --no-renames));
5094 push @cmd, qw(--name-only) unless $unrepres;
5095 push @cmd, qw(-r) if $finegrained || $unrepres;
5097 my $diffs= cmdoutput @cmd;
5100 foreach my $f (split /\0/, $diffs) {
5101 if ($unrepres && !@lmodes) {
5102 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5105 my ($oldmode,$newmode) = @lmodes;
5108 next if $f =~ m#^debian(?:/.*)?$#s;
5112 die "not a plain file or symlink\n"
5113 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5114 $oldmode =~ m/^(?:10|12)\d{4}$/;
5115 if ($oldmode =~ m/[^0]/ &&
5116 $newmode =~ m/[^0]/) {
5117 # both old and new files exist
5118 die "mode or type changed\n" if $oldmode ne $newmode;
5119 die "modified symlink\n" unless $newmode =~ m/^10/;
5120 } elsif ($oldmode =~ m/[^0]/) {
5122 die "deletion of symlink\n"
5123 unless $oldmode =~ m/^10/;
5126 die "creation with non-default mode\n"
5127 unless $newmode =~ m/^100644$/ or
5128 $newmode =~ m/^120000$/;
5132 local $/="\n"; chomp $@;
5133 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5137 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5138 $r |= $isignore ? 02 : 01;
5139 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5141 printdebug "quiltify_trees_differ $x $y => $r\n";
5145 sub quiltify_tree_sentinelfiles ($) {
5146 # lists the `sentinel' files present in the tree
5148 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5149 qw(-- debian/rules debian/control);
5154 sub quiltify_splitbrain_needed () {
5155 if (!$split_brain) {
5156 progress "dgit view: changes are required...";
5157 runcmd @git, qw(checkout -q -b dgit-view);
5162 sub quiltify_splitbrain ($$$$$$$) {
5163 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5164 $editedignores, $cachekey) = @_;
5165 my $gitignore_special = 1;
5166 if ($quilt_mode !~ m/gbp|dpm/) {
5167 # treat .gitignore just like any other upstream file
5168 $diffbits = { %$diffbits };
5169 $_ = !!$_ foreach values %$diffbits;
5170 $gitignore_special = 0;
5172 # We would like any commits we generate to be reproducible
5173 my @authline = clogp_authline($clogp);
5174 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5175 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5176 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5177 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5178 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5179 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5181 my $fulldiffhint = sub {
5183 my $cmd = "git diff $x $y -- :/ ':!debian'";
5184 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5185 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5188 if ($quilt_mode =~ m/gbp|unapplied/ &&
5189 ($diffbits->{O2H} & 01)) {
5191 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5192 " but git tree differs from orig in upstream files.";
5193 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5194 if (!stat_exists "debian/patches") {
5196 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5200 if ($quilt_mode =~ m/dpm/ &&
5201 ($diffbits->{H2A} & 01)) {
5202 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5203 --quilt=$quilt_mode specified, implying patches-applied git tree
5204 but git tree differs from result of applying debian/patches to upstream
5207 if ($quilt_mode =~ m/gbp|unapplied/ &&
5208 ($diffbits->{O2A} & 01)) { # some patches
5209 quiltify_splitbrain_needed();
5210 progress "dgit view: creating patches-applied version using gbp pq";
5211 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5212 # gbp pq import creates a fresh branch; push back to dgit-view
5213 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5214 runcmd @git, qw(checkout -q dgit-view);
5216 if ($quilt_mode =~ m/gbp|dpm/ &&
5217 ($diffbits->{O2A} & 02)) {
5219 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5220 tool which does not create patches for changes to upstream
5221 .gitignores: but, such patches exist in debian/patches.
5224 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5225 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5226 quiltify_splitbrain_needed();
5227 progress "dgit view: creating patch to represent .gitignore changes";
5228 ensuredir "debian/patches";
5229 my $gipatch = "debian/patches/auto-gitignore";
5230 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5231 stat GIPATCH or die "$gipatch: $!";
5232 fail "$gipatch already exists; but want to create it".
5233 " to record .gitignore changes" if (stat _)[7];
5234 print GIPATCH <<END or die "$gipatch: $!";
5235 Subject: Update .gitignore from Debian packaging branch
5237 The Debian packaging git branch contains these updates to the upstream
5238 .gitignore file(s). This patch is autogenerated, to provide these
5239 updates to users of the official Debian archive view of the package.
5241 [dgit ($our_version) update-gitignore]
5244 close GIPATCH or die "$gipatch: $!";
5245 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5246 $unapplied, $headref, "--", sort keys %$editedignores;
5247 open SERIES, "+>>", "debian/patches/series" or die $!;
5248 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5250 defined read SERIES, $newline, 1 or die $!;
5251 print SERIES "\n" or die $! unless $newline eq "\n";
5252 print SERIES "auto-gitignore\n" or die $!;
5253 close SERIES or die $!;
5254 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5256 Commit patch to update .gitignore
5258 [dgit ($our_version) update-gitignore-quilt-fixup]
5262 my $dgitview = git_rev_parse 'HEAD';
5265 # When we no longer need to support squeeze, use --create-reflog
5267 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5268 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5271 my $oldcache = git_get_ref "refs/$splitbraincache";
5272 if ($oldcache eq $dgitview) {
5273 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5274 # git update-ref doesn't always update, in this case. *sigh*
5275 my $dummy = make_commit_text <<END;
5278 author Dgit <dgit\@example.com> 1000000000 +0000
5279 committer Dgit <dgit\@example.com> 1000000000 +0000
5281 Dummy commit - do not use
5283 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5284 "refs/$splitbraincache", $dummy;
5286 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5289 changedir "$playground/work";
5291 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5292 progress "dgit view: created ($saved)";
5295 sub quiltify ($$$$) {
5296 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5298 # Quilt patchification algorithm
5300 # We search backwards through the history of the main tree's HEAD
5301 # (T) looking for a start commit S whose tree object is identical
5302 # to to the patch tip tree (ie the tree corresponding to the
5303 # current dpkg-committed patch series). For these purposes
5304 # `identical' disregards anything in debian/ - this wrinkle is
5305 # necessary because dpkg-source treates debian/ specially.
5307 # We can only traverse edges where at most one of the ancestors'
5308 # trees differs (in changes outside in debian/). And we cannot
5309 # handle edges which change .pc/ or debian/patches. To avoid
5310 # going down a rathole we avoid traversing edges which introduce
5311 # debian/rules or debian/control. And we set a limit on the
5312 # number of edges we are willing to look at.
5314 # If we succeed, we walk forwards again. For each traversed edge
5315 # PC (with P parent, C child) (starting with P=S and ending with
5316 # C=T) to we do this:
5318 # - dpkg-source --commit with a patch name and message derived from C
5319 # After traversing PT, we git commit the changes which
5320 # should be contained within debian/patches.
5322 # The search for the path S..T is breadth-first. We maintain a
5323 # todo list containing search nodes. A search node identifies a
5324 # commit, and looks something like this:
5326 # Commit => $git_commit_id,
5327 # Child => $c, # or undef if P=T
5328 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5329 # Nontrivial => true iff $p..$c has relevant changes
5336 my %considered; # saves being exponential on some weird graphs
5338 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5341 my ($search,$whynot) = @_;
5342 printdebug " search NOT $search->{Commit} $whynot\n";
5343 $search->{Whynot} = $whynot;
5344 push @nots, $search;
5345 no warnings qw(exiting);
5354 my $c = shift @todo;
5355 next if $considered{$c->{Commit}}++;
5357 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5359 printdebug "quiltify investigate $c->{Commit}\n";
5362 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5363 printdebug " search finished hooray!\n";
5368 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5369 if ($quilt_mode eq 'smash') {
5370 printdebug " search quitting smash\n";
5374 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5375 $not->($c, "has $c_sentinels not $t_sentinels")
5376 if $c_sentinels ne $t_sentinels;
5378 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5379 $commitdata =~ m/\n\n/;
5381 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5382 @parents = map { { Commit => $_, Child => $c } } @parents;
5384 $not->($c, "root commit") if !@parents;
5386 foreach my $p (@parents) {
5387 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5389 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5390 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5392 foreach my $p (@parents) {
5393 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5395 my @cmd= (@git, qw(diff-tree -r --name-only),
5396 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5397 my $patchstackchange = cmdoutput @cmd;
5398 if (length $patchstackchange) {
5399 $patchstackchange =~ s/\n/,/g;
5400 $not->($p, "changed $patchstackchange");
5403 printdebug " search queue P=$p->{Commit} ",
5404 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5410 printdebug "quiltify want to smash\n";
5413 my $x = $_[0]{Commit};
5414 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5417 my $reportnot = sub {
5419 my $s = $abbrev->($notp);
5420 my $c = $notp->{Child};
5421 $s .= "..".$abbrev->($c) if $c;
5422 $s .= ": ".$notp->{Whynot};
5425 if ($quilt_mode eq 'linear') {
5426 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5427 foreach my $notp (@nots) {
5428 print STDERR "$us: ", $reportnot->($notp), "\n";
5430 print STDERR "$us: $_\n" foreach @$failsuggestion;
5432 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5433 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5434 } elsif ($quilt_mode eq 'smash') {
5435 } elsif ($quilt_mode eq 'auto') {
5436 progress "quilt fixup cannot be linear, smashing...";
5438 die "$quilt_mode ?";
5441 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5442 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5444 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5446 quiltify_dpkg_commit "auto-$version-$target-$time",
5447 (getfield $clogp, 'Maintainer'),
5448 "Automatically generated patch ($clogp->{Version})\n".
5449 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5453 progress "quiltify linearisation planning successful, executing...";
5455 for (my $p = $sref_S;
5456 my $c = $p->{Child};
5458 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5459 next unless $p->{Nontrivial};
5461 my $cc = $c->{Commit};
5463 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5464 $commitdata =~ m/\n\n/ or die "$c ?";
5467 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5470 my $commitdate = cmdoutput
5471 @git, qw(log -n1 --pretty=format:%aD), $cc;
5473 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5475 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5482 my $gbp_check_suitable = sub {
5487 die "contains unexpected slashes\n" if m{//} || m{/$};
5488 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5489 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5490 die "is series file\n" if m{$series_filename_re}o;
5491 die "too long" if length > 200;
5493 return $_ unless $@;
5494 print STDERR "quiltifying commit $cc:".
5495 " ignoring/dropping Gbp-Pq $what: $@";
5499 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5501 (\S+) \s* \n //ixm) {
5502 $patchname = $gbp_check_suitable->($1, 'Name');
5504 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5506 (\S+) \s* \n //ixm) {
5507 $patchdir = $gbp_check_suitable->($1, 'Topic');
5512 if (!defined $patchname) {
5513 $patchname = $title;
5514 $patchname =~ s/[.:]$//;
5517 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5518 my $translitname = $converter->convert($patchname);
5519 die unless defined $translitname;
5520 $patchname = $translitname;
5523 "dgit: patch title transliteration error: $@"
5525 $patchname =~ y/ A-Z/-a-z/;
5526 $patchname =~ y/-a-z0-9_.+=~//cd;
5527 $patchname =~ s/^\W/x-$&/;
5528 $patchname = substr($patchname,0,40);
5529 $patchname .= ".patch";
5531 if (!defined $patchdir) {
5534 if (length $patchdir) {
5535 $patchname = "$patchdir/$patchname";
5537 if ($patchname =~ m{^(.*)/}) {
5538 mkpath "debian/patches/$1";
5543 stat "debian/patches/$patchname$index";
5545 $!==ENOENT or die "$patchname$index $!";
5547 runcmd @git, qw(checkout -q), $cc;
5549 # We use the tip's changelog so that dpkg-source doesn't
5550 # produce complaining messages from dpkg-parsechangelog. None
5551 # of the information dpkg-source gets from the changelog is
5552 # actually relevant - it gets put into the original message
5553 # which dpkg-source provides our stunt editor, and then
5555 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5557 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5558 "Date: $commitdate\n".
5559 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5561 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5564 runcmd @git, qw(checkout -q master);
5567 sub build_maybe_quilt_fixup () {
5568 my ($format,$fopts) = get_source_format;
5569 return unless madformat_wantfixup $format;
5572 check_for_vendor_patches();
5574 if (quiltmode_splitbrain) {
5575 fail <<END unless access_cfg_tagformats_can_splitbrain;
5576 quilt mode $quilt_mode requires split view so server needs to support
5577 both "new" and "maint" tag formats, but config says it doesn't.
5581 my $clogp = parsechangelog();
5582 my $headref = git_rev_parse('HEAD');
5583 my $symref = git_get_symref();
5585 if ($quilt_mode eq 'linear'
5586 && !$fopts->{'single-debian-patch'}
5587 && branch_is_gdr($symref, $headref)) {
5588 # This is much faster. It also makes patches that gdr
5589 # likes better for future updates without laundering.
5591 # However, it can fail in some casses where we would
5592 # succeed: if there are existing patches, which correspond
5593 # to a prefix of the branch, but are not in gbp/gdr
5594 # format, gdr will fail (exiting status 7), but we might
5595 # be able to figure out where to start linearising. That
5596 # will be slower so hopefully there's not much to do.
5597 my @cmd = (@git_debrebase,
5598 qw(--noop-ok -funclean-mixed -funclean-ordering
5599 make-patches --quiet-would-amend));
5600 # We tolerate soe snags that gdr wouldn't, by default.
5604 failedcmd @cmd if system @cmd and $?!=7*256;
5608 $headref = git_rev_parse('HEAD');
5612 changedir $playground;
5614 my $upstreamversion = upstreamversion $version;
5616 if ($fopts->{'single-debian-patch'}) {
5617 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5619 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5622 die 'bug' if $split_brain && !$need_split_build_invocation;
5625 runcmd_ordryrun_local
5626 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5629 sub unpack_playtree_mkwork ($) {
5632 mkdir "work" or die $!;
5634 mktree_in_ud_here();
5635 runcmd @git, qw(reset -q --hard), $headref;
5638 sub unpack_playtree_linkorigs ($$) {
5639 my ($upstreamversion, $fn) = @_;
5640 # calls $fn->($leafname);
5642 my $bpd_abs = bpd_abs();
5643 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5644 while ($!=0, defined(my $b = readdir QFD)) {
5645 my $f = bpd_abs()."/".$b;
5647 local ($debuglevel) = $debuglevel-1;
5648 printdebug "QF linkorigs $b, $f ?\n";
5650 next unless is_orig_file_of_vsn $b, $upstreamversion;
5651 printdebug "QF linkorigs $b, $f Y\n";
5652 link_ltarget $f, $b or die "$b $!";
5655 die "$buildproductsdir: $!" if $!;
5659 sub quilt_fixup_delete_pc () {
5660 runcmd @git, qw(rm -rqf .pc);
5662 Commit removal of .pc (quilt series tracking data)
5664 [dgit ($our_version) upgrade quilt-remove-pc]
5668 sub quilt_fixup_singlepatch ($$$) {
5669 my ($clogp, $headref, $upstreamversion) = @_;
5671 progress "starting quiltify (single-debian-patch)";
5673 # dpkg-source --commit generates new patches even if
5674 # single-debian-patch is in debian/source/options. In order to
5675 # get it to generate debian/patches/debian-changes, it is
5676 # necessary to build the source package.
5678 unpack_playtree_linkorigs($upstreamversion, sub { });
5679 unpack_playtree_mkwork($headref);
5681 rmtree("debian/patches");
5683 runcmd @dpkgsource, qw(-b .);
5685 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5686 rename srcfn("$upstreamversion", "/debian/patches"),
5687 "work/debian/patches";
5690 commit_quilty_patch();
5693 sub quilt_make_fake_dsc ($) {
5694 my ($upstreamversion) = @_;
5696 my $fakeversion="$upstreamversion-~~DGITFAKE";
5698 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5699 print $fakedsc <<END or die $!;
5702 Version: $fakeversion
5706 my $dscaddfile=sub {
5709 my $md = new Digest::MD5;
5711 my $fh = new IO::File $b, '<' or die "$b $!";
5716 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5719 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5721 my @files=qw(debian/source/format debian/rules
5722 debian/control debian/changelog);
5723 foreach my $maybe (qw(debian/patches debian/source/options
5724 debian/tests/control)) {
5725 next unless stat_exists "$maindir/$maybe";
5726 push @files, $maybe;
5729 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5730 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5732 $dscaddfile->($debtar);
5733 close $fakedsc or die $!;
5736 sub quilt_check_splitbrain_cache ($$) {
5737 my ($headref, $upstreamversion) = @_;
5738 # Called only if we are in (potentially) split brain mode.
5739 # Called in playground.
5740 # Computes the cache key and looks in the cache.
5741 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5743 my $splitbrain_cachekey;
5746 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5747 # we look in the reflog of dgit-intern/quilt-cache
5748 # we look for an entry whose message is the key for the cache lookup
5749 my @cachekey = (qw(dgit), $our_version);
5750 push @cachekey, $upstreamversion;
5751 push @cachekey, $quilt_mode;
5752 push @cachekey, $headref;
5754 push @cachekey, hashfile('fake.dsc');
5756 my $srcshash = Digest::SHA->new(256);
5757 my %sfs = ( %INC, '$0(dgit)' => $0 );
5758 foreach my $sfk (sort keys %sfs) {
5759 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5760 $srcshash->add($sfk," ");
5761 $srcshash->add(hashfile($sfs{$sfk}));
5762 $srcshash->add("\n");
5764 push @cachekey, $srcshash->hexdigest();
5765 $splitbrain_cachekey = "@cachekey";
5767 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5769 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5770 debugcmd "|(probably)",@cmd;
5771 my $child = open GC, "-|"; defined $child or die $!;
5773 chdir $maindir or die $!;
5774 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5775 $! == ENOENT or die $!;
5776 printdebug ">(no reflog)\n";
5783 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5784 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5787 unpack_playtree_mkwork($headref);
5788 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5789 if ($cachehit ne $headref) {
5790 progress "dgit view: found cached ($saved)";
5791 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5793 return ($cachehit, $splitbrain_cachekey);
5795 progress "dgit view: found cached, no changes required";
5796 return ($headref, $splitbrain_cachekey);
5798 die $! if GC->error;
5799 failedcmd unless close GC;
5801 printdebug "splitbrain cache miss\n";
5802 return (undef, $splitbrain_cachekey);
5805 sub quilt_fixup_multipatch ($$$) {
5806 my ($clogp, $headref, $upstreamversion) = @_;
5808 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5811 # - honour any existing .pc in case it has any strangeness
5812 # - determine the git commit corresponding to the tip of
5813 # the patch stack (if there is one)
5814 # - if there is such a git commit, convert each subsequent
5815 # git commit into a quilt patch with dpkg-source --commit
5816 # - otherwise convert all the differences in the tree into
5817 # a single git commit
5821 # Our git tree doesn't necessarily contain .pc. (Some versions of
5822 # dgit would include the .pc in the git tree.) If there isn't
5823 # one, we need to generate one by unpacking the patches that we
5826 # We first look for a .pc in the git tree. If there is one, we
5827 # will use it. (This is not the normal case.)
5829 # Otherwise need to regenerate .pc so that dpkg-source --commit
5830 # can work. We do this as follows:
5831 # 1. Collect all relevant .orig from parent directory
5832 # 2. Generate a debian.tar.gz out of
5833 # debian/{patches,rules,source/format,source/options}
5834 # 3. Generate a fake .dsc containing just these fields:
5835 # Format Source Version Files
5836 # 4. Extract the fake .dsc
5837 # Now the fake .dsc has a .pc directory.
5838 # (In fact we do this in every case, because in future we will
5839 # want to search for a good base commit for generating patches.)
5841 # Then we can actually do the dpkg-source --commit
5842 # 1. Make a new working tree with the same object
5843 # store as our main tree and check out the main
5845 # 2. Copy .pc from the fake's extraction, if necessary
5846 # 3. Run dpkg-source --commit
5847 # 4. If the result has changes to debian/, then
5848 # - git add them them
5849 # - git add .pc if we had a .pc in-tree
5851 # 5. If we had a .pc in-tree, delete it, and git commit
5852 # 6. Back in the main tree, fast forward to the new HEAD
5854 # Another situation we may have to cope with is gbp-style
5855 # patches-unapplied trees.
5857 # We would want to detect these, so we know to escape into
5858 # quilt_fixup_gbp. However, this is in general not possible.
5859 # Consider a package with a one patch which the dgit user reverts
5860 # (with git revert or the moral equivalent).
5862 # That is indistinguishable in contents from a patches-unapplied
5863 # tree. And looking at the history to distinguish them is not
5864 # useful because the user might have made a confusing-looking git
5865 # history structure (which ought to produce an error if dgit can't
5866 # cope, not a silent reintroduction of an unwanted patch).
5868 # So gbp users will have to pass an option. But we can usually
5869 # detect their failure to do so: if the tree is not a clean
5870 # patches-applied tree, quilt linearisation fails, but the tree
5871 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5872 # they want --quilt=unapplied.
5874 # To help detect this, when we are extracting the fake dsc, we
5875 # first extract it with --skip-patches, and then apply the patches
5876 # afterwards with dpkg-source --before-build. That lets us save a
5877 # tree object corresponding to .origs.
5879 my $splitbrain_cachekey;
5881 quilt_make_fake_dsc($upstreamversion);
5883 if (quiltmode_splitbrain()) {
5885 ($cachehit, $splitbrain_cachekey) =
5886 quilt_check_splitbrain_cache($headref, $upstreamversion);
5887 return if $cachehit;
5891 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5893 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5894 rename $fakexdir, "fake" or die "$fakexdir $!";
5898 remove_stray_gits("source package");
5899 mktree_in_ud_here();
5903 rmtree 'debian'; # git checkout commitish paths does not delete!
5904 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5905 my $unapplied=git_add_write_tree();
5906 printdebug "fake orig tree object $unapplied\n";
5910 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5912 if (system @bbcmd) {
5913 failedcmd @bbcmd if $? < 0;
5915 failed to apply your git tree's patch stack (from debian/patches/) to
5916 the corresponding upstream tarball(s). Your source tree and .orig
5917 are probably too inconsistent. dgit can only fix up certain kinds of
5918 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5924 unpack_playtree_mkwork($headref);
5927 if (stat_exists ".pc") {
5929 progress "Tree already contains .pc - will use it then delete it.";
5932 rename '../fake/.pc','.pc' or die $!;
5935 changedir '../fake';
5937 my $oldtiptree=git_add_write_tree();
5938 printdebug "fake o+d/p tree object $unapplied\n";
5939 changedir '../work';
5942 # We calculate some guesswork now about what kind of tree this might
5943 # be. This is mostly for error reporting.
5949 # O = orig, without patches applied
5950 # A = "applied", ie orig with H's debian/patches applied
5951 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5952 \%editedignores, \@unrepres),
5953 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5954 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5958 foreach my $b (qw(01 02)) {
5959 foreach my $v (qw(O2H O2A H2A)) {
5960 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5963 printdebug "differences \@dl @dl.\n";
5966 "$us: base trees orig=%.20s o+d/p=%.20s",
5967 $unapplied, $oldtiptree;
5969 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5970 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5971 $dl[0], $dl[1], $dl[3], $dl[4],
5975 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5977 forceable_fail [qw(unrepresentable)], <<END;
5978 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5983 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5984 push @failsuggestion, "This might be a patches-unapplied branch.";
5985 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5986 push @failsuggestion, "This might be a patches-applied branch.";
5988 push @failsuggestion, "Maybe you need to specify one of".
5989 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5991 if (quiltmode_splitbrain()) {
5992 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
5993 $diffbits, \%editedignores,
5994 $splitbrain_cachekey);
5998 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5999 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6001 if (!open P, '>>', ".pc/applied-patches") {
6002 $!==&ENOENT or die $!;
6007 commit_quilty_patch();
6009 if ($mustdeletepc) {
6010 quilt_fixup_delete_pc();
6014 sub quilt_fixup_editor () {
6015 my $descfn = $ENV{$fakeeditorenv};
6016 my $editing = $ARGV[$#ARGV];
6017 open I1, '<', $descfn or die "$descfn: $!";
6018 open I2, '<', $editing or die "$editing: $!";
6019 unlink $editing or die "$editing: $!";
6020 open O, '>', $editing or die "$editing: $!";
6021 while (<I1>) { print O or die $!; } I1->error and die $!;
6024 $copying ||= m/^\-\-\- /;
6025 next unless $copying;
6028 I2->error and die $!;
6033 sub maybe_apply_patches_dirtily () {
6034 return unless $quilt_mode =~ m/gbp|unapplied/;
6035 print STDERR <<END or die $!;
6037 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6038 dgit: Have to apply the patches - making the tree dirty.
6039 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6042 $patches_applied_dirtily = 01;
6043 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6044 runcmd qw(dpkg-source --before-build .);
6047 sub maybe_unapply_patches_again () {
6048 progress "dgit: Unapplying patches again to tidy up the tree."
6049 if $patches_applied_dirtily;
6050 runcmd qw(dpkg-source --after-build .)
6051 if $patches_applied_dirtily & 01;
6053 if $patches_applied_dirtily & 02;
6054 $patches_applied_dirtily = 0;
6057 #----- other building -----
6059 our $clean_using_builder;
6060 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6061 # clean the tree before building (perhaps invoked indirectly by
6062 # whatever we are using to run the build), rather than separately
6063 # and explicitly by us.
6066 return if $clean_using_builder;
6067 if ($cleanmode eq 'dpkg-source') {
6068 maybe_apply_patches_dirtily();
6069 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6070 } elsif ($cleanmode eq 'dpkg-source-d') {
6071 maybe_apply_patches_dirtily();
6072 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6073 } elsif ($cleanmode eq 'git') {
6074 runcmd_ordryrun_local @git, qw(clean -xdf);
6075 } elsif ($cleanmode eq 'git-ff') {
6076 runcmd_ordryrun_local @git, qw(clean -xdff);
6077 } elsif ($cleanmode eq 'check') {
6078 my $leftovers = cmdoutput @git, qw(clean -xdn);
6079 if (length $leftovers) {
6080 print STDERR $leftovers, "\n" or die $!;
6081 fail "tree contains uncommitted files and --clean=check specified";
6083 } elsif ($cleanmode eq 'none') {
6090 badusage "clean takes no additional arguments" if @ARGV;
6093 maybe_unapply_patches_again();
6096 # return values from massage_dbp_args are one or both of these flags
6097 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6098 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6100 sub build_or_push_prep_early () {
6101 our $build_or_push_prep_early_done //= 0;
6102 return if $build_or_push_prep_early_done++;
6103 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6104 my $clogp = parsechangelog();
6105 $isuite = getfield $clogp, 'Distribution';
6106 $package = getfield $clogp, 'Source';
6107 $version = getfield $clogp, 'Version';
6108 $dscfn = dscfn($version);
6111 sub build_prep_early () {
6112 build_or_push_prep_early();
6117 sub build_prep ($) {
6120 # clean the tree if we're trying to include dirty changes in the
6121 # source package, or we are running the builder in $maindir
6122 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6123 build_maybe_quilt_fixup();
6125 my $pat = changespat $version;
6126 foreach my $f (glob "$buildproductsdir/$pat") {
6128 unlink $f or fail "remove old changes file $f: $!";
6130 progress "would remove $f";
6136 sub changesopts_initial () {
6137 my @opts =@changesopts[1..$#changesopts];
6140 sub changesopts_version () {
6141 if (!defined $changes_since_version) {
6144 @vsns = archive_query('archive_query');
6145 my @quirk = access_quirk();
6146 if ($quirk[0] eq 'backports') {
6147 local $isuite = $quirk[2];
6149 canonicalise_suite();
6150 push @vsns, archive_query('archive_query');
6156 "archive query failed (queried because --since-version not specified)";
6159 @vsns = map { $_->[0] } @vsns;
6160 @vsns = sort { -version_compare($a, $b) } @vsns;
6161 $changes_since_version = $vsns[0];
6162 progress "changelog will contain changes since $vsns[0]";
6164 $changes_since_version = '_';
6165 progress "package seems new, not specifying -v<version>";
6168 if ($changes_since_version ne '_') {
6169 return ("-v$changes_since_version");
6175 sub changesopts () {
6176 return (changesopts_initial(), changesopts_version());
6179 sub massage_dbp_args ($;$) {
6180 my ($cmd,$xargs) = @_;
6183 # - if we're going to split the source build out so we can
6184 # do strange things to it, massage the arguments to dpkg-buildpackage
6185 # so that the main build doessn't build source (or add an argument
6186 # to stop it building source by default).
6188 # - add -nc to stop dpkg-source cleaning the source tree,
6189 # unless we're not doing a split build and want dpkg-source
6190 # as cleanmode, in which case we can do nothing
6192 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6193 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6194 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6195 $clean_using_builder = 1;
6196 return WANTSRC_BUILDER;
6198 # -nc has the side effect of specifying -b if nothing else specified
6199 # and some combinations of -S, -b, et al, are errors, rather than
6200 # later simply overriding earlie. So we need to:
6201 # - search the command line for these options
6202 # - pick the last one
6203 # - perhaps add our own as a default
6204 # - perhaps adjust it to the corresponding non-source-building version
6206 foreach my $l ($cmd, $xargs) {
6208 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6211 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6212 my $r = WANTSRC_BUILDER;
6213 if ($need_split_build_invocation) {
6214 printdebug "massage split $dmode.\n";
6215 $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6216 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6217 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6220 printdebug "massage done $r $dmode.\n";
6222 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6228 my $wasdir = must_getcwd();
6229 changedir $buildproductsdir;
6234 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6235 sub postbuild_mergechanges ($) {
6236 my ($msg_if_onlyone) = @_;
6237 # If there is only one .changes file, fail with $msg_if_onlyone,
6238 # or if that is undef, be a no-op.
6239 # Returns the changes file to report to the user.
6240 my $pat = changespat $version;
6241 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6242 @changesfiles = sort {
6243 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6247 if (@changesfiles==1) {
6248 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6249 only one changes file from build (@changesfiles)
6251 $result = $changesfiles[0];
6252 } elsif (@changesfiles==2) {
6253 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6254 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6255 fail "$l found in binaries changes file $binchanges"
6258 runcmd_ordryrun_local @mergechanges, @changesfiles;
6259 my $multichanges = changespat $version,'multi';
6261 stat_exists $multichanges or fail "$multichanges: $!";
6262 foreach my $cf (glob $pat) {
6263 next if $cf eq $multichanges;
6264 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6267 $result = $multichanges;
6269 fail "wrong number of different changes files (@changesfiles)";
6271 printdone "build successful, results in $result\n" or die $!;
6274 sub midbuild_checkchanges () {
6275 my $pat = changespat $version;
6276 return if $rmchanges;
6277 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6279 $_ ne changespat $version,'source' and
6280 $_ ne changespat $version,'multi'
6283 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6284 Suggest you delete @unwanted.
6289 sub midbuild_checkchanges_vanilla ($) {
6291 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6294 sub postbuild_mergechanges_vanilla ($) {
6296 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6298 postbuild_mergechanges(undef);
6301 printdone "build successful\n";
6307 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6308 my $wantsrc = massage_dbp_args \@dbp;
6309 build_prep($wantsrc);
6310 if ($wantsrc & WANTSRC_SOURCE) {
6312 midbuild_checkchanges_vanilla $wantsrc;
6314 if ($wantsrc & WANTSRC_BUILDER) {
6315 push @dbp, changesopts_version();
6316 maybe_apply_patches_dirtily();
6317 runcmd_ordryrun_local @dbp;
6319 maybe_unapply_patches_again();
6320 postbuild_mergechanges_vanilla $wantsrc;
6324 $quilt_mode //= 'gbp';
6330 # gbp can make .origs out of thin air. In my tests it does this
6331 # even for a 1.0 format package, with no origs present. So I
6332 # guess it keys off just the version number. We don't know
6333 # exactly what .origs ought to exist, but let's assume that we
6334 # should run gbp if: the version has an upstream part and the main
6336 my $upstreamversion = upstreamversion $version;
6337 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6338 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6340 if ($gbp_make_orig) {
6342 $cleanmode = 'none'; # don't do it again
6343 $need_split_build_invocation = 1;
6346 my @dbp = @dpkgbuildpackage;
6348 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6350 if (!length $gbp_build[0]) {
6351 if (length executable_on_path('git-buildpackage')) {
6352 $gbp_build[0] = qw(git-buildpackage);
6354 $gbp_build[0] = 'gbp buildpackage';
6357 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6359 push @cmd, (qw(-us -uc --git-no-sign-tags),
6360 "--git-builder=".(shellquote @dbp));
6362 if ($gbp_make_orig) {
6363 my $priv = dgit_privdir();
6364 my $ok = "$priv/origs-gen-ok";
6365 unlink $ok or $!==&ENOENT or die $!;
6366 my @origs_cmd = @cmd;
6367 push @origs_cmd, qw(--git-cleaner=true);
6368 push @origs_cmd, "--git-prebuild=".
6369 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6370 push @origs_cmd, @ARGV;
6372 debugcmd @origs_cmd;
6374 do { local $!; stat_exists $ok; }
6375 or failedcmd @origs_cmd;
6377 dryrun_report @origs_cmd;
6381 build_prep($wantsrc);
6382 if ($wantsrc & WANTSRC_SOURCE) {
6384 midbuild_checkchanges_vanilla $wantsrc;
6386 if (!$clean_using_builder) {
6387 push @cmd, '--git-cleaner=true';
6390 maybe_unapply_patches_again();
6391 if ($wantsrc & WANTSRC_BUILDER) {
6392 push @cmd, changesopts();
6393 runcmd_ordryrun_local @cmd, @ARGV;
6395 postbuild_mergechanges_vanilla $wantsrc;
6397 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6399 sub building_source_in_playtree {
6400 # If $includedirty, we have to build the source package from the
6401 # working tree, not a playtree, so that uncommitted changes are
6402 # included (copying or hardlinking them into the playtree could
6405 # Note that if we are building a source package in split brain
6406 # mode we do not support including uncommitted changes, because
6407 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6408 # building a source package)) => !$includedirty
6409 return !$includedirty;
6413 $sourcechanges = changespat $version,'source';
6415 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6416 or fail "remove $sourcechanges: $!";
6418 my @cmd = (@dpkgsource, qw(-b --));
6420 if (building_source_in_playtree()) {
6422 my $headref = git_rev_parse('HEAD');
6423 # If we are in split brain, there is already a playtree with
6424 # the thing we should package into a .dsc (thanks to quilt
6425 # fixup). If not, make a playtree
6426 prep_ud() unless $split_brain;
6427 changedir $playground;
6428 unless ($split_brain) {
6429 my $upstreamversion = upstreamversion $version;
6430 unpack_playtree_linkorigs($upstreamversion, sub { });
6431 unpack_playtree_mkwork($headref);
6435 $leafdir = basename $maindir;
6438 runcmd_ordryrun_local @cmd, $leafdir;
6441 runcmd_ordryrun_local qw(sh -ec),
6442 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6443 @dpkggenchanges, qw(-S), changesopts();
6446 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6447 $dsc = parsecontrol($dscfn, "source package");
6451 printdebug " renaming ($why) $l\n";
6452 rename "$l", bpd_abs()."/$l"
6453 or fail "put in place new built file ($l): $!";
6455 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6456 $l =~ m/\S+$/ or next;
6459 $mv->('dsc', $dscfn);
6460 $mv->('changes', $sourcechanges);
6465 sub cmd_build_source {
6466 badusage "build-source takes no additional arguments" if @ARGV;
6467 build_prep(WANTSRC_SOURCE);
6469 maybe_unapply_patches_again();
6470 printdone "source built, results in $dscfn and $sourcechanges";
6473 sub cmd_push_source {
6475 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6476 "sense with push-source!" if $includedirty;
6477 build_maybe_quilt_fixup();
6479 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6480 "source changes file");
6481 unless (test_source_only_changes($changes)) {
6482 fail "user-specified changes file is not source-only";
6485 # Building a source package is very fast, so just do it
6487 die "er, patches are applied dirtily but shouldn't be.."
6488 if $patches_applied_dirtily;
6489 $changesfile = $sourcechanges;
6496 build_with_binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6497 perhaps you need to pass -A ? (sbuild's default is to build only
6498 arch-specific binaries; dgit 1.4 used to override that.)
6502 sub build_with_binary_builder ($$$) {
6503 my ($bbuilder, $pbmc_msg, @args) = @_;
6504 build_prep(WANTSRC_SOURCE);
6506 midbuild_checkchanges();
6509 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6510 stat_exists $sourcechanges
6511 or fail "$sourcechanges (in build products dir): $!";
6513 runcmd_ordryrun_local @$bbuilder, @args;
6515 maybe_unapply_patches_again();
6517 postbuild_mergechanges($pbmc_msg);
6521 sub cmd_quilt_fixup {
6522 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6525 build_maybe_quilt_fixup();
6528 sub import_dsc_result {
6529 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6530 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6532 check_gitattrs($newhash, "source tree");
6534 progress "dgit: import-dsc: $what_msg";
6537 sub cmd_import_dsc {
6541 last unless $ARGV[0] =~ m/^-/;
6544 if (m/^--require-valid-signature$/) {
6547 badusage "unknown dgit import-dsc sub-option \`$_'";
6551 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6552 my ($dscfn, $dstbranch) = @ARGV;
6554 badusage "dry run makes no sense with import-dsc" unless act_local();
6556 my $force = $dstbranch =~ s/^\+// ? +1 :
6557 $dstbranch =~ s/^\.\.// ? -1 :
6559 my $info = $force ? " $&" : '';
6560 $info = "$dscfn$info";
6562 my $specbranch = $dstbranch;
6563 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6564 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6566 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6567 my $chead = cmdoutput_errok @symcmd;
6568 defined $chead or $?==256 or failedcmd @symcmd;
6570 fail "$dstbranch is checked out - will not update it"
6571 if defined $chead and $chead eq $dstbranch;
6573 my $oldhash = git_get_ref $dstbranch;
6575 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6576 $dscdata = do { local $/ = undef; <D>; };
6577 D->error and fail "read $dscfn: $!";
6580 # we don't normally need this so import it here
6581 use Dpkg::Source::Package;
6582 my $dp = new Dpkg::Source::Package filename => $dscfn,
6583 require_valid_signature => $needsig;
6585 local $SIG{__WARN__} = sub {
6587 return unless $needsig;
6588 fail "import-dsc signature check failed";
6590 if (!$dp->is_signed()) {
6591 warn "$us: warning: importing unsigned .dsc\n";
6593 my $r = $dp->check_signature();
6594 die "->check_signature => $r" if $needsig && $r;
6600 $package = getfield $dsc, 'Source';
6602 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6603 unless forceing [qw(import-dsc-with-dgit-field)];
6604 parse_dsc_field_def_dsc_distro();
6606 $isuite = 'DGIT-IMPORT-DSC';
6607 $idistro //= $dsc_distro;
6611 if (defined $dsc_hash) {
6612 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6613 resolve_dsc_field_commit undef, undef;
6615 if (defined $dsc_hash) {
6616 my @cmd = (qw(sh -ec),
6617 "echo $dsc_hash | git cat-file --batch-check");
6618 my $objgot = cmdoutput @cmd;
6619 if ($objgot =~ m#^\w+ missing\b#) {
6621 .dsc contains Dgit field referring to object $dsc_hash
6622 Your git tree does not have that object. Try `git fetch' from a
6623 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6626 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6628 progress "Not fast forward, forced update.";
6630 fail "Not fast forward to $dsc_hash";
6633 import_dsc_result $dstbranch, $dsc_hash,
6634 "dgit import-dsc (Dgit): $info",
6635 "updated git ref $dstbranch";
6640 Branch $dstbranch already exists
6641 Specify ..$specbranch for a pseudo-merge, binding in existing history
6642 Specify +$specbranch to overwrite, discarding existing history
6644 if $oldhash && !$force;
6646 my @dfi = dsc_files_info();
6647 foreach my $fi (@dfi) {
6648 my $f = $fi->{Filename};
6649 my $here = "$buildproductsdir/$f";
6652 fail "lstat $here works but stat gives $! !";
6654 fail "stat $here: $!" unless $! == ENOENT;
6656 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6658 } elsif ($dscfn =~ m#^/#) {
6661 fail "cannot import $dscfn which seems to be inside working tree!";
6663 $there =~ s#/+[^/]+$## or
6664 fail "import $dscfn requires ../$f, but it does not exist";
6666 my $test = $there =~ m{^/} ? $there : "../$there";
6667 stat $test or fail "import $dscfn requires $test, but: $!";
6668 symlink $there, $here or fail "symlink $there to $here: $!";
6669 progress "made symlink $here -> $there";
6670 # print STDERR Dumper($fi);
6672 my @mergeinputs = generate_commits_from_dsc();
6673 die unless @mergeinputs == 1;
6675 my $newhash = $mergeinputs[0]{Commit};
6679 progress "Import, forced update - synthetic orphan git history.";
6680 } elsif ($force < 0) {
6681 progress "Import, merging.";
6682 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6683 my $version = getfield $dsc, 'Version';
6684 my $clogp = commit_getclogp $newhash;
6685 my $authline = clogp_authline $clogp;
6686 $newhash = make_commit_text <<END;
6693 Merge $package ($version) import into $dstbranch
6696 die; # caught earlier
6700 import_dsc_result $dstbranch, $newhash,
6701 "dgit import-dsc: $info",
6702 "results are in in git ref $dstbranch";
6705 sub pre_archive_api_query () {
6706 not_necessarily_a_tree();
6708 sub cmd_archive_api_query {
6709 badusage "need only 1 subpath argument" unless @ARGV==1;
6710 my ($subpath) = @ARGV;
6711 local $isuite = 'DGIT-API-QUERY-CMD';
6712 my @cmd = archive_api_query_cmd($subpath);
6715 exec @cmd or fail "exec curl: $!\n";
6718 sub repos_server_url () {
6719 $package = '_dgit-repos-server';
6720 local $access_forpush = 1;
6721 local $isuite = 'DGIT-REPOS-SERVER';
6722 my $url = access_giturl();
6725 sub pre_clone_dgit_repos_server () {
6726 not_necessarily_a_tree();
6728 sub cmd_clone_dgit_repos_server {
6729 badusage "need destination argument" unless @ARGV==1;
6730 my ($destdir) = @ARGV;
6731 my $url = repos_server_url();
6732 my @cmd = (@git, qw(clone), $url, $destdir);
6734 exec @cmd or fail "exec git clone: $!\n";
6737 sub pre_print_dgit_repos_server_source_url () {
6738 not_necessarily_a_tree();
6740 sub cmd_print_dgit_repos_server_source_url {
6741 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6743 my $url = repos_server_url();
6744 print $url, "\n" or die $!;
6747 sub pre_print_dpkg_source_ignores {
6748 not_necessarily_a_tree();
6750 sub cmd_print_dpkg_source_ignores {
6751 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6753 print "@dpkg_source_ignores\n" or die $!;
6756 sub cmd_setup_mergechangelogs {
6757 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6758 local $isuite = 'DGIT-SETUP-TREE';
6759 setup_mergechangelogs(1);
6762 sub cmd_setup_useremail {
6763 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6764 local $isuite = 'DGIT-SETUP-TREE';
6768 sub cmd_setup_gitattributes {
6769 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6770 local $isuite = 'DGIT-SETUP-TREE';
6774 sub cmd_setup_new_tree {
6775 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6776 local $isuite = 'DGIT-SETUP-TREE';
6780 #---------- argument parsing and main program ----------
6783 print "dgit version $our_version\n" or die $!;
6787 our (%valopts_long, %valopts_short);
6788 our (%funcopts_long);
6790 our (@modeopt_cfgs);
6792 sub defvalopt ($$$$) {
6793 my ($long,$short,$val_re,$how) = @_;
6794 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6795 $valopts_long{$long} = $oi;
6796 $valopts_short{$short} = $oi;
6797 # $how subref should:
6798 # do whatever assignemnt or thing it likes with $_[0]
6799 # if the option should not be passed on to remote, @rvalopts=()
6800 # or $how can be a scalar ref, meaning simply assign the value
6803 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6804 defvalopt '--distro', '-d', '.+', \$idistro;
6805 defvalopt '', '-k', '.+', \$keyid;
6806 defvalopt '--existing-package','', '.*', \$existing_package;
6807 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6808 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6809 defvalopt '--package', '-p', $package_re, \$package;
6810 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6812 defvalopt '', '-C', '.+', sub {
6813 ($changesfile) = (@_);
6814 if ($changesfile =~ s#^(.*)/##) {
6815 $buildproductsdir = $1;
6819 defvalopt '--initiator-tempdir','','.*', sub {
6820 ($initiator_tempdir) = (@_);
6821 $initiator_tempdir =~ m#^/# or
6822 badusage "--initiator-tempdir must be used specify an".
6823 " absolute, not relative, directory."
6826 sub defoptmodes ($@) {
6827 my ($varref, $cfgkey, $default, %optmap) = @_;
6829 while (my ($opt,$val) = each %optmap) {
6830 $funcopts_long{$opt} = sub { $$varref = $val; };
6831 $permit{$val} = $val;
6833 push @modeopt_cfgs, {
6836 Default => $default,
6841 defoptmodes \$dodep14tag, qw( dep14tag want
6844 --always-dep14tag always );
6849 if (defined $ENV{'DGIT_SSH'}) {
6850 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6851 } elsif (defined $ENV{'GIT_SSH'}) {
6852 @ssh = ($ENV{'GIT_SSH'});
6860 if (!defined $val) {
6861 badusage "$what needs a value" unless @ARGV;
6863 push @rvalopts, $val;
6865 badusage "bad value \`$val' for $what" unless
6866 $val =~ m/^$oi->{Re}$(?!\n)/s;
6867 my $how = $oi->{How};
6868 if (ref($how) eq 'SCALAR') {
6873 push @ropts, @rvalopts;
6877 last unless $ARGV[0] =~ m/^-/;
6881 if (m/^--dry-run$/) {
6884 } elsif (m/^--damp-run$/) {
6887 } elsif (m/^--no-sign$/) {
6890 } elsif (m/^--help$/) {
6892 } elsif (m/^--version$/) {
6894 } elsif (m/^--new$/) {
6897 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6898 ($om = $opts_opt_map{$1}) &&
6902 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6903 !$opts_opt_cmdonly{$1} &&
6904 ($om = $opts_opt_map{$1})) {
6907 } elsif (m/^--(gbp|dpm)$/s) {
6908 push @ropts, "--quilt=$1";
6910 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6913 } elsif (m/^--no-quilt-fixup$/s) {
6915 $quilt_mode = 'nocheck';
6916 } elsif (m/^--no-rm-on-error$/s) {
6919 } elsif (m/^--no-chase-dsc-distro$/s) {
6921 $chase_dsc_distro = 0;
6922 } elsif (m/^--overwrite$/s) {
6924 $overwrite_version = '';
6925 } elsif (m/^--overwrite=(.+)$/s) {
6927 $overwrite_version = $1;
6928 } elsif (m/^--delayed=(\d+)$/s) {
6931 } elsif (m/^--dgit-view-save=(.+)$/s) {
6933 $split_brain_save = $1;
6934 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6935 } elsif (m/^--(no-)?rm-old-changes$/s) {
6938 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6940 push @deliberatelies, $&;
6941 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6945 } elsif (m/^--force-/) {
6947 "$us: warning: ignoring unknown force option $_\n";
6949 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6950 # undocumented, for testing
6952 $tagformat_want = [ $1, 'command line', 1 ];
6953 # 1 menas overrides distro configuration
6954 } elsif (m/^--always-split-source-build$/s) {
6955 # undocumented, was once for testing, now a no-op
6957 $need_split_build_invocation = 1;
6958 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6959 # undocumented, for testing
6961 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6962 # ^ it's supposed to be an array ref
6963 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6964 $val = $2 ? $' : undef; #';
6965 $valopt->($oi->{Long});
6966 } elsif ($funcopts_long{$_}) {
6968 $funcopts_long{$_}();
6970 badusage "unknown long option \`$_'";
6977 } elsif (s/^-L/-/) {
6980 } elsif (s/^-h/-/) {
6982 } elsif (s/^-D/-/) {
6986 } elsif (s/^-N/-/) {
6991 push @changesopts, $_;
6993 } elsif (s/^-wn$//s) {
6995 $cleanmode = 'none';
6996 } elsif (s/^-wg$//s) {
6999 } elsif (s/^-wgf$//s) {
7001 $cleanmode = 'git-ff';
7002 } elsif (s/^-wd$//s) {
7004 $cleanmode = 'dpkg-source';
7005 } elsif (s/^-wdd$//s) {
7007 $cleanmode = 'dpkg-source-d';
7008 } elsif (s/^-wc$//s) {
7010 $cleanmode = 'check';
7011 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7012 push @git, '-c', $&;
7013 $gitcfgs{cmdline}{$1} = [ $2 ];
7014 } elsif (s/^-c([^=]+)$//s) {
7015 push @git, '-c', $&;
7016 $gitcfgs{cmdline}{$1} = [ 'true' ];
7017 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7019 $val = undef unless length $val;
7020 $valopt->($oi->{Short});
7023 badusage "unknown short option \`$_'";
7030 sub check_env_sanity () {
7031 my $blocked = new POSIX::SigSet;
7032 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7035 foreach my $name (qw(PIPE CHLD)) {
7036 my $signame = "SIG$name";
7037 my $signum = eval "POSIX::$signame" // die;
7038 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
7039 die "$signame is set to something other than SIG_DFL\n";
7040 $blocked->ismember($signum) and
7041 die "$signame is blocked\n";
7047 On entry to dgit, $@
7048 This is a bug produced by something in in your execution environment.
7054 sub parseopts_late_defaults () {
7055 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7056 if defined $idistro;
7057 $isuite //= cfg('dgit.default.default-suite');
7059 foreach my $k (keys %opts_opt_map) {
7060 my $om = $opts_opt_map{$k};
7062 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7064 badcfg "cannot set command for $k"
7065 unless length $om->[0];
7069 foreach my $c (access_cfg_cfgs("opts-$k")) {
7071 map { $_ ? @$_ : () }
7072 map { $gitcfgs{$_}{$c} }
7073 reverse @gitcfgsources;
7074 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7075 "\n" if $debuglevel >= 4;
7077 badcfg "cannot configure options for $k"
7078 if $opts_opt_cmdonly{$k};
7079 my $insertpos = $opts_cfg_insertpos{$k};
7080 @$om = ( @$om[0..$insertpos-1],
7082 @$om[$insertpos..$#$om] );
7086 if (!defined $rmchanges) {
7087 local $access_forpush;
7088 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7091 if (!defined $quilt_mode) {
7092 local $access_forpush;
7093 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7094 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7096 $quilt_mode =~ m/^($quilt_modes_re)$/
7097 or badcfg "unknown quilt-mode \`$quilt_mode'";
7101 foreach my $moc (@modeopt_cfgs) {
7102 local $access_forpush;
7103 my $vr = $moc->{Var};
7104 next if defined $$vr;
7105 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7106 my $v = $moc->{Vals}{$$vr};
7107 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7111 $need_split_build_invocation ||= quiltmode_splitbrain();
7113 fail "dgit: --include-dirty is not supported in split view quilt mode"
7114 if $split_brain && $includedirty;
7116 if (!defined $cleanmode) {
7117 local $access_forpush;
7118 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7119 $cleanmode //= 'dpkg-source';
7121 badcfg "unknown clean-mode \`$cleanmode'" unless
7122 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7125 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7126 $buildproductsdir //= '..';
7127 $bpd_glob = $buildproductsdir;
7128 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7131 if ($ENV{$fakeeditorenv}) {
7133 quilt_fixup_editor();
7139 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7140 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7141 if $dryrun_level == 1;
7143 print STDERR $helpmsg or die $!;
7146 $cmd = $subcommand = shift @ARGV;
7149 my $pre_fn = ${*::}{"pre_$cmd"};
7150 $pre_fn->() if $pre_fn;
7152 record_maindir if $invoked_in_git_tree;
7155 my $fn = ${*::}{"cmd_$cmd"};
7156 $fn or badusage "unknown operation $cmd";