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);
40 our $our_version = 'UNRELEASED'; ###substituted###
42 our @rpushprotovsn_support = qw(3 2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
60 our $cleanmode = 'dpkg-source';
61 our $changes_since_version;
63 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
64 our $we_are_responder;
65 our $initiator_tempdir;
67 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
69 our $suite_re = '[-+.0-9a-z]+';
72 our (@dget) = qw(dget);
73 our (@curl) = qw(curl -f);
74 our (@dput) = qw(dput);
75 our (@debsign) = qw(debsign);
77 our (@sbuild) = qw(sbuild -A);
79 our (@dgit) = qw(dgit);
80 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
81 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
82 our (@dpkggenchanges) = qw(dpkg-genchanges);
83 our (@mergechanges) = qw(mergechanges -f);
84 our (@changesopts) = ('');
86 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
89 'debsign' => \@debsign,
94 'dpkg-source' => \@dpkgsource,
95 'dpkg-buildpackage' => \@dpkgbuildpackage,
96 'dpkg-genchanges' => \@dpkggenchanges,
97 'ch' => \@changesopts,
98 'mergechanges' => \@mergechanges);
100 our %opts_opt_cmdonly = ('gpg' => 1);
101 our %opts_cfg_insertpos = map {
103 scalar @{ $opts_opt_map{$_} }
104 } keys %opts_opt_map;
106 sub finalise_opts_opts();
112 our $supplementary_message = '';
116 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
119 our $remotename = 'dgit';
120 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
124 sub lbranch () { return "$branchprefix/$csuite"; }
125 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
126 sub lref () { return "refs/heads/".lbranch(); }
127 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
128 sub rrref () { return server_ref($csuite); }
130 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
140 return "${package}_".(stripepoch $vsn).$sfx
145 return srcfn($vsn,".dsc");
154 foreach my $f (@end) {
156 warn "$us: cleanup: $@" if length $@;
160 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
162 sub no_such_package () {
163 print STDERR "$us: package $package does not exist in suite $isuite\n";
169 return "+".rrref().":".lrref();
174 printdebug "CD $newdir\n";
175 chdir $newdir or die "chdir: $newdir: $!";
178 sub deliberately ($) {
180 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
183 sub deliberately_not_fast_forward () {
184 foreach (qw(not-fast-forward fresh-repo)) {
185 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
189 #---------- remote protocol support, common ----------
191 # remote push initiator/responder protocol:
192 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
193 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
194 # < dgit-remote-push-ready <actual-proto-vsn>
196 # > file parsed-changelog
197 # [indicates that output of dpkg-parsechangelog follows]
198 # > data-block NBYTES
199 # > [NBYTES bytes of data (no newline)]
200 # [maybe some more blocks]
212 # [indicates that signed tag is wanted]
213 # < data-block NBYTES
214 # < [NBYTES bytes of data (no newline)]
215 # [maybe some more blocks]
219 # > want signed-dsc-changes
220 # < data-block NBYTES [transfer of signed dsc]
222 # < data-block NBYTES [transfer of signed changes]
230 sub i_child_report () {
231 # Sees if our child has died, and reap it if so. Returns a string
232 # describing how it died if it failed, or undef otherwise.
233 return undef unless $i_child_pid;
234 my $got = waitpid $i_child_pid, WNOHANG;
235 return undef if $got <= 0;
236 die unless $got == $i_child_pid;
237 $i_child_pid = undef;
238 return undef unless $?;
239 return "build host child ".waitstatusmsg();
244 fail "connection lost: $!" if $fh->error;
245 fail "protocol violation; $m not expected";
248 sub badproto_badread ($$) {
250 fail "connection lost: $!" if $!;
251 my $report = i_child_report();
252 fail $report if defined $report;
253 badproto $fh, "eof (reading $wh)";
256 sub protocol_expect (&$) {
257 my ($match, $fh) = @_;
260 defined && chomp or badproto_badread $fh, "protocol message";
268 badproto $fh, "\`$_'";
271 sub protocol_send_file ($$) {
272 my ($fh, $ourfn) = @_;
273 open PF, "<", $ourfn or die "$ourfn: $!";
276 my $got = read PF, $d, 65536;
277 die "$ourfn: $!" unless defined $got;
279 print $fh "data-block ".length($d)."\n" or die $!;
280 print $fh $d or die $!;
282 PF->error and die "$ourfn $!";
283 print $fh "data-end\n" or die $!;
287 sub protocol_read_bytes ($$) {
288 my ($fh, $nbytes) = @_;
289 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
291 my $got = read $fh, $d, $nbytes;
292 $got==$nbytes or badproto_badread $fh, "data block";
296 sub protocol_receive_file ($$) {
297 my ($fh, $ourfn) = @_;
298 printdebug "() $ourfn\n";
299 open PF, ">", $ourfn or die "$ourfn: $!";
301 my ($y,$l) = protocol_expect {
302 m/^data-block (.*)$/ ? (1,$1) :
303 m/^data-end$/ ? (0,) :
307 my $d = protocol_read_bytes $fh, $l;
308 print PF $d or die $!;
313 #---------- remote protocol support, responder ----------
315 sub responder_send_command ($) {
317 return unless $we_are_responder;
318 # called even without $we_are_responder
319 printdebug ">> $command\n";
320 print PO $command, "\n" or die $!;
323 sub responder_send_file ($$) {
324 my ($keyword, $ourfn) = @_;
325 return unless $we_are_responder;
326 printdebug "]] $keyword $ourfn\n";
327 responder_send_command "file $keyword";
328 protocol_send_file \*PO, $ourfn;
331 sub responder_receive_files ($@) {
332 my ($keyword, @ourfns) = @_;
333 die unless $we_are_responder;
334 printdebug "[[ $keyword @ourfns\n";
335 responder_send_command "want $keyword";
336 foreach my $fn (@ourfns) {
337 protocol_receive_file \*PI, $fn;
340 protocol_expect { m/^files-end$/ } \*PI;
343 #---------- remote protocol support, initiator ----------
345 sub initiator_expect (&) {
347 protocol_expect { &$match } \*RO;
350 #---------- end remote code ----------
353 if ($we_are_responder) {
355 responder_send_command "progress ".length($m) or die $!;
356 print PO $m or die $!;
366 $ua = LWP::UserAgent->new();
370 progress "downloading $what...";
371 my $r = $ua->get(@_) or die $!;
372 return undef if $r->code == 404;
373 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
374 return $r->decoded_content(charset => 'none');
377 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
382 failedcmd @_ if system @_;
385 sub act_local () { return $dryrun_level <= 1; }
386 sub act_scary () { return !$dryrun_level; }
389 if (!$dryrun_level) {
390 progress "dgit ok: @_";
392 progress "would be ok: @_ (but dry run only)";
397 printcmd(\*STDERR,$debugprefix."#",@_);
400 sub runcmd_ordryrun {
408 sub runcmd_ordryrun_local {
417 my ($first_shell, @cmd) = @_;
418 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
421 our $helpmsg = <<END;
423 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
424 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
425 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
426 dgit [dgit-opts] push [dgit-opts] [suite]
427 dgit [dgit-opts] rpush build-host:build-dir ...
428 important dgit options:
429 -k<keyid> sign tag and package with <keyid> instead of default
430 --dry-run -n do not change anything, but go through the motions
431 --damp-run -L like --dry-run but make local changes, without signing
432 --new -N allow introducing a new package
433 --debug -D increase debug level
434 -c<name>=<value> set git config option (used directly by dgit too)
437 our $later_warning_msg = <<END;
438 Perhaps the upload is stuck in incoming. Using the version from git.
442 print STDERR "$us: @_\n", $helpmsg or die $!;
447 @ARGV or badusage "too few arguments";
448 return scalar shift @ARGV;
452 print $helpmsg or die $!;
456 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
458 our %defcfg = ('dgit.default.distro' => 'debian',
459 'dgit.default.username' => '',
460 'dgit.default.archive-query-default-component' => 'main',
461 'dgit.default.ssh' => 'ssh',
462 'dgit.default.archive-query' => 'madison:',
463 'dgit.default.sshpsql-dbname' => 'service=projectb',
464 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
465 'dgit-distro.debian.git-check' => 'url',
466 'dgit-distro.debian.git-check-suffix' => '/info/refs',
467 'dgit-distro.debian.new-private-pushers' => 't',
468 'dgit-distro.debian/push.git-url' => '',
469 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
470 'dgit-distro.debian/push.git-user-force' => 'dgit',
471 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
472 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
473 'dgit-distro.debian/push.git-create' => 'true',
474 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
475 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
476 # 'dgit-distro.debian.archive-query-tls-key',
477 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
478 # ^ this does not work because curl is broken nowadays
479 # Fixing #790093 properly will involve providing providing the key
480 # in some pacagke and maybe updating these paths.
482 # 'dgit-distro.debian.archive-query-tls-curl-args',
483 # '--ca-path=/etc/ssl/ca-debian',
484 # ^ this is a workaround but works (only) on DSA-administered machines
485 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
486 'dgit-distro.debian.git-url-suffix' => '',
487 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
488 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
489 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
490 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
491 'dgit-distro.ubuntu.git-check' => 'false',
492 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
493 'dgit-distro.test-dummy.ssh' => "$td/ssh",
494 'dgit-distro.test-dummy.username' => "alice",
495 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
496 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
497 'dgit-distro.test-dummy.git-url' => "$td/git",
498 'dgit-distro.test-dummy.git-host' => "git",
499 'dgit-distro.test-dummy.git-path' => "$td/git",
500 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
501 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
502 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
503 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
508 sub git_slurp_config () {
509 local ($debuglevel) = $debuglevel-2;
512 my @cmd = (@git, qw(config -z --get-regexp .*));
515 open GITS, "-|", @cmd or failedcmd @cmd;
518 printdebug "=> ", (messagequote $_), "\n";
520 push @{ $gitcfg{$`} }, $'; #';
524 or ($!==0 && $?==256)
528 sub git_get_config ($) {
531 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
534 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
540 return undef if $c =~ /RETURN-UNDEF/;
541 my $v = git_get_config($c);
542 return $v if defined $v;
543 my $dv = $defcfg{$c};
544 return $dv if defined $dv;
546 badcfg "need value for one of: @_\n".
547 "$us: distro or suite appears not to be (properly) supported";
550 sub access_basedistro () {
551 if (defined $idistro) {
554 return cfg("dgit-suite.$isuite.distro",
555 "dgit.default.distro");
559 sub access_quirk () {
560 # returns (quirk name, distro to use instead or undef, quirk-specific info)
561 my $basedistro = access_basedistro();
562 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
564 if (defined $backports_quirk) {
565 my $re = $backports_quirk;
566 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
568 $re =~ s/\%/([-0-9a-z_]+)/
569 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
570 if ($isuite =~ m/^$re$/) {
571 return ('backports',"$basedistro-backports",$1);
574 return ('none',undef);
579 sub parse_cfg_bool ($$$) {
580 my ($what,$def,$v) = @_;
583 $v =~ m/^[ty1]/ ? 1 :
584 $v =~ m/^[fn0]/ ? 0 :
585 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
588 sub access_forpush_config () {
589 my $d = access_basedistro();
593 parse_cfg_bool('new-private-pushers', 0,
594 cfg("dgit-distro.$d.new-private-pushers",
597 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
600 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
601 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
602 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
603 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
606 sub access_forpush () {
607 $access_forpush //= access_forpush_config();
608 return $access_forpush;
612 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
613 badcfg "pushing but distro is configured readonly"
614 if access_forpush_config() eq '0';
616 $supplementary_message = <<'END' unless $we_are_responder;
617 Push failed, before we got started.
618 You can retry the push, after fixing the problem, if you like.
620 finalise_opts_opts();
624 finalise_opts_opts();
627 sub supplementary_message ($) {
629 if (!$we_are_responder) {
630 $supplementary_message = $msg;
632 } elsif ($protovsn >= 3) {
633 responder_send_command "supplementary-message ".length($msg)
635 print PO $msg or die $!;
639 sub access_distros () {
640 # Returns list of distros to try, in order
643 # 0. `instead of' distro name(s) we have been pointed to
644 # 1. the access_quirk distro, if any
645 # 2a. the user's specified distro, or failing that } basedistro
646 # 2b. the distro calculated from the suite }
647 my @l = access_basedistro();
649 my (undef,$quirkdistro) = access_quirk();
650 unshift @l, $quirkdistro;
651 unshift @l, $instead_distro;
652 @l = grep { defined } @l;
654 if (access_forpush()) {
655 @l = map { ("$_/push", $_) } @l;
660 sub access_cfg_cfgs (@) {
663 # The nesting of these loops determines the search order. We put
664 # the key loop on the outside so that we search all the distros
665 # for each key, before going on to the next key. That means that
666 # if access_cfg is called with a more specific, and then a less
667 # specific, key, an earlier distro can override the less specific
668 # without necessarily overriding any more specific keys. (If the
669 # distro wants to override the more specific keys it can simply do
670 # so; whereas if we did the loop the other way around, it would be
671 # impossible to for an earlier distro to override a less specific
672 # key but not the more specific ones without restating the unknown
673 # values of the more specific keys.
676 # We have to deal with RETURN-UNDEF specially, so that we don't
677 # terminate the search prematurely.
679 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
682 foreach my $d (access_distros()) {
683 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
685 push @cfgs, map { "dgit.default.$_" } @realkeys;
692 my (@cfgs) = access_cfg_cfgs(@keys);
693 my $value = cfg(@cfgs);
697 sub string_to_ssh ($) {
699 if ($spec =~ m/\s/) {
700 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
706 sub access_cfg_ssh () {
707 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
708 if (!defined $gitssh) {
711 return string_to_ssh $gitssh;
715 sub access_runeinfo ($) {
717 return ": dgit ".access_basedistro()." $info ;";
720 sub access_someuserhost ($) {
722 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
723 defined($user) && length($user) or
724 $user = access_cfg("$some-user",'username');
725 my $host = access_cfg("$some-host");
726 return length($user) ? "$user\@$host" : $host;
729 sub access_gituserhost () {
730 return access_someuserhost('git');
733 sub access_giturl (;$) {
735 my $url = access_cfg('git-url','RETURN-UNDEF');
738 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
739 return undef unless defined $proto;
742 access_gituserhost().
743 access_cfg('git-path');
745 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
748 return "$url/$package$suffix";
751 sub parsecontrolfh ($$;$) {
752 my ($fh, $desc, $allowsigned) = @_;
753 our $dpkgcontrolhash_noissigned;
756 my %opts = ('name' => $desc);
757 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
758 $c = Dpkg::Control::Hash->new(%opts);
759 $c->parse($fh,$desc) or die "parsing of $desc failed";
760 last if $allowsigned;
761 last if $dpkgcontrolhash_noissigned;
762 my $issigned= $c->get_option('is_pgp_signed');
763 if (!defined $issigned) {
764 $dpkgcontrolhash_noissigned= 1;
765 seek $fh, 0,0 or die "seek $desc: $!";
766 } elsif ($issigned) {
767 fail "control file $desc is (already) PGP-signed. ".
768 " Note that dgit push needs to modify the .dsc and then".
769 " do the signature itself";
778 my ($file, $desc) = @_;
779 my $fh = new IO::Handle;
780 open $fh, '<', $file or die "$file: $!";
781 my $c = parsecontrolfh($fh,$desc);
782 $fh->error and die $!;
788 my ($dctrl,$field) = @_;
789 my $v = $dctrl->{$field};
790 return $v if defined $v;
791 fail "missing field $field in ".$v->get_option('name');
795 my $c = Dpkg::Control::Hash->new();
796 my $p = new IO::Handle;
797 my @cmd = (qw(dpkg-parsechangelog), @_);
798 open $p, '-|', @cmd or die $!;
800 $?=0; $!=0; close $p or failedcmd @cmd;
806 defined $d or fail "getcwd failed: $!";
812 sub archive_query ($) {
814 my $query = access_cfg('archive-query','RETURN-UNDEF');
815 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
818 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
821 sub pool_dsc_subpath ($$) {
822 my ($vsn,$component) = @_; # $package is implict arg
823 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
824 return "/pool/$component/$prefix/$package/".dscfn($vsn);
827 #---------- `ftpmasterapi' archive query method (nascent) ----------
829 sub archive_api_query_cmd ($) {
831 my @cmd = qw(curl -sS);
832 my $url = access_cfg('archive-query-url');
833 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
835 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
836 foreach my $key (split /\:/, $keys) {
837 $key =~ s/\%HOST\%/$host/g;
839 fail "for $url: stat $key: $!" unless $!==ENOENT;
842 fail "config requested specific TLS key but do not know".
843 " how to get curl to use exactly that EE key ($key)";
844 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
845 # # Sadly the above line does not work because of changes
846 # # to gnutls. The real fix for #790093 may involve
847 # # new curl options.
850 # Fixing #790093 properly will involve providing a value
851 # for this on clients.
852 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
853 push @cmd, split / /, $kargs if defined $kargs;
855 push @cmd, $url.$subpath;
861 my ($data, $subpath) = @_;
862 badcfg "ftpmasterapi archive query method takes no data part"
864 my @cmd = archive_api_query_cmd($subpath);
865 my $json = cmdoutput @cmd;
866 return decode_json($json);
869 sub canonicalise_suite_ftpmasterapi () {
870 my ($proto,$data) = @_;
871 my $suites = api_query($data, 'suites');
873 foreach my $entry (@$suites) {
875 my $v = $entry->{$_};
876 defined $v && $v eq $isuite;
878 push @matched, $entry;
880 fail "unknown suite $isuite" unless @matched;
883 @matched==1 or die "multiple matches for suite $isuite\n";
884 $cn = "$matched[0]{codename}";
885 defined $cn or die "suite $isuite info has no codename\n";
886 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
888 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
893 sub archive_query_ftpmasterapi () {
894 my ($proto,$data) = @_;
895 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
897 my $digester = Digest::SHA->new(256);
898 foreach my $entry (@$info) {
900 my $vsn = "$entry->{version}";
901 my ($ok,$msg) = version_check $vsn;
902 die "bad version: $msg\n" unless $ok;
903 my $component = "$entry->{component}";
904 $component =~ m/^$component_re$/ or die "bad component";
905 my $filename = "$entry->{filename}";
906 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
907 or die "bad filename";
908 my $sha256sum = "$entry->{sha256sum}";
909 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
910 push @rows, [ $vsn, "/pool/$component/$filename",
911 $digester, $sha256sum ];
913 die "bad ftpmaster api response: $@\n".Dumper($entry)
916 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
920 #---------- `madison' archive query method ----------
922 sub archive_query_madison {
923 return map { [ @$_[0..1] ] } madison_get_parse(@_);
926 sub madison_get_parse {
927 my ($proto,$data) = @_;
928 die unless $proto eq 'madison';
930 $data= access_cfg('madison-distro','RETURN-UNDEF');
931 $data //= access_basedistro();
933 $rmad{$proto,$data,$package} ||= cmdoutput
934 qw(rmadison -asource),"-s$isuite","-u$data",$package;
935 my $rmad = $rmad{$proto,$data,$package};
938 foreach my $l (split /\n/, $rmad) {
939 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
940 \s*( [^ \t|]+ )\s* \|
941 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
942 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
943 $1 eq $package or die "$rmad $package ?";
950 $component = access_cfg('archive-query-default-component');
952 $5 eq 'source' or die "$rmad ?";
953 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
955 return sort { -version_compare($a->[0],$b->[0]); } @out;
958 sub canonicalise_suite_madison {
959 # madison canonicalises for us
960 my @r = madison_get_parse(@_);
962 "unable to canonicalise suite using package $package".
963 " which does not appear to exist in suite $isuite;".
964 " --existing-package may help";
968 #---------- `sshpsql' archive query method ----------
971 my ($data,$runeinfo,$sql) = @_;
973 $data= access_someuserhost('sshpsql').':'.
974 access_cfg('sshpsql-dbname');
976 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
977 my ($userhost,$dbname) = ($`,$'); #';
979 my @cmd = (access_cfg_ssh, $userhost,
980 access_runeinfo("ssh-psql $runeinfo").
981 " export LC_MESSAGES=C; export LC_CTYPE=C;".
982 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
984 open P, "-|", @cmd or die $!;
987 printdebug("$debugprefix>|$_|\n");
990 $!=0; $?=0; close P or failedcmd @cmd;
992 my $nrows = pop @rows;
993 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
994 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
995 @rows = map { [ split /\|/, $_ ] } @rows;
996 my $ncols = scalar @{ shift @rows };
997 die if grep { scalar @$_ != $ncols } @rows;
1001 sub sql_injection_check {
1002 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1005 sub archive_query_sshpsql ($$) {
1006 my ($proto,$data) = @_;
1007 sql_injection_check $isuite, $package;
1008 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1009 SELECT source.version, component.name, files.filename, files.sha256sum
1011 JOIN src_associations ON source.id = src_associations.source
1012 JOIN suite ON suite.id = src_associations.suite
1013 JOIN dsc_files ON dsc_files.source = source.id
1014 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1015 JOIN component ON component.id = files_archive_map.component_id
1016 JOIN files ON files.id = dsc_files.file
1017 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1018 AND source.source='$package'
1019 AND files.filename LIKE '%.dsc';
1021 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1022 my $digester = Digest::SHA->new(256);
1024 my ($vsn,$component,$filename,$sha256sum) = @$_;
1025 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1030 sub canonicalise_suite_sshpsql ($$) {
1031 my ($proto,$data) = @_;
1032 sql_injection_check $isuite;
1033 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1034 SELECT suite.codename
1035 FROM suite where suite_name='$isuite' or codename='$isuite';
1037 @rows = map { $_->[0] } @rows;
1038 fail "unknown suite $isuite" unless @rows;
1039 die "ambiguous $isuite: @rows ?" if @rows>1;
1043 #---------- `dummycat' archive query method ----------
1045 sub canonicalise_suite_dummycat ($$) {
1046 my ($proto,$data) = @_;
1047 my $dpath = "$data/suite.$isuite";
1048 if (!open C, "<", $dpath) {
1049 $!==ENOENT or die "$dpath: $!";
1050 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1054 chomp or die "$dpath: $!";
1056 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1060 sub archive_query_dummycat ($$) {
1061 my ($proto,$data) = @_;
1062 canonicalise_suite();
1063 my $dpath = "$data/package.$csuite.$package";
1064 if (!open C, "<", $dpath) {
1065 $!==ENOENT or die "$dpath: $!";
1066 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1074 printdebug "dummycat query $csuite $package $dpath | $_\n";
1075 my @row = split /\s+/, $_;
1076 @row==2 or die "$dpath: $_ ?";
1079 C->error and die "$dpath: $!";
1081 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1084 #---------- archive query entrypoints and rest of program ----------
1086 sub canonicalise_suite () {
1087 return if defined $csuite;
1088 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1089 $csuite = archive_query('canonicalise_suite');
1090 if ($isuite ne $csuite) {
1091 progress "canonical suite name for $isuite is $csuite";
1095 sub get_archive_dsc () {
1096 canonicalise_suite();
1097 my @vsns = archive_query('archive_query');
1098 foreach my $vinfo (@vsns) {
1099 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1100 $dscurl = access_cfg('mirror').$subpath;
1101 $dscdata = url_get($dscurl);
1103 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1108 $digester->add($dscdata);
1109 my $got = $digester->hexdigest();
1111 fail "$dscurl has hash $got but".
1112 " archive told us to expect $digest";
1114 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1115 printdebug Dumper($dscdata) if $debuglevel>1;
1116 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1117 printdebug Dumper($dsc) if $debuglevel>1;
1118 my $fmt = getfield $dsc, 'Format';
1119 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1120 $dsc_checked = !!$digester;
1126 sub check_for_git ();
1127 sub check_for_git () {
1129 my $how = access_cfg('git-check');
1130 if ($how eq 'ssh-cmd') {
1132 (access_cfg_ssh, access_gituserhost(),
1133 access_runeinfo("git-check $package").
1134 " set -e; cd ".access_cfg('git-path').";".
1135 " if test -d $package.git; then echo 1; else echo 0; fi");
1136 my $r= cmdoutput @cmd;
1137 if ($r =~ m/^divert (\w+)$/) {
1139 my ($usedistro,) = access_distros();
1140 # NB that if we are pushing, $usedistro will be $distro/push
1141 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1142 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1143 progress "diverting to $divert (using config for $instead_distro)";
1144 return check_for_git();
1146 failedcmd @cmd unless $r =~ m/^[01]$/;
1148 } elsif ($how eq 'url') {
1149 my $prefix = access_cfg('git-check-url','git-url');
1150 my $suffix = access_cfg('git-check-suffix','git-suffix',
1151 'RETURN-UNDEF') // '.git';
1152 my $url = "$prefix/$package$suffix";
1153 my @cmd = (qw(curl -sS -I), $url);
1154 my $result = cmdoutput @cmd;
1155 $result =~ m/^\S+ (404|200) /s or
1156 fail "unexpected results from git check query - ".
1157 Dumper($prefix, $result);
1159 if ($code eq '404') {
1161 } elsif ($code eq '200') {
1166 } elsif ($how eq 'true') {
1168 } elsif ($how eq 'false') {
1171 badcfg "unknown git-check \`$how'";
1175 sub create_remote_git_repo () {
1176 my $how = access_cfg('git-create');
1177 if ($how eq 'ssh-cmd') {
1179 (access_cfg_ssh, access_gituserhost(),
1180 access_runeinfo("git-create $package").
1181 "set -e; cd ".access_cfg('git-path').";".
1182 " cp -a _template $package.git");
1183 } elsif ($how eq 'true') {
1186 badcfg "unknown git-create \`$how'";
1190 our ($dsc_hash,$lastpush_hash);
1192 our $ud = '.git/dgit/unpack';
1197 mkdir $ud or die $!;
1200 sub mktree_in_ud_here () {
1201 runcmd qw(git init -q);
1202 rmtree('.git/objects');
1203 symlink '../../../../objects','.git/objects' or die $!;
1206 sub git_write_tree () {
1207 my $tree = cmdoutput @git, qw(write-tree);
1208 $tree =~ m/^\w+$/ or die "$tree ?";
1212 sub mktree_in_ud_from_only_subdir () {
1213 # changes into the subdir
1215 die unless @dirs==1;
1216 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1220 my @gitscmd = qw(find -name .git -prune -print0);
1221 debugcmd "|",@gitscmd;
1222 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1227 print STDERR "$us: warning: removing from source package: ",
1228 (messagequote $_), "\n";
1232 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1234 mktree_in_ud_here();
1235 my $format=get_source_format();
1236 if (madformat($format)) {
1239 runcmd @git, qw(add -Af);
1240 my $tree=git_write_tree();
1241 return ($tree,$dir);
1244 sub dsc_files_info () {
1245 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1246 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1247 ['Files', 'Digest::MD5', 'new()']) {
1248 my ($fname, $module, $method) = @$csumi;
1249 my $field = $dsc->{$fname};
1250 next unless defined $field;
1251 eval "use $module; 1;" or die $@;
1253 foreach (split /\n/, $field) {
1255 m/^(\w+) (\d+) (\S+)$/ or
1256 fail "could not parse .dsc $fname line \`$_'";
1257 my $digester = eval "$module"."->$method;" or die $@;
1262 Digester => $digester,
1267 fail "missing any supported Checksums-* or Files field in ".
1268 $dsc->get_option('name');
1272 map { $_->{Filename} } dsc_files_info();
1275 sub is_orig_file ($;$) {
1278 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1279 defined $base or return 1;
1283 sub make_commit ($) {
1285 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1288 sub clogp_authline ($) {
1290 my $author = getfield $clogp, 'Maintainer';
1291 $author =~ s#,.*##ms;
1292 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1293 my $authline = "$author $date";
1294 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1295 fail "unexpected commit author line format \`$authline'".
1296 " (was generated from changelog Maintainer field)";
1300 sub vendor_patches_distro ($$) {
1301 my ($checkdistro, $what) = @_;
1302 return unless defined $checkdistro;
1304 my $series = "debian/patches/\L$checkdistro\E.series";
1305 printdebug "checking for vendor-specific $series ($what)\n";
1307 if (!open SERIES, "<", $series) {
1308 die "$series $!" unless $!==ENOENT;
1317 Unfortunately, this source package uses a feature of dpkg-source where
1318 the same source package unpacks to different source code on different
1319 distros. dgit cannot safely operate on such packages on affected
1320 distros, because the meaning of source packages is not stable.
1322 Please ask the distro/maintainer to remove the distro-specific series
1323 files and use a different technique (if necessary, uploading actually
1324 different packages, if different distros are supposed to have
1328 fail "Found active distro-specific series file for".
1329 " $checkdistro ($what): $series, cannot continue";
1331 die "$series $!" if SERIES->error;
1335 sub check_for_vendor_patches () {
1336 # This dpkg-source feature doesn't seem to be documented anywhere!
1337 # But it can be found in the changelog (reformatted):
1339 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1340 # Author: Raphael Hertzog <hertzog@debian.org>
1341 # Date: Sun Oct 3 09:36:48 2010 +0200
1343 # dpkg-source: correctly create .pc/.quilt_series with alternate
1346 # If you have debian/patches/ubuntu.series and you were
1347 # unpacking the source package on ubuntu, quilt was still
1348 # directed to debian/patches/series instead of
1349 # debian/patches/ubuntu.series.
1351 # debian/changelog | 3 +++
1352 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1353 # 2 files changed, 6 insertions(+), 1 deletion(-)
1356 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1357 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1358 "Dpkg::Vendor \`current vendor'");
1359 vendor_patches_distro(access_basedistro(),
1360 "distro being accessed");
1363 sub generate_commit_from_dsc () {
1367 foreach my $fi (dsc_files_info()) {
1368 my $f = $fi->{Filename};
1369 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1371 link "../../../$f", $f
1375 complete_file_from_dsc('.', $fi);
1377 if (is_orig_file($f)) {
1378 link $f, "../../../../$f"
1384 my $dscfn = "$package.dsc";
1386 open D, ">", $dscfn or die "$dscfn: $!";
1387 print D $dscdata or die "$dscfn: $!";
1388 close D or die "$dscfn: $!";
1389 my @cmd = qw(dpkg-source);
1390 push @cmd, '--no-check' if $dsc_checked;
1391 push @cmd, qw(-x --), $dscfn;
1394 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1395 check_for_vendor_patches() if madformat($dsc->{format});
1396 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1397 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1398 my $authline = clogp_authline $clogp;
1399 my $changes = getfield $clogp, 'Changes';
1400 open C, ">../commit.tmp" or die $!;
1401 print C <<END or die $!;
1408 # imported from the archive
1411 my $outputhash = make_commit qw(../commit.tmp);
1412 my $cversion = getfield $clogp, 'Version';
1413 progress "synthesised git commit from .dsc $cversion";
1414 if ($lastpush_hash) {
1415 runcmd @git, qw(reset --hard), $lastpush_hash;
1416 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1417 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1418 my $oversion = getfield $oldclogp, 'Version';
1420 version_compare($oversion, $cversion);
1422 # git upload/ is earlier vsn than archive, use archive
1423 open C, ">../commit2.tmp" or die $!;
1424 print C <<END or die $!;
1426 parent $lastpush_hash
1431 Record $package ($cversion) in archive suite $csuite
1433 $outputhash = make_commit qw(../commit2.tmp);
1434 } elsif ($vcmp > 0) {
1435 print STDERR <<END or die $!;
1437 Version actually in archive: $cversion (older)
1438 Last allegedly pushed/uploaded: $oversion (newer or same)
1441 $outputhash = $lastpush_hash;
1443 $outputhash = $lastpush_hash;
1446 changedir '../../../..';
1447 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1448 'DGIT_ARCHIVE', $outputhash;
1449 cmdoutput @git, qw(log -n2), $outputhash;
1450 # ... gives git a chance to complain if our commit is malformed
1455 sub complete_file_from_dsc ($$) {
1456 our ($dstdir, $fi) = @_;
1457 # Ensures that we have, in $dir, the file $fi, with the correct
1458 # contents. (Downloading it from alongside $dscurl if necessary.)
1460 my $f = $fi->{Filename};
1461 my $tf = "$dstdir/$f";
1464 if (stat_exists $tf) {
1465 progress "using existing $f";
1468 $furl =~ s{/[^/]+$}{};
1470 die "$f ?" unless $f =~ m/^${package}_/;
1471 die "$f ?" if $f =~ m#/#;
1472 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1473 next if !act_local();
1477 open F, "<", "$tf" or die "$tf: $!";
1478 $fi->{Digester}->reset();
1479 $fi->{Digester}->addfile(*F);
1480 F->error and die $!;
1481 my $got = $fi->{Digester}->hexdigest();
1482 $got eq $fi->{Hash} or
1483 fail "file $f has hash $got but .dsc".
1484 " demands hash $fi->{Hash} ".
1485 ($downloaded ? "(got wrong file from archive!)"
1486 : "(perhaps you should delete this file?)");
1489 sub ensure_we_have_orig () {
1490 foreach my $fi (dsc_files_info()) {
1491 my $f = $fi->{Filename};
1492 next unless is_orig_file($f);
1493 complete_file_from_dsc('..', $fi);
1497 sub git_fetch_us () {
1498 my @specs = (fetchspec());
1500 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1502 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1505 my $tagpat = debiantag('*',access_basedistro);
1507 git_for_each_ref("refs/tags/".$tagpat, sub {
1508 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1509 printdebug "currently $fullrefname=$objid\n";
1510 $here{$fullrefname} = $objid;
1512 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1513 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1514 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1515 printdebug "offered $lref=$objid\n";
1516 if (!defined $here{$lref}) {
1517 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1518 runcmd_ordryrun_local @upd;
1519 } elsif ($here{$lref} eq $objid) {
1522 "Not updateting $lref from $here{$lref} to $objid.\n";
1527 sub fetch_from_archive () {
1528 # ensures that lrref() is what is actually in the archive,
1529 # one way or another
1533 foreach my $field (@ourdscfield) {
1534 $dsc_hash = $dsc->{$field};
1535 last if defined $dsc_hash;
1537 if (defined $dsc_hash) {
1538 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1540 progress "last upload to archive specified git hash";
1542 progress "last upload to archive has NO git hash";
1545 progress "no version available from the archive";
1548 $lastpush_hash = git_get_ref(lrref());
1549 printdebug "previous reference hash=$lastpush_hash\n";
1551 if (defined $dsc_hash) {
1552 fail "missing remote git history even though dsc has hash -".
1553 " could not find ref ".lrref().
1554 " (should have been fetched from ".access_giturl()."#".rrref().")"
1555 unless $lastpush_hash;
1557 ensure_we_have_orig();
1558 if ($dsc_hash eq $lastpush_hash) {
1559 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1560 print STDERR <<END or die $!;
1562 Git commit in archive is behind the last version allegedly pushed/uploaded.
1563 Commit referred to by archive: $dsc_hash
1564 Last allegedly pushed/uploaded: $lastpush_hash
1567 $hash = $lastpush_hash;
1569 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1570 "descendant of archive's .dsc hash ($dsc_hash)";
1573 $hash = generate_commit_from_dsc();
1574 } elsif ($lastpush_hash) {
1575 # only in git, not in the archive yet
1576 $hash = $lastpush_hash;
1577 print STDERR <<END or die $!;
1579 Package not found in the archive, but has allegedly been pushed using dgit.
1583 printdebug "nothing found!\n";
1584 if (defined $skew_warning_vsn) {
1585 print STDERR <<END or die $!;
1587 Warning: relevant archive skew detected.
1588 Archive allegedly contains $skew_warning_vsn
1589 But we were not able to obtain any version from the archive or git.
1595 printdebug "current hash=$hash\n";
1596 if ($lastpush_hash) {
1597 fail "not fast forward on last upload branch!".
1598 " (archive's version left in DGIT_ARCHIVE)"
1599 unless is_fast_fwd($lastpush_hash, $hash);
1601 if (defined $skew_warning_vsn) {
1603 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1604 my $clogf = ".git/dgit/changelog.tmp";
1605 runcmd shell_cmd "exec >$clogf",
1606 @git, qw(cat-file blob), "$hash:debian/changelog";
1607 my $gotclogp = parsechangelog("-l$clogf");
1608 my $got_vsn = getfield $gotclogp, 'Version';
1609 printdebug "SKEW CHECK GOT $got_vsn\n";
1610 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1611 print STDERR <<END or die $!;
1613 Warning: archive skew detected. Using the available version:
1614 Archive allegedly contains $skew_warning_vsn
1615 We were able to obtain only $got_vsn
1620 if ($lastpush_hash ne $hash) {
1621 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1625 dryrun_report @upd_cmd;
1631 sub set_local_git_config ($$) {
1633 runcmd @git, qw(config), $k, $v;
1636 sub setup_mergechangelogs () {
1637 my $driver = 'dpkg-mergechangelogs';
1638 my $cb = "merge.$driver";
1639 my $attrs = '.git/info/attributes';
1640 ensuredir '.git/info';
1642 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1643 if (!open ATTRS, "<", $attrs) {
1644 $!==ENOENT or die "$attrs: $!";
1648 next if m{^debian/changelog\s};
1649 print NATTRS $_, "\n" or die $!;
1651 ATTRS->error and die $!;
1654 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1657 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1658 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1660 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1665 canonicalise_suite();
1666 badusage "dry run makes no sense with clone" unless act_local();
1667 my $hasgit = check_for_git();
1668 mkdir $dstdir or die "$dstdir $!";
1670 runcmd @git, qw(init -q);
1671 my $giturl = access_giturl(1);
1672 if (defined $giturl) {
1673 set_local_git_config "remote.$remotename.fetch", fetchspec();
1674 open H, "> .git/HEAD" or die $!;
1675 print H "ref: ".lref()."\n" or die $!;
1677 runcmd @git, qw(remote add), 'origin', $giturl;
1680 progress "fetching existing git history";
1682 runcmd_ordryrun_local @git, qw(fetch origin);
1684 progress "starting new git history";
1686 fetch_from_archive() or no_such_package;
1687 my $vcsgiturl = $dsc->{'Vcs-Git'};
1688 if (length $vcsgiturl) {
1689 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1690 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1692 setup_mergechangelogs();
1693 runcmd @git, qw(reset --hard), lrref();
1694 printdone "ready for work in $dstdir";
1698 if (check_for_git()) {
1701 fetch_from_archive() or no_such_package();
1702 printdone "fetched into ".lrref();
1707 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1709 printdone "fetched to ".lrref()." and merged into HEAD";
1712 sub check_not_dirty () {
1713 return if $ignoredirty;
1714 my @cmd = (@git, qw(diff --quiet HEAD));
1716 $!=0; $?=0; system @cmd;
1717 return if !$! && !$?;
1718 if (!$! && $?==256) {
1719 fail "working tree is dirty (does not match HEAD)";
1725 sub commit_admin ($) {
1728 runcmd_ordryrun_local @git, qw(commit -m), $m;
1731 sub commit_quilty_patch () {
1732 my $output = cmdoutput @git, qw(status --porcelain);
1734 foreach my $l (split /\n/, $output) {
1735 next unless $l =~ m/\S/;
1736 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1740 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1742 progress "nothing quilty to commit, ok.";
1745 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1746 commit_admin "Commit Debian 3.0 (quilt) metadata";
1749 sub get_source_format () {
1750 if (!open F, "debian/source/format") {
1751 die $! unless $!==&ENOENT;
1755 F->error and die $!;
1762 return 0 unless $format eq '3.0 (quilt)';
1763 if ($quilt_mode eq 'nocheck') {
1764 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1767 progress "Format \`$format', checking/updating patch stack";
1771 sub push_parse_changelog ($) {
1774 my $clogp = Dpkg::Control::Hash->new();
1775 $clogp->load($clogpfn) or die;
1777 $package = getfield $clogp, 'Source';
1778 my $cversion = getfield $clogp, 'Version';
1779 my $tag = debiantag($cversion, access_basedistro);
1780 runcmd @git, qw(check-ref-format), $tag;
1782 my $dscfn = dscfn($cversion);
1784 return ($clogp, $cversion, $tag, $dscfn);
1787 sub push_parse_dsc ($$$) {
1788 my ($dscfn,$dscfnwhat, $cversion) = @_;
1789 $dsc = parsecontrol($dscfn,$dscfnwhat);
1790 my $dversion = getfield $dsc, 'Version';
1791 my $dscpackage = getfield $dsc, 'Source';
1792 ($dscpackage eq $package && $dversion eq $cversion) or
1793 fail "$dscfn is for $dscpackage $dversion".
1794 " but debian/changelog is for $package $cversion";
1797 sub push_mktag ($$$$$$$) {
1798 my ($head,$clogp,$tag,
1800 $changesfile,$changesfilewhat,
1803 $dsc->{$ourdscfield[0]} = $head;
1804 $dsc->save("$dscfn.tmp") or die $!;
1806 my $changes = parsecontrol($changesfile,$changesfilewhat);
1807 foreach my $field (qw(Source Distribution Version)) {
1808 $changes->{$field} eq $clogp->{$field} or
1809 fail "changes field $field \`$changes->{$field}'".
1810 " does not match changelog \`$clogp->{$field}'";
1813 my $cversion = getfield $clogp, 'Version';
1814 my $clogsuite = getfield $clogp, 'Distribution';
1816 # We make the git tag by hand because (a) that makes it easier
1817 # to control the "tagger" (b) we can do remote signing
1818 my $authline = clogp_authline $clogp;
1819 my $delibs = join(" ", "",@deliberatelies);
1820 my $declaredistro = access_basedistro();
1821 open TO, '>', $tfn->('.tmp') or die $!;
1822 print TO <<END or die $!;
1828 $package release $cversion for $clogsuite ($csuite) [dgit]
1829 [dgit distro=$declaredistro$delibs]
1831 foreach my $ref (sort keys %previously) {
1832 print TO <<END or die $!;
1833 [dgit previously:$ref=$previously{$ref}]
1839 my $tagobjfn = $tfn->('.tmp');
1841 if (!defined $keyid) {
1842 $keyid = access_cfg('keyid','RETURN-UNDEF');
1844 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1845 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1846 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1847 push @sign_cmd, $tfn->('.tmp');
1848 runcmd_ordryrun @sign_cmd;
1850 $tagobjfn = $tfn->('.signed.tmp');
1851 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1852 $tfn->('.tmp'), $tfn->('.tmp.asc');
1859 sub sign_changes ($) {
1860 my ($changesfile) = @_;
1862 my @debsign_cmd = @debsign;
1863 push @debsign_cmd, "-k$keyid" if defined $keyid;
1864 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1865 push @debsign_cmd, $changesfile;
1866 runcmd_ordryrun @debsign_cmd;
1871 my ($forceflag) = @_;
1872 printdebug "actually entering push\n";
1873 supplementary_message(<<'END');
1874 Push failed, while preparing your push.
1875 You can retry the push, after fixing the problem, if you like.
1879 access_giturl(); # check that success is vaguely likely
1881 my $clogpfn = ".git/dgit/changelog.822.tmp";
1882 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1884 responder_send_file('parsed-changelog', $clogpfn);
1886 my ($clogp, $cversion, $tag, $dscfn) =
1887 push_parse_changelog("$clogpfn");
1889 my $dscpath = "$buildproductsdir/$dscfn";
1890 stat_exists $dscpath or
1891 fail "looked for .dsc $dscfn, but $!;".
1892 " maybe you forgot to build";
1894 responder_send_file('dsc', $dscpath);
1896 push_parse_dsc($dscpath, $dscfn, $cversion);
1898 my $format = getfield $dsc, 'Format';
1899 printdebug "format $format\n";
1900 if (madformat($format)) {
1901 commit_quilty_patch();
1905 progress "checking that $dscfn corresponds to HEAD";
1906 runcmd qw(dpkg-source -x --),
1907 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1908 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1909 check_for_vendor_patches() if madformat($dsc->{format});
1910 changedir '../../../..';
1911 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1912 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1913 debugcmd "+",@diffcmd;
1915 my $r = system @diffcmd;
1918 fail "$dscfn specifies a different tree to your HEAD commit;".
1919 " perhaps you forgot to build".
1920 ($diffopt eq '--exit-code' ? "" :
1921 " (run with -D to see full diff output)");
1926 my $head = git_rev_parse('HEAD');
1927 if (!$changesfile) {
1928 my $multi = "$buildproductsdir/".
1929 "${package}_".(stripepoch $cversion)."_multi.changes";
1930 if (stat_exists "$multi") {
1931 $changesfile = $multi;
1933 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1934 my @cs = glob "$buildproductsdir/$pat";
1935 fail "failed to find unique changes file".
1936 " (looked for $pat in $buildproductsdir, or $multi);".
1937 " perhaps you need to use dgit -C"
1939 ($changesfile) = @cs;
1942 $changesfile = "$buildproductsdir/$changesfile";
1945 responder_send_file('changes',$changesfile);
1946 responder_send_command("param head $head");
1947 responder_send_command("param csuite $csuite");
1949 if (deliberately_not_fast_forward) {
1950 git_for_each_ref(lrfetchrefs, sub {
1951 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1952 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1953 responder_send_command("previously $rrefname=$objid");
1954 $previously{$rrefname} = $objid;
1958 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1961 supplementary_message(<<'END');
1962 Push failed, while signing the tag.
1963 You can retry the push, after fixing the problem, if you like.
1965 # If we manage to sign but fail to record it anywhere, it's fine.
1966 if ($we_are_responder) {
1967 $tagobjfn = $tfn->('.signed.tmp');
1968 responder_receive_files('signed-tag', $tagobjfn);
1971 push_mktag($head,$clogp,$tag,
1973 $changesfile,$changesfile,
1976 supplementary_message(<<'END');
1977 Push failed, *after* signing the tag.
1978 If you want to try again, you should use a new version number.
1981 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1982 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1983 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1985 supplementary_message(<<'END');
1986 Push failed, while updating the remote git repository - see messages above.
1987 If you want to try again, you should use a new version number.
1989 if (!check_for_git()) {
1990 create_remote_git_repo();
1992 runcmd_ordryrun @git, qw(push),access_giturl(),
1993 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1994 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1996 supplementary_message(<<'END');
1997 Push failed, after updating the remote git repository.
1998 If you want to try again, you must use a new version number.
2000 if ($we_are_responder) {
2001 my $dryrunsuffix = act_local() ? "" : ".tmp";
2002 responder_receive_files('signed-dsc-changes',
2003 "$dscpath$dryrunsuffix",
2004 "$changesfile$dryrunsuffix");
2007 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2009 progress "[new .dsc left in $dscpath.tmp]";
2011 sign_changes $changesfile;
2014 supplementary_message(<<'END');
2015 Push failed, while uploading package(s) to the archive server.
2016 You can retry the upload of exactly these same files with dput of:
2018 If that .changes file is broken, you will need to use a new version
2019 number for your next attempt at the upload.
2021 my $host = access_cfg('upload-host','RETURN-UNDEF');
2022 my @hostarg = defined($host) ? ($host,) : ();
2023 runcmd_ordryrun @dput, @hostarg, $changesfile;
2024 printdone "pushed and uploaded $cversion";
2026 supplementary_message('');
2027 responder_send_command("complete");
2034 badusage "-p is not allowed with clone; specify as argument instead"
2035 if defined $package;
2038 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2039 ($package,$isuite) = @ARGV;
2040 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2041 ($package,$dstdir) = @ARGV;
2042 } elsif (@ARGV==3) {
2043 ($package,$isuite,$dstdir) = @ARGV;
2045 badusage "incorrect arguments to dgit clone";
2047 $dstdir ||= "$package";
2049 if (stat_exists $dstdir) {
2050 fail "$dstdir already exists";
2054 if ($rmonerror && !$dryrun_level) {
2055 $cwd_remove= getcwd();
2057 return unless defined $cwd_remove;
2058 if (!chdir "$cwd_remove") {
2059 return if $!==&ENOENT;
2060 die "chdir $cwd_remove: $!";
2062 rmtree($dstdir) or die "remove $dstdir: $!\n";
2067 $cwd_remove = undef;
2070 sub branchsuite () {
2071 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2072 if ($branch =~ m#$lbranch_re#o) {
2079 sub fetchpullargs () {
2081 if (!defined $package) {
2082 my $sourcep = parsecontrol('debian/control','debian/control');
2083 $package = getfield $sourcep, 'Source';
2086 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2088 my $clogp = parsechangelog();
2089 $isuite = getfield $clogp, 'Distribution';
2091 canonicalise_suite();
2092 progress "fetching from suite $csuite";
2093 } elsif (@ARGV==1) {
2095 canonicalise_suite();
2097 badusage "incorrect arguments to dgit fetch or dgit pull";
2116 badusage "-p is not allowed with dgit push" if defined $package;
2118 my $clogp = parsechangelog();
2119 $package = getfield $clogp, 'Source';
2122 } elsif (@ARGV==1) {
2123 ($specsuite) = (@ARGV);
2125 badusage "incorrect arguments to dgit push";
2127 $isuite = getfield $clogp, 'Distribution';
2129 local ($package) = $existing_package; # this is a hack
2130 canonicalise_suite();
2132 canonicalise_suite();
2134 if (defined $specsuite &&
2135 $specsuite ne $isuite &&
2136 $specsuite ne $csuite) {
2137 fail "dgit push: changelog specifies $isuite ($csuite)".
2138 " but command line specifies $specsuite";
2140 supplementary_message(<<'END');
2141 Push failed, while checking state of the archive.
2142 You can retry the push, after fixing the problem, if you like.
2144 if (check_for_git()) {
2148 if (fetch_from_archive()) {
2149 if (is_fast_fwd(lrref(), 'HEAD')) {
2151 } elsif (deliberately_not_fast_forward) {
2154 fail "dgit push: HEAD is not a descendant".
2155 " of the archive's version.\n".
2156 "dgit: To overwrite its contents,".
2157 " use git merge -s ours ".lrref().".\n".
2158 "dgit: To rewind history, if permitted by the archive,".
2159 " use --deliberately-not-fast-forward";
2163 fail "package appears to be new in this suite;".
2164 " if this is intentional, use --new";
2169 #---------- remote commands' implementation ----------
2171 sub cmd_remote_push_build_host {
2172 my ($nrargs) = shift @ARGV;
2173 my (@rargs) = @ARGV[0..$nrargs-1];
2174 @ARGV = @ARGV[$nrargs..$#ARGV];
2176 my ($dir,$vsnwant) = @rargs;
2177 # vsnwant is a comma-separated list; we report which we have
2178 # chosen in our ready response (so other end can tell if they
2181 $we_are_responder = 1;
2182 $us .= " (build host)";
2186 open PI, "<&STDIN" or die $!;
2187 open STDIN, "/dev/null" or die $!;
2188 open PO, ">&STDOUT" or die $!;
2190 open STDOUT, ">&STDERR" or die $!;
2194 ($protovsn) = grep {
2195 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2196 } @rpushprotovsn_support;
2198 fail "build host has dgit rpush protocol versions ".
2199 (join ",", @rpushprotovsn_support).
2200 " but invocation host has $vsnwant"
2201 unless defined $protovsn;
2203 responder_send_command("dgit-remote-push-ready $protovsn");
2209 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2210 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2211 # a good error message)
2217 my $report = i_child_report();
2218 if (defined $report) {
2219 printdebug "($report)\n";
2220 } elsif ($i_child_pid) {
2221 printdebug "(killing build host child $i_child_pid)\n";
2222 kill 15, $i_child_pid;
2224 if (defined $i_tmp && !defined $initiator_tempdir) {
2226 eval { rmtree $i_tmp; };
2230 END { i_cleanup(); }
2233 my ($base,$selector,@args) = @_;
2234 $selector =~ s/\-/_/g;
2235 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2242 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2250 push @rargs, join ",", @rpushprotovsn_support;
2253 push @rdgit, @ropts;
2254 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2256 my @cmd = (@ssh, $host, shellquote @rdgit);
2259 if (defined $initiator_tempdir) {
2260 rmtree $initiator_tempdir;
2261 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2262 $i_tmp = $initiator_tempdir;
2266 $i_child_pid = open2(\*RO, \*RI, @cmd);
2268 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2269 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2270 $supplementary_message = '' unless $protovsn >= 3;
2272 my ($icmd,$iargs) = initiator_expect {
2273 m/^(\S+)(?: (.*))?$/;
2276 i_method "i_resp", $icmd, $iargs;
2280 sub i_resp_progress ($) {
2282 my $msg = protocol_read_bytes \*RO, $rhs;
2286 sub i_resp_supplementary_message ($) {
2288 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2291 sub i_resp_complete {
2292 my $pid = $i_child_pid;
2293 $i_child_pid = undef; # prevents killing some other process with same pid
2294 printdebug "waiting for build host child $pid...\n";
2295 my $got = waitpid $pid, 0;
2296 die $! unless $got == $pid;
2297 die "build host child failed $?" if $?;
2300 printdebug "all done\n";
2304 sub i_resp_file ($) {
2306 my $localname = i_method "i_localname", $keyword;
2307 my $localpath = "$i_tmp/$localname";
2308 stat_exists $localpath and
2309 badproto \*RO, "file $keyword ($localpath) twice";
2310 protocol_receive_file \*RO, $localpath;
2311 i_method "i_file", $keyword;
2316 sub i_resp_param ($) {
2317 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2321 sub i_resp_previously ($) {
2322 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2323 or badproto \*RO, "bad previously spec";
2324 my $r = system qw(git check-ref-format), $1;
2325 die "bad previously ref spec ($r)" if $r;
2326 $previously{$1} = $2;
2331 sub i_resp_want ($) {
2333 die "$keyword ?" if $i_wanted{$keyword}++;
2334 my @localpaths = i_method "i_want", $keyword;
2335 printdebug "[[ $keyword @localpaths\n";
2336 foreach my $localpath (@localpaths) {
2337 protocol_send_file \*RI, $localpath;
2339 print RI "files-end\n" or die $!;
2342 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2344 sub i_localname_parsed_changelog {
2345 return "remote-changelog.822";
2347 sub i_file_parsed_changelog {
2348 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2349 push_parse_changelog "$i_tmp/remote-changelog.822";
2350 die if $i_dscfn =~ m#/|^\W#;
2353 sub i_localname_dsc {
2354 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2359 sub i_localname_changes {
2360 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2361 $i_changesfn = $i_dscfn;
2362 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2363 return $i_changesfn;
2365 sub i_file_changes { }
2367 sub i_want_signed_tag {
2368 printdebug Dumper(\%i_param, $i_dscfn);
2369 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2370 && defined $i_param{'csuite'}
2371 or badproto \*RO, "premature desire for signed-tag";
2372 my $head = $i_param{'head'};
2373 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2375 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2377 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2380 push_mktag $head, $i_clogp, $i_tag,
2382 $i_changesfn, 'remote changes',
2383 sub { "tag$_[0]"; };
2388 sub i_want_signed_dsc_changes {
2389 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2390 sign_changes $i_changesfn;
2391 return ($i_dscfn, $i_changesfn);
2394 #---------- building etc. ----------
2400 #----- `3.0 (quilt)' handling -----
2402 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2404 sub quiltify_dpkg_commit ($$$;$) {
2405 my ($patchname,$author,$msg, $xinfo) = @_;
2409 my $descfn = ".git/dgit/quilt-description.tmp";
2410 open O, '>', $descfn or die "$descfn: $!";
2413 $msg =~ s/^\s+$/ ./mg;
2414 print O <<END or die $!;
2424 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2425 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2426 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2427 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2431 sub quiltify_trees_differ ($$) {
2433 # returns 1 iff the two tree objects differ other than in debian/
2435 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2436 my $diffs= cmdoutput @cmd;
2437 foreach my $f (split /\0/, $diffs) {
2438 next if $f eq 'debian';
2444 sub quiltify_tree_sentinelfiles ($) {
2445 # lists the `sentinel' files present in the tree
2447 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2448 qw(-- debian/rules debian/control);
2454 my ($clogp,$target) = @_;
2456 # Quilt patchification algorithm
2458 # We search backwards through the history of the main tree's HEAD
2459 # (T) looking for a start commit S whose tree object is identical
2460 # to to the patch tip tree (ie the tree corresponding to the
2461 # current dpkg-committed patch series). For these purposes
2462 # `identical' disregards anything in debian/ - this wrinkle is
2463 # necessary because dpkg-source treates debian/ specially.
2465 # We can only traverse edges where at most one of the ancestors'
2466 # trees differs (in changes outside in debian/). And we cannot
2467 # handle edges which change .pc/ or debian/patches. To avoid
2468 # going down a rathole we avoid traversing edges which introduce
2469 # debian/rules or debian/control. And we set a limit on the
2470 # number of edges we are willing to look at.
2472 # If we succeed, we walk forwards again. For each traversed edge
2473 # PC (with P parent, C child) (starting with P=S and ending with
2474 # C=T) to we do this:
2476 # - dpkg-source --commit with a patch name and message derived from C
2477 # After traversing PT, we git commit the changes which
2478 # should be contained within debian/patches.
2480 changedir '../fake';
2481 mktree_in_ud_here();
2483 runcmd @git, 'add', '.';
2484 my $oldtiptree=git_write_tree();
2485 changedir '../work';
2487 # The search for the path S..T is breadth-first. We maintain a
2488 # todo list containing search nodes. A search node identifies a
2489 # commit, and looks something like this:
2491 # Commit => $git_commit_id,
2492 # Child => $c, # or undef if P=T
2493 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2494 # Nontrivial => true iff $p..$c has relevant changes
2501 my %considered; # saves being exponential on some weird graphs
2503 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2506 my ($search,$whynot) = @_;
2507 printdebug " search NOT $search->{Commit} $whynot\n";
2508 $search->{Whynot} = $whynot;
2509 push @nots, $search;
2510 no warnings qw(exiting);
2519 my $c = shift @todo;
2520 next if $considered{$c->{Commit}}++;
2522 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2524 printdebug "quiltify investigate $c->{Commit}\n";
2527 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2528 printdebug " search finished hooray!\n";
2533 if ($quilt_mode eq 'nofix') {
2534 fail "quilt fixup required but quilt mode is \`nofix'\n".
2535 "HEAD commit $c->{Commit} differs from tree implied by ".
2536 " debian/patches (tree object $oldtiptree)";
2538 if ($quilt_mode eq 'smash') {
2539 printdebug " search quitting smash\n";
2543 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2544 $not->($c, "has $c_sentinels not $t_sentinels")
2545 if $c_sentinels ne $t_sentinels;
2547 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2548 $commitdata =~ m/\n\n/;
2550 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2551 @parents = map { { Commit => $_, Child => $c } } @parents;
2553 $not->($c, "root commit") if !@parents;
2555 foreach my $p (@parents) {
2556 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2558 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2559 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2561 foreach my $p (@parents) {
2562 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2564 my @cmd= (@git, qw(diff-tree -r --name-only),
2565 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2566 my $patchstackchange = cmdoutput @cmd;
2567 if (length $patchstackchange) {
2568 $patchstackchange =~ s/\n/,/g;
2569 $not->($p, "changed $patchstackchange");
2572 printdebug " search queue P=$p->{Commit} ",
2573 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2579 printdebug "quiltify want to smash\n";
2582 my $x = $_[0]{Commit};
2583 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2586 my $reportnot = sub {
2588 my $s = $abbrev->($notp);
2589 my $c = $notp->{Child};
2590 $s .= "..".$abbrev->($c) if $c;
2591 $s .= ": ".$notp->{Whynot};
2594 if ($quilt_mode eq 'linear') {
2595 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2596 foreach my $notp (@nots) {
2597 print STDERR "$us: ", $reportnot->($notp), "\n";
2599 fail "quilt fixup naive history linearisation failed.\n".
2600 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2601 } elsif ($quilt_mode eq 'smash') {
2602 } elsif ($quilt_mode eq 'auto') {
2603 progress "quilt fixup cannot be linear, smashing...";
2605 die "$quilt_mode ?";
2610 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2612 quiltify_dpkg_commit "auto-$version-$target-$time",
2613 (getfield $clogp, 'Maintainer'),
2614 "Automatically generated patch ($clogp->{Version})\n".
2615 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2619 progress "quiltify linearisation planning successful, executing...";
2621 for (my $p = $sref_S;
2622 my $c = $p->{Child};
2624 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2625 next unless $p->{Nontrivial};
2627 my $cc = $c->{Commit};
2629 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2630 $commitdata =~ m/\n\n/ or die "$c ?";
2633 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2636 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2639 my $patchname = $title;
2640 $patchname =~ s/[.:]$//;
2641 $patchname =~ y/ A-Z/-a-z/;
2642 $patchname =~ y/-a-z0-9_.+=~//cd;
2643 $patchname =~ s/^\W/x-$&/;
2644 $patchname = substr($patchname,0,40);
2647 stat "debian/patches/$patchname$index";
2649 $!==ENOENT or die "$patchname$index $!";
2651 runcmd @git, qw(checkout -q), $cc;
2653 # We use the tip's changelog so that dpkg-source doesn't
2654 # produce complaining messages from dpkg-parsechangelog. None
2655 # of the information dpkg-source gets from the changelog is
2656 # actually relevant - it gets put into the original message
2657 # which dpkg-source provides our stunt editor, and then
2659 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2661 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2662 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2664 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2667 runcmd @git, qw(checkout -q master);
2670 sub build_maybe_quilt_fixup () {
2671 my $format=get_source_format;
2672 return unless madformat $format;
2675 check_for_vendor_patches();
2678 # - honour any existing .pc in case it has any strangeness
2679 # - determine the git commit corresponding to the tip of
2680 # the patch stack (if there is one)
2681 # - if there is such a git commit, convert each subsequent
2682 # git commit into a quilt patch with dpkg-source --commit
2683 # - otherwise convert all the differences in the tree into
2684 # a single git commit
2688 # Our git tree doesn't necessarily contain .pc. (Some versions of
2689 # dgit would include the .pc in the git tree.) If there isn't
2690 # one, we need to generate one by unpacking the patches that we
2693 # We first look for a .pc in the git tree. If there is one, we
2694 # will use it. (This is not the normal case.)
2696 # Otherwise need to regenerate .pc so that dpkg-source --commit
2697 # can work. We do this as follows:
2698 # 1. Collect all relevant .orig from parent directory
2699 # 2. Generate a debian.tar.gz out of
2700 # debian/{patches,rules,source/format}
2701 # 3. Generate a fake .dsc containing just these fields:
2702 # Format Source Version Files
2703 # 4. Extract the fake .dsc
2704 # Now the fake .dsc has a .pc directory.
2705 # (In fact we do this in every case, because in future we will
2706 # want to search for a good base commit for generating patches.)
2708 # Then we can actually do the dpkg-source --commit
2709 # 1. Make a new working tree with the same object
2710 # store as our main tree and check out the main
2712 # 2. Copy .pc from the fake's extraction, if necessary
2713 # 3. Run dpkg-source --commit
2714 # 4. If the result has changes to debian/, then
2715 # - git-add them them
2716 # - git-add .pc if we had a .pc in-tree
2718 # 5. If we had a .pc in-tree, delete it, and git-commit
2719 # 6. Back in the main tree, fast forward to the new HEAD
2721 my $clogp = parsechangelog();
2722 my $headref = git_rev_parse('HEAD');
2727 my $upstreamversion=$version;
2728 $upstreamversion =~ s/-[^-]*$//;
2730 my $fakeversion="$upstreamversion-~~DGITFAKE";
2732 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2733 print $fakedsc <<END or die $!;
2736 Version: $fakeversion
2740 my $dscaddfile=sub {
2743 my $md = new Digest::MD5;
2745 my $fh = new IO::File $b, '<' or die "$b $!";
2750 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2753 foreach my $f (<../../../../*>) { #/){
2754 my $b=$f; $b =~ s{.*/}{};
2755 next unless is_orig_file $b, srcfn $upstreamversion,'';
2756 link $f, $b or die "$b $!";
2760 my @files=qw(debian/source/format debian/rules);
2761 if (stat_exists '../../../debian/patches') {
2762 push @files, 'debian/patches';
2765 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2766 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2768 $dscaddfile->($debtar);
2769 close $fakedsc or die $!;
2771 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2773 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2774 rename $fakexdir, "fake" or die "$fakexdir $!";
2776 mkdir "work" or die $!;
2778 mktree_in_ud_here();
2779 runcmd @git, qw(reset --hard), $headref;
2782 if (stat_exists ".pc") {
2784 progress "Tree already contains .pc - will use it then delete it.";
2787 rename '../fake/.pc','.pc' or die $!;
2790 quiltify($clogp,$headref);
2792 if (!open P, '>>', ".pc/applied-patches") {
2793 $!==&ENOENT or die $!;
2798 commit_quilty_patch();
2800 if ($mustdeletepc) {
2801 runcmd @git, qw(rm -rqf .pc);
2802 commit_admin "Commit removal of .pc (quilt series tracking data)";
2805 changedir '../../../..';
2806 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2809 sub quilt_fixup_editor () {
2810 my $descfn = $ENV{$fakeeditorenv};
2811 my $editing = $ARGV[$#ARGV];
2812 open I1, '<', $descfn or die "$descfn: $!";
2813 open I2, '<', $editing or die "$editing: $!";
2814 unlink $editing or die "$editing: $!";
2815 open O, '>', $editing or die "$editing: $!";
2816 while (<I1>) { print O or die $!; } I1->error and die $!;
2819 $copying ||= m/^\-\-\- /;
2820 next unless $copying;
2823 I2->error and die $!;
2828 #----- other building -----
2831 if ($cleanmode eq 'dpkg-source') {
2832 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2833 } elsif ($cleanmode eq 'dpkg-source-d') {
2834 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2835 } elsif ($cleanmode eq 'git') {
2836 runcmd_ordryrun_local @git, qw(clean -xdf);
2837 } elsif ($cleanmode eq 'git-ff') {
2838 runcmd_ordryrun_local @git, qw(clean -xdff);
2839 } elsif ($cleanmode eq 'check') {
2840 my $leftovers = cmdoutput @git, qw(clean -xdn);
2841 if (length $leftovers) {
2842 print STDERR $leftovers, "\n" or die $!;
2843 fail "tree contains uncommitted files and --clean=check specified";
2845 } elsif ($cleanmode eq 'none') {
2852 badusage "clean takes no additional arguments" if @ARGV;
2859 badusage "-p is not allowed when building" if defined $package;
2862 my $clogp = parsechangelog();
2863 $isuite = getfield $clogp, 'Distribution';
2864 $package = getfield $clogp, 'Source';
2865 $version = getfield $clogp, 'Version';
2866 build_maybe_quilt_fixup();
2869 sub changesopts () {
2870 my @opts =@changesopts[1..$#changesopts];
2871 if (!defined $changes_since_version) {
2872 my @vsns = archive_query('archive_query');
2873 my @quirk = access_quirk();
2874 if ($quirk[0] eq 'backports') {
2875 local $isuite = $quirk[2];
2877 canonicalise_suite();
2878 push @vsns, archive_query('archive_query');
2881 @vsns = map { $_->[0] } @vsns;
2882 @vsns = sort { -version_compare($a, $b) } @vsns;
2883 $changes_since_version = $vsns[0];
2884 progress "changelog will contain changes since $vsns[0]";
2886 $changes_since_version = '_';
2887 progress "package seems new, not specifying -v<version>";
2890 if ($changes_since_version ne '_') {
2891 unshift @opts, "-v$changes_since_version";
2896 sub massage_dbp_args ($) {
2898 return unless $cleanmode =~ m/git|none/;
2899 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2900 my @newcmd = shift @$cmd;
2901 # -nc has the side effect of specifying -b if nothing else specified
2902 push @newcmd, '-nc';
2903 # and some combinations of -S, -b, et al, are errors, rather than
2904 # later simply overriding earlier
2905 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2906 push @newcmd, @$cmd;
2912 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2913 massage_dbp_args \@dbp;
2914 runcmd_ordryrun_local @dbp;
2915 printdone "build successful\n";
2920 my @dbp = @dpkgbuildpackage;
2921 massage_dbp_args \@dbp;
2923 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2924 "--git-builder=@dbp");
2925 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2926 canonicalise_suite();
2927 push @cmd, "--git-debian-branch=".lbranch();
2929 push @cmd, changesopts();
2930 runcmd_ordryrun_local @cmd, @ARGV;
2931 printdone "build successful\n";
2936 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2937 $dscfn = dscfn($version);
2938 if ($cleanmode eq 'dpkg-source') {
2939 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2941 } elsif ($cleanmode eq 'dpkg-source-d') {
2942 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2945 my $pwd = must_getcwd();
2946 my $leafdir = basename $pwd;
2948 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2950 runcmd_ordryrun_local qw(sh -ec),
2951 'exec >$1; shift; exec "$@"','x',
2952 "../$sourcechanges",
2953 @dpkggenchanges, qw(-S), changesopts();
2957 sub cmd_build_source {
2958 badusage "build-source takes no additional arguments" if @ARGV;
2960 printdone "source built, results in $dscfn and $sourcechanges";
2966 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2968 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2969 stat_exists $sourcechanges
2970 or fail "$sourcechanges (in parent directory): $!";
2971 foreach my $cf (glob $pat) {
2972 next if $cf eq $sourcechanges;
2973 unlink $cf or fail "remove $cf: $!";
2976 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2977 my @changesfiles = glob $pat;
2978 @changesfiles = sort {
2979 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2982 fail "wrong number of different changes files (@changesfiles)"
2983 unless @changesfiles;
2984 runcmd_ordryrun_local @mergechanges, @changesfiles;
2985 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2987 stat_exists $multichanges or fail "$multichanges: $!";
2989 printdone "build successful, results in $multichanges\n" or die $!;
2992 sub cmd_quilt_fixup {
2993 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2994 my $clogp = parsechangelog();
2995 $version = getfield $clogp, 'Version';
2996 $package = getfield $clogp, 'Source';
2997 build_maybe_quilt_fixup();
3000 sub cmd_archive_api_query {
3001 badusage "need only 1 subpath argument" unless @ARGV==1;
3002 my ($subpath) = @ARGV;
3003 my @cmd = archive_api_query_cmd($subpath);
3005 exec @cmd or fail "exec curl: $!\n";
3008 sub cmd_clone_dgit_repos_server {
3009 badusage "need destination argument" unless @ARGV==1;
3010 my ($destdir) = @ARGV;
3011 $package = '_dgit-repos-server';
3012 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3014 exec @cmd or fail "exec git clone: $!\n";
3017 sub cmd_setup_mergechangelogs {
3018 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3019 setup_mergechangelogs();
3022 #---------- argument parsing and main program ----------
3025 print "dgit version $our_version\n" or die $!;
3032 if (defined $ENV{'DGIT_SSH'}) {
3033 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3034 } elsif (defined $ENV{'GIT_SSH'}) {
3035 @ssh = ($ENV{'GIT_SSH'});
3039 last unless $ARGV[0] =~ m/^-/;
3043 if (m/^--dry-run$/) {
3046 } elsif (m/^--damp-run$/) {
3049 } elsif (m/^--no-sign$/) {
3052 } elsif (m/^--help$/) {
3054 } elsif (m/^--version$/) {
3056 } elsif (m/^--new$/) {
3059 } elsif (m/^--since-version=([^_]+|_)$/) {
3061 $changes_since_version = $1;
3062 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3063 ($om = $opts_opt_map{$1}) &&
3067 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3068 !$opts_opt_cmdonly{$1} &&
3069 ($om = $opts_opt_map{$1})) {
3072 } elsif (m/^--existing-package=(.*)/s) {
3074 $existing_package = $1;
3075 } elsif (m/^--initiator-tempdir=(.*)/s) {
3076 $initiator_tempdir = $1;
3077 $initiator_tempdir =~ m#^/# or
3078 badusage "--initiator-tempdir must be used specify an".
3079 " absolute, not relative, directory."
3080 } elsif (m/^--distro=(.*)/s) {
3083 } elsif (m/^--build-products-dir=(.*)/s) {
3085 $buildproductsdir = $1;
3086 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3089 } elsif (m/^--clean=(.*)$/s) {
3090 badusage "unknown cleaning mode \`$1'";
3091 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3094 } elsif (m/^--quilt=(.*)$/s) {
3095 badusage "unknown quilt fixup mode \`$1'";
3096 } elsif (m/^--ignore-dirty$/s) {
3099 } elsif (m/^--no-quilt-fixup$/s) {
3101 $quilt_mode = 'nocheck';
3102 } elsif (m/^--no-rm-on-error$/s) {
3105 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3107 push @deliberatelies, $&;
3109 badusage "unknown long option \`$_'";
3116 } elsif (s/^-L/-/) {
3119 } elsif (s/^-h/-/) {
3121 } elsif (s/^-D/-/) {
3125 } elsif (s/^-N/-/) {
3128 } elsif (s/^-v([^_]+|_)$//s) {
3130 $changes_since_version = $1;
3133 push @changesopts, $_;
3135 } elsif (s/^-c(.*=.*)//s) {
3137 push @git, '-c', $1;
3138 } elsif (s/^-d(.+)//s) {
3141 } elsif (s/^-C(.+)//s) {
3144 if ($changesfile =~ s#^(.*)/##) {
3145 $buildproductsdir = $1;
3147 } elsif (s/^-k(.+)//s) {
3149 } elsif (m/^-[vdCk]$/) {
3151 "option \`$_' requires an argument (and no space before the argument)";
3152 } elsif (s/^-wn$//s) {
3154 $cleanmode = 'none';
3155 } elsif (s/^-wg$//s) {
3158 } elsif (s/^-wgf$//s) {
3160 $cleanmode = 'git-ff';
3161 } elsif (s/^-wd$//s) {
3163 $cleanmode = 'dpkg-source';
3164 } elsif (s/^-wdd$//s) {
3166 $cleanmode = 'dpkg-source-d';
3167 } elsif (s/^-wc$//s) {
3169 $cleanmode = 'check';
3171 badusage "unknown short option \`$_'";
3178 sub finalise_opts_opts () {
3179 foreach my $k (keys %opts_opt_map) {
3180 my $om = $opts_opt_map{$k};
3182 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3184 badcfg "cannot set command for $k"
3185 unless length $om->[0];
3189 foreach my $c (access_cfg_cfgs("opts-$k")) {
3190 my $vl = $gitcfg{$c};
3191 printdebug "CL $c ",
3192 ($vl ? join " ", map { shellquote } @$vl : ""),
3193 "\n" if $debuglevel >= 4;
3195 badcfg "cannot configure options for $k"
3196 if $opts_opt_cmdonly{$k};
3197 my $insertpos = $opts_cfg_insertpos{$k};
3198 @$om = ( @$om[0..$insertpos-1],
3200 @$om[$insertpos..$#$om] );
3205 if ($ENV{$fakeeditorenv}) {
3207 quilt_fixup_editor();
3213 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3214 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3215 if $dryrun_level == 1;
3217 print STDERR $helpmsg or die $!;
3220 my $cmd = shift @ARGV;
3223 if (!defined $quilt_mode) {
3224 local $access_forpush;
3225 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3226 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3228 $quilt_mode =~ m/^($quilt_modes_re)$/
3229 or badcfg "unknown quilt-mode \`$quilt_mode'";
3233 my $fn = ${*::}{"cmd_$cmd"};
3234 $fn or badusage "unknown operation $cmd";