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';
61 our $changes_since_version;
64 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
65 our $we_are_responder;
66 our $initiator_tempdir;
67 our $patches_applied_dirtily = 00;
69 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
71 our $suite_re = '[-+.0-9a-z]+';
72 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
74 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
75 our $splitbraincache = 'dgit-intern/quilt-cache';
78 our (@dget) = qw(dget);
79 our (@curl) = qw(curl -f);
80 our (@dput) = qw(dput);
81 our (@debsign) = qw(debsign);
83 our (@sbuild) = qw(sbuild);
85 our (@dgit) = qw(dgit);
86 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
87 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
88 our (@dpkggenchanges) = qw(dpkg-genchanges);
89 our (@mergechanges) = qw(mergechanges -f);
91 our (@changesopts) = ('');
93 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
96 'debsign' => \@debsign,
102 'dpkg-source' => \@dpkgsource,
103 'dpkg-buildpackage' => \@dpkgbuildpackage,
104 'dpkg-genchanges' => \@dpkggenchanges,
106 'ch' => \@changesopts,
107 'mergechanges' => \@mergechanges);
109 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
110 our %opts_cfg_insertpos = map {
112 scalar @{ $opts_opt_map{$_} }
113 } keys %opts_opt_map;
115 sub finalise_opts_opts();
121 our $supplementary_message = '';
122 our $need_split_build_invocation = 0;
123 our $split_brain = 0;
127 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
130 our $remotename = 'dgit';
131 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
135 sub lbranch () { return "$branchprefix/$csuite"; }
136 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
137 sub lref () { return "refs/heads/".lbranch(); }
138 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
139 sub rrref () { return server_ref($csuite); }
141 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
151 return "${package}_".(stripepoch $vsn).$sfx
156 return srcfn($vsn,".dsc");
159 sub changespat ($;$) {
160 my ($vsn, $arch) = @_;
161 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
170 foreach my $f (@end) {
172 print STDERR "$us: cleanup: $@" if length $@;
176 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
178 sub no_such_package () {
179 print STDERR "$us: package $package does not exist in suite $isuite\n";
185 return "+".rrref().":".lrref();
190 printdebug "CD $newdir\n";
191 chdir $newdir or die "chdir: $newdir: $!";
194 sub deliberately ($) {
196 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
199 sub deliberately_not_fast_forward () {
200 foreach (qw(not-fast-forward fresh-repo)) {
201 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
205 sub quiltmode_splitbrain () {
206 $quilt_mode =~ m/gbp|dpm|unapplied/;
209 #---------- remote protocol support, common ----------
211 # remote push initiator/responder protocol:
212 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
213 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
214 # < dgit-remote-push-ready <actual-proto-vsn>
216 # > file parsed-changelog
217 # [indicates that output of dpkg-parsechangelog follows]
218 # > data-block NBYTES
219 # > [NBYTES bytes of data (no newline)]
220 # [maybe some more blocks]
232 # [indicates that signed tag is wanted]
233 # < data-block NBYTES
234 # < [NBYTES bytes of data (no newline)]
235 # [maybe some more blocks]
239 # > want signed-dsc-changes
240 # < data-block NBYTES [transfer of signed dsc]
242 # < data-block NBYTES [transfer of signed changes]
250 sub i_child_report () {
251 # Sees if our child has died, and reap it if so. Returns a string
252 # describing how it died if it failed, or undef otherwise.
253 return undef unless $i_child_pid;
254 my $got = waitpid $i_child_pid, WNOHANG;
255 return undef if $got <= 0;
256 die unless $got == $i_child_pid;
257 $i_child_pid = undef;
258 return undef unless $?;
259 return "build host child ".waitstatusmsg();
264 fail "connection lost: $!" if $fh->error;
265 fail "protocol violation; $m not expected";
268 sub badproto_badread ($$) {
270 fail "connection lost: $!" if $!;
271 my $report = i_child_report();
272 fail $report if defined $report;
273 badproto $fh, "eof (reading $wh)";
276 sub protocol_expect (&$) {
277 my ($match, $fh) = @_;
280 defined && chomp or badproto_badread $fh, "protocol message";
288 badproto $fh, "\`$_'";
291 sub protocol_send_file ($$) {
292 my ($fh, $ourfn) = @_;
293 open PF, "<", $ourfn or die "$ourfn: $!";
296 my $got = read PF, $d, 65536;
297 die "$ourfn: $!" unless defined $got;
299 print $fh "data-block ".length($d)."\n" or die $!;
300 print $fh $d or die $!;
302 PF->error and die "$ourfn $!";
303 print $fh "data-end\n" or die $!;
307 sub protocol_read_bytes ($$) {
308 my ($fh, $nbytes) = @_;
309 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
311 my $got = read $fh, $d, $nbytes;
312 $got==$nbytes or badproto_badread $fh, "data block";
316 sub protocol_receive_file ($$) {
317 my ($fh, $ourfn) = @_;
318 printdebug "() $ourfn\n";
319 open PF, ">", $ourfn or die "$ourfn: $!";
321 my ($y,$l) = protocol_expect {
322 m/^data-block (.*)$/ ? (1,$1) :
323 m/^data-end$/ ? (0,) :
327 my $d = protocol_read_bytes $fh, $l;
328 print PF $d or die $!;
333 #---------- remote protocol support, responder ----------
335 sub responder_send_command ($) {
337 return unless $we_are_responder;
338 # called even without $we_are_responder
339 printdebug ">> $command\n";
340 print PO $command, "\n" or die $!;
343 sub responder_send_file ($$) {
344 my ($keyword, $ourfn) = @_;
345 return unless $we_are_responder;
346 printdebug "]] $keyword $ourfn\n";
347 responder_send_command "file $keyword";
348 protocol_send_file \*PO, $ourfn;
351 sub responder_receive_files ($@) {
352 my ($keyword, @ourfns) = @_;
353 die unless $we_are_responder;
354 printdebug "[[ $keyword @ourfns\n";
355 responder_send_command "want $keyword";
356 foreach my $fn (@ourfns) {
357 protocol_receive_file \*PI, $fn;
360 protocol_expect { m/^files-end$/ } \*PI;
363 #---------- remote protocol support, initiator ----------
365 sub initiator_expect (&) {
367 protocol_expect { &$match } \*RO;
370 #---------- end remote code ----------
373 if ($we_are_responder) {
375 responder_send_command "progress ".length($m) or die $!;
376 print PO $m or die $!;
386 $ua = LWP::UserAgent->new();
390 progress "downloading $what...";
391 my $r = $ua->get(@_) or die $!;
392 return undef if $r->code == 404;
393 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
394 return $r->decoded_content(charset => 'none');
397 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
402 failedcmd @_ if system @_;
405 sub act_local () { return $dryrun_level <= 1; }
406 sub act_scary () { return !$dryrun_level; }
409 if (!$dryrun_level) {
410 progress "dgit ok: @_";
412 progress "would be ok: @_ (but dry run only)";
417 printcmd(\*STDERR,$debugprefix."#",@_);
420 sub runcmd_ordryrun {
428 sub runcmd_ordryrun_local {
437 my ($first_shell, @cmd) = @_;
438 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
441 our $helpmsg = <<END;
443 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
444 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
445 dgit [dgit-opts] build [dpkg-buildpackage-opts]
446 dgit [dgit-opts] sbuild [sbuild-opts]
447 dgit [dgit-opts] push [dgit-opts] [suite]
448 dgit [dgit-opts] rpush build-host:build-dir ...
449 important dgit options:
450 -k<keyid> sign tag and package with <keyid> instead of default
451 --dry-run -n do not change anything, but go through the motions
452 --damp-run -L like --dry-run but make local changes, without signing
453 --new -N allow introducing a new package
454 --debug -D increase debug level
455 -c<name>=<value> set git config option (used directly by dgit too)
458 our $later_warning_msg = <<END;
459 Perhaps the upload is stuck in incoming. Using the version from git.
463 print STDERR "$us: @_\n", $helpmsg or die $!;
468 @ARGV or badusage "too few arguments";
469 return scalar shift @ARGV;
473 print $helpmsg or die $!;
477 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
479 our %defcfg = ('dgit.default.distro' => 'debian',
480 'dgit.default.username' => '',
481 'dgit.default.archive-query-default-component' => 'main',
482 'dgit.default.ssh' => 'ssh',
483 'dgit.default.archive-query' => 'madison:',
484 'dgit.default.sshpsql-dbname' => 'service=projectb',
485 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
486 'dgit-distro.debian.git-check' => 'url',
487 'dgit-distro.debian.git-check-suffix' => '/info/refs',
488 'dgit-distro.debian.new-private-pushers' => 't',
489 'dgit-distro.debian/push.git-url' => '',
490 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
491 'dgit-distro.debian/push.git-user-force' => 'dgit',
492 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
493 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
494 'dgit-distro.debian/push.git-create' => 'true',
495 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
496 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
497 # 'dgit-distro.debian.archive-query-tls-key',
498 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
499 # ^ this does not work because curl is broken nowadays
500 # Fixing #790093 properly will involve providing providing the key
501 # in some pacagke and maybe updating these paths.
503 # 'dgit-distro.debian.archive-query-tls-curl-args',
504 # '--ca-path=/etc/ssl/ca-debian',
505 # ^ this is a workaround but works (only) on DSA-administered machines
506 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
507 'dgit-distro.debian.git-url-suffix' => '',
508 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
509 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
510 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
511 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
512 'dgit-distro.ubuntu.git-check' => 'false',
513 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
514 'dgit-distro.test-dummy.ssh' => "$td/ssh",
515 'dgit-distro.test-dummy.username' => "alice",
516 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
517 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
518 'dgit-distro.test-dummy.git-url' => "$td/git",
519 'dgit-distro.test-dummy.git-host' => "git",
520 'dgit-distro.test-dummy.git-path' => "$td/git",
521 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
522 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
523 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
524 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
529 sub git_slurp_config () {
530 local ($debuglevel) = $debuglevel-2;
533 my @cmd = (@git, qw(config -z --get-regexp .*));
536 open GITS, "-|", @cmd or failedcmd @cmd;
539 printdebug "=> ", (messagequote $_), "\n";
541 push @{ $gitcfg{$`} }, $'; #';
545 or ($!==0 && $?==256)
549 sub git_get_config ($) {
552 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
555 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
561 return undef if $c =~ /RETURN-UNDEF/;
562 my $v = git_get_config($c);
563 return $v if defined $v;
564 my $dv = $defcfg{$c};
565 return $dv if defined $dv;
567 badcfg "need value for one of: @_\n".
568 "$us: distro or suite appears not to be (properly) supported";
571 sub access_basedistro () {
572 if (defined $idistro) {
575 return cfg("dgit-suite.$isuite.distro",
576 "dgit.default.distro");
580 sub access_quirk () {
581 # returns (quirk name, distro to use instead or undef, quirk-specific info)
582 my $basedistro = access_basedistro();
583 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
585 if (defined $backports_quirk) {
586 my $re = $backports_quirk;
587 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
589 $re =~ s/\%/([-0-9a-z_]+)/
590 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
591 if ($isuite =~ m/^$re$/) {
592 return ('backports',"$basedistro-backports",$1);
595 return ('none',undef);
600 sub parse_cfg_bool ($$$) {
601 my ($what,$def,$v) = @_;
604 $v =~ m/^[ty1]/ ? 1 :
605 $v =~ m/^[fn0]/ ? 0 :
606 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
609 sub access_forpush_config () {
610 my $d = access_basedistro();
614 parse_cfg_bool('new-private-pushers', 0,
615 cfg("dgit-distro.$d.new-private-pushers",
618 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
621 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
622 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
623 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
624 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
627 sub access_forpush () {
628 $access_forpush //= access_forpush_config();
629 return $access_forpush;
633 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
634 badcfg "pushing but distro is configured readonly"
635 if access_forpush_config() eq '0';
637 $supplementary_message = <<'END' unless $we_are_responder;
638 Push failed, before we got started.
639 You can retry the push, after fixing the problem, if you like.
641 finalise_opts_opts();
645 finalise_opts_opts();
648 sub supplementary_message ($) {
650 if (!$we_are_responder) {
651 $supplementary_message = $msg;
653 } elsif ($protovsn >= 3) {
654 responder_send_command "supplementary-message ".length($msg)
656 print PO $msg or die $!;
660 sub access_distros () {
661 # Returns list of distros to try, in order
664 # 0. `instead of' distro name(s) we have been pointed to
665 # 1. the access_quirk distro, if any
666 # 2a. the user's specified distro, or failing that } basedistro
667 # 2b. the distro calculated from the suite }
668 my @l = access_basedistro();
670 my (undef,$quirkdistro) = access_quirk();
671 unshift @l, $quirkdistro;
672 unshift @l, $instead_distro;
673 @l = grep { defined } @l;
675 if (access_forpush()) {
676 @l = map { ("$_/push", $_) } @l;
681 sub access_cfg_cfgs (@) {
684 # The nesting of these loops determines the search order. We put
685 # the key loop on the outside so that we search all the distros
686 # for each key, before going on to the next key. That means that
687 # if access_cfg is called with a more specific, and then a less
688 # specific, key, an earlier distro can override the less specific
689 # without necessarily overriding any more specific keys. (If the
690 # distro wants to override the more specific keys it can simply do
691 # so; whereas if we did the loop the other way around, it would be
692 # impossible to for an earlier distro to override a less specific
693 # key but not the more specific ones without restating the unknown
694 # values of the more specific keys.
697 # We have to deal with RETURN-UNDEF specially, so that we don't
698 # terminate the search prematurely.
700 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
703 foreach my $d (access_distros()) {
704 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
706 push @cfgs, map { "dgit.default.$_" } @realkeys;
713 my (@cfgs) = access_cfg_cfgs(@keys);
714 my $value = cfg(@cfgs);
718 sub access_cfg_bool ($$) {
719 my ($def, @keys) = @_;
720 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
723 sub string_to_ssh ($) {
725 if ($spec =~ m/\s/) {
726 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
732 sub access_cfg_ssh () {
733 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
734 if (!defined $gitssh) {
737 return string_to_ssh $gitssh;
741 sub access_runeinfo ($) {
743 return ": dgit ".access_basedistro()." $info ;";
746 sub access_someuserhost ($) {
748 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
749 defined($user) && length($user) or
750 $user = access_cfg("$some-user",'username');
751 my $host = access_cfg("$some-host");
752 return length($user) ? "$user\@$host" : $host;
755 sub access_gituserhost () {
756 return access_someuserhost('git');
759 sub access_giturl (;$) {
761 my $url = access_cfg('git-url','RETURN-UNDEF');
764 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
765 return undef unless defined $proto;
768 access_gituserhost().
769 access_cfg('git-path');
771 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
774 return "$url/$package$suffix";
777 sub parsecontrolfh ($$;$) {
778 my ($fh, $desc, $allowsigned) = @_;
779 our $dpkgcontrolhash_noissigned;
782 my %opts = ('name' => $desc);
783 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
784 $c = Dpkg::Control::Hash->new(%opts);
785 $c->parse($fh,$desc) or die "parsing of $desc failed";
786 last if $allowsigned;
787 last if $dpkgcontrolhash_noissigned;
788 my $issigned= $c->get_option('is_pgp_signed');
789 if (!defined $issigned) {
790 $dpkgcontrolhash_noissigned= 1;
791 seek $fh, 0,0 or die "seek $desc: $!";
792 } elsif ($issigned) {
793 fail "control file $desc is (already) PGP-signed. ".
794 " Note that dgit push needs to modify the .dsc and then".
795 " do the signature itself";
804 my ($file, $desc) = @_;
805 my $fh = new IO::Handle;
806 open $fh, '<', $file or die "$file: $!";
807 my $c = parsecontrolfh($fh,$desc);
808 $fh->error and die $!;
814 my ($dctrl,$field) = @_;
815 my $v = $dctrl->{$field};
816 return $v if defined $v;
817 fail "missing field $field in ".$v->get_option('name');
821 my $c = Dpkg::Control::Hash->new();
822 my $p = new IO::Handle;
823 my @cmd = (qw(dpkg-parsechangelog), @_);
824 open $p, '-|', @cmd or die $!;
826 $?=0; $!=0; close $p or failedcmd @cmd;
832 defined $d or fail "getcwd failed: $!";
838 sub archive_query ($) {
840 my $query = access_cfg('archive-query','RETURN-UNDEF');
841 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
844 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
847 sub pool_dsc_subpath ($$) {
848 my ($vsn,$component) = @_; # $package is implict arg
849 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
850 return "/pool/$component/$prefix/$package/".dscfn($vsn);
853 #---------- `ftpmasterapi' archive query method (nascent) ----------
855 sub archive_api_query_cmd ($) {
857 my @cmd = qw(curl -sS);
858 my $url = access_cfg('archive-query-url');
859 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
861 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
862 foreach my $key (split /\:/, $keys) {
863 $key =~ s/\%HOST\%/$host/g;
865 fail "for $url: stat $key: $!" unless $!==ENOENT;
868 fail "config requested specific TLS key but do not know".
869 " how to get curl to use exactly that EE key ($key)";
870 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
871 # # Sadly the above line does not work because of changes
872 # # to gnutls. The real fix for #790093 may involve
873 # # new curl options.
876 # Fixing #790093 properly will involve providing a value
877 # for this on clients.
878 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
879 push @cmd, split / /, $kargs if defined $kargs;
881 push @cmd, $url.$subpath;
887 my ($data, $subpath) = @_;
888 badcfg "ftpmasterapi archive query method takes no data part"
890 my @cmd = archive_api_query_cmd($subpath);
891 my $json = cmdoutput @cmd;
892 return decode_json($json);
895 sub canonicalise_suite_ftpmasterapi () {
896 my ($proto,$data) = @_;
897 my $suites = api_query($data, 'suites');
899 foreach my $entry (@$suites) {
901 my $v = $entry->{$_};
902 defined $v && $v eq $isuite;
904 push @matched, $entry;
906 fail "unknown suite $isuite" unless @matched;
909 @matched==1 or die "multiple matches for suite $isuite\n";
910 $cn = "$matched[0]{codename}";
911 defined $cn or die "suite $isuite info has no codename\n";
912 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
914 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
919 sub archive_query_ftpmasterapi () {
920 my ($proto,$data) = @_;
921 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
923 my $digester = Digest::SHA->new(256);
924 foreach my $entry (@$info) {
926 my $vsn = "$entry->{version}";
927 my ($ok,$msg) = version_check $vsn;
928 die "bad version: $msg\n" unless $ok;
929 my $component = "$entry->{component}";
930 $component =~ m/^$component_re$/ or die "bad component";
931 my $filename = "$entry->{filename}";
932 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
933 or die "bad filename";
934 my $sha256sum = "$entry->{sha256sum}";
935 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
936 push @rows, [ $vsn, "/pool/$component/$filename",
937 $digester, $sha256sum ];
939 die "bad ftpmaster api response: $@\n".Dumper($entry)
942 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
946 #---------- `madison' archive query method ----------
948 sub archive_query_madison {
949 return map { [ @$_[0..1] ] } madison_get_parse(@_);
952 sub madison_get_parse {
953 my ($proto,$data) = @_;
954 die unless $proto eq 'madison';
956 $data= access_cfg('madison-distro','RETURN-UNDEF');
957 $data //= access_basedistro();
959 $rmad{$proto,$data,$package} ||= cmdoutput
960 qw(rmadison -asource),"-s$isuite","-u$data",$package;
961 my $rmad = $rmad{$proto,$data,$package};
964 foreach my $l (split /\n/, $rmad) {
965 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
966 \s*( [^ \t|]+ )\s* \|
967 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
968 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
969 $1 eq $package or die "$rmad $package ?";
976 $component = access_cfg('archive-query-default-component');
978 $5 eq 'source' or die "$rmad ?";
979 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
981 return sort { -version_compare($a->[0],$b->[0]); } @out;
984 sub canonicalise_suite_madison {
985 # madison canonicalises for us
986 my @r = madison_get_parse(@_);
988 "unable to canonicalise suite using package $package".
989 " which does not appear to exist in suite $isuite;".
990 " --existing-package may help";
994 #---------- `sshpsql' archive query method ----------
997 my ($data,$runeinfo,$sql) = @_;
999 $data= access_someuserhost('sshpsql').':'.
1000 access_cfg('sshpsql-dbname');
1002 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1003 my ($userhost,$dbname) = ($`,$'); #';
1005 my @cmd = (access_cfg_ssh, $userhost,
1006 access_runeinfo("ssh-psql $runeinfo").
1007 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1008 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1010 open P, "-|", @cmd or die $!;
1013 printdebug(">|$_|\n");
1016 $!=0; $?=0; close P or failedcmd @cmd;
1018 my $nrows = pop @rows;
1019 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1020 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1021 @rows = map { [ split /\|/, $_ ] } @rows;
1022 my $ncols = scalar @{ shift @rows };
1023 die if grep { scalar @$_ != $ncols } @rows;
1027 sub sql_injection_check {
1028 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1031 sub archive_query_sshpsql ($$) {
1032 my ($proto,$data) = @_;
1033 sql_injection_check $isuite, $package;
1034 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1035 SELECT source.version, component.name, files.filename, files.sha256sum
1037 JOIN src_associations ON source.id = src_associations.source
1038 JOIN suite ON suite.id = src_associations.suite
1039 JOIN dsc_files ON dsc_files.source = source.id
1040 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1041 JOIN component ON component.id = files_archive_map.component_id
1042 JOIN files ON files.id = dsc_files.file
1043 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1044 AND source.source='$package'
1045 AND files.filename LIKE '%.dsc';
1047 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1048 my $digester = Digest::SHA->new(256);
1050 my ($vsn,$component,$filename,$sha256sum) = @$_;
1051 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1056 sub canonicalise_suite_sshpsql ($$) {
1057 my ($proto,$data) = @_;
1058 sql_injection_check $isuite;
1059 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1060 SELECT suite.codename
1061 FROM suite where suite_name='$isuite' or codename='$isuite';
1063 @rows = map { $_->[0] } @rows;
1064 fail "unknown suite $isuite" unless @rows;
1065 die "ambiguous $isuite: @rows ?" if @rows>1;
1069 #---------- `dummycat' archive query method ----------
1071 sub canonicalise_suite_dummycat ($$) {
1072 my ($proto,$data) = @_;
1073 my $dpath = "$data/suite.$isuite";
1074 if (!open C, "<", $dpath) {
1075 $!==ENOENT or die "$dpath: $!";
1076 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1080 chomp or die "$dpath: $!";
1082 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1086 sub archive_query_dummycat ($$) {
1087 my ($proto,$data) = @_;
1088 canonicalise_suite();
1089 my $dpath = "$data/package.$csuite.$package";
1090 if (!open C, "<", $dpath) {
1091 $!==ENOENT or die "$dpath: $!";
1092 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1100 printdebug "dummycat query $csuite $package $dpath | $_\n";
1101 my @row = split /\s+/, $_;
1102 @row==2 or die "$dpath: $_ ?";
1105 C->error and die "$dpath: $!";
1107 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1110 #---------- archive query entrypoints and rest of program ----------
1112 sub canonicalise_suite () {
1113 return if defined $csuite;
1114 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1115 $csuite = archive_query('canonicalise_suite');
1116 if ($isuite ne $csuite) {
1117 progress "canonical suite name for $isuite is $csuite";
1121 sub get_archive_dsc () {
1122 canonicalise_suite();
1123 my @vsns = archive_query('archive_query');
1124 foreach my $vinfo (@vsns) {
1125 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1126 $dscurl = access_cfg('mirror').$subpath;
1127 $dscdata = url_get($dscurl);
1129 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1134 $digester->add($dscdata);
1135 my $got = $digester->hexdigest();
1137 fail "$dscurl has hash $got but".
1138 " archive told us to expect $digest";
1140 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1141 printdebug Dumper($dscdata) if $debuglevel>1;
1142 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1143 printdebug Dumper($dsc) if $debuglevel>1;
1144 my $fmt = getfield $dsc, 'Format';
1145 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1146 $dsc_checked = !!$digester;
1152 sub check_for_git ();
1153 sub check_for_git () {
1155 my $how = access_cfg('git-check');
1156 if ($how eq 'ssh-cmd') {
1158 (access_cfg_ssh, access_gituserhost(),
1159 access_runeinfo("git-check $package").
1160 " set -e; cd ".access_cfg('git-path').";".
1161 " if test -d $package.git; then echo 1; else echo 0; fi");
1162 my $r= cmdoutput @cmd;
1163 if ($r =~ m/^divert (\w+)$/) {
1165 my ($usedistro,) = access_distros();
1166 # NB that if we are pushing, $usedistro will be $distro/push
1167 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1168 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1169 progress "diverting to $divert (using config for $instead_distro)";
1170 return check_for_git();
1172 failedcmd @cmd unless $r =~ m/^[01]$/;
1174 } elsif ($how eq 'url') {
1175 my $prefix = access_cfg('git-check-url','git-url');
1176 my $suffix = access_cfg('git-check-suffix','git-suffix',
1177 'RETURN-UNDEF') // '.git';
1178 my $url = "$prefix/$package$suffix";
1179 my @cmd = (qw(curl -sS -I), $url);
1180 my $result = cmdoutput @cmd;
1181 $result =~ s/^\S+ 200 .*\n\r?\n//;
1182 # curl -sS -I with https_proxy prints
1183 # HTTP/1.0 200 Connection established
1184 $result =~ m/^\S+ (404|200) /s or
1185 fail "unexpected results from git check query - ".
1186 Dumper($prefix, $result);
1188 if ($code eq '404') {
1190 } elsif ($code eq '200') {
1195 } elsif ($how eq 'true') {
1197 } elsif ($how eq 'false') {
1200 badcfg "unknown git-check \`$how'";
1204 sub create_remote_git_repo () {
1205 my $how = access_cfg('git-create');
1206 if ($how eq 'ssh-cmd') {
1208 (access_cfg_ssh, access_gituserhost(),
1209 access_runeinfo("git-create $package").
1210 "set -e; cd ".access_cfg('git-path').";".
1211 " cp -a _template $package.git");
1212 } elsif ($how eq 'true') {
1215 badcfg "unknown git-create \`$how'";
1219 our ($dsc_hash,$lastpush_hash);
1221 our $ud = '.git/dgit/unpack';
1231 sub mktree_in_ud_here () {
1232 runcmd qw(git init -q);
1233 rmtree('.git/objects');
1234 symlink '../../../../objects','.git/objects' or die $!;
1237 sub git_write_tree () {
1238 my $tree = cmdoutput @git, qw(write-tree);
1239 $tree =~ m/^\w+$/ or die "$tree ?";
1243 sub remove_stray_gits () {
1244 my @gitscmd = qw(find -name .git -prune -print0);
1245 debugcmd "|",@gitscmd;
1246 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1251 print STDERR "$us: warning: removing from source package: ",
1252 (messagequote $_), "\n";
1256 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1259 sub mktree_in_ud_from_only_subdir () {
1260 # changes into the subdir
1262 die unless @dirs==1;
1263 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1267 remove_stray_gits();
1268 mktree_in_ud_here();
1269 my ($format, $fopts) = get_source_format();
1270 if (madformat($format)) {
1273 runcmd @git, qw(add -Af);
1274 my $tree=git_write_tree();
1275 return ($tree,$dir);
1278 sub dsc_files_info () {
1279 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1280 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1281 ['Files', 'Digest::MD5', 'new()']) {
1282 my ($fname, $module, $method) = @$csumi;
1283 my $field = $dsc->{$fname};
1284 next unless defined $field;
1285 eval "use $module; 1;" or die $@;
1287 foreach (split /\n/, $field) {
1289 m/^(\w+) (\d+) (\S+)$/ or
1290 fail "could not parse .dsc $fname line \`$_'";
1291 my $digester = eval "$module"."->$method;" or die $@;
1296 Digester => $digester,
1301 fail "missing any supported Checksums-* or Files field in ".
1302 $dsc->get_option('name');
1306 map { $_->{Filename} } dsc_files_info();
1309 sub is_orig_file ($;$) {
1312 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1313 defined $base or return 1;
1317 sub make_commit ($) {
1319 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1322 sub clogp_authline ($) {
1324 my $author = getfield $clogp, 'Maintainer';
1325 $author =~ s#,.*##ms;
1326 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1327 my $authline = "$author $date";
1328 $authline =~ m/$git_authline_re/o or
1329 fail "unexpected commit author line format \`$authline'".
1330 " (was generated from changelog Maintainer field)";
1331 return ($1,$2,$3) if wantarray;
1335 sub vendor_patches_distro ($$) {
1336 my ($checkdistro, $what) = @_;
1337 return unless defined $checkdistro;
1339 my $series = "debian/patches/\L$checkdistro\E.series";
1340 printdebug "checking for vendor-specific $series ($what)\n";
1342 if (!open SERIES, "<", $series) {
1343 die "$series $!" unless $!==ENOENT;
1352 Unfortunately, this source package uses a feature of dpkg-source where
1353 the same source package unpacks to different source code on different
1354 distros. dgit cannot safely operate on such packages on affected
1355 distros, because the meaning of source packages is not stable.
1357 Please ask the distro/maintainer to remove the distro-specific series
1358 files and use a different technique (if necessary, uploading actually
1359 different packages, if different distros are supposed to have
1363 fail "Found active distro-specific series file for".
1364 " $checkdistro ($what): $series, cannot continue";
1366 die "$series $!" if SERIES->error;
1370 sub check_for_vendor_patches () {
1371 # This dpkg-source feature doesn't seem to be documented anywhere!
1372 # But it can be found in the changelog (reformatted):
1374 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1375 # Author: Raphael Hertzog <hertzog@debian.org>
1376 # Date: Sun Oct 3 09:36:48 2010 +0200
1378 # dpkg-source: correctly create .pc/.quilt_series with alternate
1381 # If you have debian/patches/ubuntu.series and you were
1382 # unpacking the source package on ubuntu, quilt was still
1383 # directed to debian/patches/series instead of
1384 # debian/patches/ubuntu.series.
1386 # debian/changelog | 3 +++
1387 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1388 # 2 files changed, 6 insertions(+), 1 deletion(-)
1391 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1392 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1393 "Dpkg::Vendor \`current vendor'");
1394 vendor_patches_distro(access_basedistro(),
1395 "distro being accessed");
1398 sub generate_commit_from_dsc () {
1402 foreach my $fi (dsc_files_info()) {
1403 my $f = $fi->{Filename};
1404 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1406 link_ltarget "../../../$f", $f
1410 complete_file_from_dsc('.', $fi)
1413 if (is_orig_file($f)) {
1414 link $f, "../../../../$f"
1420 my $dscfn = "$package.dsc";
1422 open D, ">", $dscfn or die "$dscfn: $!";
1423 print D $dscdata or die "$dscfn: $!";
1424 close D or die "$dscfn: $!";
1425 my @cmd = qw(dpkg-source);
1426 push @cmd, '--no-check' if $dsc_checked;
1427 push @cmd, qw(-x --), $dscfn;
1430 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1431 check_for_vendor_patches() if madformat($dsc->{format});
1432 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1433 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1434 my $authline = clogp_authline $clogp;
1435 my $changes = getfield $clogp, 'Changes';
1436 open C, ">../commit.tmp" or die $!;
1437 print C <<END or die $!;
1444 # imported from the archive
1447 my $outputhash = make_commit qw(../commit.tmp);
1448 my $cversion = getfield $clogp, 'Version';
1449 progress "synthesised git commit from .dsc $cversion";
1450 if ($lastpush_hash) {
1451 runcmd @git, qw(reset -q --hard), $lastpush_hash;
1452 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1453 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1454 my $oversion = getfield $oldclogp, 'Version';
1456 version_compare($oversion, $cversion);
1458 # git upload/ is earlier vsn than archive, use archive
1459 open C, ">../commit2.tmp" or die $!;
1460 print C <<END or die $!;
1462 parent $lastpush_hash
1467 Record $package ($cversion) in archive suite $csuite
1469 $outputhash = make_commit qw(../commit2.tmp);
1470 } elsif ($vcmp > 0) {
1471 print STDERR <<END or die $!;
1473 Version actually in archive: $cversion (older)
1474 Last allegedly pushed/uploaded: $oversion (newer or same)
1477 $outputhash = $lastpush_hash;
1479 $outputhash = $lastpush_hash;
1482 changedir '../../../..';
1483 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1484 'DGIT_ARCHIVE', $outputhash;
1485 cmdoutput @git, qw(log -n2), $outputhash;
1486 # ... gives git a chance to complain if our commit is malformed
1491 sub complete_file_from_dsc ($$) {
1492 our ($dstdir, $fi) = @_;
1493 # Ensures that we have, in $dir, the file $fi, with the correct
1494 # contents. (Downloading it from alongside $dscurl if necessary.)
1496 my $f = $fi->{Filename};
1497 my $tf = "$dstdir/$f";
1500 if (stat_exists $tf) {
1501 progress "using existing $f";
1504 $furl =~ s{/[^/]+$}{};
1506 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1507 die "$f ?" if $f =~ m#/#;
1508 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1509 return 0 if !act_local();
1513 open F, "<", "$tf" or die "$tf: $!";
1514 $fi->{Digester}->reset();
1515 $fi->{Digester}->addfile(*F);
1516 F->error and die $!;
1517 my $got = $fi->{Digester}->hexdigest();
1518 $got eq $fi->{Hash} or
1519 fail "file $f has hash $got but .dsc".
1520 " demands hash $fi->{Hash} ".
1521 ($downloaded ? "(got wrong file from archive!)"
1522 : "(perhaps you should delete this file?)");
1527 sub ensure_we_have_orig () {
1528 foreach my $fi (dsc_files_info()) {
1529 my $f = $fi->{Filename};
1530 next unless is_orig_file($f);
1531 complete_file_from_dsc('..', $fi)
1536 sub git_fetch_us () {
1537 my @specs = (fetchspec());
1539 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1541 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1544 my $tagpat = debiantag('*',access_basedistro);
1546 git_for_each_ref("refs/tags/".$tagpat, sub {
1547 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1548 printdebug "currently $fullrefname=$objid\n";
1549 $here{$fullrefname} = $objid;
1551 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1552 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1553 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1554 printdebug "offered $lref=$objid\n";
1555 if (!defined $here{$lref}) {
1556 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1557 runcmd_ordryrun_local @upd;
1558 } elsif ($here{$lref} eq $objid) {
1561 "Not updateting $lref from $here{$lref} to $objid.\n";
1566 sub fetch_from_archive () {
1567 # ensures that lrref() is what is actually in the archive,
1568 # one way or another
1572 foreach my $field (@ourdscfield) {
1573 $dsc_hash = $dsc->{$field};
1574 last if defined $dsc_hash;
1576 if (defined $dsc_hash) {
1577 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1579 progress "last upload to archive specified git hash";
1581 progress "last upload to archive has NO git hash";
1584 progress "no version available from the archive";
1587 $lastpush_hash = git_get_ref(lrref());
1588 printdebug "previous reference hash=$lastpush_hash\n";
1590 if (defined $dsc_hash) {
1591 fail "missing remote git history even though dsc has hash -".
1592 " could not find ref ".lrref().
1593 " (should have been fetched from ".access_giturl()."#".rrref().")"
1594 unless $lastpush_hash;
1596 ensure_we_have_orig();
1597 if ($dsc_hash eq $lastpush_hash) {
1598 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1599 print STDERR <<END or die $!;
1601 Git commit in archive is behind the last version allegedly pushed/uploaded.
1602 Commit referred to by archive: $dsc_hash
1603 Last allegedly pushed/uploaded: $lastpush_hash
1606 $hash = $lastpush_hash;
1608 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1609 "descendant of archive's .dsc hash ($dsc_hash)";
1612 $hash = generate_commit_from_dsc();
1613 } elsif ($lastpush_hash) {
1614 # only in git, not in the archive yet
1615 $hash = $lastpush_hash;
1616 print STDERR <<END or die $!;
1618 Package not found in the archive, but has allegedly been pushed using dgit.
1622 printdebug "nothing found!\n";
1623 if (defined $skew_warning_vsn) {
1624 print STDERR <<END or die $!;
1626 Warning: relevant archive skew detected.
1627 Archive allegedly contains $skew_warning_vsn
1628 But we were not able to obtain any version from the archive or git.
1634 printdebug "current hash=$hash\n";
1635 if ($lastpush_hash) {
1636 fail "not fast forward on last upload branch!".
1637 " (archive's version left in DGIT_ARCHIVE)"
1638 unless is_fast_fwd($lastpush_hash, $hash);
1640 if (defined $skew_warning_vsn) {
1642 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1643 my $clogf = ".git/dgit/changelog.tmp";
1644 runcmd shell_cmd "exec >$clogf",
1645 @git, qw(cat-file blob), "$hash:debian/changelog";
1646 my $gotclogp = parsechangelog("-l$clogf");
1647 my $got_vsn = getfield $gotclogp, 'Version';
1648 printdebug "SKEW CHECK GOT $got_vsn\n";
1649 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1650 print STDERR <<END or die $!;
1652 Warning: archive skew detected. Using the available version:
1653 Archive allegedly contains $skew_warning_vsn
1654 We were able to obtain only $got_vsn
1659 if ($lastpush_hash ne $hash) {
1660 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1664 dryrun_report @upd_cmd;
1670 sub set_local_git_config ($$) {
1672 runcmd @git, qw(config), $k, $v;
1675 sub setup_mergechangelogs (;$) {
1677 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1679 my $driver = 'dpkg-mergechangelogs';
1680 my $cb = "merge.$driver";
1681 my $attrs = '.git/info/attributes';
1682 ensuredir '.git/info';
1684 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1685 if (!open ATTRS, "<", $attrs) {
1686 $!==ENOENT or die "$attrs: $!";
1690 next if m{^debian/changelog\s};
1691 print NATTRS $_, "\n" or die $!;
1693 ATTRS->error and die $!;
1696 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1699 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1700 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1702 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1705 sub setup_useremail (;$) {
1707 return unless $always || access_cfg_bool(1, 'setup-useremail');
1710 my ($k, $envvar) = @_;
1711 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1712 return unless defined $v;
1713 set_local_git_config "user.$k", $v;
1716 $setup->('email', 'DEBEMAIL');
1717 $setup->('name', 'DEBFULLNAME');
1720 sub setup_new_tree () {
1721 setup_mergechangelogs();
1727 canonicalise_suite();
1728 badusage "dry run makes no sense with clone" unless act_local();
1729 my $hasgit = check_for_git();
1730 mkdir $dstdir or fail "create \`$dstdir': $!";
1732 runcmd @git, qw(init -q);
1733 my $giturl = access_giturl(1);
1734 if (defined $giturl) {
1735 set_local_git_config "remote.$remotename.fetch", fetchspec();
1736 open H, "> .git/HEAD" or die $!;
1737 print H "ref: ".lref()."\n" or die $!;
1739 runcmd @git, qw(remote add), 'origin', $giturl;
1742 progress "fetching existing git history";
1744 runcmd_ordryrun_local @git, qw(fetch origin);
1746 progress "starting new git history";
1748 fetch_from_archive() or no_such_package;
1749 my $vcsgiturl = $dsc->{'Vcs-Git'};
1750 if (length $vcsgiturl) {
1751 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1752 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1755 runcmd @git, qw(reset --hard), lrref();
1756 printdone "ready for work in $dstdir";
1760 if (check_for_git()) {
1763 fetch_from_archive() or no_such_package();
1764 printdone "fetched into ".lrref();
1769 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1771 printdone "fetched to ".lrref()." and merged into HEAD";
1774 sub check_not_dirty () {
1775 foreach my $f (qw(local-options local-patch-header)) {
1776 if (stat_exists "debian/source/$f") {
1777 fail "git tree contains debian/source/$f";
1781 return if $ignoredirty;
1783 my @cmd = (@git, qw(diff --quiet HEAD));
1785 $!=0; $?=0; system @cmd;
1786 return if !$! && !$?;
1787 if (!$! && $?==256) {
1788 fail "working tree is dirty (does not match HEAD)";
1794 sub commit_admin ($) {
1797 runcmd_ordryrun_local @git, qw(commit -m), $m;
1800 sub commit_quilty_patch () {
1801 my $output = cmdoutput @git, qw(status --porcelain);
1803 foreach my $l (split /\n/, $output) {
1804 next unless $l =~ m/\S/;
1805 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1809 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1811 progress "nothing quilty to commit, ok.";
1814 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1815 runcmd_ordryrun_local @git, qw(add -f), @adds;
1816 commit_admin "Commit Debian 3.0 (quilt) metadata";
1819 sub get_source_format () {
1821 if (open F, "debian/source/options") {
1825 s/\s+$//; # ignore missing final newline
1827 my ($k, $v) = ($`, $'); #');
1828 $v =~ s/^"(.*)"$/$1/;
1834 F->error and die $!;
1837 die $! unless $!==&ENOENT;
1840 if (!open F, "debian/source/format") {
1841 die $! unless $!==&ENOENT;
1845 F->error and die $!;
1847 return ($_, \%options);
1852 return 0 unless $format eq '3.0 (quilt)';
1853 if ($quilt_mode eq 'nocheck') {
1854 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1857 progress "Format \`$format', checking/updating patch stack";
1861 sub push_parse_changelog ($) {
1864 my $clogp = Dpkg::Control::Hash->new();
1865 $clogp->load($clogpfn) or die;
1867 $package = getfield $clogp, 'Source';
1868 my $cversion = getfield $clogp, 'Version';
1869 my $tag = debiantag($cversion, access_basedistro);
1870 runcmd @git, qw(check-ref-format), $tag;
1872 my $dscfn = dscfn($cversion);
1874 return ($clogp, $cversion, $tag, $dscfn);
1877 sub push_parse_dsc ($$$) {
1878 my ($dscfn,$dscfnwhat, $cversion) = @_;
1879 $dsc = parsecontrol($dscfn,$dscfnwhat);
1880 my $dversion = getfield $dsc, 'Version';
1881 my $dscpackage = getfield $dsc, 'Source';
1882 ($dscpackage eq $package && $dversion eq $cversion) or
1883 fail "$dscfn is for $dscpackage $dversion".
1884 " but debian/changelog is for $package $cversion";
1887 sub push_mktag ($$$$$$$) {
1888 my ($head,$clogp,$tag,
1890 $changesfile,$changesfilewhat,
1893 $dsc->{$ourdscfield[0]} = $head;
1894 $dsc->save("$dscfn.tmp") or die $!;
1896 my $changes = parsecontrol($changesfile,$changesfilewhat);
1897 foreach my $field (qw(Source Distribution Version)) {
1898 $changes->{$field} eq $clogp->{$field} or
1899 fail "changes field $field \`$changes->{$field}'".
1900 " does not match changelog \`$clogp->{$field}'";
1903 my $cversion = getfield $clogp, 'Version';
1904 my $clogsuite = getfield $clogp, 'Distribution';
1906 # We make the git tag by hand because (a) that makes it easier
1907 # to control the "tagger" (b) we can do remote signing
1908 my $authline = clogp_authline $clogp;
1909 my $delibs = join(" ", "",@deliberatelies);
1910 my $declaredistro = access_basedistro();
1911 open TO, '>', $tfn->('.tmp') or die $!;
1912 print TO <<END or die $!;
1918 $package release $cversion for $clogsuite ($csuite) [dgit]
1919 [dgit distro=$declaredistro$delibs]
1921 foreach my $ref (sort keys %previously) {
1922 print TO <<END or die $!;
1923 [dgit previously:$ref=$previously{$ref}]
1929 my $tagobjfn = $tfn->('.tmp');
1931 if (!defined $keyid) {
1932 $keyid = access_cfg('keyid','RETURN-UNDEF');
1934 if (!defined $keyid) {
1935 $keyid = getfield $clogp, 'Maintainer';
1937 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1938 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1939 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1940 push @sign_cmd, $tfn->('.tmp');
1941 runcmd_ordryrun @sign_cmd;
1943 $tagobjfn = $tfn->('.signed.tmp');
1944 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1945 $tfn->('.tmp'), $tfn->('.tmp.asc');
1952 sub sign_changes ($) {
1953 my ($changesfile) = @_;
1955 my @debsign_cmd = @debsign;
1956 push @debsign_cmd, "-k$keyid" if defined $keyid;
1957 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1958 push @debsign_cmd, $changesfile;
1959 runcmd_ordryrun @debsign_cmd;
1964 my ($forceflag) = @_;
1965 printdebug "actually entering push\n";
1966 supplementary_message(<<'END');
1967 Push failed, while preparing your push.
1968 You can retry the push, after fixing the problem, if you like.
1972 access_giturl(); # check that success is vaguely likely
1974 my $clogpfn = ".git/dgit/changelog.822.tmp";
1975 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1977 responder_send_file('parsed-changelog', $clogpfn);
1979 my ($clogp, $cversion, $tag, $dscfn) =
1980 push_parse_changelog("$clogpfn");
1982 my $dscpath = "$buildproductsdir/$dscfn";
1983 stat_exists $dscpath or
1984 fail "looked for .dsc $dscfn, but $!;".
1985 " maybe you forgot to build";
1987 responder_send_file('dsc', $dscpath);
1989 push_parse_dsc($dscpath, $dscfn, $cversion);
1991 my $format = getfield $dsc, 'Format';
1992 printdebug "format $format\n";
1994 if (madformat($format)) {
1995 # user might have not used dgit build, so maybe do this now:
1996 commit_quilty_patch();
1999 die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2003 progress "checking that $dscfn corresponds to HEAD";
2004 runcmd qw(dpkg-source -x --),
2005 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2006 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2007 check_for_vendor_patches() if madformat($dsc->{format});
2008 changedir '../../../..';
2009 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2010 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2011 debugcmd "+",@diffcmd;
2013 my $r = system @diffcmd;
2016 fail "$dscfn specifies a different tree to your HEAD commit;".
2017 " perhaps you forgot to build".
2018 ($diffopt eq '--exit-code' ? "" :
2019 " (run with -D to see full diff output)");
2024 my $head = git_rev_parse('HEAD');
2025 if (!$changesfile) {
2026 my $pat = changespat $cversion;
2027 my @cs = glob "$buildproductsdir/$pat";
2028 fail "failed to find unique changes file".
2029 " (looked for $pat in $buildproductsdir);".
2030 " perhaps you need to use dgit -C"
2032 ($changesfile) = @cs;
2034 $changesfile = "$buildproductsdir/$changesfile";
2037 responder_send_file('changes',$changesfile);
2038 responder_send_command("param head $head");
2039 responder_send_command("param csuite $csuite");
2041 if (deliberately_not_fast_forward) {
2042 git_for_each_ref(lrfetchrefs, sub {
2043 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2044 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2045 responder_send_command("previously $rrefname=$objid");
2046 $previously{$rrefname} = $objid;
2050 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2053 supplementary_message(<<'END');
2054 Push failed, while signing the tag.
2055 You can retry the push, after fixing the problem, if you like.
2057 # If we manage to sign but fail to record it anywhere, it's fine.
2058 if ($we_are_responder) {
2059 $tagobjfn = $tfn->('.signed.tmp');
2060 responder_receive_files('signed-tag', $tagobjfn);
2063 push_mktag($head,$clogp,$tag,
2065 $changesfile,$changesfile,
2068 supplementary_message(<<'END');
2069 Push failed, *after* signing the tag.
2070 If you want to try again, you should use a new version number.
2073 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2074 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2075 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2077 supplementary_message(<<'END');
2078 Push failed, while updating the remote git repository - see messages above.
2079 If you want to try again, you should use a new version number.
2081 if (!check_for_git()) {
2082 create_remote_git_repo();
2084 runcmd_ordryrun @git, qw(push),access_giturl(),
2085 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2086 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2088 supplementary_message(<<'END');
2089 Push failed, after updating the remote git repository.
2090 If you want to try again, you must use a new version number.
2092 if ($we_are_responder) {
2093 my $dryrunsuffix = act_local() ? "" : ".tmp";
2094 responder_receive_files('signed-dsc-changes',
2095 "$dscpath$dryrunsuffix",
2096 "$changesfile$dryrunsuffix");
2099 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2101 progress "[new .dsc left in $dscpath.tmp]";
2103 sign_changes $changesfile;
2106 supplementary_message(<<END);
2107 Push failed, while uploading package(s) to the archive server.
2108 You can retry the upload of exactly these same files with dput of:
2110 If that .changes file is broken, you will need to use a new version
2111 number for your next attempt at the upload.
2113 my $host = access_cfg('upload-host','RETURN-UNDEF');
2114 my @hostarg = defined($host) ? ($host,) : ();
2115 runcmd_ordryrun @dput, @hostarg, $changesfile;
2116 printdone "pushed and uploaded $cversion";
2118 supplementary_message('');
2119 responder_send_command("complete");
2126 badusage "-p is not allowed with clone; specify as argument instead"
2127 if defined $package;
2130 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2131 ($package,$isuite) = @ARGV;
2132 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2133 ($package,$dstdir) = @ARGV;
2134 } elsif (@ARGV==3) {
2135 ($package,$isuite,$dstdir) = @ARGV;
2137 badusage "incorrect arguments to dgit clone";
2139 $dstdir ||= "$package";
2141 if (stat_exists $dstdir) {
2142 fail "$dstdir already exists";
2146 if ($rmonerror && !$dryrun_level) {
2147 $cwd_remove= getcwd();
2149 return unless defined $cwd_remove;
2150 if (!chdir "$cwd_remove") {
2151 return if $!==&ENOENT;
2152 die "chdir $cwd_remove: $!";
2155 rmtree($dstdir) or die "remove $dstdir: $!\n";
2156 } elsif (!grep { $! == $_ }
2157 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2159 print STDERR "check whether to remove $dstdir: $!\n";
2165 $cwd_remove = undef;
2168 sub branchsuite () {
2169 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2170 if ($branch =~ m#$lbranch_re#o) {
2177 sub fetchpullargs () {
2179 if (!defined $package) {
2180 my $sourcep = parsecontrol('debian/control','debian/control');
2181 $package = getfield $sourcep, 'Source';
2184 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2186 my $clogp = parsechangelog();
2187 $isuite = getfield $clogp, 'Distribution';
2189 canonicalise_suite();
2190 progress "fetching from suite $csuite";
2191 } elsif (@ARGV==1) {
2193 canonicalise_suite();
2195 badusage "incorrect arguments to dgit fetch or dgit pull";
2214 badusage "-p is not allowed with dgit push" if defined $package;
2216 my $clogp = parsechangelog();
2217 $package = getfield $clogp, 'Source';
2220 } elsif (@ARGV==1) {
2221 ($specsuite) = (@ARGV);
2223 badusage "incorrect arguments to dgit push";
2225 $isuite = getfield $clogp, 'Distribution';
2227 local ($package) = $existing_package; # this is a hack
2228 canonicalise_suite();
2230 canonicalise_suite();
2232 if (defined $specsuite &&
2233 $specsuite ne $isuite &&
2234 $specsuite ne $csuite) {
2235 fail "dgit push: changelog specifies $isuite ($csuite)".
2236 " but command line specifies $specsuite";
2238 supplementary_message(<<'END');
2239 Push failed, while checking state of the archive.
2240 You can retry the push, after fixing the problem, if you like.
2242 if (check_for_git()) {
2246 if (fetch_from_archive()) {
2247 if (is_fast_fwd(lrref(), 'HEAD')) {
2249 } elsif (deliberately_not_fast_forward) {
2252 fail "dgit push: HEAD is not a descendant".
2253 " of the archive's version.\n".
2254 "dgit: To overwrite its contents,".
2255 " use git merge -s ours ".lrref().".\n".
2256 "dgit: To rewind history, if permitted by the archive,".
2257 " use --deliberately-not-fast-forward";
2261 fail "package appears to be new in this suite;".
2262 " if this is intentional, use --new";
2267 #---------- remote commands' implementation ----------
2269 sub cmd_remote_push_build_host {
2270 my ($nrargs) = shift @ARGV;
2271 my (@rargs) = @ARGV[0..$nrargs-1];
2272 @ARGV = @ARGV[$nrargs..$#ARGV];
2274 my ($dir,$vsnwant) = @rargs;
2275 # vsnwant is a comma-separated list; we report which we have
2276 # chosen in our ready response (so other end can tell if they
2279 $we_are_responder = 1;
2280 $us .= " (build host)";
2284 open PI, "<&STDIN" or die $!;
2285 open STDIN, "/dev/null" or die $!;
2286 open PO, ">&STDOUT" or die $!;
2288 open STDOUT, ">&STDERR" or die $!;
2292 ($protovsn) = grep {
2293 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2294 } @rpushprotovsn_support;
2296 fail "build host has dgit rpush protocol versions ".
2297 (join ",", @rpushprotovsn_support).
2298 " but invocation host has $vsnwant"
2299 unless defined $protovsn;
2301 responder_send_command("dgit-remote-push-ready $protovsn");
2307 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2308 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2309 # a good error message)
2315 my $report = i_child_report();
2316 if (defined $report) {
2317 printdebug "($report)\n";
2318 } elsif ($i_child_pid) {
2319 printdebug "(killing build host child $i_child_pid)\n";
2320 kill 15, $i_child_pid;
2322 if (defined $i_tmp && !defined $initiator_tempdir) {
2324 eval { rmtree $i_tmp; };
2328 END { i_cleanup(); }
2331 my ($base,$selector,@args) = @_;
2332 $selector =~ s/\-/_/g;
2333 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2340 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2348 push @rargs, join ",", @rpushprotovsn_support;
2351 push @rdgit, @ropts;
2352 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2354 my @cmd = (@ssh, $host, shellquote @rdgit);
2357 if (defined $initiator_tempdir) {
2358 rmtree $initiator_tempdir;
2359 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2360 $i_tmp = $initiator_tempdir;
2364 $i_child_pid = open2(\*RO, \*RI, @cmd);
2366 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2367 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2368 $supplementary_message = '' unless $protovsn >= 3;
2370 my ($icmd,$iargs) = initiator_expect {
2371 m/^(\S+)(?: (.*))?$/;
2374 i_method "i_resp", $icmd, $iargs;
2378 sub i_resp_progress ($) {
2380 my $msg = protocol_read_bytes \*RO, $rhs;
2384 sub i_resp_supplementary_message ($) {
2386 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2389 sub i_resp_complete {
2390 my $pid = $i_child_pid;
2391 $i_child_pid = undef; # prevents killing some other process with same pid
2392 printdebug "waiting for build host child $pid...\n";
2393 my $got = waitpid $pid, 0;
2394 die $! unless $got == $pid;
2395 die "build host child failed $?" if $?;
2398 printdebug "all done\n";
2402 sub i_resp_file ($) {
2404 my $localname = i_method "i_localname", $keyword;
2405 my $localpath = "$i_tmp/$localname";
2406 stat_exists $localpath and
2407 badproto \*RO, "file $keyword ($localpath) twice";
2408 protocol_receive_file \*RO, $localpath;
2409 i_method "i_file", $keyword;
2414 sub i_resp_param ($) {
2415 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2419 sub i_resp_previously ($) {
2420 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2421 or badproto \*RO, "bad previously spec";
2422 my $r = system qw(git check-ref-format), $1;
2423 die "bad previously ref spec ($r)" if $r;
2424 $previously{$1} = $2;
2429 sub i_resp_want ($) {
2431 die "$keyword ?" if $i_wanted{$keyword}++;
2432 my @localpaths = i_method "i_want", $keyword;
2433 printdebug "[[ $keyword @localpaths\n";
2434 foreach my $localpath (@localpaths) {
2435 protocol_send_file \*RI, $localpath;
2437 print RI "files-end\n" or die $!;
2440 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2442 sub i_localname_parsed_changelog {
2443 return "remote-changelog.822";
2445 sub i_file_parsed_changelog {
2446 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2447 push_parse_changelog "$i_tmp/remote-changelog.822";
2448 die if $i_dscfn =~ m#/|^\W#;
2451 sub i_localname_dsc {
2452 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2457 sub i_localname_changes {
2458 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2459 $i_changesfn = $i_dscfn;
2460 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2461 return $i_changesfn;
2463 sub i_file_changes { }
2465 sub i_want_signed_tag {
2466 printdebug Dumper(\%i_param, $i_dscfn);
2467 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2468 && defined $i_param{'csuite'}
2469 or badproto \*RO, "premature desire for signed-tag";
2470 my $head = $i_param{'head'};
2471 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2473 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2475 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2478 push_mktag $head, $i_clogp, $i_tag,
2480 $i_changesfn, 'remote changes',
2481 sub { "tag$_[0]"; };
2486 sub i_want_signed_dsc_changes {
2487 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2488 sign_changes $i_changesfn;
2489 return ($i_dscfn, $i_changesfn);
2492 #---------- building etc. ----------
2498 #----- `3.0 (quilt)' handling -----
2500 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2502 sub quiltify_dpkg_commit ($$$;$) {
2503 my ($patchname,$author,$msg, $xinfo) = @_;
2507 my $descfn = ".git/dgit/quilt-description.tmp";
2508 open O, '>', $descfn or die "$descfn: $!";
2511 $msg =~ s/^\s+$/ ./mg;
2512 print O <<END or die $!;
2522 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2523 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2524 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2525 runcmd @dpkgsource, qw(--commit .), $patchname;
2529 sub quiltify_trees_differ ($$;$$) {
2530 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2531 # returns true iff the two tree objects differ other than in debian/
2532 # with $finegrained,
2533 # returns bitmask 01 - differ in upstream files except .gitignore
2534 # 02 - differ in .gitignore
2535 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2536 # is set for each modified .gitignore filename $fn
2538 my @cmd = (@git, qw(diff-tree --name-only -z));
2539 push @cmd, qw(-r) if $finegrained;
2541 my $diffs= cmdoutput @cmd;
2543 foreach my $f (split /\0/, $diffs) {
2544 next if $f =~ m#^debian(?:/.*)?$#s;
2545 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2546 $r |= $isignore ? 02 : 01;
2547 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2549 printdebug "quiltify_trees_differ $x $y => $r\n";
2553 sub quiltify_tree_sentinelfiles ($) {
2554 # lists the `sentinel' files present in the tree
2556 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2557 qw(-- debian/rules debian/control);
2562 sub quiltify_splitbrain_needed () {
2563 if (!$split_brain) {
2564 progress "dgit view: changes are required...";
2565 runcmd @git, qw(checkout -q -b dgit-view);
2570 sub quiltify_splitbrain ($$$$$$) {
2571 my ($clogp, $unapplied, $headref, $diffbits,
2572 $editedignores, $cachekey) = @_;
2573 if ($quilt_mode !~ m/gbp|dpm/) {
2574 # treat .gitignore just like any other upstream file
2575 $diffbits = { %$diffbits };
2576 $_ = !!$_ foreach values %$diffbits;
2578 # We would like any commits we generate to be reproducible
2579 my @authline = clogp_authline($clogp);
2580 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2581 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2582 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2584 if ($quilt_mode =~ m/gbp|unapplied/ &&
2585 ($diffbits->{H2O} & 01)) {
2587 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2588 " but git tree differs from orig in upstream files.";
2589 if (!stat_exists "debian/patches") {
2591 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2595 if ($quilt_mode =~ m/gbp|unapplied/ &&
2596 ($diffbits->{O2A} & 01)) { # some patches
2597 quiltify_splitbrain_needed();
2598 progress "dgit view: creating patches-applied version using gbp pq";
2599 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2600 # gbp pq import creates a fresh branch; push back to dgit-view
2601 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2602 runcmd @git, qw(checkout -q dgit-view);
2604 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2605 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2606 quiltify_splitbrain_needed();
2607 progress "dgit view: creating patch to represent .gitignore changes";
2608 ensuredir "debian/patches";
2609 my $gipatch = "debian/patches/auto-gitignore";
2610 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2611 stat GIPATCH or die "$gipatch: $!";
2612 fail "$gipatch already exists; but want to create it".
2613 " to record .gitignore changes" if (stat _)[7];
2614 print GIPATCH <<END or die "$gipatch: $!";
2615 Subject: Update .gitignore from Debian packaging branch
2617 The Debian packaging git branch contains these updates to the upstream
2618 .gitignore file(s). This patch is autogenerated, to provide these
2619 updates to users of the official Debian archive view of the package.
2621 [dgit version $our_version]
2624 close GIPATCH or die "$gipatch: $!";
2625 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2626 $unapplied, $headref, "--", sort keys %$editedignores;
2627 open SERIES, "+>>", "debian/patches/series" or die $!;
2628 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2630 defined read SERIES, $newline, 1 or die $!;
2631 print SERIES "\n" or die $! unless $newline eq "\n";
2632 print SERIES "auto-gitignore\n" or die $!;
2633 close SERIES or die $!;
2634 runcmd @git, qw(add -- debian/patches/series), $gipatch;
2635 commit_admin "Commit patch to update .gitignore";
2638 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2640 changedir '../../../..';
2641 ensuredir ".git/logs/refs/dgit-intern";
2642 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2644 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2647 progress "dgit view: created (commit id $dgitview)";
2649 changedir '.git/dgit/unpack/work';
2652 sub quiltify ($$$$) {
2653 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2655 # Quilt patchification algorithm
2657 # We search backwards through the history of the main tree's HEAD
2658 # (T) looking for a start commit S whose tree object is identical
2659 # to to the patch tip tree (ie the tree corresponding to the
2660 # current dpkg-committed patch series). For these purposes
2661 # `identical' disregards anything in debian/ - this wrinkle is
2662 # necessary because dpkg-source treates debian/ specially.
2664 # We can only traverse edges where at most one of the ancestors'
2665 # trees differs (in changes outside in debian/). And we cannot
2666 # handle edges which change .pc/ or debian/patches. To avoid
2667 # going down a rathole we avoid traversing edges which introduce
2668 # debian/rules or debian/control. And we set a limit on the
2669 # number of edges we are willing to look at.
2671 # If we succeed, we walk forwards again. For each traversed edge
2672 # PC (with P parent, C child) (starting with P=S and ending with
2673 # C=T) to we do this:
2675 # - dpkg-source --commit with a patch name and message derived from C
2676 # After traversing PT, we git commit the changes which
2677 # should be contained within debian/patches.
2679 # The search for the path S..T is breadth-first. We maintain a
2680 # todo list containing search nodes. A search node identifies a
2681 # commit, and looks something like this:
2683 # Commit => $git_commit_id,
2684 # Child => $c, # or undef if P=T
2685 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2686 # Nontrivial => true iff $p..$c has relevant changes
2693 my %considered; # saves being exponential on some weird graphs
2695 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2698 my ($search,$whynot) = @_;
2699 printdebug " search NOT $search->{Commit} $whynot\n";
2700 $search->{Whynot} = $whynot;
2701 push @nots, $search;
2702 no warnings qw(exiting);
2711 my $c = shift @todo;
2712 next if $considered{$c->{Commit}}++;
2714 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2716 printdebug "quiltify investigate $c->{Commit}\n";
2719 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2720 printdebug " search finished hooray!\n";
2725 if ($quilt_mode eq 'nofix') {
2726 fail "quilt fixup required but quilt mode is \`nofix'\n".
2727 "HEAD commit $c->{Commit} differs from tree implied by ".
2728 " debian/patches (tree object $oldtiptree)";
2730 if ($quilt_mode eq 'smash') {
2731 printdebug " search quitting smash\n";
2735 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2736 $not->($c, "has $c_sentinels not $t_sentinels")
2737 if $c_sentinels ne $t_sentinels;
2739 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2740 $commitdata =~ m/\n\n/;
2742 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2743 @parents = map { { Commit => $_, Child => $c } } @parents;
2745 $not->($c, "root commit") if !@parents;
2747 foreach my $p (@parents) {
2748 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2750 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2751 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2753 foreach my $p (@parents) {
2754 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2756 my @cmd= (@git, qw(diff-tree -r --name-only),
2757 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2758 my $patchstackchange = cmdoutput @cmd;
2759 if (length $patchstackchange) {
2760 $patchstackchange =~ s/\n/,/g;
2761 $not->($p, "changed $patchstackchange");
2764 printdebug " search queue P=$p->{Commit} ",
2765 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2771 printdebug "quiltify want to smash\n";
2774 my $x = $_[0]{Commit};
2775 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2778 my $reportnot = sub {
2780 my $s = $abbrev->($notp);
2781 my $c = $notp->{Child};
2782 $s .= "..".$abbrev->($c) if $c;
2783 $s .= ": ".$notp->{Whynot};
2786 if ($quilt_mode eq 'linear') {
2787 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2788 foreach my $notp (@nots) {
2789 print STDERR "$us: ", $reportnot->($notp), "\n";
2791 print STDERR "$us: $_\n" foreach @$failsuggestion;
2792 fail "quilt fixup naive history linearisation failed.\n".
2793 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2794 } elsif ($quilt_mode eq 'smash') {
2795 } elsif ($quilt_mode eq 'auto') {
2796 progress "quilt fixup cannot be linear, smashing...";
2798 die "$quilt_mode ?";
2803 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2805 quiltify_dpkg_commit "auto-$version-$target-$time",
2806 (getfield $clogp, 'Maintainer'),
2807 "Automatically generated patch ($clogp->{Version})\n".
2808 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2812 progress "quiltify linearisation planning successful, executing...";
2814 for (my $p = $sref_S;
2815 my $c = $p->{Child};
2817 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2818 next unless $p->{Nontrivial};
2820 my $cc = $c->{Commit};
2822 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2823 $commitdata =~ m/\n\n/ or die "$c ?";
2826 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2829 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2832 my $patchname = $title;
2833 $patchname =~ s/[.:]$//;
2834 $patchname =~ y/ A-Z/-a-z/;
2835 $patchname =~ y/-a-z0-9_.+=~//cd;
2836 $patchname =~ s/^\W/x-$&/;
2837 $patchname = substr($patchname,0,40);
2840 stat "debian/patches/$patchname$index";
2842 $!==ENOENT or die "$patchname$index $!";
2844 runcmd @git, qw(checkout -q), $cc;
2846 # We use the tip's changelog so that dpkg-source doesn't
2847 # produce complaining messages from dpkg-parsechangelog. None
2848 # of the information dpkg-source gets from the changelog is
2849 # actually relevant - it gets put into the original message
2850 # which dpkg-source provides our stunt editor, and then
2852 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2854 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2855 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2857 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2860 runcmd @git, qw(checkout -q master);
2863 sub build_maybe_quilt_fixup () {
2864 my ($format,$fopts) = get_source_format;
2865 return unless madformat $format;
2868 check_for_vendor_patches();
2870 my $clogp = parsechangelog();
2871 my $headref = git_rev_parse('HEAD');
2876 my $upstreamversion=$version;
2877 $upstreamversion =~ s/-[^-]*$//;
2879 if ($fopts->{'single-debian-patch'}) {
2880 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2882 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2885 die 'bug' if $split_brain && !$need_split_build_invocation;
2887 changedir '../../../..';
2888 runcmd_ordryrun_local
2889 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2892 sub quilt_fixup_mkwork ($) {
2895 mkdir "work" or die $!;
2897 mktree_in_ud_here();
2898 runcmd @git, qw(reset -q --hard), $headref;
2901 sub quilt_fixup_linkorigs ($$) {
2902 my ($upstreamversion, $fn) = @_;
2903 # calls $fn->($leafname);
2905 foreach my $f (<../../../../*>) { #/){
2906 my $b=$f; $b =~ s{.*/}{};
2908 local ($debuglevel) = $debuglevel-1;
2909 printdebug "QF linkorigs $b, $f ?\n";
2911 next unless is_orig_file $b, srcfn $upstreamversion,'';
2912 printdebug "QF linkorigs $b, $f Y\n";
2913 link_ltarget $f, $b or die "$b $!";
2918 sub quilt_fixup_delete_pc () {
2919 runcmd @git, qw(rm -rqf .pc);
2920 commit_admin "Commit removal of .pc (quilt series tracking data)";
2923 sub quilt_fixup_singlepatch ($$$) {
2924 my ($clogp, $headref, $upstreamversion) = @_;
2926 progress "starting quiltify (single-debian-patch)";
2928 # dpkg-source --commit generates new patches even if
2929 # single-debian-patch is in debian/source/options. In order to
2930 # get it to generate debian/patches/debian-changes, it is
2931 # necessary to build the source package.
2933 quilt_fixup_linkorigs($upstreamversion, sub { });
2934 quilt_fixup_mkwork($headref);
2936 rmtree("debian/patches");
2938 runcmd @dpkgsource, qw(-b .);
2940 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2941 rename srcfn("$upstreamversion", "/debian/patches"),
2942 "work/debian/patches";
2945 commit_quilty_patch();
2950 sub quilt_fixup_multipatch ($$$) {
2951 my ($clogp, $headref, $upstreamversion) = @_;
2953 progress "examining quilt state (multiple patches, $quilt_mode mode)";
2956 # - honour any existing .pc in case it has any strangeness
2957 # - determine the git commit corresponding to the tip of
2958 # the patch stack (if there is one)
2959 # - if there is such a git commit, convert each subsequent
2960 # git commit into a quilt patch with dpkg-source --commit
2961 # - otherwise convert all the differences in the tree into
2962 # a single git commit
2966 # Our git tree doesn't necessarily contain .pc. (Some versions of
2967 # dgit would include the .pc in the git tree.) If there isn't
2968 # one, we need to generate one by unpacking the patches that we
2971 # We first look for a .pc in the git tree. If there is one, we
2972 # will use it. (This is not the normal case.)
2974 # Otherwise need to regenerate .pc so that dpkg-source --commit
2975 # can work. We do this as follows:
2976 # 1. Collect all relevant .orig from parent directory
2977 # 2. Generate a debian.tar.gz out of
2978 # debian/{patches,rules,source/format,source/options}
2979 # 3. Generate a fake .dsc containing just these fields:
2980 # Format Source Version Files
2981 # 4. Extract the fake .dsc
2982 # Now the fake .dsc has a .pc directory.
2983 # (In fact we do this in every case, because in future we will
2984 # want to search for a good base commit for generating patches.)
2986 # Then we can actually do the dpkg-source --commit
2987 # 1. Make a new working tree with the same object
2988 # store as our main tree and check out the main
2990 # 2. Copy .pc from the fake's extraction, if necessary
2991 # 3. Run dpkg-source --commit
2992 # 4. If the result has changes to debian/, then
2993 # - git-add them them
2994 # - git-add .pc if we had a .pc in-tree
2996 # 5. If we had a .pc in-tree, delete it, and git-commit
2997 # 6. Back in the main tree, fast forward to the new HEAD
2999 # Another situation we may have to cope with is gbp-style
3000 # patches-unapplied trees.
3002 # We would want to detect these, so we know to escape into
3003 # quilt_fixup_gbp. However, this is in general not possible.
3004 # Consider a package with a one patch which the dgit user reverts
3005 # (with git-revert or the moral equivalent).
3007 # That is indistinguishable in contents from a patches-unapplied
3008 # tree. And looking at the history to distinguish them is not
3009 # useful because the user might have made a confusing-looking git
3010 # history structure (which ought to produce an error if dgit can't
3011 # cope, not a silent reintroduction of an unwanted patch).
3013 # So gbp users will have to pass an option. But we can usually
3014 # detect their failure to do so: if the tree is not a clean
3015 # patches-applied tree, quilt linearisation fails, but the tree
3016 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3017 # they want --quilt=unapplied.
3019 # To help detect this, when we are extracting the fake dsc, we
3020 # first extract it with --skip-patches, and then apply the patches
3021 # afterwards with dpkg-source --before-build. That lets us save a
3022 # tree object corresponding to .origs.
3024 my $fakeversion="$upstreamversion-~~DGITFAKE";
3026 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3027 print $fakedsc <<END or die $!;
3030 Version: $fakeversion
3034 my $dscaddfile=sub {
3037 my $md = new Digest::MD5;
3039 my $fh = new IO::File $b, '<' or die "$b $!";
3044 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3047 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3049 my @files=qw(debian/source/format debian/rules
3050 debian/control debian/changelog);
3051 foreach my $maybe (qw(debian/patches debian/source/options
3052 debian/tests/control)) {
3053 next unless stat_exists "../../../$maybe";
3054 push @files, $maybe;
3057 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3058 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3060 $dscaddfile->($debtar);
3061 close $fakedsc or die $!;
3063 my $splitbrain_cachekey;
3064 if (quiltmode_splitbrain()) {
3066 "dgit: split brain (separate dgit view) may needed (--quilt=$quilt_mode).";
3067 # we look in the reflog of dgit-intern/quilt-cache
3068 # we look for an entry whose message is the key for the cache lookup
3069 my @cachekey = (qw(dgit), $our_version);
3070 push @cachekey, $upstreamversion;
3071 push @cachekey, $quilt_mode;
3072 push @cachekey, $headref;
3074 push @cachekey, hashfile('fake.dsc');
3076 my $srcshash = Digest::SHA->new(256);
3077 my %sfs = ( %INC, '$0(dgit)' => $0 );
3078 foreach my $sfk (sort keys %sfs) {
3079 $srcshash->add($sfk," ");
3080 $srcshash->add(hashfile($sfs{$sfk}));
3081 $srcshash->add("\n");
3083 push @cachekey, $srcshash->hexdigest();
3084 $splitbrain_cachekey = "@cachekey";
3086 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3088 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3089 debugcmd "|(probably)",@cmd;
3090 my $child = open GC, "-|"; defined $child or die $!;
3092 chdir '../../..' or die $!;
3093 if (!stat ".git/logs/refs/$splitbraincache") {
3094 $! == ENOENT or die $!;
3095 printdebug ">(no reflog)\n";
3102 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3103 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3106 quilt_fixup_mkwork($headref);
3107 if ($cachehit ne $headref) {
3108 progress "dgit view: found cached (commit id $cachehit)";
3109 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3113 progress "dgit view: found cached, no changes required";
3116 die $! if GC->error;
3117 failedcmd unless close GC;
3119 printdebug "splitbrain cache miss\n";
3123 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3125 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3126 rename $fakexdir, "fake" or die "$fakexdir $!";
3130 remove_stray_gits();
3131 mktree_in_ud_here();
3135 runcmd @git, qw(add -Af .);
3136 my $unapplied=git_write_tree();
3137 printdebug "fake orig tree object $unapplied\n";
3142 'exec dpkg-source --before-build . >/dev/null';
3146 quilt_fixup_mkwork($headref);
3149 if (stat_exists ".pc") {
3151 progress "Tree already contains .pc - will use it then delete it.";
3154 rename '../fake/.pc','.pc' or die $!;
3157 changedir '../fake';
3159 runcmd @git, qw(add -Af .);
3160 my $oldtiptree=git_write_tree();
3161 printdebug "fake o+d/p tree object $unapplied\n";
3162 changedir '../work';
3165 # We calculate some guesswork now about what kind of tree this might
3166 # be. This is mostly for error reporting.
3171 # O = orig, without patches applied
3172 # A = "applied", ie orig with H's debian/patches applied
3173 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3174 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3175 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3179 foreach my $b (qw(01 02)) {
3180 foreach my $v (qw(H2O O2A H2A)) {
3181 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3184 printdebug "differences \@dl @dl.\n";
3187 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3188 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3189 $dl[0], $dl[1], $dl[3], $dl[4],
3193 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3194 push @failsuggestion, "This might be a patches-unapplied branch.";
3195 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3196 push @failsuggestion, "This might be a patches-applied branch.";
3198 push @failsuggestion, "Maybe you need to specify one of".
3199 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3201 if (quiltmode_splitbrain()) {
3202 quiltify_splitbrain($clogp, $unapplied, $headref,
3203 $diffbits, \%editedignores,
3204 $splitbrain_cachekey);
3208 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3209 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3211 if (!open P, '>>', ".pc/applied-patches") {
3212 $!==&ENOENT or die $!;
3217 commit_quilty_patch();
3219 if ($mustdeletepc) {
3220 quilt_fixup_delete_pc();
3224 sub quilt_fixup_editor () {
3225 my $descfn = $ENV{$fakeeditorenv};
3226 my $editing = $ARGV[$#ARGV];
3227 open I1, '<', $descfn or die "$descfn: $!";
3228 open I2, '<', $editing or die "$editing: $!";
3229 unlink $editing or die "$editing: $!";
3230 open O, '>', $editing or die "$editing: $!";
3231 while (<I1>) { print O or die $!; } I1->error and die $!;
3234 $copying ||= m/^\-\-\- /;
3235 next unless $copying;
3238 I2->error and die $!;
3243 sub maybe_apply_patches_dirtily () {
3244 return unless $quilt_mode =~ m/gbp|unapplied/;
3245 print STDERR <<END or die $!;
3247 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3248 dgit: Have to apply the patches - making the tree dirty.
3249 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3252 $patches_applied_dirtily = 01;
3253 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3254 runcmd qw(dpkg-source --before-build .);
3257 sub maybe_unapply_patches_again () {
3258 progress "dgit: Unapplying patches again to tidy up the tree."
3259 if $patches_applied_dirtily;
3260 runcmd qw(dpkg-source --after-build .)
3261 if $patches_applied_dirtily & 01;
3263 if $patches_applied_dirtily & 02;
3266 #----- other building -----
3268 our $clean_using_builder;
3269 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3270 # clean the tree before building (perhaps invoked indirectly by
3271 # whatever we are using to run the build), rather than separately
3272 # and explicitly by us.
3275 return if $clean_using_builder;
3276 if ($cleanmode eq 'dpkg-source') {
3277 maybe_apply_patches_dirtily();
3278 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3279 } elsif ($cleanmode eq 'dpkg-source-d') {
3280 maybe_apply_patches_dirtily();
3281 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3282 } elsif ($cleanmode eq 'git') {
3283 runcmd_ordryrun_local @git, qw(clean -xdf);
3284 } elsif ($cleanmode eq 'git-ff') {
3285 runcmd_ordryrun_local @git, qw(clean -xdff);
3286 } elsif ($cleanmode eq 'check') {
3287 my $leftovers = cmdoutput @git, qw(clean -xdn);
3288 if (length $leftovers) {
3289 print STDERR $leftovers, "\n" or die $!;
3290 fail "tree contains uncommitted files and --clean=check specified";
3292 } elsif ($cleanmode eq 'none') {
3299 badusage "clean takes no additional arguments" if @ARGV;
3302 maybe_unapply_patches_again();
3307 badusage "-p is not allowed when building" if defined $package;
3310 my $clogp = parsechangelog();
3311 $isuite = getfield $clogp, 'Distribution';
3312 $package = getfield $clogp, 'Source';
3313 $version = getfield $clogp, 'Version';
3314 build_maybe_quilt_fixup();
3316 my $pat = changespat $version;
3317 foreach my $f (glob "$buildproductsdir/$pat") {
3319 unlink $f or fail "remove old changes file $f: $!";
3321 progress "would remove $f";
3327 sub changesopts_initial () {
3328 my @opts =@changesopts[1..$#changesopts];
3331 sub changesopts_version () {
3332 if (!defined $changes_since_version) {
3333 my @vsns = archive_query('archive_query');
3334 my @quirk = access_quirk();
3335 if ($quirk[0] eq 'backports') {
3336 local $isuite = $quirk[2];
3338 canonicalise_suite();
3339 push @vsns, archive_query('archive_query');
3342 @vsns = map { $_->[0] } @vsns;
3343 @vsns = sort { -version_compare($a, $b) } @vsns;
3344 $changes_since_version = $vsns[0];
3345 progress "changelog will contain changes since $vsns[0]";
3347 $changes_since_version = '_';
3348 progress "package seems new, not specifying -v<version>";
3351 if ($changes_since_version ne '_') {
3352 return ("-v$changes_since_version");
3358 sub changesopts () {
3359 return (changesopts_initial(), changesopts_version());
3362 sub massage_dbp_args ($;$) {
3363 my ($cmd,$xargs) = @_;
3366 # - if we're going to split the source build out so we can
3367 # do strange things to it, massage the arguments to dpkg-buildpackage
3368 # so that the main build doessn't build source (or add an argument
3369 # to stop it building source by default).
3371 # - add -nc to stop dpkg-source cleaning the source tree,
3372 # unless we're not doing a split build and want dpkg-source
3373 # as cleanmode, in which case we can do nothing
3376 # 0 - source will NOT need to be built separately by caller
3377 # +1 - source will need to be built separately by caller
3378 # +2 - source will need to be built separately by caller AND
3379 # dpkg-buildpackage should not in fact be run at all!
3380 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3381 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3382 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3383 $clean_using_builder = 1;
3386 # -nc has the side effect of specifying -b if nothing else specified
3387 # and some combinations of -S, -b, et al, are errors, rather than
3388 # later simply overriding earlie. So we need to:
3389 # - search the command line for these options
3390 # - pick the last one
3391 # - perhaps add our own as a default
3392 # - perhaps adjust it to the corresponding non-source-building version
3394 foreach my $l ($cmd, $xargs) {
3396 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3399 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3401 if ($need_split_build_invocation) {
3402 printdebug "massage split $dmode.\n";
3403 $r = $dmode =~ m/[S]/ ? +2 :
3404 $dmode =~ y/gGF/ABb/ ? +1 :
3405 $dmode =~ m/[ABb]/ ? 0 :
3408 printdebug "massage done $r $dmode.\n";
3410 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3415 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3416 my $wantsrc = massage_dbp_args \@dbp;
3423 push @dbp, changesopts_version();
3424 maybe_apply_patches_dirtily();
3425 runcmd_ordryrun_local @dbp;
3427 maybe_unapply_patches_again();
3428 printdone "build successful\n";
3432 my @dbp = @dpkgbuildpackage;
3434 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3437 if (length executable_on_path('git-buildpackage')) {
3438 @cmd = qw(git-buildpackage);
3440 @cmd = qw(gbp buildpackage);
3442 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3447 if (!$clean_using_builder) {
3448 push @cmd, '--git-cleaner=true';
3453 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3454 canonicalise_suite();
3455 push @cmd, "--git-debian-branch=".lbranch();
3457 push @cmd, changesopts();
3458 maybe_apply_patches_dirtily();
3459 runcmd_ordryrun_local @cmd, @ARGV;
3461 maybe_unapply_patches_again();
3462 printdone "build successful\n";
3464 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3467 my $our_cleanmode = $cleanmode;
3468 if ($need_split_build_invocation) {
3469 # Pretend that clean is being done some other way. This
3470 # forces us not to try to use dpkg-buildpackage to clean and
3471 # build source all in one go; and instead we run dpkg-source
3472 # (and build_prep() will do the clean since $clean_using_builder
3474 $our_cleanmode = 'ELSEWHERE';
3476 if ($our_cleanmode =~ m/^dpkg-source/) {
3477 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3478 $clean_using_builder = 1;
3481 $sourcechanges = changespat $version,'source';
3483 unlink "../$sourcechanges" or $!==ENOENT
3484 or fail "remove $sourcechanges: $!";
3486 $dscfn = dscfn($version);
3487 if ($our_cleanmode eq 'dpkg-source') {
3488 maybe_apply_patches_dirtily();
3489 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3491 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3492 maybe_apply_patches_dirtily();
3493 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3496 my @cmd = (@dpkgsource, qw(-b --));
3499 runcmd_ordryrun_local @cmd, "work";
3500 my @udfiles = <${package}_*>;
3501 changedir "../../..";
3502 foreach my $f (@udfiles) {
3503 printdebug "source copy, found $f\n";
3506 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3507 $f eq srcfn($version, $&));
3508 printdebug "source copy, found $f - renaming\n";
3509 rename "$ud/$f", "../$f" or $!==ENOENT
3510 or fail "put in place new source file ($f): $!";
3513 my $pwd = must_getcwd();
3514 my $leafdir = basename $pwd;
3516 runcmd_ordryrun_local @cmd, $leafdir;
3519 runcmd_ordryrun_local qw(sh -ec),
3520 'exec >$1; shift; exec "$@"','x',
3521 "../$sourcechanges",
3522 @dpkggenchanges, qw(-S), changesopts();
3526 sub cmd_build_source {
3527 badusage "build-source takes no additional arguments" if @ARGV;
3529 maybe_unapply_patches_again();
3530 printdone "source built, results in $dscfn and $sourcechanges";
3535 my $pat = changespat $version;
3537 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3538 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3539 fail "changes files other than source matching $pat".
3540 " already present (@unwanted);".
3541 " building would result in ambiguity about the intended results"
3546 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3547 stat_exists $sourcechanges
3548 or fail "$sourcechanges (in parent directory): $!";
3550 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3551 my @changesfiles = glob $pat;
3552 @changesfiles = sort {
3553 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3556 fail "wrong number of different changes files (@changesfiles)"
3557 unless @changesfiles==2;
3558 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3559 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3560 fail "$l found in binaries changes file $binchanges"
3563 runcmd_ordryrun_local @mergechanges, @changesfiles;
3564 my $multichanges = changespat $version,'multi';
3566 stat_exists $multichanges or fail "$multichanges: $!";
3567 foreach my $cf (glob $pat) {
3568 next if $cf eq $multichanges;
3569 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3572 maybe_unapply_patches_again();
3573 printdone "build successful, results in $multichanges\n" or die $!;
3576 sub cmd_quilt_fixup {
3577 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3578 my $clogp = parsechangelog();
3579 $version = getfield $clogp, 'Version';
3580 $package = getfield $clogp, 'Source';
3583 build_maybe_quilt_fixup();
3586 sub cmd_archive_api_query {
3587 badusage "need only 1 subpath argument" unless @ARGV==1;
3588 my ($subpath) = @ARGV;
3589 my @cmd = archive_api_query_cmd($subpath);
3591 exec @cmd or fail "exec curl: $!\n";
3594 sub cmd_clone_dgit_repos_server {
3595 badusage "need destination argument" unless @ARGV==1;
3596 my ($destdir) = @ARGV;
3597 $package = '_dgit-repos-server';
3598 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3600 exec @cmd or fail "exec git clone: $!\n";
3603 sub cmd_setup_mergechangelogs {
3604 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3605 setup_mergechangelogs(1);
3608 sub cmd_setup_useremail {
3609 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3613 sub cmd_setup_new_tree {
3614 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3618 #---------- argument parsing and main program ----------
3621 print "dgit version $our_version\n" or die $!;
3625 our (%valopts_long, %valopts_short);
3628 sub defvalopt ($$$$) {
3629 my ($long,$short,$val_re,$how) = @_;
3630 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3631 $valopts_long{$long} = $oi;
3632 $valopts_short{$short} = $oi;
3633 # $how subref should:
3634 # do whatever assignemnt or thing it likes with $_[0]
3635 # if the option should not be passed on to remote, @rvalopts=()
3636 # or $how can be a scalar ref, meaning simply assign the value
3639 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3640 defvalopt '--distro', '-d', '.+', \$idistro;
3641 defvalopt '', '-k', '.+', \$keyid;
3642 defvalopt '--existing-package','', '.*', \$existing_package;
3643 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3644 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3645 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3647 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3649 defvalopt '', '-C', '.+', sub {
3650 ($changesfile) = (@_);
3651 if ($changesfile =~ s#^(.*)/##) {
3652 $buildproductsdir = $1;
3656 defvalopt '--initiator-tempdir','','.*', sub {
3657 ($initiator_tempdir) = (@_);
3658 $initiator_tempdir =~ m#^/# or
3659 badusage "--initiator-tempdir must be used specify an".
3660 " absolute, not relative, directory."
3666 if (defined $ENV{'DGIT_SSH'}) {
3667 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3668 } elsif (defined $ENV{'GIT_SSH'}) {
3669 @ssh = ($ENV{'GIT_SSH'});
3677 if (!defined $val) {
3678 badusage "$what needs a value" unless @ARGV;
3680 push @rvalopts, $val;
3682 badusage "bad value \`$val' for $what" unless
3683 $val =~ m/^$oi->{Re}$(?!\n)/s;
3684 my $how = $oi->{How};
3685 if (ref($how) eq 'SCALAR') {
3690 push @ropts, @rvalopts;
3694 last unless $ARGV[0] =~ m/^-/;
3698 if (m/^--dry-run$/) {
3701 } elsif (m/^--damp-run$/) {
3704 } elsif (m/^--no-sign$/) {
3707 } elsif (m/^--help$/) {
3709 } elsif (m/^--version$/) {
3711 } elsif (m/^--new$/) {
3714 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3715 ($om = $opts_opt_map{$1}) &&
3719 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3720 !$opts_opt_cmdonly{$1} &&
3721 ($om = $opts_opt_map{$1})) {
3724 } elsif (m/^--ignore-dirty$/s) {
3727 } elsif (m/^--no-quilt-fixup$/s) {
3729 $quilt_mode = 'nocheck';
3730 } elsif (m/^--no-rm-on-error$/s) {
3733 } elsif (m/^--(no-)?rm-old-changes$/s) {
3736 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3738 push @deliberatelies, $&;
3739 } elsif (m/^--always-split-source-build$/s) {
3740 # undocumented, for testing
3742 $need_split_build_invocation = 1;
3743 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3744 $val = $2 ? $' : undef; #';
3745 $valopt->($oi->{Long});
3747 badusage "unknown long option \`$_'";
3754 } elsif (s/^-L/-/) {
3757 } elsif (s/^-h/-/) {
3759 } elsif (s/^-D/-/) {
3763 } elsif (s/^-N/-/) {
3768 push @changesopts, $_;
3770 } elsif (s/^-wn$//s) {
3772 $cleanmode = 'none';
3773 } elsif (s/^-wg$//s) {
3776 } elsif (s/^-wgf$//s) {
3778 $cleanmode = 'git-ff';
3779 } elsif (s/^-wd$//s) {
3781 $cleanmode = 'dpkg-source';
3782 } elsif (s/^-wdd$//s) {
3784 $cleanmode = 'dpkg-source-d';
3785 } elsif (s/^-wc$//s) {
3787 $cleanmode = 'check';
3788 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3790 $val = undef unless length $val;
3791 $valopt->($oi->{Short});
3794 badusage "unknown short option \`$_'";
3801 sub finalise_opts_opts () {
3802 foreach my $k (keys %opts_opt_map) {
3803 my $om = $opts_opt_map{$k};
3805 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3807 badcfg "cannot set command for $k"
3808 unless length $om->[0];
3812 foreach my $c (access_cfg_cfgs("opts-$k")) {
3813 my $vl = $gitcfg{$c};
3814 printdebug "CL $c ",
3815 ($vl ? join " ", map { shellquote } @$vl : ""),
3816 "\n" if $debuglevel >= 4;
3818 badcfg "cannot configure options for $k"
3819 if $opts_opt_cmdonly{$k};
3820 my $insertpos = $opts_cfg_insertpos{$k};
3821 @$om = ( @$om[0..$insertpos-1],
3823 @$om[$insertpos..$#$om] );
3828 if ($ENV{$fakeeditorenv}) {
3830 quilt_fixup_editor();
3836 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3837 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3838 if $dryrun_level == 1;
3840 print STDERR $helpmsg or die $!;
3843 my $cmd = shift @ARGV;
3846 if (!defined $rmchanges) {
3847 local $access_forpush;
3848 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3851 if (!defined $quilt_mode) {
3852 local $access_forpush;
3853 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3854 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3856 $quilt_mode =~ m/^($quilt_modes_re)$/
3857 or badcfg "unknown quilt-mode \`$quilt_mode'";
3861 $need_split_build_invocation ||= quiltmode_splitbrain();
3863 if (!defined $cleanmode) {
3864 local $access_forpush;
3865 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3866 $cleanmode //= 'dpkg-source';
3868 badcfg "unknown clean-mode \`$cleanmode'" unless
3869 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3872 my $fn = ${*::}{"cmd_$cmd"};
3873 $fn or badusage "unknown operation $cmd";