3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
40 our $our_version = 'UNRELEASED'; ###substituted###
42 our @rpushprotovsn_support = qw(3 2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
60 our $cleanmode = 'dpkg-source';
61 our $changes_since_version;
63 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
64 our $we_are_responder;
65 our $initiator_tempdir;
67 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
69 our $suite_re = '[-+.0-9a-z]+';
72 our (@dget) = qw(dget);
73 our (@curl) = qw(curl -f);
74 our (@dput) = qw(dput);
75 our (@debsign) = qw(debsign);
77 our (@sbuild) = qw(sbuild -A);
79 our (@dgit) = qw(dgit);
80 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
81 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
82 our (@dpkggenchanges) = qw(dpkg-genchanges);
83 our (@mergechanges) = qw(mergechanges -f);
84 our (@changesopts) = ('');
86 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
89 'debsign' => \@debsign,
95 'dpkg-source' => \@dpkgsource,
96 'dpkg-buildpackage' => \@dpkgbuildpackage,
97 'dpkg-genchanges' => \@dpkggenchanges,
98 'ch' => \@changesopts,
99 'mergechanges' => \@mergechanges);
101 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
102 our %opts_cfg_insertpos = map {
104 scalar @{ $opts_opt_map{$_} }
105 } keys %opts_opt_map;
107 sub finalise_opts_opts();
113 our $supplementary_message = '';
117 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
120 our $remotename = 'dgit';
121 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
125 sub lbranch () { return "$branchprefix/$csuite"; }
126 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
127 sub lref () { return "refs/heads/".lbranch(); }
128 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
129 sub rrref () { return server_ref($csuite); }
131 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
141 return "${package}_".(stripepoch $vsn).$sfx
146 return srcfn($vsn,".dsc");
155 foreach my $f (@end) {
157 warn "$us: cleanup: $@" if length $@;
161 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
163 sub no_such_package () {
164 print STDERR "$us: package $package does not exist in suite $isuite\n";
170 return "+".rrref().":".lrref();
175 printdebug "CD $newdir\n";
176 chdir $newdir or die "chdir: $newdir: $!";
179 sub deliberately ($) {
181 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
184 sub deliberately_not_fast_forward () {
185 foreach (qw(not-fast-forward fresh-repo)) {
186 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
190 #---------- remote protocol support, common ----------
192 # remote push initiator/responder protocol:
193 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
194 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
195 # < dgit-remote-push-ready <actual-proto-vsn>
197 # > file parsed-changelog
198 # [indicates that output of dpkg-parsechangelog follows]
199 # > data-block NBYTES
200 # > [NBYTES bytes of data (no newline)]
201 # [maybe some more blocks]
213 # [indicates that signed tag is wanted]
214 # < data-block NBYTES
215 # < [NBYTES bytes of data (no newline)]
216 # [maybe some more blocks]
220 # > want signed-dsc-changes
221 # < data-block NBYTES [transfer of signed dsc]
223 # < data-block NBYTES [transfer of signed changes]
231 sub i_child_report () {
232 # Sees if our child has died, and reap it if so. Returns a string
233 # describing how it died if it failed, or undef otherwise.
234 return undef unless $i_child_pid;
235 my $got = waitpid $i_child_pid, WNOHANG;
236 return undef if $got <= 0;
237 die unless $got == $i_child_pid;
238 $i_child_pid = undef;
239 return undef unless $?;
240 return "build host child ".waitstatusmsg();
245 fail "connection lost: $!" if $fh->error;
246 fail "protocol violation; $m not expected";
249 sub badproto_badread ($$) {
251 fail "connection lost: $!" if $!;
252 my $report = i_child_report();
253 fail $report if defined $report;
254 badproto $fh, "eof (reading $wh)";
257 sub protocol_expect (&$) {
258 my ($match, $fh) = @_;
261 defined && chomp or badproto_badread $fh, "protocol message";
269 badproto $fh, "\`$_'";
272 sub protocol_send_file ($$) {
273 my ($fh, $ourfn) = @_;
274 open PF, "<", $ourfn or die "$ourfn: $!";
277 my $got = read PF, $d, 65536;
278 die "$ourfn: $!" unless defined $got;
280 print $fh "data-block ".length($d)."\n" or die $!;
281 print $fh $d or die $!;
283 PF->error and die "$ourfn $!";
284 print $fh "data-end\n" or die $!;
288 sub protocol_read_bytes ($$) {
289 my ($fh, $nbytes) = @_;
290 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
292 my $got = read $fh, $d, $nbytes;
293 $got==$nbytes or badproto_badread $fh, "data block";
297 sub protocol_receive_file ($$) {
298 my ($fh, $ourfn) = @_;
299 printdebug "() $ourfn\n";
300 open PF, ">", $ourfn or die "$ourfn: $!";
302 my ($y,$l) = protocol_expect {
303 m/^data-block (.*)$/ ? (1,$1) :
304 m/^data-end$/ ? (0,) :
308 my $d = protocol_read_bytes $fh, $l;
309 print PF $d or die $!;
314 #---------- remote protocol support, responder ----------
316 sub responder_send_command ($) {
318 return unless $we_are_responder;
319 # called even without $we_are_responder
320 printdebug ">> $command\n";
321 print PO $command, "\n" or die $!;
324 sub responder_send_file ($$) {
325 my ($keyword, $ourfn) = @_;
326 return unless $we_are_responder;
327 printdebug "]] $keyword $ourfn\n";
328 responder_send_command "file $keyword";
329 protocol_send_file \*PO, $ourfn;
332 sub responder_receive_files ($@) {
333 my ($keyword, @ourfns) = @_;
334 die unless $we_are_responder;
335 printdebug "[[ $keyword @ourfns\n";
336 responder_send_command "want $keyword";
337 foreach my $fn (@ourfns) {
338 protocol_receive_file \*PI, $fn;
341 protocol_expect { m/^files-end$/ } \*PI;
344 #---------- remote protocol support, initiator ----------
346 sub initiator_expect (&) {
348 protocol_expect { &$match } \*RO;
351 #---------- end remote code ----------
354 if ($we_are_responder) {
356 responder_send_command "progress ".length($m) or die $!;
357 print PO $m or die $!;
367 $ua = LWP::UserAgent->new();
371 progress "downloading $what...";
372 my $r = $ua->get(@_) or die $!;
373 return undef if $r->code == 404;
374 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
375 return $r->decoded_content(charset => 'none');
378 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
383 failedcmd @_ if system @_;
386 sub act_local () { return $dryrun_level <= 1; }
387 sub act_scary () { return !$dryrun_level; }
390 if (!$dryrun_level) {
391 progress "dgit ok: @_";
393 progress "would be ok: @_ (but dry run only)";
398 printcmd(\*STDERR,$debugprefix."#",@_);
401 sub runcmd_ordryrun {
409 sub runcmd_ordryrun_local {
418 my ($first_shell, @cmd) = @_;
419 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
422 our $helpmsg = <<END;
424 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
425 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
426 dgit [dgit-opts] build [dpkg-buildpackage-opts]
427 dgit [dgit-opts] sbuild [sbuild-opts]
428 dgit [dgit-opts] push [dgit-opts] [suite]
429 dgit [dgit-opts] rpush build-host:build-dir ...
430 important dgit options:
431 -k<keyid> sign tag and package with <keyid> instead of default
432 --dry-run -n do not change anything, but go through the motions
433 --damp-run -L like --dry-run but make local changes, without signing
434 --new -N allow introducing a new package
435 --debug -D increase debug level
436 -c<name>=<value> set git config option (used directly by dgit too)
439 our $later_warning_msg = <<END;
440 Perhaps the upload is stuck in incoming. Using the version from git.
444 print STDERR "$us: @_\n", $helpmsg or die $!;
449 @ARGV or badusage "too few arguments";
450 return scalar shift @ARGV;
454 print $helpmsg or die $!;
458 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
460 our %defcfg = ('dgit.default.distro' => 'debian',
461 'dgit.default.username' => '',
462 'dgit.default.archive-query-default-component' => 'main',
463 'dgit.default.ssh' => 'ssh',
464 'dgit.default.archive-query' => 'madison:',
465 'dgit.default.sshpsql-dbname' => 'service=projectb',
466 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
467 'dgit-distro.debian.git-check' => 'url',
468 'dgit-distro.debian.git-check-suffix' => '/info/refs',
469 'dgit-distro.debian.new-private-pushers' => 't',
470 'dgit-distro.debian/push.git-url' => '',
471 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
472 'dgit-distro.debian/push.git-user-force' => 'dgit',
473 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
474 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
475 'dgit-distro.debian/push.git-create' => 'true',
476 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
477 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
478 # 'dgit-distro.debian.archive-query-tls-key',
479 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
480 # ^ this does not work because curl is broken nowadays
481 # Fixing #790093 properly will involve providing providing the key
482 # in some pacagke and maybe updating these paths.
484 # 'dgit-distro.debian.archive-query-tls-curl-args',
485 # '--ca-path=/etc/ssl/ca-debian',
486 # ^ this is a workaround but works (only) on DSA-administered machines
487 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
488 'dgit-distro.debian.git-url-suffix' => '',
489 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
490 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
491 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
492 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
493 'dgit-distro.ubuntu.git-check' => 'false',
494 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
495 'dgit-distro.test-dummy.ssh' => "$td/ssh",
496 'dgit-distro.test-dummy.username' => "alice",
497 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
498 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
499 'dgit-distro.test-dummy.git-url' => "$td/git",
500 'dgit-distro.test-dummy.git-host' => "git",
501 'dgit-distro.test-dummy.git-path' => "$td/git",
502 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
503 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
504 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
505 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
510 sub git_slurp_config () {
511 local ($debuglevel) = $debuglevel-2;
514 my @cmd = (@git, qw(config -z --get-regexp .*));
517 open GITS, "-|", @cmd or failedcmd @cmd;
520 printdebug "=> ", (messagequote $_), "\n";
522 push @{ $gitcfg{$`} }, $'; #';
526 or ($!==0 && $?==256)
530 sub git_get_config ($) {
533 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
536 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
542 return undef if $c =~ /RETURN-UNDEF/;
543 my $v = git_get_config($c);
544 return $v if defined $v;
545 my $dv = $defcfg{$c};
546 return $dv if defined $dv;
548 badcfg "need value for one of: @_\n".
549 "$us: distro or suite appears not to be (properly) supported";
552 sub access_basedistro () {
553 if (defined $idistro) {
556 return cfg("dgit-suite.$isuite.distro",
557 "dgit.default.distro");
561 sub access_quirk () {
562 # returns (quirk name, distro to use instead or undef, quirk-specific info)
563 my $basedistro = access_basedistro();
564 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
566 if (defined $backports_quirk) {
567 my $re = $backports_quirk;
568 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
570 $re =~ s/\%/([-0-9a-z_]+)/
571 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
572 if ($isuite =~ m/^$re$/) {
573 return ('backports',"$basedistro-backports",$1);
576 return ('none',undef);
581 sub parse_cfg_bool ($$$) {
582 my ($what,$def,$v) = @_;
585 $v =~ m/^[ty1]/ ? 1 :
586 $v =~ m/^[fn0]/ ? 0 :
587 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
590 sub access_forpush_config () {
591 my $d = access_basedistro();
595 parse_cfg_bool('new-private-pushers', 0,
596 cfg("dgit-distro.$d.new-private-pushers",
599 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
602 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
603 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
604 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
605 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
608 sub access_forpush () {
609 $access_forpush //= access_forpush_config();
610 return $access_forpush;
614 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
615 badcfg "pushing but distro is configured readonly"
616 if access_forpush_config() eq '0';
618 $supplementary_message = <<'END' unless $we_are_responder;
619 Push failed, before we got started.
620 You can retry the push, after fixing the problem, if you like.
622 finalise_opts_opts();
626 finalise_opts_opts();
629 sub supplementary_message ($) {
631 if (!$we_are_responder) {
632 $supplementary_message = $msg;
634 } elsif ($protovsn >= 3) {
635 responder_send_command "supplementary-message ".length($msg)
637 print PO $msg or die $!;
641 sub access_distros () {
642 # Returns list of distros to try, in order
645 # 0. `instead of' distro name(s) we have been pointed to
646 # 1. the access_quirk distro, if any
647 # 2a. the user's specified distro, or failing that } basedistro
648 # 2b. the distro calculated from the suite }
649 my @l = access_basedistro();
651 my (undef,$quirkdistro) = access_quirk();
652 unshift @l, $quirkdistro;
653 unshift @l, $instead_distro;
654 @l = grep { defined } @l;
656 if (access_forpush()) {
657 @l = map { ("$_/push", $_) } @l;
662 sub access_cfg_cfgs (@) {
665 # The nesting of these loops determines the search order. We put
666 # the key loop on the outside so that we search all the distros
667 # for each key, before going on to the next key. That means that
668 # if access_cfg is called with a more specific, and then a less
669 # specific, key, an earlier distro can override the less specific
670 # without necessarily overriding any more specific keys. (If the
671 # distro wants to override the more specific keys it can simply do
672 # so; whereas if we did the loop the other way around, it would be
673 # impossible to for an earlier distro to override a less specific
674 # key but not the more specific ones without restating the unknown
675 # values of the more specific keys.
678 # We have to deal with RETURN-UNDEF specially, so that we don't
679 # terminate the search prematurely.
681 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
684 foreach my $d (access_distros()) {
685 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
687 push @cfgs, map { "dgit.default.$_" } @realkeys;
694 my (@cfgs) = access_cfg_cfgs(@keys);
695 my $value = cfg(@cfgs);
699 sub access_cfg_bool ($$) {
700 my ($def, @keys) = @_;
701 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
704 sub string_to_ssh ($) {
706 if ($spec =~ m/\s/) {
707 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
713 sub access_cfg_ssh () {
714 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
715 if (!defined $gitssh) {
718 return string_to_ssh $gitssh;
722 sub access_runeinfo ($) {
724 return ": dgit ".access_basedistro()." $info ;";
727 sub access_someuserhost ($) {
729 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
730 defined($user) && length($user) or
731 $user = access_cfg("$some-user",'username');
732 my $host = access_cfg("$some-host");
733 return length($user) ? "$user\@$host" : $host;
736 sub access_gituserhost () {
737 return access_someuserhost('git');
740 sub access_giturl (;$) {
742 my $url = access_cfg('git-url','RETURN-UNDEF');
745 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
746 return undef unless defined $proto;
749 access_gituserhost().
750 access_cfg('git-path');
752 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
755 return "$url/$package$suffix";
758 sub parsecontrolfh ($$;$) {
759 my ($fh, $desc, $allowsigned) = @_;
760 our $dpkgcontrolhash_noissigned;
763 my %opts = ('name' => $desc);
764 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
765 $c = Dpkg::Control::Hash->new(%opts);
766 $c->parse($fh,$desc) or die "parsing of $desc failed";
767 last if $allowsigned;
768 last if $dpkgcontrolhash_noissigned;
769 my $issigned= $c->get_option('is_pgp_signed');
770 if (!defined $issigned) {
771 $dpkgcontrolhash_noissigned= 1;
772 seek $fh, 0,0 or die "seek $desc: $!";
773 } elsif ($issigned) {
774 fail "control file $desc is (already) PGP-signed. ".
775 " Note that dgit push needs to modify the .dsc and then".
776 " do the signature itself";
785 my ($file, $desc) = @_;
786 my $fh = new IO::Handle;
787 open $fh, '<', $file or die "$file: $!";
788 my $c = parsecontrolfh($fh,$desc);
789 $fh->error and die $!;
795 my ($dctrl,$field) = @_;
796 my $v = $dctrl->{$field};
797 return $v if defined $v;
798 fail "missing field $field in ".$v->get_option('name');
802 my $c = Dpkg::Control::Hash->new();
803 my $p = new IO::Handle;
804 my @cmd = (qw(dpkg-parsechangelog), @_);
805 open $p, '-|', @cmd or die $!;
807 $?=0; $!=0; close $p or failedcmd @cmd;
813 defined $d or fail "getcwd failed: $!";
819 sub archive_query ($) {
821 my $query = access_cfg('archive-query','RETURN-UNDEF');
822 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
825 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
828 sub pool_dsc_subpath ($$) {
829 my ($vsn,$component) = @_; # $package is implict arg
830 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
831 return "/pool/$component/$prefix/$package/".dscfn($vsn);
834 #---------- `ftpmasterapi' archive query method (nascent) ----------
836 sub archive_api_query_cmd ($) {
838 my @cmd = qw(curl -sS);
839 my $url = access_cfg('archive-query-url');
840 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
842 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
843 foreach my $key (split /\:/, $keys) {
844 $key =~ s/\%HOST\%/$host/g;
846 fail "for $url: stat $key: $!" unless $!==ENOENT;
849 fail "config requested specific TLS key but do not know".
850 " how to get curl to use exactly that EE key ($key)";
851 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
852 # # Sadly the above line does not work because of changes
853 # # to gnutls. The real fix for #790093 may involve
854 # # new curl options.
857 # Fixing #790093 properly will involve providing a value
858 # for this on clients.
859 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
860 push @cmd, split / /, $kargs if defined $kargs;
862 push @cmd, $url.$subpath;
868 my ($data, $subpath) = @_;
869 badcfg "ftpmasterapi archive query method takes no data part"
871 my @cmd = archive_api_query_cmd($subpath);
872 my $json = cmdoutput @cmd;
873 return decode_json($json);
876 sub canonicalise_suite_ftpmasterapi () {
877 my ($proto,$data) = @_;
878 my $suites = api_query($data, 'suites');
880 foreach my $entry (@$suites) {
882 my $v = $entry->{$_};
883 defined $v && $v eq $isuite;
885 push @matched, $entry;
887 fail "unknown suite $isuite" unless @matched;
890 @matched==1 or die "multiple matches for suite $isuite\n";
891 $cn = "$matched[0]{codename}";
892 defined $cn or die "suite $isuite info has no codename\n";
893 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
895 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
900 sub archive_query_ftpmasterapi () {
901 my ($proto,$data) = @_;
902 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
904 my $digester = Digest::SHA->new(256);
905 foreach my $entry (@$info) {
907 my $vsn = "$entry->{version}";
908 my ($ok,$msg) = version_check $vsn;
909 die "bad version: $msg\n" unless $ok;
910 my $component = "$entry->{component}";
911 $component =~ m/^$component_re$/ or die "bad component";
912 my $filename = "$entry->{filename}";
913 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
914 or die "bad filename";
915 my $sha256sum = "$entry->{sha256sum}";
916 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
917 push @rows, [ $vsn, "/pool/$component/$filename",
918 $digester, $sha256sum ];
920 die "bad ftpmaster api response: $@\n".Dumper($entry)
923 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
927 #---------- `madison' archive query method ----------
929 sub archive_query_madison {
930 return map { [ @$_[0..1] ] } madison_get_parse(@_);
933 sub madison_get_parse {
934 my ($proto,$data) = @_;
935 die unless $proto eq 'madison';
937 $data= access_cfg('madison-distro','RETURN-UNDEF');
938 $data //= access_basedistro();
940 $rmad{$proto,$data,$package} ||= cmdoutput
941 qw(rmadison -asource),"-s$isuite","-u$data",$package;
942 my $rmad = $rmad{$proto,$data,$package};
945 foreach my $l (split /\n/, $rmad) {
946 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
947 \s*( [^ \t|]+ )\s* \|
948 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
949 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
950 $1 eq $package or die "$rmad $package ?";
957 $component = access_cfg('archive-query-default-component');
959 $5 eq 'source' or die "$rmad ?";
960 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
962 return sort { -version_compare($a->[0],$b->[0]); } @out;
965 sub canonicalise_suite_madison {
966 # madison canonicalises for us
967 my @r = madison_get_parse(@_);
969 "unable to canonicalise suite using package $package".
970 " which does not appear to exist in suite $isuite;".
971 " --existing-package may help";
975 #---------- `sshpsql' archive query method ----------
978 my ($data,$runeinfo,$sql) = @_;
980 $data= access_someuserhost('sshpsql').':'.
981 access_cfg('sshpsql-dbname');
983 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
984 my ($userhost,$dbname) = ($`,$'); #';
986 my @cmd = (access_cfg_ssh, $userhost,
987 access_runeinfo("ssh-psql $runeinfo").
988 " export LC_MESSAGES=C; export LC_CTYPE=C;".
989 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
991 open P, "-|", @cmd or die $!;
994 printdebug(">|$_|\n");
997 $!=0; $?=0; close P or failedcmd @cmd;
999 my $nrows = pop @rows;
1000 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1001 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1002 @rows = map { [ split /\|/, $_ ] } @rows;
1003 my $ncols = scalar @{ shift @rows };
1004 die if grep { scalar @$_ != $ncols } @rows;
1008 sub sql_injection_check {
1009 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1012 sub archive_query_sshpsql ($$) {
1013 my ($proto,$data) = @_;
1014 sql_injection_check $isuite, $package;
1015 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1016 SELECT source.version, component.name, files.filename, files.sha256sum
1018 JOIN src_associations ON source.id = src_associations.source
1019 JOIN suite ON suite.id = src_associations.suite
1020 JOIN dsc_files ON dsc_files.source = source.id
1021 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1022 JOIN component ON component.id = files_archive_map.component_id
1023 JOIN files ON files.id = dsc_files.file
1024 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1025 AND source.source='$package'
1026 AND files.filename LIKE '%.dsc';
1028 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1029 my $digester = Digest::SHA->new(256);
1031 my ($vsn,$component,$filename,$sha256sum) = @$_;
1032 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1037 sub canonicalise_suite_sshpsql ($$) {
1038 my ($proto,$data) = @_;
1039 sql_injection_check $isuite;
1040 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1041 SELECT suite.codename
1042 FROM suite where suite_name='$isuite' or codename='$isuite';
1044 @rows = map { $_->[0] } @rows;
1045 fail "unknown suite $isuite" unless @rows;
1046 die "ambiguous $isuite: @rows ?" if @rows>1;
1050 #---------- `dummycat' archive query method ----------
1052 sub canonicalise_suite_dummycat ($$) {
1053 my ($proto,$data) = @_;
1054 my $dpath = "$data/suite.$isuite";
1055 if (!open C, "<", $dpath) {
1056 $!==ENOENT or die "$dpath: $!";
1057 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1061 chomp or die "$dpath: $!";
1063 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1067 sub archive_query_dummycat ($$) {
1068 my ($proto,$data) = @_;
1069 canonicalise_suite();
1070 my $dpath = "$data/package.$csuite.$package";
1071 if (!open C, "<", $dpath) {
1072 $!==ENOENT or die "$dpath: $!";
1073 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1081 printdebug "dummycat query $csuite $package $dpath | $_\n";
1082 my @row = split /\s+/, $_;
1083 @row==2 or die "$dpath: $_ ?";
1086 C->error and die "$dpath: $!";
1088 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1091 #---------- archive query entrypoints and rest of program ----------
1093 sub canonicalise_suite () {
1094 return if defined $csuite;
1095 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1096 $csuite = archive_query('canonicalise_suite');
1097 if ($isuite ne $csuite) {
1098 progress "canonical suite name for $isuite is $csuite";
1102 sub get_archive_dsc () {
1103 canonicalise_suite();
1104 my @vsns = archive_query('archive_query');
1105 foreach my $vinfo (@vsns) {
1106 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1107 $dscurl = access_cfg('mirror').$subpath;
1108 $dscdata = url_get($dscurl);
1110 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1115 $digester->add($dscdata);
1116 my $got = $digester->hexdigest();
1118 fail "$dscurl has hash $got but".
1119 " archive told us to expect $digest";
1121 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1122 printdebug Dumper($dscdata) if $debuglevel>1;
1123 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1124 printdebug Dumper($dsc) if $debuglevel>1;
1125 my $fmt = getfield $dsc, 'Format';
1126 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1127 $dsc_checked = !!$digester;
1133 sub check_for_git ();
1134 sub check_for_git () {
1136 my $how = access_cfg('git-check');
1137 if ($how eq 'ssh-cmd') {
1139 (access_cfg_ssh, access_gituserhost(),
1140 access_runeinfo("git-check $package").
1141 " set -e; cd ".access_cfg('git-path').";".
1142 " if test -d $package.git; then echo 1; else echo 0; fi");
1143 my $r= cmdoutput @cmd;
1144 if ($r =~ m/^divert (\w+)$/) {
1146 my ($usedistro,) = access_distros();
1147 # NB that if we are pushing, $usedistro will be $distro/push
1148 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1149 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1150 progress "diverting to $divert (using config for $instead_distro)";
1151 return check_for_git();
1153 failedcmd @cmd unless $r =~ m/^[01]$/;
1155 } elsif ($how eq 'url') {
1156 my $prefix = access_cfg('git-check-url','git-url');
1157 my $suffix = access_cfg('git-check-suffix','git-suffix',
1158 'RETURN-UNDEF') // '.git';
1159 my $url = "$prefix/$package$suffix";
1160 my @cmd = (qw(curl -sS -I), $url);
1161 my $result = cmdoutput @cmd;
1162 $result =~ s/^\S+ 200 .*\n\r?\n//;
1163 # curl -sS -I with https_proxy prints
1164 # HTTP/1.0 200 Connection established
1165 $result =~ m/^\S+ (404|200) /s or
1166 fail "unexpected results from git check query - ".
1167 Dumper($prefix, $result);
1169 if ($code eq '404') {
1171 } elsif ($code eq '200') {
1176 } elsif ($how eq 'true') {
1178 } elsif ($how eq 'false') {
1181 badcfg "unknown git-check \`$how'";
1185 sub create_remote_git_repo () {
1186 my $how = access_cfg('git-create');
1187 if ($how eq 'ssh-cmd') {
1189 (access_cfg_ssh, access_gituserhost(),
1190 access_runeinfo("git-create $package").
1191 "set -e; cd ".access_cfg('git-path').";".
1192 " cp -a _template $package.git");
1193 } elsif ($how eq 'true') {
1196 badcfg "unknown git-create \`$how'";
1200 our ($dsc_hash,$lastpush_hash);
1202 our $ud = '.git/dgit/unpack';
1207 mkdir $ud or die $!;
1210 sub mktree_in_ud_here () {
1211 runcmd qw(git init -q);
1212 rmtree('.git/objects');
1213 symlink '../../../../objects','.git/objects' or die $!;
1216 sub git_write_tree () {
1217 my $tree = cmdoutput @git, qw(write-tree);
1218 $tree =~ m/^\w+$/ or die "$tree ?";
1222 sub remove_stray_gits () {
1223 my @gitscmd = qw(find -name .git -prune -print0);
1224 debugcmd "|",@gitscmd;
1225 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1230 print STDERR "$us: warning: removing from source package: ",
1231 (messagequote $_), "\n";
1235 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1238 sub mktree_in_ud_from_only_subdir () {
1239 # changes into the subdir
1241 die unless @dirs==1;
1242 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1246 remove_stray_gits();
1247 mktree_in_ud_here();
1248 my $format=get_source_format();
1249 if (madformat($format)) {
1252 runcmd @git, qw(add -Af);
1253 my $tree=git_write_tree();
1254 return ($tree,$dir);
1257 sub dsc_files_info () {
1258 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1259 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1260 ['Files', 'Digest::MD5', 'new()']) {
1261 my ($fname, $module, $method) = @$csumi;
1262 my $field = $dsc->{$fname};
1263 next unless defined $field;
1264 eval "use $module; 1;" or die $@;
1266 foreach (split /\n/, $field) {
1268 m/^(\w+) (\d+) (\S+)$/ or
1269 fail "could not parse .dsc $fname line \`$_'";
1270 my $digester = eval "$module"."->$method;" or die $@;
1275 Digester => $digester,
1280 fail "missing any supported Checksums-* or Files field in ".
1281 $dsc->get_option('name');
1285 map { $_->{Filename} } dsc_files_info();
1288 sub is_orig_file ($;$) {
1291 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1292 defined $base or return 1;
1296 sub make_commit ($) {
1298 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1301 sub clogp_authline ($) {
1303 my $author = getfield $clogp, 'Maintainer';
1304 $author =~ s#,.*##ms;
1305 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1306 my $authline = "$author $date";
1307 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1308 fail "unexpected commit author line format \`$authline'".
1309 " (was generated from changelog Maintainer field)";
1313 sub vendor_patches_distro ($$) {
1314 my ($checkdistro, $what) = @_;
1315 return unless defined $checkdistro;
1317 my $series = "debian/patches/\L$checkdistro\E.series";
1318 printdebug "checking for vendor-specific $series ($what)\n";
1320 if (!open SERIES, "<", $series) {
1321 die "$series $!" unless $!==ENOENT;
1330 Unfortunately, this source package uses a feature of dpkg-source where
1331 the same source package unpacks to different source code on different
1332 distros. dgit cannot safely operate on such packages on affected
1333 distros, because the meaning of source packages is not stable.
1335 Please ask the distro/maintainer to remove the distro-specific series
1336 files and use a different technique (if necessary, uploading actually
1337 different packages, if different distros are supposed to have
1341 fail "Found active distro-specific series file for".
1342 " $checkdistro ($what): $series, cannot continue";
1344 die "$series $!" if SERIES->error;
1348 sub check_for_vendor_patches () {
1349 # This dpkg-source feature doesn't seem to be documented anywhere!
1350 # But it can be found in the changelog (reformatted):
1352 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1353 # Author: Raphael Hertzog <hertzog@debian.org>
1354 # Date: Sun Oct 3 09:36:48 2010 +0200
1356 # dpkg-source: correctly create .pc/.quilt_series with alternate
1359 # If you have debian/patches/ubuntu.series and you were
1360 # unpacking the source package on ubuntu, quilt was still
1361 # directed to debian/patches/series instead of
1362 # debian/patches/ubuntu.series.
1364 # debian/changelog | 3 +++
1365 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1366 # 2 files changed, 6 insertions(+), 1 deletion(-)
1369 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1370 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1371 "Dpkg::Vendor \`current vendor'");
1372 vendor_patches_distro(access_basedistro(),
1373 "distro being accessed");
1376 sub generate_commit_from_dsc () {
1380 foreach my $fi (dsc_files_info()) {
1381 my $f = $fi->{Filename};
1382 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1384 link "../../../$f", $f
1388 complete_file_from_dsc('.', $fi);
1390 if (is_orig_file($f)) {
1391 link $f, "../../../../$f"
1397 my $dscfn = "$package.dsc";
1399 open D, ">", $dscfn or die "$dscfn: $!";
1400 print D $dscdata or die "$dscfn: $!";
1401 close D or die "$dscfn: $!";
1402 my @cmd = qw(dpkg-source);
1403 push @cmd, '--no-check' if $dsc_checked;
1404 push @cmd, qw(-x --), $dscfn;
1407 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1408 check_for_vendor_patches() if madformat($dsc->{format});
1409 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1410 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1411 my $authline = clogp_authline $clogp;
1412 my $changes = getfield $clogp, 'Changes';
1413 open C, ">../commit.tmp" or die $!;
1414 print C <<END or die $!;
1421 # imported from the archive
1424 my $outputhash = make_commit qw(../commit.tmp);
1425 my $cversion = getfield $clogp, 'Version';
1426 progress "synthesised git commit from .dsc $cversion";
1427 if ($lastpush_hash) {
1428 runcmd @git, qw(reset --hard), $lastpush_hash;
1429 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1430 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1431 my $oversion = getfield $oldclogp, 'Version';
1433 version_compare($oversion, $cversion);
1435 # git upload/ is earlier vsn than archive, use archive
1436 open C, ">../commit2.tmp" or die $!;
1437 print C <<END or die $!;
1439 parent $lastpush_hash
1444 Record $package ($cversion) in archive suite $csuite
1446 $outputhash = make_commit qw(../commit2.tmp);
1447 } elsif ($vcmp > 0) {
1448 print STDERR <<END or die $!;
1450 Version actually in archive: $cversion (older)
1451 Last allegedly pushed/uploaded: $oversion (newer or same)
1454 $outputhash = $lastpush_hash;
1456 $outputhash = $lastpush_hash;
1459 changedir '../../../..';
1460 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1461 'DGIT_ARCHIVE', $outputhash;
1462 cmdoutput @git, qw(log -n2), $outputhash;
1463 # ... gives git a chance to complain if our commit is malformed
1468 sub complete_file_from_dsc ($$) {
1469 our ($dstdir, $fi) = @_;
1470 # Ensures that we have, in $dir, the file $fi, with the correct
1471 # contents. (Downloading it from alongside $dscurl if necessary.)
1473 my $f = $fi->{Filename};
1474 my $tf = "$dstdir/$f";
1477 if (stat_exists $tf) {
1478 progress "using existing $f";
1481 $furl =~ s{/[^/]+$}{};
1483 die "$f ?" unless $f =~ m/^${package}_/;
1484 die "$f ?" if $f =~ m#/#;
1485 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1486 next if !act_local();
1490 open F, "<", "$tf" or die "$tf: $!";
1491 $fi->{Digester}->reset();
1492 $fi->{Digester}->addfile(*F);
1493 F->error and die $!;
1494 my $got = $fi->{Digester}->hexdigest();
1495 $got eq $fi->{Hash} or
1496 fail "file $f has hash $got but .dsc".
1497 " demands hash $fi->{Hash} ".
1498 ($downloaded ? "(got wrong file from archive!)"
1499 : "(perhaps you should delete this file?)");
1502 sub ensure_we_have_orig () {
1503 foreach my $fi (dsc_files_info()) {
1504 my $f = $fi->{Filename};
1505 next unless is_orig_file($f);
1506 complete_file_from_dsc('..', $fi);
1510 sub git_fetch_us () {
1511 my @specs = (fetchspec());
1513 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1515 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1518 my $tagpat = debiantag('*',access_basedistro);
1520 git_for_each_ref("refs/tags/".$tagpat, sub {
1521 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1522 printdebug "currently $fullrefname=$objid\n";
1523 $here{$fullrefname} = $objid;
1525 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1526 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1527 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1528 printdebug "offered $lref=$objid\n";
1529 if (!defined $here{$lref}) {
1530 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1531 runcmd_ordryrun_local @upd;
1532 } elsif ($here{$lref} eq $objid) {
1535 "Not updateting $lref from $here{$lref} to $objid.\n";
1540 sub fetch_from_archive () {
1541 # ensures that lrref() is what is actually in the archive,
1542 # one way or another
1546 foreach my $field (@ourdscfield) {
1547 $dsc_hash = $dsc->{$field};
1548 last if defined $dsc_hash;
1550 if (defined $dsc_hash) {
1551 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1553 progress "last upload to archive specified git hash";
1555 progress "last upload to archive has NO git hash";
1558 progress "no version available from the archive";
1561 $lastpush_hash = git_get_ref(lrref());
1562 printdebug "previous reference hash=$lastpush_hash\n";
1564 if (defined $dsc_hash) {
1565 fail "missing remote git history even though dsc has hash -".
1566 " could not find ref ".lrref().
1567 " (should have been fetched from ".access_giturl()."#".rrref().")"
1568 unless $lastpush_hash;
1570 ensure_we_have_orig();
1571 if ($dsc_hash eq $lastpush_hash) {
1572 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1573 print STDERR <<END or die $!;
1575 Git commit in archive is behind the last version allegedly pushed/uploaded.
1576 Commit referred to by archive: $dsc_hash
1577 Last allegedly pushed/uploaded: $lastpush_hash
1580 $hash = $lastpush_hash;
1582 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1583 "descendant of archive's .dsc hash ($dsc_hash)";
1586 $hash = generate_commit_from_dsc();
1587 } elsif ($lastpush_hash) {
1588 # only in git, not in the archive yet
1589 $hash = $lastpush_hash;
1590 print STDERR <<END or die $!;
1592 Package not found in the archive, but has allegedly been pushed using dgit.
1596 printdebug "nothing found!\n";
1597 if (defined $skew_warning_vsn) {
1598 print STDERR <<END or die $!;
1600 Warning: relevant archive skew detected.
1601 Archive allegedly contains $skew_warning_vsn
1602 But we were not able to obtain any version from the archive or git.
1608 printdebug "current hash=$hash\n";
1609 if ($lastpush_hash) {
1610 fail "not fast forward on last upload branch!".
1611 " (archive's version left in DGIT_ARCHIVE)"
1612 unless is_fast_fwd($lastpush_hash, $hash);
1614 if (defined $skew_warning_vsn) {
1616 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1617 my $clogf = ".git/dgit/changelog.tmp";
1618 runcmd shell_cmd "exec >$clogf",
1619 @git, qw(cat-file blob), "$hash:debian/changelog";
1620 my $gotclogp = parsechangelog("-l$clogf");
1621 my $got_vsn = getfield $gotclogp, 'Version';
1622 printdebug "SKEW CHECK GOT $got_vsn\n";
1623 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1624 print STDERR <<END or die $!;
1626 Warning: archive skew detected. Using the available version:
1627 Archive allegedly contains $skew_warning_vsn
1628 We were able to obtain only $got_vsn
1633 if ($lastpush_hash ne $hash) {
1634 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1638 dryrun_report @upd_cmd;
1644 sub set_local_git_config ($$) {
1646 runcmd @git, qw(config), $k, $v;
1649 sub setup_mergechangelogs (;$) {
1651 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1653 my $driver = 'dpkg-mergechangelogs';
1654 my $cb = "merge.$driver";
1655 my $attrs = '.git/info/attributes';
1656 ensuredir '.git/info';
1658 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1659 if (!open ATTRS, "<", $attrs) {
1660 $!==ENOENT or die "$attrs: $!";
1664 next if m{^debian/changelog\s};
1665 print NATTRS $_, "\n" or die $!;
1667 ATTRS->error and die $!;
1670 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1673 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1674 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1676 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1679 sub setup_useremail (;$) {
1681 return unless $always || access_cfg_bool(1, 'setup-useremail');
1684 my ($k, $envvar) = @_;
1685 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1686 return unless defined $v;
1687 set_local_git_config "user.$k", $v;
1690 $setup->('email', 'DEBEMAIL');
1691 $setup->('name', 'DEBFULLNAME');
1694 sub setup_new_tree () {
1695 setup_mergechangelogs();
1701 canonicalise_suite();
1702 badusage "dry run makes no sense with clone" unless act_local();
1703 my $hasgit = check_for_git();
1704 mkdir $dstdir or die "$dstdir $!";
1706 runcmd @git, qw(init -q);
1707 my $giturl = access_giturl(1);
1708 if (defined $giturl) {
1709 set_local_git_config "remote.$remotename.fetch", fetchspec();
1710 open H, "> .git/HEAD" or die $!;
1711 print H "ref: ".lref()."\n" or die $!;
1713 runcmd @git, qw(remote add), 'origin', $giturl;
1716 progress "fetching existing git history";
1718 runcmd_ordryrun_local @git, qw(fetch origin);
1720 progress "starting new git history";
1722 fetch_from_archive() or no_such_package;
1723 my $vcsgiturl = $dsc->{'Vcs-Git'};
1724 if (length $vcsgiturl) {
1725 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1726 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1729 runcmd @git, qw(reset --hard), lrref();
1730 printdone "ready for work in $dstdir";
1734 if (check_for_git()) {
1737 fetch_from_archive() or no_such_package();
1738 printdone "fetched into ".lrref();
1743 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1745 printdone "fetched to ".lrref()." and merged into HEAD";
1748 sub check_not_dirty () {
1749 return if $ignoredirty;
1750 my @cmd = (@git, qw(diff --quiet HEAD));
1752 $!=0; $?=0; system @cmd;
1753 return if !$! && !$?;
1754 if (!$! && $?==256) {
1755 fail "working tree is dirty (does not match HEAD)";
1761 sub commit_admin ($) {
1764 runcmd_ordryrun_local @git, qw(commit -m), $m;
1767 sub commit_quilty_patch () {
1768 my $output = cmdoutput @git, qw(status --porcelain);
1770 foreach my $l (split /\n/, $output) {
1771 next unless $l =~ m/\S/;
1772 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1776 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1778 progress "nothing quilty to commit, ok.";
1781 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1782 commit_admin "Commit Debian 3.0 (quilt) metadata";
1785 sub get_source_format () {
1786 if (!open F, "debian/source/format") {
1787 die $! unless $!==&ENOENT;
1791 F->error and die $!;
1798 return 0 unless $format eq '3.0 (quilt)';
1799 if ($quilt_mode eq 'nocheck') {
1800 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1803 progress "Format \`$format', checking/updating patch stack";
1807 sub push_parse_changelog ($) {
1810 my $clogp = Dpkg::Control::Hash->new();
1811 $clogp->load($clogpfn) or die;
1813 $package = getfield $clogp, 'Source';
1814 my $cversion = getfield $clogp, 'Version';
1815 my $tag = debiantag($cversion, access_basedistro);
1816 runcmd @git, qw(check-ref-format), $tag;
1818 my $dscfn = dscfn($cversion);
1820 return ($clogp, $cversion, $tag, $dscfn);
1823 sub push_parse_dsc ($$$) {
1824 my ($dscfn,$dscfnwhat, $cversion) = @_;
1825 $dsc = parsecontrol($dscfn,$dscfnwhat);
1826 my $dversion = getfield $dsc, 'Version';
1827 my $dscpackage = getfield $dsc, 'Source';
1828 ($dscpackage eq $package && $dversion eq $cversion) or
1829 fail "$dscfn is for $dscpackage $dversion".
1830 " but debian/changelog is for $package $cversion";
1833 sub push_mktag ($$$$$$$) {
1834 my ($head,$clogp,$tag,
1836 $changesfile,$changesfilewhat,
1839 $dsc->{$ourdscfield[0]} = $head;
1840 $dsc->save("$dscfn.tmp") or die $!;
1842 my $changes = parsecontrol($changesfile,$changesfilewhat);
1843 foreach my $field (qw(Source Distribution Version)) {
1844 $changes->{$field} eq $clogp->{$field} or
1845 fail "changes field $field \`$changes->{$field}'".
1846 " does not match changelog \`$clogp->{$field}'";
1849 my $cversion = getfield $clogp, 'Version';
1850 my $clogsuite = getfield $clogp, 'Distribution';
1852 # We make the git tag by hand because (a) that makes it easier
1853 # to control the "tagger" (b) we can do remote signing
1854 my $authline = clogp_authline $clogp;
1855 my $delibs = join(" ", "",@deliberatelies);
1856 my $declaredistro = access_basedistro();
1857 open TO, '>', $tfn->('.tmp') or die $!;
1858 print TO <<END or die $!;
1864 $package release $cversion for $clogsuite ($csuite) [dgit]
1865 [dgit distro=$declaredistro$delibs]
1867 foreach my $ref (sort keys %previously) {
1868 print TO <<END or die $!;
1869 [dgit previously:$ref=$previously{$ref}]
1875 my $tagobjfn = $tfn->('.tmp');
1877 if (!defined $keyid) {
1878 $keyid = access_cfg('keyid','RETURN-UNDEF');
1880 if (!defined $keyid) {
1881 $keyid = getfield $clogp, 'Maintainer';
1883 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1884 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1885 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1886 push @sign_cmd, $tfn->('.tmp');
1887 runcmd_ordryrun @sign_cmd;
1889 $tagobjfn = $tfn->('.signed.tmp');
1890 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1891 $tfn->('.tmp'), $tfn->('.tmp.asc');
1898 sub sign_changes ($) {
1899 my ($changesfile) = @_;
1901 my @debsign_cmd = @debsign;
1902 push @debsign_cmd, "-k$keyid" if defined $keyid;
1903 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1904 push @debsign_cmd, $changesfile;
1905 runcmd_ordryrun @debsign_cmd;
1910 my ($forceflag) = @_;
1911 printdebug "actually entering push\n";
1912 supplementary_message(<<'END');
1913 Push failed, while preparing your push.
1914 You can retry the push, after fixing the problem, if you like.
1918 access_giturl(); # check that success is vaguely likely
1920 my $clogpfn = ".git/dgit/changelog.822.tmp";
1921 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1923 responder_send_file('parsed-changelog', $clogpfn);
1925 my ($clogp, $cversion, $tag, $dscfn) =
1926 push_parse_changelog("$clogpfn");
1928 my $dscpath = "$buildproductsdir/$dscfn";
1929 stat_exists $dscpath or
1930 fail "looked for .dsc $dscfn, but $!;".
1931 " maybe you forgot to build";
1933 responder_send_file('dsc', $dscpath);
1935 push_parse_dsc($dscpath, $dscfn, $cversion);
1937 my $format = getfield $dsc, 'Format';
1938 printdebug "format $format\n";
1939 if (madformat($format)) {
1940 commit_quilty_patch();
1944 progress "checking that $dscfn corresponds to HEAD";
1945 runcmd qw(dpkg-source -x --),
1946 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1947 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1948 check_for_vendor_patches() if madformat($dsc->{format});
1949 changedir '../../../..';
1950 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1951 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1952 debugcmd "+",@diffcmd;
1954 my $r = system @diffcmd;
1957 fail "$dscfn specifies a different tree to your HEAD commit;".
1958 " perhaps you forgot to build".
1959 ($diffopt eq '--exit-code' ? "" :
1960 " (run with -D to see full diff output)");
1965 my $head = git_rev_parse('HEAD');
1966 if (!$changesfile) {
1967 my $multi = "$buildproductsdir/".
1968 "${package}_".(stripepoch $cversion)."_multi.changes";
1969 if (stat_exists "$multi") {
1970 $changesfile = $multi;
1972 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1973 my @cs = glob "$buildproductsdir/$pat";
1974 fail "failed to find unique changes file".
1975 " (looked for $pat in $buildproductsdir, or $multi);".
1976 " perhaps you need to use dgit -C"
1978 ($changesfile) = @cs;
1981 $changesfile = "$buildproductsdir/$changesfile";
1984 responder_send_file('changes',$changesfile);
1985 responder_send_command("param head $head");
1986 responder_send_command("param csuite $csuite");
1988 if (deliberately_not_fast_forward) {
1989 git_for_each_ref(lrfetchrefs, sub {
1990 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1991 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1992 responder_send_command("previously $rrefname=$objid");
1993 $previously{$rrefname} = $objid;
1997 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2000 supplementary_message(<<'END');
2001 Push failed, while signing the tag.
2002 You can retry the push, after fixing the problem, if you like.
2004 # If we manage to sign but fail to record it anywhere, it's fine.
2005 if ($we_are_responder) {
2006 $tagobjfn = $tfn->('.signed.tmp');
2007 responder_receive_files('signed-tag', $tagobjfn);
2010 push_mktag($head,$clogp,$tag,
2012 $changesfile,$changesfile,
2015 supplementary_message(<<'END');
2016 Push failed, *after* signing the tag.
2017 If you want to try again, you should use a new version number.
2020 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2021 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2022 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2024 supplementary_message(<<'END');
2025 Push failed, while updating the remote git repository - see messages above.
2026 If you want to try again, you should use a new version number.
2028 if (!check_for_git()) {
2029 create_remote_git_repo();
2031 runcmd_ordryrun @git, qw(push),access_giturl(),
2032 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2033 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2035 supplementary_message(<<'END');
2036 Push failed, after updating the remote git repository.
2037 If you want to try again, you must use a new version number.
2039 if ($we_are_responder) {
2040 my $dryrunsuffix = act_local() ? "" : ".tmp";
2041 responder_receive_files('signed-dsc-changes',
2042 "$dscpath$dryrunsuffix",
2043 "$changesfile$dryrunsuffix");
2046 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2048 progress "[new .dsc left in $dscpath.tmp]";
2050 sign_changes $changesfile;
2053 supplementary_message(<<'END');
2054 Push failed, while uploading package(s) to the archive server.
2055 You can retry the upload of exactly these same files with dput of:
2057 If that .changes file is broken, you will need to use a new version
2058 number for your next attempt at the upload.
2060 my $host = access_cfg('upload-host','RETURN-UNDEF');
2061 my @hostarg = defined($host) ? ($host,) : ();
2062 runcmd_ordryrun @dput, @hostarg, $changesfile;
2063 printdone "pushed and uploaded $cversion";
2065 supplementary_message('');
2066 responder_send_command("complete");
2073 badusage "-p is not allowed with clone; specify as argument instead"
2074 if defined $package;
2077 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2078 ($package,$isuite) = @ARGV;
2079 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2080 ($package,$dstdir) = @ARGV;
2081 } elsif (@ARGV==3) {
2082 ($package,$isuite,$dstdir) = @ARGV;
2084 badusage "incorrect arguments to dgit clone";
2086 $dstdir ||= "$package";
2088 if (stat_exists $dstdir) {
2089 fail "$dstdir already exists";
2093 if ($rmonerror && !$dryrun_level) {
2094 $cwd_remove= getcwd();
2096 return unless defined $cwd_remove;
2097 if (!chdir "$cwd_remove") {
2098 return if $!==&ENOENT;
2099 die "chdir $cwd_remove: $!";
2101 rmtree($dstdir) or die "remove $dstdir: $!\n";
2106 $cwd_remove = undef;
2109 sub branchsuite () {
2110 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2111 if ($branch =~ m#$lbranch_re#o) {
2118 sub fetchpullargs () {
2120 if (!defined $package) {
2121 my $sourcep = parsecontrol('debian/control','debian/control');
2122 $package = getfield $sourcep, 'Source';
2125 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2127 my $clogp = parsechangelog();
2128 $isuite = getfield $clogp, 'Distribution';
2130 canonicalise_suite();
2131 progress "fetching from suite $csuite";
2132 } elsif (@ARGV==1) {
2134 canonicalise_suite();
2136 badusage "incorrect arguments to dgit fetch or dgit pull";
2155 badusage "-p is not allowed with dgit push" if defined $package;
2157 my $clogp = parsechangelog();
2158 $package = getfield $clogp, 'Source';
2161 } elsif (@ARGV==1) {
2162 ($specsuite) = (@ARGV);
2164 badusage "incorrect arguments to dgit push";
2166 $isuite = getfield $clogp, 'Distribution';
2168 local ($package) = $existing_package; # this is a hack
2169 canonicalise_suite();
2171 canonicalise_suite();
2173 if (defined $specsuite &&
2174 $specsuite ne $isuite &&
2175 $specsuite ne $csuite) {
2176 fail "dgit push: changelog specifies $isuite ($csuite)".
2177 " but command line specifies $specsuite";
2179 supplementary_message(<<'END');
2180 Push failed, while checking state of the archive.
2181 You can retry the push, after fixing the problem, if you like.
2183 if (check_for_git()) {
2187 if (fetch_from_archive()) {
2188 if (is_fast_fwd(lrref(), 'HEAD')) {
2190 } elsif (deliberately_not_fast_forward) {
2193 fail "dgit push: HEAD is not a descendant".
2194 " of the archive's version.\n".
2195 "dgit: To overwrite its contents,".
2196 " use git merge -s ours ".lrref().".\n".
2197 "dgit: To rewind history, if permitted by the archive,".
2198 " use --deliberately-not-fast-forward";
2202 fail "package appears to be new in this suite;".
2203 " if this is intentional, use --new";
2208 #---------- remote commands' implementation ----------
2210 sub cmd_remote_push_build_host {
2211 my ($nrargs) = shift @ARGV;
2212 my (@rargs) = @ARGV[0..$nrargs-1];
2213 @ARGV = @ARGV[$nrargs..$#ARGV];
2215 my ($dir,$vsnwant) = @rargs;
2216 # vsnwant is a comma-separated list; we report which we have
2217 # chosen in our ready response (so other end can tell if they
2220 $we_are_responder = 1;
2221 $us .= " (build host)";
2225 open PI, "<&STDIN" or die $!;
2226 open STDIN, "/dev/null" or die $!;
2227 open PO, ">&STDOUT" or die $!;
2229 open STDOUT, ">&STDERR" or die $!;
2233 ($protovsn) = grep {
2234 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2235 } @rpushprotovsn_support;
2237 fail "build host has dgit rpush protocol versions ".
2238 (join ",", @rpushprotovsn_support).
2239 " but invocation host has $vsnwant"
2240 unless defined $protovsn;
2242 responder_send_command("dgit-remote-push-ready $protovsn");
2248 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2249 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2250 # a good error message)
2256 my $report = i_child_report();
2257 if (defined $report) {
2258 printdebug "($report)\n";
2259 } elsif ($i_child_pid) {
2260 printdebug "(killing build host child $i_child_pid)\n";
2261 kill 15, $i_child_pid;
2263 if (defined $i_tmp && !defined $initiator_tempdir) {
2265 eval { rmtree $i_tmp; };
2269 END { i_cleanup(); }
2272 my ($base,$selector,@args) = @_;
2273 $selector =~ s/\-/_/g;
2274 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2281 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2289 push @rargs, join ",", @rpushprotovsn_support;
2292 push @rdgit, @ropts;
2293 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2295 my @cmd = (@ssh, $host, shellquote @rdgit);
2298 if (defined $initiator_tempdir) {
2299 rmtree $initiator_tempdir;
2300 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2301 $i_tmp = $initiator_tempdir;
2305 $i_child_pid = open2(\*RO, \*RI, @cmd);
2307 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2308 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2309 $supplementary_message = '' unless $protovsn >= 3;
2311 my ($icmd,$iargs) = initiator_expect {
2312 m/^(\S+)(?: (.*))?$/;
2315 i_method "i_resp", $icmd, $iargs;
2319 sub i_resp_progress ($) {
2321 my $msg = protocol_read_bytes \*RO, $rhs;
2325 sub i_resp_supplementary_message ($) {
2327 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2330 sub i_resp_complete {
2331 my $pid = $i_child_pid;
2332 $i_child_pid = undef; # prevents killing some other process with same pid
2333 printdebug "waiting for build host child $pid...\n";
2334 my $got = waitpid $pid, 0;
2335 die $! unless $got == $pid;
2336 die "build host child failed $?" if $?;
2339 printdebug "all done\n";
2343 sub i_resp_file ($) {
2345 my $localname = i_method "i_localname", $keyword;
2346 my $localpath = "$i_tmp/$localname";
2347 stat_exists $localpath and
2348 badproto \*RO, "file $keyword ($localpath) twice";
2349 protocol_receive_file \*RO, $localpath;
2350 i_method "i_file", $keyword;
2355 sub i_resp_param ($) {
2356 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2360 sub i_resp_previously ($) {
2361 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2362 or badproto \*RO, "bad previously spec";
2363 my $r = system qw(git check-ref-format), $1;
2364 die "bad previously ref spec ($r)" if $r;
2365 $previously{$1} = $2;
2370 sub i_resp_want ($) {
2372 die "$keyword ?" if $i_wanted{$keyword}++;
2373 my @localpaths = i_method "i_want", $keyword;
2374 printdebug "[[ $keyword @localpaths\n";
2375 foreach my $localpath (@localpaths) {
2376 protocol_send_file \*RI, $localpath;
2378 print RI "files-end\n" or die $!;
2381 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2383 sub i_localname_parsed_changelog {
2384 return "remote-changelog.822";
2386 sub i_file_parsed_changelog {
2387 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2388 push_parse_changelog "$i_tmp/remote-changelog.822";
2389 die if $i_dscfn =~ m#/|^\W#;
2392 sub i_localname_dsc {
2393 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2398 sub i_localname_changes {
2399 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2400 $i_changesfn = $i_dscfn;
2401 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2402 return $i_changesfn;
2404 sub i_file_changes { }
2406 sub i_want_signed_tag {
2407 printdebug Dumper(\%i_param, $i_dscfn);
2408 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2409 && defined $i_param{'csuite'}
2410 or badproto \*RO, "premature desire for signed-tag";
2411 my $head = $i_param{'head'};
2412 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2414 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2416 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2419 push_mktag $head, $i_clogp, $i_tag,
2421 $i_changesfn, 'remote changes',
2422 sub { "tag$_[0]"; };
2427 sub i_want_signed_dsc_changes {
2428 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2429 sign_changes $i_changesfn;
2430 return ($i_dscfn, $i_changesfn);
2433 #---------- building etc. ----------
2439 #----- `3.0 (quilt)' handling -----
2441 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2443 sub quiltify_dpkg_commit ($$$;$) {
2444 my ($patchname,$author,$msg, $xinfo) = @_;
2448 my $descfn = ".git/dgit/quilt-description.tmp";
2449 open O, '>', $descfn or die "$descfn: $!";
2452 $msg =~ s/^\s+$/ ./mg;
2453 print O <<END or die $!;
2463 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2464 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2465 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2466 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2470 sub quiltify_trees_differ ($$) {
2472 # returns 1 iff the two tree objects differ other than in debian/
2474 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2475 my $diffs= cmdoutput @cmd;
2476 foreach my $f (split /\0/, $diffs) {
2477 next if $f eq 'debian';
2483 sub quiltify_tree_sentinelfiles ($) {
2484 # lists the `sentinel' files present in the tree
2486 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2487 qw(-- debian/rules debian/control);
2493 my ($clogp,$target) = @_;
2495 # Quilt patchification algorithm
2497 # We search backwards through the history of the main tree's HEAD
2498 # (T) looking for a start commit S whose tree object is identical
2499 # to to the patch tip tree (ie the tree corresponding to the
2500 # current dpkg-committed patch series). For these purposes
2501 # `identical' disregards anything in debian/ - this wrinkle is
2502 # necessary because dpkg-source treates debian/ specially.
2504 # We can only traverse edges where at most one of the ancestors'
2505 # trees differs (in changes outside in debian/). And we cannot
2506 # handle edges which change .pc/ or debian/patches. To avoid
2507 # going down a rathole we avoid traversing edges which introduce
2508 # debian/rules or debian/control. And we set a limit on the
2509 # number of edges we are willing to look at.
2511 # If we succeed, we walk forwards again. For each traversed edge
2512 # PC (with P parent, C child) (starting with P=S and ending with
2513 # C=T) to we do this:
2515 # - dpkg-source --commit with a patch name and message derived from C
2516 # After traversing PT, we git commit the changes which
2517 # should be contained within debian/patches.
2519 changedir '../fake';
2520 remove_stray_gits();
2521 mktree_in_ud_here();
2523 runcmd @git, 'add', '.';
2524 my $oldtiptree=git_write_tree();
2525 changedir '../work';
2527 # The search for the path S..T is breadth-first. We maintain a
2528 # todo list containing search nodes. A search node identifies a
2529 # commit, and looks something like this:
2531 # Commit => $git_commit_id,
2532 # Child => $c, # or undef if P=T
2533 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2534 # Nontrivial => true iff $p..$c has relevant changes
2541 my %considered; # saves being exponential on some weird graphs
2543 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2546 my ($search,$whynot) = @_;
2547 printdebug " search NOT $search->{Commit} $whynot\n";
2548 $search->{Whynot} = $whynot;
2549 push @nots, $search;
2550 no warnings qw(exiting);
2559 my $c = shift @todo;
2560 next if $considered{$c->{Commit}}++;
2562 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2564 printdebug "quiltify investigate $c->{Commit}\n";
2567 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2568 printdebug " search finished hooray!\n";
2573 if ($quilt_mode eq 'nofix') {
2574 fail "quilt fixup required but quilt mode is \`nofix'\n".
2575 "HEAD commit $c->{Commit} differs from tree implied by ".
2576 " debian/patches (tree object $oldtiptree)";
2578 if ($quilt_mode eq 'smash') {
2579 printdebug " search quitting smash\n";
2583 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2584 $not->($c, "has $c_sentinels not $t_sentinels")
2585 if $c_sentinels ne $t_sentinels;
2587 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2588 $commitdata =~ m/\n\n/;
2590 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2591 @parents = map { { Commit => $_, Child => $c } } @parents;
2593 $not->($c, "root commit") if !@parents;
2595 foreach my $p (@parents) {
2596 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2598 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2599 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2601 foreach my $p (@parents) {
2602 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2604 my @cmd= (@git, qw(diff-tree -r --name-only),
2605 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2606 my $patchstackchange = cmdoutput @cmd;
2607 if (length $patchstackchange) {
2608 $patchstackchange =~ s/\n/,/g;
2609 $not->($p, "changed $patchstackchange");
2612 printdebug " search queue P=$p->{Commit} ",
2613 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2619 printdebug "quiltify want to smash\n";
2622 my $x = $_[0]{Commit};
2623 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2626 my $reportnot = sub {
2628 my $s = $abbrev->($notp);
2629 my $c = $notp->{Child};
2630 $s .= "..".$abbrev->($c) if $c;
2631 $s .= ": ".$notp->{Whynot};
2634 if ($quilt_mode eq 'linear') {
2635 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2636 foreach my $notp (@nots) {
2637 print STDERR "$us: ", $reportnot->($notp), "\n";
2639 fail "quilt fixup naive history linearisation failed.\n".
2640 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2641 } elsif ($quilt_mode eq 'smash') {
2642 } elsif ($quilt_mode eq 'auto') {
2643 progress "quilt fixup cannot be linear, smashing...";
2645 die "$quilt_mode ?";
2650 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2652 quiltify_dpkg_commit "auto-$version-$target-$time",
2653 (getfield $clogp, 'Maintainer'),
2654 "Automatically generated patch ($clogp->{Version})\n".
2655 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2659 progress "quiltify linearisation planning successful, executing...";
2661 for (my $p = $sref_S;
2662 my $c = $p->{Child};
2664 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2665 next unless $p->{Nontrivial};
2667 my $cc = $c->{Commit};
2669 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2670 $commitdata =~ m/\n\n/ or die "$c ?";
2673 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2676 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2679 my $patchname = $title;
2680 $patchname =~ s/[.:]$//;
2681 $patchname =~ y/ A-Z/-a-z/;
2682 $patchname =~ y/-a-z0-9_.+=~//cd;
2683 $patchname =~ s/^\W/x-$&/;
2684 $patchname = substr($patchname,0,40);
2687 stat "debian/patches/$patchname$index";
2689 $!==ENOENT or die "$patchname$index $!";
2691 runcmd @git, qw(checkout -q), $cc;
2693 # We use the tip's changelog so that dpkg-source doesn't
2694 # produce complaining messages from dpkg-parsechangelog. None
2695 # of the information dpkg-source gets from the changelog is
2696 # actually relevant - it gets put into the original message
2697 # which dpkg-source provides our stunt editor, and then
2699 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2701 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2702 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2704 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2707 runcmd @git, qw(checkout -q master);
2710 sub build_maybe_quilt_fixup () {
2711 my $format=get_source_format;
2712 return unless madformat $format;
2715 check_for_vendor_patches();
2718 # - honour any existing .pc in case it has any strangeness
2719 # - determine the git commit corresponding to the tip of
2720 # the patch stack (if there is one)
2721 # - if there is such a git commit, convert each subsequent
2722 # git commit into a quilt patch with dpkg-source --commit
2723 # - otherwise convert all the differences in the tree into
2724 # a single git commit
2728 # Our git tree doesn't necessarily contain .pc. (Some versions of
2729 # dgit would include the .pc in the git tree.) If there isn't
2730 # one, we need to generate one by unpacking the patches that we
2733 # We first look for a .pc in the git tree. If there is one, we
2734 # will use it. (This is not the normal case.)
2736 # Otherwise need to regenerate .pc so that dpkg-source --commit
2737 # can work. We do this as follows:
2738 # 1. Collect all relevant .orig from parent directory
2739 # 2. Generate a debian.tar.gz out of
2740 # debian/{patches,rules,source/format}
2741 # 3. Generate a fake .dsc containing just these fields:
2742 # Format Source Version Files
2743 # 4. Extract the fake .dsc
2744 # Now the fake .dsc has a .pc directory.
2745 # (In fact we do this in every case, because in future we will
2746 # want to search for a good base commit for generating patches.)
2748 # Then we can actually do the dpkg-source --commit
2749 # 1. Make a new working tree with the same object
2750 # store as our main tree and check out the main
2752 # 2. Copy .pc from the fake's extraction, if necessary
2753 # 3. Run dpkg-source --commit
2754 # 4. If the result has changes to debian/, then
2755 # - git-add them them
2756 # - git-add .pc if we had a .pc in-tree
2758 # 5. If we had a .pc in-tree, delete it, and git-commit
2759 # 6. Back in the main tree, fast forward to the new HEAD
2761 my $clogp = parsechangelog();
2762 my $headref = git_rev_parse('HEAD');
2767 my $upstreamversion=$version;
2768 $upstreamversion =~ s/-[^-]*$//;
2770 my $fakeversion="$upstreamversion-~~DGITFAKE";
2772 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2773 print $fakedsc <<END or die $!;
2776 Version: $fakeversion
2780 my $dscaddfile=sub {
2783 my $md = new Digest::MD5;
2785 my $fh = new IO::File $b, '<' or die "$b $!";
2790 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2793 foreach my $f (<../../../../*>) { #/){
2794 my $b=$f; $b =~ s{.*/}{};
2795 next unless is_orig_file $b, srcfn $upstreamversion,'';
2796 link $f, $b or die "$b $!";
2800 my @files=qw(debian/source/format debian/rules);
2801 if (stat_exists '../../../debian/patches') {
2802 push @files, 'debian/patches';
2805 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2806 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2808 $dscaddfile->($debtar);
2809 close $fakedsc or die $!;
2811 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2813 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2814 rename $fakexdir, "fake" or die "$fakexdir $!";
2816 mkdir "work" or die $!;
2818 mktree_in_ud_here();
2819 runcmd @git, qw(reset --hard), $headref;
2822 if (stat_exists ".pc") {
2824 progress "Tree already contains .pc - will use it then delete it.";
2827 rename '../fake/.pc','.pc' or die $!;
2830 quiltify($clogp,$headref);
2832 if (!open P, '>>', ".pc/applied-patches") {
2833 $!==&ENOENT or die $!;
2838 commit_quilty_patch();
2840 if ($mustdeletepc) {
2841 runcmd @git, qw(rm -rqf .pc);
2842 commit_admin "Commit removal of .pc (quilt series tracking data)";
2845 changedir '../../../..';
2846 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2849 sub quilt_fixup_editor () {
2850 my $descfn = $ENV{$fakeeditorenv};
2851 my $editing = $ARGV[$#ARGV];
2852 open I1, '<', $descfn or die "$descfn: $!";
2853 open I2, '<', $editing or die "$editing: $!";
2854 unlink $editing or die "$editing: $!";
2855 open O, '>', $editing or die "$editing: $!";
2856 while (<I1>) { print O or die $!; } I1->error and die $!;
2859 $copying ||= m/^\-\-\- /;
2860 next unless $copying;
2863 I2->error and die $!;
2868 #----- other building -----
2871 if ($cleanmode eq 'dpkg-source') {
2872 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2873 } elsif ($cleanmode eq 'dpkg-source-d') {
2874 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2875 } elsif ($cleanmode eq 'git') {
2876 runcmd_ordryrun_local @git, qw(clean -xdf);
2877 } elsif ($cleanmode eq 'git-ff') {
2878 runcmd_ordryrun_local @git, qw(clean -xdff);
2879 } elsif ($cleanmode eq 'check') {
2880 my $leftovers = cmdoutput @git, qw(clean -xdn);
2881 if (length $leftovers) {
2882 print STDERR $leftovers, "\n" or die $!;
2883 fail "tree contains uncommitted files and --clean=check specified";
2885 } elsif ($cleanmode eq 'none') {
2892 badusage "clean takes no additional arguments" if @ARGV;
2899 badusage "-p is not allowed when building" if defined $package;
2902 my $clogp = parsechangelog();
2903 $isuite = getfield $clogp, 'Distribution';
2904 $package = getfield $clogp, 'Source';
2905 $version = getfield $clogp, 'Version';
2906 build_maybe_quilt_fixup();
2909 sub changesopts () {
2910 my @opts =@changesopts[1..$#changesopts];
2911 if (!defined $changes_since_version) {
2912 my @vsns = archive_query('archive_query');
2913 my @quirk = access_quirk();
2914 if ($quirk[0] eq 'backports') {
2915 local $isuite = $quirk[2];
2917 canonicalise_suite();
2918 push @vsns, archive_query('archive_query');
2921 @vsns = map { $_->[0] } @vsns;
2922 @vsns = sort { -version_compare($a, $b) } @vsns;
2923 $changes_since_version = $vsns[0];
2924 progress "changelog will contain changes since $vsns[0]";
2926 $changes_since_version = '_';
2927 progress "package seems new, not specifying -v<version>";
2930 if ($changes_since_version ne '_') {
2931 unshift @opts, "-v$changes_since_version";
2936 sub massage_dbp_args ($) {
2938 return unless $cleanmode =~ m/git|none/;
2939 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2940 my @newcmd = shift @$cmd;
2941 # -nc has the side effect of specifying -b if nothing else specified
2942 push @newcmd, '-nc';
2943 # and some combinations of -S, -b, et al, are errors, rather than
2944 # later simply overriding earlier
2945 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2946 push @newcmd, @$cmd;
2952 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2953 massage_dbp_args \@dbp;
2954 runcmd_ordryrun_local @dbp;
2955 printdone "build successful\n";
2960 my @dbp = @dpkgbuildpackage;
2961 massage_dbp_args \@dbp;
2963 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2964 "--git-builder=@dbp");
2965 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2966 canonicalise_suite();
2967 push @cmd, "--git-debian-branch=".lbranch();
2969 push @cmd, changesopts();
2970 runcmd_ordryrun_local @cmd, @ARGV;
2971 printdone "build successful\n";
2973 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
2977 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2978 $dscfn = dscfn($version);
2979 if ($cleanmode eq 'dpkg-source') {
2980 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2982 } elsif ($cleanmode eq 'dpkg-source-d') {
2983 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2986 my $pwd = must_getcwd();
2987 my $leafdir = basename $pwd;
2989 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2991 runcmd_ordryrun_local qw(sh -ec),
2992 'exec >$1; shift; exec "$@"','x',
2993 "../$sourcechanges",
2994 @dpkggenchanges, qw(-S), changesopts();
2998 sub cmd_build_source {
2999 badusage "build-source takes no additional arguments" if @ARGV;
3001 printdone "source built, results in $dscfn and $sourcechanges";
3007 my $pat = "${package}_".(stripepoch $version)."_*.changes";
3009 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3010 stat_exists $sourcechanges
3011 or fail "$sourcechanges (in parent directory): $!";
3012 foreach my $cf (glob $pat) {
3013 next if $cf eq $sourcechanges;
3014 unlink $cf or fail "remove $cf: $!";
3017 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
3018 my @changesfiles = glob $pat;
3019 @changesfiles = sort {
3020 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3023 fail "wrong number of different changes files (@changesfiles)"
3024 unless @changesfiles;
3025 runcmd_ordryrun_local @mergechanges, @changesfiles;
3026 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
3028 stat_exists $multichanges or fail "$multichanges: $!";
3030 printdone "build successful, results in $multichanges\n" or die $!;
3033 sub cmd_quilt_fixup {
3034 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3035 my $clogp = parsechangelog();
3036 $version = getfield $clogp, 'Version';
3037 $package = getfield $clogp, 'Source';
3038 build_maybe_quilt_fixup();
3041 sub cmd_archive_api_query {
3042 badusage "need only 1 subpath argument" unless @ARGV==1;
3043 my ($subpath) = @ARGV;
3044 my @cmd = archive_api_query_cmd($subpath);
3046 exec @cmd or fail "exec curl: $!\n";
3049 sub cmd_clone_dgit_repos_server {
3050 badusage "need destination argument" unless @ARGV==1;
3051 my ($destdir) = @ARGV;
3052 $package = '_dgit-repos-server';
3053 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3055 exec @cmd or fail "exec git clone: $!\n";
3058 sub cmd_setup_mergechangelogs {
3059 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3060 setup_mergechangelogs(1);
3063 sub cmd_setup_useremail {
3064 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3068 sub cmd_setup_new_tree {
3069 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3073 #---------- argument parsing and main program ----------
3076 print "dgit version $our_version\n" or die $!;
3083 if (defined $ENV{'DGIT_SSH'}) {
3084 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3085 } elsif (defined $ENV{'GIT_SSH'}) {
3086 @ssh = ($ENV{'GIT_SSH'});
3090 last unless $ARGV[0] =~ m/^-/;
3094 if (m/^--dry-run$/) {
3097 } elsif (m/^--damp-run$/) {
3100 } elsif (m/^--no-sign$/) {
3103 } elsif (m/^--help$/) {
3105 } elsif (m/^--version$/) {
3107 } elsif (m/^--new$/) {
3110 } elsif (m/^--since-version=([^_]+|_)$/) {
3112 $changes_since_version = $1;
3113 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3114 ($om = $opts_opt_map{$1}) &&
3118 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3119 !$opts_opt_cmdonly{$1} &&
3120 ($om = $opts_opt_map{$1})) {
3123 } elsif (m/^--existing-package=(.*)/s) {
3125 $existing_package = $1;
3126 } elsif (m/^--initiator-tempdir=(.*)/s) {
3127 $initiator_tempdir = $1;
3128 $initiator_tempdir =~ m#^/# or
3129 badusage "--initiator-tempdir must be used specify an".
3130 " absolute, not relative, directory."
3131 } elsif (m/^--distro=(.*)/s) {
3134 } elsif (m/^--build-products-dir=(.*)/s) {
3136 $buildproductsdir = $1;
3137 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3140 } elsif (m/^--clean=(.*)$/s) {
3141 badusage "unknown cleaning mode \`$1'";
3142 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3145 } elsif (m/^--quilt=(.*)$/s) {
3146 badusage "unknown quilt fixup mode \`$1'";
3147 } elsif (m/^--ignore-dirty$/s) {
3150 } elsif (m/^--no-quilt-fixup$/s) {
3152 $quilt_mode = 'nocheck';
3153 } elsif (m/^--no-rm-on-error$/s) {
3156 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3158 push @deliberatelies, $&;
3160 badusage "unknown long option \`$_'";
3167 } elsif (s/^-L/-/) {
3170 } elsif (s/^-h/-/) {
3172 } elsif (s/^-D/-/) {
3176 } elsif (s/^-N/-/) {
3179 } elsif (s/^-v([^_]+|_)$//s) {
3181 $changes_since_version = $1;
3184 push @changesopts, $_;
3186 } elsif (s/^-c(.*=.*)//s) {
3188 push @git, '-c', $1;
3189 } elsif (s/^-d(.+)//s) {
3192 } elsif (s/^-C(.+)//s) {
3195 if ($changesfile =~ s#^(.*)/##) {
3196 $buildproductsdir = $1;
3198 } elsif (s/^-k(.+)//s) {
3200 } elsif (m/^-[vdCk]$/) {
3202 "option \`$_' requires an argument (and no space before the argument)";
3203 } elsif (s/^-wn$//s) {
3205 $cleanmode = 'none';
3206 } elsif (s/^-wg$//s) {
3209 } elsif (s/^-wgf$//s) {
3211 $cleanmode = 'git-ff';
3212 } elsif (s/^-wd$//s) {
3214 $cleanmode = 'dpkg-source';
3215 } elsif (s/^-wdd$//s) {
3217 $cleanmode = 'dpkg-source-d';
3218 } elsif (s/^-wc$//s) {
3220 $cleanmode = 'check';
3222 badusage "unknown short option \`$_'";
3229 sub finalise_opts_opts () {
3230 foreach my $k (keys %opts_opt_map) {
3231 my $om = $opts_opt_map{$k};
3233 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3235 badcfg "cannot set command for $k"
3236 unless length $om->[0];
3240 foreach my $c (access_cfg_cfgs("opts-$k")) {
3241 my $vl = $gitcfg{$c};
3242 printdebug "CL $c ",
3243 ($vl ? join " ", map { shellquote } @$vl : ""),
3244 "\n" if $debuglevel >= 4;
3246 badcfg "cannot configure options for $k"
3247 if $opts_opt_cmdonly{$k};
3248 my $insertpos = $opts_cfg_insertpos{$k};
3249 @$om = ( @$om[0..$insertpos-1],
3251 @$om[$insertpos..$#$om] );
3256 if ($ENV{$fakeeditorenv}) {
3258 quilt_fixup_editor();
3264 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3265 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3266 if $dryrun_level == 1;
3268 print STDERR $helpmsg or die $!;
3271 my $cmd = shift @ARGV;
3274 if (!defined $quilt_mode) {
3275 local $access_forpush;
3276 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3277 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3279 $quilt_mode =~ m/^($quilt_modes_re)$/
3280 or badcfg "unknown quilt-mode \`$quilt_mode'";
3284 my $fn = ${*::}{"cmd_$cmd"};
3285 $fn or badusage "unknown operation $cmd";