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 # Same version. Use what's in the server git branch,
1553 # discarding our own import. (This could happen if the
1554 # server automatically imports all packages into git.)
1555 @output = $lastpush_mergeinput;
1558 changedir '../../../..';
1563 sub complete_file_from_dsc ($$) {
1564 our ($dstdir, $fi) = @_;
1565 # Ensures that we have, in $dir, the file $fi, with the correct
1566 # contents. (Downloading it from alongside $dscurl if necessary.)
1568 my $f = $fi->{Filename};
1569 my $tf = "$dstdir/$f";
1572 if (stat_exists $tf) {
1573 progress "using existing $f";
1576 $furl =~ s{/[^/]+$}{};
1578 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1579 die "$f ?" if $f =~ m#/#;
1580 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1581 return 0 if !act_local();
1585 open F, "<", "$tf" or die "$tf: $!";
1586 $fi->{Digester}->reset();
1587 $fi->{Digester}->addfile(*F);
1588 F->error and die $!;
1589 my $got = $fi->{Digester}->hexdigest();
1590 $got eq $fi->{Hash} or
1591 fail "file $f has hash $got but .dsc".
1592 " demands hash $fi->{Hash} ".
1593 ($downloaded ? "(got wrong file from archive!)"
1594 : "(perhaps you should delete this file?)");
1599 sub ensure_we_have_orig () {
1600 foreach my $fi (dsc_files_info()) {
1601 my $f = $fi->{Filename};
1602 next unless is_orig_file($f);
1603 complete_file_from_dsc('..', $fi)
1608 sub git_fetch_us () {
1610 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1611 qw(tags heads), $branchprefix;
1612 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1615 my @tagpats = debiantags('*',access_basedistro);
1617 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1618 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1619 printdebug "currently $fullrefname=$objid\n";
1620 $here{$fullrefname} = $objid;
1622 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1623 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1624 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1625 printdebug "offered $lref=$objid\n";
1626 if (!defined $here{$lref}) {
1627 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1628 runcmd_ordryrun_local @upd;
1629 } elsif ($here{$lref} eq $objid) {
1632 "Not updateting $lref from $here{$lref} to $objid.\n";
1637 sub mergeinfo_getclogp ($) {
1639 # Ensures thit $mi->{Clogp} exists and returns it
1640 return $mi->{Clogp} if $mi->{Clogp};
1641 my $mclog = ".git/dgit/clog-$mi->{Commit}";
1643 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1644 "$mi->{Commit}:debian/changelog";
1645 $mi->{Clogp} = parsechangelog("-l$mclog");
1648 sub mergeinfo_version ($) {
1649 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1652 sub fetch_from_archive () {
1653 # ensures that lrref() is what is actually in the archive,
1654 # one way or another
1658 foreach my $field (@ourdscfield) {
1659 $dsc_hash = $dsc->{$field};
1660 last if defined $dsc_hash;
1662 if (defined $dsc_hash) {
1663 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1665 progress "last upload to archive specified git hash";
1667 progress "last upload to archive has NO git hash";
1670 progress "no version available from the archive";
1673 # If the archive's .dsc has a Dgit field, there are three
1674 # relevant git commitids we need to choose between and/or merge
1676 # 1. $dsc_hash: the Dgit field from the archive
1677 # 2. $lastpush_hash: the suite branch on the dgit git server
1678 # 3. $lastfetch_hash: our local tracking brach for the suite
1680 # These may all be distinct and need not be in any fast forward
1683 # If the dsc was pushed to this suite, then the server suite
1684 # branch will have been updated; but it might have been pushed to
1685 # a different suite and copied by the archive. Conversely a more
1686 # recent version may have been pushed with dgit but not appeared
1687 # in the archive (yet).
1689 # $lastfetch_hash may be awkward because archive imports
1690 # (particularly, imports of Dgit-less .dscs) are performed only as
1691 # needed on individual clients, so different clients may perform a
1692 # different subset of them - and these imports are only made
1693 # public during push. So $lastfetch_hash may represent a set of
1694 # imports different to a subsequent upload by a different dgit
1697 # Our approach is as follows:
1699 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1700 # descendant of $dsc_hash, then it was pushed by a dgit user who
1701 # had based their work on $dsc_hash, so we should prefer it.
1702 # Otherwise, $dsc_hash was installed into this suite in the
1703 # archive other than by a dgit push, and (necessarily) after the
1704 # last dgit push into that suite (since a dgit push would have
1705 # been descended from the dgit server git branch); thus, in that
1706 # case, we prefer the archive's version (and produce a
1707 # pseudo-merge to overwrite the dgit server git branch).
1709 # (If there is no Dgit field in the archive's .dsc then
1710 # generate_commit_from_dsc uses the version numbers to decide
1711 # whether the suite branch or the archive is newer. If the suite
1712 # branch is newer it ignores the archive's .dsc; otherwise it
1713 # generates an import of the .dsc, and produces a pseudo-merge to
1714 # overwrite the suite branch with the archive contents.)
1716 # The outcome of that part of the algorithm is the `public view',
1717 # and is same for all dgit clients: it does not depend on any
1718 # unpublished history in the local tracking branch.
1720 # As between the public view and the local tracking branch: The
1721 # local tracking branch is only updated by dgit fetch, and
1722 # whenever dgit fetch runs it includes the public view in the
1723 # local tracking branch. Therefore if the public view is not
1724 # descended from the local tracking branch, the local tracking
1725 # branch must contain history which was imported from the archive
1726 # but never pushed; and, its tip is now out of date. So, we make
1727 # a pseudo-merge to overwrite the old imports and stitch the old
1730 # Finally: we do not necessarily reify the public view (as
1731 # described above). This is so that we do not end up stacking two
1732 # pseudo-merges. So what we actually do is figure out the inputs
1733 # to any public view psuedo-merge and put them in @mergeinputs.
1736 # $mergeinputs[]{Commit}
1737 # $mergeinputs[]{Info}
1738 # $mergeinputs[0] is the one whose tree we use
1739 # @mergeinputs is in the order we use in the actual commit)
1742 # $mergeinputs[]{Message} is a commit message to use
1743 # $mergeinputs[]{ReverseParents} if def specifies that parent
1744 # list should be in opposite order
1745 # Such an entry has no Commit or Info. It applies only when found
1746 # in the last entry. (This ugliness is to support making
1747 # identical imports to previous dgit versions.)
1749 my $lastpush_hash = git_get_ref(lrfetchref());
1750 printdebug "previous reference hash=$lastpush_hash\n";
1751 $lastpush_mergeinput = $lastpush_hash && {
1752 Commit => $lastpush_hash,
1753 Info => "dgit suite branch on dgit git server",
1756 my $lastfetch_hash = git_get_ref(lrref());
1757 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1758 my $lastfetch_mergeinput = $lastfetch_hash && {
1759 Commit => $lastfetch_hash,
1760 Info => "dgit client's archive history view",
1763 my $dsc_mergeinput = $dsc_hash && {
1764 Commit => $dsc_hash,
1765 Info => "Dgit field in .dsc from archive",
1768 if (defined $dsc_hash) {
1769 fail "missing remote git history even though dsc has hash -".
1770 " could not find ref ".rref()." at ".access_giturl()
1771 unless $lastpush_hash;
1772 ensure_we_have_orig();
1773 if ($dsc_hash eq $lastpush_hash) {
1774 @mergeinputs = $dsc_mergeinput
1775 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1776 print STDERR <<END or die $!;
1778 Git commit in archive is behind the last version allegedly pushed/uploaded.
1779 Commit referred to by archive: $dsc_hash
1780 Last version pushed with dgit: $lastpush_hash
1783 @mergeinputs = ($lastpush_mergeinput);
1785 # Archive has .dsc which is not a descendant of the last dgit
1786 # push. This can happen if the archive moves .dscs about.
1787 # Just follow its lead.
1788 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1789 progress "archive .dsc names newer git commit";
1790 @mergeinputs = ($dsc_mergeinput);
1792 progress "archive .dsc names other git commit, fixing up";
1793 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1797 @mergeinputs = generate_commits_from_dsc();
1798 # We have just done an import. Now, our import algorithm might
1799 # have been improved. But even so we do not want to generate
1800 # a new different import of the same package. So if the
1801 # version numbers are the same, just use our existing version.
1802 # If the version numbers are different, the archive has changed
1803 # (perhaps, rewound).
1804 if ($lastfetch_mergeinput &&
1805 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1806 (mergeinfo_version $mergeinputs[0]) )) {
1807 @mergeinputs = ($lastfetch_mergeinput);
1809 } elsif ($lastpush_hash) {
1810 # only in git, not in the archive yet
1811 @mergeinputs = ($lastpush_mergeinput);
1812 print STDERR <<END or die $!;
1814 Package not found in the archive, but has allegedly been pushed using dgit.
1818 printdebug "nothing found!\n";
1819 if (defined $skew_warning_vsn) {
1820 print STDERR <<END or die $!;
1822 Warning: relevant archive skew detected.
1823 Archive allegedly contains $skew_warning_vsn
1824 But we were not able to obtain any version from the archive or git.
1831 if ($lastfetch_hash &&
1833 my $h = $_->{Commit};
1834 $h and is_fast_fwd($lastfetch_hash, $h);
1835 # If true, one of the existing parents of this commit
1836 # is a descendant of the $lastfetch_hash, so we'll
1837 # be ff from that automatically.
1841 push @mergeinputs, $lastfetch_mergeinput;
1844 printdebug "fetch mergeinfos:\n";
1845 foreach my $mi (@mergeinputs) {
1847 printdebug " commit $mi->{Commit} $mi->{Info}\n";
1849 printdebug sprintf " ReverseParents=%d Message=%s",
1850 $mi->{ReverseParents}, $mi->{Message};
1854 my $compat_info= pop @mergeinputs
1855 if $mergeinputs[$#mergeinputs]{Message};
1857 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
1860 if (@mergeinputs > 1) {
1862 my $tree_commit = $mergeinputs[0]{Commit};
1864 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
1865 $tree =~ m/\n\n/; $tree = $`;
1866 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
1869 # We use the changelog author of the package in question the
1870 # author of this pseudo-merge. This is (roughly) correct if
1871 # this commit is simply representing aa non-dgit upload.
1872 # (Roughly because it does not record sponsorship - but we
1873 # don't have sponsorship info because that's in the .changes,
1874 # which isn't in the archivw.)
1876 # But, it might be that we are representing archive history
1877 # updates (including in-archive copies). These are not really
1878 # the responsibility of the person who created the .dsc, but
1879 # there is no-one whose name we should better use. (The
1880 # author of the .dsc-named commit is clearly worse.)
1882 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
1883 my $author = clogp_authline $useclogp;
1884 my $cversion = getfield $useclogp, 'Version';
1886 my $mcf = ".git/dgit/mergecommit";
1887 open MC, ">", $mcf or die "$mcf $!";
1888 print MC <<END or die $!;
1892 my @parents = grep { $_->{Commit} } @mergeinputs;
1893 @parents = reverse @parents if $compat_info->{ReverseParents};
1894 print MC <<END or die $! foreach @parents;
1898 print MC <<END or die $!;
1904 if (defined $compat_info->{Message}) {
1905 print MC $compat_info->{Message} or die $!;
1907 print MC <<END or die $!;
1908 Record $package ($cversion) in archive suite $csuite
1912 my $message_add_info = sub {
1914 my $mversion = mergeinfo_version $mi;
1915 printf MC " %-20s %s\n", $mversion, $mi->{Info}
1919 $message_add_info->($mergeinputs[0]);
1920 print MC <<END or die $!;
1921 should be treated as descended from
1923 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
1927 $hash = make_commit $mcf;
1929 $hash = $mergeinputs[0]{Commit};
1931 progress "fetch hash=$hash\n";
1934 my ($lasth, $what) = @_;
1935 return unless $lasth;
1936 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
1939 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
1940 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
1942 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
1943 'DGIT_ARCHIVE', $hash;
1944 cmdoutput @git, qw(log -n2), $hash;
1945 # ... gives git a chance to complain if our commit is malformed
1947 if (defined $skew_warning_vsn) {
1949 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1950 my $clogf = ".git/dgit/changelog.tmp";
1951 runcmd shell_cmd "exec >$clogf",
1952 @git, qw(cat-file blob), "$hash:debian/changelog";
1953 my $gotclogp = parsechangelog("-l$clogf");
1954 my $got_vsn = getfield $gotclogp, 'Version';
1955 printdebug "SKEW CHECK GOT $got_vsn\n";
1956 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1957 print STDERR <<END or die $!;
1959 Warning: archive skew detected. Using the available version:
1960 Archive allegedly contains $skew_warning_vsn
1961 We were able to obtain only $got_vsn
1967 if ($lastfetch_hash ne $hash) {
1968 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1972 dryrun_report @upd_cmd;
1978 sub set_local_git_config ($$) {
1980 runcmd @git, qw(config), $k, $v;
1983 sub setup_mergechangelogs (;$) {
1985 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1987 my $driver = 'dpkg-mergechangelogs';
1988 my $cb = "merge.$driver";
1989 my $attrs = '.git/info/attributes';
1990 ensuredir '.git/info';
1992 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1993 if (!open ATTRS, "<", $attrs) {
1994 $!==ENOENT or die "$attrs: $!";
1998 next if m{^debian/changelog\s};
1999 print NATTRS $_, "\n" or die $!;
2001 ATTRS->error and die $!;
2004 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2007 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2008 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2010 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2013 sub setup_useremail (;$) {
2015 return unless $always || access_cfg_bool(1, 'setup-useremail');
2018 my ($k, $envvar) = @_;
2019 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2020 return unless defined $v;
2021 set_local_git_config "user.$k", $v;
2024 $setup->('email', 'DEBEMAIL');
2025 $setup->('name', 'DEBFULLNAME');
2028 sub setup_new_tree () {
2029 setup_mergechangelogs();
2035 canonicalise_suite();
2036 badusage "dry run makes no sense with clone" unless act_local();
2037 my $hasgit = check_for_git();
2038 mkdir $dstdir or fail "create \`$dstdir': $!";
2040 runcmd @git, qw(init -q);
2041 my $giturl = access_giturl(1);
2042 if (defined $giturl) {
2043 open H, "> .git/HEAD" or die $!;
2044 print H "ref: ".lref()."\n" or die $!;
2046 runcmd @git, qw(remote add), 'origin', $giturl;
2049 progress "fetching existing git history";
2051 runcmd_ordryrun_local @git, qw(fetch origin);
2053 progress "starting new git history";
2055 fetch_from_archive() or no_such_package;
2056 my $vcsgiturl = $dsc->{'Vcs-Git'};
2057 if (length $vcsgiturl) {
2058 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2059 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2062 runcmd @git, qw(reset --hard), lrref();
2063 printdone "ready for work in $dstdir";
2067 if (check_for_git()) {
2070 fetch_from_archive() or no_such_package();
2071 printdone "fetched into ".lrref();
2076 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2078 printdone "fetched to ".lrref()." and merged into HEAD";
2081 sub check_not_dirty () {
2082 foreach my $f (qw(local-options local-patch-header)) {
2083 if (stat_exists "debian/source/$f") {
2084 fail "git tree contains debian/source/$f";
2088 return if $ignoredirty;
2090 my @cmd = (@git, qw(diff --quiet HEAD));
2092 $!=0; $?=-1; system @cmd;
2095 fail "working tree is dirty (does not match HEAD)";
2101 sub commit_admin ($) {
2104 runcmd_ordryrun_local @git, qw(commit -m), $m;
2107 sub commit_quilty_patch () {
2108 my $output = cmdoutput @git, qw(status --porcelain);
2110 foreach my $l (split /\n/, $output) {
2111 next unless $l =~ m/\S/;
2112 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2116 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2118 progress "nothing quilty to commit, ok.";
2121 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2122 runcmd_ordryrun_local @git, qw(add -f), @adds;
2123 commit_admin "Commit Debian 3.0 (quilt) metadata";
2126 sub get_source_format () {
2128 if (open F, "debian/source/options") {
2132 s/\s+$//; # ignore missing final newline
2134 my ($k, $v) = ($`, $'); #');
2135 $v =~ s/^"(.*)"$/$1/;
2141 F->error and die $!;
2144 die $! unless $!==&ENOENT;
2147 if (!open F, "debian/source/format") {
2148 die $! unless $!==&ENOENT;
2152 F->error and die $!;
2154 return ($_, \%options);
2159 return 0 unless $format eq '3.0 (quilt)';
2160 our $quilt_mode_warned;
2161 if ($quilt_mode eq 'nocheck') {
2162 progress "Not doing any fixup of \`$format' due to".
2163 " ----no-quilt-fixup or --quilt=nocheck"
2164 unless $quilt_mode_warned++;
2167 progress "Format \`$format', need to check/update patch stack"
2168 unless $quilt_mode_warned++;
2172 sub push_parse_changelog ($) {
2175 my $clogp = Dpkg::Control::Hash->new();
2176 $clogp->load($clogpfn) or die;
2178 $package = getfield $clogp, 'Source';
2179 my $cversion = getfield $clogp, 'Version';
2180 my $tag = debiantag($cversion, access_basedistro);
2181 runcmd @git, qw(check-ref-format), $tag;
2183 my $dscfn = dscfn($cversion);
2185 return ($clogp, $cversion, $dscfn);
2188 sub push_parse_dsc ($$$) {
2189 my ($dscfn,$dscfnwhat, $cversion) = @_;
2190 $dsc = parsecontrol($dscfn,$dscfnwhat);
2191 my $dversion = getfield $dsc, 'Version';
2192 my $dscpackage = getfield $dsc, 'Source';
2193 ($dscpackage eq $package && $dversion eq $cversion) or
2194 fail "$dscfn is for $dscpackage $dversion".
2195 " but debian/changelog is for $package $cversion";
2198 sub push_tagwants ($$$$) {
2199 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2202 TagFn => \&debiantag,
2207 if (defined $maintviewhead) {
2209 TagFn => \&debiantag_maintview,
2210 Objid => $maintviewhead,
2211 TfSuffix => '-maintview',
2215 foreach my $tw (@tagwants) {
2216 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2217 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2222 sub push_mktags ($$ $$ $) {
2224 $changesfile,$changesfilewhat,
2227 die unless $tagwants->[0]{View} eq 'dgit';
2229 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2230 $dsc->save("$dscfn.tmp") or die $!;
2232 my $changes = parsecontrol($changesfile,$changesfilewhat);
2233 foreach my $field (qw(Source Distribution Version)) {
2234 $changes->{$field} eq $clogp->{$field} or
2235 fail "changes field $field \`$changes->{$field}'".
2236 " does not match changelog \`$clogp->{$field}'";
2239 my $cversion = getfield $clogp, 'Version';
2240 my $clogsuite = getfield $clogp, 'Distribution';
2242 # We make the git tag by hand because (a) that makes it easier
2243 # to control the "tagger" (b) we can do remote signing
2244 my $authline = clogp_authline $clogp;
2245 my $delibs = join(" ", "",@deliberatelies);
2246 my $declaredistro = access_basedistro();
2250 my $tfn = $tw->{Tfn};
2251 my $head = $tw->{Objid};
2252 my $tag = $tw->{Tag};
2254 open TO, '>', $tfn->('.tmp') or die $!;
2255 print TO <<END or die $!;
2262 if ($tw->{View} eq 'dgit') {
2263 print TO <<END or die $!;
2264 $package release $cversion for $clogsuite ($csuite) [dgit]
2265 [dgit distro=$declaredistro$delibs]
2267 foreach my $ref (sort keys %previously) {
2268 print TO <<END or die $!;
2269 [dgit previously:$ref=$previously{$ref}]
2272 } elsif ($tw->{View} eq 'maint') {
2273 print TO <<END or die $!;
2274 $package release $cversion for $clogsuite ($csuite)
2275 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2278 die Dumper($tw)."?";
2283 my $tagobjfn = $tfn->('.tmp');
2285 if (!defined $keyid) {
2286 $keyid = access_cfg('keyid','RETURN-UNDEF');
2288 if (!defined $keyid) {
2289 $keyid = getfield $clogp, 'Maintainer';
2291 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2292 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2293 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2294 push @sign_cmd, $tfn->('.tmp');
2295 runcmd_ordryrun @sign_cmd;
2297 $tagobjfn = $tfn->('.signed.tmp');
2298 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2299 $tfn->('.tmp'), $tfn->('.tmp.asc');
2305 my @r = map { $mktag->($_); } @$tagwants;
2309 sub sign_changes ($) {
2310 my ($changesfile) = @_;
2312 my @debsign_cmd = @debsign;
2313 push @debsign_cmd, "-k$keyid" if defined $keyid;
2314 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2315 push @debsign_cmd, $changesfile;
2316 runcmd_ordryrun @debsign_cmd;
2321 my ($forceflag) = @_;
2322 printdebug "actually entering push\n";
2323 supplementary_message(<<'END');
2324 Push failed, while preparing your push.
2325 You can retry the push, after fixing the problem, if you like.
2328 need_tagformat 'new', "quilt mode $quilt_mode"
2329 if quiltmode_splitbrain;
2333 access_giturl(); # check that success is vaguely likely
2336 my $clogpfn = ".git/dgit/changelog.822.tmp";
2337 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2339 responder_send_file('parsed-changelog', $clogpfn);
2341 my ($clogp, $cversion, $dscfn) =
2342 push_parse_changelog("$clogpfn");
2344 my $dscpath = "$buildproductsdir/$dscfn";
2345 stat_exists $dscpath or
2346 fail "looked for .dsc $dscfn, but $!;".
2347 " maybe you forgot to build";
2349 responder_send_file('dsc', $dscpath);
2351 push_parse_dsc($dscpath, $dscfn, $cversion);
2353 my $format = getfield $dsc, 'Format';
2354 printdebug "format $format\n";
2356 my $actualhead = git_rev_parse('HEAD');
2357 my $dgithead = $actualhead;
2358 my $maintviewhead = undef;
2360 if (madformat($format)) {
2361 # user might have not used dgit build, so maybe do this now:
2362 if (quiltmode_splitbrain()) {
2363 my $upstreamversion = $clogp->{Version};
2364 $upstreamversion =~ s/-[^-]*$//;
2366 quilt_make_fake_dsc($upstreamversion);
2367 my ($dgitview, $cachekey) =
2368 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2370 "--quilt=$quilt_mode but no cached dgit view:
2371 perhaps tree changed since dgit build[-source] ?";
2373 $dgithead = $dgitview;
2374 $maintviewhead = $actualhead;
2375 changedir '../../../..';
2376 prep_ud(); # so _only_subdir() works, below
2378 commit_quilty_patch();
2384 progress "checking that $dscfn corresponds to HEAD";
2385 runcmd qw(dpkg-source -x --),
2386 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2387 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2388 check_for_vendor_patches() if madformat($dsc->{format});
2389 changedir '../../../..';
2390 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2391 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2392 debugcmd "+",@diffcmd;
2394 my $r = system @diffcmd;
2397 fail "$dscfn specifies a different tree to your HEAD commit;".
2398 " perhaps you forgot to build".
2399 ($diffopt eq '--exit-code' ? "" :
2400 " (run with -D to see full diff output)");
2405 if (!$changesfile) {
2406 my $pat = changespat $cversion;
2407 my @cs = glob "$buildproductsdir/$pat";
2408 fail "failed to find unique changes file".
2409 " (looked for $pat in $buildproductsdir);".
2410 " perhaps you need to use dgit -C"
2412 ($changesfile) = @cs;
2414 $changesfile = "$buildproductsdir/$changesfile";
2417 responder_send_file('changes',$changesfile);
2418 responder_send_command("param head $dgithead");
2419 responder_send_command("param csuite $csuite");
2420 responder_send_command("param tagformat $tagformat");
2421 if (quiltmode_splitbrain) {
2422 die unless ($protovsn//4) >= 4;
2423 responder_send_command("param maint-view $maintviewhead");
2426 if (deliberately_not_fast_forward) {
2427 git_for_each_ref(lrfetchrefs, sub {
2428 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2429 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2430 responder_send_command("previously $rrefname=$objid");
2431 $previously{$rrefname} = $objid;
2435 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2439 supplementary_message(<<'END');
2440 Push failed, while signing the tag.
2441 You can retry the push, after fixing the problem, if you like.
2443 # If we manage to sign but fail to record it anywhere, it's fine.
2444 if ($we_are_responder) {
2445 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2446 responder_receive_files('signed-tag', @tagobjfns);
2448 @tagobjfns = push_mktags($clogp,$dscpath,
2449 $changesfile,$changesfile,
2452 supplementary_message(<<'END');
2453 Push failed, *after* signing the tag.
2454 If you want to try again, you should use a new version number.
2457 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2459 foreach my $tw (@tagwants) {
2460 my $tag = $tw->{Tag};
2461 my $tagobjfn = $tw->{TagObjFn};
2463 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2464 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2465 runcmd_ordryrun_local
2466 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2469 supplementary_message(<<'END');
2470 Push failed, while updating the remote git repository - see messages above.
2471 If you want to try again, you should use a new version number.
2473 if (!check_for_git()) {
2474 create_remote_git_repo();
2477 my @pushrefs = $forceflag."HEAD:".rrref();
2478 foreach my $tw (@tagwants) {
2479 my $view = $tw->{View};
2480 next unless $view eq 'dgit'
2481 or any { $_ eq $view } access_cfg_tagformats();
2482 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2485 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2486 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2488 supplementary_message(<<'END');
2489 Push failed, after updating the remote git repository.
2490 If you want to try again, you must use a new version number.
2492 if ($we_are_responder) {
2493 my $dryrunsuffix = act_local() ? "" : ".tmp";
2494 responder_receive_files('signed-dsc-changes',
2495 "$dscpath$dryrunsuffix",
2496 "$changesfile$dryrunsuffix");
2499 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2501 progress "[new .dsc left in $dscpath.tmp]";
2503 sign_changes $changesfile;
2506 supplementary_message(<<END);
2507 Push failed, while uploading package(s) to the archive server.
2508 You can retry the upload of exactly these same files with dput of:
2510 If that .changes file is broken, you will need to use a new version
2511 number for your next attempt at the upload.
2513 my $host = access_cfg('upload-host','RETURN-UNDEF');
2514 my @hostarg = defined($host) ? ($host,) : ();
2515 runcmd_ordryrun @dput, @hostarg, $changesfile;
2516 printdone "pushed and uploaded $cversion";
2518 supplementary_message('');
2519 responder_send_command("complete");
2526 badusage "-p is not allowed with clone; specify as argument instead"
2527 if defined $package;
2530 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2531 ($package,$isuite) = @ARGV;
2532 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2533 ($package,$dstdir) = @ARGV;
2534 } elsif (@ARGV==3) {
2535 ($package,$isuite,$dstdir) = @ARGV;
2537 badusage "incorrect arguments to dgit clone";
2539 $dstdir ||= "$package";
2541 if (stat_exists $dstdir) {
2542 fail "$dstdir already exists";
2546 if ($rmonerror && !$dryrun_level) {
2547 $cwd_remove= getcwd();
2549 return unless defined $cwd_remove;
2550 if (!chdir "$cwd_remove") {
2551 return if $!==&ENOENT;
2552 die "chdir $cwd_remove: $!";
2555 rmtree($dstdir) or die "remove $dstdir: $!\n";
2556 } elsif (!grep { $! == $_ }
2557 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2559 print STDERR "check whether to remove $dstdir: $!\n";
2565 $cwd_remove = undef;
2568 sub branchsuite () {
2569 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2570 if ($branch =~ m#$lbranch_re#o) {
2577 sub fetchpullargs () {
2579 if (!defined $package) {
2580 my $sourcep = parsecontrol('debian/control','debian/control');
2581 $package = getfield $sourcep, 'Source';
2584 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2586 my $clogp = parsechangelog();
2587 $isuite = getfield $clogp, 'Distribution';
2589 canonicalise_suite();
2590 progress "fetching from suite $csuite";
2591 } elsif (@ARGV==1) {
2593 canonicalise_suite();
2595 badusage "incorrect arguments to dgit fetch or dgit pull";
2614 badusage "-p is not allowed with dgit push" if defined $package;
2616 my $clogp = parsechangelog();
2617 $package = getfield $clogp, 'Source';
2620 } elsif (@ARGV==1) {
2621 ($specsuite) = (@ARGV);
2623 badusage "incorrect arguments to dgit push";
2625 $isuite = getfield $clogp, 'Distribution';
2627 local ($package) = $existing_package; # this is a hack
2628 canonicalise_suite();
2630 canonicalise_suite();
2632 if (defined $specsuite &&
2633 $specsuite ne $isuite &&
2634 $specsuite ne $csuite) {
2635 fail "dgit push: changelog specifies $isuite ($csuite)".
2636 " but command line specifies $specsuite";
2638 supplementary_message(<<'END');
2639 Push failed, while checking state of the archive.
2640 You can retry the push, after fixing the problem, if you like.
2642 if (check_for_git()) {
2646 if (fetch_from_archive()) {
2647 if (is_fast_fwd(lrref(), 'HEAD')) {
2649 } elsif (deliberately_not_fast_forward) {
2652 fail "dgit push: HEAD is not a descendant".
2653 " of the archive's version.\n".
2654 "dgit: To overwrite its contents,".
2655 " use git merge -s ours ".lrref().".\n".
2656 "dgit: To rewind history, if permitted by the archive,".
2657 " use --deliberately-not-fast-forward";
2661 fail "package appears to be new in this suite;".
2662 " if this is intentional, use --new";
2667 #---------- remote commands' implementation ----------
2669 sub cmd_remote_push_build_host {
2670 my ($nrargs) = shift @ARGV;
2671 my (@rargs) = @ARGV[0..$nrargs-1];
2672 @ARGV = @ARGV[$nrargs..$#ARGV];
2674 my ($dir,$vsnwant) = @rargs;
2675 # vsnwant is a comma-separated list; we report which we have
2676 # chosen in our ready response (so other end can tell if they
2679 $we_are_responder = 1;
2680 $us .= " (build host)";
2684 open PI, "<&STDIN" or die $!;
2685 open STDIN, "/dev/null" or die $!;
2686 open PO, ">&STDOUT" or die $!;
2688 open STDOUT, ">&STDERR" or die $!;
2692 ($protovsn) = grep {
2693 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2694 } @rpushprotovsn_support;
2696 fail "build host has dgit rpush protocol versions ".
2697 (join ",", @rpushprotovsn_support).
2698 " but invocation host has $vsnwant"
2699 unless defined $protovsn;
2701 responder_send_command("dgit-remote-push-ready $protovsn");
2702 rpush_handle_protovsn_bothends();
2707 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2708 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2709 # a good error message)
2711 sub rpush_handle_protovsn_bothends () {
2712 if ($protovsn < 4) {
2713 need_tagformat 'old', "rpush negotiated protocol $protovsn";
2722 my $report = i_child_report();
2723 if (defined $report) {
2724 printdebug "($report)\n";
2725 } elsif ($i_child_pid) {
2726 printdebug "(killing build host child $i_child_pid)\n";
2727 kill 15, $i_child_pid;
2729 if (defined $i_tmp && !defined $initiator_tempdir) {
2731 eval { rmtree $i_tmp; };
2735 END { i_cleanup(); }
2738 my ($base,$selector,@args) = @_;
2739 $selector =~ s/\-/_/g;
2740 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2747 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2755 push @rargs, join ",", @rpushprotovsn_support;
2758 push @rdgit, @ropts;
2759 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2761 my @cmd = (@ssh, $host, shellquote @rdgit);
2764 if (defined $initiator_tempdir) {
2765 rmtree $initiator_tempdir;
2766 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2767 $i_tmp = $initiator_tempdir;
2771 $i_child_pid = open2(\*RO, \*RI, @cmd);
2773 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2774 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2775 $supplementary_message = '' unless $protovsn >= 3;
2777 fail "rpush negotiated protocol version $protovsn".
2778 " which does not support quilt mode $quilt_mode"
2779 if quiltmode_splitbrain;
2781 rpush_handle_protovsn_bothends();
2783 my ($icmd,$iargs) = initiator_expect {
2784 m/^(\S+)(?: (.*))?$/;
2787 i_method "i_resp", $icmd, $iargs;
2791 sub i_resp_progress ($) {
2793 my $msg = protocol_read_bytes \*RO, $rhs;
2797 sub i_resp_supplementary_message ($) {
2799 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2802 sub i_resp_complete {
2803 my $pid = $i_child_pid;
2804 $i_child_pid = undef; # prevents killing some other process with same pid
2805 printdebug "waiting for build host child $pid...\n";
2806 my $got = waitpid $pid, 0;
2807 die $! unless $got == $pid;
2808 die "build host child failed $?" if $?;
2811 printdebug "all done\n";
2815 sub i_resp_file ($) {
2817 my $localname = i_method "i_localname", $keyword;
2818 my $localpath = "$i_tmp/$localname";
2819 stat_exists $localpath and
2820 badproto \*RO, "file $keyword ($localpath) twice";
2821 protocol_receive_file \*RO, $localpath;
2822 i_method "i_file", $keyword;
2827 sub i_resp_param ($) {
2828 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2832 sub i_resp_previously ($) {
2833 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2834 or badproto \*RO, "bad previously spec";
2835 my $r = system qw(git check-ref-format), $1;
2836 die "bad previously ref spec ($r)" if $r;
2837 $previously{$1} = $2;
2842 sub i_resp_want ($) {
2844 die "$keyword ?" if $i_wanted{$keyword}++;
2845 my @localpaths = i_method "i_want", $keyword;
2846 printdebug "[[ $keyword @localpaths\n";
2847 foreach my $localpath (@localpaths) {
2848 protocol_send_file \*RI, $localpath;
2850 print RI "files-end\n" or die $!;
2853 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
2855 sub i_localname_parsed_changelog {
2856 return "remote-changelog.822";
2858 sub i_file_parsed_changelog {
2859 ($i_clogp, $i_version, $i_dscfn) =
2860 push_parse_changelog "$i_tmp/remote-changelog.822";
2861 die if $i_dscfn =~ m#/|^\W#;
2864 sub i_localname_dsc {
2865 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2870 sub i_localname_changes {
2871 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2872 $i_changesfn = $i_dscfn;
2873 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2874 return $i_changesfn;
2876 sub i_file_changes { }
2878 sub i_want_signed_tag {
2879 printdebug Dumper(\%i_param, $i_dscfn);
2880 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2881 && defined $i_param{'csuite'}
2882 or badproto \*RO, "premature desire for signed-tag";
2883 my $head = $i_param{'head'};
2884 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2886 my $maintview = $i_param{'maint-view'};
2887 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
2890 if ($protovsn >= 4) {
2891 my $p = $i_param{'tagformat'} // '<undef>';
2893 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
2896 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2898 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2900 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
2903 push_mktags $i_clogp, $i_dscfn,
2904 $i_changesfn, 'remote changes',
2908 sub i_want_signed_dsc_changes {
2909 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2910 sign_changes $i_changesfn;
2911 return ($i_dscfn, $i_changesfn);
2914 #---------- building etc. ----------
2920 #----- `3.0 (quilt)' handling -----
2922 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2924 sub quiltify_dpkg_commit ($$$;$) {
2925 my ($patchname,$author,$msg, $xinfo) = @_;
2929 my $descfn = ".git/dgit/quilt-description.tmp";
2930 open O, '>', $descfn or die "$descfn: $!";
2933 $msg =~ s/^\s+$/ ./mg;
2934 print O <<END or die $!;
2944 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2945 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2946 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2947 runcmd @dpkgsource, qw(--commit .), $patchname;
2951 sub quiltify_trees_differ ($$;$$) {
2952 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2953 # returns true iff the two tree objects differ other than in debian/
2954 # with $finegrained,
2955 # returns bitmask 01 - differ in upstream files except .gitignore
2956 # 02 - differ in .gitignore
2957 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2958 # is set for each modified .gitignore filename $fn
2960 my @cmd = (@git, qw(diff-tree --name-only -z));
2961 push @cmd, qw(-r) if $finegrained;
2963 my $diffs= cmdoutput @cmd;
2965 foreach my $f (split /\0/, $diffs) {
2966 next if $f =~ m#^debian(?:/.*)?$#s;
2967 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2968 $r |= $isignore ? 02 : 01;
2969 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2971 printdebug "quiltify_trees_differ $x $y => $r\n";
2975 sub quiltify_tree_sentinelfiles ($) {
2976 # lists the `sentinel' files present in the tree
2978 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2979 qw(-- debian/rules debian/control);
2984 sub quiltify_splitbrain_needed () {
2985 if (!$split_brain) {
2986 progress "dgit view: changes are required...";
2987 runcmd @git, qw(checkout -q -b dgit-view);
2992 sub quiltify_splitbrain ($$$$$$) {
2993 my ($clogp, $unapplied, $headref, $diffbits,
2994 $editedignores, $cachekey) = @_;
2995 if ($quilt_mode !~ m/gbp|dpm/) {
2996 # treat .gitignore just like any other upstream file
2997 $diffbits = { %$diffbits };
2998 $_ = !!$_ foreach values %$diffbits;
3000 # We would like any commits we generate to be reproducible
3001 my @authline = clogp_authline($clogp);
3002 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3003 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3004 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3006 if ($quilt_mode =~ m/gbp|unapplied/ &&
3007 ($diffbits->{H2O} & 01)) {
3009 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3010 " but git tree differs from orig in upstream files.";
3011 if (!stat_exists "debian/patches") {
3013 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3017 if ($quilt_mode =~ m/gbp|unapplied/ &&
3018 ($diffbits->{O2A} & 01)) { # some patches
3019 quiltify_splitbrain_needed();
3020 progress "dgit view: creating patches-applied version using gbp pq";
3021 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3022 # gbp pq import creates a fresh branch; push back to dgit-view
3023 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3024 runcmd @git, qw(checkout -q dgit-view);
3026 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3027 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3028 quiltify_splitbrain_needed();
3029 progress "dgit view: creating patch to represent .gitignore changes";
3030 ensuredir "debian/patches";
3031 my $gipatch = "debian/patches/auto-gitignore";
3032 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3033 stat GIPATCH or die "$gipatch: $!";
3034 fail "$gipatch already exists; but want to create it".
3035 " to record .gitignore changes" if (stat _)[7];
3036 print GIPATCH <<END or die "$gipatch: $!";
3037 Subject: Update .gitignore from Debian packaging branch
3039 The Debian packaging git branch contains these updates to the upstream
3040 .gitignore file(s). This patch is autogenerated, to provide these
3041 updates to users of the official Debian archive view of the package.
3043 [dgit version $our_version]
3046 close GIPATCH or die "$gipatch: $!";
3047 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3048 $unapplied, $headref, "--", sort keys %$editedignores;
3049 open SERIES, "+>>", "debian/patches/series" or die $!;
3050 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3052 defined read SERIES, $newline, 1 or die $!;
3053 print SERIES "\n" or die $! unless $newline eq "\n";
3054 print SERIES "auto-gitignore\n" or die $!;
3055 close SERIES or die $!;
3056 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3057 commit_admin "Commit patch to update .gitignore";
3060 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3062 changedir '../../../..';
3063 ensuredir ".git/logs/refs/dgit-intern";
3064 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3066 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3069 progress "dgit view: created (commit id $dgitview)";
3071 changedir '.git/dgit/unpack/work';
3074 sub quiltify ($$$$) {
3075 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3077 # Quilt patchification algorithm
3079 # We search backwards through the history of the main tree's HEAD
3080 # (T) looking for a start commit S whose tree object is identical
3081 # to to the patch tip tree (ie the tree corresponding to the
3082 # current dpkg-committed patch series). For these purposes
3083 # `identical' disregards anything in debian/ - this wrinkle is
3084 # necessary because dpkg-source treates debian/ specially.
3086 # We can only traverse edges where at most one of the ancestors'
3087 # trees differs (in changes outside in debian/). And we cannot
3088 # handle edges which change .pc/ or debian/patches. To avoid
3089 # going down a rathole we avoid traversing edges which introduce
3090 # debian/rules or debian/control. And we set a limit on the
3091 # number of edges we are willing to look at.
3093 # If we succeed, we walk forwards again. For each traversed edge
3094 # PC (with P parent, C child) (starting with P=S and ending with
3095 # C=T) to we do this:
3097 # - dpkg-source --commit with a patch name and message derived from C
3098 # After traversing PT, we git commit the changes which
3099 # should be contained within debian/patches.
3101 # The search for the path S..T is breadth-first. We maintain a
3102 # todo list containing search nodes. A search node identifies a
3103 # commit, and looks something like this:
3105 # Commit => $git_commit_id,
3106 # Child => $c, # or undef if P=T
3107 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3108 # Nontrivial => true iff $p..$c has relevant changes
3115 my %considered; # saves being exponential on some weird graphs
3117 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3120 my ($search,$whynot) = @_;
3121 printdebug " search NOT $search->{Commit} $whynot\n";
3122 $search->{Whynot} = $whynot;
3123 push @nots, $search;
3124 no warnings qw(exiting);
3133 my $c = shift @todo;
3134 next if $considered{$c->{Commit}}++;
3136 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3138 printdebug "quiltify investigate $c->{Commit}\n";
3141 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3142 printdebug " search finished hooray!\n";
3147 if ($quilt_mode eq 'nofix') {
3148 fail "quilt fixup required but quilt mode is \`nofix'\n".
3149 "HEAD commit $c->{Commit} differs from tree implied by ".
3150 " debian/patches (tree object $oldtiptree)";
3152 if ($quilt_mode eq 'smash') {
3153 printdebug " search quitting smash\n";
3157 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3158 $not->($c, "has $c_sentinels not $t_sentinels")
3159 if $c_sentinels ne $t_sentinels;
3161 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3162 $commitdata =~ m/\n\n/;
3164 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3165 @parents = map { { Commit => $_, Child => $c } } @parents;
3167 $not->($c, "root commit") if !@parents;
3169 foreach my $p (@parents) {
3170 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3172 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3173 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3175 foreach my $p (@parents) {
3176 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3178 my @cmd= (@git, qw(diff-tree -r --name-only),
3179 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3180 my $patchstackchange = cmdoutput @cmd;
3181 if (length $patchstackchange) {
3182 $patchstackchange =~ s/\n/,/g;
3183 $not->($p, "changed $patchstackchange");
3186 printdebug " search queue P=$p->{Commit} ",
3187 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3193 printdebug "quiltify want to smash\n";
3196 my $x = $_[0]{Commit};
3197 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3200 my $reportnot = sub {
3202 my $s = $abbrev->($notp);
3203 my $c = $notp->{Child};
3204 $s .= "..".$abbrev->($c) if $c;
3205 $s .= ": ".$notp->{Whynot};
3208 if ($quilt_mode eq 'linear') {
3209 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3210 foreach my $notp (@nots) {
3211 print STDERR "$us: ", $reportnot->($notp), "\n";
3213 print STDERR "$us: $_\n" foreach @$failsuggestion;
3214 fail "quilt fixup naive history linearisation failed.\n".
3215 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3216 } elsif ($quilt_mode eq 'smash') {
3217 } elsif ($quilt_mode eq 'auto') {
3218 progress "quilt fixup cannot be linear, smashing...";
3220 die "$quilt_mode ?";
3223 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3224 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3226 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3228 quiltify_dpkg_commit "auto-$version-$target-$time",
3229 (getfield $clogp, 'Maintainer'),
3230 "Automatically generated patch ($clogp->{Version})\n".
3231 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3235 progress "quiltify linearisation planning successful, executing...";
3237 for (my $p = $sref_S;
3238 my $c = $p->{Child};
3240 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3241 next unless $p->{Nontrivial};
3243 my $cc = $c->{Commit};
3245 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3246 $commitdata =~ m/\n\n/ or die "$c ?";
3249 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3252 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3255 my $patchname = $title;
3256 $patchname =~ s/[.:]$//;
3257 $patchname =~ y/ A-Z/-a-z/;
3258 $patchname =~ y/-a-z0-9_.+=~//cd;
3259 $patchname =~ s/^\W/x-$&/;
3260 $patchname = substr($patchname,0,40);
3263 stat "debian/patches/$patchname$index";
3265 $!==ENOENT or die "$patchname$index $!";
3267 runcmd @git, qw(checkout -q), $cc;
3269 # We use the tip's changelog so that dpkg-source doesn't
3270 # produce complaining messages from dpkg-parsechangelog. None
3271 # of the information dpkg-source gets from the changelog is
3272 # actually relevant - it gets put into the original message
3273 # which dpkg-source provides our stunt editor, and then
3275 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3277 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3278 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3280 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3283 runcmd @git, qw(checkout -q master);
3286 sub build_maybe_quilt_fixup () {
3287 my ($format,$fopts) = get_source_format;
3288 return unless madformat $format;
3291 check_for_vendor_patches();
3293 my $clogp = parsechangelog();
3294 my $headref = git_rev_parse('HEAD');
3299 my $upstreamversion=$version;
3300 $upstreamversion =~ s/-[^-]*$//;
3302 if ($fopts->{'single-debian-patch'}) {
3303 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3305 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3308 die 'bug' if $split_brain && !$need_split_build_invocation;
3310 changedir '../../../..';
3311 runcmd_ordryrun_local
3312 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3315 sub quilt_fixup_mkwork ($) {
3318 mkdir "work" or die $!;
3320 mktree_in_ud_here();
3321 runcmd @git, qw(reset -q --hard), $headref;
3324 sub quilt_fixup_linkorigs ($$) {
3325 my ($upstreamversion, $fn) = @_;
3326 # calls $fn->($leafname);
3328 foreach my $f (<../../../../*>) { #/){
3329 my $b=$f; $b =~ s{.*/}{};
3331 local ($debuglevel) = $debuglevel-1;
3332 printdebug "QF linkorigs $b, $f ?\n";
3334 next unless is_orig_file $b, srcfn $upstreamversion,'';
3335 printdebug "QF linkorigs $b, $f Y\n";
3336 link_ltarget $f, $b or die "$b $!";
3341 sub quilt_fixup_delete_pc () {
3342 runcmd @git, qw(rm -rqf .pc);
3343 commit_admin "Commit removal of .pc (quilt series tracking data)";
3346 sub quilt_fixup_singlepatch ($$$) {
3347 my ($clogp, $headref, $upstreamversion) = @_;
3349 progress "starting quiltify (single-debian-patch)";
3351 # dpkg-source --commit generates new patches even if
3352 # single-debian-patch is in debian/source/options. In order to
3353 # get it to generate debian/patches/debian-changes, it is
3354 # necessary to build the source package.
3356 quilt_fixup_linkorigs($upstreamversion, sub { });
3357 quilt_fixup_mkwork($headref);
3359 rmtree("debian/patches");
3361 runcmd @dpkgsource, qw(-b .);
3363 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3364 rename srcfn("$upstreamversion", "/debian/patches"),
3365 "work/debian/patches";
3368 commit_quilty_patch();
3371 sub quilt_make_fake_dsc ($) {
3372 my ($upstreamversion) = @_;
3374 my $fakeversion="$upstreamversion-~~DGITFAKE";
3376 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3377 print $fakedsc <<END or die $!;
3380 Version: $fakeversion
3384 my $dscaddfile=sub {
3387 my $md = new Digest::MD5;
3389 my $fh = new IO::File $b, '<' or die "$b $!";
3394 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3397 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3399 my @files=qw(debian/source/format debian/rules
3400 debian/control debian/changelog);
3401 foreach my $maybe (qw(debian/patches debian/source/options
3402 debian/tests/control)) {
3403 next unless stat_exists "../../../$maybe";
3404 push @files, $maybe;
3407 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3408 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3410 $dscaddfile->($debtar);
3411 close $fakedsc or die $!;
3414 sub quilt_check_splitbrain_cache ($$) {
3415 my ($headref, $upstreamversion) = @_;
3416 # Called only if we are in (potentially) split brain mode.
3418 # Computes the cache key and looks in the cache.
3419 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3421 my $splitbrain_cachekey;
3424 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3425 # we look in the reflog of dgit-intern/quilt-cache
3426 # we look for an entry whose message is the key for the cache lookup
3427 my @cachekey = (qw(dgit), $our_version);
3428 push @cachekey, $upstreamversion;
3429 push @cachekey, $quilt_mode;
3430 push @cachekey, $headref;
3432 push @cachekey, hashfile('fake.dsc');
3434 my $srcshash = Digest::SHA->new(256);
3435 my %sfs = ( %INC, '$0(dgit)' => $0 );
3436 foreach my $sfk (sort keys %sfs) {
3437 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3438 $srcshash->add($sfk," ");
3439 $srcshash->add(hashfile($sfs{$sfk}));
3440 $srcshash->add("\n");
3442 push @cachekey, $srcshash->hexdigest();
3443 $splitbrain_cachekey = "@cachekey";
3445 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3447 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3448 debugcmd "|(probably)",@cmd;
3449 my $child = open GC, "-|"; defined $child or die $!;
3451 chdir '../../..' or die $!;
3452 if (!stat ".git/logs/refs/$splitbraincache") {
3453 $! == ENOENT or die $!;
3454 printdebug ">(no reflog)\n";
3461 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3462 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3465 quilt_fixup_mkwork($headref);
3466 if ($cachehit ne $headref) {
3467 progress "dgit view: found cached (commit id $cachehit)";
3468 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3470 return ($cachehit, $splitbrain_cachekey);
3472 progress "dgit view: found cached, no changes required";
3473 return ($headref, $splitbrain_cachekey);
3475 die $! if GC->error;
3476 failedcmd unless close GC;
3478 printdebug "splitbrain cache miss\n";
3479 return (undef, $splitbrain_cachekey);
3482 sub quilt_fixup_multipatch ($$$) {
3483 my ($clogp, $headref, $upstreamversion) = @_;
3485 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3488 # - honour any existing .pc in case it has any strangeness
3489 # - determine the git commit corresponding to the tip of
3490 # the patch stack (if there is one)
3491 # - if there is such a git commit, convert each subsequent
3492 # git commit into a quilt patch with dpkg-source --commit
3493 # - otherwise convert all the differences in the tree into
3494 # a single git commit
3498 # Our git tree doesn't necessarily contain .pc. (Some versions of
3499 # dgit would include the .pc in the git tree.) If there isn't
3500 # one, we need to generate one by unpacking the patches that we
3503 # We first look for a .pc in the git tree. If there is one, we
3504 # will use it. (This is not the normal case.)
3506 # Otherwise need to regenerate .pc so that dpkg-source --commit
3507 # can work. We do this as follows:
3508 # 1. Collect all relevant .orig from parent directory
3509 # 2. Generate a debian.tar.gz out of
3510 # debian/{patches,rules,source/format,source/options}
3511 # 3. Generate a fake .dsc containing just these fields:
3512 # Format Source Version Files
3513 # 4. Extract the fake .dsc
3514 # Now the fake .dsc has a .pc directory.
3515 # (In fact we do this in every case, because in future we will
3516 # want to search for a good base commit for generating patches.)
3518 # Then we can actually do the dpkg-source --commit
3519 # 1. Make a new working tree with the same object
3520 # store as our main tree and check out the main
3522 # 2. Copy .pc from the fake's extraction, if necessary
3523 # 3. Run dpkg-source --commit
3524 # 4. If the result has changes to debian/, then
3525 # - git-add them them
3526 # - git-add .pc if we had a .pc in-tree
3528 # 5. If we had a .pc in-tree, delete it, and git-commit
3529 # 6. Back in the main tree, fast forward to the new HEAD
3531 # Another situation we may have to cope with is gbp-style
3532 # patches-unapplied trees.
3534 # We would want to detect these, so we know to escape into
3535 # quilt_fixup_gbp. However, this is in general not possible.
3536 # Consider a package with a one patch which the dgit user reverts
3537 # (with git-revert or the moral equivalent).
3539 # That is indistinguishable in contents from a patches-unapplied
3540 # tree. And looking at the history to distinguish them is not
3541 # useful because the user might have made a confusing-looking git
3542 # history structure (which ought to produce an error if dgit can't
3543 # cope, not a silent reintroduction of an unwanted patch).
3545 # So gbp users will have to pass an option. But we can usually
3546 # detect their failure to do so: if the tree is not a clean
3547 # patches-applied tree, quilt linearisation fails, but the tree
3548 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3549 # they want --quilt=unapplied.
3551 # To help detect this, when we are extracting the fake dsc, we
3552 # first extract it with --skip-patches, and then apply the patches
3553 # afterwards with dpkg-source --before-build. That lets us save a
3554 # tree object corresponding to .origs.
3556 my $splitbrain_cachekey;
3558 quilt_make_fake_dsc($upstreamversion);
3560 if (quiltmode_splitbrain()) {
3562 ($cachehit, $splitbrain_cachekey) =
3563 quilt_check_splitbrain_cache($headref, $upstreamversion);
3564 return if $cachehit;
3568 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3570 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3571 rename $fakexdir, "fake" or die "$fakexdir $!";
3575 remove_stray_gits();
3576 mktree_in_ud_here();
3580 runcmd @git, qw(add -Af .);
3581 my $unapplied=git_write_tree();
3582 printdebug "fake orig tree object $unapplied\n";
3587 'exec dpkg-source --before-build . >/dev/null';
3591 quilt_fixup_mkwork($headref);
3594 if (stat_exists ".pc") {
3596 progress "Tree already contains .pc - will use it then delete it.";
3599 rename '../fake/.pc','.pc' or die $!;
3602 changedir '../fake';
3604 runcmd @git, qw(add -Af .);
3605 my $oldtiptree=git_write_tree();
3606 printdebug "fake o+d/p tree object $unapplied\n";
3607 changedir '../work';
3610 # We calculate some guesswork now about what kind of tree this might
3611 # be. This is mostly for error reporting.
3616 # O = orig, without patches applied
3617 # A = "applied", ie orig with H's debian/patches applied
3618 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3619 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3620 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3624 foreach my $b (qw(01 02)) {
3625 foreach my $v (qw(H2O O2A H2A)) {
3626 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3629 printdebug "differences \@dl @dl.\n";
3632 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3633 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3634 $dl[0], $dl[1], $dl[3], $dl[4],
3638 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3639 push @failsuggestion, "This might be a patches-unapplied branch.";
3640 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3641 push @failsuggestion, "This might be a patches-applied branch.";
3643 push @failsuggestion, "Maybe you need to specify one of".
3644 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3646 if (quiltmode_splitbrain()) {
3647 quiltify_splitbrain($clogp, $unapplied, $headref,
3648 $diffbits, \%editedignores,
3649 $splitbrain_cachekey);
3653 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3654 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3656 if (!open P, '>>', ".pc/applied-patches") {
3657 $!==&ENOENT or die $!;
3662 commit_quilty_patch();
3664 if ($mustdeletepc) {
3665 quilt_fixup_delete_pc();
3669 sub quilt_fixup_editor () {
3670 my $descfn = $ENV{$fakeeditorenv};
3671 my $editing = $ARGV[$#ARGV];
3672 open I1, '<', $descfn or die "$descfn: $!";
3673 open I2, '<', $editing or die "$editing: $!";
3674 unlink $editing or die "$editing: $!";
3675 open O, '>', $editing or die "$editing: $!";
3676 while (<I1>) { print O or die $!; } I1->error and die $!;
3679 $copying ||= m/^\-\-\- /;
3680 next unless $copying;
3683 I2->error and die $!;
3688 sub maybe_apply_patches_dirtily () {
3689 return unless $quilt_mode =~ m/gbp|unapplied/;
3690 print STDERR <<END or die $!;
3692 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3693 dgit: Have to apply the patches - making the tree dirty.
3694 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3697 $patches_applied_dirtily = 01;
3698 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3699 runcmd qw(dpkg-source --before-build .);
3702 sub maybe_unapply_patches_again () {
3703 progress "dgit: Unapplying patches again to tidy up the tree."
3704 if $patches_applied_dirtily;
3705 runcmd qw(dpkg-source --after-build .)
3706 if $patches_applied_dirtily & 01;
3708 if $patches_applied_dirtily & 02;
3711 #----- other building -----
3713 our $clean_using_builder;
3714 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3715 # clean the tree before building (perhaps invoked indirectly by
3716 # whatever we are using to run the build), rather than separately
3717 # and explicitly by us.
3720 return if $clean_using_builder;
3721 if ($cleanmode eq 'dpkg-source') {
3722 maybe_apply_patches_dirtily();
3723 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3724 } elsif ($cleanmode eq 'dpkg-source-d') {
3725 maybe_apply_patches_dirtily();
3726 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3727 } elsif ($cleanmode eq 'git') {
3728 runcmd_ordryrun_local @git, qw(clean -xdf);
3729 } elsif ($cleanmode eq 'git-ff') {
3730 runcmd_ordryrun_local @git, qw(clean -xdff);
3731 } elsif ($cleanmode eq 'check') {
3732 my $leftovers = cmdoutput @git, qw(clean -xdn);
3733 if (length $leftovers) {
3734 print STDERR $leftovers, "\n" or die $!;
3735 fail "tree contains uncommitted files and --clean=check specified";
3737 } elsif ($cleanmode eq 'none') {
3744 badusage "clean takes no additional arguments" if @ARGV;
3747 maybe_unapply_patches_again();
3752 badusage "-p is not allowed when building" if defined $package;
3755 my $clogp = parsechangelog();
3756 $isuite = getfield $clogp, 'Distribution';
3757 $package = getfield $clogp, 'Source';
3758 $version = getfield $clogp, 'Version';
3759 build_maybe_quilt_fixup();
3761 my $pat = changespat $version;
3762 foreach my $f (glob "$buildproductsdir/$pat") {
3764 unlink $f or fail "remove old changes file $f: $!";
3766 progress "would remove $f";
3772 sub changesopts_initial () {
3773 my @opts =@changesopts[1..$#changesopts];
3776 sub changesopts_version () {
3777 if (!defined $changes_since_version) {
3778 my @vsns = archive_query('archive_query');
3779 my @quirk = access_quirk();
3780 if ($quirk[0] eq 'backports') {
3781 local $isuite = $quirk[2];
3783 canonicalise_suite();
3784 push @vsns, archive_query('archive_query');
3787 @vsns = map { $_->[0] } @vsns;
3788 @vsns = sort { -version_compare($a, $b) } @vsns;
3789 $changes_since_version = $vsns[0];
3790 progress "changelog will contain changes since $vsns[0]";
3792 $changes_since_version = '_';
3793 progress "package seems new, not specifying -v<version>";
3796 if ($changes_since_version ne '_') {
3797 return ("-v$changes_since_version");
3803 sub changesopts () {
3804 return (changesopts_initial(), changesopts_version());
3807 sub massage_dbp_args ($;$) {
3808 my ($cmd,$xargs) = @_;
3811 # - if we're going to split the source build out so we can
3812 # do strange things to it, massage the arguments to dpkg-buildpackage
3813 # so that the main build doessn't build source (or add an argument
3814 # to stop it building source by default).
3816 # - add -nc to stop dpkg-source cleaning the source tree,
3817 # unless we're not doing a split build and want dpkg-source
3818 # as cleanmode, in which case we can do nothing
3821 # 0 - source will NOT need to be built separately by caller
3822 # +1 - source will need to be built separately by caller
3823 # +2 - source will need to be built separately by caller AND
3824 # dpkg-buildpackage should not in fact be run at all!
3825 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3826 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3827 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3828 $clean_using_builder = 1;
3831 # -nc has the side effect of specifying -b if nothing else specified
3832 # and some combinations of -S, -b, et al, are errors, rather than
3833 # later simply overriding earlie. So we need to:
3834 # - search the command line for these options
3835 # - pick the last one
3836 # - perhaps add our own as a default
3837 # - perhaps adjust it to the corresponding non-source-building version
3839 foreach my $l ($cmd, $xargs) {
3841 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3844 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3846 if ($need_split_build_invocation) {
3847 printdebug "massage split $dmode.\n";
3848 $r = $dmode =~ m/[S]/ ? +2 :
3849 $dmode =~ y/gGF/ABb/ ? +1 :
3850 $dmode =~ m/[ABb]/ ? 0 :
3853 printdebug "massage done $r $dmode.\n";
3855 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3860 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3861 my $wantsrc = massage_dbp_args \@dbp;
3868 push @dbp, changesopts_version();
3869 maybe_apply_patches_dirtily();
3870 runcmd_ordryrun_local @dbp;
3872 maybe_unapply_patches_again();
3873 printdone "build successful\n";
3877 my @dbp = @dpkgbuildpackage;
3879 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3882 if (length executable_on_path('git-buildpackage')) {
3883 @cmd = qw(git-buildpackage);
3885 @cmd = qw(gbp buildpackage);
3887 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3892 if (!$clean_using_builder) {
3893 push @cmd, '--git-cleaner=true';
3898 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3899 canonicalise_suite();
3900 push @cmd, "--git-debian-branch=".lbranch();
3902 push @cmd, changesopts();
3903 maybe_apply_patches_dirtily();
3904 runcmd_ordryrun_local @cmd, @ARGV;
3906 maybe_unapply_patches_again();
3907 printdone "build successful\n";
3909 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3912 my $our_cleanmode = $cleanmode;
3913 if ($need_split_build_invocation) {
3914 # Pretend that clean is being done some other way. This
3915 # forces us not to try to use dpkg-buildpackage to clean and
3916 # build source all in one go; and instead we run dpkg-source
3917 # (and build_prep() will do the clean since $clean_using_builder
3919 $our_cleanmode = 'ELSEWHERE';
3921 if ($our_cleanmode =~ m/^dpkg-source/) {
3922 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3923 $clean_using_builder = 1;
3926 $sourcechanges = changespat $version,'source';
3928 unlink "../$sourcechanges" or $!==ENOENT
3929 or fail "remove $sourcechanges: $!";
3931 $dscfn = dscfn($version);
3932 if ($our_cleanmode eq 'dpkg-source') {
3933 maybe_apply_patches_dirtily();
3934 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3936 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3937 maybe_apply_patches_dirtily();
3938 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3941 my @cmd = (@dpkgsource, qw(-b --));
3944 runcmd_ordryrun_local @cmd, "work";
3945 my @udfiles = <${package}_*>;
3946 changedir "../../..";
3947 foreach my $f (@udfiles) {
3948 printdebug "source copy, found $f\n";
3951 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3952 $f eq srcfn($version, $&));
3953 printdebug "source copy, found $f - renaming\n";
3954 rename "$ud/$f", "../$f" or $!==ENOENT
3955 or fail "put in place new source file ($f): $!";
3958 my $pwd = must_getcwd();
3959 my $leafdir = basename $pwd;
3961 runcmd_ordryrun_local @cmd, $leafdir;
3964 runcmd_ordryrun_local qw(sh -ec),
3965 'exec >$1; shift; exec "$@"','x',
3966 "../$sourcechanges",
3967 @dpkggenchanges, qw(-S), changesopts();
3971 sub cmd_build_source {
3972 badusage "build-source takes no additional arguments" if @ARGV;
3974 maybe_unapply_patches_again();
3975 printdone "source built, results in $dscfn and $sourcechanges";
3980 my $pat = changespat $version;
3982 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3983 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3984 fail "changes files other than source matching $pat".
3985 " already present (@unwanted);".
3986 " building would result in ambiguity about the intended results"
3991 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3992 stat_exists $sourcechanges
3993 or fail "$sourcechanges (in parent directory): $!";
3995 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3996 my @changesfiles = glob $pat;
3997 @changesfiles = sort {
3998 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4001 fail "wrong number of different changes files (@changesfiles)"
4002 unless @changesfiles==2;
4003 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4004 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4005 fail "$l found in binaries changes file $binchanges"
4008 runcmd_ordryrun_local @mergechanges, @changesfiles;
4009 my $multichanges = changespat $version,'multi';
4011 stat_exists $multichanges or fail "$multichanges: $!";
4012 foreach my $cf (glob $pat) {
4013 next if $cf eq $multichanges;
4014 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4017 maybe_unapply_patches_again();
4018 printdone "build successful, results in $multichanges\n" or die $!;
4021 sub cmd_quilt_fixup {
4022 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4023 my $clogp = parsechangelog();
4024 $version = getfield $clogp, 'Version';
4025 $package = getfield $clogp, 'Source';
4028 build_maybe_quilt_fixup();
4031 sub cmd_archive_api_query {
4032 badusage "need only 1 subpath argument" unless @ARGV==1;
4033 my ($subpath) = @ARGV;
4034 my @cmd = archive_api_query_cmd($subpath);
4036 exec @cmd or fail "exec curl: $!\n";
4039 sub cmd_clone_dgit_repos_server {
4040 badusage "need destination argument" unless @ARGV==1;
4041 my ($destdir) = @ARGV;
4042 $package = '_dgit-repos-server';
4043 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4045 exec @cmd or fail "exec git clone: $!\n";
4048 sub cmd_setup_mergechangelogs {
4049 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4050 setup_mergechangelogs(1);
4053 sub cmd_setup_useremail {
4054 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4058 sub cmd_setup_new_tree {
4059 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4063 #---------- argument parsing and main program ----------
4066 print "dgit version $our_version\n" or die $!;
4070 our (%valopts_long, %valopts_short);
4073 sub defvalopt ($$$$) {
4074 my ($long,$short,$val_re,$how) = @_;
4075 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4076 $valopts_long{$long} = $oi;
4077 $valopts_short{$short} = $oi;
4078 # $how subref should:
4079 # do whatever assignemnt or thing it likes with $_[0]
4080 # if the option should not be passed on to remote, @rvalopts=()
4081 # or $how can be a scalar ref, meaning simply assign the value
4084 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4085 defvalopt '--distro', '-d', '.+', \$idistro;
4086 defvalopt '', '-k', '.+', \$keyid;
4087 defvalopt '--existing-package','', '.*', \$existing_package;
4088 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4089 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4090 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4092 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4094 defvalopt '', '-C', '.+', sub {
4095 ($changesfile) = (@_);
4096 if ($changesfile =~ s#^(.*)/##) {
4097 $buildproductsdir = $1;
4101 defvalopt '--initiator-tempdir','','.*', sub {
4102 ($initiator_tempdir) = (@_);
4103 $initiator_tempdir =~ m#^/# or
4104 badusage "--initiator-tempdir must be used specify an".
4105 " absolute, not relative, directory."
4111 if (defined $ENV{'DGIT_SSH'}) {
4112 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4113 } elsif (defined $ENV{'GIT_SSH'}) {
4114 @ssh = ($ENV{'GIT_SSH'});
4122 if (!defined $val) {
4123 badusage "$what needs a value" unless @ARGV;
4125 push @rvalopts, $val;
4127 badusage "bad value \`$val' for $what" unless
4128 $val =~ m/^$oi->{Re}$(?!\n)/s;
4129 my $how = $oi->{How};
4130 if (ref($how) eq 'SCALAR') {
4135 push @ropts, @rvalopts;
4139 last unless $ARGV[0] =~ m/^-/;
4143 if (m/^--dry-run$/) {
4146 } elsif (m/^--damp-run$/) {
4149 } elsif (m/^--no-sign$/) {
4152 } elsif (m/^--help$/) {
4154 } elsif (m/^--version$/) {
4156 } elsif (m/^--new$/) {
4159 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4160 ($om = $opts_opt_map{$1}) &&
4164 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4165 !$opts_opt_cmdonly{$1} &&
4166 ($om = $opts_opt_map{$1})) {
4169 } elsif (m/^--ignore-dirty$/s) {
4172 } elsif (m/^--no-quilt-fixup$/s) {
4174 $quilt_mode = 'nocheck';
4175 } elsif (m/^--no-rm-on-error$/s) {
4178 } elsif (m/^--(no-)?rm-old-changes$/s) {
4181 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4183 push @deliberatelies, $&;
4184 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4185 # undocumented, for testing
4187 $tagformat_want = [ $1, 'command line', 1 ];
4188 # 1 menas overrides distro configuration
4189 } elsif (m/^--always-split-source-build$/s) {
4190 # undocumented, for testing
4192 $need_split_build_invocation = 1;
4193 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4194 $val = $2 ? $' : undef; #';
4195 $valopt->($oi->{Long});
4197 badusage "unknown long option \`$_'";
4204 } elsif (s/^-L/-/) {
4207 } elsif (s/^-h/-/) {
4209 } elsif (s/^-D/-/) {
4213 } elsif (s/^-N/-/) {
4218 push @changesopts, $_;
4220 } elsif (s/^-wn$//s) {
4222 $cleanmode = 'none';
4223 } elsif (s/^-wg$//s) {
4226 } elsif (s/^-wgf$//s) {
4228 $cleanmode = 'git-ff';
4229 } elsif (s/^-wd$//s) {
4231 $cleanmode = 'dpkg-source';
4232 } elsif (s/^-wdd$//s) {
4234 $cleanmode = 'dpkg-source-d';
4235 } elsif (s/^-wc$//s) {
4237 $cleanmode = 'check';
4238 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4240 $val = undef unless length $val;
4241 $valopt->($oi->{Short});
4244 badusage "unknown short option \`$_'";
4251 sub finalise_opts_opts () {
4252 foreach my $k (keys %opts_opt_map) {
4253 my $om = $opts_opt_map{$k};
4255 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4257 badcfg "cannot set command for $k"
4258 unless length $om->[0];
4262 foreach my $c (access_cfg_cfgs("opts-$k")) {
4263 my $vl = $gitcfg{$c};
4264 printdebug "CL $c ",
4265 ($vl ? join " ", map { shellquote } @$vl : ""),
4266 "\n" if $debuglevel >= 4;
4268 badcfg "cannot configure options for $k"
4269 if $opts_opt_cmdonly{$k};
4270 my $insertpos = $opts_cfg_insertpos{$k};
4271 @$om = ( @$om[0..$insertpos-1],
4273 @$om[$insertpos..$#$om] );
4278 if ($ENV{$fakeeditorenv}) {
4280 quilt_fixup_editor();
4286 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4287 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4288 if $dryrun_level == 1;
4290 print STDERR $helpmsg or die $!;
4293 my $cmd = shift @ARGV;
4296 if (!defined $rmchanges) {
4297 local $access_forpush;
4298 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4301 if (!defined $quilt_mode) {
4302 local $access_forpush;
4303 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4304 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4306 $quilt_mode =~ m/^($quilt_modes_re)$/
4307 or badcfg "unknown quilt-mode \`$quilt_mode'";
4311 $need_split_build_invocation ||= quiltmode_splitbrain();
4313 if (!defined $cleanmode) {
4314 local $access_forpush;
4315 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4316 $cleanmode //= 'dpkg-source';
4318 badcfg "unknown clean-mode \`$cleanmode'" unless
4319 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4322 my $fn = ${*::}{"cmd_$cmd"};
4323 $fn or badusage "unknown operation $cmd";