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',
506 sub git_get_config ($) {
509 our %git_get_config_memo;
510 if (exists $git_get_config_memo{$c}) {
511 return $git_get_config_memo{$c};
515 my @cmd = (@git, qw(config --), $c);
517 local ($debuglevel) = $debuglevel-2;
518 $v = cmdoutput_errok @cmd;
526 $git_get_config_memo{$c} = $v;
532 return undef if $c =~ /RETURN-UNDEF/;
533 my $v = git_get_config($c);
534 return $v if defined $v;
535 my $dv = $defcfg{$c};
536 return $dv if defined $dv;
538 badcfg "need value for one of: @_\n".
539 "$us: distro or suite appears not to be (properly) supported";
542 sub access_basedistro () {
543 if (defined $idistro) {
546 return cfg("dgit-suite.$isuite.distro",
547 "dgit.default.distro");
551 sub access_quirk () {
552 # returns (quirk name, distro to use instead or undef, quirk-specific info)
553 my $basedistro = access_basedistro();
554 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
556 if (defined $backports_quirk) {
557 my $re = $backports_quirk;
558 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
560 $re =~ s/\%/([-0-9a-z_]+)/
561 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
562 if ($isuite =~ m/^$re$/) {
563 return ('backports',"$basedistro-backports",$1);
566 return ('none',undef);
571 sub parse_cfg_bool ($$$) {
572 my ($what,$def,$v) = @_;
575 $v =~ m/^[ty1]/ ? 1 :
576 $v =~ m/^[fn0]/ ? 0 :
577 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
580 sub access_forpush_config () {
581 my $d = access_basedistro();
585 parse_cfg_bool('new-private-pushers', 0,
586 cfg("dgit-distro.$d.new-private-pushers",
589 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
592 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
593 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
594 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
595 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
598 sub access_forpush () {
599 $access_forpush //= access_forpush_config();
600 return $access_forpush;
604 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
605 badcfg "pushing but distro is configured readonly"
606 if access_forpush_config() eq '0';
608 $supplementary_message = <<'END' unless $we_are_responder;
609 Push failed, before we got started.
610 You can retry the push, after fixing the problem, if you like.
612 finalise_opts_opts();
616 finalise_opts_opts();
619 sub supplementary_message ($) {
621 if (!$we_are_responder) {
622 $supplementary_message = $msg;
624 } elsif ($protovsn >= 3) {
625 responder_send_command "supplementary-message ".length($msg)
627 print PO $msg or die $!;
631 sub access_distros () {
632 # Returns list of distros to try, in order
635 # 0. `instead of' distro name(s) we have been pointed to
636 # 1. the access_quirk distro, if any
637 # 2a. the user's specified distro, or failing that } basedistro
638 # 2b. the distro calculated from the suite }
639 my @l = access_basedistro();
641 my (undef,$quirkdistro) = access_quirk();
642 unshift @l, $quirkdistro;
643 unshift @l, $instead_distro;
644 @l = grep { defined } @l;
646 if (access_forpush()) {
647 @l = map { ("$_/push", $_) } @l;
652 sub access_cfg_cfgs (@) {
655 # The nesting of these loops determines the search order. We put
656 # the key loop on the outside so that we search all the distros
657 # for each key, before going on to the next key. That means that
658 # if access_cfg is called with a more specific, and then a less
659 # specific, key, an earlier distro can override the less specific
660 # without necessarily overriding any more specific keys. (If the
661 # distro wants to override the more specific keys it can simply do
662 # so; whereas if we did the loop the other way around, it would be
663 # impossible to for an earlier distro to override a less specific
664 # key but not the more specific ones without restating the unknown
665 # values of the more specific keys.
668 # We have to deal with RETURN-UNDEF specially, so that we don't
669 # terminate the search prematurely.
671 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
674 foreach my $d (access_distros()) {
675 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
677 push @cfgs, map { "dgit.default.$_" } @realkeys;
684 my (@cfgs) = access_cfg_cfgs(@keys);
685 my $value = cfg(@cfgs);
689 sub string_to_ssh ($) {
691 if ($spec =~ m/\s/) {
692 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
698 sub access_cfg_ssh () {
699 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
700 if (!defined $gitssh) {
703 return string_to_ssh $gitssh;
707 sub access_runeinfo ($) {
709 return ": dgit ".access_basedistro()." $info ;";
712 sub access_someuserhost ($) {
714 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
715 defined($user) && length($user) or
716 $user = access_cfg("$some-user",'username');
717 my $host = access_cfg("$some-host");
718 return length($user) ? "$user\@$host" : $host;
721 sub access_gituserhost () {
722 return access_someuserhost('git');
725 sub access_giturl (;$) {
727 my $url = access_cfg('git-url','RETURN-UNDEF');
730 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
731 return undef unless defined $proto;
734 access_gituserhost().
735 access_cfg('git-path');
737 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
740 return "$url/$package$suffix";
743 sub parsecontrolfh ($$;$) {
744 my ($fh, $desc, $allowsigned) = @_;
745 our $dpkgcontrolhash_noissigned;
748 my %opts = ('name' => $desc);
749 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
750 $c = Dpkg::Control::Hash->new(%opts);
751 $c->parse($fh,$desc) or die "parsing of $desc failed";
752 last if $allowsigned;
753 last if $dpkgcontrolhash_noissigned;
754 my $issigned= $c->get_option('is_pgp_signed');
755 if (!defined $issigned) {
756 $dpkgcontrolhash_noissigned= 1;
757 seek $fh, 0,0 or die "seek $desc: $!";
758 } elsif ($issigned) {
759 fail "control file $desc is (already) PGP-signed. ".
760 " Note that dgit push needs to modify the .dsc and then".
761 " do the signature itself";
770 my ($file, $desc) = @_;
771 my $fh = new IO::Handle;
772 open $fh, '<', $file or die "$file: $!";
773 my $c = parsecontrolfh($fh,$desc);
774 $fh->error and die $!;
780 my ($dctrl,$field) = @_;
781 my $v = $dctrl->{$field};
782 return $v if defined $v;
783 fail "missing field $field in ".$v->get_option('name');
787 my $c = Dpkg::Control::Hash->new();
788 my $p = new IO::Handle;
789 my @cmd = (qw(dpkg-parsechangelog), @_);
790 open $p, '-|', @cmd or die $!;
792 $?=0; $!=0; close $p or failedcmd @cmd;
798 defined $d or fail "getcwd failed: $!";
804 sub archive_query ($) {
806 my $query = access_cfg('archive-query','RETURN-UNDEF');
807 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
810 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
813 sub pool_dsc_subpath ($$) {
814 my ($vsn,$component) = @_; # $package is implict arg
815 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
816 return "/pool/$component/$prefix/$package/".dscfn($vsn);
819 #---------- `ftpmasterapi' archive query method (nascent) ----------
821 sub archive_api_query_cmd ($) {
823 my @cmd = qw(curl -sS);
824 my $url = access_cfg('archive-query-url');
825 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
827 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
828 foreach my $key (split /\:/, $keys) {
829 $key =~ s/\%HOST\%/$host/g;
831 fail "for $url: stat $key: $!" unless $!==ENOENT;
834 fail "config requested specific TLS key but do not know".
835 " how to get curl to use exactly that EE key ($key)";
836 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
837 # # Sadly the above line does not work because of changes
838 # # to gnutls. The real fix for #790093 may involve
839 # # new curl options.
842 # Fixing #790093 properly will involve providing a value
843 # for this on clients.
844 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
845 push @cmd, split / /, $kargs if defined $kargs;
847 push @cmd, $url.$subpath;
853 my ($data, $subpath) = @_;
854 badcfg "ftpmasterapi archive query method takes no data part"
856 my @cmd = archive_api_query_cmd($subpath);
857 my $json = cmdoutput @cmd;
858 return decode_json($json);
861 sub canonicalise_suite_ftpmasterapi () {
862 my ($proto,$data) = @_;
863 my $suites = api_query($data, 'suites');
865 foreach my $entry (@$suites) {
867 my $v = $entry->{$_};
868 defined $v && $v eq $isuite;
870 push @matched, $entry;
872 fail "unknown suite $isuite" unless @matched;
875 @matched==1 or die "multiple matches for suite $isuite\n";
876 $cn = "$matched[0]{codename}";
877 defined $cn or die "suite $isuite info has no codename\n";
878 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
880 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
885 sub archive_query_ftpmasterapi () {
886 my ($proto,$data) = @_;
887 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
889 my $digester = Digest::SHA->new(256);
890 foreach my $entry (@$info) {
892 my $vsn = "$entry->{version}";
893 my ($ok,$msg) = version_check $vsn;
894 die "bad version: $msg\n" unless $ok;
895 my $component = "$entry->{component}";
896 $component =~ m/^$component_re$/ or die "bad component";
897 my $filename = "$entry->{filename}";
898 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
899 or die "bad filename";
900 my $sha256sum = "$entry->{sha256sum}";
901 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
902 push @rows, [ $vsn, "/pool/$component/$filename",
903 $digester, $sha256sum ];
905 die "bad ftpmaster api response: $@\n".Dumper($entry)
908 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
912 #---------- `madison' archive query method ----------
914 sub archive_query_madison {
915 return map { [ @$_[0..1] ] } madison_get_parse(@_);
918 sub madison_get_parse {
919 my ($proto,$data) = @_;
920 die unless $proto eq 'madison';
922 $data= access_cfg('madison-distro','RETURN-UNDEF');
923 $data //= access_basedistro();
925 $rmad{$proto,$data,$package} ||= cmdoutput
926 qw(rmadison -asource),"-s$isuite","-u$data",$package;
927 my $rmad = $rmad{$proto,$data,$package};
930 foreach my $l (split /\n/, $rmad) {
931 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
932 \s*( [^ \t|]+ )\s* \|
933 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
934 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
935 $1 eq $package or die "$rmad $package ?";
942 $component = access_cfg('archive-query-default-component');
944 $5 eq 'source' or die "$rmad ?";
945 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
947 return sort { -version_compare($a->[0],$b->[0]); } @out;
950 sub canonicalise_suite_madison {
951 # madison canonicalises for us
952 my @r = madison_get_parse(@_);
954 "unable to canonicalise suite using package $package".
955 " which does not appear to exist in suite $isuite;".
956 " --existing-package may help";
960 #---------- `sshpsql' archive query method ----------
963 my ($data,$runeinfo,$sql) = @_;
965 $data= access_someuserhost('sshpsql').':'.
966 access_cfg('sshpsql-dbname');
968 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
969 my ($userhost,$dbname) = ($`,$'); #';
971 my @cmd = (access_cfg_ssh, $userhost,
972 access_runeinfo("ssh-psql $runeinfo").
973 " export LC_MESSAGES=C; export LC_CTYPE=C;".
974 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
976 open P, "-|", @cmd or die $!;
979 printdebug("$debugprefix>|$_|\n");
982 $!=0; $?=0; close P or failedcmd @cmd;
984 my $nrows = pop @rows;
985 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
986 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
987 @rows = map { [ split /\|/, $_ ] } @rows;
988 my $ncols = scalar @{ shift @rows };
989 die if grep { scalar @$_ != $ncols } @rows;
993 sub sql_injection_check {
994 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
997 sub archive_query_sshpsql ($$) {
998 my ($proto,$data) = @_;
999 sql_injection_check $isuite, $package;
1000 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1001 SELECT source.version, component.name, files.filename, files.sha256sum
1003 JOIN src_associations ON source.id = src_associations.source
1004 JOIN suite ON suite.id = src_associations.suite
1005 JOIN dsc_files ON dsc_files.source = source.id
1006 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1007 JOIN component ON component.id = files_archive_map.component_id
1008 JOIN files ON files.id = dsc_files.file
1009 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1010 AND source.source='$package'
1011 AND files.filename LIKE '%.dsc';
1013 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1014 my $digester = Digest::SHA->new(256);
1016 my ($vsn,$component,$filename,$sha256sum) = @$_;
1017 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1022 sub canonicalise_suite_sshpsql ($$) {
1023 my ($proto,$data) = @_;
1024 sql_injection_check $isuite;
1025 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1026 SELECT suite.codename
1027 FROM suite where suite_name='$isuite' or codename='$isuite';
1029 @rows = map { $_->[0] } @rows;
1030 fail "unknown suite $isuite" unless @rows;
1031 die "ambiguous $isuite: @rows ?" if @rows>1;
1035 #---------- `dummycat' archive query method ----------
1037 sub canonicalise_suite_dummycat ($$) {
1038 my ($proto,$data) = @_;
1039 my $dpath = "$data/suite.$isuite";
1040 if (!open C, "<", $dpath) {
1041 $!==ENOENT or die "$dpath: $!";
1042 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1046 chomp or die "$dpath: $!";
1048 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1052 sub archive_query_dummycat ($$) {
1053 my ($proto,$data) = @_;
1054 canonicalise_suite();
1055 my $dpath = "$data/package.$csuite.$package";
1056 if (!open C, "<", $dpath) {
1057 $!==ENOENT or die "$dpath: $!";
1058 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1066 printdebug "dummycat query $csuite $package $dpath | $_\n";
1067 my @row = split /\s+/, $_;
1068 @row==2 or die "$dpath: $_ ?";
1071 C->error and die "$dpath: $!";
1073 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1076 #---------- archive query entrypoints and rest of program ----------
1078 sub canonicalise_suite () {
1079 return if defined $csuite;
1080 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1081 $csuite = archive_query('canonicalise_suite');
1082 if ($isuite ne $csuite) {
1083 progress "canonical suite name for $isuite is $csuite";
1087 sub get_archive_dsc () {
1088 canonicalise_suite();
1089 my @vsns = archive_query('archive_query');
1090 foreach my $vinfo (@vsns) {
1091 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1092 $dscurl = access_cfg('mirror').$subpath;
1093 $dscdata = url_get($dscurl);
1095 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1100 $digester->add($dscdata);
1101 my $got = $digester->hexdigest();
1103 fail "$dscurl has hash $got but".
1104 " archive told us to expect $digest";
1106 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1107 printdebug Dumper($dscdata) if $debuglevel>1;
1108 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1109 printdebug Dumper($dsc) if $debuglevel>1;
1110 my $fmt = getfield $dsc, 'Format';
1111 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1112 $dsc_checked = !!$digester;
1118 sub check_for_git ();
1119 sub check_for_git () {
1121 my $how = access_cfg('git-check');
1122 if ($how eq 'ssh-cmd') {
1124 (access_cfg_ssh, access_gituserhost(),
1125 access_runeinfo("git-check $package").
1126 " set -e; cd ".access_cfg('git-path').";".
1127 " if test -d $package.git; then echo 1; else echo 0; fi");
1128 my $r= cmdoutput @cmd;
1129 if ($r =~ m/^divert (\w+)$/) {
1131 my ($usedistro,) = access_distros();
1132 # NB that if we are pushing, $usedistro will be $distro/push
1133 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1134 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1135 progress "diverting to $divert (using config for $instead_distro)";
1136 return check_for_git();
1138 failedcmd @cmd unless $r =~ m/^[01]$/;
1140 } elsif ($how eq 'url') {
1141 my $prefix = access_cfg('git-check-url','git-url');
1142 my $suffix = access_cfg('git-check-suffix','git-suffix',
1143 'RETURN-UNDEF') // '.git';
1144 my $url = "$prefix/$package$suffix";
1145 my @cmd = (qw(curl -sS -I), $url);
1146 my $result = cmdoutput @cmd;
1147 $result =~ m/^\S+ (404|200) /s or
1148 fail "unexpected results from git check query - ".
1149 Dumper($prefix, $result);
1151 if ($code eq '404') {
1153 } elsif ($code eq '200') {
1158 } elsif ($how eq 'true') {
1160 } elsif ($how eq 'false') {
1163 badcfg "unknown git-check \`$how'";
1167 sub create_remote_git_repo () {
1168 my $how = access_cfg('git-create');
1169 if ($how eq 'ssh-cmd') {
1171 (access_cfg_ssh, access_gituserhost(),
1172 access_runeinfo("git-create $package").
1173 "set -e; cd ".access_cfg('git-path').";".
1174 " cp -a _template $package.git");
1175 } elsif ($how eq 'true') {
1178 badcfg "unknown git-create \`$how'";
1182 our ($dsc_hash,$lastpush_hash);
1184 our $ud = '.git/dgit/unpack';
1189 mkdir $ud or die $!;
1192 sub mktree_in_ud_here () {
1193 runcmd qw(git init -q);
1194 rmtree('.git/objects');
1195 symlink '../../../../objects','.git/objects' or die $!;
1198 sub git_write_tree () {
1199 my $tree = cmdoutput @git, qw(write-tree);
1200 $tree =~ m/^\w+$/ or die "$tree ?";
1204 sub mktree_in_ud_from_only_subdir () {
1205 # changes into the subdir
1207 die unless @dirs==1;
1208 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1212 my @gitscmd = qw(find -name .git -prune -print0);
1213 debugcmd "|",@gitscmd;
1214 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1219 print STDERR "$us: warning: removing from source package: ",
1220 (messagequote $_), "\n";
1224 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1226 mktree_in_ud_here();
1227 my $format=get_source_format();
1228 if (madformat($format)) {
1231 runcmd @git, qw(add -Af);
1232 my $tree=git_write_tree();
1233 return ($tree,$dir);
1236 sub dsc_files_info () {
1237 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1238 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1239 ['Files', 'Digest::MD5', 'new()']) {
1240 my ($fname, $module, $method) = @$csumi;
1241 my $field = $dsc->{$fname};
1242 next unless defined $field;
1243 eval "use $module; 1;" or die $@;
1245 foreach (split /\n/, $field) {
1247 m/^(\w+) (\d+) (\S+)$/ or
1248 fail "could not parse .dsc $fname line \`$_'";
1249 my $digester = eval "$module"."->$method;" or die $@;
1254 Digester => $digester,
1259 fail "missing any supported Checksums-* or Files field in ".
1260 $dsc->get_option('name');
1264 map { $_->{Filename} } dsc_files_info();
1267 sub is_orig_file ($;$) {
1270 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1271 defined $base or return 1;
1275 sub make_commit ($) {
1277 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1280 sub clogp_authline ($) {
1282 my $author = getfield $clogp, 'Maintainer';
1283 $author =~ s#,.*##ms;
1284 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1285 my $authline = "$author $date";
1286 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1287 fail "unexpected commit author line format \`$authline'".
1288 " (was generated from changelog Maintainer field)";
1292 sub vendor_patches_distro ($$) {
1293 my ($checkdistro, $what) = @_;
1294 return unless defined $checkdistro;
1296 my $series = "debian/patches/\L$checkdistro\E.series";
1297 printdebug "checking for vendor-specific $series ($what)\n";
1299 if (!open SERIES, "<", $series) {
1300 die "$series $!" unless $!==ENOENT;
1309 Unfortunately, this source package uses a feature of dpkg-source where
1310 the same source package unpacks to different source code on different
1311 distros. dgit cannot safely operate on such packages on affected
1312 distros, because the meaning of source packages is not stable.
1314 Please ask the distro/maintainer to remove the distro-specific series
1315 files and use a different technique (if necessary, uploading actually
1316 different packages, if different distros are supposed to have
1320 fail "Found active distro-specific series file for".
1321 " $checkdistro ($what): $series, cannot continue";
1323 die "$series $!" if SERIES->error;
1327 sub check_for_vendor_patches () {
1328 # This dpkg-source feature doesn't seem to be documented anywhere!
1329 # But it can be found in the changelog (reformatted):
1331 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1332 # Author: Raphael Hertzog <hertzog@debian.org>
1333 # Date: Sun Oct 3 09:36:48 2010 +0200
1335 # dpkg-source: correctly create .pc/.quilt_series with alternate
1338 # If you have debian/patches/ubuntu.series and you were
1339 # unpacking the source package on ubuntu, quilt was still
1340 # directed to debian/patches/series instead of
1341 # debian/patches/ubuntu.series.
1343 # debian/changelog | 3 +++
1344 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1345 # 2 files changed, 6 insertions(+), 1 deletion(-)
1348 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1349 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1350 "Dpkg::Vendor \`current vendor'");
1351 vendor_patches_distro(access_basedistro(),
1352 "distro being accessed");
1355 sub generate_commit_from_dsc () {
1359 foreach my $fi (dsc_files_info()) {
1360 my $f = $fi->{Filename};
1361 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1363 link "../../../$f", $f
1367 complete_file_from_dsc('.', $fi);
1369 if (is_orig_file($f)) {
1370 link $f, "../../../../$f"
1376 my $dscfn = "$package.dsc";
1378 open D, ">", $dscfn or die "$dscfn: $!";
1379 print D $dscdata or die "$dscfn: $!";
1380 close D or die "$dscfn: $!";
1381 my @cmd = qw(dpkg-source);
1382 push @cmd, '--no-check' if $dsc_checked;
1383 push @cmd, qw(-x --), $dscfn;
1386 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1387 check_for_vendor_patches() if madformat($dsc->{format});
1388 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1389 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1390 my $authline = clogp_authline $clogp;
1391 my $changes = getfield $clogp, 'Changes';
1392 open C, ">../commit.tmp" or die $!;
1393 print C <<END or die $!;
1400 # imported from the archive
1403 my $outputhash = make_commit qw(../commit.tmp);
1404 my $cversion = getfield $clogp, 'Version';
1405 progress "synthesised git commit from .dsc $cversion";
1406 if ($lastpush_hash) {
1407 runcmd @git, qw(reset --hard), $lastpush_hash;
1408 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1409 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1410 my $oversion = getfield $oldclogp, 'Version';
1412 version_compare($oversion, $cversion);
1414 # git upload/ is earlier vsn than archive, use archive
1415 open C, ">../commit2.tmp" or die $!;
1416 print C <<END or die $!;
1418 parent $lastpush_hash
1423 Record $package ($cversion) in archive suite $csuite
1425 $outputhash = make_commit qw(../commit2.tmp);
1426 } elsif ($vcmp > 0) {
1427 print STDERR <<END or die $!;
1429 Version actually in archive: $cversion (older)
1430 Last allegedly pushed/uploaded: $oversion (newer or same)
1433 $outputhash = $lastpush_hash;
1435 $outputhash = $lastpush_hash;
1438 changedir '../../../..';
1439 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1440 'DGIT_ARCHIVE', $outputhash;
1441 cmdoutput @git, qw(log -n2), $outputhash;
1442 # ... gives git a chance to complain if our commit is malformed
1447 sub complete_file_from_dsc ($$) {
1448 our ($dstdir, $fi) = @_;
1449 # Ensures that we have, in $dir, the file $fi, with the correct
1450 # contents. (Downloading it from alongside $dscurl if necessary.)
1452 my $f = $fi->{Filename};
1453 my $tf = "$dstdir/$f";
1456 if (stat_exists $tf) {
1457 progress "using existing $f";
1460 $furl =~ s{/[^/]+$}{};
1462 die "$f ?" unless $f =~ m/^${package}_/;
1463 die "$f ?" if $f =~ m#/#;
1464 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1465 next if !act_local();
1469 open F, "<", "$tf" or die "$tf: $!";
1470 $fi->{Digester}->reset();
1471 $fi->{Digester}->addfile(*F);
1472 F->error and die $!;
1473 my $got = $fi->{Digester}->hexdigest();
1474 $got eq $fi->{Hash} or
1475 fail "file $f has hash $got but .dsc".
1476 " demands hash $fi->{Hash} ".
1477 ($downloaded ? "(got wrong file from archive!)"
1478 : "(perhaps you should delete this file?)");
1481 sub ensure_we_have_orig () {
1482 foreach my $fi (dsc_files_info()) {
1483 my $f = $fi->{Filename};
1484 next unless is_orig_file($f);
1485 complete_file_from_dsc('..', $fi);
1489 sub git_fetch_us () {
1490 my @specs = (fetchspec());
1492 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1494 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1497 my $tagpat = debiantag('*',access_basedistro);
1499 git_for_each_ref("refs/tags/".$tagpat, sub {
1500 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1501 printdebug "currently $fullrefname=$objid\n";
1502 $here{$fullrefname} = $objid;
1504 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1505 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1506 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1507 printdebug "offered $lref=$objid\n";
1508 if (!defined $here{$lref}) {
1509 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1510 runcmd_ordryrun_local @upd;
1511 } elsif ($here{$lref} eq $objid) {
1514 "Not updateting $lref from $here{$lref} to $objid.\n";
1519 sub fetch_from_archive () {
1520 # ensures that lrref() is what is actually in the archive,
1521 # one way or another
1525 foreach my $field (@ourdscfield) {
1526 $dsc_hash = $dsc->{$field};
1527 last if defined $dsc_hash;
1529 if (defined $dsc_hash) {
1530 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1532 progress "last upload to archive specified git hash";
1534 progress "last upload to archive has NO git hash";
1537 progress "no version available from the archive";
1540 $lastpush_hash = git_get_ref(lrref());
1541 printdebug "previous reference hash=$lastpush_hash\n";
1543 if (defined $dsc_hash) {
1544 fail "missing remote git history even though dsc has hash -".
1545 " could not find ref ".lrref().
1546 " (should have been fetched from ".access_giturl()."#".rrref().")"
1547 unless $lastpush_hash;
1549 ensure_we_have_orig();
1550 if ($dsc_hash eq $lastpush_hash) {
1551 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1552 print STDERR <<END or die $!;
1554 Git commit in archive is behind the last version allegedly pushed/uploaded.
1555 Commit referred to by archive: $dsc_hash
1556 Last allegedly pushed/uploaded: $lastpush_hash
1559 $hash = $lastpush_hash;
1561 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1562 "descendant of archive's .dsc hash ($dsc_hash)";
1565 $hash = generate_commit_from_dsc();
1566 } elsif ($lastpush_hash) {
1567 # only in git, not in the archive yet
1568 $hash = $lastpush_hash;
1569 print STDERR <<END or die $!;
1571 Package not found in the archive, but has allegedly been pushed using dgit.
1575 printdebug "nothing found!\n";
1576 if (defined $skew_warning_vsn) {
1577 print STDERR <<END or die $!;
1579 Warning: relevant archive skew detected.
1580 Archive allegedly contains $skew_warning_vsn
1581 But we were not able to obtain any version from the archive or git.
1587 printdebug "current hash=$hash\n";
1588 if ($lastpush_hash) {
1589 fail "not fast forward on last upload branch!".
1590 " (archive's version left in DGIT_ARCHIVE)"
1591 unless is_fast_fwd($lastpush_hash, $hash);
1593 if (defined $skew_warning_vsn) {
1595 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1596 my $clogf = ".git/dgit/changelog.tmp";
1597 runcmd shell_cmd "exec >$clogf",
1598 @git, qw(cat-file blob), "$hash:debian/changelog";
1599 my $gotclogp = parsechangelog("-l$clogf");
1600 my $got_vsn = getfield $gotclogp, 'Version';
1601 printdebug "SKEW CHECK GOT $got_vsn\n";
1602 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1603 print STDERR <<END or die $!;
1605 Warning: archive skew detected. Using the available version:
1606 Archive allegedly contains $skew_warning_vsn
1607 We were able to obtain only $got_vsn
1612 if ($lastpush_hash ne $hash) {
1613 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1617 dryrun_report @upd_cmd;
1623 sub set_local_git_config ($$) {
1625 runcmd @git, qw(config), $k, $v;
1628 sub setup_mergechangelogs () {
1629 my $driver = 'dpkg-mergechangelogs';
1630 my $cb = "merge.$driver";
1631 my $attrs = '.git/info/attributes';
1632 ensuredir '.git/info';
1634 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1635 if (!open ATTRS, "<", $attrs) {
1636 $!==ENOENT or die "$attrs: $!";
1640 next if m{^debian/changelog\s};
1641 print NATTRS $_, "\n" or die $!;
1643 ATTRS->error and die $!;
1646 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1649 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1650 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1652 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1657 canonicalise_suite();
1658 badusage "dry run makes no sense with clone" unless act_local();
1659 my $hasgit = check_for_git();
1660 mkdir $dstdir or die "$dstdir $!";
1662 runcmd @git, qw(init -q);
1663 my $giturl = access_giturl(1);
1664 if (defined $giturl) {
1665 set_local_git_config "remote.$remotename.fetch", fetchspec();
1666 open H, "> .git/HEAD" or die $!;
1667 print H "ref: ".lref()."\n" or die $!;
1669 runcmd @git, qw(remote add), 'origin', $giturl;
1672 progress "fetching existing git history";
1674 runcmd_ordryrun_local @git, qw(fetch origin);
1676 progress "starting new git history";
1678 fetch_from_archive() or no_such_package;
1679 my $vcsgiturl = $dsc->{'Vcs-Git'};
1680 if (length $vcsgiturl) {
1681 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1682 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1684 setup_mergechangelogs();
1685 runcmd @git, qw(reset --hard), lrref();
1686 printdone "ready for work in $dstdir";
1690 if (check_for_git()) {
1693 fetch_from_archive() or no_such_package();
1694 printdone "fetched into ".lrref();
1699 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1701 printdone "fetched to ".lrref()." and merged into HEAD";
1704 sub check_not_dirty () {
1705 return if $ignoredirty;
1706 my @cmd = (@git, qw(diff --quiet HEAD));
1708 $!=0; $?=0; system @cmd;
1709 return if !$! && !$?;
1710 if (!$! && $?==256) {
1711 fail "working tree is dirty (does not match HEAD)";
1717 sub commit_admin ($) {
1720 runcmd_ordryrun_local @git, qw(commit -m), $m;
1723 sub commit_quilty_patch () {
1724 my $output = cmdoutput @git, qw(status --porcelain);
1726 foreach my $l (split /\n/, $output) {
1727 next unless $l =~ m/\S/;
1728 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1732 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1734 progress "nothing quilty to commit, ok.";
1737 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1738 commit_admin "Commit Debian 3.0 (quilt) metadata";
1741 sub get_source_format () {
1742 if (!open F, "debian/source/format") {
1743 die $! unless $!==&ENOENT;
1747 F->error and die $!;
1754 return 0 unless $format eq '3.0 (quilt)';
1755 if ($quilt_mode eq 'nocheck') {
1756 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1759 progress "Format \`$format', checking/updating patch stack";
1763 sub push_parse_changelog ($) {
1766 my $clogp = Dpkg::Control::Hash->new();
1767 $clogp->load($clogpfn) or die;
1769 $package = getfield $clogp, 'Source';
1770 my $cversion = getfield $clogp, 'Version';
1771 my $tag = debiantag($cversion, access_basedistro);
1772 runcmd @git, qw(check-ref-format), $tag;
1774 my $dscfn = dscfn($cversion);
1776 return ($clogp, $cversion, $tag, $dscfn);
1779 sub push_parse_dsc ($$$) {
1780 my ($dscfn,$dscfnwhat, $cversion) = @_;
1781 $dsc = parsecontrol($dscfn,$dscfnwhat);
1782 my $dversion = getfield $dsc, 'Version';
1783 my $dscpackage = getfield $dsc, 'Source';
1784 ($dscpackage eq $package && $dversion eq $cversion) or
1785 fail "$dscfn is for $dscpackage $dversion".
1786 " but debian/changelog is for $package $cversion";
1789 sub push_mktag ($$$$$$$) {
1790 my ($head,$clogp,$tag,
1792 $changesfile,$changesfilewhat,
1795 $dsc->{$ourdscfield[0]} = $head;
1796 $dsc->save("$dscfn.tmp") or die $!;
1798 my $changes = parsecontrol($changesfile,$changesfilewhat);
1799 foreach my $field (qw(Source Distribution Version)) {
1800 $changes->{$field} eq $clogp->{$field} or
1801 fail "changes field $field \`$changes->{$field}'".
1802 " does not match changelog \`$clogp->{$field}'";
1805 my $cversion = getfield $clogp, 'Version';
1806 my $clogsuite = getfield $clogp, 'Distribution';
1808 # We make the git tag by hand because (a) that makes it easier
1809 # to control the "tagger" (b) we can do remote signing
1810 my $authline = clogp_authline $clogp;
1811 my $delibs = join(" ", "",@deliberatelies);
1812 my $declaredistro = access_basedistro();
1813 open TO, '>', $tfn->('.tmp') or die $!;
1814 print TO <<END or die $!;
1820 $package release $cversion for $clogsuite ($csuite) [dgit]
1821 [dgit distro=$declaredistro$delibs]
1823 foreach my $ref (sort keys %previously) {
1824 print TO <<END or die $!;
1825 [dgit previously:$ref=$previously{$ref}]
1831 my $tagobjfn = $tfn->('.tmp');
1833 if (!defined $keyid) {
1834 $keyid = access_cfg('keyid','RETURN-UNDEF');
1836 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1837 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1838 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1839 push @sign_cmd, $tfn->('.tmp');
1840 runcmd_ordryrun @sign_cmd;
1842 $tagobjfn = $tfn->('.signed.tmp');
1843 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1844 $tfn->('.tmp'), $tfn->('.tmp.asc');
1851 sub sign_changes ($) {
1852 my ($changesfile) = @_;
1854 my @debsign_cmd = @debsign;
1855 push @debsign_cmd, "-k$keyid" if defined $keyid;
1856 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1857 push @debsign_cmd, $changesfile;
1858 runcmd_ordryrun @debsign_cmd;
1863 my ($forceflag) = @_;
1864 printdebug "actually entering push\n";
1865 supplementary_message(<<'END');
1866 Push failed, while preparing your push.
1867 You can retry the push, after fixing the problem, if you like.
1871 access_giturl(); # check that success is vaguely likely
1873 my $clogpfn = ".git/dgit/changelog.822.tmp";
1874 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1876 responder_send_file('parsed-changelog', $clogpfn);
1878 my ($clogp, $cversion, $tag, $dscfn) =
1879 push_parse_changelog("$clogpfn");
1881 my $dscpath = "$buildproductsdir/$dscfn";
1882 stat_exists $dscpath or
1883 fail "looked for .dsc $dscfn, but $!;".
1884 " maybe you forgot to build";
1886 responder_send_file('dsc', $dscpath);
1888 push_parse_dsc($dscpath, $dscfn, $cversion);
1890 my $format = getfield $dsc, 'Format';
1891 printdebug "format $format\n";
1892 if (madformat($format)) {
1893 commit_quilty_patch();
1897 progress "checking that $dscfn corresponds to HEAD";
1898 runcmd qw(dpkg-source -x --),
1899 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1900 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1901 check_for_vendor_patches() if madformat($dsc->{format});
1902 changedir '../../../..';
1903 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1904 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1905 debugcmd "+",@diffcmd;
1907 my $r = system @diffcmd;
1910 fail "$dscfn specifies a different tree to your HEAD commit;".
1911 " perhaps you forgot to build".
1912 ($diffopt eq '--exit-code' ? "" :
1913 " (run with -D to see full diff output)");
1918 my $head = git_rev_parse('HEAD');
1919 if (!$changesfile) {
1920 my $multi = "$buildproductsdir/".
1921 "${package}_".(stripepoch $cversion)."_multi.changes";
1922 if (stat_exists "$multi") {
1923 $changesfile = $multi;
1925 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1926 my @cs = glob "$buildproductsdir/$pat";
1927 fail "failed to find unique changes file".
1928 " (looked for $pat in $buildproductsdir, or $multi);".
1929 " perhaps you need to use dgit -C"
1931 ($changesfile) = @cs;
1934 $changesfile = "$buildproductsdir/$changesfile";
1937 responder_send_file('changes',$changesfile);
1938 responder_send_command("param head $head");
1939 responder_send_command("param csuite $csuite");
1941 if (deliberately_not_fast_forward) {
1942 git_for_each_ref(lrfetchrefs, sub {
1943 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1944 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1945 responder_send_command("previously $rrefname=$objid");
1946 $previously{$rrefname} = $objid;
1950 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1953 supplementary_message(<<'END');
1954 Push failed, while signing the tag.
1955 You can retry the push, after fixing the problem, if you like.
1957 # If we manage to sign but fail to record it anywhere, it's fine.
1958 if ($we_are_responder) {
1959 $tagobjfn = $tfn->('.signed.tmp');
1960 responder_receive_files('signed-tag', $tagobjfn);
1963 push_mktag($head,$clogp,$tag,
1965 $changesfile,$changesfile,
1968 supplementary_message(<<'END');
1969 Push failed, *after* signing the tag.
1970 If you want to try again, you should use a new version number.
1973 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1974 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1975 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1977 supplementary_message(<<'END');
1978 Push failed, while updating the remote git repository - see messages above.
1979 If you want to try again, you should use a new version number.
1981 if (!check_for_git()) {
1982 create_remote_git_repo();
1984 runcmd_ordryrun @git, qw(push),access_giturl(),
1985 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1986 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1988 supplementary_message(<<'END');
1989 Push failed, after updating the remote git repository.
1990 If you want to try again, you must use a new version number.
1992 if ($we_are_responder) {
1993 my $dryrunsuffix = act_local() ? "" : ".tmp";
1994 responder_receive_files('signed-dsc-changes',
1995 "$dscpath$dryrunsuffix",
1996 "$changesfile$dryrunsuffix");
1999 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2001 progress "[new .dsc left in $dscpath.tmp]";
2003 sign_changes $changesfile;
2006 supplementary_message(<<'END');
2007 Push failed, while uploading package(s) to the archive server.
2008 You can retry the upload of exactly these same files with dput of:
2010 If that .changes file is broken, you will need to use a new version
2011 number for your next attempt at the upload.
2013 my $host = access_cfg('upload-host','RETURN-UNDEF');
2014 my @hostarg = defined($host) ? ($host,) : ();
2015 runcmd_ordryrun @dput, @hostarg, $changesfile;
2016 printdone "pushed and uploaded $cversion";
2018 supplementary_message('');
2019 responder_send_command("complete");
2026 badusage "-p is not allowed with clone; specify as argument instead"
2027 if defined $package;
2030 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2031 ($package,$isuite) = @ARGV;
2032 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2033 ($package,$dstdir) = @ARGV;
2034 } elsif (@ARGV==3) {
2035 ($package,$isuite,$dstdir) = @ARGV;
2037 badusage "incorrect arguments to dgit clone";
2039 $dstdir ||= "$package";
2041 if (stat_exists $dstdir) {
2042 fail "$dstdir already exists";
2046 if ($rmonerror && !$dryrun_level) {
2047 $cwd_remove= getcwd();
2049 return unless defined $cwd_remove;
2050 if (!chdir "$cwd_remove") {
2051 return if $!==&ENOENT;
2052 die "chdir $cwd_remove: $!";
2054 rmtree($dstdir) or die "remove $dstdir: $!\n";
2059 $cwd_remove = undef;
2062 sub branchsuite () {
2063 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2064 if ($branch =~ m#$lbranch_re#o) {
2071 sub fetchpullargs () {
2073 if (!defined $package) {
2074 my $sourcep = parsecontrol('debian/control','debian/control');
2075 $package = getfield $sourcep, 'Source';
2078 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2080 my $clogp = parsechangelog();
2081 $isuite = getfield $clogp, 'Distribution';
2083 canonicalise_suite();
2084 progress "fetching from suite $csuite";
2085 } elsif (@ARGV==1) {
2087 canonicalise_suite();
2089 badusage "incorrect arguments to dgit fetch or dgit pull";
2108 badusage "-p is not allowed with dgit push" if defined $package;
2110 my $clogp = parsechangelog();
2111 $package = getfield $clogp, 'Source';
2114 } elsif (@ARGV==1) {
2115 ($specsuite) = (@ARGV);
2117 badusage "incorrect arguments to dgit push";
2119 $isuite = getfield $clogp, 'Distribution';
2121 local ($package) = $existing_package; # this is a hack
2122 canonicalise_suite();
2124 canonicalise_suite();
2126 if (defined $specsuite &&
2127 $specsuite ne $isuite &&
2128 $specsuite ne $csuite) {
2129 fail "dgit push: changelog specifies $isuite ($csuite)".
2130 " but command line specifies $specsuite";
2132 supplementary_message(<<'END');
2133 Push failed, while checking state of the archive.
2134 You can retry the push, after fixing the problem, if you like.
2136 if (check_for_git()) {
2140 if (fetch_from_archive()) {
2141 if (is_fast_fwd(lrref(), 'HEAD')) {
2143 } elsif (deliberately_not_fast_forward) {
2146 fail "dgit push: HEAD is not a descendant".
2147 " of the archive's version.\n".
2148 "dgit: To overwrite its contents,".
2149 " use git merge -s ours ".lrref().".\n".
2150 "dgit: To rewind history, if permitted by the archive,".
2151 " use --deliberately-not-fast-forward";
2155 fail "package appears to be new in this suite;".
2156 " if this is intentional, use --new";
2161 #---------- remote commands' implementation ----------
2163 sub cmd_remote_push_build_host {
2164 my ($nrargs) = shift @ARGV;
2165 my (@rargs) = @ARGV[0..$nrargs-1];
2166 @ARGV = @ARGV[$nrargs..$#ARGV];
2168 my ($dir,$vsnwant) = @rargs;
2169 # vsnwant is a comma-separated list; we report which we have
2170 # chosen in our ready response (so other end can tell if they
2173 $we_are_responder = 1;
2174 $us .= " (build host)";
2178 open PI, "<&STDIN" or die $!;
2179 open STDIN, "/dev/null" or die $!;
2180 open PO, ">&STDOUT" or die $!;
2182 open STDOUT, ">&STDERR" or die $!;
2186 ($protovsn) = grep {
2187 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2188 } @rpushprotovsn_support;
2190 fail "build host has dgit rpush protocol versions ".
2191 (join ",", @rpushprotovsn_support).
2192 " but invocation host has $vsnwant"
2193 unless defined $protovsn;
2195 responder_send_command("dgit-remote-push-ready $protovsn");
2201 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2202 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2203 # a good error message)
2209 my $report = i_child_report();
2210 if (defined $report) {
2211 printdebug "($report)\n";
2212 } elsif ($i_child_pid) {
2213 printdebug "(killing build host child $i_child_pid)\n";
2214 kill 15, $i_child_pid;
2216 if (defined $i_tmp && !defined $initiator_tempdir) {
2218 eval { rmtree $i_tmp; };
2222 END { i_cleanup(); }
2225 my ($base,$selector,@args) = @_;
2226 $selector =~ s/\-/_/g;
2227 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2234 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2242 push @rargs, join ",", @rpushprotovsn_support;
2245 push @rdgit, @ropts;
2246 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2248 my @cmd = (@ssh, $host, shellquote @rdgit);
2251 if (defined $initiator_tempdir) {
2252 rmtree $initiator_tempdir;
2253 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2254 $i_tmp = $initiator_tempdir;
2258 $i_child_pid = open2(\*RO, \*RI, @cmd);
2260 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2261 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2262 $supplementary_message = '' unless $protovsn >= 3;
2264 my ($icmd,$iargs) = initiator_expect {
2265 m/^(\S+)(?: (.*))?$/;
2268 i_method "i_resp", $icmd, $iargs;
2272 sub i_resp_progress ($) {
2274 my $msg = protocol_read_bytes \*RO, $rhs;
2278 sub i_resp_supplementary_message ($) {
2280 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2283 sub i_resp_complete {
2284 my $pid = $i_child_pid;
2285 $i_child_pid = undef; # prevents killing some other process with same pid
2286 printdebug "waiting for build host child $pid...\n";
2287 my $got = waitpid $pid, 0;
2288 die $! unless $got == $pid;
2289 die "build host child failed $?" if $?;
2292 printdebug "all done\n";
2296 sub i_resp_file ($) {
2298 my $localname = i_method "i_localname", $keyword;
2299 my $localpath = "$i_tmp/$localname";
2300 stat_exists $localpath and
2301 badproto \*RO, "file $keyword ($localpath) twice";
2302 protocol_receive_file \*RO, $localpath;
2303 i_method "i_file", $keyword;
2308 sub i_resp_param ($) {
2309 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2313 sub i_resp_previously ($) {
2314 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2315 or badproto \*RO, "bad previously spec";
2316 my $r = system qw(git check-ref-format), $1;
2317 die "bad previously ref spec ($r)" if $r;
2318 $previously{$1} = $2;
2323 sub i_resp_want ($) {
2325 die "$keyword ?" if $i_wanted{$keyword}++;
2326 my @localpaths = i_method "i_want", $keyword;
2327 printdebug "[[ $keyword @localpaths\n";
2328 foreach my $localpath (@localpaths) {
2329 protocol_send_file \*RI, $localpath;
2331 print RI "files-end\n" or die $!;
2334 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2336 sub i_localname_parsed_changelog {
2337 return "remote-changelog.822";
2339 sub i_file_parsed_changelog {
2340 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2341 push_parse_changelog "$i_tmp/remote-changelog.822";
2342 die if $i_dscfn =~ m#/|^\W#;
2345 sub i_localname_dsc {
2346 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2351 sub i_localname_changes {
2352 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2353 $i_changesfn = $i_dscfn;
2354 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2355 return $i_changesfn;
2357 sub i_file_changes { }
2359 sub i_want_signed_tag {
2360 printdebug Dumper(\%i_param, $i_dscfn);
2361 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2362 && defined $i_param{'csuite'}
2363 or badproto \*RO, "premature desire for signed-tag";
2364 my $head = $i_param{'head'};
2365 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2367 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2369 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2372 push_mktag $head, $i_clogp, $i_tag,
2374 $i_changesfn, 'remote changes',
2375 sub { "tag$_[0]"; };
2380 sub i_want_signed_dsc_changes {
2381 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2382 sign_changes $i_changesfn;
2383 return ($i_dscfn, $i_changesfn);
2386 #---------- building etc. ----------
2392 #----- `3.0 (quilt)' handling -----
2394 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2396 sub quiltify_dpkg_commit ($$$;$) {
2397 my ($patchname,$author,$msg, $xinfo) = @_;
2401 my $descfn = ".git/dgit/quilt-description.tmp";
2402 open O, '>', $descfn or die "$descfn: $!";
2405 $msg =~ s/^\s+$/ ./mg;
2406 print O <<END or die $!;
2416 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2417 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2418 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2419 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2423 sub quiltify_trees_differ ($$) {
2425 # returns 1 iff the two tree objects differ other than in debian/
2427 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2428 my $diffs= cmdoutput @cmd;
2429 foreach my $f (split /\0/, $diffs) {
2430 next if $f eq 'debian';
2436 sub quiltify_tree_sentinelfiles ($) {
2437 # lists the `sentinel' files present in the tree
2439 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2440 qw(-- debian/rules debian/control);
2446 my ($clogp,$target) = @_;
2448 # Quilt patchification algorithm
2450 # We search backwards through the history of the main tree's HEAD
2451 # (T) looking for a start commit S whose tree object is identical
2452 # to to the patch tip tree (ie the tree corresponding to the
2453 # current dpkg-committed patch series). For these purposes
2454 # `identical' disregards anything in debian/ - this wrinkle is
2455 # necessary because dpkg-source treates debian/ specially.
2457 # We can only traverse edges where at most one of the ancestors'
2458 # trees differs (in changes outside in debian/). And we cannot
2459 # handle edges which change .pc/ or debian/patches. To avoid
2460 # going down a rathole we avoid traversing edges which introduce
2461 # debian/rules or debian/control. And we set a limit on the
2462 # number of edges we are willing to look at.
2464 # If we succeed, we walk forwards again. For each traversed edge
2465 # PC (with P parent, C child) (starting with P=S and ending with
2466 # C=T) to we do this:
2468 # - dpkg-source --commit with a patch name and message derived from C
2469 # After traversing PT, we git commit the changes which
2470 # should be contained within debian/patches.
2472 changedir '../fake';
2473 mktree_in_ud_here();
2475 runcmd @git, 'add', '.';
2476 my $oldtiptree=git_write_tree();
2477 changedir '../work';
2479 # The search for the path S..T is breadth-first. We maintain a
2480 # todo list containing search nodes. A search node identifies a
2481 # commit, and looks something like this:
2483 # Commit => $git_commit_id,
2484 # Child => $c, # or undef if P=T
2485 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2486 # Nontrivial => true iff $p..$c has relevant changes
2493 my %considered; # saves being exponential on some weird graphs
2495 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2498 my ($search,$whynot) = @_;
2499 printdebug " search NOT $search->{Commit} $whynot\n";
2500 $search->{Whynot} = $whynot;
2501 push @nots, $search;
2502 no warnings qw(exiting);
2511 my $c = shift @todo;
2512 next if $considered{$c->{Commit}}++;
2514 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2516 printdebug "quiltify investigate $c->{Commit}\n";
2519 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2520 printdebug " search finished hooray!\n";
2525 if ($quilt_mode eq 'nofix') {
2526 fail "quilt fixup required but quilt mode is \`nofix'\n".
2527 "HEAD commit $c->{Commit} differs from tree implied by ".
2528 " debian/patches (tree object $oldtiptree)";
2530 if ($quilt_mode eq 'smash') {
2531 printdebug " search quitting smash\n";
2535 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2536 $not->($c, "has $c_sentinels not $t_sentinels")
2537 if $c_sentinels ne $t_sentinels;
2539 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2540 $commitdata =~ m/\n\n/;
2542 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2543 @parents = map { { Commit => $_, Child => $c } } @parents;
2545 $not->($c, "root commit") if !@parents;
2547 foreach my $p (@parents) {
2548 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2550 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2551 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2553 foreach my $p (@parents) {
2554 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2556 my @cmd= (@git, qw(diff-tree -r --name-only),
2557 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2558 my $patchstackchange = cmdoutput @cmd;
2559 if (length $patchstackchange) {
2560 $patchstackchange =~ s/\n/,/g;
2561 $not->($p, "changed $patchstackchange");
2564 printdebug " search queue P=$p->{Commit} ",
2565 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2571 printdebug "quiltify want to smash\n";
2574 my $x = $_[0]{Commit};
2575 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2578 my $reportnot = sub {
2580 my $s = $abbrev->($notp);
2581 my $c = $notp->{Child};
2582 $s .= "..".$abbrev->($c) if $c;
2583 $s .= ": ".$notp->{Whynot};
2586 if ($quilt_mode eq 'linear') {
2587 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2588 foreach my $notp (@nots) {
2589 print STDERR "$us: ", $reportnot->($notp), "\n";
2591 fail "quilt fixup naive history linearisation failed.\n".
2592 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2593 } elsif ($quilt_mode eq 'smash') {
2594 } elsif ($quilt_mode eq 'auto') {
2595 progress "quilt fixup cannot be linear, smashing...";
2597 die "$quilt_mode ?";
2602 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2604 quiltify_dpkg_commit "auto-$version-$target-$time",
2605 (getfield $clogp, 'Maintainer'),
2606 "Automatically generated patch ($clogp->{Version})\n".
2607 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2611 progress "quiltify linearisation planning successful, executing...";
2613 for (my $p = $sref_S;
2614 my $c = $p->{Child};
2616 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2617 next unless $p->{Nontrivial};
2619 my $cc = $c->{Commit};
2621 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2622 $commitdata =~ m/\n\n/ or die "$c ?";
2625 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2628 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2631 my $patchname = $title;
2632 $patchname =~ s/[.:]$//;
2633 $patchname =~ y/ A-Z/-a-z/;
2634 $patchname =~ y/-a-z0-9_.+=~//cd;
2635 $patchname =~ s/^\W/x-$&/;
2636 $patchname = substr($patchname,0,40);
2639 stat "debian/patches/$patchname$index";
2641 $!==ENOENT or die "$patchname$index $!";
2643 runcmd @git, qw(checkout -q), $cc;
2645 # We use the tip's changelog so that dpkg-source doesn't
2646 # produce complaining messages from dpkg-parsechangelog. None
2647 # of the information dpkg-source gets from the changelog is
2648 # actually relevant - it gets put into the original message
2649 # which dpkg-source provides our stunt editor, and then
2651 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2653 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2654 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2656 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2659 runcmd @git, qw(checkout -q master);
2662 sub build_maybe_quilt_fixup () {
2663 my $format=get_source_format;
2664 return unless madformat $format;
2667 check_for_vendor_patches();
2670 # - honour any existing .pc in case it has any strangeness
2671 # - determine the git commit corresponding to the tip of
2672 # the patch stack (if there is one)
2673 # - if there is such a git commit, convert each subsequent
2674 # git commit into a quilt patch with dpkg-source --commit
2675 # - otherwise convert all the differences in the tree into
2676 # a single git commit
2680 # Our git tree doesn't necessarily contain .pc. (Some versions of
2681 # dgit would include the .pc in the git tree.) If there isn't
2682 # one, we need to generate one by unpacking the patches that we
2685 # We first look for a .pc in the git tree. If there is one, we
2686 # will use it. (This is not the normal case.)
2688 # Otherwise need to regenerate .pc so that dpkg-source --commit
2689 # can work. We do this as follows:
2690 # 1. Collect all relevant .orig from parent directory
2691 # 2. Generate a debian.tar.gz out of
2692 # debian/{patches,rules,source/format}
2693 # 3. Generate a fake .dsc containing just these fields:
2694 # Format Source Version Files
2695 # 4. Extract the fake .dsc
2696 # Now the fake .dsc has a .pc directory.
2697 # (In fact we do this in every case, because in future we will
2698 # want to search for a good base commit for generating patches.)
2700 # Then we can actually do the dpkg-source --commit
2701 # 1. Make a new working tree with the same object
2702 # store as our main tree and check out the main
2704 # 2. Copy .pc from the fake's extraction, if necessary
2705 # 3. Run dpkg-source --commit
2706 # 4. If the result has changes to debian/, then
2707 # - git-add them them
2708 # - git-add .pc if we had a .pc in-tree
2710 # 5. If we had a .pc in-tree, delete it, and git-commit
2711 # 6. Back in the main tree, fast forward to the new HEAD
2713 my $clogp = parsechangelog();
2714 my $headref = git_rev_parse('HEAD');
2719 my $upstreamversion=$version;
2720 $upstreamversion =~ s/-[^-]*$//;
2722 my $fakeversion="$upstreamversion-~~DGITFAKE";
2724 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2725 print $fakedsc <<END or die $!;
2728 Version: $fakeversion
2732 my $dscaddfile=sub {
2735 my $md = new Digest::MD5;
2737 my $fh = new IO::File $b, '<' or die "$b $!";
2742 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2745 foreach my $f (<../../../../*>) { #/){
2746 my $b=$f; $b =~ s{.*/}{};
2747 next unless is_orig_file $b, srcfn $upstreamversion,'';
2748 link $f, $b or die "$b $!";
2752 my @files=qw(debian/source/format debian/rules);
2753 if (stat_exists '../../../debian/patches') {
2754 push @files, 'debian/patches';
2757 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2758 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2760 $dscaddfile->($debtar);
2761 close $fakedsc or die $!;
2763 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2765 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2766 rename $fakexdir, "fake" or die "$fakexdir $!";
2768 mkdir "work" or die $!;
2770 mktree_in_ud_here();
2771 runcmd @git, qw(reset --hard), $headref;
2774 if (stat_exists ".pc") {
2776 progress "Tree already contains .pc - will use it then delete it.";
2779 rename '../fake/.pc','.pc' or die $!;
2782 quiltify($clogp,$headref);
2784 if (!open P, '>>', ".pc/applied-patches") {
2785 $!==&ENOENT or die $!;
2790 commit_quilty_patch();
2792 if ($mustdeletepc) {
2793 runcmd @git, qw(rm -rqf .pc);
2794 commit_admin "Commit removal of .pc (quilt series tracking data)";
2797 changedir '../../../..';
2798 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2801 sub quilt_fixup_editor () {
2802 my $descfn = $ENV{$fakeeditorenv};
2803 my $editing = $ARGV[$#ARGV];
2804 open I1, '<', $descfn or die "$descfn: $!";
2805 open I2, '<', $editing or die "$editing: $!";
2806 unlink $editing or die "$editing: $!";
2807 open O, '>', $editing or die "$editing: $!";
2808 while (<I1>) { print O or die $!; } I1->error and die $!;
2811 $copying ||= m/^\-\-\- /;
2812 next unless $copying;
2815 I2->error and die $!;
2820 #----- other building -----
2823 if ($cleanmode eq 'dpkg-source') {
2824 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2825 } elsif ($cleanmode eq 'dpkg-source-d') {
2826 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2827 } elsif ($cleanmode eq 'git') {
2828 runcmd_ordryrun_local @git, qw(clean -xdf);
2829 } elsif ($cleanmode eq 'git-ff') {
2830 runcmd_ordryrun_local @git, qw(clean -xdff);
2831 } elsif ($cleanmode eq 'check') {
2832 my $leftovers = cmdoutput @git, qw(clean -xdn);
2833 if (length $leftovers) {
2834 print STDERR $leftovers, "\n" or die $!;
2835 fail "tree contains uncommitted files and --clean=check specified";
2837 } elsif ($cleanmode eq 'none') {
2844 badusage "clean takes no additional arguments" if @ARGV;
2851 badusage "-p is not allowed when building" if defined $package;
2854 my $clogp = parsechangelog();
2855 $isuite = getfield $clogp, 'Distribution';
2856 $package = getfield $clogp, 'Source';
2857 $version = getfield $clogp, 'Version';
2858 build_maybe_quilt_fixup();
2861 sub changesopts () {
2862 my @opts =@changesopts[1..$#changesopts];
2863 if (!defined $changes_since_version) {
2864 my @vsns = archive_query('archive_query');
2865 my @quirk = access_quirk();
2866 if ($quirk[0] eq 'backports') {
2867 local $isuite = $quirk[2];
2869 canonicalise_suite();
2870 push @vsns, archive_query('archive_query');
2873 @vsns = map { $_->[0] } @vsns;
2874 @vsns = sort { -version_compare($a, $b) } @vsns;
2875 $changes_since_version = $vsns[0];
2876 progress "changelog will contain changes since $vsns[0]";
2878 $changes_since_version = '_';
2879 progress "package seems new, not specifying -v<version>";
2882 if ($changes_since_version ne '_') {
2883 unshift @opts, "-v$changes_since_version";
2888 sub massage_dbp_args ($) {
2890 return unless $cleanmode =~ m/git|none/;
2891 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2892 my @newcmd = shift @$cmd;
2893 # -nc has the side effect of specifying -b if nothing else specified
2894 push @newcmd, '-nc';
2895 # and some combinations of -S, -b, et al, are errors, rather than
2896 # later simply overriding earlier
2897 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2898 push @newcmd, @$cmd;
2904 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2905 massage_dbp_args \@dbp;
2906 runcmd_ordryrun_local @dbp;
2907 printdone "build successful\n";
2912 my @dbp = @dpkgbuildpackage;
2913 massage_dbp_args \@dbp;
2915 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2916 "--git-builder=@dbp");
2917 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2918 canonicalise_suite();
2919 push @cmd, "--git-debian-branch=".lbranch();
2921 push @cmd, changesopts();
2922 runcmd_ordryrun_local @cmd, @ARGV;
2923 printdone "build successful\n";
2928 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2929 $dscfn = dscfn($version);
2930 if ($cleanmode eq 'dpkg-source') {
2931 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2933 } elsif ($cleanmode eq 'dpkg-source-d') {
2934 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2937 my $pwd = must_getcwd();
2938 my $leafdir = basename $pwd;
2940 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2942 runcmd_ordryrun_local qw(sh -ec),
2943 'exec >$1; shift; exec "$@"','x',
2944 "../$sourcechanges",
2945 @dpkggenchanges, qw(-S), changesopts();
2949 sub cmd_build_source {
2950 badusage "build-source takes no additional arguments" if @ARGV;
2952 printdone "source built, results in $dscfn and $sourcechanges";
2958 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2960 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2961 stat_exists $sourcechanges
2962 or fail "$sourcechanges (in parent directory): $!";
2963 foreach my $cf (glob $pat) {
2964 next if $cf eq $sourcechanges;
2965 unlink $cf or fail "remove $cf: $!";
2968 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2969 my @changesfiles = glob $pat;
2970 @changesfiles = sort {
2971 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2974 fail "wrong number of different changes files (@changesfiles)"
2975 unless @changesfiles;
2976 runcmd_ordryrun_local @mergechanges, @changesfiles;
2977 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2979 stat_exists $multichanges or fail "$multichanges: $!";
2981 printdone "build successful, results in $multichanges\n" or die $!;
2984 sub cmd_quilt_fixup {
2985 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2986 my $clogp = parsechangelog();
2987 $version = getfield $clogp, 'Version';
2988 $package = getfield $clogp, 'Source';
2989 build_maybe_quilt_fixup();
2992 sub cmd_archive_api_query {
2993 badusage "need only 1 subpath argument" unless @ARGV==1;
2994 my ($subpath) = @ARGV;
2995 my @cmd = archive_api_query_cmd($subpath);
2997 exec @cmd or fail "exec curl: $!\n";
3000 sub cmd_clone_dgit_repos_server {
3001 badusage "need destination argument" unless @ARGV==1;
3002 my ($destdir) = @ARGV;
3003 $package = '_dgit-repos-server';
3004 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3006 exec @cmd or fail "exec git clone: $!\n";
3009 sub cmd_setup_mergechangelogs {
3010 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3011 setup_mergechangelogs();
3014 #---------- argument parsing and main program ----------
3017 print "dgit version $our_version\n" or die $!;
3024 if (defined $ENV{'DGIT_SSH'}) {
3025 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3026 } elsif (defined $ENV{'GIT_SSH'}) {
3027 @ssh = ($ENV{'GIT_SSH'});
3031 last unless $ARGV[0] =~ m/^-/;
3035 if (m/^--dry-run$/) {
3038 } elsif (m/^--damp-run$/) {
3041 } elsif (m/^--no-sign$/) {
3044 } elsif (m/^--help$/) {
3046 } elsif (m/^--version$/) {
3048 } elsif (m/^--new$/) {
3051 } elsif (m/^--since-version=([^_]+|_)$/) {
3053 $changes_since_version = $1;
3054 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3055 ($om = $opts_opt_map{$1}) &&
3059 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3060 !$opts_opt_cmdonly{$1} &&
3061 ($om = $opts_opt_map{$1})) {
3064 } elsif (m/^--existing-package=(.*)/s) {
3066 $existing_package = $1;
3067 } elsif (m/^--initiator-tempdir=(.*)/s) {
3068 $initiator_tempdir = $1;
3069 $initiator_tempdir =~ m#^/# or
3070 badusage "--initiator-tempdir must be used specify an".
3071 " absolute, not relative, directory."
3072 } elsif (m/^--distro=(.*)/s) {
3075 } elsif (m/^--build-products-dir=(.*)/s) {
3077 $buildproductsdir = $1;
3078 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3081 } elsif (m/^--clean=(.*)$/s) {
3082 badusage "unknown cleaning mode \`$1'";
3083 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3086 } elsif (m/^--quilt=(.*)$/s) {
3087 badusage "unknown quilt fixup mode \`$1'";
3088 } elsif (m/^--ignore-dirty$/s) {
3091 } elsif (m/^--no-quilt-fixup$/s) {
3093 $quilt_mode = 'nocheck';
3094 } elsif (m/^--no-rm-on-error$/s) {
3097 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3099 push @deliberatelies, $&;
3101 badusage "unknown long option \`$_'";
3108 } elsif (s/^-L/-/) {
3111 } elsif (s/^-h/-/) {
3113 } elsif (s/^-D/-/) {
3117 } elsif (s/^-N/-/) {
3120 } elsif (s/^-v([^_]+|_)$//s) {
3122 $changes_since_version = $1;
3125 push @changesopts, $_;
3127 } elsif (s/^-c(.*=.*)//s) {
3129 push @git, '-c', $1;
3130 } elsif (s/^-d(.+)//s) {
3133 } elsif (s/^-C(.+)//s) {
3136 if ($changesfile =~ s#^(.*)/##) {
3137 $buildproductsdir = $1;
3139 } elsif (s/^-k(.+)//s) {
3141 } elsif (m/^-[vdCk]$/) {
3143 "option \`$_' requires an argument (and no space before the argument)";
3144 } elsif (s/^-wn$//s) {
3146 $cleanmode = 'none';
3147 } elsif (s/^-wg$//s) {
3150 } elsif (s/^-wgf$//s) {
3152 $cleanmode = 'git-ff';
3153 } elsif (s/^-wd$//s) {
3155 $cleanmode = 'dpkg-source';
3156 } elsif (s/^-wdd$//s) {
3158 $cleanmode = 'dpkg-source-d';
3159 } elsif (s/^-wc$//s) {
3161 $cleanmode = 'check';
3163 badusage "unknown short option \`$_'";
3170 sub finalise_opts_opts () {
3171 foreach my $k (keys %opts_opt_map) {
3172 my $om = $opts_opt_map{$k};
3174 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3176 badcfg "cannot set command for $k"
3177 unless length $om->[0];
3181 foreach my $c (access_cfg_cfgs("opts-$k")) {
3182 local ($debuglevel) = $debuglevel-2;
3183 my @cmd = (@git, qw(config -z --get-all), $c);
3184 my $vs = cmdoutput_errok @cmd;
3186 badcfg "cannot configure options for $k"
3187 if $opts_opt_cmdonly{$k};
3188 my $insertpos = $opts_cfg_insertpos{$k};
3189 @$om = ( @$om[0..$insertpos-1],
3191 @$om[$insertpos..$#$om] );
3193 die "$k $c ?" if length $vs;
3201 if ($ENV{$fakeeditorenv}) {
3202 quilt_fixup_editor();
3207 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3208 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3209 if $dryrun_level == 1;
3211 print STDERR $helpmsg or die $!;
3214 my $cmd = shift @ARGV;
3217 if (!defined $quilt_mode) {
3218 local $access_forpush;
3219 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3220 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3222 $quilt_mode =~ m/^($quilt_modes_re)$/
3223 or badcfg "unknown quilt-mode \`$quilt_mode'";
3227 my $fn = ${*::}{"cmd_$cmd"};
3228 $fn or badusage "unknown operation $cmd";