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_opt_cmdline_opts;
102 sub finalise_opts_opts();
108 our $supplementary_message = '';
112 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
115 our $remotename = 'dgit';
116 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
120 sub lbranch () { return "$branchprefix/$csuite"; }
121 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
122 sub lref () { return "refs/heads/".lbranch(); }
123 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
124 sub rrref () { return server_ref($csuite); }
126 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
136 return "${package}_".(stripepoch $vsn).$sfx
141 return srcfn($vsn,".dsc");
150 foreach my $f (@end) {
152 warn "$us: cleanup: $@" if length $@;
156 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
158 sub no_such_package () {
159 print STDERR "$us: package $package does not exist in suite $isuite\n";
165 return "+".rrref().":".lrref();
170 printdebug "CD $newdir\n";
171 chdir $newdir or die "chdir: $newdir: $!";
174 sub deliberately ($) {
176 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
179 sub deliberately_not_fast_forward () {
180 foreach (qw(not-fast-forward fresh-repo)) {
181 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
185 #---------- remote protocol support, common ----------
187 # remote push initiator/responder protocol:
188 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
189 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
190 # < dgit-remote-push-ready <actual-proto-vsn>
192 # > file parsed-changelog
193 # [indicates that output of dpkg-parsechangelog follows]
194 # > data-block NBYTES
195 # > [NBYTES bytes of data (no newline)]
196 # [maybe some more blocks]
208 # [indicates that signed tag is wanted]
209 # < data-block NBYTES
210 # < [NBYTES bytes of data (no newline)]
211 # [maybe some more blocks]
215 # > want signed-dsc-changes
216 # < data-block NBYTES [transfer of signed dsc]
218 # < data-block NBYTES [transfer of signed changes]
226 sub i_child_report () {
227 # Sees if our child has died, and reap it if so. Returns a string
228 # describing how it died if it failed, or undef otherwise.
229 return undef unless $i_child_pid;
230 my $got = waitpid $i_child_pid, WNOHANG;
231 return undef if $got <= 0;
232 die unless $got == $i_child_pid;
233 $i_child_pid = undef;
234 return undef unless $?;
235 return "build host child ".waitstatusmsg();
240 fail "connection lost: $!" if $fh->error;
241 fail "protocol violation; $m not expected";
244 sub badproto_badread ($$) {
246 fail "connection lost: $!" if $!;
247 my $report = i_child_report();
248 fail $report if defined $report;
249 badproto $fh, "eof (reading $wh)";
252 sub protocol_expect (&$) {
253 my ($match, $fh) = @_;
256 defined && chomp or badproto_badread $fh, "protocol message";
264 badproto $fh, "\`$_'";
267 sub protocol_send_file ($$) {
268 my ($fh, $ourfn) = @_;
269 open PF, "<", $ourfn or die "$ourfn: $!";
272 my $got = read PF, $d, 65536;
273 die "$ourfn: $!" unless defined $got;
275 print $fh "data-block ".length($d)."\n" or die $!;
276 print $fh $d or die $!;
278 PF->error and die "$ourfn $!";
279 print $fh "data-end\n" or die $!;
283 sub protocol_read_bytes ($$) {
284 my ($fh, $nbytes) = @_;
285 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
287 my $got = read $fh, $d, $nbytes;
288 $got==$nbytes or badproto_badread $fh, "data block";
292 sub protocol_receive_file ($$) {
293 my ($fh, $ourfn) = @_;
294 printdebug "() $ourfn\n";
295 open PF, ">", $ourfn or die "$ourfn: $!";
297 my ($y,$l) = protocol_expect {
298 m/^data-block (.*)$/ ? (1,$1) :
299 m/^data-end$/ ? (0,) :
303 my $d = protocol_read_bytes $fh, $l;
304 print PF $d or die $!;
309 #---------- remote protocol support, responder ----------
311 sub responder_send_command ($) {
313 return unless $we_are_responder;
314 # called even without $we_are_responder
315 printdebug ">> $command\n";
316 print PO $command, "\n" or die $!;
319 sub responder_send_file ($$) {
320 my ($keyword, $ourfn) = @_;
321 return unless $we_are_responder;
322 printdebug "]] $keyword $ourfn\n";
323 responder_send_command "file $keyword";
324 protocol_send_file \*PO, $ourfn;
327 sub responder_receive_files ($@) {
328 my ($keyword, @ourfns) = @_;
329 die unless $we_are_responder;
330 printdebug "[[ $keyword @ourfns\n";
331 responder_send_command "want $keyword";
332 foreach my $fn (@ourfns) {
333 protocol_receive_file \*PI, $fn;
336 protocol_expect { m/^files-end$/ } \*PI;
339 #---------- remote protocol support, initiator ----------
341 sub initiator_expect (&) {
343 protocol_expect { &$match } \*RO;
346 #---------- end remote code ----------
349 if ($we_are_responder) {
351 responder_send_command "progress ".length($m) or die $!;
352 print PO $m or die $!;
362 $ua = LWP::UserAgent->new();
366 progress "downloading $what...";
367 my $r = $ua->get(@_) or die $!;
368 return undef if $r->code == 404;
369 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
370 return $r->decoded_content(charset => 'none');
373 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
378 failedcmd @_ if system @_;
381 sub act_local () { return $dryrun_level <= 1; }
382 sub act_scary () { return !$dryrun_level; }
385 if (!$dryrun_level) {
386 progress "dgit ok: @_";
388 progress "would be ok: @_ (but dry run only)";
393 printcmd(\*STDERR,$debugprefix."#",@_);
396 sub runcmd_ordryrun {
404 sub runcmd_ordryrun_local {
413 my ($first_shell, @cmd) = @_;
414 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
417 our $helpmsg = <<END;
419 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
420 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
421 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
422 dgit [dgit-opts] push [dgit-opts] [suite]
423 dgit [dgit-opts] rpush build-host:build-dir ...
424 important dgit options:
425 -k<keyid> sign tag and package with <keyid> instead of default
426 --dry-run -n do not change anything, but go through the motions
427 --damp-run -L like --dry-run but make local changes, without signing
428 --new -N allow introducing a new package
429 --debug -D increase debug level
430 -c<name>=<value> set git config option (used directly by dgit too)
433 our $later_warning_msg = <<END;
434 Perhaps the upload is stuck in incoming. Using the version from git.
438 print STDERR "$us: @_\n", $helpmsg or die $!;
443 @ARGV or badusage "too few arguments";
444 return scalar shift @ARGV;
448 print $helpmsg or die $!;
452 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
454 our %defcfg = ('dgit.default.distro' => 'debian',
455 'dgit.default.username' => '',
456 'dgit.default.archive-query-default-component' => 'main',
457 'dgit.default.ssh' => 'ssh',
458 'dgit.default.archive-query' => 'madison:',
459 'dgit.default.sshpsql-dbname' => 'service=projectb',
460 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
461 'dgit-distro.debian.git-check' => 'url',
462 'dgit-distro.debian.git-check-suffix' => '/info/refs',
463 'dgit-distro.debian.new-private-pushers' => 't',
464 'dgit-distro.debian/push.git-url' => '',
465 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
466 'dgit-distro.debian/push.git-user-force' => 'dgit',
467 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
468 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
469 'dgit-distro.debian/push.git-create' => 'true',
470 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
471 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
472 # 'dgit-distro.debian.archive-query-tls-key',
473 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
474 # ^ this does not work because curl is broken nowadays
475 # Fixing #790093 properly will involve providing providing the key
476 # in some pacagke and maybe updating these paths.
478 # 'dgit-distro.debian.archive-query-tls-curl-args',
479 # '--ca-path=/etc/ssl/ca-debian',
480 # ^ this is a workaround but works (only) on DSA-administered machines
481 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
482 'dgit-distro.debian.git-url-suffix' => '',
483 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
484 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
485 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
486 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
487 'dgit-distro.ubuntu.git-check' => 'false',
488 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
489 'dgit-distro.test-dummy.ssh' => "$td/ssh",
490 'dgit-distro.test-dummy.username' => "alice",
491 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
492 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
493 'dgit-distro.test-dummy.git-url' => "$td/git",
494 'dgit-distro.test-dummy.git-host' => "git",
495 'dgit-distro.test-dummy.git-path' => "$td/git",
496 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
497 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
498 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
499 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
502 sub git_get_config ($) {
505 our %git_get_config_memo;
506 if (exists $git_get_config_memo{$c}) {
507 return $git_get_config_memo{$c};
511 my @cmd = (@git, qw(config --), $c);
513 local ($debuglevel) = $debuglevel-2;
514 $v = cmdoutput_errok @cmd;
522 $git_get_config_memo{$c} = $v;
528 return undef if $c =~ /RETURN-UNDEF/;
529 my $v = git_get_config($c);
530 return $v if defined $v;
531 my $dv = $defcfg{$c};
532 return $dv if defined $dv;
534 badcfg "need value for one of: @_\n".
535 "$us: distro or suite appears not to be (properly) supported";
538 sub access_basedistro () {
539 if (defined $idistro) {
542 return cfg("dgit-suite.$isuite.distro",
543 "dgit.default.distro");
547 sub access_quirk () {
548 # returns (quirk name, distro to use instead or undef, quirk-specific info)
549 my $basedistro = access_basedistro();
550 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
552 if (defined $backports_quirk) {
553 my $re = $backports_quirk;
554 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
556 $re =~ s/\%/([-0-9a-z_]+)/
557 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
558 if ($isuite =~ m/^$re$/) {
559 return ('backports',"$basedistro-backports",$1);
562 return ('none',undef);
567 sub parse_cfg_bool ($$$) {
568 my ($what,$def,$v) = @_;
571 $v =~ m/^[ty1]/ ? 1 :
572 $v =~ m/^[fn0]/ ? 0 :
573 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
576 sub access_forpush_config () {
577 my $d = access_basedistro();
581 parse_cfg_bool('new-private-pushers', 0,
582 cfg("dgit-distro.$d.new-private-pushers",
585 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
588 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
589 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
590 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
591 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
594 sub access_forpush () {
595 $access_forpush //= access_forpush_config();
596 return $access_forpush;
600 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
601 badcfg "pushing but distro is configured readonly"
602 if access_forpush_config() eq '0';
604 $supplementary_message = <<'END' unless $we_are_responder;
605 Push failed, before we got started.
606 You can retry the push, after fixing the problem, if you like.
608 finalise_opts_opts();
612 finalise_opts_opts();
615 sub supplementary_message ($) {
617 if (!$we_are_responder) {
618 $supplementary_message = $msg;
620 } elsif ($protovsn >= 3) {
621 responder_send_command "supplementary-message ".length($msg)
623 print PO $msg or die $!;
627 sub access_distros () {
628 # Returns list of distros to try, in order
631 # 0. `instead of' distro name(s) we have been pointed to
632 # 1. the access_quirk distro, if any
633 # 2a. the user's specified distro, or failing that } basedistro
634 # 2b. the distro calculated from the suite }
635 my @l = access_basedistro();
637 my (undef,$quirkdistro) = access_quirk();
638 unshift @l, $quirkdistro;
639 unshift @l, $instead_distro;
640 @l = grep { defined } @l;
642 if (access_forpush()) {
643 @l = map { ("$_/push", $_) } @l;
648 sub access_cfg_cfgs (@) {
651 # The nesting of these loops determines the search order. We put
652 # the key loop on the outside so that we search all the distros
653 # for each key, before going on to the next key. That means that
654 # if access_cfg is called with a more specific, and then a less
655 # specific, key, an earlier distro can override the less specific
656 # without necessarily overriding any more specific keys. (If the
657 # distro wants to override the more specific keys it can simply do
658 # so; whereas if we did the loop the other way around, it would be
659 # impossible to for an earlier distro to override a less specific
660 # key but not the more specific ones without restating the unknown
661 # values of the more specific keys.
664 # We have to deal with RETURN-UNDEF specially, so that we don't
665 # terminate the search prematurely.
667 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
670 foreach my $d (access_distros()) {
671 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
673 push @cfgs, map { "dgit.default.$_" } @realkeys;
680 my (@cfgs) = access_cfg_cfgs(@keys);
681 my $value = cfg(@cfgs);
685 sub string_to_ssh ($) {
687 if ($spec =~ m/\s/) {
688 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
694 sub access_cfg_ssh () {
695 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
696 if (!defined $gitssh) {
699 return string_to_ssh $gitssh;
703 sub access_runeinfo ($) {
705 return ": dgit ".access_basedistro()." $info ;";
708 sub access_someuserhost ($) {
710 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
711 defined($user) && length($user) or
712 $user = access_cfg("$some-user",'username');
713 my $host = access_cfg("$some-host");
714 return length($user) ? "$user\@$host" : $host;
717 sub access_gituserhost () {
718 return access_someuserhost('git');
721 sub access_giturl (;$) {
723 my $url = access_cfg('git-url','RETURN-UNDEF');
726 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
727 return undef unless defined $proto;
730 access_gituserhost().
731 access_cfg('git-path');
733 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
736 return "$url/$package$suffix";
739 sub parsecontrolfh ($$;$) {
740 my ($fh, $desc, $allowsigned) = @_;
741 our $dpkgcontrolhash_noissigned;
744 my %opts = ('name' => $desc);
745 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
746 $c = Dpkg::Control::Hash->new(%opts);
747 $c->parse($fh,$desc) or die "parsing of $desc failed";
748 last if $allowsigned;
749 last if $dpkgcontrolhash_noissigned;
750 my $issigned= $c->get_option('is_pgp_signed');
751 if (!defined $issigned) {
752 $dpkgcontrolhash_noissigned= 1;
753 seek $fh, 0,0 or die "seek $desc: $!";
754 } elsif ($issigned) {
755 fail "control file $desc is (already) PGP-signed. ".
756 " Note that dgit push needs to modify the .dsc and then".
757 " do the signature itself";
766 my ($file, $desc) = @_;
767 my $fh = new IO::Handle;
768 open $fh, '<', $file or die "$file: $!";
769 my $c = parsecontrolfh($fh,$desc);
770 $fh->error and die $!;
776 my ($dctrl,$field) = @_;
777 my $v = $dctrl->{$field};
778 return $v if defined $v;
779 fail "missing field $field in ".$v->get_option('name');
783 my $c = Dpkg::Control::Hash->new();
784 my $p = new IO::Handle;
785 my @cmd = (qw(dpkg-parsechangelog), @_);
786 open $p, '-|', @cmd or die $!;
788 $?=0; $!=0; close $p or failedcmd @cmd;
794 defined $d or fail "getcwd failed: $!";
800 sub archive_query ($) {
802 my $query = access_cfg('archive-query','RETURN-UNDEF');
803 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
806 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
809 sub pool_dsc_subpath ($$) {
810 my ($vsn,$component) = @_; # $package is implict arg
811 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
812 return "/pool/$component/$prefix/$package/".dscfn($vsn);
815 #---------- `ftpmasterapi' archive query method (nascent) ----------
817 sub archive_api_query_cmd ($) {
819 my @cmd = qw(curl -sS);
820 my $url = access_cfg('archive-query-url');
821 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
823 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
824 foreach my $key (split /\:/, $keys) {
825 $key =~ s/\%HOST\%/$host/g;
827 fail "for $url: stat $key: $!" unless $!==ENOENT;
830 fail "config requested specific TLS key but do not know".
831 " how to get curl to use exactly that EE key ($key)";
832 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
833 # # Sadly the above line does not work because of changes
834 # # to gnutls. The real fix for #790093 may involve
835 # # new curl options.
838 # Fixing #790093 properly will involve providing a value
839 # for this on clients.
840 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
841 push @cmd, split / /, $kargs if defined $kargs;
843 push @cmd, $url.$subpath;
849 my ($data, $subpath) = @_;
850 badcfg "ftpmasterapi archive query method takes no data part"
852 my @cmd = archive_api_query_cmd($subpath);
853 my $json = cmdoutput @cmd;
854 return decode_json($json);
857 sub canonicalise_suite_ftpmasterapi () {
858 my ($proto,$data) = @_;
859 my $suites = api_query($data, 'suites');
861 foreach my $entry (@$suites) {
863 my $v = $entry->{$_};
864 defined $v && $v eq $isuite;
866 push @matched, $entry;
868 fail "unknown suite $isuite" unless @matched;
871 @matched==1 or die "multiple matches for suite $isuite\n";
872 $cn = "$matched[0]{codename}";
873 defined $cn or die "suite $isuite info has no codename\n";
874 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
876 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
881 sub archive_query_ftpmasterapi () {
882 my ($proto,$data) = @_;
883 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
885 my $digester = Digest::SHA->new(256);
886 foreach my $entry (@$info) {
888 my $vsn = "$entry->{version}";
889 my ($ok,$msg) = version_check $vsn;
890 die "bad version: $msg\n" unless $ok;
891 my $component = "$entry->{component}";
892 $component =~ m/^$component_re$/ or die "bad component";
893 my $filename = "$entry->{filename}";
894 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
895 or die "bad filename";
896 my $sha256sum = "$entry->{sha256sum}";
897 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
898 push @rows, [ $vsn, "/pool/$component/$filename",
899 $digester, $sha256sum ];
901 die "bad ftpmaster api response: $@\n".Dumper($entry)
904 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
908 #---------- `madison' archive query method ----------
910 sub archive_query_madison {
911 return map { [ @$_[0..1] ] } madison_get_parse(@_);
914 sub madison_get_parse {
915 my ($proto,$data) = @_;
916 die unless $proto eq 'madison';
918 $data= access_cfg('madison-distro','RETURN-UNDEF');
919 $data //= access_basedistro();
921 $rmad{$proto,$data,$package} ||= cmdoutput
922 qw(rmadison -asource),"-s$isuite","-u$data",$package;
923 my $rmad = $rmad{$proto,$data,$package};
926 foreach my $l (split /\n/, $rmad) {
927 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
928 \s*( [^ \t|]+ )\s* \|
929 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
930 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
931 $1 eq $package or die "$rmad $package ?";
938 $component = access_cfg('archive-query-default-component');
940 $5 eq 'source' or die "$rmad ?";
941 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
943 return sort { -version_compare($a->[0],$b->[0]); } @out;
946 sub canonicalise_suite_madison {
947 # madison canonicalises for us
948 my @r = madison_get_parse(@_);
950 "unable to canonicalise suite using package $package".
951 " which does not appear to exist in suite $isuite;".
952 " --existing-package may help";
956 #---------- `sshpsql' archive query method ----------
959 my ($data,$runeinfo,$sql) = @_;
961 $data= access_someuserhost('sshpsql').':'.
962 access_cfg('sshpsql-dbname');
964 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
965 my ($userhost,$dbname) = ($`,$'); #';
967 my @cmd = (access_cfg_ssh, $userhost,
968 access_runeinfo("ssh-psql $runeinfo").
969 " export LC_MESSAGES=C; export LC_CTYPE=C;".
970 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
972 open P, "-|", @cmd or die $!;
975 printdebug("$debugprefix>|$_|\n");
978 $!=0; $?=0; close P or failedcmd @cmd;
980 my $nrows = pop @rows;
981 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
982 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
983 @rows = map { [ split /\|/, $_ ] } @rows;
984 my $ncols = scalar @{ shift @rows };
985 die if grep { scalar @$_ != $ncols } @rows;
989 sub sql_injection_check {
990 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
993 sub archive_query_sshpsql ($$) {
994 my ($proto,$data) = @_;
995 sql_injection_check $isuite, $package;
996 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
997 SELECT source.version, component.name, files.filename, files.sha256sum
999 JOIN src_associations ON source.id = src_associations.source
1000 JOIN suite ON suite.id = src_associations.suite
1001 JOIN dsc_files ON dsc_files.source = source.id
1002 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1003 JOIN component ON component.id = files_archive_map.component_id
1004 JOIN files ON files.id = dsc_files.file
1005 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1006 AND source.source='$package'
1007 AND files.filename LIKE '%.dsc';
1009 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1010 my $digester = Digest::SHA->new(256);
1012 my ($vsn,$component,$filename,$sha256sum) = @$_;
1013 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1018 sub canonicalise_suite_sshpsql ($$) {
1019 my ($proto,$data) = @_;
1020 sql_injection_check $isuite;
1021 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1022 SELECT suite.codename
1023 FROM suite where suite_name='$isuite' or codename='$isuite';
1025 @rows = map { $_->[0] } @rows;
1026 fail "unknown suite $isuite" unless @rows;
1027 die "ambiguous $isuite: @rows ?" if @rows>1;
1031 #---------- `dummycat' archive query method ----------
1033 sub canonicalise_suite_dummycat ($$) {
1034 my ($proto,$data) = @_;
1035 my $dpath = "$data/suite.$isuite";
1036 if (!open C, "<", $dpath) {
1037 $!==ENOENT or die "$dpath: $!";
1038 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1042 chomp or die "$dpath: $!";
1044 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1048 sub archive_query_dummycat ($$) {
1049 my ($proto,$data) = @_;
1050 canonicalise_suite();
1051 my $dpath = "$data/package.$csuite.$package";
1052 if (!open C, "<", $dpath) {
1053 $!==ENOENT or die "$dpath: $!";
1054 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1062 printdebug "dummycat query $csuite $package $dpath | $_\n";
1063 my @row = split /\s+/, $_;
1064 @row==2 or die "$dpath: $_ ?";
1067 C->error and die "$dpath: $!";
1069 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1072 #---------- archive query entrypoints and rest of program ----------
1074 sub canonicalise_suite () {
1075 return if defined $csuite;
1076 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1077 $csuite = archive_query('canonicalise_suite');
1078 if ($isuite ne $csuite) {
1079 progress "canonical suite name for $isuite is $csuite";
1083 sub get_archive_dsc () {
1084 canonicalise_suite();
1085 my @vsns = archive_query('archive_query');
1086 foreach my $vinfo (@vsns) {
1087 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1088 $dscurl = access_cfg('mirror').$subpath;
1089 $dscdata = url_get($dscurl);
1091 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1096 $digester->add($dscdata);
1097 my $got = $digester->hexdigest();
1099 fail "$dscurl has hash $got but".
1100 " archive told us to expect $digest";
1102 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1103 printdebug Dumper($dscdata) if $debuglevel>1;
1104 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1105 printdebug Dumper($dsc) if $debuglevel>1;
1106 my $fmt = getfield $dsc, 'Format';
1107 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1108 $dsc_checked = !!$digester;
1114 sub check_for_git ();
1115 sub check_for_git () {
1117 my $how = access_cfg('git-check');
1118 if ($how eq 'ssh-cmd') {
1120 (access_cfg_ssh, access_gituserhost(),
1121 access_runeinfo("git-check $package").
1122 " set -e; cd ".access_cfg('git-path').";".
1123 " if test -d $package.git; then echo 1; else echo 0; fi");
1124 my $r= cmdoutput @cmd;
1125 if ($r =~ m/^divert (\w+)$/) {
1127 my ($usedistro,) = access_distros();
1128 # NB that if we are pushing, $usedistro will be $distro/push
1129 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1130 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1131 progress "diverting to $divert (using config for $instead_distro)";
1132 return check_for_git();
1134 failedcmd @cmd unless $r =~ m/^[01]$/;
1136 } elsif ($how eq 'url') {
1137 my $prefix = access_cfg('git-check-url','git-url');
1138 my $suffix = access_cfg('git-check-suffix','git-suffix',
1139 'RETURN-UNDEF') // '.git';
1140 my $url = "$prefix/$package$suffix";
1141 my @cmd = (qw(curl -sS -I), $url);
1142 my $result = cmdoutput @cmd;
1143 $result =~ m/^\S+ (404|200) /s or
1144 fail "unexpected results from git check query - ".
1145 Dumper($prefix, $result);
1147 if ($code eq '404') {
1149 } elsif ($code eq '200') {
1154 } elsif ($how eq 'true') {
1156 } elsif ($how eq 'false') {
1159 badcfg "unknown git-check \`$how'";
1163 sub create_remote_git_repo () {
1164 my $how = access_cfg('git-create');
1165 if ($how eq 'ssh-cmd') {
1167 (access_cfg_ssh, access_gituserhost(),
1168 access_runeinfo("git-create $package").
1169 "set -e; cd ".access_cfg('git-path').";".
1170 " cp -a _template $package.git");
1171 } elsif ($how eq 'true') {
1174 badcfg "unknown git-create \`$how'";
1178 our ($dsc_hash,$lastpush_hash);
1180 our $ud = '.git/dgit/unpack';
1185 mkdir $ud or die $!;
1188 sub mktree_in_ud_here () {
1189 runcmd qw(git init -q);
1190 rmtree('.git/objects');
1191 symlink '../../../../objects','.git/objects' or die $!;
1194 sub git_write_tree () {
1195 my $tree = cmdoutput @git, qw(write-tree);
1196 $tree =~ m/^\w+$/ or die "$tree ?";
1200 sub mktree_in_ud_from_only_subdir () {
1201 # changes into the subdir
1203 die unless @dirs==1;
1204 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1208 my @gitscmd = qw(find -name .git -prune -print0);
1209 debugcmd "|",@gitscmd;
1210 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1215 print STDERR "$us: warning: removing from source package: ",
1216 (messagequote $_), "\n";
1220 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1222 mktree_in_ud_here();
1223 my $format=get_source_format();
1224 if (madformat($format)) {
1227 runcmd @git, qw(add -Af);
1228 my $tree=git_write_tree();
1229 return ($tree,$dir);
1232 sub dsc_files_info () {
1233 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1234 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1235 ['Files', 'Digest::MD5', 'new()']) {
1236 my ($fname, $module, $method) = @$csumi;
1237 my $field = $dsc->{$fname};
1238 next unless defined $field;
1239 eval "use $module; 1;" or die $@;
1241 foreach (split /\n/, $field) {
1243 m/^(\w+) (\d+) (\S+)$/ or
1244 fail "could not parse .dsc $fname line \`$_'";
1245 my $digester = eval "$module"."->$method;" or die $@;
1250 Digester => $digester,
1255 fail "missing any supported Checksums-* or Files field in ".
1256 $dsc->get_option('name');
1260 map { $_->{Filename} } dsc_files_info();
1263 sub is_orig_file ($;$) {
1266 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1267 defined $base or return 1;
1271 sub make_commit ($) {
1273 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1276 sub clogp_authline ($) {
1278 my $author = getfield $clogp, 'Maintainer';
1279 $author =~ s#,.*##ms;
1280 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1281 my $authline = "$author $date";
1282 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1283 fail "unexpected commit author line format \`$authline'".
1284 " (was generated from changelog Maintainer field)";
1288 sub vendor_patches_distro ($$) {
1289 my ($checkdistro, $what) = @_;
1290 return unless defined $checkdistro;
1292 my $series = "debian/patches/\L$checkdistro\E.series";
1293 printdebug "checking for vendor-specific $series ($what)\n";
1295 if (!open SERIES, "<", $series) {
1296 die "$series $!" unless $!==ENOENT;
1305 Unfortunately, this source package uses a feature of dpkg-source where
1306 the same source package unpacks to different source code on different
1307 distros. dgit cannot safely operate on such packages on affected
1308 distros, because the meaning of source packages is not stable.
1310 Please ask the distro/maintainer to remove the distro-specific series
1311 files and use a different technique (if necessary, uploading actually
1312 different packages, if different distros are supposed to have
1316 fail "Found active distro-specific series file for".
1317 " $checkdistro ($what): $series, cannot continue";
1319 die "$series $!" if SERIES->error;
1323 sub check_for_vendor_patches () {
1324 # This dpkg-source feature doesn't seem to be documented anywhere!
1325 # But it can be found in the changelog (reformatted):
1327 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1328 # Author: Raphael Hertzog <hertzog@debian.org>
1329 # Date: Sun Oct 3 09:36:48 2010 +0200
1331 # dpkg-source: correctly create .pc/.quilt_series with alternate
1334 # If you have debian/patches/ubuntu.series and you were
1335 # unpacking the source package on ubuntu, quilt was still
1336 # directed to debian/patches/series instead of
1337 # debian/patches/ubuntu.series.
1339 # debian/changelog | 3 +++
1340 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1341 # 2 files changed, 6 insertions(+), 1 deletion(-)
1344 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1345 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1346 "Dpkg::Vendor \`current vendor'");
1347 vendor_patches_distro(access_basedistro(),
1348 "distro being accessed");
1351 sub generate_commit_from_dsc () {
1355 foreach my $fi (dsc_files_info()) {
1356 my $f = $fi->{Filename};
1357 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1359 link "../../../$f", $f
1363 complete_file_from_dsc('.', $fi);
1365 if (is_orig_file($f)) {
1366 link $f, "../../../../$f"
1372 my $dscfn = "$package.dsc";
1374 open D, ">", $dscfn or die "$dscfn: $!";
1375 print D $dscdata or die "$dscfn: $!";
1376 close D or die "$dscfn: $!";
1377 my @cmd = qw(dpkg-source);
1378 push @cmd, '--no-check' if $dsc_checked;
1379 push @cmd, qw(-x --), $dscfn;
1382 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1383 check_for_vendor_patches() if madformat($dsc->{format});
1384 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1385 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1386 my $authline = clogp_authline $clogp;
1387 my $changes = getfield $clogp, 'Changes';
1388 open C, ">../commit.tmp" or die $!;
1389 print C <<END or die $!;
1396 # imported from the archive
1399 my $outputhash = make_commit qw(../commit.tmp);
1400 my $cversion = getfield $clogp, 'Version';
1401 progress "synthesised git commit from .dsc $cversion";
1402 if ($lastpush_hash) {
1403 runcmd @git, qw(reset --hard), $lastpush_hash;
1404 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1405 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1406 my $oversion = getfield $oldclogp, 'Version';
1408 version_compare($oversion, $cversion);
1410 # git upload/ is earlier vsn than archive, use archive
1411 open C, ">../commit2.tmp" or die $!;
1412 print C <<END or die $!;
1414 parent $lastpush_hash
1419 Record $package ($cversion) in archive suite $csuite
1421 $outputhash = make_commit qw(../commit2.tmp);
1422 } elsif ($vcmp > 0) {
1423 print STDERR <<END or die $!;
1425 Version actually in archive: $cversion (older)
1426 Last allegedly pushed/uploaded: $oversion (newer or same)
1429 $outputhash = $lastpush_hash;
1431 $outputhash = $lastpush_hash;
1434 changedir '../../../..';
1435 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1436 'DGIT_ARCHIVE', $outputhash;
1437 cmdoutput @git, qw(log -n2), $outputhash;
1438 # ... gives git a chance to complain if our commit is malformed
1443 sub complete_file_from_dsc ($$) {
1444 our ($dstdir, $fi) = @_;
1445 # Ensures that we have, in $dir, the file $fi, with the correct
1446 # contents. (Downloading it from alongside $dscurl if necessary.)
1448 my $f = $fi->{Filename};
1449 my $tf = "$dstdir/$f";
1452 if (stat_exists $tf) {
1453 progress "using existing $f";
1456 $furl =~ s{/[^/]+$}{};
1458 die "$f ?" unless $f =~ m/^${package}_/;
1459 die "$f ?" if $f =~ m#/#;
1460 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1461 next if !act_local();
1465 open F, "<", "$tf" or die "$tf: $!";
1466 $fi->{Digester}->reset();
1467 $fi->{Digester}->addfile(*F);
1468 F->error and die $!;
1469 my $got = $fi->{Digester}->hexdigest();
1470 $got eq $fi->{Hash} or
1471 fail "file $f has hash $got but .dsc".
1472 " demands hash $fi->{Hash} ".
1473 ($downloaded ? "(got wrong file from archive!)"
1474 : "(perhaps you should delete this file?)");
1477 sub ensure_we_have_orig () {
1478 foreach my $fi (dsc_files_info()) {
1479 my $f = $fi->{Filename};
1480 next unless is_orig_file($f);
1481 complete_file_from_dsc('..', $fi);
1485 sub git_fetch_us () {
1486 my @specs = (fetchspec());
1488 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1490 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1493 my $tagpat = debiantag('*',access_basedistro);
1495 git_for_each_ref("refs/tags/".$tagpat, sub {
1496 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1497 printdebug "currently $fullrefname=$objid\n";
1498 $here{$fullrefname} = $objid;
1500 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1501 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1502 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1503 printdebug "offered $lref=$objid\n";
1504 if (!defined $here{$lref}) {
1505 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1506 runcmd_ordryrun_local @upd;
1507 } elsif ($here{$lref} eq $objid) {
1510 "Not updateting $lref from $here{$lref} to $objid.\n";
1515 sub fetch_from_archive () {
1516 # ensures that lrref() is what is actually in the archive,
1517 # one way or another
1521 foreach my $field (@ourdscfield) {
1522 $dsc_hash = $dsc->{$field};
1523 last if defined $dsc_hash;
1525 if (defined $dsc_hash) {
1526 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1528 progress "last upload to archive specified git hash";
1530 progress "last upload to archive has NO git hash";
1533 progress "no version available from the archive";
1536 $lastpush_hash = git_get_ref(lrref());
1537 printdebug "previous reference hash=$lastpush_hash\n";
1539 if (defined $dsc_hash) {
1540 fail "missing remote git history even though dsc has hash -".
1541 " could not find ref ".lrref().
1542 " (should have been fetched from ".access_giturl()."#".rrref().")"
1543 unless $lastpush_hash;
1545 ensure_we_have_orig();
1546 if ($dsc_hash eq $lastpush_hash) {
1547 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1548 print STDERR <<END or die $!;
1550 Git commit in archive is behind the last version allegedly pushed/uploaded.
1551 Commit referred to by archive: $dsc_hash
1552 Last allegedly pushed/uploaded: $lastpush_hash
1555 $hash = $lastpush_hash;
1557 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1558 "descendant of archive's .dsc hash ($dsc_hash)";
1561 $hash = generate_commit_from_dsc();
1562 } elsif ($lastpush_hash) {
1563 # only in git, not in the archive yet
1564 $hash = $lastpush_hash;
1565 print STDERR <<END or die $!;
1567 Package not found in the archive, but has allegedly been pushed using dgit.
1571 printdebug "nothing found!\n";
1572 if (defined $skew_warning_vsn) {
1573 print STDERR <<END or die $!;
1575 Warning: relevant archive skew detected.
1576 Archive allegedly contains $skew_warning_vsn
1577 But we were not able to obtain any version from the archive or git.
1583 printdebug "current hash=$hash\n";
1584 if ($lastpush_hash) {
1585 fail "not fast forward on last upload branch!".
1586 " (archive's version left in DGIT_ARCHIVE)"
1587 unless is_fast_fwd($lastpush_hash, $hash);
1589 if (defined $skew_warning_vsn) {
1591 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1592 my $clogf = ".git/dgit/changelog.tmp";
1593 runcmd shell_cmd "exec >$clogf",
1594 @git, qw(cat-file blob), "$hash:debian/changelog";
1595 my $gotclogp = parsechangelog("-l$clogf");
1596 my $got_vsn = getfield $gotclogp, 'Version';
1597 printdebug "SKEW CHECK GOT $got_vsn\n";
1598 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1599 print STDERR <<END or die $!;
1601 Warning: archive skew detected. Using the available version:
1602 Archive allegedly contains $skew_warning_vsn
1603 We were able to obtain only $got_vsn
1608 if ($lastpush_hash ne $hash) {
1609 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1613 dryrun_report @upd_cmd;
1619 sub set_local_git_config ($$) {
1621 runcmd @git, qw(config), $k, $v;
1624 sub setup_mergechangelogs () {
1625 my $driver = 'dpkg-mergechangelogs';
1626 my $cb = "merge.$driver";
1627 my $attrs = '.git/info/attributes';
1628 ensuredir '.git/info';
1630 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1631 if (!open ATTRS, "<", $attrs) {
1632 $!==ENOENT or die "$attrs: $!";
1636 next if m{^debian/changelog\s};
1637 print NATTRS $_, "\n" or die $!;
1639 ATTRS->error and die $!;
1642 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1645 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1646 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1648 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1653 canonicalise_suite();
1654 badusage "dry run makes no sense with clone" unless act_local();
1655 my $hasgit = check_for_git();
1656 mkdir $dstdir or die "$dstdir $!";
1658 runcmd @git, qw(init -q);
1659 my $giturl = access_giturl(1);
1660 if (defined $giturl) {
1661 set_local_git_config "remote.$remotename.fetch", fetchspec();
1662 open H, "> .git/HEAD" or die $!;
1663 print H "ref: ".lref()."\n" or die $!;
1665 runcmd @git, qw(remote add), 'origin', $giturl;
1668 progress "fetching existing git history";
1670 runcmd_ordryrun_local @git, qw(fetch origin);
1672 progress "starting new git history";
1674 fetch_from_archive() or no_such_package;
1675 my $vcsgiturl = $dsc->{'Vcs-Git'};
1676 if (length $vcsgiturl) {
1677 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1678 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1680 setup_mergechangelogs();
1681 runcmd @git, qw(reset --hard), lrref();
1682 printdone "ready for work in $dstdir";
1686 if (check_for_git()) {
1689 fetch_from_archive() or no_such_package();
1690 printdone "fetched into ".lrref();
1695 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1697 printdone "fetched to ".lrref()." and merged into HEAD";
1700 sub check_not_dirty () {
1701 return if $ignoredirty;
1702 my @cmd = (@git, qw(diff --quiet HEAD));
1704 $!=0; $?=0; system @cmd;
1705 return if !$! && !$?;
1706 if (!$! && $?==256) {
1707 fail "working tree is dirty (does not match HEAD)";
1713 sub commit_admin ($) {
1716 runcmd_ordryrun_local @git, qw(commit -m), $m;
1719 sub commit_quilty_patch () {
1720 my $output = cmdoutput @git, qw(status --porcelain);
1722 foreach my $l (split /\n/, $output) {
1723 next unless $l =~ m/\S/;
1724 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1728 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1730 progress "nothing quilty to commit, ok.";
1733 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1734 commit_admin "Commit Debian 3.0 (quilt) metadata";
1737 sub get_source_format () {
1738 if (!open F, "debian/source/format") {
1739 die $! unless $!==&ENOENT;
1743 F->error and die $!;
1750 return 0 unless $format eq '3.0 (quilt)';
1751 if ($quilt_mode eq 'nocheck') {
1752 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1755 progress "Format \`$format', checking/updating patch stack";
1759 sub push_parse_changelog ($) {
1762 my $clogp = Dpkg::Control::Hash->new();
1763 $clogp->load($clogpfn) or die;
1765 $package = getfield $clogp, 'Source';
1766 my $cversion = getfield $clogp, 'Version';
1767 my $tag = debiantag($cversion, access_basedistro);
1768 runcmd @git, qw(check-ref-format), $tag;
1770 my $dscfn = dscfn($cversion);
1772 return ($clogp, $cversion, $tag, $dscfn);
1775 sub push_parse_dsc ($$$) {
1776 my ($dscfn,$dscfnwhat, $cversion) = @_;
1777 $dsc = parsecontrol($dscfn,$dscfnwhat);
1778 my $dversion = getfield $dsc, 'Version';
1779 my $dscpackage = getfield $dsc, 'Source';
1780 ($dscpackage eq $package && $dversion eq $cversion) or
1781 fail "$dscfn is for $dscpackage $dversion".
1782 " but debian/changelog is for $package $cversion";
1785 sub push_mktag ($$$$$$$) {
1786 my ($head,$clogp,$tag,
1788 $changesfile,$changesfilewhat,
1791 $dsc->{$ourdscfield[0]} = $head;
1792 $dsc->save("$dscfn.tmp") or die $!;
1794 my $changes = parsecontrol($changesfile,$changesfilewhat);
1795 foreach my $field (qw(Source Distribution Version)) {
1796 $changes->{$field} eq $clogp->{$field} or
1797 fail "changes field $field \`$changes->{$field}'".
1798 " does not match changelog \`$clogp->{$field}'";
1801 my $cversion = getfield $clogp, 'Version';
1802 my $clogsuite = getfield $clogp, 'Distribution';
1804 # We make the git tag by hand because (a) that makes it easier
1805 # to control the "tagger" (b) we can do remote signing
1806 my $authline = clogp_authline $clogp;
1807 my $delibs = join(" ", "",@deliberatelies);
1808 my $declaredistro = access_basedistro();
1809 open TO, '>', $tfn->('.tmp') or die $!;
1810 print TO <<END or die $!;
1816 $package release $cversion for $clogsuite ($csuite) [dgit]
1817 [dgit distro=$declaredistro$delibs]
1819 foreach my $ref (sort keys %previously) {
1820 print TO <<END or die $!;
1821 [dgit previously:$ref=$previously{$ref}]
1827 my $tagobjfn = $tfn->('.tmp');
1829 if (!defined $keyid) {
1830 $keyid = access_cfg('keyid','RETURN-UNDEF');
1832 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1833 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1834 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1835 push @sign_cmd, $tfn->('.tmp');
1836 runcmd_ordryrun @sign_cmd;
1838 $tagobjfn = $tfn->('.signed.tmp');
1839 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1840 $tfn->('.tmp'), $tfn->('.tmp.asc');
1847 sub sign_changes ($) {
1848 my ($changesfile) = @_;
1850 my @debsign_cmd = @debsign;
1851 push @debsign_cmd, "-k$keyid" if defined $keyid;
1852 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1853 push @debsign_cmd, $changesfile;
1854 runcmd_ordryrun @debsign_cmd;
1859 my ($forceflag) = @_;
1860 printdebug "actually entering push\n";
1861 supplementary_message(<<'END');
1862 Push failed, while preparing your push.
1863 You can retry the push, after fixing the problem, if you like.
1867 access_giturl(); # check that success is vaguely likely
1869 my $clogpfn = ".git/dgit/changelog.822.tmp";
1870 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1872 responder_send_file('parsed-changelog', $clogpfn);
1874 my ($clogp, $cversion, $tag, $dscfn) =
1875 push_parse_changelog("$clogpfn");
1877 my $dscpath = "$buildproductsdir/$dscfn";
1878 stat_exists $dscpath or
1879 fail "looked for .dsc $dscfn, but $!;".
1880 " maybe you forgot to build";
1882 responder_send_file('dsc', $dscpath);
1884 push_parse_dsc($dscpath, $dscfn, $cversion);
1886 my $format = getfield $dsc, 'Format';
1887 printdebug "format $format\n";
1888 if (madformat($format)) {
1889 commit_quilty_patch();
1893 progress "checking that $dscfn corresponds to HEAD";
1894 runcmd qw(dpkg-source -x --),
1895 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1896 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1897 check_for_vendor_patches() if madformat($dsc->{format});
1898 changedir '../../../..';
1899 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1900 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1901 debugcmd "+",@diffcmd;
1903 my $r = system @diffcmd;
1906 fail "$dscfn specifies a different tree to your HEAD commit;".
1907 " perhaps you forgot to build".
1908 ($diffopt eq '--exit-code' ? "" :
1909 " (run with -D to see full diff output)");
1914 my $head = git_rev_parse('HEAD');
1915 if (!$changesfile) {
1916 my $multi = "$buildproductsdir/".
1917 "${package}_".(stripepoch $cversion)."_multi.changes";
1918 if (stat_exists "$multi") {
1919 $changesfile = $multi;
1921 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1922 my @cs = glob "$buildproductsdir/$pat";
1923 fail "failed to find unique changes file".
1924 " (looked for $pat in $buildproductsdir, or $multi);".
1925 " perhaps you need to use dgit -C"
1927 ($changesfile) = @cs;
1930 $changesfile = "$buildproductsdir/$changesfile";
1933 responder_send_file('changes',$changesfile);
1934 responder_send_command("param head $head");
1935 responder_send_command("param csuite $csuite");
1937 if (deliberately_not_fast_forward) {
1938 git_for_each_ref(lrfetchrefs, sub {
1939 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1940 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1941 responder_send_command("previously $rrefname=$objid");
1942 $previously{$rrefname} = $objid;
1946 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1949 supplementary_message(<<'END');
1950 Push failed, while signing the tag.
1951 You can retry the push, after fixing the problem, if you like.
1953 # If we manage to sign but fail to record it anywhere, it's fine.
1954 if ($we_are_responder) {
1955 $tagobjfn = $tfn->('.signed.tmp');
1956 responder_receive_files('signed-tag', $tagobjfn);
1959 push_mktag($head,$clogp,$tag,
1961 $changesfile,$changesfile,
1964 supplementary_message(<<'END');
1965 Push failed, *after* signing the tag.
1966 If you want to try again, you should use a new version number.
1969 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1970 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1971 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1973 supplementary_message(<<'END');
1974 Push failed, while updating the remote git repository - see messages above.
1975 If you want to try again, you should use a new version number.
1977 if (!check_for_git()) {
1978 create_remote_git_repo();
1980 runcmd_ordryrun @git, qw(push),access_giturl(),
1981 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1982 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1984 supplementary_message(<<'END');
1985 Push failed, after updating the remote git repository.
1986 If you want to try again, you must use a new version number.
1988 if ($we_are_responder) {
1989 my $dryrunsuffix = act_local() ? "" : ".tmp";
1990 responder_receive_files('signed-dsc-changes',
1991 "$dscpath$dryrunsuffix",
1992 "$changesfile$dryrunsuffix");
1995 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1997 progress "[new .dsc left in $dscpath.tmp]";
1999 sign_changes $changesfile;
2002 supplementary_message(<<'END');
2003 Push failed, while uploading package(s) to the archive server.
2004 You can retry the upload of exactly these same files with dput of:
2006 If that .changes file is broken, you will need to use a new version
2007 number for your next attempt at the upload.
2009 my $host = access_cfg('upload-host','RETURN-UNDEF');
2010 my @hostarg = defined($host) ? ($host,) : ();
2011 runcmd_ordryrun @dput, @hostarg, $changesfile;
2012 printdone "pushed and uploaded $cversion";
2014 supplementary_message('');
2015 responder_send_command("complete");
2022 badusage "-p is not allowed with clone; specify as argument instead"
2023 if defined $package;
2026 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2027 ($package,$isuite) = @ARGV;
2028 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2029 ($package,$dstdir) = @ARGV;
2030 } elsif (@ARGV==3) {
2031 ($package,$isuite,$dstdir) = @ARGV;
2033 badusage "incorrect arguments to dgit clone";
2035 $dstdir ||= "$package";
2037 if (stat_exists $dstdir) {
2038 fail "$dstdir already exists";
2042 if ($rmonerror && !$dryrun_level) {
2043 $cwd_remove= getcwd();
2045 return unless defined $cwd_remove;
2046 if (!chdir "$cwd_remove") {
2047 return if $!==&ENOENT;
2048 die "chdir $cwd_remove: $!";
2050 rmtree($dstdir) or die "remove $dstdir: $!\n";
2055 $cwd_remove = undef;
2058 sub branchsuite () {
2059 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2060 if ($branch =~ m#$lbranch_re#o) {
2067 sub fetchpullargs () {
2069 if (!defined $package) {
2070 my $sourcep = parsecontrol('debian/control','debian/control');
2071 $package = getfield $sourcep, 'Source';
2074 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2076 my $clogp = parsechangelog();
2077 $isuite = getfield $clogp, 'Distribution';
2079 canonicalise_suite();
2080 progress "fetching from suite $csuite";
2081 } elsif (@ARGV==1) {
2083 canonicalise_suite();
2085 badusage "incorrect arguments to dgit fetch or dgit pull";
2104 badusage "-p is not allowed with dgit push" if defined $package;
2106 my $clogp = parsechangelog();
2107 $package = getfield $clogp, 'Source';
2110 } elsif (@ARGV==1) {
2111 ($specsuite) = (@ARGV);
2113 badusage "incorrect arguments to dgit push";
2115 $isuite = getfield $clogp, 'Distribution';
2117 local ($package) = $existing_package; # this is a hack
2118 canonicalise_suite();
2120 canonicalise_suite();
2122 if (defined $specsuite &&
2123 $specsuite ne $isuite &&
2124 $specsuite ne $csuite) {
2125 fail "dgit push: changelog specifies $isuite ($csuite)".
2126 " but command line specifies $specsuite";
2128 supplementary_message(<<'END');
2129 Push failed, while checking state of the archive.
2130 You can retry the push, after fixing the problem, if you like.
2132 if (check_for_git()) {
2136 if (fetch_from_archive()) {
2137 if (is_fast_fwd(lrref(), 'HEAD')) {
2139 } elsif (deliberately_not_fast_forward) {
2142 fail "dgit push: HEAD is not a descendant".
2143 " of the archive's version.\n".
2144 "dgit: To overwrite its contents,".
2145 " use git merge -s ours ".lrref().".\n".
2146 "dgit: To rewind history, if permitted by the archive,".
2147 " use --deliberately-not-fast-forward";
2151 fail "package appears to be new in this suite;".
2152 " if this is intentional, use --new";
2157 #---------- remote commands' implementation ----------
2159 sub cmd_remote_push_build_host {
2160 my ($nrargs) = shift @ARGV;
2161 my (@rargs) = @ARGV[0..$nrargs-1];
2162 @ARGV = @ARGV[$nrargs..$#ARGV];
2164 my ($dir,$vsnwant) = @rargs;
2165 # vsnwant is a comma-separated list; we report which we have
2166 # chosen in our ready response (so other end can tell if they
2169 $we_are_responder = 1;
2170 $us .= " (build host)";
2174 open PI, "<&STDIN" or die $!;
2175 open STDIN, "/dev/null" or die $!;
2176 open PO, ">&STDOUT" or die $!;
2178 open STDOUT, ">&STDERR" or die $!;
2182 ($protovsn) = grep {
2183 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2184 } @rpushprotovsn_support;
2186 fail "build host has dgit rpush protocol versions ".
2187 (join ",", @rpushprotovsn_support).
2188 " but invocation host has $vsnwant"
2189 unless defined $protovsn;
2191 responder_send_command("dgit-remote-push-ready $protovsn");
2197 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2198 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2199 # a good error message)
2205 my $report = i_child_report();
2206 if (defined $report) {
2207 printdebug "($report)\n";
2208 } elsif ($i_child_pid) {
2209 printdebug "(killing build host child $i_child_pid)\n";
2210 kill 15, $i_child_pid;
2212 if (defined $i_tmp && !defined $initiator_tempdir) {
2214 eval { rmtree $i_tmp; };
2218 END { i_cleanup(); }
2221 my ($base,$selector,@args) = @_;
2222 $selector =~ s/\-/_/g;
2223 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2230 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2238 push @rargs, join ",", @rpushprotovsn_support;
2241 push @rdgit, @ropts;
2242 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2244 my @cmd = (@ssh, $host, shellquote @rdgit);
2247 if (defined $initiator_tempdir) {
2248 rmtree $initiator_tempdir;
2249 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2250 $i_tmp = $initiator_tempdir;
2254 $i_child_pid = open2(\*RO, \*RI, @cmd);
2256 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2257 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2258 $supplementary_message = '' unless $protovsn >= 3;
2260 my ($icmd,$iargs) = initiator_expect {
2261 m/^(\S+)(?: (.*))?$/;
2264 i_method "i_resp", $icmd, $iargs;
2268 sub i_resp_progress ($) {
2270 my $msg = protocol_read_bytes \*RO, $rhs;
2274 sub i_resp_supplementary_message ($) {
2276 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2279 sub i_resp_complete {
2280 my $pid = $i_child_pid;
2281 $i_child_pid = undef; # prevents killing some other process with same pid
2282 printdebug "waiting for build host child $pid...\n";
2283 my $got = waitpid $pid, 0;
2284 die $! unless $got == $pid;
2285 die "build host child failed $?" if $?;
2288 printdebug "all done\n";
2292 sub i_resp_file ($) {
2294 my $localname = i_method "i_localname", $keyword;
2295 my $localpath = "$i_tmp/$localname";
2296 stat_exists $localpath and
2297 badproto \*RO, "file $keyword ($localpath) twice";
2298 protocol_receive_file \*RO, $localpath;
2299 i_method "i_file", $keyword;
2304 sub i_resp_param ($) {
2305 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2309 sub i_resp_previously ($) {
2310 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2311 or badproto \*RO, "bad previously spec";
2312 my $r = system qw(git check-ref-format), $1;
2313 die "bad previously ref spec ($r)" if $r;
2314 $previously{$1} = $2;
2319 sub i_resp_want ($) {
2321 die "$keyword ?" if $i_wanted{$keyword}++;
2322 my @localpaths = i_method "i_want", $keyword;
2323 printdebug "[[ $keyword @localpaths\n";
2324 foreach my $localpath (@localpaths) {
2325 protocol_send_file \*RI, $localpath;
2327 print RI "files-end\n" or die $!;
2330 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2332 sub i_localname_parsed_changelog {
2333 return "remote-changelog.822";
2335 sub i_file_parsed_changelog {
2336 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2337 push_parse_changelog "$i_tmp/remote-changelog.822";
2338 die if $i_dscfn =~ m#/|^\W#;
2341 sub i_localname_dsc {
2342 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2347 sub i_localname_changes {
2348 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2349 $i_changesfn = $i_dscfn;
2350 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2351 return $i_changesfn;
2353 sub i_file_changes { }
2355 sub i_want_signed_tag {
2356 printdebug Dumper(\%i_param, $i_dscfn);
2357 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2358 && defined $i_param{'csuite'}
2359 or badproto \*RO, "premature desire for signed-tag";
2360 my $head = $i_param{'head'};
2361 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2363 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2365 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2368 push_mktag $head, $i_clogp, $i_tag,
2370 $i_changesfn, 'remote changes',
2371 sub { "tag$_[0]"; };
2376 sub i_want_signed_dsc_changes {
2377 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2378 sign_changes $i_changesfn;
2379 return ($i_dscfn, $i_changesfn);
2382 #---------- building etc. ----------
2388 #----- `3.0 (quilt)' handling -----
2390 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2392 sub quiltify_dpkg_commit ($$$;$) {
2393 my ($patchname,$author,$msg, $xinfo) = @_;
2397 my $descfn = ".git/dgit/quilt-description.tmp";
2398 open O, '>', $descfn or die "$descfn: $!";
2401 $msg =~ s/^\s+$/ ./mg;
2402 print O <<END or die $!;
2412 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2413 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2414 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2415 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2419 sub quiltify_trees_differ ($$) {
2421 # returns 1 iff the two tree objects differ other than in debian/
2423 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2424 my $diffs= cmdoutput @cmd;
2425 foreach my $f (split /\0/, $diffs) {
2426 next if $f eq 'debian';
2432 sub quiltify_tree_sentinelfiles ($) {
2433 # lists the `sentinel' files present in the tree
2435 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2436 qw(-- debian/rules debian/control);
2442 my ($clogp,$target) = @_;
2444 # Quilt patchification algorithm
2446 # We search backwards through the history of the main tree's HEAD
2447 # (T) looking for a start commit S whose tree object is identical
2448 # to to the patch tip tree (ie the tree corresponding to the
2449 # current dpkg-committed patch series). For these purposes
2450 # `identical' disregards anything in debian/ - this wrinkle is
2451 # necessary because dpkg-source treates debian/ specially.
2453 # We can only traverse edges where at most one of the ancestors'
2454 # trees differs (in changes outside in debian/). And we cannot
2455 # handle edges which change .pc/ or debian/patches. To avoid
2456 # going down a rathole we avoid traversing edges which introduce
2457 # debian/rules or debian/control. And we set a limit on the
2458 # number of edges we are willing to look at.
2460 # If we succeed, we walk forwards again. For each traversed edge
2461 # PC (with P parent, C child) (starting with P=S and ending with
2462 # C=T) to we do this:
2464 # - dpkg-source --commit with a patch name and message derived from C
2465 # After traversing PT, we git commit the changes which
2466 # should be contained within debian/patches.
2468 changedir '../fake';
2469 mktree_in_ud_here();
2471 runcmd @git, 'add', '.';
2472 my $oldtiptree=git_write_tree();
2473 changedir '../work';
2475 # The search for the path S..T is breadth-first. We maintain a
2476 # todo list containing search nodes. A search node identifies a
2477 # commit, and looks something like this:
2479 # Commit => $git_commit_id,
2480 # Child => $c, # or undef if P=T
2481 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2482 # Nontrivial => true iff $p..$c has relevant changes
2489 my %considered; # saves being exponential on some weird graphs
2491 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2494 my ($search,$whynot) = @_;
2495 printdebug " search NOT $search->{Commit} $whynot\n";
2496 $search->{Whynot} = $whynot;
2497 push @nots, $search;
2498 no warnings qw(exiting);
2507 my $c = shift @todo;
2508 next if $considered{$c->{Commit}}++;
2510 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2512 printdebug "quiltify investigate $c->{Commit}\n";
2515 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2516 printdebug " search finished hooray!\n";
2521 if ($quilt_mode eq 'nofix') {
2522 fail "quilt fixup required but quilt mode is \`nofix'\n".
2523 "HEAD commit $c->{Commit} differs from tree implied by ".
2524 " debian/patches (tree object $oldtiptree)";
2526 if ($quilt_mode eq 'smash') {
2527 printdebug " search quitting smash\n";
2531 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2532 $not->($c, "has $c_sentinels not $t_sentinels")
2533 if $c_sentinels ne $t_sentinels;
2535 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2536 $commitdata =~ m/\n\n/;
2538 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2539 @parents = map { { Commit => $_, Child => $c } } @parents;
2541 $not->($c, "root commit") if !@parents;
2543 foreach my $p (@parents) {
2544 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2546 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2547 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2549 foreach my $p (@parents) {
2550 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2552 my @cmd= (@git, qw(diff-tree -r --name-only),
2553 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2554 my $patchstackchange = cmdoutput @cmd;
2555 if (length $patchstackchange) {
2556 $patchstackchange =~ s/\n/,/g;
2557 $not->($p, "changed $patchstackchange");
2560 printdebug " search queue P=$p->{Commit} ",
2561 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2567 printdebug "quiltify want to smash\n";
2570 my $x = $_[0]{Commit};
2571 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2574 my $reportnot = sub {
2576 my $s = $abbrev->($notp);
2577 my $c = $notp->{Child};
2578 $s .= "..".$abbrev->($c) if $c;
2579 $s .= ": ".$notp->{Whynot};
2582 if ($quilt_mode eq 'linear') {
2583 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2584 foreach my $notp (@nots) {
2585 print STDERR "$us: ", $reportnot->($notp), "\n";
2587 fail "quilt fixup naive history linearisation failed.\n".
2588 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2589 } elsif ($quilt_mode eq 'smash') {
2590 } elsif ($quilt_mode eq 'auto') {
2591 progress "quilt fixup cannot be linear, smashing...";
2593 die "$quilt_mode ?";
2598 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2600 quiltify_dpkg_commit "auto-$version-$target-$time",
2601 (getfield $clogp, 'Maintainer'),
2602 "Automatically generated patch ($clogp->{Version})\n".
2603 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2607 progress "quiltify linearisation planning successful, executing...";
2609 for (my $p = $sref_S;
2610 my $c = $p->{Child};
2612 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2613 next unless $p->{Nontrivial};
2615 my $cc = $c->{Commit};
2617 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2618 $commitdata =~ m/\n\n/ or die "$c ?";
2621 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2624 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2627 my $patchname = $title;
2628 $patchname =~ s/[.:]$//;
2629 $patchname =~ y/ A-Z/-a-z/;
2630 $patchname =~ y/-a-z0-9_.+=~//cd;
2631 $patchname =~ s/^\W/x-$&/;
2632 $patchname = substr($patchname,0,40);
2635 stat "debian/patches/$patchname$index";
2637 $!==ENOENT or die "$patchname$index $!";
2639 runcmd @git, qw(checkout -q), $cc;
2641 # We use the tip's changelog so that dpkg-source doesn't
2642 # produce complaining messages from dpkg-parsechangelog. None
2643 # of the information dpkg-source gets from the changelog is
2644 # actually relevant - it gets put into the original message
2645 # which dpkg-source provides our stunt editor, and then
2647 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2649 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2650 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2652 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2655 runcmd @git, qw(checkout -q master);
2658 sub build_maybe_quilt_fixup () {
2659 my $format=get_source_format;
2660 return unless madformat $format;
2663 check_for_vendor_patches();
2666 # - honour any existing .pc in case it has any strangeness
2667 # - determine the git commit corresponding to the tip of
2668 # the patch stack (if there is one)
2669 # - if there is such a git commit, convert each subsequent
2670 # git commit into a quilt patch with dpkg-source --commit
2671 # - otherwise convert all the differences in the tree into
2672 # a single git commit
2676 # Our git tree doesn't necessarily contain .pc. (Some versions of
2677 # dgit would include the .pc in the git tree.) If there isn't
2678 # one, we need to generate one by unpacking the patches that we
2681 # We first look for a .pc in the git tree. If there is one, we
2682 # will use it. (This is not the normal case.)
2684 # Otherwise need to regenerate .pc so that dpkg-source --commit
2685 # can work. We do this as follows:
2686 # 1. Collect all relevant .orig from parent directory
2687 # 2. Generate a debian.tar.gz out of
2688 # debian/{patches,rules,source/format}
2689 # 3. Generate a fake .dsc containing just these fields:
2690 # Format Source Version Files
2691 # 4. Extract the fake .dsc
2692 # Now the fake .dsc has a .pc directory.
2693 # (In fact we do this in every case, because in future we will
2694 # want to search for a good base commit for generating patches.)
2696 # Then we can actually do the dpkg-source --commit
2697 # 1. Make a new working tree with the same object
2698 # store as our main tree and check out the main
2700 # 2. Copy .pc from the fake's extraction, if necessary
2701 # 3. Run dpkg-source --commit
2702 # 4. If the result has changes to debian/, then
2703 # - git-add them them
2704 # - git-add .pc if we had a .pc in-tree
2706 # 5. If we had a .pc in-tree, delete it, and git-commit
2707 # 6. Back in the main tree, fast forward to the new HEAD
2709 my $clogp = parsechangelog();
2710 my $headref = git_rev_parse('HEAD');
2715 my $upstreamversion=$version;
2716 $upstreamversion =~ s/-[^-]*$//;
2718 my $fakeversion="$upstreamversion-~~DGITFAKE";
2720 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2721 print $fakedsc <<END or die $!;
2724 Version: $fakeversion
2728 my $dscaddfile=sub {
2731 my $md = new Digest::MD5;
2733 my $fh = new IO::File $b, '<' or die "$b $!";
2738 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2741 foreach my $f (<../../../../*>) { #/){
2742 my $b=$f; $b =~ s{.*/}{};
2743 next unless is_orig_file $b, srcfn $upstreamversion,'';
2744 link $f, $b or die "$b $!";
2748 my @files=qw(debian/source/format debian/rules);
2749 if (stat_exists '../../../debian/patches') {
2750 push @files, 'debian/patches';
2753 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2754 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2756 $dscaddfile->($debtar);
2757 close $fakedsc or die $!;
2759 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2761 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2762 rename $fakexdir, "fake" or die "$fakexdir $!";
2764 mkdir "work" or die $!;
2766 mktree_in_ud_here();
2767 runcmd @git, qw(reset --hard), $headref;
2770 if (stat_exists ".pc") {
2772 progress "Tree already contains .pc - will use it then delete it.";
2775 rename '../fake/.pc','.pc' or die $!;
2778 quiltify($clogp,$headref);
2780 if (!open P, '>>', ".pc/applied-patches") {
2781 $!==&ENOENT or die $!;
2786 commit_quilty_patch();
2788 if ($mustdeletepc) {
2789 runcmd @git, qw(rm -rqf .pc);
2790 commit_admin "Commit removal of .pc (quilt series tracking data)";
2793 changedir '../../../..';
2794 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2797 sub quilt_fixup_editor () {
2798 my $descfn = $ENV{$fakeeditorenv};
2799 my $editing = $ARGV[$#ARGV];
2800 open I1, '<', $descfn or die "$descfn: $!";
2801 open I2, '<', $editing or die "$editing: $!";
2802 unlink $editing or die "$editing: $!";
2803 open O, '>', $editing or die "$editing: $!";
2804 while (<I1>) { print O or die $!; } I1->error and die $!;
2807 $copying ||= m/^\-\-\- /;
2808 next unless $copying;
2811 I2->error and die $!;
2816 #----- other building -----
2819 if ($cleanmode eq 'dpkg-source') {
2820 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2821 } elsif ($cleanmode eq 'dpkg-source-d') {
2822 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2823 } elsif ($cleanmode eq 'git') {
2824 runcmd_ordryrun_local @git, qw(clean -xdf);
2825 } elsif ($cleanmode eq 'git-ff') {
2826 runcmd_ordryrun_local @git, qw(clean -xdff);
2827 } elsif ($cleanmode eq 'check') {
2828 my $leftovers = cmdoutput @git, qw(clean -xdn);
2829 if (length $leftovers) {
2830 print STDERR $leftovers, "\n" or die $!;
2831 fail "tree contains uncommitted files and --clean=check specified";
2833 } elsif ($cleanmode eq 'none') {
2840 badusage "clean takes no additional arguments" if @ARGV;
2847 badusage "-p is not allowed when building" if defined $package;
2850 my $clogp = parsechangelog();
2851 $isuite = getfield $clogp, 'Distribution';
2852 $package = getfield $clogp, 'Source';
2853 $version = getfield $clogp, 'Version';
2854 build_maybe_quilt_fixup();
2857 sub changesopts () {
2858 my @opts =@changesopts[1..$#changesopts];
2859 if (!defined $changes_since_version) {
2860 my @vsns = archive_query('archive_query');
2861 my @quirk = access_quirk();
2862 if ($quirk[0] eq 'backports') {
2863 local $isuite = $quirk[2];
2865 canonicalise_suite();
2866 push @vsns, archive_query('archive_query');
2869 @vsns = map { $_->[0] } @vsns;
2870 @vsns = sort { -version_compare($a, $b) } @vsns;
2871 $changes_since_version = $vsns[0];
2872 progress "changelog will contain changes since $vsns[0]";
2874 $changes_since_version = '_';
2875 progress "package seems new, not specifying -v<version>";
2878 if ($changes_since_version ne '_') {
2879 unshift @opts, "-v$changes_since_version";
2884 sub massage_dbp_args ($) {
2886 return unless $cleanmode =~ m/git|none/;
2887 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2888 my @newcmd = shift @$cmd;
2889 # -nc has the side effect of specifying -b if nothing else specified
2890 push @newcmd, '-nc';
2891 # and some combinations of -S, -b, et al, are errors, rather than
2892 # later simply overriding earlier
2893 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2894 push @newcmd, @$cmd;
2900 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2901 massage_dbp_args \@dbp;
2902 runcmd_ordryrun_local @dbp;
2903 printdone "build successful\n";
2908 my @dbp = @dpkgbuildpackage;
2909 massage_dbp_args \@dbp;
2911 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2912 "--git-builder=@dbp");
2913 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2914 canonicalise_suite();
2915 push @cmd, "--git-debian-branch=".lbranch();
2917 push @cmd, changesopts();
2918 runcmd_ordryrun_local @cmd, @ARGV;
2919 printdone "build successful\n";
2924 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2925 $dscfn = dscfn($version);
2926 if ($cleanmode eq 'dpkg-source') {
2927 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2929 } elsif ($cleanmode eq 'dpkg-source-d') {
2930 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2933 my $pwd = must_getcwd();
2934 my $leafdir = basename $pwd;
2936 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2938 runcmd_ordryrun_local qw(sh -ec),
2939 'exec >$1; shift; exec "$@"','x',
2940 "../$sourcechanges",
2941 @dpkggenchanges, qw(-S), changesopts();
2945 sub cmd_build_source {
2946 badusage "build-source takes no additional arguments" if @ARGV;
2948 printdone "source built, results in $dscfn and $sourcechanges";
2954 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2956 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2957 stat_exists $sourcechanges
2958 or fail "$sourcechanges (in parent directory): $!";
2959 foreach my $cf (glob $pat) {
2960 next if $cf eq $sourcechanges;
2961 unlink $cf or fail "remove $cf: $!";
2964 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2965 my @changesfiles = glob $pat;
2966 @changesfiles = sort {
2967 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2970 fail "wrong number of different changes files (@changesfiles)"
2971 unless @changesfiles;
2972 runcmd_ordryrun_local @mergechanges, @changesfiles;
2973 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2975 stat_exists $multichanges or fail "$multichanges: $!";
2977 printdone "build successful, results in $multichanges\n" or die $!;
2980 sub cmd_quilt_fixup {
2981 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2982 my $clogp = parsechangelog();
2983 $version = getfield $clogp, 'Version';
2984 $package = getfield $clogp, 'Source';
2985 build_maybe_quilt_fixup();
2988 sub cmd_archive_api_query {
2989 badusage "need only 1 subpath argument" unless @ARGV==1;
2990 my ($subpath) = @ARGV;
2991 my @cmd = archive_api_query_cmd($subpath);
2993 exec @cmd or fail "exec curl: $!\n";
2996 sub cmd_clone_dgit_repos_server {
2997 badusage "need destination argument" unless @ARGV==1;
2998 my ($destdir) = @ARGV;
2999 $package = '_dgit-repos-server';
3000 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3002 exec @cmd or fail "exec git clone: $!\n";
3005 sub cmd_setup_mergechangelogs {
3006 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3007 setup_mergechangelogs();
3010 #---------- argument parsing and main program ----------
3013 print "dgit version $our_version\n" or die $!;
3020 if (defined $ENV{'DGIT_SSH'}) {
3021 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3022 } elsif (defined $ENV{'GIT_SSH'}) {
3023 @ssh = ($ENV{'GIT_SSH'});
3027 last unless $ARGV[0] =~ m/^-/;
3031 if (m/^--dry-run$/) {
3034 } elsif (m/^--damp-run$/) {
3037 } elsif (m/^--no-sign$/) {
3040 } elsif (m/^--help$/) {
3042 } elsif (m/^--version$/) {
3044 } elsif (m/^--new$/) {
3047 } elsif (m/^--since-version=([^_]+|_)$/) {
3049 $changes_since_version = $1;
3050 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3051 ($om = $opts_opt_map{$1}) &&
3055 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3056 !$opts_opt_cmdonly{$1} &&
3057 ($om = $opts_opt_map{$1})) {
3059 push @{ $opts_opt_cmdline_opts{$1} }, $2;
3060 } elsif (m/^--existing-package=(.*)/s) {
3062 $existing_package = $1;
3063 } elsif (m/^--initiator-tempdir=(.*)/s) {
3064 $initiator_tempdir = $1;
3065 $initiator_tempdir =~ m#^/# or
3066 badusage "--initiator-tempdir must be used specify an".
3067 " absolute, not relative, directory."
3068 } elsif (m/^--distro=(.*)/s) {
3071 } elsif (m/^--build-products-dir=(.*)/s) {
3073 $buildproductsdir = $1;
3074 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3077 } elsif (m/^--clean=(.*)$/s) {
3078 badusage "unknown cleaning mode \`$1'";
3079 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3082 } elsif (m/^--quilt=(.*)$/s) {
3083 badusage "unknown quilt fixup mode \`$1'";
3084 } elsif (m/^--ignore-dirty$/s) {
3087 } elsif (m/^--no-quilt-fixup$/s) {
3089 $quilt_mode = 'nocheck';
3090 } elsif (m/^--no-rm-on-error$/s) {
3093 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3095 push @deliberatelies, $&;
3097 badusage "unknown long option \`$_'";
3104 } elsif (s/^-L/-/) {
3107 } elsif (s/^-h/-/) {
3109 } elsif (s/^-D/-/) {
3113 } elsif (s/^-N/-/) {
3116 } elsif (s/^-v([^_]+|_)$//s) {
3118 $changes_since_version = $1;
3121 push @changesopts, $_;
3123 } elsif (s/^-c(.*=.*)//s) {
3125 push @git, '-c', $1;
3126 } elsif (s/^-d(.+)//s) {
3129 } elsif (s/^-C(.+)//s) {
3132 if ($changesfile =~ s#^(.*)/##) {
3133 $buildproductsdir = $1;
3135 } elsif (s/^-k(.+)//s) {
3137 } elsif (m/^-[vdCk]$/) {
3139 "option \`$_' requires an argument (and no space before the argument)";
3140 } elsif (s/^-wn$//s) {
3142 $cleanmode = 'none';
3143 } elsif (s/^-wg$//s) {
3146 } elsif (s/^-wgf$//s) {
3148 $cleanmode = 'git-ff';
3149 } elsif (s/^-wd$//s) {
3151 $cleanmode = 'dpkg-source';
3152 } elsif (s/^-wdd$//s) {
3154 $cleanmode = 'dpkg-source-d';
3155 } elsif (s/^-wc$//s) {
3157 $cleanmode = 'check';
3159 badusage "unknown short option \`$_'";
3166 sub finalise_opts_opts () {
3167 foreach my $k (keys %opts_opt_cmdline_opts) {
3168 push @{ $opts_opt_map{$k} }, @{ $opts_opt_cmdline_opts{$k} };
3172 if ($ENV{$fakeeditorenv}) {
3173 quilt_fixup_editor();
3178 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3179 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3180 if $dryrun_level == 1;
3182 print STDERR $helpmsg or die $!;
3185 my $cmd = shift @ARGV;
3188 if (!defined $quilt_mode) {
3189 local $access_forpush;
3190 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3191 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3193 $quilt_mode =~ m/^($quilt_modes_re)$/
3194 or badcfg "unknown quilt-mode \`$quilt_mode'";
3198 my $fn = ${*::}{"cmd_$cmd"};
3199 $fn or badusage "unknown operation $cmd";