3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
42 our $our_version = 'UNRELEASED'; ###substituted###
44 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
47 our $isuite = 'unstable';
53 our $dryrun_level = 0;
55 our $buildproductsdir = '..';
61 our $existing_package = 'dpkg';
63 our $changes_since_version;
66 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
67 our $we_are_responder;
68 our $initiator_tempdir;
69 our $patches_applied_dirtily = 00;
74 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
76 our $suite_re = '[-+.0-9a-z]+';
77 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
79 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
80 our $splitbraincache = 'dgit-intern/quilt-cache';
83 our (@dget) = qw(dget);
84 our (@curl) = qw(curl -f);
85 our (@dput) = qw(dput);
86 our (@debsign) = qw(debsign);
88 our (@sbuild) = qw(sbuild);
90 our (@dgit) = qw(dgit);
91 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
92 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
93 our (@dpkggenchanges) = qw(dpkg-genchanges);
94 our (@mergechanges) = qw(mergechanges -f);
96 our (@changesopts) = ('');
98 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
101 'debsign' => \@debsign,
103 'sbuild' => \@sbuild,
107 'dpkg-source' => \@dpkgsource,
108 'dpkg-buildpackage' => \@dpkgbuildpackage,
109 'dpkg-genchanges' => \@dpkggenchanges,
111 'ch' => \@changesopts,
112 'mergechanges' => \@mergechanges);
114 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
115 our %opts_cfg_insertpos = map {
117 scalar @{ $opts_opt_map{$_} }
118 } keys %opts_opt_map;
120 sub finalise_opts_opts();
126 our $supplementary_message = '';
127 our $need_split_build_invocation = 0;
128 our $split_brain = 0;
132 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
135 our $remotename = 'dgit';
136 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
141 my ($v,$distro) = @_;
142 return $tagformatfn->($v, $distro);
145 sub debiantag_maintview ($$) {
146 my ($v,$distro) = @_;
151 sub lbranch () { return "$branchprefix/$csuite"; }
152 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
153 sub lref () { return "refs/heads/".lbranch(); }
154 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
155 sub rrref () { return server_ref($csuite); }
157 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
158 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
168 return "${package}_".(stripepoch $vsn).$sfx
173 return srcfn($vsn,".dsc");
176 sub changespat ($;$) {
177 my ($vsn, $arch) = @_;
178 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
187 foreach my $f (@end) {
189 print STDERR "$us: cleanup: $@" if length $@;
193 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
195 sub no_such_package () {
196 print STDERR "$us: package $package does not exist in suite $isuite\n";
202 printdebug "CD $newdir\n";
203 chdir $newdir or die "chdir: $newdir: $!";
206 sub deliberately ($) {
208 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
211 sub deliberately_not_fast_forward () {
212 foreach (qw(not-fast-forward fresh-repo)) {
213 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
217 sub quiltmode_splitbrain () {
218 $quilt_mode =~ m/gbp|dpm|unapplied/;
221 #---------- remote protocol support, common ----------
223 # remote push initiator/responder protocol:
224 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
225 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
226 # < dgit-remote-push-ready <actual-proto-vsn>
233 # > supplementary-message NBYTES # $protovsn >= 3
238 # > file parsed-changelog
239 # [indicates that output of dpkg-parsechangelog follows]
240 # > data-block NBYTES
241 # > [NBYTES bytes of data (no newline)]
242 # [maybe some more blocks]
251 # > param head DGIT-VIEW-HEAD
252 # > param csuite SUITE
253 # > param tagformat old|new
254 # > param maint-view MAINT-VIEW-HEAD
256 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
257 # # goes into tag, for replay prevention
260 # [indicates that signed tag is wanted]
261 # < data-block NBYTES
262 # < [NBYTES bytes of data (no newline)]
263 # [maybe some more blocks]
267 # > want signed-dsc-changes
268 # < data-block NBYTES [transfer of signed dsc]
270 # < data-block NBYTES [transfer of signed changes]
278 sub i_child_report () {
279 # Sees if our child has died, and reap it if so. Returns a string
280 # describing how it died if it failed, or undef otherwise.
281 return undef unless $i_child_pid;
282 my $got = waitpid $i_child_pid, WNOHANG;
283 return undef if $got <= 0;
284 die unless $got == $i_child_pid;
285 $i_child_pid = undef;
286 return undef unless $?;
287 return "build host child ".waitstatusmsg();
292 fail "connection lost: $!" if $fh->error;
293 fail "protocol violation; $m not expected";
296 sub badproto_badread ($$) {
298 fail "connection lost: $!" if $!;
299 my $report = i_child_report();
300 fail $report if defined $report;
301 badproto $fh, "eof (reading $wh)";
304 sub protocol_expect (&$) {
305 my ($match, $fh) = @_;
308 defined && chomp or badproto_badread $fh, "protocol message";
316 badproto $fh, "\`$_'";
319 sub protocol_send_file ($$) {
320 my ($fh, $ourfn) = @_;
321 open PF, "<", $ourfn or die "$ourfn: $!";
324 my $got = read PF, $d, 65536;
325 die "$ourfn: $!" unless defined $got;
327 print $fh "data-block ".length($d)."\n" or die $!;
328 print $fh $d or die $!;
330 PF->error and die "$ourfn $!";
331 print $fh "data-end\n" or die $!;
335 sub protocol_read_bytes ($$) {
336 my ($fh, $nbytes) = @_;
337 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
339 my $got = read $fh, $d, $nbytes;
340 $got==$nbytes or badproto_badread $fh, "data block";
344 sub protocol_receive_file ($$) {
345 my ($fh, $ourfn) = @_;
346 printdebug "() $ourfn\n";
347 open PF, ">", $ourfn or die "$ourfn: $!";
349 my ($y,$l) = protocol_expect {
350 m/^data-block (.*)$/ ? (1,$1) :
351 m/^data-end$/ ? (0,) :
355 my $d = protocol_read_bytes $fh, $l;
356 print PF $d or die $!;
361 #---------- remote protocol support, responder ----------
363 sub responder_send_command ($) {
365 return unless $we_are_responder;
366 # called even without $we_are_responder
367 printdebug ">> $command\n";
368 print PO $command, "\n" or die $!;
371 sub responder_send_file ($$) {
372 my ($keyword, $ourfn) = @_;
373 return unless $we_are_responder;
374 printdebug "]] $keyword $ourfn\n";
375 responder_send_command "file $keyword";
376 protocol_send_file \*PO, $ourfn;
379 sub responder_receive_files ($@) {
380 my ($keyword, @ourfns) = @_;
381 die unless $we_are_responder;
382 printdebug "[[ $keyword @ourfns\n";
383 responder_send_command "want $keyword";
384 foreach my $fn (@ourfns) {
385 protocol_receive_file \*PI, $fn;
388 protocol_expect { m/^files-end$/ } \*PI;
391 #---------- remote protocol support, initiator ----------
393 sub initiator_expect (&) {
395 protocol_expect { &$match } \*RO;
398 #---------- end remote code ----------
401 if ($we_are_responder) {
403 responder_send_command "progress ".length($m) or die $!;
404 print PO $m or die $!;
414 $ua = LWP::UserAgent->new();
418 progress "downloading $what...";
419 my $r = $ua->get(@_) or die $!;
420 return undef if $r->code == 404;
421 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
422 return $r->decoded_content(charset => 'none');
425 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
430 failedcmd @_ if system @_;
433 sub act_local () { return $dryrun_level <= 1; }
434 sub act_scary () { return !$dryrun_level; }
437 if (!$dryrun_level) {
438 progress "dgit ok: @_";
440 progress "would be ok: @_ (but dry run only)";
445 printcmd(\*STDERR,$debugprefix."#",@_);
448 sub runcmd_ordryrun {
456 sub runcmd_ordryrun_local {
465 my ($first_shell, @cmd) = @_;
466 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
469 our $helpmsg = <<END;
471 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
472 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
473 dgit [dgit-opts] build [dpkg-buildpackage-opts]
474 dgit [dgit-opts] sbuild [sbuild-opts]
475 dgit [dgit-opts] push [dgit-opts] [suite]
476 dgit [dgit-opts] rpush build-host:build-dir ...
477 important dgit options:
478 -k<keyid> sign tag and package with <keyid> instead of default
479 --dry-run -n do not change anything, but go through the motions
480 --damp-run -L like --dry-run but make local changes, without signing
481 --new -N allow introducing a new package
482 --debug -D increase debug level
483 -c<name>=<value> set git config option (used directly by dgit too)
486 our $later_warning_msg = <<END;
487 Perhaps the upload is stuck in incoming. Using the version from git.
491 print STDERR "$us: @_\n", $helpmsg or die $!;
496 @ARGV or badusage "too few arguments";
497 return scalar shift @ARGV;
501 print $helpmsg or die $!;
505 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
507 our %defcfg = ('dgit.default.distro' => 'debian',
508 'dgit.default.username' => '',
509 'dgit.default.archive-query-default-component' => 'main',
510 'dgit.default.ssh' => 'ssh',
511 'dgit.default.archive-query' => 'madison:',
512 'dgit.default.sshpsql-dbname' => 'service=projectb',
513 'dgit.default.dgit-tag-format' => 'old,new,maint',
514 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
515 'dgit-distro.debian.git-check' => 'url',
516 'dgit-distro.debian.git-check-suffix' => '/info/refs',
517 'dgit-distro.debian.new-private-pushers' => 't',
518 'dgit-distro.debian.dgit-tag-format' => 'old',
519 'dgit-distro.debian/push.git-url' => '',
520 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
521 'dgit-distro.debian/push.git-user-force' => 'dgit',
522 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
523 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
524 'dgit-distro.debian/push.git-create' => 'true',
525 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
526 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
527 # 'dgit-distro.debian.archive-query-tls-key',
528 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
529 # ^ this does not work because curl is broken nowadays
530 # Fixing #790093 properly will involve providing providing the key
531 # in some pacagke and maybe updating these paths.
533 # 'dgit-distro.debian.archive-query-tls-curl-args',
534 # '--ca-path=/etc/ssl/ca-debian',
535 # ^ this is a workaround but works (only) on DSA-administered machines
536 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
537 'dgit-distro.debian.git-url-suffix' => '',
538 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
539 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
540 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
541 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
542 'dgit-distro.ubuntu.git-check' => 'false',
543 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
544 'dgit-distro.test-dummy.ssh' => "$td/ssh",
545 'dgit-distro.test-dummy.username' => "alice",
546 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
547 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
548 'dgit-distro.test-dummy.git-url' => "$td/git",
549 'dgit-distro.test-dummy.git-host' => "git",
550 'dgit-distro.test-dummy.git-path' => "$td/git",
551 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
552 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
553 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
554 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
559 sub git_slurp_config () {
560 local ($debuglevel) = $debuglevel-2;
563 my @cmd = (@git, qw(config -z --get-regexp .*));
566 open GITS, "-|", @cmd or die $!;
569 printdebug "=> ", (messagequote $_), "\n";
571 push @{ $gitcfg{$`} }, $'; #';
575 or ($!==0 && $?==256)
579 sub git_get_config ($) {
582 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
585 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
591 return undef if $c =~ /RETURN-UNDEF/;
592 my $v = git_get_config($c);
593 return $v if defined $v;
594 my $dv = $defcfg{$c};
595 return $dv if defined $dv;
597 badcfg "need value for one of: @_\n".
598 "$us: distro or suite appears not to be (properly) supported";
601 sub access_basedistro () {
602 if (defined $idistro) {
605 return cfg("dgit-suite.$isuite.distro",
606 "dgit.default.distro");
610 sub access_quirk () {
611 # returns (quirk name, distro to use instead or undef, quirk-specific info)
612 my $basedistro = access_basedistro();
613 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
615 if (defined $backports_quirk) {
616 my $re = $backports_quirk;
617 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
619 $re =~ s/\%/([-0-9a-z_]+)/
620 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
621 if ($isuite =~ m/^$re$/) {
622 return ('backports',"$basedistro-backports",$1);
625 return ('none',undef);
630 sub parse_cfg_bool ($$$) {
631 my ($what,$def,$v) = @_;
634 $v =~ m/^[ty1]/ ? 1 :
635 $v =~ m/^[fn0]/ ? 0 :
636 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
639 sub access_forpush_config () {
640 my $d = access_basedistro();
644 parse_cfg_bool('new-private-pushers', 0,
645 cfg("dgit-distro.$d.new-private-pushers",
648 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
651 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
652 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
653 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
654 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
657 sub access_forpush () {
658 $access_forpush //= access_forpush_config();
659 return $access_forpush;
663 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
664 badcfg "pushing but distro is configured readonly"
665 if access_forpush_config() eq '0';
667 $supplementary_message = <<'END' unless $we_are_responder;
668 Push failed, before we got started.
669 You can retry the push, after fixing the problem, if you like.
671 finalise_opts_opts();
675 finalise_opts_opts();
678 sub supplementary_message ($) {
680 if (!$we_are_responder) {
681 $supplementary_message = $msg;
683 } elsif ($protovsn >= 3) {
684 responder_send_command "supplementary-message ".length($msg)
686 print PO $msg or die $!;
690 sub access_distros () {
691 # Returns list of distros to try, in order
694 # 0. `instead of' distro name(s) we have been pointed to
695 # 1. the access_quirk distro, if any
696 # 2a. the user's specified distro, or failing that } basedistro
697 # 2b. the distro calculated from the suite }
698 my @l = access_basedistro();
700 my (undef,$quirkdistro) = access_quirk();
701 unshift @l, $quirkdistro;
702 unshift @l, $instead_distro;
703 @l = grep { defined } @l;
705 if (access_forpush()) {
706 @l = map { ("$_/push", $_) } @l;
711 sub access_cfg_cfgs (@) {
714 # The nesting of these loops determines the search order. We put
715 # the key loop on the outside so that we search all the distros
716 # for each key, before going on to the next key. That means that
717 # if access_cfg is called with a more specific, and then a less
718 # specific, key, an earlier distro can override the less specific
719 # without necessarily overriding any more specific keys. (If the
720 # distro wants to override the more specific keys it can simply do
721 # so; whereas if we did the loop the other way around, it would be
722 # impossible to for an earlier distro to override a less specific
723 # key but not the more specific ones without restating the unknown
724 # values of the more specific keys.
727 # We have to deal with RETURN-UNDEF specially, so that we don't
728 # terminate the search prematurely.
730 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
733 foreach my $d (access_distros()) {
734 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
736 push @cfgs, map { "dgit.default.$_" } @realkeys;
743 my (@cfgs) = access_cfg_cfgs(@keys);
744 my $value = cfg(@cfgs);
748 sub access_cfg_bool ($$) {
749 my ($def, @keys) = @_;
750 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
753 sub string_to_ssh ($) {
755 if ($spec =~ m/\s/) {
756 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
762 sub access_cfg_ssh () {
763 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
764 if (!defined $gitssh) {
767 return string_to_ssh $gitssh;
771 sub access_runeinfo ($) {
773 return ": dgit ".access_basedistro()." $info ;";
776 sub access_someuserhost ($) {
778 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
779 defined($user) && length($user) or
780 $user = access_cfg("$some-user",'username');
781 my $host = access_cfg("$some-host");
782 return length($user) ? "$user\@$host" : $host;
785 sub access_gituserhost () {
786 return access_someuserhost('git');
789 sub access_giturl (;$) {
791 my $url = access_cfg('git-url','RETURN-UNDEF');
794 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
795 return undef unless defined $proto;
798 access_gituserhost().
799 access_cfg('git-path');
801 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
804 return "$url/$package$suffix";
807 sub parsecontrolfh ($$;$) {
808 my ($fh, $desc, $allowsigned) = @_;
809 our $dpkgcontrolhash_noissigned;
812 my %opts = ('name' => $desc);
813 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
814 $c = Dpkg::Control::Hash->new(%opts);
815 $c->parse($fh,$desc) or die "parsing of $desc failed";
816 last if $allowsigned;
817 last if $dpkgcontrolhash_noissigned;
818 my $issigned= $c->get_option('is_pgp_signed');
819 if (!defined $issigned) {
820 $dpkgcontrolhash_noissigned= 1;
821 seek $fh, 0,0 or die "seek $desc: $!";
822 } elsif ($issigned) {
823 fail "control file $desc is (already) PGP-signed. ".
824 " Note that dgit push needs to modify the .dsc and then".
825 " do the signature itself";
834 my ($file, $desc) = @_;
835 my $fh = new IO::Handle;
836 open $fh, '<', $file or die "$file: $!";
837 my $c = parsecontrolfh($fh,$desc);
838 $fh->error and die $!;
844 my ($dctrl,$field) = @_;
845 my $v = $dctrl->{$field};
846 return $v if defined $v;
847 fail "missing field $field in ".$v->get_option('name');
851 my $c = Dpkg::Control::Hash->new();
852 my $p = new IO::Handle;
853 my @cmd = (qw(dpkg-parsechangelog), @_);
854 open $p, '-|', @cmd or die $!;
856 $?=0; $!=0; close $p or failedcmd @cmd;
862 defined $d or fail "getcwd failed: $!";
868 sub archive_query ($) {
870 my $query = access_cfg('archive-query','RETURN-UNDEF');
871 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
874 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
877 sub pool_dsc_subpath ($$) {
878 my ($vsn,$component) = @_; # $package is implict arg
879 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
880 return "/pool/$component/$prefix/$package/".dscfn($vsn);
883 #---------- `ftpmasterapi' archive query method (nascent) ----------
885 sub archive_api_query_cmd ($) {
887 my @cmd = qw(curl -sS);
888 my $url = access_cfg('archive-query-url');
889 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
891 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
892 foreach my $key (split /\:/, $keys) {
893 $key =~ s/\%HOST\%/$host/g;
895 fail "for $url: stat $key: $!" unless $!==ENOENT;
898 fail "config requested specific TLS key but do not know".
899 " how to get curl to use exactly that EE key ($key)";
900 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
901 # # Sadly the above line does not work because of changes
902 # # to gnutls. The real fix for #790093 may involve
903 # # new curl options.
906 # Fixing #790093 properly will involve providing a value
907 # for this on clients.
908 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
909 push @cmd, split / /, $kargs if defined $kargs;
911 push @cmd, $url.$subpath;
917 my ($data, $subpath) = @_;
918 badcfg "ftpmasterapi archive query method takes no data part"
920 my @cmd = archive_api_query_cmd($subpath);
921 my $json = cmdoutput @cmd;
922 return decode_json($json);
925 sub canonicalise_suite_ftpmasterapi () {
926 my ($proto,$data) = @_;
927 my $suites = api_query($data, 'suites');
929 foreach my $entry (@$suites) {
931 my $v = $entry->{$_};
932 defined $v && $v eq $isuite;
934 push @matched, $entry;
936 fail "unknown suite $isuite" unless @matched;
939 @matched==1 or die "multiple matches for suite $isuite\n";
940 $cn = "$matched[0]{codename}";
941 defined $cn or die "suite $isuite info has no codename\n";
942 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
944 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
949 sub archive_query_ftpmasterapi () {
950 my ($proto,$data) = @_;
951 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
953 my $digester = Digest::SHA->new(256);
954 foreach my $entry (@$info) {
956 my $vsn = "$entry->{version}";
957 my ($ok,$msg) = version_check $vsn;
958 die "bad version: $msg\n" unless $ok;
959 my $component = "$entry->{component}";
960 $component =~ m/^$component_re$/ or die "bad component";
961 my $filename = "$entry->{filename}";
962 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
963 or die "bad filename";
964 my $sha256sum = "$entry->{sha256sum}";
965 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
966 push @rows, [ $vsn, "/pool/$component/$filename",
967 $digester, $sha256sum ];
969 die "bad ftpmaster api response: $@\n".Dumper($entry)
972 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
976 #---------- `madison' archive query method ----------
978 sub archive_query_madison {
979 return map { [ @$_[0..1] ] } madison_get_parse(@_);
982 sub madison_get_parse {
983 my ($proto,$data) = @_;
984 die unless $proto eq 'madison';
986 $data= access_cfg('madison-distro','RETURN-UNDEF');
987 $data //= access_basedistro();
989 $rmad{$proto,$data,$package} ||= cmdoutput
990 qw(rmadison -asource),"-s$isuite","-u$data",$package;
991 my $rmad = $rmad{$proto,$data,$package};
994 foreach my $l (split /\n/, $rmad) {
995 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
996 \s*( [^ \t|]+ )\s* \|
997 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
998 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
999 $1 eq $package or die "$rmad $package ?";
1006 $component = access_cfg('archive-query-default-component');
1008 $5 eq 'source' or die "$rmad ?";
1009 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1011 return sort { -version_compare($a->[0],$b->[0]); } @out;
1014 sub canonicalise_suite_madison {
1015 # madison canonicalises for us
1016 my @r = madison_get_parse(@_);
1018 "unable to canonicalise suite using package $package".
1019 " which does not appear to exist in suite $isuite;".
1020 " --existing-package may help";
1024 #---------- `sshpsql' archive query method ----------
1027 my ($data,$runeinfo,$sql) = @_;
1028 if (!length $data) {
1029 $data= access_someuserhost('sshpsql').':'.
1030 access_cfg('sshpsql-dbname');
1032 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1033 my ($userhost,$dbname) = ($`,$'); #';
1035 my @cmd = (access_cfg_ssh, $userhost,
1036 access_runeinfo("ssh-psql $runeinfo").
1037 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1038 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1040 open P, "-|", @cmd or die $!;
1043 printdebug(">|$_|\n");
1046 $!=0; $?=0; close P or failedcmd @cmd;
1048 my $nrows = pop @rows;
1049 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1050 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1051 @rows = map { [ split /\|/, $_ ] } @rows;
1052 my $ncols = scalar @{ shift @rows };
1053 die if grep { scalar @$_ != $ncols } @rows;
1057 sub sql_injection_check {
1058 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1061 sub archive_query_sshpsql ($$) {
1062 my ($proto,$data) = @_;
1063 sql_injection_check $isuite, $package;
1064 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1065 SELECT source.version, component.name, files.filename, files.sha256sum
1067 JOIN src_associations ON source.id = src_associations.source
1068 JOIN suite ON suite.id = src_associations.suite
1069 JOIN dsc_files ON dsc_files.source = source.id
1070 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1071 JOIN component ON component.id = files_archive_map.component_id
1072 JOIN files ON files.id = dsc_files.file
1073 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1074 AND source.source='$package'
1075 AND files.filename LIKE '%.dsc';
1077 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1078 my $digester = Digest::SHA->new(256);
1080 my ($vsn,$component,$filename,$sha256sum) = @$_;
1081 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1086 sub canonicalise_suite_sshpsql ($$) {
1087 my ($proto,$data) = @_;
1088 sql_injection_check $isuite;
1089 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1090 SELECT suite.codename
1091 FROM suite where suite_name='$isuite' or codename='$isuite';
1093 @rows = map { $_->[0] } @rows;
1094 fail "unknown suite $isuite" unless @rows;
1095 die "ambiguous $isuite: @rows ?" if @rows>1;
1099 #---------- `dummycat' archive query method ----------
1101 sub canonicalise_suite_dummycat ($$) {
1102 my ($proto,$data) = @_;
1103 my $dpath = "$data/suite.$isuite";
1104 if (!open C, "<", $dpath) {
1105 $!==ENOENT or die "$dpath: $!";
1106 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1110 chomp or die "$dpath: $!";
1112 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1116 sub archive_query_dummycat ($$) {
1117 my ($proto,$data) = @_;
1118 canonicalise_suite();
1119 my $dpath = "$data/package.$csuite.$package";
1120 if (!open C, "<", $dpath) {
1121 $!==ENOENT or die "$dpath: $!";
1122 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1130 printdebug "dummycat query $csuite $package $dpath | $_\n";
1131 my @row = split /\s+/, $_;
1132 @row==2 or die "$dpath: $_ ?";
1135 C->error and die "$dpath: $!";
1137 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1140 #---------- tag format handling ----------
1142 sub access_cfg_tagformats () {
1143 split /\,/, access_cfg('dgit-tag-format');
1146 sub need_tagformat ($$) {
1147 my ($fmt, $why) = @_;
1148 fail "need to use tag format $fmt ($why) but also need".
1149 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1150 " - no way to proceed"
1151 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1152 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1155 sub select_tagformat () {
1157 return if $tagformatfn && !$tagformat_want;
1158 die 'bug' if $tagformatfn && $tagformat_want;
1159 # ... $tagformat_want assigned after previous select_tagformat
1161 my (@supported) = grep { $_ ne 'maint' } access_cfg_tagformats();
1162 printdebug "select_tagformat supported @supported\n";
1164 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1165 printdebug "select_tagformat specified @$tagformat_want\n";
1167 my ($fmt,$why,$override) = @$tagformat_want;
1169 fail "target distro supports tag formats @supported".
1170 " but have to use $fmt ($why)"
1172 or grep { $_ eq $fmt } @supported;
1174 $tagformat_want = undef;
1176 $tagformatfn = ${*::}{"debiantag_$fmt"};
1178 fail "trying to use unknown tag format \`$fmt' ($why) !"
1179 unless $tagformatfn;
1182 #---------- archive query entrypoints and rest of program ----------
1184 sub canonicalise_suite () {
1185 return if defined $csuite;
1186 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1187 $csuite = archive_query('canonicalise_suite');
1188 if ($isuite ne $csuite) {
1189 progress "canonical suite name for $isuite is $csuite";
1193 sub get_archive_dsc () {
1194 canonicalise_suite();
1195 my @vsns = archive_query('archive_query');
1196 foreach my $vinfo (@vsns) {
1197 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1198 $dscurl = access_cfg('mirror').$subpath;
1199 $dscdata = url_get($dscurl);
1201 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1206 $digester->add($dscdata);
1207 my $got = $digester->hexdigest();
1209 fail "$dscurl has hash $got but".
1210 " archive told us to expect $digest";
1212 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1213 printdebug Dumper($dscdata) if $debuglevel>1;
1214 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1215 printdebug Dumper($dsc) if $debuglevel>1;
1216 my $fmt = getfield $dsc, 'Format';
1217 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1218 $dsc_checked = !!$digester;
1219 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1223 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1226 sub check_for_git ();
1227 sub check_for_git () {
1229 my $how = access_cfg('git-check');
1230 if ($how eq 'ssh-cmd') {
1232 (access_cfg_ssh, access_gituserhost(),
1233 access_runeinfo("git-check $package").
1234 " set -e; cd ".access_cfg('git-path').";".
1235 " if test -d $package.git; then echo 1; else echo 0; fi");
1236 my $r= cmdoutput @cmd;
1237 if (defined $r and $r =~ m/^divert (\w+)$/) {
1239 my ($usedistro,) = access_distros();
1240 # NB that if we are pushing, $usedistro will be $distro/push
1241 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1242 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1243 progress "diverting to $divert (using config for $instead_distro)";
1244 return check_for_git();
1246 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1248 } elsif ($how eq 'url') {
1249 my $prefix = access_cfg('git-check-url','git-url');
1250 my $suffix = access_cfg('git-check-suffix','git-suffix',
1251 'RETURN-UNDEF') // '.git';
1252 my $url = "$prefix/$package$suffix";
1253 my @cmd = (qw(curl -sS -I), $url);
1254 my $result = cmdoutput @cmd;
1255 $result =~ s/^\S+ 200 .*\n\r?\n//;
1256 # curl -sS -I with https_proxy prints
1257 # HTTP/1.0 200 Connection established
1258 $result =~ m/^\S+ (404|200) /s or
1259 fail "unexpected results from git check query - ".
1260 Dumper($prefix, $result);
1262 if ($code eq '404') {
1264 } elsif ($code eq '200') {
1269 } elsif ($how eq 'true') {
1271 } elsif ($how eq 'false') {
1274 badcfg "unknown git-check \`$how'";
1278 sub create_remote_git_repo () {
1279 my $how = access_cfg('git-create');
1280 if ($how eq 'ssh-cmd') {
1282 (access_cfg_ssh, access_gituserhost(),
1283 access_runeinfo("git-create $package").
1284 "set -e; cd ".access_cfg('git-path').";".
1285 " cp -a _template $package.git");
1286 } elsif ($how eq 'true') {
1289 badcfg "unknown git-create \`$how'";
1293 our ($dsc_hash,$lastpush_mergeinput);
1295 our $ud = '.git/dgit/unpack';
1305 sub mktree_in_ud_here () {
1306 runcmd qw(git init -q);
1307 rmtree('.git/objects');
1308 symlink '../../../../objects','.git/objects' or die $!;
1311 sub git_write_tree () {
1312 my $tree = cmdoutput @git, qw(write-tree);
1313 $tree =~ m/^\w+$/ or die "$tree ?";
1317 sub remove_stray_gits () {
1318 my @gitscmd = qw(find -name .git -prune -print0);
1319 debugcmd "|",@gitscmd;
1320 open GITS, "-|", @gitscmd or die $!;
1325 print STDERR "$us: warning: removing from source package: ",
1326 (messagequote $_), "\n";
1330 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1333 sub mktree_in_ud_from_only_subdir () {
1334 # changes into the subdir
1336 die "@dirs ?" unless @dirs==1;
1337 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1341 remove_stray_gits();
1342 mktree_in_ud_here();
1343 my ($format, $fopts) = get_source_format();
1344 if (madformat($format)) {
1347 runcmd @git, qw(add -Af);
1348 my $tree=git_write_tree();
1349 return ($tree,$dir);
1352 sub dsc_files_info () {
1353 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1354 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1355 ['Files', 'Digest::MD5', 'new()']) {
1356 my ($fname, $module, $method) = @$csumi;
1357 my $field = $dsc->{$fname};
1358 next unless defined $field;
1359 eval "use $module; 1;" or die $@;
1361 foreach (split /\n/, $field) {
1363 m/^(\w+) (\d+) (\S+)$/ or
1364 fail "could not parse .dsc $fname line \`$_'";
1365 my $digester = eval "$module"."->$method;" or die $@;
1370 Digester => $digester,
1375 fail "missing any supported Checksums-* or Files field in ".
1376 $dsc->get_option('name');
1380 map { $_->{Filename} } dsc_files_info();
1383 sub is_orig_file ($;$) {
1386 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1387 defined $base or return 1;
1391 sub make_commit ($) {
1393 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1396 sub clogp_authline ($) {
1398 my $author = getfield $clogp, 'Maintainer';
1399 $author =~ s#,.*##ms;
1400 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1401 my $authline = "$author $date";
1402 $authline =~ m/$git_authline_re/o or
1403 fail "unexpected commit author line format \`$authline'".
1404 " (was generated from changelog Maintainer field)";
1405 return ($1,$2,$3) if wantarray;
1409 sub vendor_patches_distro ($$) {
1410 my ($checkdistro, $what) = @_;
1411 return unless defined $checkdistro;
1413 my $series = "debian/patches/\L$checkdistro\E.series";
1414 printdebug "checking for vendor-specific $series ($what)\n";
1416 if (!open SERIES, "<", $series) {
1417 die "$series $!" unless $!==ENOENT;
1426 Unfortunately, this source package uses a feature of dpkg-source where
1427 the same source package unpacks to different source code on different
1428 distros. dgit cannot safely operate on such packages on affected
1429 distros, because the meaning of source packages is not stable.
1431 Please ask the distro/maintainer to remove the distro-specific series
1432 files and use a different technique (if necessary, uploading actually
1433 different packages, if different distros are supposed to have
1437 fail "Found active distro-specific series file for".
1438 " $checkdistro ($what): $series, cannot continue";
1440 die "$series $!" if SERIES->error;
1444 sub check_for_vendor_patches () {
1445 # This dpkg-source feature doesn't seem to be documented anywhere!
1446 # But it can be found in the changelog (reformatted):
1448 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1449 # Author: Raphael Hertzog <hertzog@debian.org>
1450 # Date: Sun Oct 3 09:36:48 2010 +0200
1452 # dpkg-source: correctly create .pc/.quilt_series with alternate
1455 # If you have debian/patches/ubuntu.series and you were
1456 # unpacking the source package on ubuntu, quilt was still
1457 # directed to debian/patches/series instead of
1458 # debian/patches/ubuntu.series.
1460 # debian/changelog | 3 +++
1461 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1462 # 2 files changed, 6 insertions(+), 1 deletion(-)
1465 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1466 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1467 "Dpkg::Vendor \`current vendor'");
1468 vendor_patches_distro(access_basedistro(),
1469 "distro being accessed");
1472 sub generate_commits_from_dsc () {
1473 # See big comment in fetch_from_archive, below.
1477 foreach my $fi (dsc_files_info()) {
1478 my $f = $fi->{Filename};
1479 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1481 link_ltarget "../../../$f", $f
1485 complete_file_from_dsc('.', $fi)
1488 if (is_orig_file($f)) {
1489 link $f, "../../../../$f"
1495 my $dscfn = "$package.dsc";
1497 open D, ">", $dscfn or die "$dscfn: $!";
1498 print D $dscdata or die "$dscfn: $!";
1499 close D or die "$dscfn: $!";
1500 my @cmd = qw(dpkg-source);
1501 push @cmd, '--no-check' if $dsc_checked;
1502 push @cmd, qw(-x --), $dscfn;
1505 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1506 check_for_vendor_patches() if madformat($dsc->{format});
1507 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1508 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1509 my $authline = clogp_authline $clogp;
1510 my $changes = getfield $clogp, 'Changes';
1511 open C, ">../commit.tmp" or die $!;
1512 print C <<END or die $!;
1519 # imported from the archive
1522 my $rawimport_hash = make_commit qw(../commit.tmp);
1523 my $cversion = getfield $clogp, 'Version';
1524 my $rawimport_mergeinput = {
1525 Commit => $rawimport_hash,
1526 Info => "Import of source package",
1528 my @output = ($rawimport_mergeinput);
1529 progress "synthesised git commit from .dsc $cversion";
1530 if ($lastpush_mergeinput) {
1531 my $lastpush_hash = $lastpush_mergeinput->{Commit};
1532 runcmd @git, qw(reset -q --hard), $lastpush_hash;
1533 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1534 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1535 my $oversion = getfield $oldclogp, 'Version';
1537 version_compare($oversion, $cversion);
1539 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1540 { Message => <<END, ReverseParents => 1 });
1541 Record $package ($cversion) in archive suite $csuite
1543 } elsif ($vcmp > 0) {
1544 print STDERR <<END or die $!;
1546 Version actually in archive: $cversion (older)
1547 Last version pushed with dgit: $oversion (newer or same)
1550 @output = $lastpush_mergeinput;
1552 @output = $lastpush_mergeinput;
1555 changedir '../../../..';
1560 sub complete_file_from_dsc ($$) {
1561 our ($dstdir, $fi) = @_;
1562 # Ensures that we have, in $dir, the file $fi, with the correct
1563 # contents. (Downloading it from alongside $dscurl if necessary.)
1565 my $f = $fi->{Filename};
1566 my $tf = "$dstdir/$f";
1569 if (stat_exists $tf) {
1570 progress "using existing $f";
1573 $furl =~ s{/[^/]+$}{};
1575 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1576 die "$f ?" if $f =~ m#/#;
1577 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1578 return 0 if !act_local();
1582 open F, "<", "$tf" or die "$tf: $!";
1583 $fi->{Digester}->reset();
1584 $fi->{Digester}->addfile(*F);
1585 F->error and die $!;
1586 my $got = $fi->{Digester}->hexdigest();
1587 $got eq $fi->{Hash} or
1588 fail "file $f has hash $got but .dsc".
1589 " demands hash $fi->{Hash} ".
1590 ($downloaded ? "(got wrong file from archive!)"
1591 : "(perhaps you should delete this file?)");
1596 sub ensure_we_have_orig () {
1597 foreach my $fi (dsc_files_info()) {
1598 my $f = $fi->{Filename};
1599 next unless is_orig_file($f);
1600 complete_file_from_dsc('..', $fi)
1605 sub git_fetch_us () {
1607 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1608 qw(tags heads), $branchprefix;
1609 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1612 my @tagpats = debiantags('*',access_basedistro);
1614 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1615 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1616 printdebug "currently $fullrefname=$objid\n";
1617 $here{$fullrefname} = $objid;
1619 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1620 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1621 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1622 printdebug "offered $lref=$objid\n";
1623 if (!defined $here{$lref}) {
1624 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1625 runcmd_ordryrun_local @upd;
1626 } elsif ($here{$lref} eq $objid) {
1629 "Not updateting $lref from $here{$lref} to $objid.\n";
1634 sub mergeinfo_getclogp ($) {
1636 # Ensures thit $mi->{Clogp} exists and returns it
1637 return $mi->{Clogp} if $mi->{Clogp};
1638 my $mclog = ".git/dgit/clog-$mi->{Commit}";
1640 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1641 "$mi->{Commit}:debian/changelog";
1642 $mi->{Clogp} = parsechangelog("-l$mclog");
1645 sub mergeinfo_version ($) {
1646 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1649 sub fetch_from_archive () {
1650 # ensures that lrref() is what is actually in the archive,
1651 # one way or another
1655 foreach my $field (@ourdscfield) {
1656 $dsc_hash = $dsc->{$field};
1657 last if defined $dsc_hash;
1659 if (defined $dsc_hash) {
1660 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1662 progress "last upload to archive specified git hash";
1664 progress "last upload to archive has NO git hash";
1667 progress "no version available from the archive";
1670 # If the archive's .dsc has a Dgit field, there are three
1671 # relevant git commitids we need to choose between and/or merge
1673 # 1. $dsc_hash: the Dgit field from the archive
1674 # 2. $lastpush_hash: the suite branch on the dgit git server
1675 # 3. $lastfetch_hash: our local tracking brach for the suite
1677 # These may all be distinct and need not be in any fast forward
1680 # If the dsc was pushed to this suite, then the server suite
1681 # branch will have been updated; but it might have been pushed to
1682 # a different suite and copied by the archive. Conversely a more
1683 # recent version may have been pushed with dgit but not appeared
1684 # in the archive (yet).
1686 # $lastfetch_hash may be awkward because archive imports
1687 # (particularly, imports of Dgit-less .dscs) are performed only as
1688 # needed on individual clients, so different clients may perform a
1689 # different subset of them - and these imports are only made
1690 # public during push. So $lastfetch_hash may represent a set of
1691 # imports different to a subsequent upload by a different dgit
1694 # Our approach is as follows:
1696 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1697 # descendant of $dsc_hash, then it was pushed by a dgit user who
1698 # had based their work on $dsc_hash, so we should prefer it.
1699 # Otherwise, $dsc_hash was installed into this suite in the
1700 # archive other than by a dgit push, and (necessarily) after the
1701 # last dgit push into that suite (since a dgit push would have
1702 # been descended from the dgit server git branch); thus, in that
1703 # case, we prefer the archive's version (and produce a
1704 # pseudo-merge to overwrite the dgit server git branch).
1706 # (If there is no Dgit field in the archive's .dsc then
1707 # generate_commit_from_dsc uses the version numbers to decide
1708 # whether the suite branch or the archive is newer. If the suite
1709 # branch is newer it ignores the archive's .dsc; otherwise it
1710 # generates an import of the .dsc, and produces a pseudo-merge to
1711 # overwrite the suite branch with the archive contents.)
1713 # The outcome of that part of the algorithm is the `public view',
1714 # and is same for all dgit clients: it does not depend on any
1715 # unpublished history in the local tracking branch.
1717 # As between the public view and the local tracking branch: The
1718 # local tracking branch is only updated by dgit fetch, and
1719 # whenever dgit fetch runs it includes the public view in the
1720 # local tracking branch. Therefore if the public view is not
1721 # descended from the local tracking branch, the local tracking
1722 # branch must contain history which was imported from the archive
1723 # but never pushed; and, its tip is now out of date. So, we make
1724 # a pseudo-merge to overwrite the old imports and stitch the old
1727 # Finally: we do not necessarily reify the public view (as
1728 # described above). This is so that we do not end up stacking two
1729 # pseudo-merges. So what we actually do is figure out the inputs
1730 # to any public view psuedo-merge and put them in @mergeinputs.
1733 # $mergeinputs[]{Commit}
1734 # $mergeinputs[]{Info}
1735 # $mergeinputs[0] is the one whose tree we use
1736 # @mergeinputs is in the order we use in the actual commit)
1739 # $mergeinputs[]{Message} is a commit message to use
1740 # $mergeinputs[]{ReverseParents} if def specifies that parent
1741 # list should be in opposite order
1742 # Such an entry has no Commit or Info. It applies only when found
1743 # in the last entry. (This ugliness is to support making
1744 # identical imports to previous dgit versions.)
1746 my $lastpush_hash = git_get_ref(lrfetchref());
1747 printdebug "previous reference hash=$lastpush_hash\n";
1748 $lastpush_mergeinput = $lastpush_hash && {
1749 Commit => $lastpush_hash,
1750 Info => "dgit suite branch on dgit git server",
1753 my $lastfetch_hash = git_get_ref(lrref());
1754 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1755 my $lastfetch_mergeinput = $lastfetch_hash && {
1756 Commit => $lastfetch_hash,
1757 Info => "dgit client's archive history view",
1760 my $dsc_mergeinput = $dsc_hash && {
1761 Commit => $dsc_hash,
1762 Info => "Dgit field in .dsc from archive",
1765 if (defined $dsc_hash) {
1766 fail "missing remote git history even though dsc has hash -".
1767 " could not find ref ".rref()." at ".access_giturl()
1768 unless $lastpush_hash;
1769 ensure_we_have_orig();
1770 if ($dsc_hash eq $lastpush_hash) {
1771 @mergeinputs = $dsc_mergeinput
1772 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1773 print STDERR <<END or die $!;
1775 Git commit in archive is behind the last version allegedly pushed/uploaded.
1776 Commit referred to by archive: $dsc_hash
1777 Last version pushed with dgit: $lastpush_hash
1780 @mergeinputs = ($lastpush_mergeinput);
1782 # Archive has .dsc which is not a descendant of the last dgit
1783 # push. This can happen if the archive moves .dscs about.
1784 # Just follow its lead.
1785 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1786 progress "archive .dsc names newer git commit";
1787 @mergeinputs = ($dsc_mergeinput);
1789 progress "archive .dsc names other git commit, fixing up";
1790 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1794 @mergeinputs = generate_commits_from_dsc();
1795 # We have just done an import. Now, our import algorithm might
1796 # have been improved. But even so we do not want to generate
1797 # a new different import of the same package. So if the
1798 # version numbers are the same, just use our existing version.
1799 # If the version numbers are different, the archive has changed
1800 # (perhaps, rewound).
1801 if ($lastfetch_mergeinput &&
1802 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1803 (mergeinfo_version $mergeinputs[0]) )) {
1804 @mergeinputs = ($lastfetch_mergeinput);
1806 } elsif ($lastpush_hash) {
1807 # only in git, not in the archive yet
1808 @mergeinputs = ($lastpush_mergeinput);
1809 print STDERR <<END or die $!;
1811 Package not found in the archive, but has allegedly been pushed using dgit.
1815 printdebug "nothing found!\n";
1816 if (defined $skew_warning_vsn) {
1817 print STDERR <<END or die $!;
1819 Warning: relevant archive skew detected.
1820 Archive allegedly contains $skew_warning_vsn
1821 But we were not able to obtain any version from the archive or git.
1828 if ($lastfetch_hash &&
1830 my $h = $_->{Commit};
1831 $h and is_fast_fwd($lastfetch_hash, $h);
1832 # If true, one of the existing parents of this commit
1833 # is a descendant of the $lastfetch_hash, so we'll
1834 # be ff from that automatically.
1838 push @mergeinputs, $lastfetch_mergeinput;
1841 printdebug "fetch mergeinfos:\n";
1842 foreach my $mi (@mergeinputs) {
1844 printdebug " commit $mi->{Commit} $mi->{Info}\n";
1846 printdebug sprintf " ReverseParents=%d Message=%s",
1847 $mi->{ReverseParents}, $mi->{Message};
1851 my $compat_info= pop @mergeinputs
1852 if $mergeinputs[$#mergeinputs]{Message};
1854 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
1857 if (@mergeinputs > 1) {
1859 my $tree_commit = $mergeinputs[0]{Commit};
1861 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
1862 $tree =~ m/\n\n/; $tree = $`;
1863 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
1866 # We use the changelog author of the package in question the
1867 # author of this pseudo-merge. This is (roughly) correct if
1868 # this commit is simply representing aa non-dgit upload.
1869 # (Roughly because it does not record sponsorship - but we
1870 # don't have sponsorship info because that's in the .changes,
1871 # which isn't in the archivw.)
1873 # But, it might be that we are representing archive history
1874 # updates (including in-archive copies). These are not really
1875 # the responsibility of the person who created the .dsc, but
1876 # there is no-one whose name we should better use. (The
1877 # author of the .dsc-named commit is clearly worse.)
1879 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
1880 my $author = clogp_authline $useclogp;
1881 my $cversion = getfield $useclogp, 'Version';
1883 my $mcf = ".git/dgit/mergecommit";
1884 open MC, ">", $mcf or die "$mcf $!";
1885 print MC <<END or die $!;
1889 my @parents = grep { $_->{Commit} } @mergeinputs;
1890 @parents = reverse @parents if $compat_info->{ReverseParents};
1891 print MC <<END or die $! foreach @parents;
1895 print MC <<END or die $!;
1901 if (defined $compat_info->{Message}) {
1902 print MC $compat_info->{Message} or die $!;
1904 print MC <<END or die $!;
1905 Record $package ($cversion) in archive suite $csuite
1909 my $message_add_info = sub {
1911 my $mversion = mergeinfo_version $mi;
1912 printf MC " %-20s %s\n", $mversion, $mi->{Info}
1916 $message_add_info->($mergeinputs[0]);
1917 print MC <<END or die $!;
1918 should be treated as descended from
1920 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
1924 $hash = make_commit $mcf;
1926 $hash = $mergeinputs[0]{Commit};
1928 progress "fetch hash=$hash\n";
1931 my ($lasth, $what) = @_;
1932 return unless $lasth;
1933 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
1936 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
1937 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
1939 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
1940 'DGIT_ARCHIVE', $hash;
1941 cmdoutput @git, qw(log -n2), $hash;
1942 # ... gives git a chance to complain if our commit is malformed
1944 if (defined $skew_warning_vsn) {
1946 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1947 my $clogf = ".git/dgit/changelog.tmp";
1948 runcmd shell_cmd "exec >$clogf",
1949 @git, qw(cat-file blob), "$hash:debian/changelog";
1950 my $gotclogp = parsechangelog("-l$clogf");
1951 my $got_vsn = getfield $gotclogp, 'Version';
1952 printdebug "SKEW CHECK GOT $got_vsn\n";
1953 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1954 print STDERR <<END or die $!;
1956 Warning: archive skew detected. Using the available version:
1957 Archive allegedly contains $skew_warning_vsn
1958 We were able to obtain only $got_vsn
1964 if ($lastfetch_hash ne $hash) {
1965 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1969 dryrun_report @upd_cmd;
1975 sub set_local_git_config ($$) {
1977 runcmd @git, qw(config), $k, $v;
1980 sub setup_mergechangelogs (;$) {
1982 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1984 my $driver = 'dpkg-mergechangelogs';
1985 my $cb = "merge.$driver";
1986 my $attrs = '.git/info/attributes';
1987 ensuredir '.git/info';
1989 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1990 if (!open ATTRS, "<", $attrs) {
1991 $!==ENOENT or die "$attrs: $!";
1995 next if m{^debian/changelog\s};
1996 print NATTRS $_, "\n" or die $!;
1998 ATTRS->error and die $!;
2001 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2004 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2005 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2007 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2010 sub setup_useremail (;$) {
2012 return unless $always || access_cfg_bool(1, 'setup-useremail');
2015 my ($k, $envvar) = @_;
2016 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2017 return unless defined $v;
2018 set_local_git_config "user.$k", $v;
2021 $setup->('email', 'DEBEMAIL');
2022 $setup->('name', 'DEBFULLNAME');
2025 sub setup_new_tree () {
2026 setup_mergechangelogs();
2032 canonicalise_suite();
2033 badusage "dry run makes no sense with clone" unless act_local();
2034 my $hasgit = check_for_git();
2035 mkdir $dstdir or fail "create \`$dstdir': $!";
2037 runcmd @git, qw(init -q);
2038 my $giturl = access_giturl(1);
2039 if (defined $giturl) {
2040 open H, "> .git/HEAD" or die $!;
2041 print H "ref: ".lref()."\n" or die $!;
2043 runcmd @git, qw(remote add), 'origin', $giturl;
2046 progress "fetching existing git history";
2048 runcmd_ordryrun_local @git, qw(fetch origin);
2050 progress "starting new git history";
2052 fetch_from_archive() or no_such_package;
2053 my $vcsgiturl = $dsc->{'Vcs-Git'};
2054 if (length $vcsgiturl) {
2055 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2056 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2059 runcmd @git, qw(reset --hard), lrref();
2060 printdone "ready for work in $dstdir";
2064 if (check_for_git()) {
2067 fetch_from_archive() or no_such_package();
2068 printdone "fetched into ".lrref();
2073 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2075 printdone "fetched to ".lrref()." and merged into HEAD";
2078 sub check_not_dirty () {
2079 foreach my $f (qw(local-options local-patch-header)) {
2080 if (stat_exists "debian/source/$f") {
2081 fail "git tree contains debian/source/$f";
2085 return if $ignoredirty;
2087 my @cmd = (@git, qw(diff --quiet HEAD));
2089 $!=0; $?=-1; system @cmd;
2092 fail "working tree is dirty (does not match HEAD)";
2098 sub commit_admin ($) {
2101 runcmd_ordryrun_local @git, qw(commit -m), $m;
2104 sub commit_quilty_patch () {
2105 my $output = cmdoutput @git, qw(status --porcelain);
2107 foreach my $l (split /\n/, $output) {
2108 next unless $l =~ m/\S/;
2109 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2113 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2115 progress "nothing quilty to commit, ok.";
2118 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2119 runcmd_ordryrun_local @git, qw(add -f), @adds;
2120 commit_admin "Commit Debian 3.0 (quilt) metadata";
2123 sub get_source_format () {
2125 if (open F, "debian/source/options") {
2129 s/\s+$//; # ignore missing final newline
2131 my ($k, $v) = ($`, $'); #');
2132 $v =~ s/^"(.*)"$/$1/;
2138 F->error and die $!;
2141 die $! unless $!==&ENOENT;
2144 if (!open F, "debian/source/format") {
2145 die $! unless $!==&ENOENT;
2149 F->error and die $!;
2151 return ($_, \%options);
2156 return 0 unless $format eq '3.0 (quilt)';
2157 our $quilt_mode_warned;
2158 if ($quilt_mode eq 'nocheck') {
2159 progress "Not doing any fixup of \`$format' due to".
2160 " ----no-quilt-fixup or --quilt=nocheck"
2161 unless $quilt_mode_warned++;
2164 progress "Format \`$format', need to check/update patch stack"
2165 unless $quilt_mode_warned++;
2169 sub push_parse_changelog ($) {
2172 my $clogp = Dpkg::Control::Hash->new();
2173 $clogp->load($clogpfn) or die;
2175 $package = getfield $clogp, 'Source';
2176 my $cversion = getfield $clogp, 'Version';
2177 my $tag = debiantag($cversion, access_basedistro);
2178 runcmd @git, qw(check-ref-format), $tag;
2180 my $dscfn = dscfn($cversion);
2182 return ($clogp, $cversion, $dscfn);
2185 sub push_parse_dsc ($$$) {
2186 my ($dscfn,$dscfnwhat, $cversion) = @_;
2187 $dsc = parsecontrol($dscfn,$dscfnwhat);
2188 my $dversion = getfield $dsc, 'Version';
2189 my $dscpackage = getfield $dsc, 'Source';
2190 ($dscpackage eq $package && $dversion eq $cversion) or
2191 fail "$dscfn is for $dscpackage $dversion".
2192 " but debian/changelog is for $package $cversion";
2195 sub push_tagwants ($$$$) {
2196 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2199 TagFn => \&debiantag,
2204 if (defined $maintviewhead) {
2206 TagFn => \&debiantag_maintview,
2207 Objid => $maintviewhead,
2208 TfSuffix => '-maintview',
2212 foreach my $tw (@tagwants) {
2213 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2214 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2219 sub push_mktags ($$ $$ $) {
2221 $changesfile,$changesfilewhat,
2224 die unless $tagwants->[0]{View} eq 'dgit';
2226 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2227 $dsc->save("$dscfn.tmp") or die $!;
2229 my $changes = parsecontrol($changesfile,$changesfilewhat);
2230 foreach my $field (qw(Source Distribution Version)) {
2231 $changes->{$field} eq $clogp->{$field} or
2232 fail "changes field $field \`$changes->{$field}'".
2233 " does not match changelog \`$clogp->{$field}'";
2236 my $cversion = getfield $clogp, 'Version';
2237 my $clogsuite = getfield $clogp, 'Distribution';
2239 # We make the git tag by hand because (a) that makes it easier
2240 # to control the "tagger" (b) we can do remote signing
2241 my $authline = clogp_authline $clogp;
2242 my $delibs = join(" ", "",@deliberatelies);
2243 my $declaredistro = access_basedistro();
2247 my $tfn = $tw->{Tfn};
2248 my $head = $tw->{Objid};
2249 my $tag = $tw->{Tag};
2251 open TO, '>', $tfn->('.tmp') or die $!;
2252 print TO <<END or die $!;
2259 if ($tw->{View} eq 'dgit') {
2260 print TO <<END or die $!;
2261 $package release $cversion for $clogsuite ($csuite) [dgit]
2262 [dgit distro=$declaredistro$delibs]
2264 foreach my $ref (sort keys %previously) {
2265 print TO <<END or die $!;
2266 [dgit previously:$ref=$previously{$ref}]
2269 } elsif ($tw->{View} eq 'maint') {
2270 print TO <<END or die $!;
2271 $package release $cversion for $clogsuite ($csuite)
2272 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2275 die Dumper($tw)."?";
2280 my $tagobjfn = $tfn->('.tmp');
2282 if (!defined $keyid) {
2283 $keyid = access_cfg('keyid','RETURN-UNDEF');
2285 if (!defined $keyid) {
2286 $keyid = getfield $clogp, 'Maintainer';
2288 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2289 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2290 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2291 push @sign_cmd, $tfn->('.tmp');
2292 runcmd_ordryrun @sign_cmd;
2294 $tagobjfn = $tfn->('.signed.tmp');
2295 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2296 $tfn->('.tmp'), $tfn->('.tmp.asc');
2302 my @r = map { $mktag->($_); } @$tagwants;
2306 sub sign_changes ($) {
2307 my ($changesfile) = @_;
2309 my @debsign_cmd = @debsign;
2310 push @debsign_cmd, "-k$keyid" if defined $keyid;
2311 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2312 push @debsign_cmd, $changesfile;
2313 runcmd_ordryrun @debsign_cmd;
2318 my ($forceflag) = @_;
2319 printdebug "actually entering push\n";
2320 supplementary_message(<<'END');
2321 Push failed, while preparing your push.
2322 You can retry the push, after fixing the problem, if you like.
2325 need_tagformat 'new', "quilt mode $quilt_mode"
2326 if quiltmode_splitbrain;
2330 access_giturl(); # check that success is vaguely likely
2333 my $clogpfn = ".git/dgit/changelog.822.tmp";
2334 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2336 responder_send_file('parsed-changelog', $clogpfn);
2338 my ($clogp, $cversion, $dscfn) =
2339 push_parse_changelog("$clogpfn");
2341 my $dscpath = "$buildproductsdir/$dscfn";
2342 stat_exists $dscpath or
2343 fail "looked for .dsc $dscfn, but $!;".
2344 " maybe you forgot to build";
2346 responder_send_file('dsc', $dscpath);
2348 push_parse_dsc($dscpath, $dscfn, $cversion);
2350 my $format = getfield $dsc, 'Format';
2351 printdebug "format $format\n";
2353 my $actualhead = git_rev_parse('HEAD');
2354 my $dgithead = $actualhead;
2355 my $maintviewhead = undef;
2357 if (madformat($format)) {
2358 # user might have not used dgit build, so maybe do this now:
2359 if (quiltmode_splitbrain()) {
2360 my $upstreamversion = $clogp->{Version};
2361 $upstreamversion =~ s/-[^-]*$//;
2363 quilt_make_fake_dsc($upstreamversion);
2364 my ($dgitview, $cachekey) =
2365 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2367 "--quilt=$quilt_mode but no cached dgit view:
2368 perhaps tree changed since dgit build[-source] ?";
2370 $dgithead = $dgitview;
2371 $maintviewhead = $actualhead;
2372 changedir '../../../..';
2373 prep_ud(); # so _only_subdir() works, below
2375 commit_quilty_patch();
2381 progress "checking that $dscfn corresponds to HEAD";
2382 runcmd qw(dpkg-source -x --),
2383 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2384 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2385 check_for_vendor_patches() if madformat($dsc->{format});
2386 changedir '../../../..';
2387 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2388 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2389 debugcmd "+",@diffcmd;
2391 my $r = system @diffcmd;
2394 fail "$dscfn specifies a different tree to your HEAD commit;".
2395 " perhaps you forgot to build".
2396 ($diffopt eq '--exit-code' ? "" :
2397 " (run with -D to see full diff output)");
2402 if (!$changesfile) {
2403 my $pat = changespat $cversion;
2404 my @cs = glob "$buildproductsdir/$pat";
2405 fail "failed to find unique changes file".
2406 " (looked for $pat in $buildproductsdir);".
2407 " perhaps you need to use dgit -C"
2409 ($changesfile) = @cs;
2411 $changesfile = "$buildproductsdir/$changesfile";
2414 responder_send_file('changes',$changesfile);
2415 responder_send_command("param head $dgithead");
2416 responder_send_command("param csuite $csuite");
2417 responder_send_command("param tagformat $tagformat");
2418 if (quiltmode_splitbrain) {
2419 die unless ($protovsn//4) >= 4;
2420 responder_send_command("param maint-view $maintviewhead");
2423 if (deliberately_not_fast_forward) {
2424 git_for_each_ref(lrfetchrefs, sub {
2425 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2426 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2427 responder_send_command("previously $rrefname=$objid");
2428 $previously{$rrefname} = $objid;
2432 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2436 supplementary_message(<<'END');
2437 Push failed, while signing the tag.
2438 You can retry the push, after fixing the problem, if you like.
2440 # If we manage to sign but fail to record it anywhere, it's fine.
2441 if ($we_are_responder) {
2442 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2443 responder_receive_files('signed-tag', @tagobjfns);
2445 @tagobjfns = push_mktags($clogp,$dscpath,
2446 $changesfile,$changesfile,
2449 supplementary_message(<<'END');
2450 Push failed, *after* signing the tag.
2451 If you want to try again, you should use a new version number.
2454 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2456 foreach my $tw (@tagwants) {
2457 my $tag = $tw->{Tag};
2458 my $tagobjfn = $tw->{TagObjFn};
2460 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2461 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2462 runcmd_ordryrun_local
2463 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2466 supplementary_message(<<'END');
2467 Push failed, while updating the remote git repository - see messages above.
2468 If you want to try again, you should use a new version number.
2470 if (!check_for_git()) {
2471 create_remote_git_repo();
2474 my @pushrefs = $forceflag."HEAD:".rrref();
2475 foreach my $tw (@tagwants) {
2476 my $view = $tw->{View};
2477 next unless $view eq 'dgit'
2478 or any { $_ eq $view } access_cfg_tagformats();
2479 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2482 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2483 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2485 supplementary_message(<<'END');
2486 Push failed, after updating the remote git repository.
2487 If you want to try again, you must use a new version number.
2489 if ($we_are_responder) {
2490 my $dryrunsuffix = act_local() ? "" : ".tmp";
2491 responder_receive_files('signed-dsc-changes',
2492 "$dscpath$dryrunsuffix",
2493 "$changesfile$dryrunsuffix");
2496 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2498 progress "[new .dsc left in $dscpath.tmp]";
2500 sign_changes $changesfile;
2503 supplementary_message(<<END);
2504 Push failed, while uploading package(s) to the archive server.
2505 You can retry the upload of exactly these same files with dput of:
2507 If that .changes file is broken, you will need to use a new version
2508 number for your next attempt at the upload.
2510 my $host = access_cfg('upload-host','RETURN-UNDEF');
2511 my @hostarg = defined($host) ? ($host,) : ();
2512 runcmd_ordryrun @dput, @hostarg, $changesfile;
2513 printdone "pushed and uploaded $cversion";
2515 supplementary_message('');
2516 responder_send_command("complete");
2523 badusage "-p is not allowed with clone; specify as argument instead"
2524 if defined $package;
2527 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2528 ($package,$isuite) = @ARGV;
2529 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2530 ($package,$dstdir) = @ARGV;
2531 } elsif (@ARGV==3) {
2532 ($package,$isuite,$dstdir) = @ARGV;
2534 badusage "incorrect arguments to dgit clone";
2536 $dstdir ||= "$package";
2538 if (stat_exists $dstdir) {
2539 fail "$dstdir already exists";
2543 if ($rmonerror && !$dryrun_level) {
2544 $cwd_remove= getcwd();
2546 return unless defined $cwd_remove;
2547 if (!chdir "$cwd_remove") {
2548 return if $!==&ENOENT;
2549 die "chdir $cwd_remove: $!";
2552 rmtree($dstdir) or die "remove $dstdir: $!\n";
2553 } elsif (!grep { $! == $_ }
2554 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2556 print STDERR "check whether to remove $dstdir: $!\n";
2562 $cwd_remove = undef;
2565 sub branchsuite () {
2566 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2567 if ($branch =~ m#$lbranch_re#o) {
2574 sub fetchpullargs () {
2576 if (!defined $package) {
2577 my $sourcep = parsecontrol('debian/control','debian/control');
2578 $package = getfield $sourcep, 'Source';
2581 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2583 my $clogp = parsechangelog();
2584 $isuite = getfield $clogp, 'Distribution';
2586 canonicalise_suite();
2587 progress "fetching from suite $csuite";
2588 } elsif (@ARGV==1) {
2590 canonicalise_suite();
2592 badusage "incorrect arguments to dgit fetch or dgit pull";
2611 badusage "-p is not allowed with dgit push" if defined $package;
2613 my $clogp = parsechangelog();
2614 $package = getfield $clogp, 'Source';
2617 } elsif (@ARGV==1) {
2618 ($specsuite) = (@ARGV);
2620 badusage "incorrect arguments to dgit push";
2622 $isuite = getfield $clogp, 'Distribution';
2624 local ($package) = $existing_package; # this is a hack
2625 canonicalise_suite();
2627 canonicalise_suite();
2629 if (defined $specsuite &&
2630 $specsuite ne $isuite &&
2631 $specsuite ne $csuite) {
2632 fail "dgit push: changelog specifies $isuite ($csuite)".
2633 " but command line specifies $specsuite";
2635 supplementary_message(<<'END');
2636 Push failed, while checking state of the archive.
2637 You can retry the push, after fixing the problem, if you like.
2639 if (check_for_git()) {
2643 if (fetch_from_archive()) {
2644 if (is_fast_fwd(lrref(), 'HEAD')) {
2646 } elsif (deliberately_not_fast_forward) {
2649 fail "dgit push: HEAD is not a descendant".
2650 " of the archive's version.\n".
2651 "dgit: To overwrite its contents,".
2652 " use git merge -s ours ".lrref().".\n".
2653 "dgit: To rewind history, if permitted by the archive,".
2654 " use --deliberately-not-fast-forward";
2658 fail "package appears to be new in this suite;".
2659 " if this is intentional, use --new";
2664 #---------- remote commands' implementation ----------
2666 sub cmd_remote_push_build_host {
2667 my ($nrargs) = shift @ARGV;
2668 my (@rargs) = @ARGV[0..$nrargs-1];
2669 @ARGV = @ARGV[$nrargs..$#ARGV];
2671 my ($dir,$vsnwant) = @rargs;
2672 # vsnwant is a comma-separated list; we report which we have
2673 # chosen in our ready response (so other end can tell if they
2676 $we_are_responder = 1;
2677 $us .= " (build host)";
2681 open PI, "<&STDIN" or die $!;
2682 open STDIN, "/dev/null" or die $!;
2683 open PO, ">&STDOUT" or die $!;
2685 open STDOUT, ">&STDERR" or die $!;
2689 ($protovsn) = grep {
2690 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2691 } @rpushprotovsn_support;
2693 fail "build host has dgit rpush protocol versions ".
2694 (join ",", @rpushprotovsn_support).
2695 " but invocation host has $vsnwant"
2696 unless defined $protovsn;
2698 responder_send_command("dgit-remote-push-ready $protovsn");
2699 rpush_handle_protovsn_bothends();
2704 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2705 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2706 # a good error message)
2708 sub rpush_handle_protovsn_bothends () {
2709 if ($protovsn < 4) {
2710 need_tagformat 'old', "rpush negotiated protocol $protovsn";
2719 my $report = i_child_report();
2720 if (defined $report) {
2721 printdebug "($report)\n";
2722 } elsif ($i_child_pid) {
2723 printdebug "(killing build host child $i_child_pid)\n";
2724 kill 15, $i_child_pid;
2726 if (defined $i_tmp && !defined $initiator_tempdir) {
2728 eval { rmtree $i_tmp; };
2732 END { i_cleanup(); }
2735 my ($base,$selector,@args) = @_;
2736 $selector =~ s/\-/_/g;
2737 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2744 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2752 push @rargs, join ",", @rpushprotovsn_support;
2755 push @rdgit, @ropts;
2756 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2758 my @cmd = (@ssh, $host, shellquote @rdgit);
2761 if (defined $initiator_tempdir) {
2762 rmtree $initiator_tempdir;
2763 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2764 $i_tmp = $initiator_tempdir;
2768 $i_child_pid = open2(\*RO, \*RI, @cmd);
2770 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2771 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2772 $supplementary_message = '' unless $protovsn >= 3;
2774 fail "rpush negotiated protocol version $protovsn".
2775 " which does not support quilt mode $quilt_mode"
2776 if quiltmode_splitbrain;
2778 rpush_handle_protovsn_bothends();
2780 my ($icmd,$iargs) = initiator_expect {
2781 m/^(\S+)(?: (.*))?$/;
2784 i_method "i_resp", $icmd, $iargs;
2788 sub i_resp_progress ($) {
2790 my $msg = protocol_read_bytes \*RO, $rhs;
2794 sub i_resp_supplementary_message ($) {
2796 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2799 sub i_resp_complete {
2800 my $pid = $i_child_pid;
2801 $i_child_pid = undef; # prevents killing some other process with same pid
2802 printdebug "waiting for build host child $pid...\n";
2803 my $got = waitpid $pid, 0;
2804 die $! unless $got == $pid;
2805 die "build host child failed $?" if $?;
2808 printdebug "all done\n";
2812 sub i_resp_file ($) {
2814 my $localname = i_method "i_localname", $keyword;
2815 my $localpath = "$i_tmp/$localname";
2816 stat_exists $localpath and
2817 badproto \*RO, "file $keyword ($localpath) twice";
2818 protocol_receive_file \*RO, $localpath;
2819 i_method "i_file", $keyword;
2824 sub i_resp_param ($) {
2825 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2829 sub i_resp_previously ($) {
2830 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2831 or badproto \*RO, "bad previously spec";
2832 my $r = system qw(git check-ref-format), $1;
2833 die "bad previously ref spec ($r)" if $r;
2834 $previously{$1} = $2;
2839 sub i_resp_want ($) {
2841 die "$keyword ?" if $i_wanted{$keyword}++;
2842 my @localpaths = i_method "i_want", $keyword;
2843 printdebug "[[ $keyword @localpaths\n";
2844 foreach my $localpath (@localpaths) {
2845 protocol_send_file \*RI, $localpath;
2847 print RI "files-end\n" or die $!;
2850 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
2852 sub i_localname_parsed_changelog {
2853 return "remote-changelog.822";
2855 sub i_file_parsed_changelog {
2856 ($i_clogp, $i_version, $i_dscfn) =
2857 push_parse_changelog "$i_tmp/remote-changelog.822";
2858 die if $i_dscfn =~ m#/|^\W#;
2861 sub i_localname_dsc {
2862 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2867 sub i_localname_changes {
2868 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2869 $i_changesfn = $i_dscfn;
2870 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2871 return $i_changesfn;
2873 sub i_file_changes { }
2875 sub i_want_signed_tag {
2876 printdebug Dumper(\%i_param, $i_dscfn);
2877 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2878 && defined $i_param{'csuite'}
2879 or badproto \*RO, "premature desire for signed-tag";
2880 my $head = $i_param{'head'};
2881 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2883 my $maintview = $i_param{'maint-view'};
2884 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
2887 if ($protovsn >= 4) {
2888 my $p = $i_param{'tagformat'} // '<undef>';
2890 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
2893 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2895 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2897 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
2900 push_mktags $i_clogp, $i_dscfn,
2901 $i_changesfn, 'remote changes',
2905 sub i_want_signed_dsc_changes {
2906 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2907 sign_changes $i_changesfn;
2908 return ($i_dscfn, $i_changesfn);
2911 #---------- building etc. ----------
2917 #----- `3.0 (quilt)' handling -----
2919 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2921 sub quiltify_dpkg_commit ($$$;$) {
2922 my ($patchname,$author,$msg, $xinfo) = @_;
2926 my $descfn = ".git/dgit/quilt-description.tmp";
2927 open O, '>', $descfn or die "$descfn: $!";
2930 $msg =~ s/^\s+$/ ./mg;
2931 print O <<END or die $!;
2941 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2942 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2943 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2944 runcmd @dpkgsource, qw(--commit .), $patchname;
2948 sub quiltify_trees_differ ($$;$$) {
2949 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2950 # returns true iff the two tree objects differ other than in debian/
2951 # with $finegrained,
2952 # returns bitmask 01 - differ in upstream files except .gitignore
2953 # 02 - differ in .gitignore
2954 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2955 # is set for each modified .gitignore filename $fn
2957 my @cmd = (@git, qw(diff-tree --name-only -z));
2958 push @cmd, qw(-r) if $finegrained;
2960 my $diffs= cmdoutput @cmd;
2962 foreach my $f (split /\0/, $diffs) {
2963 next if $f =~ m#^debian(?:/.*)?$#s;
2964 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2965 $r |= $isignore ? 02 : 01;
2966 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2968 printdebug "quiltify_trees_differ $x $y => $r\n";
2972 sub quiltify_tree_sentinelfiles ($) {
2973 # lists the `sentinel' files present in the tree
2975 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2976 qw(-- debian/rules debian/control);
2981 sub quiltify_splitbrain_needed () {
2982 if (!$split_brain) {
2983 progress "dgit view: changes are required...";
2984 runcmd @git, qw(checkout -q -b dgit-view);
2989 sub quiltify_splitbrain ($$$$$$) {
2990 my ($clogp, $unapplied, $headref, $diffbits,
2991 $editedignores, $cachekey) = @_;
2992 if ($quilt_mode !~ m/gbp|dpm/) {
2993 # treat .gitignore just like any other upstream file
2994 $diffbits = { %$diffbits };
2995 $_ = !!$_ foreach values %$diffbits;
2997 # We would like any commits we generate to be reproducible
2998 my @authline = clogp_authline($clogp);
2999 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3000 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3001 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3003 if ($quilt_mode =~ m/gbp|unapplied/ &&
3004 ($diffbits->{H2O} & 01)) {
3006 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3007 " but git tree differs from orig in upstream files.";
3008 if (!stat_exists "debian/patches") {
3010 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3014 if ($quilt_mode =~ m/gbp|unapplied/ &&
3015 ($diffbits->{O2A} & 01)) { # some patches
3016 quiltify_splitbrain_needed();
3017 progress "dgit view: creating patches-applied version using gbp pq";
3018 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3019 # gbp pq import creates a fresh branch; push back to dgit-view
3020 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3021 runcmd @git, qw(checkout -q dgit-view);
3023 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3024 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3025 quiltify_splitbrain_needed();
3026 progress "dgit view: creating patch to represent .gitignore changes";
3027 ensuredir "debian/patches";
3028 my $gipatch = "debian/patches/auto-gitignore";
3029 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3030 stat GIPATCH or die "$gipatch: $!";
3031 fail "$gipatch already exists; but want to create it".
3032 " to record .gitignore changes" if (stat _)[7];
3033 print GIPATCH <<END or die "$gipatch: $!";
3034 Subject: Update .gitignore from Debian packaging branch
3036 The Debian packaging git branch contains these updates to the upstream
3037 .gitignore file(s). This patch is autogenerated, to provide these
3038 updates to users of the official Debian archive view of the package.
3040 [dgit version $our_version]
3043 close GIPATCH or die "$gipatch: $!";
3044 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3045 $unapplied, $headref, "--", sort keys %$editedignores;
3046 open SERIES, "+>>", "debian/patches/series" or die $!;
3047 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3049 defined read SERIES, $newline, 1 or die $!;
3050 print SERIES "\n" or die $! unless $newline eq "\n";
3051 print SERIES "auto-gitignore\n" or die $!;
3052 close SERIES or die $!;
3053 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3054 commit_admin "Commit patch to update .gitignore";
3057 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3059 changedir '../../../..';
3060 ensuredir ".git/logs/refs/dgit-intern";
3061 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3063 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3066 progress "dgit view: created (commit id $dgitview)";
3068 changedir '.git/dgit/unpack/work';
3071 sub quiltify ($$$$) {
3072 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3074 # Quilt patchification algorithm
3076 # We search backwards through the history of the main tree's HEAD
3077 # (T) looking for a start commit S whose tree object is identical
3078 # to to the patch tip tree (ie the tree corresponding to the
3079 # current dpkg-committed patch series). For these purposes
3080 # `identical' disregards anything in debian/ - this wrinkle is
3081 # necessary because dpkg-source treates debian/ specially.
3083 # We can only traverse edges where at most one of the ancestors'
3084 # trees differs (in changes outside in debian/). And we cannot
3085 # handle edges which change .pc/ or debian/patches. To avoid
3086 # going down a rathole we avoid traversing edges which introduce
3087 # debian/rules or debian/control. And we set a limit on the
3088 # number of edges we are willing to look at.
3090 # If we succeed, we walk forwards again. For each traversed edge
3091 # PC (with P parent, C child) (starting with P=S and ending with
3092 # C=T) to we do this:
3094 # - dpkg-source --commit with a patch name and message derived from C
3095 # After traversing PT, we git commit the changes which
3096 # should be contained within debian/patches.
3098 # The search for the path S..T is breadth-first. We maintain a
3099 # todo list containing search nodes. A search node identifies a
3100 # commit, and looks something like this:
3102 # Commit => $git_commit_id,
3103 # Child => $c, # or undef if P=T
3104 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3105 # Nontrivial => true iff $p..$c has relevant changes
3112 my %considered; # saves being exponential on some weird graphs
3114 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3117 my ($search,$whynot) = @_;
3118 printdebug " search NOT $search->{Commit} $whynot\n";
3119 $search->{Whynot} = $whynot;
3120 push @nots, $search;
3121 no warnings qw(exiting);
3130 my $c = shift @todo;
3131 next if $considered{$c->{Commit}}++;
3133 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3135 printdebug "quiltify investigate $c->{Commit}\n";
3138 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3139 printdebug " search finished hooray!\n";
3144 if ($quilt_mode eq 'nofix') {
3145 fail "quilt fixup required but quilt mode is \`nofix'\n".
3146 "HEAD commit $c->{Commit} differs from tree implied by ".
3147 " debian/patches (tree object $oldtiptree)";
3149 if ($quilt_mode eq 'smash') {
3150 printdebug " search quitting smash\n";
3154 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3155 $not->($c, "has $c_sentinels not $t_sentinels")
3156 if $c_sentinels ne $t_sentinels;
3158 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3159 $commitdata =~ m/\n\n/;
3161 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3162 @parents = map { { Commit => $_, Child => $c } } @parents;
3164 $not->($c, "root commit") if !@parents;
3166 foreach my $p (@parents) {
3167 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3169 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3170 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3172 foreach my $p (@parents) {
3173 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3175 my @cmd= (@git, qw(diff-tree -r --name-only),
3176 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3177 my $patchstackchange = cmdoutput @cmd;
3178 if (length $patchstackchange) {
3179 $patchstackchange =~ s/\n/,/g;
3180 $not->($p, "changed $patchstackchange");
3183 printdebug " search queue P=$p->{Commit} ",
3184 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3190 printdebug "quiltify want to smash\n";
3193 my $x = $_[0]{Commit};
3194 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3197 my $reportnot = sub {
3199 my $s = $abbrev->($notp);
3200 my $c = $notp->{Child};
3201 $s .= "..".$abbrev->($c) if $c;
3202 $s .= ": ".$notp->{Whynot};
3205 if ($quilt_mode eq 'linear') {
3206 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3207 foreach my $notp (@nots) {
3208 print STDERR "$us: ", $reportnot->($notp), "\n";
3210 print STDERR "$us: $_\n" foreach @$failsuggestion;
3211 fail "quilt fixup naive history linearisation failed.\n".
3212 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3213 } elsif ($quilt_mode eq 'smash') {
3214 } elsif ($quilt_mode eq 'auto') {
3215 progress "quilt fixup cannot be linear, smashing...";
3217 die "$quilt_mode ?";
3220 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3221 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3223 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3225 quiltify_dpkg_commit "auto-$version-$target-$time",
3226 (getfield $clogp, 'Maintainer'),
3227 "Automatically generated patch ($clogp->{Version})\n".
3228 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3232 progress "quiltify linearisation planning successful, executing...";
3234 for (my $p = $sref_S;
3235 my $c = $p->{Child};
3237 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3238 next unless $p->{Nontrivial};
3240 my $cc = $c->{Commit};
3242 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3243 $commitdata =~ m/\n\n/ or die "$c ?";
3246 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3249 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3252 my $patchname = $title;
3253 $patchname =~ s/[.:]$//;
3254 $patchname =~ y/ A-Z/-a-z/;
3255 $patchname =~ y/-a-z0-9_.+=~//cd;
3256 $patchname =~ s/^\W/x-$&/;
3257 $patchname = substr($patchname,0,40);
3260 stat "debian/patches/$patchname$index";
3262 $!==ENOENT or die "$patchname$index $!";
3264 runcmd @git, qw(checkout -q), $cc;
3266 # We use the tip's changelog so that dpkg-source doesn't
3267 # produce complaining messages from dpkg-parsechangelog. None
3268 # of the information dpkg-source gets from the changelog is
3269 # actually relevant - it gets put into the original message
3270 # which dpkg-source provides our stunt editor, and then
3272 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3274 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3275 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3277 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3280 runcmd @git, qw(checkout -q master);
3283 sub build_maybe_quilt_fixup () {
3284 my ($format,$fopts) = get_source_format;
3285 return unless madformat $format;
3288 check_for_vendor_patches();
3290 my $clogp = parsechangelog();
3291 my $headref = git_rev_parse('HEAD');
3296 my $upstreamversion=$version;
3297 $upstreamversion =~ s/-[^-]*$//;
3299 if ($fopts->{'single-debian-patch'}) {
3300 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3302 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3305 die 'bug' if $split_brain && !$need_split_build_invocation;
3307 changedir '../../../..';
3308 runcmd_ordryrun_local
3309 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3312 sub quilt_fixup_mkwork ($) {
3315 mkdir "work" or die $!;
3317 mktree_in_ud_here();
3318 runcmd @git, qw(reset -q --hard), $headref;
3321 sub quilt_fixup_linkorigs ($$) {
3322 my ($upstreamversion, $fn) = @_;
3323 # calls $fn->($leafname);
3325 foreach my $f (<../../../../*>) { #/){
3326 my $b=$f; $b =~ s{.*/}{};
3328 local ($debuglevel) = $debuglevel-1;
3329 printdebug "QF linkorigs $b, $f ?\n";
3331 next unless is_orig_file $b, srcfn $upstreamversion,'';
3332 printdebug "QF linkorigs $b, $f Y\n";
3333 link_ltarget $f, $b or die "$b $!";
3338 sub quilt_fixup_delete_pc () {
3339 runcmd @git, qw(rm -rqf .pc);
3340 commit_admin "Commit removal of .pc (quilt series tracking data)";
3343 sub quilt_fixup_singlepatch ($$$) {
3344 my ($clogp, $headref, $upstreamversion) = @_;
3346 progress "starting quiltify (single-debian-patch)";
3348 # dpkg-source --commit generates new patches even if
3349 # single-debian-patch is in debian/source/options. In order to
3350 # get it to generate debian/patches/debian-changes, it is
3351 # necessary to build the source package.
3353 quilt_fixup_linkorigs($upstreamversion, sub { });
3354 quilt_fixup_mkwork($headref);
3356 rmtree("debian/patches");
3358 runcmd @dpkgsource, qw(-b .);
3360 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3361 rename srcfn("$upstreamversion", "/debian/patches"),
3362 "work/debian/patches";
3365 commit_quilty_patch();
3368 sub quilt_make_fake_dsc ($) {
3369 my ($upstreamversion) = @_;
3371 my $fakeversion="$upstreamversion-~~DGITFAKE";
3373 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3374 print $fakedsc <<END or die $!;
3377 Version: $fakeversion
3381 my $dscaddfile=sub {
3384 my $md = new Digest::MD5;
3386 my $fh = new IO::File $b, '<' or die "$b $!";
3391 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3394 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3396 my @files=qw(debian/source/format debian/rules
3397 debian/control debian/changelog);
3398 foreach my $maybe (qw(debian/patches debian/source/options
3399 debian/tests/control)) {
3400 next unless stat_exists "../../../$maybe";
3401 push @files, $maybe;
3404 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3405 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3407 $dscaddfile->($debtar);
3408 close $fakedsc or die $!;
3411 sub quilt_check_splitbrain_cache ($$) {
3412 my ($headref, $upstreamversion) = @_;
3413 # Called only if we are in (potentially) split brain mode.
3415 # Computes the cache key and looks in the cache.
3416 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3418 my $splitbrain_cachekey;
3421 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3422 # we look in the reflog of dgit-intern/quilt-cache
3423 # we look for an entry whose message is the key for the cache lookup
3424 my @cachekey = (qw(dgit), $our_version);
3425 push @cachekey, $upstreamversion;
3426 push @cachekey, $quilt_mode;
3427 push @cachekey, $headref;
3429 push @cachekey, hashfile('fake.dsc');
3431 my $srcshash = Digest::SHA->new(256);
3432 my %sfs = ( %INC, '$0(dgit)' => $0 );
3433 foreach my $sfk (sort keys %sfs) {
3434 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3435 $srcshash->add($sfk," ");
3436 $srcshash->add(hashfile($sfs{$sfk}));
3437 $srcshash->add("\n");
3439 push @cachekey, $srcshash->hexdigest();
3440 $splitbrain_cachekey = "@cachekey";
3442 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3444 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3445 debugcmd "|(probably)",@cmd;
3446 my $child = open GC, "-|"; defined $child or die $!;
3448 chdir '../../..' or die $!;
3449 if (!stat ".git/logs/refs/$splitbraincache") {
3450 $! == ENOENT or die $!;
3451 printdebug ">(no reflog)\n";
3458 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3459 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3462 quilt_fixup_mkwork($headref);
3463 if ($cachehit ne $headref) {
3464 progress "dgit view: found cached (commit id $cachehit)";
3465 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3467 return ($cachehit, $splitbrain_cachekey);
3469 progress "dgit view: found cached, no changes required";
3470 return ($headref, $splitbrain_cachekey);
3472 die $! if GC->error;
3473 failedcmd unless close GC;
3475 printdebug "splitbrain cache miss\n";
3476 return (undef, $splitbrain_cachekey);
3479 sub quilt_fixup_multipatch ($$$) {
3480 my ($clogp, $headref, $upstreamversion) = @_;
3482 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3485 # - honour any existing .pc in case it has any strangeness
3486 # - determine the git commit corresponding to the tip of
3487 # the patch stack (if there is one)
3488 # - if there is such a git commit, convert each subsequent
3489 # git commit into a quilt patch with dpkg-source --commit
3490 # - otherwise convert all the differences in the tree into
3491 # a single git commit
3495 # Our git tree doesn't necessarily contain .pc. (Some versions of
3496 # dgit would include the .pc in the git tree.) If there isn't
3497 # one, we need to generate one by unpacking the patches that we
3500 # We first look for a .pc in the git tree. If there is one, we
3501 # will use it. (This is not the normal case.)
3503 # Otherwise need to regenerate .pc so that dpkg-source --commit
3504 # can work. We do this as follows:
3505 # 1. Collect all relevant .orig from parent directory
3506 # 2. Generate a debian.tar.gz out of
3507 # debian/{patches,rules,source/format,source/options}
3508 # 3. Generate a fake .dsc containing just these fields:
3509 # Format Source Version Files
3510 # 4. Extract the fake .dsc
3511 # Now the fake .dsc has a .pc directory.
3512 # (In fact we do this in every case, because in future we will
3513 # want to search for a good base commit for generating patches.)
3515 # Then we can actually do the dpkg-source --commit
3516 # 1. Make a new working tree with the same object
3517 # store as our main tree and check out the main
3519 # 2. Copy .pc from the fake's extraction, if necessary
3520 # 3. Run dpkg-source --commit
3521 # 4. If the result has changes to debian/, then
3522 # - git-add them them
3523 # - git-add .pc if we had a .pc in-tree
3525 # 5. If we had a .pc in-tree, delete it, and git-commit
3526 # 6. Back in the main tree, fast forward to the new HEAD
3528 # Another situation we may have to cope with is gbp-style
3529 # patches-unapplied trees.
3531 # We would want to detect these, so we know to escape into
3532 # quilt_fixup_gbp. However, this is in general not possible.
3533 # Consider a package with a one patch which the dgit user reverts
3534 # (with git-revert or the moral equivalent).
3536 # That is indistinguishable in contents from a patches-unapplied
3537 # tree. And looking at the history to distinguish them is not
3538 # useful because the user might have made a confusing-looking git
3539 # history structure (which ought to produce an error if dgit can't
3540 # cope, not a silent reintroduction of an unwanted patch).
3542 # So gbp users will have to pass an option. But we can usually
3543 # detect their failure to do so: if the tree is not a clean
3544 # patches-applied tree, quilt linearisation fails, but the tree
3545 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3546 # they want --quilt=unapplied.
3548 # To help detect this, when we are extracting the fake dsc, we
3549 # first extract it with --skip-patches, and then apply the patches
3550 # afterwards with dpkg-source --before-build. That lets us save a
3551 # tree object corresponding to .origs.
3553 my $splitbrain_cachekey;
3555 quilt_make_fake_dsc($upstreamversion);
3557 if (quiltmode_splitbrain()) {
3559 ($cachehit, $splitbrain_cachekey) =
3560 quilt_check_splitbrain_cache($headref, $upstreamversion);
3561 return if $cachehit;
3565 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3567 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3568 rename $fakexdir, "fake" or die "$fakexdir $!";
3572 remove_stray_gits();
3573 mktree_in_ud_here();
3577 runcmd @git, qw(add -Af .);
3578 my $unapplied=git_write_tree();
3579 printdebug "fake orig tree object $unapplied\n";
3584 'exec dpkg-source --before-build . >/dev/null';
3588 quilt_fixup_mkwork($headref);
3591 if (stat_exists ".pc") {
3593 progress "Tree already contains .pc - will use it then delete it.";
3596 rename '../fake/.pc','.pc' or die $!;
3599 changedir '../fake';
3601 runcmd @git, qw(add -Af .);
3602 my $oldtiptree=git_write_tree();
3603 printdebug "fake o+d/p tree object $unapplied\n";
3604 changedir '../work';
3607 # We calculate some guesswork now about what kind of tree this might
3608 # be. This is mostly for error reporting.
3613 # O = orig, without patches applied
3614 # A = "applied", ie orig with H's debian/patches applied
3615 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3616 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3617 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3621 foreach my $b (qw(01 02)) {
3622 foreach my $v (qw(H2O O2A H2A)) {
3623 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3626 printdebug "differences \@dl @dl.\n";
3629 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3630 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3631 $dl[0], $dl[1], $dl[3], $dl[4],
3635 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3636 push @failsuggestion, "This might be a patches-unapplied branch.";
3637 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3638 push @failsuggestion, "This might be a patches-applied branch.";
3640 push @failsuggestion, "Maybe you need to specify one of".
3641 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3643 if (quiltmode_splitbrain()) {
3644 quiltify_splitbrain($clogp, $unapplied, $headref,
3645 $diffbits, \%editedignores,
3646 $splitbrain_cachekey);
3650 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3651 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3653 if (!open P, '>>', ".pc/applied-patches") {
3654 $!==&ENOENT or die $!;
3659 commit_quilty_patch();
3661 if ($mustdeletepc) {
3662 quilt_fixup_delete_pc();
3666 sub quilt_fixup_editor () {
3667 my $descfn = $ENV{$fakeeditorenv};
3668 my $editing = $ARGV[$#ARGV];
3669 open I1, '<', $descfn or die "$descfn: $!";
3670 open I2, '<', $editing or die "$editing: $!";
3671 unlink $editing or die "$editing: $!";
3672 open O, '>', $editing or die "$editing: $!";
3673 while (<I1>) { print O or die $!; } I1->error and die $!;
3676 $copying ||= m/^\-\-\- /;
3677 next unless $copying;
3680 I2->error and die $!;
3685 sub maybe_apply_patches_dirtily () {
3686 return unless $quilt_mode =~ m/gbp|unapplied/;
3687 print STDERR <<END or die $!;
3689 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3690 dgit: Have to apply the patches - making the tree dirty.
3691 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3694 $patches_applied_dirtily = 01;
3695 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3696 runcmd qw(dpkg-source --before-build .);
3699 sub maybe_unapply_patches_again () {
3700 progress "dgit: Unapplying patches again to tidy up the tree."
3701 if $patches_applied_dirtily;
3702 runcmd qw(dpkg-source --after-build .)
3703 if $patches_applied_dirtily & 01;
3705 if $patches_applied_dirtily & 02;
3708 #----- other building -----
3710 our $clean_using_builder;
3711 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3712 # clean the tree before building (perhaps invoked indirectly by
3713 # whatever we are using to run the build), rather than separately
3714 # and explicitly by us.
3717 return if $clean_using_builder;
3718 if ($cleanmode eq 'dpkg-source') {
3719 maybe_apply_patches_dirtily();
3720 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3721 } elsif ($cleanmode eq 'dpkg-source-d') {
3722 maybe_apply_patches_dirtily();
3723 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3724 } elsif ($cleanmode eq 'git') {
3725 runcmd_ordryrun_local @git, qw(clean -xdf);
3726 } elsif ($cleanmode eq 'git-ff') {
3727 runcmd_ordryrun_local @git, qw(clean -xdff);
3728 } elsif ($cleanmode eq 'check') {
3729 my $leftovers = cmdoutput @git, qw(clean -xdn);
3730 if (length $leftovers) {
3731 print STDERR $leftovers, "\n" or die $!;
3732 fail "tree contains uncommitted files and --clean=check specified";
3734 } elsif ($cleanmode eq 'none') {
3741 badusage "clean takes no additional arguments" if @ARGV;
3744 maybe_unapply_patches_again();
3749 badusage "-p is not allowed when building" if defined $package;
3752 my $clogp = parsechangelog();
3753 $isuite = getfield $clogp, 'Distribution';
3754 $package = getfield $clogp, 'Source';
3755 $version = getfield $clogp, 'Version';
3756 build_maybe_quilt_fixup();
3758 my $pat = changespat $version;
3759 foreach my $f (glob "$buildproductsdir/$pat") {
3761 unlink $f or fail "remove old changes file $f: $!";
3763 progress "would remove $f";
3769 sub changesopts_initial () {
3770 my @opts =@changesopts[1..$#changesopts];
3773 sub changesopts_version () {
3774 if (!defined $changes_since_version) {
3775 my @vsns = archive_query('archive_query');
3776 my @quirk = access_quirk();
3777 if ($quirk[0] eq 'backports') {
3778 local $isuite = $quirk[2];
3780 canonicalise_suite();
3781 push @vsns, archive_query('archive_query');
3784 @vsns = map { $_->[0] } @vsns;
3785 @vsns = sort { -version_compare($a, $b) } @vsns;
3786 $changes_since_version = $vsns[0];
3787 progress "changelog will contain changes since $vsns[0]";
3789 $changes_since_version = '_';
3790 progress "package seems new, not specifying -v<version>";
3793 if ($changes_since_version ne '_') {
3794 return ("-v$changes_since_version");
3800 sub changesopts () {
3801 return (changesopts_initial(), changesopts_version());
3804 sub massage_dbp_args ($;$) {
3805 my ($cmd,$xargs) = @_;
3808 # - if we're going to split the source build out so we can
3809 # do strange things to it, massage the arguments to dpkg-buildpackage
3810 # so that the main build doessn't build source (or add an argument
3811 # to stop it building source by default).
3813 # - add -nc to stop dpkg-source cleaning the source tree,
3814 # unless we're not doing a split build and want dpkg-source
3815 # as cleanmode, in which case we can do nothing
3818 # 0 - source will NOT need to be built separately by caller
3819 # +1 - source will need to be built separately by caller
3820 # +2 - source will need to be built separately by caller AND
3821 # dpkg-buildpackage should not in fact be run at all!
3822 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3823 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3824 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3825 $clean_using_builder = 1;
3828 # -nc has the side effect of specifying -b if nothing else specified
3829 # and some combinations of -S, -b, et al, are errors, rather than
3830 # later simply overriding earlie. So we need to:
3831 # - search the command line for these options
3832 # - pick the last one
3833 # - perhaps add our own as a default
3834 # - perhaps adjust it to the corresponding non-source-building version
3836 foreach my $l ($cmd, $xargs) {
3838 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3841 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3843 if ($need_split_build_invocation) {
3844 printdebug "massage split $dmode.\n";
3845 $r = $dmode =~ m/[S]/ ? +2 :
3846 $dmode =~ y/gGF/ABb/ ? +1 :
3847 $dmode =~ m/[ABb]/ ? 0 :
3850 printdebug "massage done $r $dmode.\n";
3852 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3857 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3858 my $wantsrc = massage_dbp_args \@dbp;
3865 push @dbp, changesopts_version();
3866 maybe_apply_patches_dirtily();
3867 runcmd_ordryrun_local @dbp;
3869 maybe_unapply_patches_again();
3870 printdone "build successful\n";
3874 my @dbp = @dpkgbuildpackage;
3876 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3879 if (length executable_on_path('git-buildpackage')) {
3880 @cmd = qw(git-buildpackage);
3882 @cmd = qw(gbp buildpackage);
3884 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3889 if (!$clean_using_builder) {
3890 push @cmd, '--git-cleaner=true';
3895 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3896 canonicalise_suite();
3897 push @cmd, "--git-debian-branch=".lbranch();
3899 push @cmd, changesopts();
3900 maybe_apply_patches_dirtily();
3901 runcmd_ordryrun_local @cmd, @ARGV;
3903 maybe_unapply_patches_again();
3904 printdone "build successful\n";
3906 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3909 my $our_cleanmode = $cleanmode;
3910 if ($need_split_build_invocation) {
3911 # Pretend that clean is being done some other way. This
3912 # forces us not to try to use dpkg-buildpackage to clean and
3913 # build source all in one go; and instead we run dpkg-source
3914 # (and build_prep() will do the clean since $clean_using_builder
3916 $our_cleanmode = 'ELSEWHERE';
3918 if ($our_cleanmode =~ m/^dpkg-source/) {
3919 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3920 $clean_using_builder = 1;
3923 $sourcechanges = changespat $version,'source';
3925 unlink "../$sourcechanges" or $!==ENOENT
3926 or fail "remove $sourcechanges: $!";
3928 $dscfn = dscfn($version);
3929 if ($our_cleanmode eq 'dpkg-source') {
3930 maybe_apply_patches_dirtily();
3931 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3933 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3934 maybe_apply_patches_dirtily();
3935 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3938 my @cmd = (@dpkgsource, qw(-b --));
3941 runcmd_ordryrun_local @cmd, "work";
3942 my @udfiles = <${package}_*>;
3943 changedir "../../..";
3944 foreach my $f (@udfiles) {
3945 printdebug "source copy, found $f\n";
3948 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3949 $f eq srcfn($version, $&));
3950 printdebug "source copy, found $f - renaming\n";
3951 rename "$ud/$f", "../$f" or $!==ENOENT
3952 or fail "put in place new source file ($f): $!";
3955 my $pwd = must_getcwd();
3956 my $leafdir = basename $pwd;
3958 runcmd_ordryrun_local @cmd, $leafdir;
3961 runcmd_ordryrun_local qw(sh -ec),
3962 'exec >$1; shift; exec "$@"','x',
3963 "../$sourcechanges",
3964 @dpkggenchanges, qw(-S), changesopts();
3968 sub cmd_build_source {
3969 badusage "build-source takes no additional arguments" if @ARGV;
3971 maybe_unapply_patches_again();
3972 printdone "source built, results in $dscfn and $sourcechanges";
3977 my $pat = changespat $version;
3979 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3980 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3981 fail "changes files other than source matching $pat".
3982 " already present (@unwanted);".
3983 " building would result in ambiguity about the intended results"
3988 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3989 stat_exists $sourcechanges
3990 or fail "$sourcechanges (in parent directory): $!";
3992 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3993 my @changesfiles = glob $pat;
3994 @changesfiles = sort {
3995 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3998 fail "wrong number of different changes files (@changesfiles)"
3999 unless @changesfiles==2;
4000 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4001 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4002 fail "$l found in binaries changes file $binchanges"
4005 runcmd_ordryrun_local @mergechanges, @changesfiles;
4006 my $multichanges = changespat $version,'multi';
4008 stat_exists $multichanges or fail "$multichanges: $!";
4009 foreach my $cf (glob $pat) {
4010 next if $cf eq $multichanges;
4011 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4014 maybe_unapply_patches_again();
4015 printdone "build successful, results in $multichanges\n" or die $!;
4018 sub cmd_quilt_fixup {
4019 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4020 my $clogp = parsechangelog();
4021 $version = getfield $clogp, 'Version';
4022 $package = getfield $clogp, 'Source';
4025 build_maybe_quilt_fixup();
4028 sub cmd_archive_api_query {
4029 badusage "need only 1 subpath argument" unless @ARGV==1;
4030 my ($subpath) = @ARGV;
4031 my @cmd = archive_api_query_cmd($subpath);
4033 exec @cmd or fail "exec curl: $!\n";
4036 sub cmd_clone_dgit_repos_server {
4037 badusage "need destination argument" unless @ARGV==1;
4038 my ($destdir) = @ARGV;
4039 $package = '_dgit-repos-server';
4040 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4042 exec @cmd or fail "exec git clone: $!\n";
4045 sub cmd_setup_mergechangelogs {
4046 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4047 setup_mergechangelogs(1);
4050 sub cmd_setup_useremail {
4051 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4055 sub cmd_setup_new_tree {
4056 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4060 #---------- argument parsing and main program ----------
4063 print "dgit version $our_version\n" or die $!;
4067 our (%valopts_long, %valopts_short);
4070 sub defvalopt ($$$$) {
4071 my ($long,$short,$val_re,$how) = @_;
4072 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4073 $valopts_long{$long} = $oi;
4074 $valopts_short{$short} = $oi;
4075 # $how subref should:
4076 # do whatever assignemnt or thing it likes with $_[0]
4077 # if the option should not be passed on to remote, @rvalopts=()
4078 # or $how can be a scalar ref, meaning simply assign the value
4081 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4082 defvalopt '--distro', '-d', '.+', \$idistro;
4083 defvalopt '', '-k', '.+', \$keyid;
4084 defvalopt '--existing-package','', '.*', \$existing_package;
4085 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4086 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4087 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4089 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4091 defvalopt '', '-C', '.+', sub {
4092 ($changesfile) = (@_);
4093 if ($changesfile =~ s#^(.*)/##) {
4094 $buildproductsdir = $1;
4098 defvalopt '--initiator-tempdir','','.*', sub {
4099 ($initiator_tempdir) = (@_);
4100 $initiator_tempdir =~ m#^/# or
4101 badusage "--initiator-tempdir must be used specify an".
4102 " absolute, not relative, directory."
4108 if (defined $ENV{'DGIT_SSH'}) {
4109 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4110 } elsif (defined $ENV{'GIT_SSH'}) {
4111 @ssh = ($ENV{'GIT_SSH'});
4119 if (!defined $val) {
4120 badusage "$what needs a value" unless @ARGV;
4122 push @rvalopts, $val;
4124 badusage "bad value \`$val' for $what" unless
4125 $val =~ m/^$oi->{Re}$(?!\n)/s;
4126 my $how = $oi->{How};
4127 if (ref($how) eq 'SCALAR') {
4132 push @ropts, @rvalopts;
4136 last unless $ARGV[0] =~ m/^-/;
4140 if (m/^--dry-run$/) {
4143 } elsif (m/^--damp-run$/) {
4146 } elsif (m/^--no-sign$/) {
4149 } elsif (m/^--help$/) {
4151 } elsif (m/^--version$/) {
4153 } elsif (m/^--new$/) {
4156 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4157 ($om = $opts_opt_map{$1}) &&
4161 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4162 !$opts_opt_cmdonly{$1} &&
4163 ($om = $opts_opt_map{$1})) {
4166 } elsif (m/^--ignore-dirty$/s) {
4169 } elsif (m/^--no-quilt-fixup$/s) {
4171 $quilt_mode = 'nocheck';
4172 } elsif (m/^--no-rm-on-error$/s) {
4175 } elsif (m/^--(no-)?rm-old-changes$/s) {
4178 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4180 push @deliberatelies, $&;
4181 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4182 # undocumented, for testing
4184 $tagformat_want = [ $1, 'command line', 1 ];
4185 # 1 menas overrides distro configuration
4186 } elsif (m/^--always-split-source-build$/s) {
4187 # undocumented, for testing
4189 $need_split_build_invocation = 1;
4190 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4191 $val = $2 ? $' : undef; #';
4192 $valopt->($oi->{Long});
4194 badusage "unknown long option \`$_'";
4201 } elsif (s/^-L/-/) {
4204 } elsif (s/^-h/-/) {
4206 } elsif (s/^-D/-/) {
4210 } elsif (s/^-N/-/) {
4215 push @changesopts, $_;
4217 } elsif (s/^-wn$//s) {
4219 $cleanmode = 'none';
4220 } elsif (s/^-wg$//s) {
4223 } elsif (s/^-wgf$//s) {
4225 $cleanmode = 'git-ff';
4226 } elsif (s/^-wd$//s) {
4228 $cleanmode = 'dpkg-source';
4229 } elsif (s/^-wdd$//s) {
4231 $cleanmode = 'dpkg-source-d';
4232 } elsif (s/^-wc$//s) {
4234 $cleanmode = 'check';
4235 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4237 $val = undef unless length $val;
4238 $valopt->($oi->{Short});
4241 badusage "unknown short option \`$_'";
4248 sub finalise_opts_opts () {
4249 foreach my $k (keys %opts_opt_map) {
4250 my $om = $opts_opt_map{$k};
4252 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4254 badcfg "cannot set command for $k"
4255 unless length $om->[0];
4259 foreach my $c (access_cfg_cfgs("opts-$k")) {
4260 my $vl = $gitcfg{$c};
4261 printdebug "CL $c ",
4262 ($vl ? join " ", map { shellquote } @$vl : ""),
4263 "\n" if $debuglevel >= 4;
4265 badcfg "cannot configure options for $k"
4266 if $opts_opt_cmdonly{$k};
4267 my $insertpos = $opts_cfg_insertpos{$k};
4268 @$om = ( @$om[0..$insertpos-1],
4270 @$om[$insertpos..$#$om] );
4275 if ($ENV{$fakeeditorenv}) {
4277 quilt_fixup_editor();
4283 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4284 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4285 if $dryrun_level == 1;
4287 print STDERR $helpmsg or die $!;
4290 my $cmd = shift @ARGV;
4293 if (!defined $rmchanges) {
4294 local $access_forpush;
4295 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4298 if (!defined $quilt_mode) {
4299 local $access_forpush;
4300 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4301 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4303 $quilt_mode =~ m/^($quilt_modes_re)$/
4304 or badcfg "unknown quilt-mode \`$quilt_mode'";
4308 $need_split_build_invocation ||= quiltmode_splitbrain();
4310 if (!defined $cleanmode) {
4311 local $access_forpush;
4312 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4313 $cleanmode //= 'dpkg-source';
4315 badcfg "unknown clean-mode \`$cleanmode'" unless
4316 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4319 my $fn = ${*::}{"cmd_$cmd"};
4320 $fn or badusage "unknown operation $cmd";