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,
95 'dpkg-source' => \@dpkgsource,
96 'dpkg-buildpackage' => \@dpkgbuildpackage,
97 'dpkg-genchanges' => \@dpkggenchanges,
98 'ch' => \@changesopts,
99 'mergechanges' => \@mergechanges);
101 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
102 our %opts_cfg_insertpos = map {
104 scalar @{ $opts_opt_map{$_} }
105 } keys %opts_opt_map;
107 sub finalise_opts_opts();
113 our $supplementary_message = '';
117 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
120 our $remotename = 'dgit';
121 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
125 sub lbranch () { return "$branchprefix/$csuite"; }
126 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
127 sub lref () { return "refs/heads/".lbranch(); }
128 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
129 sub rrref () { return server_ref($csuite); }
131 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
141 return "${package}_".(stripepoch $vsn).$sfx
146 return srcfn($vsn,".dsc");
155 foreach my $f (@end) {
157 warn "$us: cleanup: $@" if length $@;
161 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
163 sub no_such_package () {
164 print STDERR "$us: package $package does not exist in suite $isuite\n";
170 return "+".rrref().":".lrref();
175 printdebug "CD $newdir\n";
176 chdir $newdir or die "chdir: $newdir: $!";
179 sub deliberately ($) {
181 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
184 sub deliberately_not_fast_forward () {
185 foreach (qw(not-fast-forward fresh-repo)) {
186 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
190 #---------- remote protocol support, common ----------
192 # remote push initiator/responder protocol:
193 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
194 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
195 # < dgit-remote-push-ready <actual-proto-vsn>
197 # > file parsed-changelog
198 # [indicates that output of dpkg-parsechangelog follows]
199 # > data-block NBYTES
200 # > [NBYTES bytes of data (no newline)]
201 # [maybe some more blocks]
213 # [indicates that signed tag is wanted]
214 # < data-block NBYTES
215 # < [NBYTES bytes of data (no newline)]
216 # [maybe some more blocks]
220 # > want signed-dsc-changes
221 # < data-block NBYTES [transfer of signed dsc]
223 # < data-block NBYTES [transfer of signed changes]
231 sub i_child_report () {
232 # Sees if our child has died, and reap it if so. Returns a string
233 # describing how it died if it failed, or undef otherwise.
234 return undef unless $i_child_pid;
235 my $got = waitpid $i_child_pid, WNOHANG;
236 return undef if $got <= 0;
237 die unless $got == $i_child_pid;
238 $i_child_pid = undef;
239 return undef unless $?;
240 return "build host child ".waitstatusmsg();
245 fail "connection lost: $!" if $fh->error;
246 fail "protocol violation; $m not expected";
249 sub badproto_badread ($$) {
251 fail "connection lost: $!" if $!;
252 my $report = i_child_report();
253 fail $report if defined $report;
254 badproto $fh, "eof (reading $wh)";
257 sub protocol_expect (&$) {
258 my ($match, $fh) = @_;
261 defined && chomp or badproto_badread $fh, "protocol message";
269 badproto $fh, "\`$_'";
272 sub protocol_send_file ($$) {
273 my ($fh, $ourfn) = @_;
274 open PF, "<", $ourfn or die "$ourfn: $!";
277 my $got = read PF, $d, 65536;
278 die "$ourfn: $!" unless defined $got;
280 print $fh "data-block ".length($d)."\n" or die $!;
281 print $fh $d or die $!;
283 PF->error and die "$ourfn $!";
284 print $fh "data-end\n" or die $!;
288 sub protocol_read_bytes ($$) {
289 my ($fh, $nbytes) = @_;
290 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
292 my $got = read $fh, $d, $nbytes;
293 $got==$nbytes or badproto_badread $fh, "data block";
297 sub protocol_receive_file ($$) {
298 my ($fh, $ourfn) = @_;
299 printdebug "() $ourfn\n";
300 open PF, ">", $ourfn or die "$ourfn: $!";
302 my ($y,$l) = protocol_expect {
303 m/^data-block (.*)$/ ? (1,$1) :
304 m/^data-end$/ ? (0,) :
308 my $d = protocol_read_bytes $fh, $l;
309 print PF $d or die $!;
314 #---------- remote protocol support, responder ----------
316 sub responder_send_command ($) {
318 return unless $we_are_responder;
319 # called even without $we_are_responder
320 printdebug ">> $command\n";
321 print PO $command, "\n" or die $!;
324 sub responder_send_file ($$) {
325 my ($keyword, $ourfn) = @_;
326 return unless $we_are_responder;
327 printdebug "]] $keyword $ourfn\n";
328 responder_send_command "file $keyword";
329 protocol_send_file \*PO, $ourfn;
332 sub responder_receive_files ($@) {
333 my ($keyword, @ourfns) = @_;
334 die unless $we_are_responder;
335 printdebug "[[ $keyword @ourfns\n";
336 responder_send_command "want $keyword";
337 foreach my $fn (@ourfns) {
338 protocol_receive_file \*PI, $fn;
341 protocol_expect { m/^files-end$/ } \*PI;
344 #---------- remote protocol support, initiator ----------
346 sub initiator_expect (&) {
348 protocol_expect { &$match } \*RO;
351 #---------- end remote code ----------
354 if ($we_are_responder) {
356 responder_send_command "progress ".length($m) or die $!;
357 print PO $m or die $!;
367 $ua = LWP::UserAgent->new();
371 progress "downloading $what...";
372 my $r = $ua->get(@_) or die $!;
373 return undef if $r->code == 404;
374 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
375 return $r->decoded_content(charset => 'none');
378 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
383 failedcmd @_ if system @_;
386 sub act_local () { return $dryrun_level <= 1; }
387 sub act_scary () { return !$dryrun_level; }
390 if (!$dryrun_level) {
391 progress "dgit ok: @_";
393 progress "would be ok: @_ (but dry run only)";
398 printcmd(\*STDERR,$debugprefix."#",@_);
401 sub runcmd_ordryrun {
409 sub runcmd_ordryrun_local {
418 my ($first_shell, @cmd) = @_;
419 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
422 our $helpmsg = <<END;
424 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
425 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
426 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
427 dgit [dgit-opts] push [dgit-opts] [suite]
428 dgit [dgit-opts] rpush build-host:build-dir ...
429 important dgit options:
430 -k<keyid> sign tag and package with <keyid> instead of default
431 --dry-run -n do not change anything, but go through the motions
432 --damp-run -L like --dry-run but make local changes, without signing
433 --new -N allow introducing a new package
434 --debug -D increase debug level
435 -c<name>=<value> set git config option (used directly by dgit too)
438 our $later_warning_msg = <<END;
439 Perhaps the upload is stuck in incoming. Using the version from git.
443 print STDERR "$us: @_\n", $helpmsg or die $!;
448 @ARGV or badusage "too few arguments";
449 return scalar shift @ARGV;
453 print $helpmsg or die $!;
457 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
459 our %defcfg = ('dgit.default.distro' => 'debian',
460 'dgit.default.username' => '',
461 'dgit.default.archive-query-default-component' => 'main',
462 'dgit.default.ssh' => 'ssh',
463 'dgit.default.archive-query' => 'madison:',
464 'dgit.default.sshpsql-dbname' => 'service=projectb',
465 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
466 'dgit-distro.debian.git-check' => 'url',
467 'dgit-distro.debian.git-check-suffix' => '/info/refs',
468 'dgit-distro.debian.new-private-pushers' => 't',
469 'dgit-distro.debian/push.git-url' => '',
470 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
471 'dgit-distro.debian/push.git-user-force' => 'dgit',
472 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
473 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
474 'dgit-distro.debian/push.git-create' => 'true',
475 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
476 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
477 # 'dgit-distro.debian.archive-query-tls-key',
478 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
479 # ^ this does not work because curl is broken nowadays
480 # Fixing #790093 properly will involve providing providing the key
481 # in some pacagke and maybe updating these paths.
483 # 'dgit-distro.debian.archive-query-tls-curl-args',
484 # '--ca-path=/etc/ssl/ca-debian',
485 # ^ this is a workaround but works (only) on DSA-administered machines
486 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
487 'dgit-distro.debian.git-url-suffix' => '',
488 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
489 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
490 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
491 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
492 'dgit-distro.ubuntu.git-check' => 'false',
493 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
494 'dgit-distro.test-dummy.ssh' => "$td/ssh",
495 'dgit-distro.test-dummy.username' => "alice",
496 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
497 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
498 'dgit-distro.test-dummy.git-url' => "$td/git",
499 'dgit-distro.test-dummy.git-host' => "git",
500 'dgit-distro.test-dummy.git-path' => "$td/git",
501 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
502 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
503 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
504 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
509 sub git_slurp_config () {
510 local ($debuglevel) = $debuglevel-2;
513 my @cmd = (@git, qw(config -z --get-regexp .*));
516 open GITS, "-|", @cmd or failedcmd @cmd;
519 printdebug "=> ", (messagequote $_), "\n";
521 push @{ $gitcfg{$`} }, $'; #';
525 or ($!==0 && $?==256)
529 sub git_get_config ($) {
532 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
535 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
541 return undef if $c =~ /RETURN-UNDEF/;
542 my $v = git_get_config($c);
543 return $v if defined $v;
544 my $dv = $defcfg{$c};
545 return $dv if defined $dv;
547 badcfg "need value for one of: @_\n".
548 "$us: distro or suite appears not to be (properly) supported";
551 sub access_basedistro () {
552 if (defined $idistro) {
555 return cfg("dgit-suite.$isuite.distro",
556 "dgit.default.distro");
560 sub access_quirk () {
561 # returns (quirk name, distro to use instead or undef, quirk-specific info)
562 my $basedistro = access_basedistro();
563 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
565 if (defined $backports_quirk) {
566 my $re = $backports_quirk;
567 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
569 $re =~ s/\%/([-0-9a-z_]+)/
570 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
571 if ($isuite =~ m/^$re$/) {
572 return ('backports',"$basedistro-backports",$1);
575 return ('none',undef);
580 sub parse_cfg_bool ($$$) {
581 my ($what,$def,$v) = @_;
584 $v =~ m/^[ty1]/ ? 1 :
585 $v =~ m/^[fn0]/ ? 0 :
586 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
589 sub access_forpush_config () {
590 my $d = access_basedistro();
594 parse_cfg_bool('new-private-pushers', 0,
595 cfg("dgit-distro.$d.new-private-pushers",
598 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
601 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
602 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
603 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
604 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
607 sub access_forpush () {
608 $access_forpush //= access_forpush_config();
609 return $access_forpush;
613 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
614 badcfg "pushing but distro is configured readonly"
615 if access_forpush_config() eq '0';
617 $supplementary_message = <<'END' unless $we_are_responder;
618 Push failed, before we got started.
619 You can retry the push, after fixing the problem, if you like.
621 finalise_opts_opts();
625 finalise_opts_opts();
628 sub supplementary_message ($) {
630 if (!$we_are_responder) {
631 $supplementary_message = $msg;
633 } elsif ($protovsn >= 3) {
634 responder_send_command "supplementary-message ".length($msg)
636 print PO $msg or die $!;
640 sub access_distros () {
641 # Returns list of distros to try, in order
644 # 0. `instead of' distro name(s) we have been pointed to
645 # 1. the access_quirk distro, if any
646 # 2a. the user's specified distro, or failing that } basedistro
647 # 2b. the distro calculated from the suite }
648 my @l = access_basedistro();
650 my (undef,$quirkdistro) = access_quirk();
651 unshift @l, $quirkdistro;
652 unshift @l, $instead_distro;
653 @l = grep { defined } @l;
655 if (access_forpush()) {
656 @l = map { ("$_/push", $_) } @l;
661 sub access_cfg_cfgs (@) {
664 # The nesting of these loops determines the search order. We put
665 # the key loop on the outside so that we search all the distros
666 # for each key, before going on to the next key. That means that
667 # if access_cfg is called with a more specific, and then a less
668 # specific, key, an earlier distro can override the less specific
669 # without necessarily overriding any more specific keys. (If the
670 # distro wants to override the more specific keys it can simply do
671 # so; whereas if we did the loop the other way around, it would be
672 # impossible to for an earlier distro to override a less specific
673 # key but not the more specific ones without restating the unknown
674 # values of the more specific keys.
677 # We have to deal with RETURN-UNDEF specially, so that we don't
678 # terminate the search prematurely.
680 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
683 foreach my $d (access_distros()) {
684 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
686 push @cfgs, map { "dgit.default.$_" } @realkeys;
693 my (@cfgs) = access_cfg_cfgs(@keys);
694 my $value = cfg(@cfgs);
698 sub access_cfg_bool ($$) {
699 my ($def, @keys) = @_;
700 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
703 sub string_to_ssh ($) {
705 if ($spec =~ m/\s/) {
706 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
712 sub access_cfg_ssh () {
713 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
714 if (!defined $gitssh) {
717 return string_to_ssh $gitssh;
721 sub access_runeinfo ($) {
723 return ": dgit ".access_basedistro()." $info ;";
726 sub access_someuserhost ($) {
728 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
729 defined($user) && length($user) or
730 $user = access_cfg("$some-user",'username');
731 my $host = access_cfg("$some-host");
732 return length($user) ? "$user\@$host" : $host;
735 sub access_gituserhost () {
736 return access_someuserhost('git');
739 sub access_giturl (;$) {
741 my $url = access_cfg('git-url','RETURN-UNDEF');
744 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
745 return undef unless defined $proto;
748 access_gituserhost().
749 access_cfg('git-path');
751 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
754 return "$url/$package$suffix";
757 sub parsecontrolfh ($$;$) {
758 my ($fh, $desc, $allowsigned) = @_;
759 our $dpkgcontrolhash_noissigned;
762 my %opts = ('name' => $desc);
763 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
764 $c = Dpkg::Control::Hash->new(%opts);
765 $c->parse($fh,$desc) or die "parsing of $desc failed";
766 last if $allowsigned;
767 last if $dpkgcontrolhash_noissigned;
768 my $issigned= $c->get_option('is_pgp_signed');
769 if (!defined $issigned) {
770 $dpkgcontrolhash_noissigned= 1;
771 seek $fh, 0,0 or die "seek $desc: $!";
772 } elsif ($issigned) {
773 fail "control file $desc is (already) PGP-signed. ".
774 " Note that dgit push needs to modify the .dsc and then".
775 " do the signature itself";
784 my ($file, $desc) = @_;
785 my $fh = new IO::Handle;
786 open $fh, '<', $file or die "$file: $!";
787 my $c = parsecontrolfh($fh,$desc);
788 $fh->error and die $!;
794 my ($dctrl,$field) = @_;
795 my $v = $dctrl->{$field};
796 return $v if defined $v;
797 fail "missing field $field in ".$v->get_option('name');
801 my $c = Dpkg::Control::Hash->new();
802 my $p = new IO::Handle;
803 my @cmd = (qw(dpkg-parsechangelog), @_);
804 open $p, '-|', @cmd or die $!;
806 $?=0; $!=0; close $p or failedcmd @cmd;
812 defined $d or fail "getcwd failed: $!";
818 sub archive_query ($) {
820 my $query = access_cfg('archive-query','RETURN-UNDEF');
821 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
824 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
827 sub pool_dsc_subpath ($$) {
828 my ($vsn,$component) = @_; # $package is implict arg
829 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
830 return "/pool/$component/$prefix/$package/".dscfn($vsn);
833 #---------- `ftpmasterapi' archive query method (nascent) ----------
835 sub archive_api_query_cmd ($) {
837 my @cmd = qw(curl -sS);
838 my $url = access_cfg('archive-query-url');
839 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
841 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
842 foreach my $key (split /\:/, $keys) {
843 $key =~ s/\%HOST\%/$host/g;
845 fail "for $url: stat $key: $!" unless $!==ENOENT;
848 fail "config requested specific TLS key but do not know".
849 " how to get curl to use exactly that EE key ($key)";
850 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
851 # # Sadly the above line does not work because of changes
852 # # to gnutls. The real fix for #790093 may involve
853 # # new curl options.
856 # Fixing #790093 properly will involve providing a value
857 # for this on clients.
858 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
859 push @cmd, split / /, $kargs if defined $kargs;
861 push @cmd, $url.$subpath;
867 my ($data, $subpath) = @_;
868 badcfg "ftpmasterapi archive query method takes no data part"
870 my @cmd = archive_api_query_cmd($subpath);
871 my $json = cmdoutput @cmd;
872 return decode_json($json);
875 sub canonicalise_suite_ftpmasterapi () {
876 my ($proto,$data) = @_;
877 my $suites = api_query($data, 'suites');
879 foreach my $entry (@$suites) {
881 my $v = $entry->{$_};
882 defined $v && $v eq $isuite;
884 push @matched, $entry;
886 fail "unknown suite $isuite" unless @matched;
889 @matched==1 or die "multiple matches for suite $isuite\n";
890 $cn = "$matched[0]{codename}";
891 defined $cn or die "suite $isuite info has no codename\n";
892 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
894 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
899 sub archive_query_ftpmasterapi () {
900 my ($proto,$data) = @_;
901 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
903 my $digester = Digest::SHA->new(256);
904 foreach my $entry (@$info) {
906 my $vsn = "$entry->{version}";
907 my ($ok,$msg) = version_check $vsn;
908 die "bad version: $msg\n" unless $ok;
909 my $component = "$entry->{component}";
910 $component =~ m/^$component_re$/ or die "bad component";
911 my $filename = "$entry->{filename}";
912 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
913 or die "bad filename";
914 my $sha256sum = "$entry->{sha256sum}";
915 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
916 push @rows, [ $vsn, "/pool/$component/$filename",
917 $digester, $sha256sum ];
919 die "bad ftpmaster api response: $@\n".Dumper($entry)
922 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
926 #---------- `madison' archive query method ----------
928 sub archive_query_madison {
929 return map { [ @$_[0..1] ] } madison_get_parse(@_);
932 sub madison_get_parse {
933 my ($proto,$data) = @_;
934 die unless $proto eq 'madison';
936 $data= access_cfg('madison-distro','RETURN-UNDEF');
937 $data //= access_basedistro();
939 $rmad{$proto,$data,$package} ||= cmdoutput
940 qw(rmadison -asource),"-s$isuite","-u$data",$package;
941 my $rmad = $rmad{$proto,$data,$package};
944 foreach my $l (split /\n/, $rmad) {
945 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
946 \s*( [^ \t|]+ )\s* \|
947 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
948 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
949 $1 eq $package or die "$rmad $package ?";
956 $component = access_cfg('archive-query-default-component');
958 $5 eq 'source' or die "$rmad ?";
959 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
961 return sort { -version_compare($a->[0],$b->[0]); } @out;
964 sub canonicalise_suite_madison {
965 # madison canonicalises for us
966 my @r = madison_get_parse(@_);
968 "unable to canonicalise suite using package $package".
969 " which does not appear to exist in suite $isuite;".
970 " --existing-package may help";
974 #---------- `sshpsql' archive query method ----------
977 my ($data,$runeinfo,$sql) = @_;
979 $data= access_someuserhost('sshpsql').':'.
980 access_cfg('sshpsql-dbname');
982 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
983 my ($userhost,$dbname) = ($`,$'); #';
985 my @cmd = (access_cfg_ssh, $userhost,
986 access_runeinfo("ssh-psql $runeinfo").
987 " export LC_MESSAGES=C; export LC_CTYPE=C;".
988 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
990 open P, "-|", @cmd or die $!;
993 printdebug(">|$_|\n");
996 $!=0; $?=0; close P or failedcmd @cmd;
998 my $nrows = pop @rows;
999 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1000 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1001 @rows = map { [ split /\|/, $_ ] } @rows;
1002 my $ncols = scalar @{ shift @rows };
1003 die if grep { scalar @$_ != $ncols } @rows;
1007 sub sql_injection_check {
1008 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1011 sub archive_query_sshpsql ($$) {
1012 my ($proto,$data) = @_;
1013 sql_injection_check $isuite, $package;
1014 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1015 SELECT source.version, component.name, files.filename, files.sha256sum
1017 JOIN src_associations ON source.id = src_associations.source
1018 JOIN suite ON suite.id = src_associations.suite
1019 JOIN dsc_files ON dsc_files.source = source.id
1020 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1021 JOIN component ON component.id = files_archive_map.component_id
1022 JOIN files ON files.id = dsc_files.file
1023 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1024 AND source.source='$package'
1025 AND files.filename LIKE '%.dsc';
1027 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1028 my $digester = Digest::SHA->new(256);
1030 my ($vsn,$component,$filename,$sha256sum) = @$_;
1031 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1036 sub canonicalise_suite_sshpsql ($$) {
1037 my ($proto,$data) = @_;
1038 sql_injection_check $isuite;
1039 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1040 SELECT suite.codename
1041 FROM suite where suite_name='$isuite' or codename='$isuite';
1043 @rows = map { $_->[0] } @rows;
1044 fail "unknown suite $isuite" unless @rows;
1045 die "ambiguous $isuite: @rows ?" if @rows>1;
1049 #---------- `dummycat' archive query method ----------
1051 sub canonicalise_suite_dummycat ($$) {
1052 my ($proto,$data) = @_;
1053 my $dpath = "$data/suite.$isuite";
1054 if (!open C, "<", $dpath) {
1055 $!==ENOENT or die "$dpath: $!";
1056 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1060 chomp or die "$dpath: $!";
1062 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1066 sub archive_query_dummycat ($$) {
1067 my ($proto,$data) = @_;
1068 canonicalise_suite();
1069 my $dpath = "$data/package.$csuite.$package";
1070 if (!open C, "<", $dpath) {
1071 $!==ENOENT or die "$dpath: $!";
1072 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1080 printdebug "dummycat query $csuite $package $dpath | $_\n";
1081 my @row = split /\s+/, $_;
1082 @row==2 or die "$dpath: $_ ?";
1085 C->error and die "$dpath: $!";
1087 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1090 #---------- archive query entrypoints and rest of program ----------
1092 sub canonicalise_suite () {
1093 return if defined $csuite;
1094 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1095 $csuite = archive_query('canonicalise_suite');
1096 if ($isuite ne $csuite) {
1097 progress "canonical suite name for $isuite is $csuite";
1101 sub get_archive_dsc () {
1102 canonicalise_suite();
1103 my @vsns = archive_query('archive_query');
1104 foreach my $vinfo (@vsns) {
1105 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1106 $dscurl = access_cfg('mirror').$subpath;
1107 $dscdata = url_get($dscurl);
1109 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1114 $digester->add($dscdata);
1115 my $got = $digester->hexdigest();
1117 fail "$dscurl has hash $got but".
1118 " archive told us to expect $digest";
1120 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1121 printdebug Dumper($dscdata) if $debuglevel>1;
1122 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1123 printdebug Dumper($dsc) if $debuglevel>1;
1124 my $fmt = getfield $dsc, 'Format';
1125 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1126 $dsc_checked = !!$digester;
1132 sub check_for_git ();
1133 sub check_for_git () {
1135 my $how = access_cfg('git-check');
1136 if ($how eq 'ssh-cmd') {
1138 (access_cfg_ssh, access_gituserhost(),
1139 access_runeinfo("git-check $package").
1140 " set -e; cd ".access_cfg('git-path').";".
1141 " if test -d $package.git; then echo 1; else echo 0; fi");
1142 my $r= cmdoutput @cmd;
1143 if ($r =~ m/^divert (\w+)$/) {
1145 my ($usedistro,) = access_distros();
1146 # NB that if we are pushing, $usedistro will be $distro/push
1147 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1148 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1149 progress "diverting to $divert (using config for $instead_distro)";
1150 return check_for_git();
1152 failedcmd @cmd unless $r =~ m/^[01]$/;
1154 } elsif ($how eq 'url') {
1155 my $prefix = access_cfg('git-check-url','git-url');
1156 my $suffix = access_cfg('git-check-suffix','git-suffix',
1157 'RETURN-UNDEF') // '.git';
1158 my $url = "$prefix/$package$suffix";
1159 my @cmd = (qw(curl -sS -I), $url);
1160 my $result = cmdoutput @cmd;
1161 $result =~ s/^\S+ 200 .*\n\r?\n//;
1162 # curl -sS -I with https_proxy prints
1163 # HTTP/1.0 200 Connection established
1164 $result =~ m/^\S+ (404|200) /s or
1165 fail "unexpected results from git check query - ".
1166 Dumper($prefix, $result);
1168 if ($code eq '404') {
1170 } elsif ($code eq '200') {
1175 } elsif ($how eq 'true') {
1177 } elsif ($how eq 'false') {
1180 badcfg "unknown git-check \`$how'";
1184 sub create_remote_git_repo () {
1185 my $how = access_cfg('git-create');
1186 if ($how eq 'ssh-cmd') {
1188 (access_cfg_ssh, access_gituserhost(),
1189 access_runeinfo("git-create $package").
1190 "set -e; cd ".access_cfg('git-path').";".
1191 " cp -a _template $package.git");
1192 } elsif ($how eq 'true') {
1195 badcfg "unknown git-create \`$how'";
1199 our ($dsc_hash,$lastpush_hash);
1201 our $ud = '.git/dgit/unpack';
1206 mkdir $ud or die $!;
1209 sub mktree_in_ud_here () {
1210 runcmd qw(git init -q);
1211 rmtree('.git/objects');
1212 symlink '../../../../objects','.git/objects' or die $!;
1215 sub git_write_tree () {
1216 my $tree = cmdoutput @git, qw(write-tree);
1217 $tree =~ m/^\w+$/ or die "$tree ?";
1221 sub remove_stray_gits () {
1222 my @gitscmd = qw(find -name .git -prune -print0);
1223 debugcmd "|",@gitscmd;
1224 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1229 print STDERR "$us: warning: removing from source package: ",
1230 (messagequote $_), "\n";
1234 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1237 sub mktree_in_ud_from_only_subdir () {
1238 # changes into the subdir
1240 die unless @dirs==1;
1241 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1245 remove_stray_gits();
1246 mktree_in_ud_here();
1247 my $format=get_source_format();
1248 if (madformat($format)) {
1251 runcmd @git, qw(add -Af);
1252 my $tree=git_write_tree();
1253 return ($tree,$dir);
1256 sub dsc_files_info () {
1257 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1258 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1259 ['Files', 'Digest::MD5', 'new()']) {
1260 my ($fname, $module, $method) = @$csumi;
1261 my $field = $dsc->{$fname};
1262 next unless defined $field;
1263 eval "use $module; 1;" or die $@;
1265 foreach (split /\n/, $field) {
1267 m/^(\w+) (\d+) (\S+)$/ or
1268 fail "could not parse .dsc $fname line \`$_'";
1269 my $digester = eval "$module"."->$method;" or die $@;
1274 Digester => $digester,
1279 fail "missing any supported Checksums-* or Files field in ".
1280 $dsc->get_option('name');
1284 map { $_->{Filename} } dsc_files_info();
1287 sub is_orig_file ($;$) {
1290 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1291 defined $base or return 1;
1295 sub make_commit ($) {
1297 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1300 sub clogp_authline ($) {
1302 my $author = getfield $clogp, 'Maintainer';
1303 $author =~ s#,.*##ms;
1304 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1305 my $authline = "$author $date";
1306 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1307 fail "unexpected commit author line format \`$authline'".
1308 " (was generated from changelog Maintainer field)";
1312 sub vendor_patches_distro ($$) {
1313 my ($checkdistro, $what) = @_;
1314 return unless defined $checkdistro;
1316 my $series = "debian/patches/\L$checkdistro\E.series";
1317 printdebug "checking for vendor-specific $series ($what)\n";
1319 if (!open SERIES, "<", $series) {
1320 die "$series $!" unless $!==ENOENT;
1329 Unfortunately, this source package uses a feature of dpkg-source where
1330 the same source package unpacks to different source code on different
1331 distros. dgit cannot safely operate on such packages on affected
1332 distros, because the meaning of source packages is not stable.
1334 Please ask the distro/maintainer to remove the distro-specific series
1335 files and use a different technique (if necessary, uploading actually
1336 different packages, if different distros are supposed to have
1340 fail "Found active distro-specific series file for".
1341 " $checkdistro ($what): $series, cannot continue";
1343 die "$series $!" if SERIES->error;
1347 sub check_for_vendor_patches () {
1348 # This dpkg-source feature doesn't seem to be documented anywhere!
1349 # But it can be found in the changelog (reformatted):
1351 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1352 # Author: Raphael Hertzog <hertzog@debian.org>
1353 # Date: Sun Oct 3 09:36:48 2010 +0200
1355 # dpkg-source: correctly create .pc/.quilt_series with alternate
1358 # If you have debian/patches/ubuntu.series and you were
1359 # unpacking the source package on ubuntu, quilt was still
1360 # directed to debian/patches/series instead of
1361 # debian/patches/ubuntu.series.
1363 # debian/changelog | 3 +++
1364 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1365 # 2 files changed, 6 insertions(+), 1 deletion(-)
1368 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1369 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1370 "Dpkg::Vendor \`current vendor'");
1371 vendor_patches_distro(access_basedistro(),
1372 "distro being accessed");
1375 sub generate_commit_from_dsc () {
1379 foreach my $fi (dsc_files_info()) {
1380 my $f = $fi->{Filename};
1381 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1383 link "../../../$f", $f
1387 complete_file_from_dsc('.', $fi);
1389 if (is_orig_file($f)) {
1390 link $f, "../../../../$f"
1396 my $dscfn = "$package.dsc";
1398 open D, ">", $dscfn or die "$dscfn: $!";
1399 print D $dscdata or die "$dscfn: $!";
1400 close D or die "$dscfn: $!";
1401 my @cmd = qw(dpkg-source);
1402 push @cmd, '--no-check' if $dsc_checked;
1403 push @cmd, qw(-x --), $dscfn;
1406 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1407 check_for_vendor_patches() if madformat($dsc->{format});
1408 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1409 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1410 my $authline = clogp_authline $clogp;
1411 my $changes = getfield $clogp, 'Changes';
1412 open C, ">../commit.tmp" or die $!;
1413 print C <<END or die $!;
1420 # imported from the archive
1423 my $outputhash = make_commit qw(../commit.tmp);
1424 my $cversion = getfield $clogp, 'Version';
1425 progress "synthesised git commit from .dsc $cversion";
1426 if ($lastpush_hash) {
1427 runcmd @git, qw(reset --hard), $lastpush_hash;
1428 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1429 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1430 my $oversion = getfield $oldclogp, 'Version';
1432 version_compare($oversion, $cversion);
1434 # git upload/ is earlier vsn than archive, use archive
1435 open C, ">../commit2.tmp" or die $!;
1436 print C <<END or die $!;
1438 parent $lastpush_hash
1443 Record $package ($cversion) in archive suite $csuite
1445 $outputhash = make_commit qw(../commit2.tmp);
1446 } elsif ($vcmp > 0) {
1447 print STDERR <<END or die $!;
1449 Version actually in archive: $cversion (older)
1450 Last allegedly pushed/uploaded: $oversion (newer or same)
1453 $outputhash = $lastpush_hash;
1455 $outputhash = $lastpush_hash;
1458 changedir '../../../..';
1459 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1460 'DGIT_ARCHIVE', $outputhash;
1461 cmdoutput @git, qw(log -n2), $outputhash;
1462 # ... gives git a chance to complain if our commit is malformed
1467 sub complete_file_from_dsc ($$) {
1468 our ($dstdir, $fi) = @_;
1469 # Ensures that we have, in $dir, the file $fi, with the correct
1470 # contents. (Downloading it from alongside $dscurl if necessary.)
1472 my $f = $fi->{Filename};
1473 my $tf = "$dstdir/$f";
1476 if (stat_exists $tf) {
1477 progress "using existing $f";
1480 $furl =~ s{/[^/]+$}{};
1482 die "$f ?" unless $f =~ m/^${package}_/;
1483 die "$f ?" if $f =~ m#/#;
1484 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1485 next if !act_local();
1489 open F, "<", "$tf" or die "$tf: $!";
1490 $fi->{Digester}->reset();
1491 $fi->{Digester}->addfile(*F);
1492 F->error and die $!;
1493 my $got = $fi->{Digester}->hexdigest();
1494 $got eq $fi->{Hash} or
1495 fail "file $f has hash $got but .dsc".
1496 " demands hash $fi->{Hash} ".
1497 ($downloaded ? "(got wrong file from archive!)"
1498 : "(perhaps you should delete this file?)");
1501 sub ensure_we_have_orig () {
1502 foreach my $fi (dsc_files_info()) {
1503 my $f = $fi->{Filename};
1504 next unless is_orig_file($f);
1505 complete_file_from_dsc('..', $fi);
1509 sub git_fetch_us () {
1510 my @specs = (fetchspec());
1512 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1514 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1517 my $tagpat = debiantag('*',access_basedistro);
1519 git_for_each_ref("refs/tags/".$tagpat, sub {
1520 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1521 printdebug "currently $fullrefname=$objid\n";
1522 $here{$fullrefname} = $objid;
1524 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1525 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1526 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1527 printdebug "offered $lref=$objid\n";
1528 if (!defined $here{$lref}) {
1529 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1530 runcmd_ordryrun_local @upd;
1531 } elsif ($here{$lref} eq $objid) {
1534 "Not updateting $lref from $here{$lref} to $objid.\n";
1539 sub fetch_from_archive () {
1540 # ensures that lrref() is what is actually in the archive,
1541 # one way or another
1545 foreach my $field (@ourdscfield) {
1546 $dsc_hash = $dsc->{$field};
1547 last if defined $dsc_hash;
1549 if (defined $dsc_hash) {
1550 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1552 progress "last upload to archive specified git hash";
1554 progress "last upload to archive has NO git hash";
1557 progress "no version available from the archive";
1560 $lastpush_hash = git_get_ref(lrref());
1561 printdebug "previous reference hash=$lastpush_hash\n";
1563 if (defined $dsc_hash) {
1564 fail "missing remote git history even though dsc has hash -".
1565 " could not find ref ".lrref().
1566 " (should have been fetched from ".access_giturl()."#".rrref().")"
1567 unless $lastpush_hash;
1569 ensure_we_have_orig();
1570 if ($dsc_hash eq $lastpush_hash) {
1571 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1572 print STDERR <<END or die $!;
1574 Git commit in archive is behind the last version allegedly pushed/uploaded.
1575 Commit referred to by archive: $dsc_hash
1576 Last allegedly pushed/uploaded: $lastpush_hash
1579 $hash = $lastpush_hash;
1581 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1582 "descendant of archive's .dsc hash ($dsc_hash)";
1585 $hash = generate_commit_from_dsc();
1586 } elsif ($lastpush_hash) {
1587 # only in git, not in the archive yet
1588 $hash = $lastpush_hash;
1589 print STDERR <<END or die $!;
1591 Package not found in the archive, but has allegedly been pushed using dgit.
1595 printdebug "nothing found!\n";
1596 if (defined $skew_warning_vsn) {
1597 print STDERR <<END or die $!;
1599 Warning: relevant archive skew detected.
1600 Archive allegedly contains $skew_warning_vsn
1601 But we were not able to obtain any version from the archive or git.
1607 printdebug "current hash=$hash\n";
1608 if ($lastpush_hash) {
1609 fail "not fast forward on last upload branch!".
1610 " (archive's version left in DGIT_ARCHIVE)"
1611 unless is_fast_fwd($lastpush_hash, $hash);
1613 if (defined $skew_warning_vsn) {
1615 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1616 my $clogf = ".git/dgit/changelog.tmp";
1617 runcmd shell_cmd "exec >$clogf",
1618 @git, qw(cat-file blob), "$hash:debian/changelog";
1619 my $gotclogp = parsechangelog("-l$clogf");
1620 my $got_vsn = getfield $gotclogp, 'Version';
1621 printdebug "SKEW CHECK GOT $got_vsn\n";
1622 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1623 print STDERR <<END or die $!;
1625 Warning: archive skew detected. Using the available version:
1626 Archive allegedly contains $skew_warning_vsn
1627 We were able to obtain only $got_vsn
1632 if ($lastpush_hash ne $hash) {
1633 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1637 dryrun_report @upd_cmd;
1643 sub set_local_git_config ($$) {
1645 runcmd @git, qw(config), $k, $v;
1648 sub setup_mergechangelogs (;$) {
1650 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1652 my $driver = 'dpkg-mergechangelogs';
1653 my $cb = "merge.$driver";
1654 my $attrs = '.git/info/attributes';
1655 ensuredir '.git/info';
1657 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1658 if (!open ATTRS, "<", $attrs) {
1659 $!==ENOENT or die "$attrs: $!";
1663 next if m{^debian/changelog\s};
1664 print NATTRS $_, "\n" or die $!;
1666 ATTRS->error and die $!;
1669 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1672 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1673 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1675 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1678 sub setup_useremail (;$) {
1680 return unless $always || access_cfg_bool(1, 'setup-useremail');
1683 my ($k, $envvar) = @_;
1684 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1685 return unless defined $v;
1686 set_local_git_config "user.$k", $v;
1689 $setup->('email', 'DEBEMAIL');
1690 $setup->('name', 'DEBFULLNAME');
1693 sub setup_new_tree () {
1694 setup_mergechangelogs();
1700 canonicalise_suite();
1701 badusage "dry run makes no sense with clone" unless act_local();
1702 my $hasgit = check_for_git();
1703 mkdir $dstdir or die "$dstdir $!";
1705 runcmd @git, qw(init -q);
1706 my $giturl = access_giturl(1);
1707 if (defined $giturl) {
1708 set_local_git_config "remote.$remotename.fetch", fetchspec();
1709 open H, "> .git/HEAD" or die $!;
1710 print H "ref: ".lref()."\n" or die $!;
1712 runcmd @git, qw(remote add), 'origin', $giturl;
1715 progress "fetching existing git history";
1717 runcmd_ordryrun_local @git, qw(fetch origin);
1719 progress "starting new git history";
1721 fetch_from_archive() or no_such_package;
1722 my $vcsgiturl = $dsc->{'Vcs-Git'};
1723 if (length $vcsgiturl) {
1724 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1725 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1728 runcmd @git, qw(reset --hard), lrref();
1729 printdone "ready for work in $dstdir";
1733 if (check_for_git()) {
1736 fetch_from_archive() or no_such_package();
1737 printdone "fetched into ".lrref();
1742 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1744 printdone "fetched to ".lrref()." and merged into HEAD";
1747 sub check_not_dirty () {
1748 return if $ignoredirty;
1749 my @cmd = (@git, qw(diff --quiet HEAD));
1751 $!=0; $?=0; system @cmd;
1752 return if !$! && !$?;
1753 if (!$! && $?==256) {
1754 fail "working tree is dirty (does not match HEAD)";
1760 sub commit_admin ($) {
1763 runcmd_ordryrun_local @git, qw(commit -m), $m;
1766 sub commit_quilty_patch () {
1767 my $output = cmdoutput @git, qw(status --porcelain);
1769 foreach my $l (split /\n/, $output) {
1770 next unless $l =~ m/\S/;
1771 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1775 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1777 progress "nothing quilty to commit, ok.";
1780 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1781 commit_admin "Commit Debian 3.0 (quilt) metadata";
1784 sub get_source_format () {
1785 if (!open F, "debian/source/format") {
1786 die $! unless $!==&ENOENT;
1790 F->error and die $!;
1797 return 0 unless $format eq '3.0 (quilt)';
1798 if ($quilt_mode eq 'nocheck') {
1799 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1802 progress "Format \`$format', checking/updating patch stack";
1806 sub push_parse_changelog ($) {
1809 my $clogp = Dpkg::Control::Hash->new();
1810 $clogp->load($clogpfn) or die;
1812 $package = getfield $clogp, 'Source';
1813 my $cversion = getfield $clogp, 'Version';
1814 my $tag = debiantag($cversion, access_basedistro);
1815 runcmd @git, qw(check-ref-format), $tag;
1817 my $dscfn = dscfn($cversion);
1819 return ($clogp, $cversion, $tag, $dscfn);
1822 sub push_parse_dsc ($$$) {
1823 my ($dscfn,$dscfnwhat, $cversion) = @_;
1824 $dsc = parsecontrol($dscfn,$dscfnwhat);
1825 my $dversion = getfield $dsc, 'Version';
1826 my $dscpackage = getfield $dsc, 'Source';
1827 ($dscpackage eq $package && $dversion eq $cversion) or
1828 fail "$dscfn is for $dscpackage $dversion".
1829 " but debian/changelog is for $package $cversion";
1832 sub push_mktag ($$$$$$$) {
1833 my ($head,$clogp,$tag,
1835 $changesfile,$changesfilewhat,
1838 $dsc->{$ourdscfield[0]} = $head;
1839 $dsc->save("$dscfn.tmp") or die $!;
1841 my $changes = parsecontrol($changesfile,$changesfilewhat);
1842 foreach my $field (qw(Source Distribution Version)) {
1843 $changes->{$field} eq $clogp->{$field} or
1844 fail "changes field $field \`$changes->{$field}'".
1845 " does not match changelog \`$clogp->{$field}'";
1848 my $cversion = getfield $clogp, 'Version';
1849 my $clogsuite = getfield $clogp, 'Distribution';
1851 # We make the git tag by hand because (a) that makes it easier
1852 # to control the "tagger" (b) we can do remote signing
1853 my $authline = clogp_authline $clogp;
1854 my $delibs = join(" ", "",@deliberatelies);
1855 my $declaredistro = access_basedistro();
1856 open TO, '>', $tfn->('.tmp') or die $!;
1857 print TO <<END or die $!;
1863 $package release $cversion for $clogsuite ($csuite) [dgit]
1864 [dgit distro=$declaredistro$delibs]
1866 foreach my $ref (sort keys %previously) {
1867 print TO <<END or die $!;
1868 [dgit previously:$ref=$previously{$ref}]
1874 my $tagobjfn = $tfn->('.tmp');
1876 if (!defined $keyid) {
1877 $keyid = access_cfg('keyid','RETURN-UNDEF');
1879 if (!defined $keyid) {
1880 $keyid = getfield $clogp, 'Maintainer';
1882 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1883 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1884 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1885 push @sign_cmd, $tfn->('.tmp');
1886 runcmd_ordryrun @sign_cmd;
1888 $tagobjfn = $tfn->('.signed.tmp');
1889 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1890 $tfn->('.tmp'), $tfn->('.tmp.asc');
1897 sub sign_changes ($) {
1898 my ($changesfile) = @_;
1900 my @debsign_cmd = @debsign;
1901 push @debsign_cmd, "-k$keyid" if defined $keyid;
1902 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1903 push @debsign_cmd, $changesfile;
1904 runcmd_ordryrun @debsign_cmd;
1909 my ($forceflag) = @_;
1910 printdebug "actually entering push\n";
1911 supplementary_message(<<'END');
1912 Push failed, while preparing your push.
1913 You can retry the push, after fixing the problem, if you like.
1917 access_giturl(); # check that success is vaguely likely
1919 my $clogpfn = ".git/dgit/changelog.822.tmp";
1920 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1922 responder_send_file('parsed-changelog', $clogpfn);
1924 my ($clogp, $cversion, $tag, $dscfn) =
1925 push_parse_changelog("$clogpfn");
1927 my $dscpath = "$buildproductsdir/$dscfn";
1928 stat_exists $dscpath or
1929 fail "looked for .dsc $dscfn, but $!;".
1930 " maybe you forgot to build";
1932 responder_send_file('dsc', $dscpath);
1934 push_parse_dsc($dscpath, $dscfn, $cversion);
1936 my $format = getfield $dsc, 'Format';
1937 printdebug "format $format\n";
1938 if (madformat($format)) {
1939 commit_quilty_patch();
1943 progress "checking that $dscfn corresponds to HEAD";
1944 runcmd qw(dpkg-source -x --),
1945 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1946 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1947 check_for_vendor_patches() if madformat($dsc->{format});
1948 changedir '../../../..';
1949 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1950 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1951 debugcmd "+",@diffcmd;
1953 my $r = system @diffcmd;
1956 fail "$dscfn specifies a different tree to your HEAD commit;".
1957 " perhaps you forgot to build".
1958 ($diffopt eq '--exit-code' ? "" :
1959 " (run with -D to see full diff output)");
1964 my $head = git_rev_parse('HEAD');
1965 if (!$changesfile) {
1966 my $multi = "$buildproductsdir/".
1967 "${package}_".(stripepoch $cversion)."_multi.changes";
1968 if (stat_exists "$multi") {
1969 $changesfile = $multi;
1971 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1972 my @cs = glob "$buildproductsdir/$pat";
1973 fail "failed to find unique changes file".
1974 " (looked for $pat in $buildproductsdir, or $multi);".
1975 " perhaps you need to use dgit -C"
1977 ($changesfile) = @cs;
1980 $changesfile = "$buildproductsdir/$changesfile";
1983 responder_send_file('changes',$changesfile);
1984 responder_send_command("param head $head");
1985 responder_send_command("param csuite $csuite");
1987 if (deliberately_not_fast_forward) {
1988 git_for_each_ref(lrfetchrefs, sub {
1989 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1990 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1991 responder_send_command("previously $rrefname=$objid");
1992 $previously{$rrefname} = $objid;
1996 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1999 supplementary_message(<<'END');
2000 Push failed, while signing the tag.
2001 You can retry the push, after fixing the problem, if you like.
2003 # If we manage to sign but fail to record it anywhere, it's fine.
2004 if ($we_are_responder) {
2005 $tagobjfn = $tfn->('.signed.tmp');
2006 responder_receive_files('signed-tag', $tagobjfn);
2009 push_mktag($head,$clogp,$tag,
2011 $changesfile,$changesfile,
2014 supplementary_message(<<'END');
2015 Push failed, *after* signing the tag.
2016 If you want to try again, you should use a new version number.
2019 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2020 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2021 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2023 supplementary_message(<<'END');
2024 Push failed, while updating the remote git repository - see messages above.
2025 If you want to try again, you should use a new version number.
2027 if (!check_for_git()) {
2028 create_remote_git_repo();
2030 runcmd_ordryrun @git, qw(push),access_giturl(),
2031 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2032 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2034 supplementary_message(<<'END');
2035 Push failed, after updating the remote git repository.
2036 If you want to try again, you must use a new version number.
2038 if ($we_are_responder) {
2039 my $dryrunsuffix = act_local() ? "" : ".tmp";
2040 responder_receive_files('signed-dsc-changes',
2041 "$dscpath$dryrunsuffix",
2042 "$changesfile$dryrunsuffix");
2045 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2047 progress "[new .dsc left in $dscpath.tmp]";
2049 sign_changes $changesfile;
2052 supplementary_message(<<'END');
2053 Push failed, while uploading package(s) to the archive server.
2054 You can retry the upload of exactly these same files with dput of:
2056 If that .changes file is broken, you will need to use a new version
2057 number for your next attempt at the upload.
2059 my $host = access_cfg('upload-host','RETURN-UNDEF');
2060 my @hostarg = defined($host) ? ($host,) : ();
2061 runcmd_ordryrun @dput, @hostarg, $changesfile;
2062 printdone "pushed and uploaded $cversion";
2064 supplementary_message('');
2065 responder_send_command("complete");
2072 badusage "-p is not allowed with clone; specify as argument instead"
2073 if defined $package;
2076 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2077 ($package,$isuite) = @ARGV;
2078 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2079 ($package,$dstdir) = @ARGV;
2080 } elsif (@ARGV==3) {
2081 ($package,$isuite,$dstdir) = @ARGV;
2083 badusage "incorrect arguments to dgit clone";
2085 $dstdir ||= "$package";
2087 if (stat_exists $dstdir) {
2088 fail "$dstdir already exists";
2092 if ($rmonerror && !$dryrun_level) {
2093 $cwd_remove= getcwd();
2095 return unless defined $cwd_remove;
2096 if (!chdir "$cwd_remove") {
2097 return if $!==&ENOENT;
2098 die "chdir $cwd_remove: $!";
2100 rmtree($dstdir) or die "remove $dstdir: $!\n";
2105 $cwd_remove = undef;
2108 sub branchsuite () {
2109 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2110 if ($branch =~ m#$lbranch_re#o) {
2117 sub fetchpullargs () {
2119 if (!defined $package) {
2120 my $sourcep = parsecontrol('debian/control','debian/control');
2121 $package = getfield $sourcep, 'Source';
2124 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2126 my $clogp = parsechangelog();
2127 $isuite = getfield $clogp, 'Distribution';
2129 canonicalise_suite();
2130 progress "fetching from suite $csuite";
2131 } elsif (@ARGV==1) {
2133 canonicalise_suite();
2135 badusage "incorrect arguments to dgit fetch or dgit pull";
2154 badusage "-p is not allowed with dgit push" if defined $package;
2156 my $clogp = parsechangelog();
2157 $package = getfield $clogp, 'Source';
2160 } elsif (@ARGV==1) {
2161 ($specsuite) = (@ARGV);
2163 badusage "incorrect arguments to dgit push";
2165 $isuite = getfield $clogp, 'Distribution';
2167 local ($package) = $existing_package; # this is a hack
2168 canonicalise_suite();
2170 canonicalise_suite();
2172 if (defined $specsuite &&
2173 $specsuite ne $isuite &&
2174 $specsuite ne $csuite) {
2175 fail "dgit push: changelog specifies $isuite ($csuite)".
2176 " but command line specifies $specsuite";
2178 supplementary_message(<<'END');
2179 Push failed, while checking state of the archive.
2180 You can retry the push, after fixing the problem, if you like.
2182 if (check_for_git()) {
2186 if (fetch_from_archive()) {
2187 if (is_fast_fwd(lrref(), 'HEAD')) {
2189 } elsif (deliberately_not_fast_forward) {
2192 fail "dgit push: HEAD is not a descendant".
2193 " of the archive's version.\n".
2194 "dgit: To overwrite its contents,".
2195 " use git merge -s ours ".lrref().".\n".
2196 "dgit: To rewind history, if permitted by the archive,".
2197 " use --deliberately-not-fast-forward";
2201 fail "package appears to be new in this suite;".
2202 " if this is intentional, use --new";
2207 #---------- remote commands' implementation ----------
2209 sub cmd_remote_push_build_host {
2210 my ($nrargs) = shift @ARGV;
2211 my (@rargs) = @ARGV[0..$nrargs-1];
2212 @ARGV = @ARGV[$nrargs..$#ARGV];
2214 my ($dir,$vsnwant) = @rargs;
2215 # vsnwant is a comma-separated list; we report which we have
2216 # chosen in our ready response (so other end can tell if they
2219 $we_are_responder = 1;
2220 $us .= " (build host)";
2224 open PI, "<&STDIN" or die $!;
2225 open STDIN, "/dev/null" or die $!;
2226 open PO, ">&STDOUT" or die $!;
2228 open STDOUT, ">&STDERR" or die $!;
2232 ($protovsn) = grep {
2233 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2234 } @rpushprotovsn_support;
2236 fail "build host has dgit rpush protocol versions ".
2237 (join ",", @rpushprotovsn_support).
2238 " but invocation host has $vsnwant"
2239 unless defined $protovsn;
2241 responder_send_command("dgit-remote-push-ready $protovsn");
2247 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2248 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2249 # a good error message)
2255 my $report = i_child_report();
2256 if (defined $report) {
2257 printdebug "($report)\n";
2258 } elsif ($i_child_pid) {
2259 printdebug "(killing build host child $i_child_pid)\n";
2260 kill 15, $i_child_pid;
2262 if (defined $i_tmp && !defined $initiator_tempdir) {
2264 eval { rmtree $i_tmp; };
2268 END { i_cleanup(); }
2271 my ($base,$selector,@args) = @_;
2272 $selector =~ s/\-/_/g;
2273 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2280 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2288 push @rargs, join ",", @rpushprotovsn_support;
2291 push @rdgit, @ropts;
2292 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2294 my @cmd = (@ssh, $host, shellquote @rdgit);
2297 if (defined $initiator_tempdir) {
2298 rmtree $initiator_tempdir;
2299 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2300 $i_tmp = $initiator_tempdir;
2304 $i_child_pid = open2(\*RO, \*RI, @cmd);
2306 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2307 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2308 $supplementary_message = '' unless $protovsn >= 3;
2310 my ($icmd,$iargs) = initiator_expect {
2311 m/^(\S+)(?: (.*))?$/;
2314 i_method "i_resp", $icmd, $iargs;
2318 sub i_resp_progress ($) {
2320 my $msg = protocol_read_bytes \*RO, $rhs;
2324 sub i_resp_supplementary_message ($) {
2326 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2329 sub i_resp_complete {
2330 my $pid = $i_child_pid;
2331 $i_child_pid = undef; # prevents killing some other process with same pid
2332 printdebug "waiting for build host child $pid...\n";
2333 my $got = waitpid $pid, 0;
2334 die $! unless $got == $pid;
2335 die "build host child failed $?" if $?;
2338 printdebug "all done\n";
2342 sub i_resp_file ($) {
2344 my $localname = i_method "i_localname", $keyword;
2345 my $localpath = "$i_tmp/$localname";
2346 stat_exists $localpath and
2347 badproto \*RO, "file $keyword ($localpath) twice";
2348 protocol_receive_file \*RO, $localpath;
2349 i_method "i_file", $keyword;
2354 sub i_resp_param ($) {
2355 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2359 sub i_resp_previously ($) {
2360 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2361 or badproto \*RO, "bad previously spec";
2362 my $r = system qw(git check-ref-format), $1;
2363 die "bad previously ref spec ($r)" if $r;
2364 $previously{$1} = $2;
2369 sub i_resp_want ($) {
2371 die "$keyword ?" if $i_wanted{$keyword}++;
2372 my @localpaths = i_method "i_want", $keyword;
2373 printdebug "[[ $keyword @localpaths\n";
2374 foreach my $localpath (@localpaths) {
2375 protocol_send_file \*RI, $localpath;
2377 print RI "files-end\n" or die $!;
2380 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2382 sub i_localname_parsed_changelog {
2383 return "remote-changelog.822";
2385 sub i_file_parsed_changelog {
2386 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2387 push_parse_changelog "$i_tmp/remote-changelog.822";
2388 die if $i_dscfn =~ m#/|^\W#;
2391 sub i_localname_dsc {
2392 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2397 sub i_localname_changes {
2398 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2399 $i_changesfn = $i_dscfn;
2400 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2401 return $i_changesfn;
2403 sub i_file_changes { }
2405 sub i_want_signed_tag {
2406 printdebug Dumper(\%i_param, $i_dscfn);
2407 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2408 && defined $i_param{'csuite'}
2409 or badproto \*RO, "premature desire for signed-tag";
2410 my $head = $i_param{'head'};
2411 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2413 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2415 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2418 push_mktag $head, $i_clogp, $i_tag,
2420 $i_changesfn, 'remote changes',
2421 sub { "tag$_[0]"; };
2426 sub i_want_signed_dsc_changes {
2427 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2428 sign_changes $i_changesfn;
2429 return ($i_dscfn, $i_changesfn);
2432 #---------- building etc. ----------
2438 #----- `3.0 (quilt)' handling -----
2440 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2442 sub quiltify_dpkg_commit ($$$;$) {
2443 my ($patchname,$author,$msg, $xinfo) = @_;
2447 my $descfn = ".git/dgit/quilt-description.tmp";
2448 open O, '>', $descfn or die "$descfn: $!";
2451 $msg =~ s/^\s+$/ ./mg;
2452 print O <<END or die $!;
2462 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2463 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2464 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2465 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2469 sub quiltify_trees_differ ($$) {
2471 # returns 1 iff the two tree objects differ other than in debian/
2473 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2474 my $diffs= cmdoutput @cmd;
2475 foreach my $f (split /\0/, $diffs) {
2476 next if $f eq 'debian';
2482 sub quiltify_tree_sentinelfiles ($) {
2483 # lists the `sentinel' files present in the tree
2485 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2486 qw(-- debian/rules debian/control);
2492 my ($clogp,$target) = @_;
2494 # Quilt patchification algorithm
2496 # We search backwards through the history of the main tree's HEAD
2497 # (T) looking for a start commit S whose tree object is identical
2498 # to to the patch tip tree (ie the tree corresponding to the
2499 # current dpkg-committed patch series). For these purposes
2500 # `identical' disregards anything in debian/ - this wrinkle is
2501 # necessary because dpkg-source treates debian/ specially.
2503 # We can only traverse edges where at most one of the ancestors'
2504 # trees differs (in changes outside in debian/). And we cannot
2505 # handle edges which change .pc/ or debian/patches. To avoid
2506 # going down a rathole we avoid traversing edges which introduce
2507 # debian/rules or debian/control. And we set a limit on the
2508 # number of edges we are willing to look at.
2510 # If we succeed, we walk forwards again. For each traversed edge
2511 # PC (with P parent, C child) (starting with P=S and ending with
2512 # C=T) to we do this:
2514 # - dpkg-source --commit with a patch name and message derived from C
2515 # After traversing PT, we git commit the changes which
2516 # should be contained within debian/patches.
2518 changedir '../fake';
2519 remove_stray_gits();
2520 mktree_in_ud_here();
2522 runcmd @git, 'add', '.';
2523 my $oldtiptree=git_write_tree();
2524 changedir '../work';
2526 # The search for the path S..T is breadth-first. We maintain a
2527 # todo list containing search nodes. A search node identifies a
2528 # commit, and looks something like this:
2530 # Commit => $git_commit_id,
2531 # Child => $c, # or undef if P=T
2532 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2533 # Nontrivial => true iff $p..$c has relevant changes
2540 my %considered; # saves being exponential on some weird graphs
2542 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2545 my ($search,$whynot) = @_;
2546 printdebug " search NOT $search->{Commit} $whynot\n";
2547 $search->{Whynot} = $whynot;
2548 push @nots, $search;
2549 no warnings qw(exiting);
2558 my $c = shift @todo;
2559 next if $considered{$c->{Commit}}++;
2561 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2563 printdebug "quiltify investigate $c->{Commit}\n";
2566 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2567 printdebug " search finished hooray!\n";
2572 if ($quilt_mode eq 'nofix') {
2573 fail "quilt fixup required but quilt mode is \`nofix'\n".
2574 "HEAD commit $c->{Commit} differs from tree implied by ".
2575 " debian/patches (tree object $oldtiptree)";
2577 if ($quilt_mode eq 'smash') {
2578 printdebug " search quitting smash\n";
2582 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2583 $not->($c, "has $c_sentinels not $t_sentinels")
2584 if $c_sentinels ne $t_sentinels;
2586 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2587 $commitdata =~ m/\n\n/;
2589 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2590 @parents = map { { Commit => $_, Child => $c } } @parents;
2592 $not->($c, "root commit") if !@parents;
2594 foreach my $p (@parents) {
2595 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2597 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2598 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2600 foreach my $p (@parents) {
2601 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2603 my @cmd= (@git, qw(diff-tree -r --name-only),
2604 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2605 my $patchstackchange = cmdoutput @cmd;
2606 if (length $patchstackchange) {
2607 $patchstackchange =~ s/\n/,/g;
2608 $not->($p, "changed $patchstackchange");
2611 printdebug " search queue P=$p->{Commit} ",
2612 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2618 printdebug "quiltify want to smash\n";
2621 my $x = $_[0]{Commit};
2622 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2625 my $reportnot = sub {
2627 my $s = $abbrev->($notp);
2628 my $c = $notp->{Child};
2629 $s .= "..".$abbrev->($c) if $c;
2630 $s .= ": ".$notp->{Whynot};
2633 if ($quilt_mode eq 'linear') {
2634 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2635 foreach my $notp (@nots) {
2636 print STDERR "$us: ", $reportnot->($notp), "\n";
2638 fail "quilt fixup naive history linearisation failed.\n".
2639 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2640 } elsif ($quilt_mode eq 'smash') {
2641 } elsif ($quilt_mode eq 'auto') {
2642 progress "quilt fixup cannot be linear, smashing...";
2644 die "$quilt_mode ?";
2649 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2651 quiltify_dpkg_commit "auto-$version-$target-$time",
2652 (getfield $clogp, 'Maintainer'),
2653 "Automatically generated patch ($clogp->{Version})\n".
2654 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2658 progress "quiltify linearisation planning successful, executing...";
2660 for (my $p = $sref_S;
2661 my $c = $p->{Child};
2663 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2664 next unless $p->{Nontrivial};
2666 my $cc = $c->{Commit};
2668 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2669 $commitdata =~ m/\n\n/ or die "$c ?";
2672 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2675 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2678 my $patchname = $title;
2679 $patchname =~ s/[.:]$//;
2680 $patchname =~ y/ A-Z/-a-z/;
2681 $patchname =~ y/-a-z0-9_.+=~//cd;
2682 $patchname =~ s/^\W/x-$&/;
2683 $patchname = substr($patchname,0,40);
2686 stat "debian/patches/$patchname$index";
2688 $!==ENOENT or die "$patchname$index $!";
2690 runcmd @git, qw(checkout -q), $cc;
2692 # We use the tip's changelog so that dpkg-source doesn't
2693 # produce complaining messages from dpkg-parsechangelog. None
2694 # of the information dpkg-source gets from the changelog is
2695 # actually relevant - it gets put into the original message
2696 # which dpkg-source provides our stunt editor, and then
2698 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2700 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2701 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2703 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2706 runcmd @git, qw(checkout -q master);
2709 sub build_maybe_quilt_fixup () {
2710 my $format=get_source_format;
2711 return unless madformat $format;
2714 check_for_vendor_patches();
2717 # - honour any existing .pc in case it has any strangeness
2718 # - determine the git commit corresponding to the tip of
2719 # the patch stack (if there is one)
2720 # - if there is such a git commit, convert each subsequent
2721 # git commit into a quilt patch with dpkg-source --commit
2722 # - otherwise convert all the differences in the tree into
2723 # a single git commit
2727 # Our git tree doesn't necessarily contain .pc. (Some versions of
2728 # dgit would include the .pc in the git tree.) If there isn't
2729 # one, we need to generate one by unpacking the patches that we
2732 # We first look for a .pc in the git tree. If there is one, we
2733 # will use it. (This is not the normal case.)
2735 # Otherwise need to regenerate .pc so that dpkg-source --commit
2736 # can work. We do this as follows:
2737 # 1. Collect all relevant .orig from parent directory
2738 # 2. Generate a debian.tar.gz out of
2739 # debian/{patches,rules,source/format}
2740 # 3. Generate a fake .dsc containing just these fields:
2741 # Format Source Version Files
2742 # 4. Extract the fake .dsc
2743 # Now the fake .dsc has a .pc directory.
2744 # (In fact we do this in every case, because in future we will
2745 # want to search for a good base commit for generating patches.)
2747 # Then we can actually do the dpkg-source --commit
2748 # 1. Make a new working tree with the same object
2749 # store as our main tree and check out the main
2751 # 2. Copy .pc from the fake's extraction, if necessary
2752 # 3. Run dpkg-source --commit
2753 # 4. If the result has changes to debian/, then
2754 # - git-add them them
2755 # - git-add .pc if we had a .pc in-tree
2757 # 5. If we had a .pc in-tree, delete it, and git-commit
2758 # 6. Back in the main tree, fast forward to the new HEAD
2760 my $clogp = parsechangelog();
2761 my $headref = git_rev_parse('HEAD');
2766 my $upstreamversion=$version;
2767 $upstreamversion =~ s/-[^-]*$//;
2769 my $fakeversion="$upstreamversion-~~DGITFAKE";
2771 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2772 print $fakedsc <<END or die $!;
2775 Version: $fakeversion
2779 my $dscaddfile=sub {
2782 my $md = new Digest::MD5;
2784 my $fh = new IO::File $b, '<' or die "$b $!";
2789 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2792 foreach my $f (<../../../../*>) { #/){
2793 my $b=$f; $b =~ s{.*/}{};
2794 next unless is_orig_file $b, srcfn $upstreamversion,'';
2795 link $f, $b or die "$b $!";
2799 my @files=qw(debian/source/format debian/rules);
2800 if (stat_exists '../../../debian/patches') {
2801 push @files, 'debian/patches';
2804 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2805 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2807 $dscaddfile->($debtar);
2808 close $fakedsc or die $!;
2810 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2812 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2813 rename $fakexdir, "fake" or die "$fakexdir $!";
2815 mkdir "work" or die $!;
2817 mktree_in_ud_here();
2818 runcmd @git, qw(reset --hard), $headref;
2821 if (stat_exists ".pc") {
2823 progress "Tree already contains .pc - will use it then delete it.";
2826 rename '../fake/.pc','.pc' or die $!;
2829 quiltify($clogp,$headref);
2831 if (!open P, '>>', ".pc/applied-patches") {
2832 $!==&ENOENT or die $!;
2837 commit_quilty_patch();
2839 if ($mustdeletepc) {
2840 runcmd @git, qw(rm -rqf .pc);
2841 commit_admin "Commit removal of .pc (quilt series tracking data)";
2844 changedir '../../../..';
2845 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2848 sub quilt_fixup_editor () {
2849 my $descfn = $ENV{$fakeeditorenv};
2850 my $editing = $ARGV[$#ARGV];
2851 open I1, '<', $descfn or die "$descfn: $!";
2852 open I2, '<', $editing or die "$editing: $!";
2853 unlink $editing or die "$editing: $!";
2854 open O, '>', $editing or die "$editing: $!";
2855 while (<I1>) { print O or die $!; } I1->error and die $!;
2858 $copying ||= m/^\-\-\- /;
2859 next unless $copying;
2862 I2->error and die $!;
2867 #----- other building -----
2870 if ($cleanmode eq 'dpkg-source') {
2871 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2872 } elsif ($cleanmode eq 'dpkg-source-d') {
2873 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2874 } elsif ($cleanmode eq 'git') {
2875 runcmd_ordryrun_local @git, qw(clean -xdf);
2876 } elsif ($cleanmode eq 'git-ff') {
2877 runcmd_ordryrun_local @git, qw(clean -xdff);
2878 } elsif ($cleanmode eq 'check') {
2879 my $leftovers = cmdoutput @git, qw(clean -xdn);
2880 if (length $leftovers) {
2881 print STDERR $leftovers, "\n" or die $!;
2882 fail "tree contains uncommitted files and --clean=check specified";
2884 } elsif ($cleanmode eq 'none') {
2891 badusage "clean takes no additional arguments" if @ARGV;
2898 badusage "-p is not allowed when building" if defined $package;
2901 my $clogp = parsechangelog();
2902 $isuite = getfield $clogp, 'Distribution';
2903 $package = getfield $clogp, 'Source';
2904 $version = getfield $clogp, 'Version';
2905 build_maybe_quilt_fixup();
2908 sub changesopts () {
2909 my @opts =@changesopts[1..$#changesopts];
2910 if (!defined $changes_since_version) {
2911 my @vsns = archive_query('archive_query');
2912 my @quirk = access_quirk();
2913 if ($quirk[0] eq 'backports') {
2914 local $isuite = $quirk[2];
2916 canonicalise_suite();
2917 push @vsns, archive_query('archive_query');
2920 @vsns = map { $_->[0] } @vsns;
2921 @vsns = sort { -version_compare($a, $b) } @vsns;
2922 $changes_since_version = $vsns[0];
2923 progress "changelog will contain changes since $vsns[0]";
2925 $changes_since_version = '_';
2926 progress "package seems new, not specifying -v<version>";
2929 if ($changes_since_version ne '_') {
2930 unshift @opts, "-v$changes_since_version";
2935 sub massage_dbp_args ($) {
2937 return unless $cleanmode =~ m/git|none/;
2938 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2939 my @newcmd = shift @$cmd;
2940 # -nc has the side effect of specifying -b if nothing else specified
2941 push @newcmd, '-nc';
2942 # and some combinations of -S, -b, et al, are errors, rather than
2943 # later simply overriding earlier
2944 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2945 push @newcmd, @$cmd;
2951 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2952 massage_dbp_args \@dbp;
2953 runcmd_ordryrun_local @dbp;
2954 printdone "build successful\n";
2959 my @dbp = @dpkgbuildpackage;
2960 massage_dbp_args \@dbp;
2962 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2963 "--git-builder=@dbp");
2964 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2965 canonicalise_suite();
2966 push @cmd, "--git-debian-branch=".lbranch();
2968 push @cmd, changesopts();
2969 runcmd_ordryrun_local @cmd, @ARGV;
2970 printdone "build successful\n";
2972 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
2976 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2977 $dscfn = dscfn($version);
2978 if ($cleanmode eq 'dpkg-source') {
2979 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2981 } elsif ($cleanmode eq 'dpkg-source-d') {
2982 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2985 my $pwd = must_getcwd();
2986 my $leafdir = basename $pwd;
2988 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2990 runcmd_ordryrun_local qw(sh -ec),
2991 'exec >$1; shift; exec "$@"','x',
2992 "../$sourcechanges",
2993 @dpkggenchanges, qw(-S), changesopts();
2997 sub cmd_build_source {
2998 badusage "build-source takes no additional arguments" if @ARGV;
3000 printdone "source built, results in $dscfn and $sourcechanges";
3006 my $pat = "${package}_".(stripepoch $version)."_*.changes";
3008 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3009 stat_exists $sourcechanges
3010 or fail "$sourcechanges (in parent directory): $!";
3011 foreach my $cf (glob $pat) {
3012 next if $cf eq $sourcechanges;
3013 unlink $cf or fail "remove $cf: $!";
3016 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
3017 my @changesfiles = glob $pat;
3018 @changesfiles = sort {
3019 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3022 fail "wrong number of different changes files (@changesfiles)"
3023 unless @changesfiles;
3024 runcmd_ordryrun_local @mergechanges, @changesfiles;
3025 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
3027 stat_exists $multichanges or fail "$multichanges: $!";
3029 printdone "build successful, results in $multichanges\n" or die $!;
3032 sub cmd_quilt_fixup {
3033 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3034 my $clogp = parsechangelog();
3035 $version = getfield $clogp, 'Version';
3036 $package = getfield $clogp, 'Source';
3037 build_maybe_quilt_fixup();
3040 sub cmd_archive_api_query {
3041 badusage "need only 1 subpath argument" unless @ARGV==1;
3042 my ($subpath) = @ARGV;
3043 my @cmd = archive_api_query_cmd($subpath);
3045 exec @cmd or fail "exec curl: $!\n";
3048 sub cmd_clone_dgit_repos_server {
3049 badusage "need destination argument" unless @ARGV==1;
3050 my ($destdir) = @ARGV;
3051 $package = '_dgit-repos-server';
3052 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3054 exec @cmd or fail "exec git clone: $!\n";
3057 sub cmd_setup_mergechangelogs {
3058 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3059 setup_mergechangelogs(1);
3062 sub cmd_setup_useremail {
3063 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3067 sub cmd_setup_new_tree {
3068 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3072 #---------- argument parsing and main program ----------
3075 print "dgit version $our_version\n" or die $!;
3082 if (defined $ENV{'DGIT_SSH'}) {
3083 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3084 } elsif (defined $ENV{'GIT_SSH'}) {
3085 @ssh = ($ENV{'GIT_SSH'});
3089 last unless $ARGV[0] =~ m/^-/;
3093 if (m/^--dry-run$/) {
3096 } elsif (m/^--damp-run$/) {
3099 } elsif (m/^--no-sign$/) {
3102 } elsif (m/^--help$/) {
3104 } elsif (m/^--version$/) {
3106 } elsif (m/^--new$/) {
3109 } elsif (m/^--since-version=([^_]+|_)$/) {
3111 $changes_since_version = $1;
3112 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3113 ($om = $opts_opt_map{$1}) &&
3117 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3118 !$opts_opt_cmdonly{$1} &&
3119 ($om = $opts_opt_map{$1})) {
3122 } elsif (m/^--existing-package=(.*)/s) {
3124 $existing_package = $1;
3125 } elsif (m/^--initiator-tempdir=(.*)/s) {
3126 $initiator_tempdir = $1;
3127 $initiator_tempdir =~ m#^/# or
3128 badusage "--initiator-tempdir must be used specify an".
3129 " absolute, not relative, directory."
3130 } elsif (m/^--distro=(.*)/s) {
3133 } elsif (m/^--build-products-dir=(.*)/s) {
3135 $buildproductsdir = $1;
3136 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3139 } elsif (m/^--clean=(.*)$/s) {
3140 badusage "unknown cleaning mode \`$1'";
3141 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3144 } elsif (m/^--quilt=(.*)$/s) {
3145 badusage "unknown quilt fixup mode \`$1'";
3146 } elsif (m/^--ignore-dirty$/s) {
3149 } elsif (m/^--no-quilt-fixup$/s) {
3151 $quilt_mode = 'nocheck';
3152 } elsif (m/^--no-rm-on-error$/s) {
3155 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3157 push @deliberatelies, $&;
3159 badusage "unknown long option \`$_'";
3166 } elsif (s/^-L/-/) {
3169 } elsif (s/^-h/-/) {
3171 } elsif (s/^-D/-/) {
3175 } elsif (s/^-N/-/) {
3178 } elsif (s/^-v([^_]+|_)$//s) {
3180 $changes_since_version = $1;
3183 push @changesopts, $_;
3185 } elsif (s/^-c(.*=.*)//s) {
3187 push @git, '-c', $1;
3188 } elsif (s/^-d(.+)//s) {
3191 } elsif (s/^-C(.+)//s) {
3194 if ($changesfile =~ s#^(.*)/##) {
3195 $buildproductsdir = $1;
3197 } elsif (s/^-k(.+)//s) {
3199 } elsif (m/^-[vdCk]$/) {
3201 "option \`$_' requires an argument (and no space before the argument)";
3202 } elsif (s/^-wn$//s) {
3204 $cleanmode = 'none';
3205 } elsif (s/^-wg$//s) {
3208 } elsif (s/^-wgf$//s) {
3210 $cleanmode = 'git-ff';
3211 } elsif (s/^-wd$//s) {
3213 $cleanmode = 'dpkg-source';
3214 } elsif (s/^-wdd$//s) {
3216 $cleanmode = 'dpkg-source-d';
3217 } elsif (s/^-wc$//s) {
3219 $cleanmode = 'check';
3221 badusage "unknown short option \`$_'";
3228 sub finalise_opts_opts () {
3229 foreach my $k (keys %opts_opt_map) {
3230 my $om = $opts_opt_map{$k};
3232 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3234 badcfg "cannot set command for $k"
3235 unless length $om->[0];
3239 foreach my $c (access_cfg_cfgs("opts-$k")) {
3240 my $vl = $gitcfg{$c};
3241 printdebug "CL $c ",
3242 ($vl ? join " ", map { shellquote } @$vl : ""),
3243 "\n" if $debuglevel >= 4;
3245 badcfg "cannot configure options for $k"
3246 if $opts_opt_cmdonly{$k};
3247 my $insertpos = $opts_cfg_insertpos{$k};
3248 @$om = ( @$om[0..$insertpos-1],
3250 @$om[$insertpos..$#$om] );
3255 if ($ENV{$fakeeditorenv}) {
3257 quilt_fixup_editor();
3263 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3264 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3265 if $dryrun_level == 1;
3267 print STDERR $helpmsg or die $!;
3270 my $cmd = shift @ARGV;
3273 if (!defined $quilt_mode) {
3274 local $access_forpush;
3275 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3276 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3278 $quilt_mode =~ m/^($quilt_modes_re)$/
3279 or badcfg "unknown quilt-mode \`$quilt_mode'";
3283 my $fn = ${*::}{"cmd_$cmd"};
3284 $fn or badusage "unknown operation $cmd";