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); # 4 is new tag format
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;
71 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
73 our $suite_re = '[-+.0-9a-z]+';
74 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
76 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
77 our $splitbraincache = 'dgit-intern/quilt-cache';
80 our (@dget) = qw(dget);
81 our (@curl) = qw(curl -f);
82 our (@dput) = qw(dput);
83 our (@debsign) = qw(debsign);
85 our (@sbuild) = qw(sbuild);
87 our (@dgit) = qw(dgit);
88 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
89 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
90 our (@dpkggenchanges) = qw(dpkg-genchanges);
91 our (@mergechanges) = qw(mergechanges -f);
93 our (@changesopts) = ('');
95 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
98 'debsign' => \@debsign,
100 'sbuild' => \@sbuild,
104 'dpkg-source' => \@dpkgsource,
105 'dpkg-buildpackage' => \@dpkgbuildpackage,
106 'dpkg-genchanges' => \@dpkggenchanges,
108 'ch' => \@changesopts,
109 'mergechanges' => \@mergechanges);
111 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
112 our %opts_cfg_insertpos = map {
114 scalar @{ $opts_opt_map{$_} }
115 } keys %opts_opt_map;
117 sub finalise_opts_opts();
123 our $supplementary_message = '';
124 our $need_split_build_invocation = 0;
125 our $split_brain = 0;
129 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
132 our $remotename = 'dgit';
133 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
138 my ($v,$distro) = @_;
139 return $tagformatfn->($v, $distro);
142 sub lbranch () { return "$branchprefix/$csuite"; }
143 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
144 sub lref () { return "refs/heads/".lbranch(); }
145 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
146 sub rrref () { return server_ref($csuite); }
148 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
158 return "${package}_".(stripepoch $vsn).$sfx
163 return srcfn($vsn,".dsc");
166 sub changespat ($;$) {
167 my ($vsn, $arch) = @_;
168 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
177 foreach my $f (@end) {
179 print STDERR "$us: cleanup: $@" if length $@;
183 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
185 sub no_such_package () {
186 print STDERR "$us: package $package does not exist in suite $isuite\n";
192 return "+".rrref().":".lrref();
197 printdebug "CD $newdir\n";
198 chdir $newdir or die "chdir: $newdir: $!";
201 sub deliberately ($) {
203 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
206 sub deliberately_not_fast_forward () {
207 foreach (qw(not-fast-forward fresh-repo)) {
208 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
212 sub quiltmode_splitbrain () {
213 $quilt_mode =~ m/gbp|dpm|unapplied/;
216 #---------- remote protocol support, common ----------
218 # remote push initiator/responder protocol:
219 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
220 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
221 # < dgit-remote-push-ready <actual-proto-vsn>
228 # > supplementary-message NBYTES # $protovsn >= 3
233 # > file parsed-changelog
234 # [indicates that output of dpkg-parsechangelog follows]
235 # > data-block NBYTES
236 # > [NBYTES bytes of data (no newline)]
237 # [maybe some more blocks]
247 # > param csuite SUITE
249 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
250 # # goes into tag, for replay prevention
253 # [indicates that signed tag is wanted]
254 # < data-block NBYTES
255 # < [NBYTES bytes of data (no newline)]
256 # [maybe some more blocks]
260 # > want signed-dsc-changes
261 # < data-block NBYTES [transfer of signed dsc]
263 # < data-block NBYTES [transfer of signed changes]
271 sub i_child_report () {
272 # Sees if our child has died, and reap it if so. Returns a string
273 # describing how it died if it failed, or undef otherwise.
274 return undef unless $i_child_pid;
275 my $got = waitpid $i_child_pid, WNOHANG;
276 return undef if $got <= 0;
277 die unless $got == $i_child_pid;
278 $i_child_pid = undef;
279 return undef unless $?;
280 return "build host child ".waitstatusmsg();
285 fail "connection lost: $!" if $fh->error;
286 fail "protocol violation; $m not expected";
289 sub badproto_badread ($$) {
291 fail "connection lost: $!" if $!;
292 my $report = i_child_report();
293 fail $report if defined $report;
294 badproto $fh, "eof (reading $wh)";
297 sub protocol_expect (&$) {
298 my ($match, $fh) = @_;
301 defined && chomp or badproto_badread $fh, "protocol message";
309 badproto $fh, "\`$_'";
312 sub protocol_send_file ($$) {
313 my ($fh, $ourfn) = @_;
314 open PF, "<", $ourfn or die "$ourfn: $!";
317 my $got = read PF, $d, 65536;
318 die "$ourfn: $!" unless defined $got;
320 print $fh "data-block ".length($d)."\n" or die $!;
321 print $fh $d or die $!;
323 PF->error and die "$ourfn $!";
324 print $fh "data-end\n" or die $!;
328 sub protocol_read_bytes ($$) {
329 my ($fh, $nbytes) = @_;
330 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
332 my $got = read $fh, $d, $nbytes;
333 $got==$nbytes or badproto_badread $fh, "data block";
337 sub protocol_receive_file ($$) {
338 my ($fh, $ourfn) = @_;
339 printdebug "() $ourfn\n";
340 open PF, ">", $ourfn or die "$ourfn: $!";
342 my ($y,$l) = protocol_expect {
343 m/^data-block (.*)$/ ? (1,$1) :
344 m/^data-end$/ ? (0,) :
348 my $d = protocol_read_bytes $fh, $l;
349 print PF $d or die $!;
354 #---------- remote protocol support, responder ----------
356 sub responder_send_command ($) {
358 return unless $we_are_responder;
359 # called even without $we_are_responder
360 printdebug ">> $command\n";
361 print PO $command, "\n" or die $!;
364 sub responder_send_file ($$) {
365 my ($keyword, $ourfn) = @_;
366 return unless $we_are_responder;
367 printdebug "]] $keyword $ourfn\n";
368 responder_send_command "file $keyword";
369 protocol_send_file \*PO, $ourfn;
372 sub responder_receive_files ($@) {
373 my ($keyword, @ourfns) = @_;
374 die unless $we_are_responder;
375 printdebug "[[ $keyword @ourfns\n";
376 responder_send_command "want $keyword";
377 foreach my $fn (@ourfns) {
378 protocol_receive_file \*PI, $fn;
381 protocol_expect { m/^files-end$/ } \*PI;
384 #---------- remote protocol support, initiator ----------
386 sub initiator_expect (&) {
388 protocol_expect { &$match } \*RO;
391 #---------- end remote code ----------
394 if ($we_are_responder) {
396 responder_send_command "progress ".length($m) or die $!;
397 print PO $m or die $!;
407 $ua = LWP::UserAgent->new();
411 progress "downloading $what...";
412 my $r = $ua->get(@_) or die $!;
413 return undef if $r->code == 404;
414 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
415 return $r->decoded_content(charset => 'none');
418 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
423 failedcmd @_ if system @_;
426 sub act_local () { return $dryrun_level <= 1; }
427 sub act_scary () { return !$dryrun_level; }
430 if (!$dryrun_level) {
431 progress "dgit ok: @_";
433 progress "would be ok: @_ (but dry run only)";
438 printcmd(\*STDERR,$debugprefix."#",@_);
441 sub runcmd_ordryrun {
449 sub runcmd_ordryrun_local {
458 my ($first_shell, @cmd) = @_;
459 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
462 our $helpmsg = <<END;
464 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
465 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
466 dgit [dgit-opts] build [dpkg-buildpackage-opts]
467 dgit [dgit-opts] sbuild [sbuild-opts]
468 dgit [dgit-opts] push [dgit-opts] [suite]
469 dgit [dgit-opts] rpush build-host:build-dir ...
470 important dgit options:
471 -k<keyid> sign tag and package with <keyid> instead of default
472 --dry-run -n do not change anything, but go through the motions
473 --damp-run -L like --dry-run but make local changes, without signing
474 --new -N allow introducing a new package
475 --debug -D increase debug level
476 -c<name>=<value> set git config option (used directly by dgit too)
479 our $later_warning_msg = <<END;
480 Perhaps the upload is stuck in incoming. Using the version from git.
484 print STDERR "$us: @_\n", $helpmsg or die $!;
489 @ARGV or badusage "too few arguments";
490 return scalar shift @ARGV;
494 print $helpmsg or die $!;
498 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
500 our %defcfg = ('dgit.default.distro' => 'debian',
501 'dgit.default.username' => '',
502 'dgit.default.archive-query-default-component' => 'main',
503 'dgit.default.ssh' => 'ssh',
504 'dgit.default.archive-query' => 'madison:',
505 'dgit.default.sshpsql-dbname' => 'service=projectb',
506 'dgit.default.dgit-tag-format' => 'old,new',
507 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
508 'dgit-distro.debian.git-check' => 'url',
509 'dgit-distro.debian.git-check-suffix' => '/info/refs',
510 'dgit-distro.debian.new-private-pushers' => 't',
511 'dgit-distro.debian.dgit-tag-format' => 'old',
512 'dgit-distro.debian/push.git-url' => '',
513 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
514 'dgit-distro.debian/push.git-user-force' => 'dgit',
515 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
516 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
517 'dgit-distro.debian/push.git-create' => 'true',
518 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
519 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
520 # 'dgit-distro.debian.archive-query-tls-key',
521 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
522 # ^ this does not work because curl is broken nowadays
523 # Fixing #790093 properly will involve providing providing the key
524 # in some pacagke and maybe updating these paths.
526 # 'dgit-distro.debian.archive-query-tls-curl-args',
527 # '--ca-path=/etc/ssl/ca-debian',
528 # ^ this is a workaround but works (only) on DSA-administered machines
529 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
530 'dgit-distro.debian.git-url-suffix' => '',
531 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
532 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
533 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
534 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
535 'dgit-distro.ubuntu.git-check' => 'false',
536 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
537 'dgit-distro.test-dummy.ssh' => "$td/ssh",
538 'dgit-distro.test-dummy.username' => "alice",
539 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
540 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
541 'dgit-distro.test-dummy.git-url' => "$td/git",
542 'dgit-distro.test-dummy.git-host' => "git",
543 'dgit-distro.test-dummy.git-path' => "$td/git",
544 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
545 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
546 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
547 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
552 sub git_slurp_config () {
553 local ($debuglevel) = $debuglevel-2;
556 my @cmd = (@git, qw(config -z --get-regexp .*));
559 open GITS, "-|", @cmd or die $!;
562 printdebug "=> ", (messagequote $_), "\n";
564 push @{ $gitcfg{$`} }, $'; #';
568 or ($!==0 && $?==256)
572 sub git_get_config ($) {
575 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
578 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
584 return undef if $c =~ /RETURN-UNDEF/;
585 my $v = git_get_config($c);
586 return $v if defined $v;
587 my $dv = $defcfg{$c};
588 return $dv if defined $dv;
590 badcfg "need value for one of: @_\n".
591 "$us: distro or suite appears not to be (properly) supported";
594 sub access_basedistro () {
595 if (defined $idistro) {
598 return cfg("dgit-suite.$isuite.distro",
599 "dgit.default.distro");
603 sub access_quirk () {
604 # returns (quirk name, distro to use instead or undef, quirk-specific info)
605 my $basedistro = access_basedistro();
606 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
608 if (defined $backports_quirk) {
609 my $re = $backports_quirk;
610 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
612 $re =~ s/\%/([-0-9a-z_]+)/
613 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
614 if ($isuite =~ m/^$re$/) {
615 return ('backports',"$basedistro-backports",$1);
618 return ('none',undef);
623 sub parse_cfg_bool ($$$) {
624 my ($what,$def,$v) = @_;
627 $v =~ m/^[ty1]/ ? 1 :
628 $v =~ m/^[fn0]/ ? 0 :
629 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
632 sub access_forpush_config () {
633 my $d = access_basedistro();
637 parse_cfg_bool('new-private-pushers', 0,
638 cfg("dgit-distro.$d.new-private-pushers",
641 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
644 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
645 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
646 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
647 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
650 sub access_forpush () {
651 $access_forpush //= access_forpush_config();
652 return $access_forpush;
656 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
657 badcfg "pushing but distro is configured readonly"
658 if access_forpush_config() eq '0';
660 $supplementary_message = <<'END' unless $we_are_responder;
661 Push failed, before we got started.
662 You can retry the push, after fixing the problem, if you like.
664 finalise_opts_opts();
668 finalise_opts_opts();
671 sub supplementary_message ($) {
673 if (!$we_are_responder) {
674 $supplementary_message = $msg;
676 } elsif ($protovsn >= 3) {
677 responder_send_command "supplementary-message ".length($msg)
679 print PO $msg or die $!;
683 sub access_distros () {
684 # Returns list of distros to try, in order
687 # 0. `instead of' distro name(s) we have been pointed to
688 # 1. the access_quirk distro, if any
689 # 2a. the user's specified distro, or failing that } basedistro
690 # 2b. the distro calculated from the suite }
691 my @l = access_basedistro();
693 my (undef,$quirkdistro) = access_quirk();
694 unshift @l, $quirkdistro;
695 unshift @l, $instead_distro;
696 @l = grep { defined } @l;
698 if (access_forpush()) {
699 @l = map { ("$_/push", $_) } @l;
704 sub access_cfg_cfgs (@) {
707 # The nesting of these loops determines the search order. We put
708 # the key loop on the outside so that we search all the distros
709 # for each key, before going on to the next key. That means that
710 # if access_cfg is called with a more specific, and then a less
711 # specific, key, an earlier distro can override the less specific
712 # without necessarily overriding any more specific keys. (If the
713 # distro wants to override the more specific keys it can simply do
714 # so; whereas if we did the loop the other way around, it would be
715 # impossible to for an earlier distro to override a less specific
716 # key but not the more specific ones without restating the unknown
717 # values of the more specific keys.
720 # We have to deal with RETURN-UNDEF specially, so that we don't
721 # terminate the search prematurely.
723 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
726 foreach my $d (access_distros()) {
727 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
729 push @cfgs, map { "dgit.default.$_" } @realkeys;
736 my (@cfgs) = access_cfg_cfgs(@keys);
737 my $value = cfg(@cfgs);
741 sub access_cfg_bool ($$) {
742 my ($def, @keys) = @_;
743 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
746 sub string_to_ssh ($) {
748 if ($spec =~ m/\s/) {
749 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
755 sub access_cfg_ssh () {
756 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
757 if (!defined $gitssh) {
760 return string_to_ssh $gitssh;
764 sub access_runeinfo ($) {
766 return ": dgit ".access_basedistro()." $info ;";
769 sub access_someuserhost ($) {
771 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
772 defined($user) && length($user) or
773 $user = access_cfg("$some-user",'username');
774 my $host = access_cfg("$some-host");
775 return length($user) ? "$user\@$host" : $host;
778 sub access_gituserhost () {
779 return access_someuserhost('git');
782 sub access_giturl (;$) {
784 my $url = access_cfg('git-url','RETURN-UNDEF');
787 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
788 return undef unless defined $proto;
791 access_gituserhost().
792 access_cfg('git-path');
794 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
797 return "$url/$package$suffix";
800 sub parsecontrolfh ($$;$) {
801 my ($fh, $desc, $allowsigned) = @_;
802 our $dpkgcontrolhash_noissigned;
805 my %opts = ('name' => $desc);
806 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
807 $c = Dpkg::Control::Hash->new(%opts);
808 $c->parse($fh,$desc) or die "parsing of $desc failed";
809 last if $allowsigned;
810 last if $dpkgcontrolhash_noissigned;
811 my $issigned= $c->get_option('is_pgp_signed');
812 if (!defined $issigned) {
813 $dpkgcontrolhash_noissigned= 1;
814 seek $fh, 0,0 or die "seek $desc: $!";
815 } elsif ($issigned) {
816 fail "control file $desc is (already) PGP-signed. ".
817 " Note that dgit push needs to modify the .dsc and then".
818 " do the signature itself";
827 my ($file, $desc) = @_;
828 my $fh = new IO::Handle;
829 open $fh, '<', $file or die "$file: $!";
830 my $c = parsecontrolfh($fh,$desc);
831 $fh->error and die $!;
837 my ($dctrl,$field) = @_;
838 my $v = $dctrl->{$field};
839 return $v if defined $v;
840 fail "missing field $field in ".$v->get_option('name');
844 my $c = Dpkg::Control::Hash->new();
845 my $p = new IO::Handle;
846 my @cmd = (qw(dpkg-parsechangelog), @_);
847 open $p, '-|', @cmd or die $!;
849 $?=0; $!=0; close $p or failedcmd @cmd;
855 defined $d or fail "getcwd failed: $!";
861 sub archive_query ($) {
863 my $query = access_cfg('archive-query','RETURN-UNDEF');
864 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
867 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
870 sub pool_dsc_subpath ($$) {
871 my ($vsn,$component) = @_; # $package is implict arg
872 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
873 return "/pool/$component/$prefix/$package/".dscfn($vsn);
876 #---------- `ftpmasterapi' archive query method (nascent) ----------
878 sub archive_api_query_cmd ($) {
880 my @cmd = qw(curl -sS);
881 my $url = access_cfg('archive-query-url');
882 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
884 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
885 foreach my $key (split /\:/, $keys) {
886 $key =~ s/\%HOST\%/$host/g;
888 fail "for $url: stat $key: $!" unless $!==ENOENT;
891 fail "config requested specific TLS key but do not know".
892 " how to get curl to use exactly that EE key ($key)";
893 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
894 # # Sadly the above line does not work because of changes
895 # # to gnutls. The real fix for #790093 may involve
896 # # new curl options.
899 # Fixing #790093 properly will involve providing a value
900 # for this on clients.
901 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
902 push @cmd, split / /, $kargs if defined $kargs;
904 push @cmd, $url.$subpath;
910 my ($data, $subpath) = @_;
911 badcfg "ftpmasterapi archive query method takes no data part"
913 my @cmd = archive_api_query_cmd($subpath);
914 my $json = cmdoutput @cmd;
915 return decode_json($json);
918 sub canonicalise_suite_ftpmasterapi () {
919 my ($proto,$data) = @_;
920 my $suites = api_query($data, 'suites');
922 foreach my $entry (@$suites) {
924 my $v = $entry->{$_};
925 defined $v && $v eq $isuite;
927 push @matched, $entry;
929 fail "unknown suite $isuite" unless @matched;
932 @matched==1 or die "multiple matches for suite $isuite\n";
933 $cn = "$matched[0]{codename}";
934 defined $cn or die "suite $isuite info has no codename\n";
935 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
937 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
942 sub archive_query_ftpmasterapi () {
943 my ($proto,$data) = @_;
944 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
946 my $digester = Digest::SHA->new(256);
947 foreach my $entry (@$info) {
949 my $vsn = "$entry->{version}";
950 my ($ok,$msg) = version_check $vsn;
951 die "bad version: $msg\n" unless $ok;
952 my $component = "$entry->{component}";
953 $component =~ m/^$component_re$/ or die "bad component";
954 my $filename = "$entry->{filename}";
955 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
956 or die "bad filename";
957 my $sha256sum = "$entry->{sha256sum}";
958 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
959 push @rows, [ $vsn, "/pool/$component/$filename",
960 $digester, $sha256sum ];
962 die "bad ftpmaster api response: $@\n".Dumper($entry)
965 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
969 #---------- `madison' archive query method ----------
971 sub archive_query_madison {
972 return map { [ @$_[0..1] ] } madison_get_parse(@_);
975 sub madison_get_parse {
976 my ($proto,$data) = @_;
977 die unless $proto eq 'madison';
979 $data= access_cfg('madison-distro','RETURN-UNDEF');
980 $data //= access_basedistro();
982 $rmad{$proto,$data,$package} ||= cmdoutput
983 qw(rmadison -asource),"-s$isuite","-u$data",$package;
984 my $rmad = $rmad{$proto,$data,$package};
987 foreach my $l (split /\n/, $rmad) {
988 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
989 \s*( [^ \t|]+ )\s* \|
990 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
991 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
992 $1 eq $package or die "$rmad $package ?";
999 $component = access_cfg('archive-query-default-component');
1001 $5 eq 'source' or die "$rmad ?";
1002 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1004 return sort { -version_compare($a->[0],$b->[0]); } @out;
1007 sub canonicalise_suite_madison {
1008 # madison canonicalises for us
1009 my @r = madison_get_parse(@_);
1011 "unable to canonicalise suite using package $package".
1012 " which does not appear to exist in suite $isuite;".
1013 " --existing-package may help";
1017 #---------- `sshpsql' archive query method ----------
1020 my ($data,$runeinfo,$sql) = @_;
1021 if (!length $data) {
1022 $data= access_someuserhost('sshpsql').':'.
1023 access_cfg('sshpsql-dbname');
1025 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1026 my ($userhost,$dbname) = ($`,$'); #';
1028 my @cmd = (access_cfg_ssh, $userhost,
1029 access_runeinfo("ssh-psql $runeinfo").
1030 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1031 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1033 open P, "-|", @cmd or die $!;
1036 printdebug(">|$_|\n");
1039 $!=0; $?=0; close P or failedcmd @cmd;
1041 my $nrows = pop @rows;
1042 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1043 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1044 @rows = map { [ split /\|/, $_ ] } @rows;
1045 my $ncols = scalar @{ shift @rows };
1046 die if grep { scalar @$_ != $ncols } @rows;
1050 sub sql_injection_check {
1051 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1054 sub archive_query_sshpsql ($$) {
1055 my ($proto,$data) = @_;
1056 sql_injection_check $isuite, $package;
1057 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1058 SELECT source.version, component.name, files.filename, files.sha256sum
1060 JOIN src_associations ON source.id = src_associations.source
1061 JOIN suite ON suite.id = src_associations.suite
1062 JOIN dsc_files ON dsc_files.source = source.id
1063 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1064 JOIN component ON component.id = files_archive_map.component_id
1065 JOIN files ON files.id = dsc_files.file
1066 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1067 AND source.source='$package'
1068 AND files.filename LIKE '%.dsc';
1070 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1071 my $digester = Digest::SHA->new(256);
1073 my ($vsn,$component,$filename,$sha256sum) = @$_;
1074 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1079 sub canonicalise_suite_sshpsql ($$) {
1080 my ($proto,$data) = @_;
1081 sql_injection_check $isuite;
1082 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1083 SELECT suite.codename
1084 FROM suite where suite_name='$isuite' or codename='$isuite';
1086 @rows = map { $_->[0] } @rows;
1087 fail "unknown suite $isuite" unless @rows;
1088 die "ambiguous $isuite: @rows ?" if @rows>1;
1092 #---------- `dummycat' archive query method ----------
1094 sub canonicalise_suite_dummycat ($$) {
1095 my ($proto,$data) = @_;
1096 my $dpath = "$data/suite.$isuite";
1097 if (!open C, "<", $dpath) {
1098 $!==ENOENT or die "$dpath: $!";
1099 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1103 chomp or die "$dpath: $!";
1105 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1109 sub archive_query_dummycat ($$) {
1110 my ($proto,$data) = @_;
1111 canonicalise_suite();
1112 my $dpath = "$data/package.$csuite.$package";
1113 if (!open C, "<", $dpath) {
1114 $!==ENOENT or die "$dpath: $!";
1115 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1123 printdebug "dummycat query $csuite $package $dpath | $_\n";
1124 my @row = split /\s+/, $_;
1125 @row==2 or die "$dpath: $_ ?";
1128 C->error and die "$dpath: $!";
1130 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1133 #---------- archive query entrypoints and rest of program ----------
1135 sub canonicalise_suite () {
1136 return if defined $csuite;
1137 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1138 $csuite = archive_query('canonicalise_suite');
1139 if ($isuite ne $csuite) {
1140 progress "canonical suite name for $isuite is $csuite";
1144 sub get_archive_dsc () {
1145 canonicalise_suite();
1146 my @vsns = archive_query('archive_query');
1147 foreach my $vinfo (@vsns) {
1148 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1149 $dscurl = access_cfg('mirror').$subpath;
1150 $dscdata = url_get($dscurl);
1152 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1157 $digester->add($dscdata);
1158 my $got = $digester->hexdigest();
1160 fail "$dscurl has hash $got but".
1161 " archive told us to expect $digest";
1163 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1164 printdebug Dumper($dscdata) if $debuglevel>1;
1165 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1166 printdebug Dumper($dsc) if $debuglevel>1;
1167 my $fmt = getfield $dsc, 'Format';
1168 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1169 $dsc_checked = !!$digester;
1175 sub check_for_git ();
1176 sub check_for_git () {
1178 my $how = access_cfg('git-check');
1179 if ($how eq 'ssh-cmd') {
1181 (access_cfg_ssh, access_gituserhost(),
1182 access_runeinfo("git-check $package").
1183 " set -e; cd ".access_cfg('git-path').";".
1184 " if test -d $package.git; then echo 1; else echo 0; fi");
1185 my $r= cmdoutput @cmd;
1186 if (defined $r and $r =~ m/^divert (\w+)$/) {
1188 my ($usedistro,) = access_distros();
1189 # NB that if we are pushing, $usedistro will be $distro/push
1190 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1191 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1192 progress "diverting to $divert (using config for $instead_distro)";
1193 return check_for_git();
1195 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1197 } elsif ($how eq 'url') {
1198 my $prefix = access_cfg('git-check-url','git-url');
1199 my $suffix = access_cfg('git-check-suffix','git-suffix',
1200 'RETURN-UNDEF') // '.git';
1201 my $url = "$prefix/$package$suffix";
1202 my @cmd = (qw(curl -sS -I), $url);
1203 my $result = cmdoutput @cmd;
1204 $result =~ s/^\S+ 200 .*\n\r?\n//;
1205 # curl -sS -I with https_proxy prints
1206 # HTTP/1.0 200 Connection established
1207 $result =~ m/^\S+ (404|200) /s or
1208 fail "unexpected results from git check query - ".
1209 Dumper($prefix, $result);
1211 if ($code eq '404') {
1213 } elsif ($code eq '200') {
1218 } elsif ($how eq 'true') {
1220 } elsif ($how eq 'false') {
1223 badcfg "unknown git-check \`$how'";
1227 sub create_remote_git_repo () {
1228 my $how = access_cfg('git-create');
1229 if ($how eq 'ssh-cmd') {
1231 (access_cfg_ssh, access_gituserhost(),
1232 access_runeinfo("git-create $package").
1233 "set -e; cd ".access_cfg('git-path').";".
1234 " cp -a _template $package.git");
1235 } elsif ($how eq 'true') {
1238 badcfg "unknown git-create \`$how'";
1242 sub select_tagformat () {
1244 return if $tagformatfn && !$tagformat;
1245 die 'bug' if $tagformatfn && $tagformat;
1246 # ... $tagformat assigned after previous select_tagformat
1248 my (@supported) = split /\,/, access_cfg('dgit-tag-format');
1249 printdebug "select_tagformat supported @supported\n";
1251 $tagformat //= [ $supported[0], "distro access configuration", 0 ];
1252 printdebug "select_tagformat specified @$tagformat\n";
1254 my ($fmt,$why,$override) = @$tagformat;
1256 fail "target distro supports tag formats @supported".
1257 " but have to use $fmt ($why)"
1259 or grep { $_ eq $fmt } @supported;
1262 $tagformatfn = ${*::}{"debiantag_$fmt"};
1264 fail "trying to use unknown tag format \`$fmt' ($why) !"
1265 unless $tagformatfn;
1268 our ($dsc_hash,$lastpush_hash);
1270 our $ud = '.git/dgit/unpack';
1280 sub mktree_in_ud_here () {
1281 runcmd qw(git init -q);
1282 rmtree('.git/objects');
1283 symlink '../../../../objects','.git/objects' or die $!;
1286 sub git_write_tree () {
1287 my $tree = cmdoutput @git, qw(write-tree);
1288 $tree =~ m/^\w+$/ or die "$tree ?";
1292 sub remove_stray_gits () {
1293 my @gitscmd = qw(find -name .git -prune -print0);
1294 debugcmd "|",@gitscmd;
1295 open GITS, "-|", @gitscmd or die $!;
1300 print STDERR "$us: warning: removing from source package: ",
1301 (messagequote $_), "\n";
1305 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1308 sub mktree_in_ud_from_only_subdir () {
1309 # changes into the subdir
1311 die "@dirs ?" unless @dirs==1;
1312 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1316 remove_stray_gits();
1317 mktree_in_ud_here();
1318 my ($format, $fopts) = get_source_format();
1319 if (madformat($format)) {
1322 runcmd @git, qw(add -Af);
1323 my $tree=git_write_tree();
1324 return ($tree,$dir);
1327 sub dsc_files_info () {
1328 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1329 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1330 ['Files', 'Digest::MD5', 'new()']) {
1331 my ($fname, $module, $method) = @$csumi;
1332 my $field = $dsc->{$fname};
1333 next unless defined $field;
1334 eval "use $module; 1;" or die $@;
1336 foreach (split /\n/, $field) {
1338 m/^(\w+) (\d+) (\S+)$/ or
1339 fail "could not parse .dsc $fname line \`$_'";
1340 my $digester = eval "$module"."->$method;" or die $@;
1345 Digester => $digester,
1350 fail "missing any supported Checksums-* or Files field in ".
1351 $dsc->get_option('name');
1355 map { $_->{Filename} } dsc_files_info();
1358 sub is_orig_file ($;$) {
1361 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1362 defined $base or return 1;
1366 sub make_commit ($) {
1368 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1371 sub clogp_authline ($) {
1373 my $author = getfield $clogp, 'Maintainer';
1374 $author =~ s#,.*##ms;
1375 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1376 my $authline = "$author $date";
1377 $authline =~ m/$git_authline_re/o or
1378 fail "unexpected commit author line format \`$authline'".
1379 " (was generated from changelog Maintainer field)";
1380 return ($1,$2,$3) if wantarray;
1384 sub vendor_patches_distro ($$) {
1385 my ($checkdistro, $what) = @_;
1386 return unless defined $checkdistro;
1388 my $series = "debian/patches/\L$checkdistro\E.series";
1389 printdebug "checking for vendor-specific $series ($what)\n";
1391 if (!open SERIES, "<", $series) {
1392 die "$series $!" unless $!==ENOENT;
1401 Unfortunately, this source package uses a feature of dpkg-source where
1402 the same source package unpacks to different source code on different
1403 distros. dgit cannot safely operate on such packages on affected
1404 distros, because the meaning of source packages is not stable.
1406 Please ask the distro/maintainer to remove the distro-specific series
1407 files and use a different technique (if necessary, uploading actually
1408 different packages, if different distros are supposed to have
1412 fail "Found active distro-specific series file for".
1413 " $checkdistro ($what): $series, cannot continue";
1415 die "$series $!" if SERIES->error;
1419 sub check_for_vendor_patches () {
1420 # This dpkg-source feature doesn't seem to be documented anywhere!
1421 # But it can be found in the changelog (reformatted):
1423 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1424 # Author: Raphael Hertzog <hertzog@debian.org>
1425 # Date: Sun Oct 3 09:36:48 2010 +0200
1427 # dpkg-source: correctly create .pc/.quilt_series with alternate
1430 # If you have debian/patches/ubuntu.series and you were
1431 # unpacking the source package on ubuntu, quilt was still
1432 # directed to debian/patches/series instead of
1433 # debian/patches/ubuntu.series.
1435 # debian/changelog | 3 +++
1436 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1437 # 2 files changed, 6 insertions(+), 1 deletion(-)
1440 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1441 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1442 "Dpkg::Vendor \`current vendor'");
1443 vendor_patches_distro(access_basedistro(),
1444 "distro being accessed");
1447 sub generate_commit_from_dsc () {
1451 foreach my $fi (dsc_files_info()) {
1452 my $f = $fi->{Filename};
1453 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1455 link_ltarget "../../../$f", $f
1459 complete_file_from_dsc('.', $fi)
1462 if (is_orig_file($f)) {
1463 link $f, "../../../../$f"
1469 my $dscfn = "$package.dsc";
1471 open D, ">", $dscfn or die "$dscfn: $!";
1472 print D $dscdata or die "$dscfn: $!";
1473 close D or die "$dscfn: $!";
1474 my @cmd = qw(dpkg-source);
1475 push @cmd, '--no-check' if $dsc_checked;
1476 push @cmd, qw(-x --), $dscfn;
1479 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1480 check_for_vendor_patches() if madformat($dsc->{format});
1481 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1482 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1483 my $authline = clogp_authline $clogp;
1484 my $changes = getfield $clogp, 'Changes';
1485 open C, ">../commit.tmp" or die $!;
1486 print C <<END or die $!;
1493 # imported from the archive
1496 my $outputhash = make_commit qw(../commit.tmp);
1497 my $cversion = getfield $clogp, 'Version';
1498 progress "synthesised git commit from .dsc $cversion";
1499 if ($lastpush_hash) {
1500 runcmd @git, qw(reset -q --hard), $lastpush_hash;
1501 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1502 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1503 my $oversion = getfield $oldclogp, 'Version';
1505 version_compare($oversion, $cversion);
1507 # git upload/ is earlier vsn than archive, use archive
1508 open C, ">../commit2.tmp" or die $!;
1509 print C <<END or die $!;
1511 parent $lastpush_hash
1516 Record $package ($cversion) in archive suite $csuite
1518 $outputhash = make_commit qw(../commit2.tmp);
1519 } elsif ($vcmp > 0) {
1520 print STDERR <<END or die $!;
1522 Version actually in archive: $cversion (older)
1523 Last allegedly pushed/uploaded: $oversion (newer or same)
1526 $outputhash = $lastpush_hash;
1528 $outputhash = $lastpush_hash;
1531 changedir '../../../..';
1532 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1533 'DGIT_ARCHIVE', $outputhash;
1534 cmdoutput @git, qw(log -n2), $outputhash;
1535 # ... gives git a chance to complain if our commit is malformed
1540 sub complete_file_from_dsc ($$) {
1541 our ($dstdir, $fi) = @_;
1542 # Ensures that we have, in $dir, the file $fi, with the correct
1543 # contents. (Downloading it from alongside $dscurl if necessary.)
1545 my $f = $fi->{Filename};
1546 my $tf = "$dstdir/$f";
1549 if (stat_exists $tf) {
1550 progress "using existing $f";
1553 $furl =~ s{/[^/]+$}{};
1555 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1556 die "$f ?" if $f =~ m#/#;
1557 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1558 return 0 if !act_local();
1562 open F, "<", "$tf" or die "$tf: $!";
1563 $fi->{Digester}->reset();
1564 $fi->{Digester}->addfile(*F);
1565 F->error and die $!;
1566 my $got = $fi->{Digester}->hexdigest();
1567 $got eq $fi->{Hash} or
1568 fail "file $f has hash $got but .dsc".
1569 " demands hash $fi->{Hash} ".
1570 ($downloaded ? "(got wrong file from archive!)"
1571 : "(perhaps you should delete this file?)");
1576 sub ensure_we_have_orig () {
1577 foreach my $fi (dsc_files_info()) {
1578 my $f = $fi->{Filename};
1579 next unless is_orig_file($f);
1580 complete_file_from_dsc('..', $fi)
1585 sub git_fetch_us () {
1586 my @specs = (fetchspec());
1588 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1590 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1593 my @tagpats = debiantags('*',access_basedistro);
1595 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1596 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1597 printdebug "currently $fullrefname=$objid\n";
1598 $here{$fullrefname} = $objid;
1600 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1601 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1602 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1603 printdebug "offered $lref=$objid\n";
1604 if (!defined $here{$lref}) {
1605 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1606 runcmd_ordryrun_local @upd;
1607 } elsif ($here{$lref} eq $objid) {
1610 "Not updateting $lref from $here{$lref} to $objid.\n";
1615 sub fetch_from_archive () {
1616 # ensures that lrref() is what is actually in the archive,
1617 # one way or another
1621 foreach my $field (@ourdscfield) {
1622 $dsc_hash = $dsc->{$field};
1623 last if defined $dsc_hash;
1625 if (defined $dsc_hash) {
1626 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1628 progress "last upload to archive specified git hash";
1630 progress "last upload to archive has NO git hash";
1633 progress "no version available from the archive";
1636 $lastpush_hash = git_get_ref(lrref());
1637 printdebug "previous reference hash=$lastpush_hash\n";
1639 if (defined $dsc_hash) {
1640 fail "missing remote git history even though dsc has hash -".
1641 " could not find ref ".lrref().
1642 " (should have been fetched from ".access_giturl()."#".rrref().")"
1643 unless $lastpush_hash;
1645 ensure_we_have_orig();
1646 if ($dsc_hash eq $lastpush_hash) {
1647 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1648 print STDERR <<END or die $!;
1650 Git commit in archive is behind the last version allegedly pushed/uploaded.
1651 Commit referred to by archive: $dsc_hash
1652 Last allegedly pushed/uploaded: $lastpush_hash
1655 $hash = $lastpush_hash;
1657 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1658 "descendant of archive's .dsc hash ($dsc_hash)";
1661 $hash = generate_commit_from_dsc();
1662 } elsif ($lastpush_hash) {
1663 # only in git, not in the archive yet
1664 $hash = $lastpush_hash;
1665 print STDERR <<END or die $!;
1667 Package not found in the archive, but has allegedly been pushed using dgit.
1671 printdebug "nothing found!\n";
1672 if (defined $skew_warning_vsn) {
1673 print STDERR <<END or die $!;
1675 Warning: relevant archive skew detected.
1676 Archive allegedly contains $skew_warning_vsn
1677 But we were not able to obtain any version from the archive or git.
1683 printdebug "current hash=$hash\n";
1684 if ($lastpush_hash) {
1685 fail "not fast forward on last upload branch!".
1686 " (archive's version left in DGIT_ARCHIVE)"
1687 unless is_fast_fwd($lastpush_hash, $hash);
1689 if (defined $skew_warning_vsn) {
1691 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1692 my $clogf = ".git/dgit/changelog.tmp";
1693 runcmd shell_cmd "exec >$clogf",
1694 @git, qw(cat-file blob), "$hash:debian/changelog";
1695 my $gotclogp = parsechangelog("-l$clogf");
1696 my $got_vsn = getfield $gotclogp, 'Version';
1697 printdebug "SKEW CHECK GOT $got_vsn\n";
1698 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1699 print STDERR <<END or die $!;
1701 Warning: archive skew detected. Using the available version:
1702 Archive allegedly contains $skew_warning_vsn
1703 We were able to obtain only $got_vsn
1708 if ($lastpush_hash ne $hash) {
1709 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1713 dryrun_report @upd_cmd;
1719 sub set_local_git_config ($$) {
1721 runcmd @git, qw(config), $k, $v;
1724 sub setup_mergechangelogs (;$) {
1726 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1728 my $driver = 'dpkg-mergechangelogs';
1729 my $cb = "merge.$driver";
1730 my $attrs = '.git/info/attributes';
1731 ensuredir '.git/info';
1733 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1734 if (!open ATTRS, "<", $attrs) {
1735 $!==ENOENT or die "$attrs: $!";
1739 next if m{^debian/changelog\s};
1740 print NATTRS $_, "\n" or die $!;
1742 ATTRS->error and die $!;
1745 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1748 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1749 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1751 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1754 sub setup_useremail (;$) {
1756 return unless $always || access_cfg_bool(1, 'setup-useremail');
1759 my ($k, $envvar) = @_;
1760 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1761 return unless defined $v;
1762 set_local_git_config "user.$k", $v;
1765 $setup->('email', 'DEBEMAIL');
1766 $setup->('name', 'DEBFULLNAME');
1769 sub setup_new_tree () {
1770 setup_mergechangelogs();
1776 canonicalise_suite();
1777 badusage "dry run makes no sense with clone" unless act_local();
1778 my $hasgit = check_for_git();
1779 mkdir $dstdir or fail "create \`$dstdir': $!";
1781 runcmd @git, qw(init -q);
1782 my $giturl = access_giturl(1);
1783 if (defined $giturl) {
1784 set_local_git_config "remote.$remotename.fetch", fetchspec();
1785 open H, "> .git/HEAD" or die $!;
1786 print H "ref: ".lref()."\n" or die $!;
1788 runcmd @git, qw(remote add), 'origin', $giturl;
1791 progress "fetching existing git history";
1793 runcmd_ordryrun_local @git, qw(fetch origin);
1795 progress "starting new git history";
1797 fetch_from_archive() or no_such_package;
1798 my $vcsgiturl = $dsc->{'Vcs-Git'};
1799 if (length $vcsgiturl) {
1800 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1801 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1804 runcmd @git, qw(reset --hard), lrref();
1805 printdone "ready for work in $dstdir";
1809 if (check_for_git()) {
1812 fetch_from_archive() or no_such_package();
1813 printdone "fetched into ".lrref();
1818 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1820 printdone "fetched to ".lrref()." and merged into HEAD";
1823 sub check_not_dirty () {
1824 foreach my $f (qw(local-options local-patch-header)) {
1825 if (stat_exists "debian/source/$f") {
1826 fail "git tree contains debian/source/$f";
1830 return if $ignoredirty;
1832 my @cmd = (@git, qw(diff --quiet HEAD));
1834 $!=0; $?=-1; system @cmd;
1837 fail "working tree is dirty (does not match HEAD)";
1843 sub commit_admin ($) {
1846 runcmd_ordryrun_local @git, qw(commit -m), $m;
1849 sub commit_quilty_patch () {
1850 my $output = cmdoutput @git, qw(status --porcelain);
1852 foreach my $l (split /\n/, $output) {
1853 next unless $l =~ m/\S/;
1854 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1858 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1860 progress "nothing quilty to commit, ok.";
1863 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1864 runcmd_ordryrun_local @git, qw(add -f), @adds;
1865 commit_admin "Commit Debian 3.0 (quilt) metadata";
1868 sub get_source_format () {
1870 if (open F, "debian/source/options") {
1874 s/\s+$//; # ignore missing final newline
1876 my ($k, $v) = ($`, $'); #');
1877 $v =~ s/^"(.*)"$/$1/;
1883 F->error and die $!;
1886 die $! unless $!==&ENOENT;
1889 if (!open F, "debian/source/format") {
1890 die $! unless $!==&ENOENT;
1894 F->error and die $!;
1896 return ($_, \%options);
1901 return 0 unless $format eq '3.0 (quilt)';
1902 our $quilt_mode_warned;
1903 if ($quilt_mode eq 'nocheck') {
1904 progress "Not doing any fixup of \`$format' due to".
1905 " ----no-quilt-fixup or --quilt=nocheck"
1906 unless $quilt_mode_warned++;
1909 progress "Format \`$format', need to check/update patch stack"
1910 unless $quilt_mode_warned++;
1914 sub push_parse_changelog ($) {
1917 my $clogp = Dpkg::Control::Hash->new();
1918 $clogp->load($clogpfn) or die;
1920 $package = getfield $clogp, 'Source';
1921 my $cversion = getfield $clogp, 'Version';
1922 my $tag = debiantag($cversion, access_basedistro);
1923 runcmd @git, qw(check-ref-format), $tag;
1925 my $dscfn = dscfn($cversion);
1927 return ($clogp, $cversion, $tag, $dscfn);
1930 sub push_parse_dsc ($$$) {
1931 my ($dscfn,$dscfnwhat, $cversion) = @_;
1932 $dsc = parsecontrol($dscfn,$dscfnwhat);
1933 my $dversion = getfield $dsc, 'Version';
1934 my $dscpackage = getfield $dsc, 'Source';
1935 ($dscpackage eq $package && $dversion eq $cversion) or
1936 fail "$dscfn is for $dscpackage $dversion".
1937 " but debian/changelog is for $package $cversion";
1940 sub push_mktag ($$$$$$$) {
1941 my ($head,$clogp,$tag,
1943 $changesfile,$changesfilewhat,
1946 $dsc->{$ourdscfield[0]} = $head;
1947 $dsc->save("$dscfn.tmp") or die $!;
1949 my $changes = parsecontrol($changesfile,$changesfilewhat);
1950 foreach my $field (qw(Source Distribution Version)) {
1951 $changes->{$field} eq $clogp->{$field} or
1952 fail "changes field $field \`$changes->{$field}'".
1953 " does not match changelog \`$clogp->{$field}'";
1956 my $cversion = getfield $clogp, 'Version';
1957 my $clogsuite = getfield $clogp, 'Distribution';
1959 # We make the git tag by hand because (a) that makes it easier
1960 # to control the "tagger" (b) we can do remote signing
1961 my $authline = clogp_authline $clogp;
1962 my $delibs = join(" ", "",@deliberatelies);
1963 my $declaredistro = access_basedistro();
1964 open TO, '>', $tfn->('.tmp') or die $!;
1965 print TO <<END or die $!;
1971 $package release $cversion for $clogsuite ($csuite) [dgit]
1972 [dgit distro=$declaredistro$delibs]
1974 foreach my $ref (sort keys %previously) {
1975 print TO <<END or die $!;
1976 [dgit previously:$ref=$previously{$ref}]
1982 my $tagobjfn = $tfn->('.tmp');
1984 if (!defined $keyid) {
1985 $keyid = access_cfg('keyid','RETURN-UNDEF');
1987 if (!defined $keyid) {
1988 $keyid = getfield $clogp, 'Maintainer';
1990 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1991 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1992 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1993 push @sign_cmd, $tfn->('.tmp');
1994 runcmd_ordryrun @sign_cmd;
1996 $tagobjfn = $tfn->('.signed.tmp');
1997 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1998 $tfn->('.tmp'), $tfn->('.tmp.asc');
2005 sub sign_changes ($) {
2006 my ($changesfile) = @_;
2008 my @debsign_cmd = @debsign;
2009 push @debsign_cmd, "-k$keyid" if defined $keyid;
2010 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2011 push @debsign_cmd, $changesfile;
2012 runcmd_ordryrun @debsign_cmd;
2017 my ($forceflag) = @_;
2018 printdebug "actually entering push\n";
2019 supplementary_message(<<'END');
2020 Push failed, while preparing your push.
2021 You can retry the push, after fixing the problem, if you like.
2025 access_giturl(); # check that success is vaguely likely
2028 my $clogpfn = ".git/dgit/changelog.822.tmp";
2029 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2031 responder_send_file('parsed-changelog', $clogpfn);
2033 my ($clogp, $cversion, $tag, $dscfn) =
2034 push_parse_changelog("$clogpfn");
2036 my $dscpath = "$buildproductsdir/$dscfn";
2037 stat_exists $dscpath or
2038 fail "looked for .dsc $dscfn, but $!;".
2039 " maybe you forgot to build";
2041 responder_send_file('dsc', $dscpath);
2043 push_parse_dsc($dscpath, $dscfn, $cversion);
2045 my $format = getfield $dsc, 'Format';
2046 printdebug "format $format\n";
2048 my $head = git_rev_parse('HEAD');
2050 if (madformat($format)) {
2051 # user might have not used dgit build, so maybe do this now:
2052 if (quiltmode_splitbrain()) {
2053 my $upstreamversion = $clogp->{Version};
2054 $upstreamversion =~ s/-[^-]*$//;
2056 quilt_make_fake_dsc($upstreamversion);
2057 my ($dgitview, $cachekey) =
2058 quilt_check_splitbrain_cache($head, $upstreamversion);
2060 "--quilt=$quilt_mode but no cached dgit view:
2061 perhaps tree changed since dgit build[-source] ?";
2063 changedir '../../../..';
2064 prep_ud(); # so _only_subdir() works, below
2066 commit_quilty_patch();
2070 die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2074 progress "checking that $dscfn corresponds to HEAD";
2075 runcmd qw(dpkg-source -x --),
2076 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2077 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2078 check_for_vendor_patches() if madformat($dsc->{format});
2079 changedir '../../../..';
2080 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2081 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2082 debugcmd "+",@diffcmd;
2084 my $r = system @diffcmd;
2087 fail "$dscfn specifies a different tree to your HEAD commit;".
2088 " perhaps you forgot to build".
2089 ($diffopt eq '--exit-code' ? "" :
2090 " (run with -D to see full diff output)");
2095 if (!$changesfile) {
2096 my $pat = changespat $cversion;
2097 my @cs = glob "$buildproductsdir/$pat";
2098 fail "failed to find unique changes file".
2099 " (looked for $pat in $buildproductsdir);".
2100 " perhaps you need to use dgit -C"
2102 ($changesfile) = @cs;
2104 $changesfile = "$buildproductsdir/$changesfile";
2107 responder_send_file('changes',$changesfile);
2108 responder_send_command("param head $head");
2109 responder_send_command("param csuite $csuite");
2111 if (deliberately_not_fast_forward) {
2112 git_for_each_ref(lrfetchrefs, sub {
2113 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2114 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2115 responder_send_command("previously $rrefname=$objid");
2116 $previously{$rrefname} = $objid;
2120 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2123 supplementary_message(<<'END');
2124 Push failed, while signing the tag.
2125 You can retry the push, after fixing the problem, if you like.
2127 # If we manage to sign but fail to record it anywhere, it's fine.
2128 if ($we_are_responder) {
2129 $tagobjfn = $tfn->('.signed.tmp');
2130 responder_receive_files('signed-tag', $tagobjfn);
2133 push_mktag($head,$clogp,$tag,
2135 $changesfile,$changesfile,
2138 supplementary_message(<<'END');
2139 Push failed, *after* signing the tag.
2140 If you want to try again, you should use a new version number.
2143 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2144 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2145 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2147 supplementary_message(<<'END');
2148 Push failed, while updating the remote git repository - see messages above.
2149 If you want to try again, you should use a new version number.
2151 if (!check_for_git()) {
2152 create_remote_git_repo();
2154 runcmd_ordryrun @git, qw(push),access_giturl(),
2155 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2156 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2158 supplementary_message(<<'END');
2159 Push failed, after updating the remote git repository.
2160 If you want to try again, you must use a new version number.
2162 if ($we_are_responder) {
2163 my $dryrunsuffix = act_local() ? "" : ".tmp";
2164 responder_receive_files('signed-dsc-changes',
2165 "$dscpath$dryrunsuffix",
2166 "$changesfile$dryrunsuffix");
2169 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2171 progress "[new .dsc left in $dscpath.tmp]";
2173 sign_changes $changesfile;
2176 supplementary_message(<<END);
2177 Push failed, while uploading package(s) to the archive server.
2178 You can retry the upload of exactly these same files with dput of:
2180 If that .changes file is broken, you will need to use a new version
2181 number for your next attempt at the upload.
2183 my $host = access_cfg('upload-host','RETURN-UNDEF');
2184 my @hostarg = defined($host) ? ($host,) : ();
2185 runcmd_ordryrun @dput, @hostarg, $changesfile;
2186 printdone "pushed and uploaded $cversion";
2188 supplementary_message('');
2189 responder_send_command("complete");
2196 badusage "-p is not allowed with clone; specify as argument instead"
2197 if defined $package;
2200 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2201 ($package,$isuite) = @ARGV;
2202 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2203 ($package,$dstdir) = @ARGV;
2204 } elsif (@ARGV==3) {
2205 ($package,$isuite,$dstdir) = @ARGV;
2207 badusage "incorrect arguments to dgit clone";
2209 $dstdir ||= "$package";
2211 if (stat_exists $dstdir) {
2212 fail "$dstdir already exists";
2216 if ($rmonerror && !$dryrun_level) {
2217 $cwd_remove= getcwd();
2219 return unless defined $cwd_remove;
2220 if (!chdir "$cwd_remove") {
2221 return if $!==&ENOENT;
2222 die "chdir $cwd_remove: $!";
2225 rmtree($dstdir) or die "remove $dstdir: $!\n";
2226 } elsif (!grep { $! == $_ }
2227 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2229 print STDERR "check whether to remove $dstdir: $!\n";
2235 $cwd_remove = undef;
2238 sub branchsuite () {
2239 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2240 if ($branch =~ m#$lbranch_re#o) {
2247 sub fetchpullargs () {
2249 if (!defined $package) {
2250 my $sourcep = parsecontrol('debian/control','debian/control');
2251 $package = getfield $sourcep, 'Source';
2254 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2256 my $clogp = parsechangelog();
2257 $isuite = getfield $clogp, 'Distribution';
2259 canonicalise_suite();
2260 progress "fetching from suite $csuite";
2261 } elsif (@ARGV==1) {
2263 canonicalise_suite();
2265 badusage "incorrect arguments to dgit fetch or dgit pull";
2284 badusage "-p is not allowed with dgit push" if defined $package;
2286 my $clogp = parsechangelog();
2287 $package = getfield $clogp, 'Source';
2290 } elsif (@ARGV==1) {
2291 ($specsuite) = (@ARGV);
2293 badusage "incorrect arguments to dgit push";
2295 $isuite = getfield $clogp, 'Distribution';
2297 local ($package) = $existing_package; # this is a hack
2298 canonicalise_suite();
2300 canonicalise_suite();
2302 if (defined $specsuite &&
2303 $specsuite ne $isuite &&
2304 $specsuite ne $csuite) {
2305 fail "dgit push: changelog specifies $isuite ($csuite)".
2306 " but command line specifies $specsuite";
2308 supplementary_message(<<'END');
2309 Push failed, while checking state of the archive.
2310 You can retry the push, after fixing the problem, if you like.
2312 if (check_for_git()) {
2316 if (fetch_from_archive()) {
2317 if (is_fast_fwd(lrref(), 'HEAD')) {
2319 } elsif (deliberately_not_fast_forward) {
2322 fail "dgit push: HEAD is not a descendant".
2323 " of the archive's version.\n".
2324 "dgit: To overwrite its contents,".
2325 " use git merge -s ours ".lrref().".\n".
2326 "dgit: To rewind history, if permitted by the archive,".
2327 " use --deliberately-not-fast-forward";
2331 fail "package appears to be new in this suite;".
2332 " if this is intentional, use --new";
2337 #---------- remote commands' implementation ----------
2339 sub cmd_remote_push_build_host {
2340 my ($nrargs) = shift @ARGV;
2341 my (@rargs) = @ARGV[0..$nrargs-1];
2342 @ARGV = @ARGV[$nrargs..$#ARGV];
2344 my ($dir,$vsnwant) = @rargs;
2345 # vsnwant is a comma-separated list; we report which we have
2346 # chosen in our ready response (so other end can tell if they
2349 $we_are_responder = 1;
2350 $us .= " (build host)";
2354 open PI, "<&STDIN" or die $!;
2355 open STDIN, "/dev/null" or die $!;
2356 open PO, ">&STDOUT" or die $!;
2358 open STDOUT, ">&STDERR" or die $!;
2362 ($protovsn) = grep {
2363 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2364 } @rpushprotovsn_support;
2366 fail "build host has dgit rpush protocol versions ".
2367 (join ",", @rpushprotovsn_support).
2368 " but invocation host has $vsnwant"
2369 unless defined $protovsn;
2371 responder_send_command("dgit-remote-push-ready $protovsn");
2372 rpush_handle_protovsn_bothends();
2377 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2378 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2379 # a good error message)
2381 sub rpush_handle_protovsn_bothends () {
2382 if ($protovsn < 4) {
2383 fail "rpush negotiated protocol version $protovsn".
2384 " which supports old tag format only".
2385 " but trying to use new format (".$tagformat->[1].")"
2386 if $tagformat && $tagformat->[0] ne 'old';
2387 $tagformat = ['old', "rpush negotiated protocol $protovsn", 0];
2396 my $report = i_child_report();
2397 if (defined $report) {
2398 printdebug "($report)\n";
2399 } elsif ($i_child_pid) {
2400 printdebug "(killing build host child $i_child_pid)\n";
2401 kill 15, $i_child_pid;
2403 if (defined $i_tmp && !defined $initiator_tempdir) {
2405 eval { rmtree $i_tmp; };
2409 END { i_cleanup(); }
2412 my ($base,$selector,@args) = @_;
2413 $selector =~ s/\-/_/g;
2414 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2421 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2429 push @rargs, join ",", @rpushprotovsn_support;
2432 push @rdgit, @ropts;
2433 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2435 my @cmd = (@ssh, $host, shellquote @rdgit);
2438 if (defined $initiator_tempdir) {
2439 rmtree $initiator_tempdir;
2440 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2441 $i_tmp = $initiator_tempdir;
2445 $i_child_pid = open2(\*RO, \*RI, @cmd);
2447 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2448 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2449 $supplementary_message = '' unless $protovsn >= 3;
2450 rpush_handle_protovsn_bothends();
2452 my ($icmd,$iargs) = initiator_expect {
2453 m/^(\S+)(?: (.*))?$/;
2456 i_method "i_resp", $icmd, $iargs;
2460 sub i_resp_progress ($) {
2462 my $msg = protocol_read_bytes \*RO, $rhs;
2466 sub i_resp_supplementary_message ($) {
2468 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2471 sub i_resp_complete {
2472 my $pid = $i_child_pid;
2473 $i_child_pid = undef; # prevents killing some other process with same pid
2474 printdebug "waiting for build host child $pid...\n";
2475 my $got = waitpid $pid, 0;
2476 die $! unless $got == $pid;
2477 die "build host child failed $?" if $?;
2480 printdebug "all done\n";
2484 sub i_resp_file ($) {
2486 my $localname = i_method "i_localname", $keyword;
2487 my $localpath = "$i_tmp/$localname";
2488 stat_exists $localpath and
2489 badproto \*RO, "file $keyword ($localpath) twice";
2490 protocol_receive_file \*RO, $localpath;
2491 i_method "i_file", $keyword;
2496 sub i_resp_param ($) {
2497 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2501 sub i_resp_previously ($) {
2502 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2503 or badproto \*RO, "bad previously spec";
2504 my $r = system qw(git check-ref-format), $1;
2505 die "bad previously ref spec ($r)" if $r;
2506 $previously{$1} = $2;
2511 sub i_resp_want ($) {
2513 die "$keyword ?" if $i_wanted{$keyword}++;
2514 my @localpaths = i_method "i_want", $keyword;
2515 printdebug "[[ $keyword @localpaths\n";
2516 foreach my $localpath (@localpaths) {
2517 protocol_send_file \*RI, $localpath;
2519 print RI "files-end\n" or die $!;
2522 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2524 sub i_localname_parsed_changelog {
2525 return "remote-changelog.822";
2527 sub i_file_parsed_changelog {
2528 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2529 push_parse_changelog "$i_tmp/remote-changelog.822";
2530 die if $i_dscfn =~ m#/|^\W#;
2533 sub i_localname_dsc {
2534 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2539 sub i_localname_changes {
2540 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2541 $i_changesfn = $i_dscfn;
2542 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2543 return $i_changesfn;
2545 sub i_file_changes { }
2547 sub i_want_signed_tag {
2548 printdebug Dumper(\%i_param, $i_dscfn);
2549 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2550 && defined $i_param{'csuite'}
2551 or badproto \*RO, "premature desire for signed-tag";
2552 my $head = $i_param{'head'};
2553 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2555 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2557 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2560 push_mktag $head, $i_clogp, $i_tag,
2562 $i_changesfn, 'remote changes',
2563 sub { "tag$_[0]"; };
2568 sub i_want_signed_dsc_changes {
2569 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2570 sign_changes $i_changesfn;
2571 return ($i_dscfn, $i_changesfn);
2574 #---------- building etc. ----------
2580 #----- `3.0 (quilt)' handling -----
2582 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2584 sub quiltify_dpkg_commit ($$$;$) {
2585 my ($patchname,$author,$msg, $xinfo) = @_;
2589 my $descfn = ".git/dgit/quilt-description.tmp";
2590 open O, '>', $descfn or die "$descfn: $!";
2593 $msg =~ s/^\s+$/ ./mg;
2594 print O <<END or die $!;
2604 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2605 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2606 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2607 runcmd @dpkgsource, qw(--commit .), $patchname;
2611 sub quiltify_trees_differ ($$;$$) {
2612 my ($x,$y,$finegrained,$ignorenamesr) = @_;
2613 # returns true iff the two tree objects differ other than in debian/
2614 # with $finegrained,
2615 # returns bitmask 01 - differ in upstream files except .gitignore
2616 # 02 - differ in .gitignore
2617 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2618 # is set for each modified .gitignore filename $fn
2620 my @cmd = (@git, qw(diff-tree --name-only -z));
2621 push @cmd, qw(-r) if $finegrained;
2623 my $diffs= cmdoutput @cmd;
2625 foreach my $f (split /\0/, $diffs) {
2626 next if $f =~ m#^debian(?:/.*)?$#s;
2627 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2628 $r |= $isignore ? 02 : 01;
2629 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2631 printdebug "quiltify_trees_differ $x $y => $r\n";
2635 sub quiltify_tree_sentinelfiles ($) {
2636 # lists the `sentinel' files present in the tree
2638 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2639 qw(-- debian/rules debian/control);
2644 sub quiltify_splitbrain_needed () {
2645 if (!$split_brain) {
2646 progress "dgit view: changes are required...";
2647 runcmd @git, qw(checkout -q -b dgit-view);
2652 sub quiltify_splitbrain ($$$$$$) {
2653 my ($clogp, $unapplied, $headref, $diffbits,
2654 $editedignores, $cachekey) = @_;
2655 if ($quilt_mode !~ m/gbp|dpm/) {
2656 # treat .gitignore just like any other upstream file
2657 $diffbits = { %$diffbits };
2658 $_ = !!$_ foreach values %$diffbits;
2660 # We would like any commits we generate to be reproducible
2661 my @authline = clogp_authline($clogp);
2662 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2663 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2664 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2666 if ($quilt_mode =~ m/gbp|unapplied/ &&
2667 ($diffbits->{H2O} & 01)) {
2669 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2670 " but git tree differs from orig in upstream files.";
2671 if (!stat_exists "debian/patches") {
2673 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2677 if ($quilt_mode =~ m/gbp|unapplied/ &&
2678 ($diffbits->{O2A} & 01)) { # some patches
2679 quiltify_splitbrain_needed();
2680 progress "dgit view: creating patches-applied version using gbp pq";
2681 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2682 # gbp pq import creates a fresh branch; push back to dgit-view
2683 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2684 runcmd @git, qw(checkout -q dgit-view);
2686 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2687 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2688 quiltify_splitbrain_needed();
2689 progress "dgit view: creating patch to represent .gitignore changes";
2690 ensuredir "debian/patches";
2691 my $gipatch = "debian/patches/auto-gitignore";
2692 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2693 stat GIPATCH or die "$gipatch: $!";
2694 fail "$gipatch already exists; but want to create it".
2695 " to record .gitignore changes" if (stat _)[7];
2696 print GIPATCH <<END or die "$gipatch: $!";
2697 Subject: Update .gitignore from Debian packaging branch
2699 The Debian packaging git branch contains these updates to the upstream
2700 .gitignore file(s). This patch is autogenerated, to provide these
2701 updates to users of the official Debian archive view of the package.
2703 [dgit version $our_version]
2706 close GIPATCH or die "$gipatch: $!";
2707 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2708 $unapplied, $headref, "--", sort keys %$editedignores;
2709 open SERIES, "+>>", "debian/patches/series" or die $!;
2710 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2712 defined read SERIES, $newline, 1 or die $!;
2713 print SERIES "\n" or die $! unless $newline eq "\n";
2714 print SERIES "auto-gitignore\n" or die $!;
2715 close SERIES or die $!;
2716 runcmd @git, qw(add -- debian/patches/series), $gipatch;
2717 commit_admin "Commit patch to update .gitignore";
2720 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2722 changedir '../../../..';
2723 ensuredir ".git/logs/refs/dgit-intern";
2724 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2726 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2729 progress "dgit view: created (commit id $dgitview)";
2731 changedir '.git/dgit/unpack/work';
2734 sub quiltify ($$$$) {
2735 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2737 # Quilt patchification algorithm
2739 # We search backwards through the history of the main tree's HEAD
2740 # (T) looking for a start commit S whose tree object is identical
2741 # to to the patch tip tree (ie the tree corresponding to the
2742 # current dpkg-committed patch series). For these purposes
2743 # `identical' disregards anything in debian/ - this wrinkle is
2744 # necessary because dpkg-source treates debian/ specially.
2746 # We can only traverse edges where at most one of the ancestors'
2747 # trees differs (in changes outside in debian/). And we cannot
2748 # handle edges which change .pc/ or debian/patches. To avoid
2749 # going down a rathole we avoid traversing edges which introduce
2750 # debian/rules or debian/control. And we set a limit on the
2751 # number of edges we are willing to look at.
2753 # If we succeed, we walk forwards again. For each traversed edge
2754 # PC (with P parent, C child) (starting with P=S and ending with
2755 # C=T) to we do this:
2757 # - dpkg-source --commit with a patch name and message derived from C
2758 # After traversing PT, we git commit the changes which
2759 # should be contained within debian/patches.
2761 # The search for the path S..T is breadth-first. We maintain a
2762 # todo list containing search nodes. A search node identifies a
2763 # commit, and looks something like this:
2765 # Commit => $git_commit_id,
2766 # Child => $c, # or undef if P=T
2767 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2768 # Nontrivial => true iff $p..$c has relevant changes
2775 my %considered; # saves being exponential on some weird graphs
2777 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2780 my ($search,$whynot) = @_;
2781 printdebug " search NOT $search->{Commit} $whynot\n";
2782 $search->{Whynot} = $whynot;
2783 push @nots, $search;
2784 no warnings qw(exiting);
2793 my $c = shift @todo;
2794 next if $considered{$c->{Commit}}++;
2796 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2798 printdebug "quiltify investigate $c->{Commit}\n";
2801 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2802 printdebug " search finished hooray!\n";
2807 if ($quilt_mode eq 'nofix') {
2808 fail "quilt fixup required but quilt mode is \`nofix'\n".
2809 "HEAD commit $c->{Commit} differs from tree implied by ".
2810 " debian/patches (tree object $oldtiptree)";
2812 if ($quilt_mode eq 'smash') {
2813 printdebug " search quitting smash\n";
2817 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2818 $not->($c, "has $c_sentinels not $t_sentinels")
2819 if $c_sentinels ne $t_sentinels;
2821 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2822 $commitdata =~ m/\n\n/;
2824 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2825 @parents = map { { Commit => $_, Child => $c } } @parents;
2827 $not->($c, "root commit") if !@parents;
2829 foreach my $p (@parents) {
2830 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2832 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2833 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2835 foreach my $p (@parents) {
2836 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2838 my @cmd= (@git, qw(diff-tree -r --name-only),
2839 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2840 my $patchstackchange = cmdoutput @cmd;
2841 if (length $patchstackchange) {
2842 $patchstackchange =~ s/\n/,/g;
2843 $not->($p, "changed $patchstackchange");
2846 printdebug " search queue P=$p->{Commit} ",
2847 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2853 printdebug "quiltify want to smash\n";
2856 my $x = $_[0]{Commit};
2857 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2860 my $reportnot = sub {
2862 my $s = $abbrev->($notp);
2863 my $c = $notp->{Child};
2864 $s .= "..".$abbrev->($c) if $c;
2865 $s .= ": ".$notp->{Whynot};
2868 if ($quilt_mode eq 'linear') {
2869 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2870 foreach my $notp (@nots) {
2871 print STDERR "$us: ", $reportnot->($notp), "\n";
2873 print STDERR "$us: $_\n" foreach @$failsuggestion;
2874 fail "quilt fixup naive history linearisation failed.\n".
2875 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2876 } elsif ($quilt_mode eq 'smash') {
2877 } elsif ($quilt_mode eq 'auto') {
2878 progress "quilt fixup cannot be linear, smashing...";
2880 die "$quilt_mode ?";
2883 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
2884 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
2886 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2888 quiltify_dpkg_commit "auto-$version-$target-$time",
2889 (getfield $clogp, 'Maintainer'),
2890 "Automatically generated patch ($clogp->{Version})\n".
2891 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2895 progress "quiltify linearisation planning successful, executing...";
2897 for (my $p = $sref_S;
2898 my $c = $p->{Child};
2900 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2901 next unless $p->{Nontrivial};
2903 my $cc = $c->{Commit};
2905 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2906 $commitdata =~ m/\n\n/ or die "$c ?";
2909 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2912 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2915 my $patchname = $title;
2916 $patchname =~ s/[.:]$//;
2917 $patchname =~ y/ A-Z/-a-z/;
2918 $patchname =~ y/-a-z0-9_.+=~//cd;
2919 $patchname =~ s/^\W/x-$&/;
2920 $patchname = substr($patchname,0,40);
2923 stat "debian/patches/$patchname$index";
2925 $!==ENOENT or die "$patchname$index $!";
2927 runcmd @git, qw(checkout -q), $cc;
2929 # We use the tip's changelog so that dpkg-source doesn't
2930 # produce complaining messages from dpkg-parsechangelog. None
2931 # of the information dpkg-source gets from the changelog is
2932 # actually relevant - it gets put into the original message
2933 # which dpkg-source provides our stunt editor, and then
2935 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2937 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2938 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2940 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2943 runcmd @git, qw(checkout -q master);
2946 sub build_maybe_quilt_fixup () {
2947 my ($format,$fopts) = get_source_format;
2948 return unless madformat $format;
2951 check_for_vendor_patches();
2953 my $clogp = parsechangelog();
2954 my $headref = git_rev_parse('HEAD');
2959 my $upstreamversion=$version;
2960 $upstreamversion =~ s/-[^-]*$//;
2962 if ($fopts->{'single-debian-patch'}) {
2963 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2965 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2968 die 'bug' if $split_brain && !$need_split_build_invocation;
2970 changedir '../../../..';
2971 runcmd_ordryrun_local
2972 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2975 sub quilt_fixup_mkwork ($) {
2978 mkdir "work" or die $!;
2980 mktree_in_ud_here();
2981 runcmd @git, qw(reset -q --hard), $headref;
2984 sub quilt_fixup_linkorigs ($$) {
2985 my ($upstreamversion, $fn) = @_;
2986 # calls $fn->($leafname);
2988 foreach my $f (<../../../../*>) { #/){
2989 my $b=$f; $b =~ s{.*/}{};
2991 local ($debuglevel) = $debuglevel-1;
2992 printdebug "QF linkorigs $b, $f ?\n";
2994 next unless is_orig_file $b, srcfn $upstreamversion,'';
2995 printdebug "QF linkorigs $b, $f Y\n";
2996 link_ltarget $f, $b or die "$b $!";
3001 sub quilt_fixup_delete_pc () {
3002 runcmd @git, qw(rm -rqf .pc);
3003 commit_admin "Commit removal of .pc (quilt series tracking data)";
3006 sub quilt_fixup_singlepatch ($$$) {
3007 my ($clogp, $headref, $upstreamversion) = @_;
3009 progress "starting quiltify (single-debian-patch)";
3011 # dpkg-source --commit generates new patches even if
3012 # single-debian-patch is in debian/source/options. In order to
3013 # get it to generate debian/patches/debian-changes, it is
3014 # necessary to build the source package.
3016 quilt_fixup_linkorigs($upstreamversion, sub { });
3017 quilt_fixup_mkwork($headref);
3019 rmtree("debian/patches");
3021 runcmd @dpkgsource, qw(-b .);
3023 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3024 rename srcfn("$upstreamversion", "/debian/patches"),
3025 "work/debian/patches";
3028 commit_quilty_patch();
3031 sub quilt_make_fake_dsc ($) {
3032 my ($upstreamversion) = @_;
3034 my $fakeversion="$upstreamversion-~~DGITFAKE";
3036 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3037 print $fakedsc <<END or die $!;
3040 Version: $fakeversion
3044 my $dscaddfile=sub {
3047 my $md = new Digest::MD5;
3049 my $fh = new IO::File $b, '<' or die "$b $!";
3054 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3057 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3059 my @files=qw(debian/source/format debian/rules
3060 debian/control debian/changelog);
3061 foreach my $maybe (qw(debian/patches debian/source/options
3062 debian/tests/control)) {
3063 next unless stat_exists "../../../$maybe";
3064 push @files, $maybe;
3067 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3068 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3070 $dscaddfile->($debtar);
3071 close $fakedsc or die $!;
3074 sub quilt_check_splitbrain_cache ($$) {
3075 my ($headref, $upstreamversion) = @_;
3076 # Called only if we are in (potentially) split brain mode.
3078 # Computes the cache key and looks in the cache.
3079 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3081 my $splitbrain_cachekey;
3084 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3085 # we look in the reflog of dgit-intern/quilt-cache
3086 # we look for an entry whose message is the key for the cache lookup
3087 my @cachekey = (qw(dgit), $our_version);
3088 push @cachekey, $upstreamversion;
3089 push @cachekey, $quilt_mode;
3090 push @cachekey, $headref;
3092 push @cachekey, hashfile('fake.dsc');
3094 my $srcshash = Digest::SHA->new(256);
3095 my %sfs = ( %INC, '$0(dgit)' => $0 );
3096 foreach my $sfk (sort keys %sfs) {
3097 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3098 $srcshash->add($sfk," ");
3099 $srcshash->add(hashfile($sfs{$sfk}));
3100 $srcshash->add("\n");
3102 push @cachekey, $srcshash->hexdigest();
3103 $splitbrain_cachekey = "@cachekey";
3105 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3107 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3108 debugcmd "|(probably)",@cmd;
3109 my $child = open GC, "-|"; defined $child or die $!;
3111 chdir '../../..' or die $!;
3112 if (!stat ".git/logs/refs/$splitbraincache") {
3113 $! == ENOENT or die $!;
3114 printdebug ">(no reflog)\n";
3121 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3122 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3125 quilt_fixup_mkwork($headref);
3126 if ($cachehit ne $headref) {
3127 progress "dgit view: found cached (commit id $cachehit)";
3128 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3130 return ($cachehit, $splitbrain_cachekey);
3132 progress "dgit view: found cached, no changes required";
3133 return ($headref, $splitbrain_cachekey);
3135 die $! if GC->error;
3136 failedcmd unless close GC;
3138 printdebug "splitbrain cache miss\n";
3139 return (undef, $splitbrain_cachekey);
3142 sub quilt_fixup_multipatch ($$$) {
3143 my ($clogp, $headref, $upstreamversion) = @_;
3145 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3148 # - honour any existing .pc in case it has any strangeness
3149 # - determine the git commit corresponding to the tip of
3150 # the patch stack (if there is one)
3151 # - if there is such a git commit, convert each subsequent
3152 # git commit into a quilt patch with dpkg-source --commit
3153 # - otherwise convert all the differences in the tree into
3154 # a single git commit
3158 # Our git tree doesn't necessarily contain .pc. (Some versions of
3159 # dgit would include the .pc in the git tree.) If there isn't
3160 # one, we need to generate one by unpacking the patches that we
3163 # We first look for a .pc in the git tree. If there is one, we
3164 # will use it. (This is not the normal case.)
3166 # Otherwise need to regenerate .pc so that dpkg-source --commit
3167 # can work. We do this as follows:
3168 # 1. Collect all relevant .orig from parent directory
3169 # 2. Generate a debian.tar.gz out of
3170 # debian/{patches,rules,source/format,source/options}
3171 # 3. Generate a fake .dsc containing just these fields:
3172 # Format Source Version Files
3173 # 4. Extract the fake .dsc
3174 # Now the fake .dsc has a .pc directory.
3175 # (In fact we do this in every case, because in future we will
3176 # want to search for a good base commit for generating patches.)
3178 # Then we can actually do the dpkg-source --commit
3179 # 1. Make a new working tree with the same object
3180 # store as our main tree and check out the main
3182 # 2. Copy .pc from the fake's extraction, if necessary
3183 # 3. Run dpkg-source --commit
3184 # 4. If the result has changes to debian/, then
3185 # - git-add them them
3186 # - git-add .pc if we had a .pc in-tree
3188 # 5. If we had a .pc in-tree, delete it, and git-commit
3189 # 6. Back in the main tree, fast forward to the new HEAD
3191 # Another situation we may have to cope with is gbp-style
3192 # patches-unapplied trees.
3194 # We would want to detect these, so we know to escape into
3195 # quilt_fixup_gbp. However, this is in general not possible.
3196 # Consider a package with a one patch which the dgit user reverts
3197 # (with git-revert or the moral equivalent).
3199 # That is indistinguishable in contents from a patches-unapplied
3200 # tree. And looking at the history to distinguish them is not
3201 # useful because the user might have made a confusing-looking git
3202 # history structure (which ought to produce an error if dgit can't
3203 # cope, not a silent reintroduction of an unwanted patch).
3205 # So gbp users will have to pass an option. But we can usually
3206 # detect their failure to do so: if the tree is not a clean
3207 # patches-applied tree, quilt linearisation fails, but the tree
3208 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3209 # they want --quilt=unapplied.
3211 # To help detect this, when we are extracting the fake dsc, we
3212 # first extract it with --skip-patches, and then apply the patches
3213 # afterwards with dpkg-source --before-build. That lets us save a
3214 # tree object corresponding to .origs.
3216 my $splitbrain_cachekey;
3218 quilt_make_fake_dsc($upstreamversion);
3220 if (quiltmode_splitbrain()) {
3222 ($cachehit, $splitbrain_cachekey) =
3223 quilt_check_splitbrain_cache($headref, $upstreamversion);
3224 return if $cachehit;
3228 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3230 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3231 rename $fakexdir, "fake" or die "$fakexdir $!";
3235 remove_stray_gits();
3236 mktree_in_ud_here();
3240 runcmd @git, qw(add -Af .);
3241 my $unapplied=git_write_tree();
3242 printdebug "fake orig tree object $unapplied\n";
3247 'exec dpkg-source --before-build . >/dev/null';
3251 quilt_fixup_mkwork($headref);
3254 if (stat_exists ".pc") {
3256 progress "Tree already contains .pc - will use it then delete it.";
3259 rename '../fake/.pc','.pc' or die $!;
3262 changedir '../fake';
3264 runcmd @git, qw(add -Af .);
3265 my $oldtiptree=git_write_tree();
3266 printdebug "fake o+d/p tree object $unapplied\n";
3267 changedir '../work';
3270 # We calculate some guesswork now about what kind of tree this might
3271 # be. This is mostly for error reporting.
3276 # O = orig, without patches applied
3277 # A = "applied", ie orig with H's debian/patches applied
3278 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3279 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3280 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3284 foreach my $b (qw(01 02)) {
3285 foreach my $v (qw(H2O O2A H2A)) {
3286 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3289 printdebug "differences \@dl @dl.\n";
3292 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3293 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3294 $dl[0], $dl[1], $dl[3], $dl[4],
3298 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3299 push @failsuggestion, "This might be a patches-unapplied branch.";
3300 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3301 push @failsuggestion, "This might be a patches-applied branch.";
3303 push @failsuggestion, "Maybe you need to specify one of".
3304 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3306 if (quiltmode_splitbrain()) {
3307 quiltify_splitbrain($clogp, $unapplied, $headref,
3308 $diffbits, \%editedignores,
3309 $splitbrain_cachekey);
3313 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3314 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3316 if (!open P, '>>', ".pc/applied-patches") {
3317 $!==&ENOENT or die $!;
3322 commit_quilty_patch();
3324 if ($mustdeletepc) {
3325 quilt_fixup_delete_pc();
3329 sub quilt_fixup_editor () {
3330 my $descfn = $ENV{$fakeeditorenv};
3331 my $editing = $ARGV[$#ARGV];
3332 open I1, '<', $descfn or die "$descfn: $!";
3333 open I2, '<', $editing or die "$editing: $!";
3334 unlink $editing or die "$editing: $!";
3335 open O, '>', $editing or die "$editing: $!";
3336 while (<I1>) { print O or die $!; } I1->error and die $!;
3339 $copying ||= m/^\-\-\- /;
3340 next unless $copying;
3343 I2->error and die $!;
3348 sub maybe_apply_patches_dirtily () {
3349 return unless $quilt_mode =~ m/gbp|unapplied/;
3350 print STDERR <<END or die $!;
3352 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3353 dgit: Have to apply the patches - making the tree dirty.
3354 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3357 $patches_applied_dirtily = 01;
3358 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3359 runcmd qw(dpkg-source --before-build .);
3362 sub maybe_unapply_patches_again () {
3363 progress "dgit: Unapplying patches again to tidy up the tree."
3364 if $patches_applied_dirtily;
3365 runcmd qw(dpkg-source --after-build .)
3366 if $patches_applied_dirtily & 01;
3368 if $patches_applied_dirtily & 02;
3371 #----- other building -----
3373 our $clean_using_builder;
3374 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3375 # clean the tree before building (perhaps invoked indirectly by
3376 # whatever we are using to run the build), rather than separately
3377 # and explicitly by us.
3380 return if $clean_using_builder;
3381 if ($cleanmode eq 'dpkg-source') {
3382 maybe_apply_patches_dirtily();
3383 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3384 } elsif ($cleanmode eq 'dpkg-source-d') {
3385 maybe_apply_patches_dirtily();
3386 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3387 } elsif ($cleanmode eq 'git') {
3388 runcmd_ordryrun_local @git, qw(clean -xdf);
3389 } elsif ($cleanmode eq 'git-ff') {
3390 runcmd_ordryrun_local @git, qw(clean -xdff);
3391 } elsif ($cleanmode eq 'check') {
3392 my $leftovers = cmdoutput @git, qw(clean -xdn);
3393 if (length $leftovers) {
3394 print STDERR $leftovers, "\n" or die $!;
3395 fail "tree contains uncommitted files and --clean=check specified";
3397 } elsif ($cleanmode eq 'none') {
3404 badusage "clean takes no additional arguments" if @ARGV;
3407 maybe_unapply_patches_again();
3412 badusage "-p is not allowed when building" if defined $package;
3415 my $clogp = parsechangelog();
3416 $isuite = getfield $clogp, 'Distribution';
3417 $package = getfield $clogp, 'Source';
3418 $version = getfield $clogp, 'Version';
3419 build_maybe_quilt_fixup();
3421 my $pat = changespat $version;
3422 foreach my $f (glob "$buildproductsdir/$pat") {
3424 unlink $f or fail "remove old changes file $f: $!";
3426 progress "would remove $f";
3432 sub changesopts_initial () {
3433 my @opts =@changesopts[1..$#changesopts];
3436 sub changesopts_version () {
3437 if (!defined $changes_since_version) {
3438 my @vsns = archive_query('archive_query');
3439 my @quirk = access_quirk();
3440 if ($quirk[0] eq 'backports') {
3441 local $isuite = $quirk[2];
3443 canonicalise_suite();
3444 push @vsns, archive_query('archive_query');
3447 @vsns = map { $_->[0] } @vsns;
3448 @vsns = sort { -version_compare($a, $b) } @vsns;
3449 $changes_since_version = $vsns[0];
3450 progress "changelog will contain changes since $vsns[0]";
3452 $changes_since_version = '_';
3453 progress "package seems new, not specifying -v<version>";
3456 if ($changes_since_version ne '_') {
3457 return ("-v$changes_since_version");
3463 sub changesopts () {
3464 return (changesopts_initial(), changesopts_version());
3467 sub massage_dbp_args ($;$) {
3468 my ($cmd,$xargs) = @_;
3471 # - if we're going to split the source build out so we can
3472 # do strange things to it, massage the arguments to dpkg-buildpackage
3473 # so that the main build doessn't build source (or add an argument
3474 # to stop it building source by default).
3476 # - add -nc to stop dpkg-source cleaning the source tree,
3477 # unless we're not doing a split build and want dpkg-source
3478 # as cleanmode, in which case we can do nothing
3481 # 0 - source will NOT need to be built separately by caller
3482 # +1 - source will need to be built separately by caller
3483 # +2 - source will need to be built separately by caller AND
3484 # dpkg-buildpackage should not in fact be run at all!
3485 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3486 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3487 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3488 $clean_using_builder = 1;
3491 # -nc has the side effect of specifying -b if nothing else specified
3492 # and some combinations of -S, -b, et al, are errors, rather than
3493 # later simply overriding earlie. So we need to:
3494 # - search the command line for these options
3495 # - pick the last one
3496 # - perhaps add our own as a default
3497 # - perhaps adjust it to the corresponding non-source-building version
3499 foreach my $l ($cmd, $xargs) {
3501 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3504 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3506 if ($need_split_build_invocation) {
3507 printdebug "massage split $dmode.\n";
3508 $r = $dmode =~ m/[S]/ ? +2 :
3509 $dmode =~ y/gGF/ABb/ ? +1 :
3510 $dmode =~ m/[ABb]/ ? 0 :
3513 printdebug "massage done $r $dmode.\n";
3515 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3520 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3521 my $wantsrc = massage_dbp_args \@dbp;
3528 push @dbp, changesopts_version();
3529 maybe_apply_patches_dirtily();
3530 runcmd_ordryrun_local @dbp;
3532 maybe_unapply_patches_again();
3533 printdone "build successful\n";
3537 my @dbp = @dpkgbuildpackage;
3539 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3542 if (length executable_on_path('git-buildpackage')) {
3543 @cmd = qw(git-buildpackage);
3545 @cmd = qw(gbp buildpackage);
3547 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3552 if (!$clean_using_builder) {
3553 push @cmd, '--git-cleaner=true';
3558 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3559 canonicalise_suite();
3560 push @cmd, "--git-debian-branch=".lbranch();
3562 push @cmd, changesopts();
3563 maybe_apply_patches_dirtily();
3564 runcmd_ordryrun_local @cmd, @ARGV;
3566 maybe_unapply_patches_again();
3567 printdone "build successful\n";
3569 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3572 my $our_cleanmode = $cleanmode;
3573 if ($need_split_build_invocation) {
3574 # Pretend that clean is being done some other way. This
3575 # forces us not to try to use dpkg-buildpackage to clean and
3576 # build source all in one go; and instead we run dpkg-source
3577 # (and build_prep() will do the clean since $clean_using_builder
3579 $our_cleanmode = 'ELSEWHERE';
3581 if ($our_cleanmode =~ m/^dpkg-source/) {
3582 # dpkg-source invocation (below) will clean, so build_prep shouldn't
3583 $clean_using_builder = 1;
3586 $sourcechanges = changespat $version,'source';
3588 unlink "../$sourcechanges" or $!==ENOENT
3589 or fail "remove $sourcechanges: $!";
3591 $dscfn = dscfn($version);
3592 if ($our_cleanmode eq 'dpkg-source') {
3593 maybe_apply_patches_dirtily();
3594 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3596 } elsif ($our_cleanmode eq 'dpkg-source-d') {
3597 maybe_apply_patches_dirtily();
3598 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3601 my @cmd = (@dpkgsource, qw(-b --));
3604 runcmd_ordryrun_local @cmd, "work";
3605 my @udfiles = <${package}_*>;
3606 changedir "../../..";
3607 foreach my $f (@udfiles) {
3608 printdebug "source copy, found $f\n";
3611 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3612 $f eq srcfn($version, $&));
3613 printdebug "source copy, found $f - renaming\n";
3614 rename "$ud/$f", "../$f" or $!==ENOENT
3615 or fail "put in place new source file ($f): $!";
3618 my $pwd = must_getcwd();
3619 my $leafdir = basename $pwd;
3621 runcmd_ordryrun_local @cmd, $leafdir;
3624 runcmd_ordryrun_local qw(sh -ec),
3625 'exec >$1; shift; exec "$@"','x',
3626 "../$sourcechanges",
3627 @dpkggenchanges, qw(-S), changesopts();
3631 sub cmd_build_source {
3632 badusage "build-source takes no additional arguments" if @ARGV;
3634 maybe_unapply_patches_again();
3635 printdone "source built, results in $dscfn and $sourcechanges";
3640 my $pat = changespat $version;
3642 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3643 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3644 fail "changes files other than source matching $pat".
3645 " already present (@unwanted);".
3646 " building would result in ambiguity about the intended results"
3651 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3652 stat_exists $sourcechanges
3653 or fail "$sourcechanges (in parent directory): $!";
3655 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3656 my @changesfiles = glob $pat;
3657 @changesfiles = sort {
3658 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3661 fail "wrong number of different changes files (@changesfiles)"
3662 unless @changesfiles==2;
3663 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3664 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3665 fail "$l found in binaries changes file $binchanges"
3668 runcmd_ordryrun_local @mergechanges, @changesfiles;
3669 my $multichanges = changespat $version,'multi';
3671 stat_exists $multichanges or fail "$multichanges: $!";
3672 foreach my $cf (glob $pat) {
3673 next if $cf eq $multichanges;
3674 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3677 maybe_unapply_patches_again();
3678 printdone "build successful, results in $multichanges\n" or die $!;
3681 sub cmd_quilt_fixup {
3682 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3683 my $clogp = parsechangelog();
3684 $version = getfield $clogp, 'Version';
3685 $package = getfield $clogp, 'Source';
3688 build_maybe_quilt_fixup();
3691 sub cmd_archive_api_query {
3692 badusage "need only 1 subpath argument" unless @ARGV==1;
3693 my ($subpath) = @ARGV;
3694 my @cmd = archive_api_query_cmd($subpath);
3696 exec @cmd or fail "exec curl: $!\n";
3699 sub cmd_clone_dgit_repos_server {
3700 badusage "need destination argument" unless @ARGV==1;
3701 my ($destdir) = @ARGV;
3702 $package = '_dgit-repos-server';
3703 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3705 exec @cmd or fail "exec git clone: $!\n";
3708 sub cmd_setup_mergechangelogs {
3709 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3710 setup_mergechangelogs(1);
3713 sub cmd_setup_useremail {
3714 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3718 sub cmd_setup_new_tree {
3719 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3723 #---------- argument parsing and main program ----------
3726 print "dgit version $our_version\n" or die $!;
3730 our (%valopts_long, %valopts_short);
3733 sub defvalopt ($$$$) {
3734 my ($long,$short,$val_re,$how) = @_;
3735 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3736 $valopts_long{$long} = $oi;
3737 $valopts_short{$short} = $oi;
3738 # $how subref should:
3739 # do whatever assignemnt or thing it likes with $_[0]
3740 # if the option should not be passed on to remote, @rvalopts=()
3741 # or $how can be a scalar ref, meaning simply assign the value
3744 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3745 defvalopt '--distro', '-d', '.+', \$idistro;
3746 defvalopt '', '-k', '.+', \$keyid;
3747 defvalopt '--existing-package','', '.*', \$existing_package;
3748 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3749 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3750 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3752 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3754 defvalopt '', '-C', '.+', sub {
3755 ($changesfile) = (@_);
3756 if ($changesfile =~ s#^(.*)/##) {
3757 $buildproductsdir = $1;
3761 defvalopt '--initiator-tempdir','','.*', sub {
3762 ($initiator_tempdir) = (@_);
3763 $initiator_tempdir =~ m#^/# or
3764 badusage "--initiator-tempdir must be used specify an".
3765 " absolute, not relative, directory."
3771 if (defined $ENV{'DGIT_SSH'}) {
3772 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3773 } elsif (defined $ENV{'GIT_SSH'}) {
3774 @ssh = ($ENV{'GIT_SSH'});
3782 if (!defined $val) {
3783 badusage "$what needs a value" unless @ARGV;
3785 push @rvalopts, $val;
3787 badusage "bad value \`$val' for $what" unless
3788 $val =~ m/^$oi->{Re}$(?!\n)/s;
3789 my $how = $oi->{How};
3790 if (ref($how) eq 'SCALAR') {
3795 push @ropts, @rvalopts;
3799 last unless $ARGV[0] =~ m/^-/;
3803 if (m/^--dry-run$/) {
3806 } elsif (m/^--damp-run$/) {
3809 } elsif (m/^--no-sign$/) {
3812 } elsif (m/^--help$/) {
3814 } elsif (m/^--version$/) {
3816 } elsif (m/^--new$/) {
3819 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3820 ($om = $opts_opt_map{$1}) &&
3824 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3825 !$opts_opt_cmdonly{$1} &&
3826 ($om = $opts_opt_map{$1})) {
3829 } elsif (m/^--ignore-dirty$/s) {
3832 } elsif (m/^--no-quilt-fixup$/s) {
3834 $quilt_mode = 'nocheck';
3835 } elsif (m/^--no-rm-on-error$/s) {
3838 } elsif (m/^--(no-)?rm-old-changes$/s) {
3841 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3843 push @deliberatelies, $&;
3844 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
3845 # undocumented, for testing
3847 $tagformat = [ $1, 'command line', 1 ];
3848 # 1 menas overrides distro configuration
3849 } elsif (m/^--always-split-source-build$/s) {
3850 # undocumented, for testing
3852 $need_split_build_invocation = 1;
3853 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3854 $val = $2 ? $' : undef; #';
3855 $valopt->($oi->{Long});
3857 badusage "unknown long option \`$_'";
3864 } elsif (s/^-L/-/) {
3867 } elsif (s/^-h/-/) {
3869 } elsif (s/^-D/-/) {
3873 } elsif (s/^-N/-/) {
3878 push @changesopts, $_;
3880 } elsif (s/^-wn$//s) {
3882 $cleanmode = 'none';
3883 } elsif (s/^-wg$//s) {
3886 } elsif (s/^-wgf$//s) {
3888 $cleanmode = 'git-ff';
3889 } elsif (s/^-wd$//s) {
3891 $cleanmode = 'dpkg-source';
3892 } elsif (s/^-wdd$//s) {
3894 $cleanmode = 'dpkg-source-d';
3895 } elsif (s/^-wc$//s) {
3897 $cleanmode = 'check';
3898 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3900 $val = undef unless length $val;
3901 $valopt->($oi->{Short});
3904 badusage "unknown short option \`$_'";
3911 sub finalise_opts_opts () {
3912 foreach my $k (keys %opts_opt_map) {
3913 my $om = $opts_opt_map{$k};
3915 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3917 badcfg "cannot set command for $k"
3918 unless length $om->[0];
3922 foreach my $c (access_cfg_cfgs("opts-$k")) {
3923 my $vl = $gitcfg{$c};
3924 printdebug "CL $c ",
3925 ($vl ? join " ", map { shellquote } @$vl : ""),
3926 "\n" if $debuglevel >= 4;
3928 badcfg "cannot configure options for $k"
3929 if $opts_opt_cmdonly{$k};
3930 my $insertpos = $opts_cfg_insertpos{$k};
3931 @$om = ( @$om[0..$insertpos-1],
3933 @$om[$insertpos..$#$om] );
3938 if ($ENV{$fakeeditorenv}) {
3940 quilt_fixup_editor();
3946 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3947 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3948 if $dryrun_level == 1;
3950 print STDERR $helpmsg or die $!;
3953 my $cmd = shift @ARGV;
3956 if (!defined $rmchanges) {
3957 local $access_forpush;
3958 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3961 if (!defined $quilt_mode) {
3962 local $access_forpush;
3963 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3964 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3966 $quilt_mode =~ m/^($quilt_modes_re)$/
3967 or badcfg "unknown quilt-mode \`$quilt_mode'";
3971 $need_split_build_invocation ||= quiltmode_splitbrain();
3973 if (!defined $cleanmode) {
3974 local $access_forpush;
3975 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3976 $cleanmode //= 'dpkg-source';
3978 badcfg "unknown clean-mode \`$cleanmode'" unless
3979 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3982 my $fn = ${*::}{"cmd_$cmd"};
3983 $fn or badusage "unknown operation $cmd";