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 () {
1611 qw(tags heads), $branchprefix;
1613 # This is rather miserable:
1614 # When git-fetch --prune is passed a fetchspec ending with a *,
1615 # it does a plausible thing. If there is no * then:
1616 # - it matches subpaths too, even if the supplied refspec
1617 # starts refs, and behaves completely madly if the source
1618 # has refs/refs/something. (See, for example, Debian #NNNN.)
1619 # - if there is no matching remote ref, it bombs out the whole
1621 # We want to fetch a fixed ref, and we don't know in advance
1622 # if it exists, so this is not suitable.
1624 # Our workaround is to use git-ls-remote. git-ls-remote has its
1625 # own qairks. Notably, it has the absurd multi-tail-matching
1626 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1627 # refs/refs/foo etc.
1629 # Also, we want an idempotent snapshot, but we have to make two
1630 # calls to the remote: one to git-ls-remote and to git-fetch. The
1631 # solution is use git-ls-remote to obtain a target state, and
1632 # git-fetch to try to generate it. If we don't manage to generate
1633 # the target state, we try again.
1635 my $specre = join '|', map {
1641 printdebug "git_fetch_us specre=$specre\n";
1642 my $wanted_rref = sub {
1644 return m/^(?:$specre)$/o;
1649 my $fetch_iteration = 0;
1652 if (++$fetch_iteration > 10) {
1653 fail "too many iterations trying to get sane fetch!";
1656 my @look = map { "refs/$_" } @specs;
1657 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1661 open GITLS, "-|", @lcmd or die $!;
1663 printdebug "=> ", $_;
1664 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1665 my ($objid,$rrefname) = ($1,$2);
1666 if (!$wanted_rref->($rrefname)) {
1668 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1672 $wantr{$rrefname} = $objid;
1675 close GITLS or failedcmd @lcmd;
1677 # OK, now %want is exactly what we want for refs in @specs
1679 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1680 "+refs/$_:".lrfetchrefs."/$_";
1683 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1684 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1687 %lrfetchrefs_f = ();
1690 git_for_each_ref(lrfetchrefs, sub {
1691 my ($objid,$objtype,$lrefname,$reftail) = @_;
1692 $lrfetchrefs_f{$lrefname} = $objid;
1693 $objgot{$objid} = 1;
1696 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1697 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1698 if (!exists $wantr{$rrefname}) {
1699 if ($wanted_rref->($rrefname)) {
1701 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1705 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1708 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1709 delete $lrfetchrefs_f{$lrefname};
1713 foreach my $rrefname (sort keys %wantr) {
1714 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1715 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1716 my $want = $wantr{$rrefname};
1717 next if $got eq $want;
1718 if (!defined $objgot{$want}) {
1720 warning: git-ls-remote suggests we want $lrefname
1721 warning: and it should refer to $want
1722 warning: but git-fetch didn't fetch that object to any relevant ref.
1723 warning: This may be due to a race with someone updating the server.
1724 warning: Will try again...
1726 next FETCH_ITERATION;
1729 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1731 runcmd_ordryrun_local @git, qw(update-ref -m),
1732 "dgit fetch git-fetch fixup", $lrefname, $want;
1733 $lrfetchrefs_f{$lrefname} = $want;
1737 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1738 Dumper(\%lrfetchrefs_f);
1741 my @tagpats = debiantags('*',access_basedistro);
1743 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1744 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1745 printdebug "currently $fullrefname=$objid\n";
1746 $here{$fullrefname} = $objid;
1748 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1749 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1750 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1751 printdebug "offered $lref=$objid\n";
1752 if (!defined $here{$lref}) {
1753 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1754 runcmd_ordryrun_local @upd;
1755 } elsif ($here{$lref} eq $objid) {
1758 "Not updateting $lref from $here{$lref} to $objid.\n";
1763 sub mergeinfo_getclogp ($) {
1765 # Ensures thit $mi->{Clogp} exists and returns it
1766 return $mi->{Clogp} if $mi->{Clogp};
1767 my $mclog = ".git/dgit/clog-$mi->{Commit}";
1769 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1770 "$mi->{Commit}:debian/changelog";
1771 $mi->{Clogp} = parsechangelog("-l$mclog");
1774 sub mergeinfo_version ($) {
1775 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1778 sub fetch_from_archive () {
1779 # ensures that lrref() is what is actually in the archive,
1780 # one way or another
1784 foreach my $field (@ourdscfield) {
1785 $dsc_hash = $dsc->{$field};
1786 last if defined $dsc_hash;
1788 if (defined $dsc_hash) {
1789 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1791 progress "last upload to archive specified git hash";
1793 progress "last upload to archive has NO git hash";
1796 progress "no version available from the archive";
1799 # If the archive's .dsc has a Dgit field, there are three
1800 # relevant git commitids we need to choose between and/or merge
1802 # 1. $dsc_hash: the Dgit field from the archive
1803 # 2. $lastpush_hash: the suite branch on the dgit git server
1804 # 3. $lastfetch_hash: our local tracking brach for the suite
1806 # These may all be distinct and need not be in any fast forward
1809 # If the dsc was pushed to this suite, then the server suite
1810 # branch will have been updated; but it might have been pushed to
1811 # a different suite and copied by the archive. Conversely a more
1812 # recent version may have been pushed with dgit but not appeared
1813 # in the archive (yet).
1815 # $lastfetch_hash may be awkward because archive imports
1816 # (particularly, imports of Dgit-less .dscs) are performed only as
1817 # needed on individual clients, so different clients may perform a
1818 # different subset of them - and these imports are only made
1819 # public during push. So $lastfetch_hash may represent a set of
1820 # imports different to a subsequent upload by a different dgit
1823 # Our approach is as follows:
1825 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1826 # descendant of $dsc_hash, then it was pushed by a dgit user who
1827 # had based their work on $dsc_hash, so we should prefer it.
1828 # Otherwise, $dsc_hash was installed into this suite in the
1829 # archive other than by a dgit push, and (necessarily) after the
1830 # last dgit push into that suite (since a dgit push would have
1831 # been descended from the dgit server git branch); thus, in that
1832 # case, we prefer the archive's version (and produce a
1833 # pseudo-merge to overwrite the dgit server git branch).
1835 # (If there is no Dgit field in the archive's .dsc then
1836 # generate_commit_from_dsc uses the version numbers to decide
1837 # whether the suite branch or the archive is newer. If the suite
1838 # branch is newer it ignores the archive's .dsc; otherwise it
1839 # generates an import of the .dsc, and produces a pseudo-merge to
1840 # overwrite the suite branch with the archive contents.)
1842 # The outcome of that part of the algorithm is the `public view',
1843 # and is same for all dgit clients: it does not depend on any
1844 # unpublished history in the local tracking branch.
1846 # As between the public view and the local tracking branch: The
1847 # local tracking branch is only updated by dgit fetch, and
1848 # whenever dgit fetch runs it includes the public view in the
1849 # local tracking branch. Therefore if the public view is not
1850 # descended from the local tracking branch, the local tracking
1851 # branch must contain history which was imported from the archive
1852 # but never pushed; and, its tip is now out of date. So, we make
1853 # a pseudo-merge to overwrite the old imports and stitch the old
1856 # Finally: we do not necessarily reify the public view (as
1857 # described above). This is so that we do not end up stacking two
1858 # pseudo-merges. So what we actually do is figure out the inputs
1859 # to any public view psuedo-merge and put them in @mergeinputs.
1862 # $mergeinputs[]{Commit}
1863 # $mergeinputs[]{Info}
1864 # $mergeinputs[0] is the one whose tree we use
1865 # @mergeinputs is in the order we use in the actual commit)
1868 # $mergeinputs[]{Message} is a commit message to use
1869 # $mergeinputs[]{ReverseParents} if def specifies that parent
1870 # list should be in opposite order
1871 # Such an entry has no Commit or Info. It applies only when found
1872 # in the last entry. (This ugliness is to support making
1873 # identical imports to previous dgit versions.)
1875 my $lastpush_hash = git_get_ref(lrfetchref());
1876 printdebug "previous reference hash=$lastpush_hash\n";
1877 $lastpush_mergeinput = $lastpush_hash && {
1878 Commit => $lastpush_hash,
1879 Info => "dgit suite branch on dgit git server",
1882 my $lastfetch_hash = git_get_ref(lrref());
1883 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1884 my $lastfetch_mergeinput = $lastfetch_hash && {
1885 Commit => $lastfetch_hash,
1886 Info => "dgit client's archive history view",
1889 my $dsc_mergeinput = $dsc_hash && {
1890 Commit => $dsc_hash,
1891 Info => "Dgit field in .dsc from archive",
1894 if (defined $dsc_hash) {
1895 fail "missing remote git history even though dsc has hash -".
1896 " could not find ref ".rref()." at ".access_giturl()
1897 unless $lastpush_hash;
1898 ensure_we_have_orig();
1899 if ($dsc_hash eq $lastpush_hash) {
1900 @mergeinputs = $dsc_mergeinput
1901 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1902 print STDERR <<END or die $!;
1904 Git commit in archive is behind the last version allegedly pushed/uploaded.
1905 Commit referred to by archive: $dsc_hash
1906 Last version pushed with dgit: $lastpush_hash
1909 @mergeinputs = ($lastpush_mergeinput);
1911 # Archive has .dsc which is not a descendant of the last dgit
1912 # push. This can happen if the archive moves .dscs about.
1913 # Just follow its lead.
1914 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1915 progress "archive .dsc names newer git commit";
1916 @mergeinputs = ($dsc_mergeinput);
1918 progress "archive .dsc names other git commit, fixing up";
1919 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1923 @mergeinputs = generate_commits_from_dsc();
1924 # We have just done an import. Now, our import algorithm might
1925 # have been improved. But even so we do not want to generate
1926 # a new different import of the same package. So if the
1927 # version numbers are the same, just use our existing version.
1928 # If the version numbers are different, the archive has changed
1929 # (perhaps, rewound).
1930 if ($lastfetch_mergeinput &&
1931 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1932 (mergeinfo_version $mergeinputs[0]) )) {
1933 @mergeinputs = ($lastfetch_mergeinput);
1935 } elsif ($lastpush_hash) {
1936 # only in git, not in the archive yet
1937 @mergeinputs = ($lastpush_mergeinput);
1938 print STDERR <<END or die $!;
1940 Package not found in the archive, but has allegedly been pushed using dgit.
1944 printdebug "nothing found!\n";
1945 if (defined $skew_warning_vsn) {
1946 print STDERR <<END or die $!;
1948 Warning: relevant archive skew detected.
1949 Archive allegedly contains $skew_warning_vsn
1950 But we were not able to obtain any version from the archive or git.
1957 if ($lastfetch_hash &&
1959 my $h = $_->{Commit};
1960 $h and is_fast_fwd($lastfetch_hash, $h);
1961 # If true, one of the existing parents of this commit
1962 # is a descendant of the $lastfetch_hash, so we'll
1963 # be ff from that automatically.
1967 push @mergeinputs, $lastfetch_mergeinput;
1970 printdebug "fetch mergeinfos:\n";
1971 foreach my $mi (@mergeinputs) {
1973 printdebug " commit $mi->{Commit} $mi->{Info}\n";
1975 printdebug sprintf " ReverseParents=%d Message=%s",
1976 $mi->{ReverseParents}, $mi->{Message};
1980 my $compat_info= pop @mergeinputs
1981 if $mergeinputs[$#mergeinputs]{Message};
1983 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
1986 if (@mergeinputs > 1) {
1988 my $tree_commit = $mergeinputs[0]{Commit};
1990 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
1991 $tree =~ m/\n\n/; $tree = $`;
1992 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
1995 # We use the changelog author of the package in question the
1996 # author of this pseudo-merge. This is (roughly) correct if
1997 # this commit is simply representing aa non-dgit upload.
1998 # (Roughly because it does not record sponsorship - but we
1999 # don't have sponsorship info because that's in the .changes,
2000 # which isn't in the archivw.)
2002 # But, it might be that we are representing archive history
2003 # updates (including in-archive copies). These are not really
2004 # the responsibility of the person who created the .dsc, but
2005 # there is no-one whose name we should better use. (The
2006 # author of the .dsc-named commit is clearly worse.)
2008 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2009 my $author = clogp_authline $useclogp;
2010 my $cversion = getfield $useclogp, 'Version';
2012 my $mcf = ".git/dgit/mergecommit";
2013 open MC, ">", $mcf or die "$mcf $!";
2014 print MC <<END or die $!;
2018 my @parents = grep { $_->{Commit} } @mergeinputs;
2019 @parents = reverse @parents if $compat_info->{ReverseParents};
2020 print MC <<END or die $! foreach @parents;
2024 print MC <<END or die $!;
2030 if (defined $compat_info->{Message}) {
2031 print MC $compat_info->{Message} or die $!;
2033 print MC <<END or die $!;
2034 Record $package ($cversion) in archive suite $csuite
2038 my $message_add_info = sub {
2040 my $mversion = mergeinfo_version $mi;
2041 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2045 $message_add_info->($mergeinputs[0]);
2046 print MC <<END or die $!;
2047 should be treated as descended from
2049 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2053 $hash = make_commit $mcf;
2055 $hash = $mergeinputs[0]{Commit};
2057 progress "fetch hash=$hash\n";
2060 my ($lasth, $what) = @_;
2061 return unless $lasth;
2062 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2065 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2066 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2068 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2069 'DGIT_ARCHIVE', $hash;
2070 cmdoutput @git, qw(log -n2), $hash;
2071 # ... gives git a chance to complain if our commit is malformed
2073 if (defined $skew_warning_vsn) {
2075 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2076 my $clogf = ".git/dgit/changelog.tmp";
2077 runcmd shell_cmd "exec >$clogf",
2078 @git, qw(cat-file blob), "$hash:debian/changelog";
2079 my $gotclogp = parsechangelog("-l$clogf");
2080 my $got_vsn = getfield $gotclogp, 'Version';
2081 printdebug "SKEW CHECK GOT $got_vsn\n";
2082 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2083 print STDERR <<END or die $!;
2085 Warning: archive skew detected. Using the available version:
2086 Archive allegedly contains $skew_warning_vsn
2087 We were able to obtain only $got_vsn
2093 if ($lastfetch_hash ne $hash) {
2094 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2098 dryrun_report @upd_cmd;
2104 sub set_local_git_config ($$) {
2106 runcmd @git, qw(config), $k, $v;
2109 sub setup_mergechangelogs (;$) {
2111 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2113 my $driver = 'dpkg-mergechangelogs';
2114 my $cb = "merge.$driver";
2115 my $attrs = '.git/info/attributes';
2116 ensuredir '.git/info';
2118 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2119 if (!open ATTRS, "<", $attrs) {
2120 $!==ENOENT or die "$attrs: $!";
2124 next if m{^debian/changelog\s};
2125 print NATTRS $_, "\n" or die $!;
2127 ATTRS->error and die $!;
2130 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2133 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2134 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2136 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2139 sub setup_useremail (;$) {
2141 return unless $always || access_cfg_bool(1, 'setup-useremail');
2144 my ($k, $envvar) = @_;
2145 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2146 return unless defined $v;
2147 set_local_git_config "user.$k", $v;
2150 $setup->('email', 'DEBEMAIL');
2151 $setup->('name', 'DEBFULLNAME');
2154 sub setup_new_tree () {
2155 setup_mergechangelogs();
2161 canonicalise_suite();
2162 badusage "dry run makes no sense with clone" unless act_local();
2163 my $hasgit = check_for_git();
2164 mkdir $dstdir or fail "create \`$dstdir': $!";
2166 runcmd @git, qw(init -q);
2167 my $giturl = access_giturl(1);
2168 if (defined $giturl) {
2169 open H, "> .git/HEAD" or die $!;
2170 print H "ref: ".lref()."\n" or die $!;
2172 runcmd @git, qw(remote add), 'origin', $giturl;
2175 progress "fetching existing git history";
2177 runcmd_ordryrun_local @git, qw(fetch origin);
2179 progress "starting new git history";
2181 fetch_from_archive() or no_such_package;
2182 my $vcsgiturl = $dsc->{'Vcs-Git'};
2183 if (length $vcsgiturl) {
2184 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2185 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2188 runcmd @git, qw(reset --hard), lrref();
2189 printdone "ready for work in $dstdir";
2193 if (check_for_git()) {
2196 fetch_from_archive() or no_such_package();
2197 printdone "fetched into ".lrref();
2202 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2204 printdone "fetched to ".lrref()." and merged into HEAD";
2207 sub check_not_dirty () {
2208 foreach my $f (qw(local-options local-patch-header)) {
2209 if (stat_exists "debian/source/$f") {
2210 fail "git tree contains debian/source/$f";
2214 return if $ignoredirty;
2216 my @cmd = (@git, qw(diff --quiet HEAD));
2218 $!=0; $?=-1; system @cmd;
2221 fail "working tree is dirty (does not match HEAD)";
2227 sub commit_admin ($) {
2230 runcmd_ordryrun_local @git, qw(commit -m), $m;
2233 sub commit_quilty_patch () {
2234 my $output = cmdoutput @git, qw(status --porcelain);
2236 foreach my $l (split /\n/, $output) {
2237 next unless $l =~ m/\S/;
2238 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2242 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2244 progress "nothing quilty to commit, ok.";
2247 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2248 runcmd_ordryrun_local @git, qw(add -f), @adds;
2249 commit_admin "Commit Debian 3.0 (quilt) metadata";
2252 sub get_source_format () {
2254 if (open F, "debian/source/options") {
2258 s/\s+$//; # ignore missing final newline
2260 my ($k, $v) = ($`, $'); #');
2261 $v =~ s/^"(.*)"$/$1/;
2267 F->error and die $!;
2270 die $! unless $!==&ENOENT;
2273 if (!open F, "debian/source/format") {
2274 die $! unless $!==&ENOENT;
2278 F->error and die $!;
2280 return ($_, \%options);
2285 return 0 unless $format eq '3.0 (quilt)';
2286 our $quilt_mode_warned;
2287 if ($quilt_mode eq 'nocheck') {
2288 progress "Not doing any fixup of \`$format' due to".
2289 " ----no-quilt-fixup or --quilt=nocheck"
2290 unless $quilt_mode_warned++;
2293 progress "Format \`$format', need to check/update patch stack"
2294 unless $quilt_mode_warned++;
2298 sub push_parse_changelog ($) {
2301 my $clogp = Dpkg::Control::Hash->new();
2302 $clogp->load($clogpfn) or die;
2304 $package = getfield $clogp, 'Source';
2305 my $cversion = getfield $clogp, 'Version';
2306 my $tag = debiantag($cversion, access_basedistro);
2307 runcmd @git, qw(check-ref-format), $tag;
2309 my $dscfn = dscfn($cversion);
2311 return ($clogp, $cversion, $dscfn);
2314 sub push_parse_dsc ($$$) {
2315 my ($dscfn,$dscfnwhat, $cversion) = @_;
2316 $dsc = parsecontrol($dscfn,$dscfnwhat);
2317 my $dversion = getfield $dsc, 'Version';
2318 my $dscpackage = getfield $dsc, 'Source';
2319 ($dscpackage eq $package && $dversion eq $cversion) or
2320 fail "$dscfn is for $dscpackage $dversion".
2321 " but debian/changelog is for $package $cversion";
2324 sub push_tagwants ($$$$) {
2325 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2328 TagFn => \&debiantag,
2333 if (defined $maintviewhead) {
2335 TagFn => \&debiantag_maintview,
2336 Objid => $maintviewhead,
2337 TfSuffix => '-maintview',
2341 foreach my $tw (@tagwants) {
2342 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2343 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2348 sub push_mktags ($$ $$ $) {
2350 $changesfile,$changesfilewhat,
2353 die unless $tagwants->[0]{View} eq 'dgit';
2355 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2356 $dsc->save("$dscfn.tmp") or die $!;
2358 my $changes = parsecontrol($changesfile,$changesfilewhat);
2359 foreach my $field (qw(Source Distribution Version)) {
2360 $changes->{$field} eq $clogp->{$field} or
2361 fail "changes field $field \`$changes->{$field}'".
2362 " does not match changelog \`$clogp->{$field}'";
2365 my $cversion = getfield $clogp, 'Version';
2366 my $clogsuite = getfield $clogp, 'Distribution';
2368 # We make the git tag by hand because (a) that makes it easier
2369 # to control the "tagger" (b) we can do remote signing
2370 my $authline = clogp_authline $clogp;
2371 my $delibs = join(" ", "",@deliberatelies);
2372 my $declaredistro = access_basedistro();
2376 my $tfn = $tw->{Tfn};
2377 my $head = $tw->{Objid};
2378 my $tag = $tw->{Tag};
2380 open TO, '>', $tfn->('.tmp') or die $!;
2381 print TO <<END or die $!;
2388 if ($tw->{View} eq 'dgit') {
2389 print TO <<END or die $!;
2390 $package release $cversion for $clogsuite ($csuite) [dgit]
2391 [dgit distro=$declaredistro$delibs]
2393 foreach my $ref (sort keys %previously) {
2394 print TO <<END or die $!;
2395 [dgit previously:$ref=$previously{$ref}]
2398 } elsif ($tw->{View} eq 'maint') {
2399 print TO <<END or die $!;
2400 $package release $cversion for $clogsuite ($csuite)
2401 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2404 die Dumper($tw)."?";
2409 my $tagobjfn = $tfn->('.tmp');
2411 if (!defined $keyid) {
2412 $keyid = access_cfg('keyid','RETURN-UNDEF');
2414 if (!defined $keyid) {
2415 $keyid = getfield $clogp, 'Maintainer';
2417 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2418 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2419 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2420 push @sign_cmd, $tfn->('.tmp');
2421 runcmd_ordryrun @sign_cmd;
2423 $tagobjfn = $tfn->('.signed.tmp');
2424 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2425 $tfn->('.tmp'), $tfn->('.tmp.asc');
2431 my @r = map { $mktag->($_); } @$tagwants;
2435 sub sign_changes ($) {
2436 my ($changesfile) = @_;
2438 my @debsign_cmd = @debsign;
2439 push @debsign_cmd, "-k$keyid" if defined $keyid;
2440 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2441 push @debsign_cmd, $changesfile;
2442 runcmd_ordryrun @debsign_cmd;
2447 my ($forceflag) = @_;
2448 printdebug "actually entering push\n";
2449 supplementary_message(<<'END');
2450 Push failed, while preparing your push.
2451 You can retry the push, after fixing the problem, if you like.
2454 need_tagformat 'new', "quilt mode $quilt_mode"
2455 if quiltmode_splitbrain;
2459 access_giturl(); # check that success is vaguely likely
2462 my $clogpfn = ".git/dgit/changelog.822.tmp";
2463 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2465 responder_send_file('parsed-changelog', $clogpfn);
2467 my ($clogp, $cversion, $dscfn) =
2468 push_parse_changelog("$clogpfn");
2470 my $dscpath = "$buildproductsdir/$dscfn";
2471 stat_exists $dscpath or
2472 fail "looked for .dsc $dscfn, but $!;".
2473 " maybe you forgot to build";
2475 responder_send_file('dsc', $dscpath);
2477 push_parse_dsc($dscpath, $dscfn, $cversion);
2479 my $format = getfield $dsc, 'Format';
2480 printdebug "format $format\n";
2482 my $actualhead = git_rev_parse('HEAD');
2483 my $dgithead = $actualhead;
2484 my $maintviewhead = undef;
2486 if (madformat($format)) {
2487 # user might have not used dgit build, so maybe do this now:
2488 if (quiltmode_splitbrain()) {
2489 my $upstreamversion = $clogp->{Version};
2490 $upstreamversion =~ s/-[^-]*$//;
2492 quilt_make_fake_dsc($upstreamversion);
2493 my ($dgitview, $cachekey) =
2494 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2496 "--quilt=$quilt_mode but no cached dgit view:
2497 perhaps tree changed since dgit build[-source] ?";
2499 $dgithead = $dgitview;
2500 $maintviewhead = $actualhead;
2501 changedir '../../../..';
2502 prep_ud(); # so _only_subdir() works, below
2504 commit_quilty_patch();
2510 progress "checking that $dscfn corresponds to HEAD";
2511 runcmd qw(dpkg-source -x --),
2512 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2513 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2514 check_for_vendor_patches() if madformat($dsc->{format});
2515 changedir '../../../..';
2516 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2517 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2518 debugcmd "+",@diffcmd;
2520 my $r = system @diffcmd;
2523 fail "$dscfn specifies a different tree to your HEAD commit;".
2524 " perhaps you forgot to build".
2525 ($diffopt eq '--exit-code' ? "" :
2526 " (run with -D to see full diff output)");
2531 if (!$changesfile) {
2532 my $pat = changespat $cversion;
2533 my @cs = glob "$buildproductsdir/$pat";
2534 fail "failed to find unique changes file".
2535 " (looked for $pat in $buildproductsdir);".
2536 " perhaps you need to use dgit -C"
2538 ($changesfile) = @cs;
2540 $changesfile = "$buildproductsdir/$changesfile";
2543 responder_send_file('changes',$changesfile);
2544 responder_send_command("param head $dgithead");
2545 responder_send_command("param csuite $csuite");
2546 responder_send_command("param tagformat $tagformat");
2547 if (quiltmode_splitbrain) {
2548 die unless ($protovsn//4) >= 4;
2549 responder_send_command("param maint-view $maintviewhead");
2552 if (deliberately_not_fast_forward) {
2553 git_for_each_ref(lrfetchrefs, sub {
2554 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2555 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2556 responder_send_command("previously $rrefname=$objid");
2557 $previously{$rrefname} = $objid;
2561 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2565 supplementary_message(<<'END');
2566 Push failed, while signing the tag.
2567 You can retry the push, after fixing the problem, if you like.
2569 # If we manage to sign but fail to record it anywhere, it's fine.
2570 if ($we_are_responder) {
2571 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2572 responder_receive_files('signed-tag', @tagobjfns);
2574 @tagobjfns = push_mktags($clogp,$dscpath,
2575 $changesfile,$changesfile,
2578 supplementary_message(<<'END');
2579 Push failed, *after* signing the tag.
2580 If you want to try again, you should use a new version number.
2583 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2585 foreach my $tw (@tagwants) {
2586 my $tag = $tw->{Tag};
2587 my $tagobjfn = $tw->{TagObjFn};
2589 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2590 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2591 runcmd_ordryrun_local
2592 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2595 supplementary_message(<<'END');
2596 Push failed, while updating the remote git repository - see messages above.
2597 If you want to try again, you should use a new version number.
2599 if (!check_for_git()) {
2600 create_remote_git_repo();
2603 my @pushrefs = $forceflag."HEAD:".rrref();
2604 foreach my $tw (@tagwants) {
2605 my $view = $tw->{View};
2606 next unless $view eq 'dgit'
2607 or any { $_ eq $view } access_cfg_tagformats();
2608 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2611 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2612 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2614 supplementary_message(<<'END');
2615 Push failed, after updating the remote git repository.
2616 If you want to try again, you must use a new version number.
2618 if ($we_are_responder) {
2619 my $dryrunsuffix = act_local() ? "" : ".tmp";
2620 responder_receive_files('signed-dsc-changes',
2621 "$dscpath$dryrunsuffix",
2622 "$changesfile$dryrunsuffix");
2625 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2627 progress "[new .dsc left in $dscpath.tmp]";
2629 sign_changes $changesfile;
2632 supplementary_message(<<END);
2633 Push failed, while uploading package(s) to the archive server.
2634 You can retry the upload of exactly these same files with dput of:
2636 If that .changes file is broken, you will need to use a new version
2637 number for your next attempt at the upload.
2639 my $host = access_cfg('upload-host','RETURN-UNDEF');
2640 my @hostarg = defined($host) ? ($host,) : ();
2641 runcmd_ordryrun @dput, @hostarg, $changesfile;
2642 printdone "pushed and uploaded $cversion";
2644 supplementary_message('');
2645 responder_send_command("complete");
2652 badusage "-p is not allowed with clone; specify as argument instead"
2653 if defined $package;
2656 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2657 ($package,$isuite) = @ARGV;
2658 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2659 ($package,$dstdir) = @ARGV;
2660 } elsif (@ARGV==3) {
2661 ($package,$isuite,$dstdir) = @ARGV;
2663 badusage "incorrect arguments to dgit clone";
2665 $dstdir ||= "$package";
2667 if (stat_exists $dstdir) {
2668 fail "$dstdir already exists";
2672 if ($rmonerror && !$dryrun_level) {
2673 $cwd_remove= getcwd();
2675 return unless defined $cwd_remove;
2676 if (!chdir "$cwd_remove") {
2677 return if $!==&ENOENT;
2678 die "chdir $cwd_remove: $!";
2681 rmtree($dstdir) or die "remove $dstdir: $!\n";
2682 } elsif (!grep { $! == $_ }
2683 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2685 print STDERR "check whether to remove $dstdir: $!\n";
2691 $cwd_remove = undef;
2694 sub branchsuite () {
2695 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2696 if ($branch =~ m#$lbranch_re#o) {
2703 sub fetchpullargs () {
2705 if (!defined $package) {
2706 my $sourcep = parsecontrol('debian/control','debian/control');
2707 $package = getfield $sourcep, 'Source';
2710 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2712 my $clogp = parsechangelog();
2713 $isuite = getfield $clogp, 'Distribution';
2715 canonicalise_suite();
2716 progress "fetching from suite $csuite";
2717 } elsif (@ARGV==1) {
2719 canonicalise_suite();
2721 badusage "incorrect arguments to dgit fetch or dgit pull";
2740 badusage "-p is not allowed with dgit push" if defined $package;
2742 my $clogp = parsechangelog();
2743 $package = getfield $clogp, 'Source';
2746 } elsif (@ARGV==1) {
2747 ($specsuite) = (@ARGV);
2749 badusage "incorrect arguments to dgit push";
2751 $isuite = getfield $clogp, 'Distribution';
2753 local ($package) = $existing_package; # this is a hack
2754 canonicalise_suite();
2756 canonicalise_suite();
2758 if (defined $specsuite &&
2759 $specsuite ne $isuite &&
2760 $specsuite ne $csuite) {
2761 fail "dgit push: changelog specifies $isuite ($csuite)".
2762 " but command line specifies $specsuite";
2764 supplementary_message(<<'END');
2765 Push failed, while checking state of the archive.
2766 You can retry the push, after fixing the problem, if you like.
2768 if (check_for_git()) {
2772 if (fetch_from_archive()) {
2773 if (is_fast_fwd(lrref(), 'HEAD')) {
2775 } elsif (deliberately_not_fast_forward) {
2778 fail "dgit push: HEAD is not a descendant".
2779 " of the archive's version.\n".
2780 "dgit: To overwrite its contents,".
2781 " use git merge -s ours ".lrref().".\n".
2782 "dgit: To rewind history, if permitted by the archive,".
2783 " use --deliberately-not-fast-forward";
2787 fail "package appears to be new in this suite;".
2788 " if this is intentional, use --new";
2793 #---------- remote commands' implementation ----------
2795 sub cmd_remote_push_build_host {
2796 my ($nrargs) = shift @ARGV;
2797 my (@rargs) = @ARGV[0..$nrargs-1];
2798 @ARGV = @ARGV[$nrargs..$#ARGV];
2800 my ($dir,$vsnwant) = @rargs;
2801 # vsnwant is a comma-separated list; we report which we have
2802 # chosen in our ready response (so other end can tell if they
2805 $we_are_responder = 1;
2806 $us .= " (build host)";
2810 open PI, "<&STDIN" or die $!;
2811 open STDIN, "/dev/null" or die $!;
2812 open PO, ">&STDOUT" or die $!;
2814 open STDOUT, ">&STDERR" or die $!;
2818 ($protovsn) = grep {
2819 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2820 } @rpushprotovsn_support;
2822 fail "build host has dgit rpush protocol versions ".
2823 (join ",", @rpushprotovsn_support).
2824 " but invocation host has $vsnwant"
2825 unless defined $protovsn;
2827 responder_send_command("dgit-remote-push-ready $protovsn");
2828 rpush_handle_protovsn_bothends();
2833 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2834 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2835 # a good error message)
2837 sub rpush_handle_protovsn_bothends () {
2838 if ($protovsn < 4) {
2839 need_tagformat 'old', "rpush negotiated protocol $protovsn";
2848 my $report = i_child_report();
2849 if (defined $report) {
2850 printdebug "($report)\n";
2851 } elsif ($i_child_pid) {
2852 printdebug "(killing build host child $i_child_pid)\n";
2853 kill 15, $i_child_pid;
2855 if (defined $i_tmp && !defined $initiator_tempdir) {
2857 eval { rmtree $i_tmp; };
2861 END { i_cleanup(); }
2864 my ($base,$selector,@args) = @_;
2865 $selector =~ s/\-/_/g;
2866 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2873 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2881 push @rargs, join ",", @rpushprotovsn_support;
2884 push @rdgit, @ropts;
2885 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2887 my @cmd = (@ssh, $host, shellquote @rdgit);
2890 if (defined $initiator_tempdir) {
2891 rmtree $initiator_tempdir;
2892 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2893 $i_tmp = $initiator_tempdir;
2897 $i_child_pid = open2(\*RO, \*RI, @cmd);
2899 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2900 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2901 $supplementary_message = '' unless $protovsn >= 3;
2903 fail "rpush negotiated protocol version $protovsn".
2904 " which does not support quilt mode $quilt_mode"
2905 if quiltmode_splitbrain;
2907 rpush_handle_protovsn_bothends();
2909 my ($icmd,$iargs) = initiator_expect {
2910 m/^(\S+)(?: (.*))?$/;
2913 i_method "i_resp", $icmd, $iargs;
2917 sub i_resp_progress ($) {
2919 my $msg = protocol_read_bytes \*RO, $rhs;
2923 sub i_resp_supplementary_message ($) {
2925 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2928 sub i_resp_complete {
2929 my $pid = $i_child_pid;
2930 $i_child_pid = undef; # prevents killing some other process with same pid
2931 printdebug "waiting for build host child $pid...\n";
2932 my $got = waitpid $pid, 0;
2933 die $! unless $got == $pid;
2934 die "build host child failed $?" if $?;
2937 printdebug "all done\n";
2941 sub i_resp_file ($) {
2943 my $localname = i_method "i_localname", $keyword;
2944 my $localpath = "$i_tmp/$localname";
2945 stat_exists $localpath and
2946 badproto \*RO, "file $keyword ($localpath) twice";
2947 protocol_receive_file \*RO, $localpath;
2948 i_method "i_file", $keyword;
2953 sub i_resp_param ($) {
2954 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2958 sub i_resp_previously ($) {
2959 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2960 or badproto \*RO, "bad previously spec";
2961 my $r = system qw(git check-ref-format), $1;
2962 die "bad previously ref spec ($r)" if $r;
2963 $previously{$1} = $2;
2968 sub i_resp_want ($) {
2970 die "$keyword ?" if $i_wanted{$keyword}++;
2971 my @localpaths = i_method "i_want", $keyword;
2972 printdebug "[[ $keyword @localpaths\n";
2973 foreach my $localpath (@localpaths) {
2974 protocol_send_file \*RI, $localpath;
2976 print RI "files-end\n" or die $!;
2979 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
2981 sub i_localname_parsed_changelog {
2982 return "remote-changelog.822";
2984 sub i_file_parsed_changelog {
2985 ($i_clogp, $i_version, $i_dscfn) =
2986 push_parse_changelog "$i_tmp/remote-changelog.822";
2987 die if $i_dscfn =~ m#/|^\W#;
2990 sub i_localname_dsc {
2991 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2996 sub i_localname_changes {
2997 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2998 $i_changesfn = $i_dscfn;
2999 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3000 return $i_changesfn;
3002 sub i_file_changes { }
3004 sub i_want_signed_tag {
3005 printdebug Dumper(\%i_param, $i_dscfn);
3006 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3007 && defined $i_param{'csuite'}
3008 or badproto \*RO, "premature desire for signed-tag";
3009 my $head = $i_param{'head'};
3010 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3012 my $maintview = $i_param{'maint-view'};
3013 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3016 if ($protovsn >= 4) {
3017 my $p = $i_param{'tagformat'} // '<undef>';
3019 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3022 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3024 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3026 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3029 push_mktags $i_clogp, $i_dscfn,
3030 $i_changesfn, 'remote changes',
3034 sub i_want_signed_dsc_changes {
3035 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3036 sign_changes $i_changesfn;
3037 return ($i_dscfn, $i_changesfn);
3040 #---------- building etc. ----------
3046 #----- `3.0 (quilt)' handling -----
3048 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3050 sub quiltify_dpkg_commit ($$$;$) {
3051 my ($patchname,$author,$msg, $xinfo) = @_;
3055 my $descfn = ".git/dgit/quilt-description.tmp";
3056 open O, '>', $descfn or die "$descfn: $!";
3059 $msg =~ s/^\s+$/ ./mg;
3060 print O <<END or die $!;
3070 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3071 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3072 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3073 runcmd @dpkgsource, qw(--commit .), $patchname;
3077 sub quiltify_trees_differ ($$;$$) {
3078 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3079 # returns true iff the two tree objects differ other than in debian/
3080 # with $finegrained,
3081 # returns bitmask 01 - differ in upstream files except .gitignore
3082 # 02 - differ in .gitignore
3083 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3084 # is set for each modified .gitignore filename $fn
3086 my @cmd = (@git, qw(diff-tree --name-only -z));
3087 push @cmd, qw(-r) if $finegrained;
3089 my $diffs= cmdoutput @cmd;
3091 foreach my $f (split /\0/, $diffs) {
3092 next if $f =~ m#^debian(?:/.*)?$#s;
3093 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3094 $r |= $isignore ? 02 : 01;
3095 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3097 printdebug "quiltify_trees_differ $x $y => $r\n";
3101 sub quiltify_tree_sentinelfiles ($) {
3102 # lists the `sentinel' files present in the tree
3104 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3105 qw(-- debian/rules debian/control);
3110 sub quiltify_splitbrain_needed () {
3111 if (!$split_brain) {
3112 progress "dgit view: changes are required...";
3113 runcmd @git, qw(checkout -q -b dgit-view);
3118 sub quiltify_splitbrain ($$$$$$) {
3119 my ($clogp, $unapplied, $headref, $diffbits,
3120 $editedignores, $cachekey) = @_;
3121 if ($quilt_mode !~ m/gbp|dpm/) {
3122 # treat .gitignore just like any other upstream file
3123 $diffbits = { %$diffbits };
3124 $_ = !!$_ foreach values %$diffbits;
3126 # We would like any commits we generate to be reproducible
3127 my @authline = clogp_authline($clogp);
3128 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3129 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3130 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3132 if ($quilt_mode =~ m/gbp|unapplied/ &&
3133 ($diffbits->{H2O} & 01)) {
3135 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3136 " but git tree differs from orig in upstream files.";
3137 if (!stat_exists "debian/patches") {
3139 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3143 if ($quilt_mode =~ m/gbp|unapplied/ &&
3144 ($diffbits->{O2A} & 01)) { # some patches
3145 quiltify_splitbrain_needed();
3146 progress "dgit view: creating patches-applied version using gbp pq";
3147 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3148 # gbp pq import creates a fresh branch; push back to dgit-view
3149 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3150 runcmd @git, qw(checkout -q dgit-view);
3152 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3153 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3154 quiltify_splitbrain_needed();
3155 progress "dgit view: creating patch to represent .gitignore changes";
3156 ensuredir "debian/patches";
3157 my $gipatch = "debian/patches/auto-gitignore";
3158 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3159 stat GIPATCH or die "$gipatch: $!";
3160 fail "$gipatch already exists; but want to create it".
3161 " to record .gitignore changes" if (stat _)[7];
3162 print GIPATCH <<END or die "$gipatch: $!";
3163 Subject: Update .gitignore from Debian packaging branch
3165 The Debian packaging git branch contains these updates to the upstream
3166 .gitignore file(s). This patch is autogenerated, to provide these
3167 updates to users of the official Debian archive view of the package.
3169 [dgit version $our_version]
3172 close GIPATCH or die "$gipatch: $!";
3173 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3174 $unapplied, $headref, "--", sort keys %$editedignores;
3175 open SERIES, "+>>", "debian/patches/series" or die $!;
3176 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3178 defined read SERIES, $newline, 1 or die $!;
3179 print SERIES "\n" or die $! unless $newline eq "\n";
3180 print SERIES "auto-gitignore\n" or die $!;
3181 close SERIES or die $!;
3182 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3183 commit_admin "Commit patch to update .gitignore";
3186 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3188 changedir '../../../..';
3189 ensuredir ".git/logs/refs/dgit-intern";
3190 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3192 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3195 progress "dgit view: created (commit id $dgitview)";
3197 changedir '.git/dgit/unpack/work';
3200 sub quiltify ($$$$) {
3201 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3203 # Quilt patchification algorithm
3205 # We search backwards through the history of the main tree's HEAD
3206 # (T) looking for a start commit S whose tree object is identical
3207 # to to the patch tip tree (ie the tree corresponding to the
3208 # current dpkg-committed patch series). For these purposes
3209 # `identical' disregards anything in debian/ - this wrinkle is
3210 # necessary because dpkg-source treates debian/ specially.
3212 # We can only traverse edges where at most one of the ancestors'
3213 # trees differs (in changes outside in debian/). And we cannot
3214 # handle edges which change .pc/ or debian/patches. To avoid
3215 # going down a rathole we avoid traversing edges which introduce
3216 # debian/rules or debian/control. And we set a limit on the
3217 # number of edges we are willing to look at.
3219 # If we succeed, we walk forwards again. For each traversed edge
3220 # PC (with P parent, C child) (starting with P=S and ending with
3221 # C=T) to we do this:
3223 # - dpkg-source --commit with a patch name and message derived from C
3224 # After traversing PT, we git commit the changes which
3225 # should be contained within debian/patches.
3227 # The search for the path S..T is breadth-first. We maintain a
3228 # todo list containing search nodes. A search node identifies a
3229 # commit, and looks something like this:
3231 # Commit => $git_commit_id,
3232 # Child => $c, # or undef if P=T
3233 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3234 # Nontrivial => true iff $p..$c has relevant changes
3241 my %considered; # saves being exponential on some weird graphs
3243 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3246 my ($search,$whynot) = @_;
3247 printdebug " search NOT $search->{Commit} $whynot\n";
3248 $search->{Whynot} = $whynot;
3249 push @nots, $search;
3250 no warnings qw(exiting);
3259 my $c = shift @todo;
3260 next if $considered{$c->{Commit}}++;
3262 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3264 printdebug "quiltify investigate $c->{Commit}\n";
3267 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3268 printdebug " search finished hooray!\n";
3273 if ($quilt_mode eq 'nofix') {
3274 fail "quilt fixup required but quilt mode is \`nofix'\n".
3275 "HEAD commit $c->{Commit} differs from tree implied by ".
3276 " debian/patches (tree object $oldtiptree)";
3278 if ($quilt_mode eq 'smash') {
3279 printdebug " search quitting smash\n";
3283 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3284 $not->($c, "has $c_sentinels not $t_sentinels")
3285 if $c_sentinels ne $t_sentinels;
3287 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3288 $commitdata =~ m/\n\n/;
3290 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3291 @parents = map { { Commit => $_, Child => $c } } @parents;
3293 $not->($c, "root commit") if !@parents;
3295 foreach my $p (@parents) {
3296 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3298 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3299 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3301 foreach my $p (@parents) {
3302 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3304 my @cmd= (@git, qw(diff-tree -r --name-only),
3305 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3306 my $patchstackchange = cmdoutput @cmd;
3307 if (length $patchstackchange) {
3308 $patchstackchange =~ s/\n/,/g;
3309 $not->($p, "changed $patchstackchange");
3312 printdebug " search queue P=$p->{Commit} ",
3313 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3319 printdebug "quiltify want to smash\n";
3322 my $x = $_[0]{Commit};
3323 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3326 my $reportnot = sub {
3328 my $s = $abbrev->($notp);
3329 my $c = $notp->{Child};
3330 $s .= "..".$abbrev->($c) if $c;
3331 $s .= ": ".$notp->{Whynot};
3334 if ($quilt_mode eq 'linear') {
3335 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3336 foreach my $notp (@nots) {
3337 print STDERR "$us: ", $reportnot->($notp), "\n";
3339 print STDERR "$us: $_\n" foreach @$failsuggestion;
3340 fail "quilt fixup naive history linearisation failed.\n".
3341 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3342 } elsif ($quilt_mode eq 'smash') {
3343 } elsif ($quilt_mode eq 'auto') {
3344 progress "quilt fixup cannot be linear, smashing...";
3346 die "$quilt_mode ?";
3349 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3350 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3352 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3354 quiltify_dpkg_commit "auto-$version-$target-$time",
3355 (getfield $clogp, 'Maintainer'),
3356 "Automatically generated patch ($clogp->{Version})\n".
3357 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3361 progress "quiltify linearisation planning successful, executing...";
3363 for (my $p = $sref_S;
3364 my $c = $p->{Child};
3366 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3367 next unless $p->{Nontrivial};
3369 my $cc = $c->{Commit};
3371 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3372 $commitdata =~ m/\n\n/ or die "$c ?";
3375 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3378 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3381 my $patchname = $title;
3382 $patchname =~ s/[.:]$//;
3383 $patchname =~ y/ A-Z/-a-z/;
3384 $patchname =~ y/-a-z0-9_.+=~//cd;
3385 $patchname =~ s/^\W/x-$&/;
3386 $patchname = substr($patchname,0,40);
3389 stat "debian/patches/$patchname$index";
3391 $!==ENOENT or die "$patchname$index $!";
3393 runcmd @git, qw(checkout -q), $cc;
3395 # We use the tip's changelog so that dpkg-source doesn't
3396 # produce complaining messages from dpkg-parsechangelog. None
3397 # of the information dpkg-source gets from the changelog is
3398 # actually relevant - it gets put into the original message
3399 # which dpkg-source provides our stunt editor, and then
3401 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3403 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3404 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3406 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3409 runcmd @git, qw(checkout -q master);
3412 sub build_maybe_quilt_fixup () {
3413 my ($format,$fopts) = get_source_format;
3414 return unless madformat $format;
3417 check_for_vendor_patches();
3419 my $clogp = parsechangelog();
3420 my $headref = git_rev_parse('HEAD');
3425 my $upstreamversion=$version;
3426 $upstreamversion =~ s/-[^-]*$//;
3428 if ($fopts->{'single-debian-patch'}) {
3429 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3431 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3434 die 'bug' if $split_brain && !$need_split_build_invocation;
3436 changedir '../../../..';
3437 runcmd_ordryrun_local
3438 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3441 sub quilt_fixup_mkwork ($) {
3444 mkdir "work" or die $!;
3446 mktree_in_ud_here();
3447 runcmd @git, qw(reset -q --hard), $headref;
3450 sub quilt_fixup_linkorigs ($$) {
3451 my ($upstreamversion, $fn) = @_;
3452 # calls $fn->($leafname);
3454 foreach my $f (<../../../../*>) { #/){
3455 my $b=$f; $b =~ s{.*/}{};
3457 local ($debuglevel) = $debuglevel-1;
3458 printdebug "QF linkorigs $b, $f ?\n";
3460 next unless is_orig_file $b, srcfn $upstreamversion,'';
3461 printdebug "QF linkorigs $b, $f Y\n";
3462 link_ltarget $f, $b or die "$b $!";
3467 sub quilt_fixup_delete_pc () {
3468 runcmd @git, qw(rm -rqf .pc);
3469 commit_admin "Commit removal of .pc (quilt series tracking data)";
3472 sub quilt_fixup_singlepatch ($$$) {
3473 my ($clogp, $headref, $upstreamversion) = @_;
3475 progress "starting quiltify (single-debian-patch)";
3477 # dpkg-source --commit generates new patches even if
3478 # single-debian-patch is in debian/source/options. In order to
3479 # get it to generate debian/patches/debian-changes, it is
3480 # necessary to build the source package.
3482 quilt_fixup_linkorigs($upstreamversion, sub { });
3483 quilt_fixup_mkwork($headref);
3485 rmtree("debian/patches");
3487 runcmd @dpkgsource, qw(-b .);
3489 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3490 rename srcfn("$upstreamversion", "/debian/patches"),
3491 "work/debian/patches";
3494 commit_quilty_patch();
3497 sub quilt_make_fake_dsc ($) {
3498 my ($upstreamversion) = @_;
3500 my $fakeversion="$upstreamversion-~~DGITFAKE";
3502 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3503 print $fakedsc <<END or die $!;
3506 Version: $fakeversion
3510 my $dscaddfile=sub {
3513 my $md = new Digest::MD5;
3515 my $fh = new IO::File $b, '<' or die "$b $!";
3520 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3523 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3525 my @files=qw(debian/source/format debian/rules
3526 debian/control debian/changelog);
3527 foreach my $maybe (qw(debian/patches debian/source/options
3528 debian/tests/control)) {
3529 next unless stat_exists "../../../$maybe";
3530 push @files, $maybe;
3533 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3534 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3536 $dscaddfile->($debtar);
3537 close $fakedsc or die $!;
3540 sub quilt_check_splitbrain_cache ($$) {
3541 my ($headref, $upstreamversion) = @_;
3542 # Called only if we are in (potentially) split brain mode.
3544 # Computes the cache key and looks in the cache.
3545 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3547 my $splitbrain_cachekey;
3550 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3551 # we look in the reflog of dgit-intern/quilt-cache
3552 # we look for an entry whose message is the key for the cache lookup
3553 my @cachekey = (qw(dgit), $our_version);
3554 push @cachekey, $upstreamversion;
3555 push @cachekey, $quilt_mode;
3556 push @cachekey, $headref;
3558 push @cachekey, hashfile('fake.dsc');
3560 my $srcshash = Digest::SHA->new(256);
3561 my %sfs = ( %INC, '$0(dgit)' => $0 );
3562 foreach my $sfk (sort keys %sfs) {
3563 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3564 $srcshash->add($sfk," ");
3565 $srcshash->add(hashfile($sfs{$sfk}));
3566 $srcshash->add("\n");
3568 push @cachekey, $srcshash->hexdigest();
3569 $splitbrain_cachekey = "@cachekey";
3571 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3573 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3574 debugcmd "|(probably)",@cmd;
3575 my $child = open GC, "-|"; defined $child or die $!;
3577 chdir '../../..' or die $!;
3578 if (!stat ".git/logs/refs/$splitbraincache") {
3579 $! == ENOENT or die $!;
3580 printdebug ">(no reflog)\n";
3587 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3588 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3591 quilt_fixup_mkwork($headref);
3592 if ($cachehit ne $headref) {
3593 progress "dgit view: found cached (commit id $cachehit)";
3594 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3596 return ($cachehit, $splitbrain_cachekey);
3598 progress "dgit view: found cached, no changes required";
3599 return ($headref, $splitbrain_cachekey);
3601 die $! if GC->error;
3602 failedcmd unless close GC;
3604 printdebug "splitbrain cache miss\n";
3605 return (undef, $splitbrain_cachekey);
3608 sub quilt_fixup_multipatch ($$$) {
3609 my ($clogp, $headref, $upstreamversion) = @_;
3611 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3614 # - honour any existing .pc in case it has any strangeness
3615 # - determine the git commit corresponding to the tip of
3616 # the patch stack (if there is one)
3617 # - if there is such a git commit, convert each subsequent
3618 # git commit into a quilt patch with dpkg-source --commit
3619 # - otherwise convert all the differences in the tree into
3620 # a single git commit
3624 # Our git tree doesn't necessarily contain .pc. (Some versions of
3625 # dgit would include the .pc in the git tree.) If there isn't
3626 # one, we need to generate one by unpacking the patches that we
3629 # We first look for a .pc in the git tree. If there is one, we
3630 # will use it. (This is not the normal case.)
3632 # Otherwise need to regenerate .pc so that dpkg-source --commit
3633 # can work. We do this as follows:
3634 # 1. Collect all relevant .orig from parent directory
3635 # 2. Generate a debian.tar.gz out of
3636 # debian/{patches,rules,source/format,source/options}
3637 # 3. Generate a fake .dsc containing just these fields:
3638 # Format Source Version Files
3639 # 4. Extract the fake .dsc
3640 # Now the fake .dsc has a .pc directory.
3641 # (In fact we do this in every case, because in future we will
3642 # want to search for a good base commit for generating patches.)
3644 # Then we can actually do the dpkg-source --commit
3645 # 1. Make a new working tree with the same object
3646 # store as our main tree and check out the main
3648 # 2. Copy .pc from the fake's extraction, if necessary
3649 # 3. Run dpkg-source --commit
3650 # 4. If the result has changes to debian/, then
3651 # - git-add them them
3652 # - git-add .pc if we had a .pc in-tree
3654 # 5. If we had a .pc in-tree, delete it, and git-commit
3655 # 6. Back in the main tree, fast forward to the new HEAD
3657 # Another situation we may have to cope with is gbp-style
3658 # patches-unapplied trees.
3660 # We would want to detect these, so we know to escape into
3661 # quilt_fixup_gbp. However, this is in general not possible.
3662 # Consider a package with a one patch which the dgit user reverts
3663 # (with git-revert or the moral equivalent).
3665 # That is indistinguishable in contents from a patches-unapplied
3666 # tree. And looking at the history to distinguish them is not
3667 # useful because the user might have made a confusing-looking git
3668 # history structure (which ought to produce an error if dgit can't
3669 # cope, not a silent reintroduction of an unwanted patch).
3671 # So gbp users will have to pass an option. But we can usually
3672 # detect their failure to do so: if the tree is not a clean
3673 # patches-applied tree, quilt linearisation fails, but the tree
3674 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3675 # they want --quilt=unapplied.
3677 # To help detect this, when we are extracting the fake dsc, we
3678 # first extract it with --skip-patches, and then apply the patches
3679 # afterwards with dpkg-source --before-build. That lets us save a
3680 # tree object corresponding to .origs.
3682 my $splitbrain_cachekey;
3684 quilt_make_fake_dsc($upstreamversion);
3686 if (quiltmode_splitbrain()) {
3688 ($cachehit, $splitbrain_cachekey) =
3689 quilt_check_splitbrain_cache($headref, $upstreamversion);
3690 return if $cachehit;
3694 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3696 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3697 rename $fakexdir, "fake" or die "$fakexdir $!";
3701 remove_stray_gits();
3702 mktree_in_ud_here();
3706 runcmd @git, qw(add -Af .);
3707 my $unapplied=git_write_tree();
3708 printdebug "fake orig tree object $unapplied\n";
3713 'exec dpkg-source --before-build . >/dev/null';
3717 quilt_fixup_mkwork($headref);
3720 if (stat_exists ".pc") {
3722 progress "Tree already contains .pc - will use it then delete it.";
3725 rename '../fake/.pc','.pc' or die $!;
3728 changedir '../fake';
3730 runcmd @git, qw(add -Af .);
3731 my $oldtiptree=git_write_tree();
3732 printdebug "fake o+d/p tree object $unapplied\n";
3733 changedir '../work';
3736 # We calculate some guesswork now about what kind of tree this might
3737 # be. This is mostly for error reporting.
3742 # O = orig, without patches applied
3743 # A = "applied", ie orig with H's debian/patches applied
3744 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3745 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3746 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3750 foreach my $b (qw(01 02)) {
3751 foreach my $v (qw(H2O O2A H2A)) {
3752 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3755 printdebug "differences \@dl @dl.\n";
3758 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3759 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3760 $dl[0], $dl[1], $dl[3], $dl[4],
3764 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3765 push @failsuggestion, "This might be a patches-unapplied branch.";
3766 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3767 push @failsuggestion, "This might be a patches-applied branch.";
3769 push @failsuggestion, "Maybe you need to specify one of".
3770 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3772 if (quiltmode_splitbrain()) {
3773 quiltify_splitbrain($clogp, $unapplied, $headref,
3774 $diffbits, \%editedignores,
3775 $splitbrain_cachekey);
3779 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3780 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3782 if (!open P, '>>', ".pc/applied-patches") {
3783 $!==&ENOENT or die $!;
3788 commit_quilty_patch();
3790 if ($mustdeletepc) {
3791 quilt_fixup_delete_pc();
3795 sub quilt_fixup_editor () {
3796 my $descfn = $ENV{$fakeeditorenv};
3797 my $editing = $ARGV[$#ARGV];
3798 open I1, '<', $descfn or die "$descfn: $!";
3799 open I2, '<', $editing or die "$editing: $!";
3800 unlink $editing or die "$editing: $!";
3801 open O, '>', $editing or die "$editing: $!";
3802 while (<I1>) { print O or die $!; } I1->error and die $!;
3805 $copying ||= m/^\-\-\- /;
3806 next unless $copying;
3809 I2->error and die $!;
3814 sub maybe_apply_patches_dirtily () {
3815 return unless $quilt_mode =~ m/gbp|unapplied/;
3816 print STDERR <<END or die $!;
3818 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3819 dgit: Have to apply the patches - making the tree dirty.
3820 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3823 $patches_applied_dirtily = 01;
3824 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3825 runcmd qw(dpkg-source --before-build .);
3828 sub maybe_unapply_patches_again () {
3829 progress "dgit: Unapplying patches again to tidy up the tree."
3830 if $patches_applied_dirtily;
3831 runcmd qw(dpkg-source --after-build .)
3832 if $patches_applied_dirtily & 01;
3834 if $patches_applied_dirtily & 02;
3837 #----- other building -----
3839 our $clean_using_builder;
3840 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3841 # clean the tree before building (perhaps invoked indirectly by
3842 # whatever we are using to run the build), rather than separately
3843 # and explicitly by us.
3846 return if $clean_using_builder;
3847 if ($cleanmode eq 'dpkg-source') {
3848 maybe_apply_patches_dirtily();
3849 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3850 } elsif ($cleanmode eq 'dpkg-source-d') {
3851 maybe_apply_patches_dirtily();
3852 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3853 } elsif ($cleanmode eq 'git') {
3854 runcmd_ordryrun_local @git, qw(clean -xdf);
3855 } elsif ($cleanmode eq 'git-ff') {
3856 runcmd_ordryrun_local @git, qw(clean -xdff);
3857 } elsif ($cleanmode eq 'check') {
3858 my $leftovers = cmdoutput @git, qw(clean -xdn);
3859 if (length $leftovers) {
3860 print STDERR $leftovers, "\n" or die $!;
3861 fail "tree contains uncommitted files and --clean=check specified";
3863 } elsif ($cleanmode eq 'none') {
3870 badusage "clean takes no additional arguments" if @ARGV;
3873 maybe_unapply_patches_again();
3878 badusage "-p is not allowed when building" if defined $package;
3881 my $clogp = parsechangelog();
3882 $isuite = getfield $clogp, 'Distribution';
3883 $package = getfield $clogp, 'Source';
3884 $version = getfield $clogp, 'Version';
3885 build_maybe_quilt_fixup();
3887 my $pat = changespat $version;
3888 foreach my $f (glob "$buildproductsdir/$pat") {
3890 unlink $f or fail "remove old changes file $f: $!";
3892 progress "would remove $f";
3898 sub changesopts_initial () {
3899 my @opts =@changesopts[1..$#changesopts];
3902 sub changesopts_version () {
3903 if (!defined $changes_since_version) {
3904 my @vsns = archive_query('archive_query');
3905 my @quirk = access_quirk();
3906 if ($quirk[0] eq 'backports') {
3907 local $isuite = $quirk[2];
3909 canonicalise_suite();
3910 push @vsns, archive_query('archive_query');
3913 @vsns = map { $_->[0] } @vsns;
3914 @vsns = sort { -version_compare($a, $b) } @vsns;
3915 $changes_since_version = $vsns[0];
3916 progress "changelog will contain changes since $vsns[0]";
3918 $changes_since_version = '_';
3919 progress "package seems new, not specifying -v<version>";
3922 if ($changes_since_version ne '_') {
3923 return ("-v$changes_since_version");
3929 sub changesopts () {
3930 return (changesopts_initial(), changesopts_version());
3933 sub massage_dbp_args ($;$) {
3934 my ($cmd,$xargs) = @_;
3937 # - if we're going to split the source build out so we can
3938 # do strange things to it, massage the arguments to dpkg-buildpackage
3939 # so that the main build doessn't build source (or add an argument
3940 # to stop it building source by default).
3942 # - add -nc to stop dpkg-source cleaning the source tree,
3943 # unless we're not doing a split build and want dpkg-source
3944 # as cleanmode, in which case we can do nothing
3947 # 0 - source will NOT need to be built separately by caller
3948 # +1 - source will need to be built separately by caller
3949 # +2 - source will need to be built separately by caller AND
3950 # dpkg-buildpackage should not in fact be run at all!
3951 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3952 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3953 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3954 $clean_using_builder = 1;
3957 # -nc has the side effect of specifying -b if nothing else specified
3958 # and some combinations of -S, -b, et al, are errors, rather than
3959 # later simply overriding earlie. So we need to:
3960 # - search the command line for these options
3961 # - pick the last one
3962 # - perhaps add our own as a default
3963 # - perhaps adjust it to the corresponding non-source-building version
3965 foreach my $l ($cmd, $xargs) {
3967 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3970 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3972 if ($need_split_build_invocation) {
3973 printdebug "massage split $dmode.\n";
3974 $r = $dmode =~ m/[S]/ ? +2 :
3975 $dmode =~ y/gGF/ABb/ ? +1 :
3976 $dmode =~ m/[ABb]/ ? 0 :
3979 printdebug "massage done $r $dmode.\n";
3981 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3986 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3987 my $wantsrc = massage_dbp_args \@dbp;
3994 push @dbp, changesopts_version();
3995 maybe_apply_patches_dirtily();
3996 runcmd_ordryrun_local @dbp;
3998 maybe_unapply_patches_again();
3999 printdone "build successful\n";
4003 my @dbp = @dpkgbuildpackage;
4005 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4008 if (length executable_on_path('git-buildpackage')) {
4009 @cmd = qw(git-buildpackage);
4011 @cmd = qw(gbp buildpackage);
4013 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4018 if (!$clean_using_builder) {
4019 push @cmd, '--git-cleaner=true';
4024 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4025 canonicalise_suite();
4026 push @cmd, "--git-debian-branch=".lbranch();
4028 push @cmd, changesopts();
4029 maybe_apply_patches_dirtily();
4030 runcmd_ordryrun_local @cmd, @ARGV;
4032 maybe_unapply_patches_again();
4033 printdone "build successful\n";
4035 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4038 my $our_cleanmode = $cleanmode;
4039 if ($need_split_build_invocation) {
4040 # Pretend that clean is being done some other way. This
4041 # forces us not to try to use dpkg-buildpackage to clean and
4042 # build source all in one go; and instead we run dpkg-source
4043 # (and build_prep() will do the clean since $clean_using_builder
4045 $our_cleanmode = 'ELSEWHERE';
4047 if ($our_cleanmode =~ m/^dpkg-source/) {
4048 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4049 $clean_using_builder = 1;
4052 $sourcechanges = changespat $version,'source';
4054 unlink "../$sourcechanges" or $!==ENOENT
4055 or fail "remove $sourcechanges: $!";
4057 $dscfn = dscfn($version);
4058 if ($our_cleanmode eq 'dpkg-source') {
4059 maybe_apply_patches_dirtily();
4060 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4062 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4063 maybe_apply_patches_dirtily();
4064 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4067 my @cmd = (@dpkgsource, qw(-b --));
4070 runcmd_ordryrun_local @cmd, "work";
4071 my @udfiles = <${package}_*>;
4072 changedir "../../..";
4073 foreach my $f (@udfiles) {
4074 printdebug "source copy, found $f\n";
4077 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4078 $f eq srcfn($version, $&));
4079 printdebug "source copy, found $f - renaming\n";
4080 rename "$ud/$f", "../$f" or $!==ENOENT
4081 or fail "put in place new source file ($f): $!";
4084 my $pwd = must_getcwd();
4085 my $leafdir = basename $pwd;
4087 runcmd_ordryrun_local @cmd, $leafdir;
4090 runcmd_ordryrun_local qw(sh -ec),
4091 'exec >$1; shift; exec "$@"','x',
4092 "../$sourcechanges",
4093 @dpkggenchanges, qw(-S), changesopts();
4097 sub cmd_build_source {
4098 badusage "build-source takes no additional arguments" if @ARGV;
4100 maybe_unapply_patches_again();
4101 printdone "source built, results in $dscfn and $sourcechanges";
4106 my $pat = changespat $version;
4108 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4109 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4110 fail "changes files other than source matching $pat".
4111 " already present (@unwanted);".
4112 " building would result in ambiguity about the intended results"
4117 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4118 stat_exists $sourcechanges
4119 or fail "$sourcechanges (in parent directory): $!";
4121 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4122 my @changesfiles = glob $pat;
4123 @changesfiles = sort {
4124 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4127 fail "wrong number of different changes files (@changesfiles)"
4128 unless @changesfiles==2;
4129 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4130 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4131 fail "$l found in binaries changes file $binchanges"
4134 runcmd_ordryrun_local @mergechanges, @changesfiles;
4135 my $multichanges = changespat $version,'multi';
4137 stat_exists $multichanges or fail "$multichanges: $!";
4138 foreach my $cf (glob $pat) {
4139 next if $cf eq $multichanges;
4140 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4143 maybe_unapply_patches_again();
4144 printdone "build successful, results in $multichanges\n" or die $!;
4147 sub cmd_quilt_fixup {
4148 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4149 my $clogp = parsechangelog();
4150 $version = getfield $clogp, 'Version';
4151 $package = getfield $clogp, 'Source';
4154 build_maybe_quilt_fixup();
4157 sub cmd_archive_api_query {
4158 badusage "need only 1 subpath argument" unless @ARGV==1;
4159 my ($subpath) = @ARGV;
4160 my @cmd = archive_api_query_cmd($subpath);
4162 exec @cmd or fail "exec curl: $!\n";
4165 sub cmd_clone_dgit_repos_server {
4166 badusage "need destination argument" unless @ARGV==1;
4167 my ($destdir) = @ARGV;
4168 $package = '_dgit-repos-server';
4169 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4171 exec @cmd or fail "exec git clone: $!\n";
4174 sub cmd_setup_mergechangelogs {
4175 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4176 setup_mergechangelogs(1);
4179 sub cmd_setup_useremail {
4180 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4184 sub cmd_setup_new_tree {
4185 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4189 #---------- argument parsing and main program ----------
4192 print "dgit version $our_version\n" or die $!;
4196 our (%valopts_long, %valopts_short);
4199 sub defvalopt ($$$$) {
4200 my ($long,$short,$val_re,$how) = @_;
4201 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4202 $valopts_long{$long} = $oi;
4203 $valopts_short{$short} = $oi;
4204 # $how subref should:
4205 # do whatever assignemnt or thing it likes with $_[0]
4206 # if the option should not be passed on to remote, @rvalopts=()
4207 # or $how can be a scalar ref, meaning simply assign the value
4210 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4211 defvalopt '--distro', '-d', '.+', \$idistro;
4212 defvalopt '', '-k', '.+', \$keyid;
4213 defvalopt '--existing-package','', '.*', \$existing_package;
4214 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4215 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4216 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4218 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4220 defvalopt '', '-C', '.+', sub {
4221 ($changesfile) = (@_);
4222 if ($changesfile =~ s#^(.*)/##) {
4223 $buildproductsdir = $1;
4227 defvalopt '--initiator-tempdir','','.*', sub {
4228 ($initiator_tempdir) = (@_);
4229 $initiator_tempdir =~ m#^/# or
4230 badusage "--initiator-tempdir must be used specify an".
4231 " absolute, not relative, directory."
4237 if (defined $ENV{'DGIT_SSH'}) {
4238 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4239 } elsif (defined $ENV{'GIT_SSH'}) {
4240 @ssh = ($ENV{'GIT_SSH'});
4248 if (!defined $val) {
4249 badusage "$what needs a value" unless @ARGV;
4251 push @rvalopts, $val;
4253 badusage "bad value \`$val' for $what" unless
4254 $val =~ m/^$oi->{Re}$(?!\n)/s;
4255 my $how = $oi->{How};
4256 if (ref($how) eq 'SCALAR') {
4261 push @ropts, @rvalopts;
4265 last unless $ARGV[0] =~ m/^-/;
4269 if (m/^--dry-run$/) {
4272 } elsif (m/^--damp-run$/) {
4275 } elsif (m/^--no-sign$/) {
4278 } elsif (m/^--help$/) {
4280 } elsif (m/^--version$/) {
4282 } elsif (m/^--new$/) {
4285 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4286 ($om = $opts_opt_map{$1}) &&
4290 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4291 !$opts_opt_cmdonly{$1} &&
4292 ($om = $opts_opt_map{$1})) {
4295 } elsif (m/^--ignore-dirty$/s) {
4298 } elsif (m/^--no-quilt-fixup$/s) {
4300 $quilt_mode = 'nocheck';
4301 } elsif (m/^--no-rm-on-error$/s) {
4304 } elsif (m/^--(no-)?rm-old-changes$/s) {
4307 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4309 push @deliberatelies, $&;
4310 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4311 # undocumented, for testing
4313 $tagformat_want = [ $1, 'command line', 1 ];
4314 # 1 menas overrides distro configuration
4315 } elsif (m/^--always-split-source-build$/s) {
4316 # undocumented, for testing
4318 $need_split_build_invocation = 1;
4319 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4320 $val = $2 ? $' : undef; #';
4321 $valopt->($oi->{Long});
4323 badusage "unknown long option \`$_'";
4330 } elsif (s/^-L/-/) {
4333 } elsif (s/^-h/-/) {
4335 } elsif (s/^-D/-/) {
4339 } elsif (s/^-N/-/) {
4344 push @changesopts, $_;
4346 } elsif (s/^-wn$//s) {
4348 $cleanmode = 'none';
4349 } elsif (s/^-wg$//s) {
4352 } elsif (s/^-wgf$//s) {
4354 $cleanmode = 'git-ff';
4355 } elsif (s/^-wd$//s) {
4357 $cleanmode = 'dpkg-source';
4358 } elsif (s/^-wdd$//s) {
4360 $cleanmode = 'dpkg-source-d';
4361 } elsif (s/^-wc$//s) {
4363 $cleanmode = 'check';
4364 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4366 $val = undef unless length $val;
4367 $valopt->($oi->{Short});
4370 badusage "unknown short option \`$_'";
4377 sub finalise_opts_opts () {
4378 foreach my $k (keys %opts_opt_map) {
4379 my $om = $opts_opt_map{$k};
4381 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4383 badcfg "cannot set command for $k"
4384 unless length $om->[0];
4388 foreach my $c (access_cfg_cfgs("opts-$k")) {
4389 my $vl = $gitcfg{$c};
4390 printdebug "CL $c ",
4391 ($vl ? join " ", map { shellquote } @$vl : ""),
4392 "\n" if $debuglevel >= 4;
4394 badcfg "cannot configure options for $k"
4395 if $opts_opt_cmdonly{$k};
4396 my $insertpos = $opts_cfg_insertpos{$k};
4397 @$om = ( @$om[0..$insertpos-1],
4399 @$om[$insertpos..$#$om] );
4404 if ($ENV{$fakeeditorenv}) {
4406 quilt_fixup_editor();
4412 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4413 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4414 if $dryrun_level == 1;
4416 print STDERR $helpmsg or die $!;
4419 my $cmd = shift @ARGV;
4422 if (!defined $rmchanges) {
4423 local $access_forpush;
4424 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4427 if (!defined $quilt_mode) {
4428 local $access_forpush;
4429 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4430 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4432 $quilt_mode =~ m/^($quilt_modes_re)$/
4433 or badcfg "unknown quilt-mode \`$quilt_mode'";
4437 $need_split_build_invocation ||= quiltmode_splitbrain();
4439 if (!defined $cleanmode) {
4440 local $access_forpush;
4441 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4442 $cleanmode //= 'dpkg-source';
4444 badcfg "unknown clean-mode \`$cleanmode'" unless
4445 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4448 my $fn = ${*::}{"cmd_$cmd"};
4449 $fn or badusage "unknown operation $cmd";