3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
40 our $our_version = 'UNRELEASED'; ###substituted###
42 our @rpushprotovsn_support = qw(3 2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
60 our $cleanmode = 'dpkg-source';
61 our $changes_since_version;
63 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
64 our $we_are_responder;
65 our $initiator_tempdir;
67 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
69 our $suite_re = '[-+.0-9a-z]+';
72 our (@dget) = qw(dget);
73 our (@curl) = qw(curl -f);
74 our (@dput) = qw(dput);
75 our (@debsign) = qw(debsign);
77 our (@sbuild) = qw(sbuild -A);
79 our (@dgit) = qw(dgit);
80 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
81 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
82 our (@dpkggenchanges) = qw(dpkg-genchanges);
83 our (@mergechanges) = qw(mergechanges -f);
84 our (@changesopts) = ('');
86 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
89 'debsign' => \@debsign,
94 'dpkg-source' => \@dpkgsource,
95 'dpkg-buildpackage' => \@dpkgbuildpackage,
96 'dpkg-genchanges' => \@dpkggenchanges,
97 'ch' => \@changesopts,
98 'mergechanges' => \@mergechanges);
100 our %opts_opt_cmdonly = ('gpg' => 1);
106 our $supplementary_message = '';
110 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
113 our $remotename = 'dgit';
114 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
118 sub lbranch () { return "$branchprefix/$csuite"; }
119 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
120 sub lref () { return "refs/heads/".lbranch(); }
121 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
122 sub rrref () { return server_ref($csuite); }
124 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
134 return "${package}_".(stripepoch $vsn).$sfx
139 return srcfn($vsn,".dsc");
148 foreach my $f (@end) {
150 warn "$us: cleanup: $@" if length $@;
154 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
156 sub no_such_package () {
157 print STDERR "$us: package $package does not exist in suite $isuite\n";
163 return "+".rrref().":".lrref();
168 printdebug "CD $newdir\n";
169 chdir $newdir or die "chdir: $newdir: $!";
172 sub deliberately ($) {
174 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
177 sub deliberately_not_fast_forward () {
178 foreach (qw(not-fast-forward fresh-repo)) {
179 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
183 #---------- remote protocol support, common ----------
185 # remote push initiator/responder protocol:
186 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
187 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
188 # < dgit-remote-push-ready <actual-proto-vsn>
190 # > file parsed-changelog
191 # [indicates that output of dpkg-parsechangelog follows]
192 # > data-block NBYTES
193 # > [NBYTES bytes of data (no newline)]
194 # [maybe some more blocks]
206 # [indicates that signed tag is wanted]
207 # < data-block NBYTES
208 # < [NBYTES bytes of data (no newline)]
209 # [maybe some more blocks]
213 # > want signed-dsc-changes
214 # < data-block NBYTES [transfer of signed dsc]
216 # < data-block NBYTES [transfer of signed changes]
224 sub i_child_report () {
225 # Sees if our child has died, and reap it if so. Returns a string
226 # describing how it died if it failed, or undef otherwise.
227 return undef unless $i_child_pid;
228 my $got = waitpid $i_child_pid, WNOHANG;
229 return undef if $got <= 0;
230 die unless $got == $i_child_pid;
231 $i_child_pid = undef;
232 return undef unless $?;
233 return "build host child ".waitstatusmsg();
238 fail "connection lost: $!" if $fh->error;
239 fail "protocol violation; $m not expected";
242 sub badproto_badread ($$) {
244 fail "connection lost: $!" if $!;
245 my $report = i_child_report();
246 fail $report if defined $report;
247 badproto $fh, "eof (reading $wh)";
250 sub protocol_expect (&$) {
251 my ($match, $fh) = @_;
254 defined && chomp or badproto_badread $fh, "protocol message";
262 badproto $fh, "\`$_'";
265 sub protocol_send_file ($$) {
266 my ($fh, $ourfn) = @_;
267 open PF, "<", $ourfn or die "$ourfn: $!";
270 my $got = read PF, $d, 65536;
271 die "$ourfn: $!" unless defined $got;
273 print $fh "data-block ".length($d)."\n" or die $!;
274 print $fh $d or die $!;
276 PF->error and die "$ourfn $!";
277 print $fh "data-end\n" or die $!;
281 sub protocol_read_bytes ($$) {
282 my ($fh, $nbytes) = @_;
283 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
285 my $got = read $fh, $d, $nbytes;
286 $got==$nbytes or badproto_badread $fh, "data block";
290 sub protocol_receive_file ($$) {
291 my ($fh, $ourfn) = @_;
292 printdebug "() $ourfn\n";
293 open PF, ">", $ourfn or die "$ourfn: $!";
295 my ($y,$l) = protocol_expect {
296 m/^data-block (.*)$/ ? (1,$1) :
297 m/^data-end$/ ? (0,) :
301 my $d = protocol_read_bytes $fh, $l;
302 print PF $d or die $!;
307 #---------- remote protocol support, responder ----------
309 sub responder_send_command ($) {
311 return unless $we_are_responder;
312 # called even without $we_are_responder
313 printdebug ">> $command\n";
314 print PO $command, "\n" or die $!;
317 sub responder_send_file ($$) {
318 my ($keyword, $ourfn) = @_;
319 return unless $we_are_responder;
320 printdebug "]] $keyword $ourfn\n";
321 responder_send_command "file $keyword";
322 protocol_send_file \*PO, $ourfn;
325 sub responder_receive_files ($@) {
326 my ($keyword, @ourfns) = @_;
327 die unless $we_are_responder;
328 printdebug "[[ $keyword @ourfns\n";
329 responder_send_command "want $keyword";
330 foreach my $fn (@ourfns) {
331 protocol_receive_file \*PI, $fn;
334 protocol_expect { m/^files-end$/ } \*PI;
337 #---------- remote protocol support, initiator ----------
339 sub initiator_expect (&) {
341 protocol_expect { &$match } \*RO;
344 #---------- end remote code ----------
347 if ($we_are_responder) {
349 responder_send_command "progress ".length($m) or die $!;
350 print PO $m or die $!;
360 $ua = LWP::UserAgent->new();
364 progress "downloading $what...";
365 my $r = $ua->get(@_) or die $!;
366 return undef if $r->code == 404;
367 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
368 return $r->decoded_content(charset => 'none');
371 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
376 failedcmd @_ if system @_;
379 sub act_local () { return $dryrun_level <= 1; }
380 sub act_scary () { return !$dryrun_level; }
383 if (!$dryrun_level) {
384 progress "dgit ok: @_";
386 progress "would be ok: @_ (but dry run only)";
391 printcmd(\*STDERR,$debugprefix."#",@_);
394 sub runcmd_ordryrun {
402 sub runcmd_ordryrun_local {
411 my ($first_shell, @cmd) = @_;
412 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
415 our $helpmsg = <<END;
417 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
418 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
419 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
420 dgit [dgit-opts] push [dgit-opts] [suite]
421 dgit [dgit-opts] rpush build-host:build-dir ...
422 important dgit options:
423 -k<keyid> sign tag and package with <keyid> instead of default
424 --dry-run -n do not change anything, but go through the motions
425 --damp-run -L like --dry-run but make local changes, without signing
426 --new -N allow introducing a new package
427 --debug -D increase debug level
428 -c<name>=<value> set git config option (used directly by dgit too)
431 our $later_warning_msg = <<END;
432 Perhaps the upload is stuck in incoming. Using the version from git.
436 print STDERR "$us: @_\n", $helpmsg or die $!;
441 @ARGV or badusage "too few arguments";
442 return scalar shift @ARGV;
446 print $helpmsg or die $!;
450 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
452 our %defcfg = ('dgit.default.distro' => 'debian',
453 'dgit.default.username' => '',
454 'dgit.default.archive-query-default-component' => 'main',
455 'dgit.default.ssh' => 'ssh',
456 'dgit.default.archive-query' => 'madison:',
457 'dgit.default.sshpsql-dbname' => 'service=projectb',
458 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
459 'dgit-distro.debian.git-check' => 'url',
460 'dgit-distro.debian.git-check-suffix' => '/info/refs',
461 'dgit-distro.debian.new-private-pushers' => 't',
462 'dgit-distro.debian/push.git-url' => '',
463 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
464 'dgit-distro.debian/push.git-user-force' => 'dgit',
465 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
466 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
467 'dgit-distro.debian/push.git-create' => 'true',
468 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
469 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
470 # 'dgit-distro.debian.archive-query-tls-key',
471 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
472 # ^ this does not work because curl is broken nowadays
473 # Fixing #790093 properly will involve providing providing the key
474 # in some pacagke and maybe updating these paths.
476 # 'dgit-distro.debian.archive-query-tls-curl-args',
477 # '--ca-path=/etc/ssl/ca-debian',
478 # ^ this is a workaround but works (only) on DSA-administered machines
479 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
480 'dgit-distro.debian.git-url-suffix' => '',
481 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
482 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
483 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
484 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
485 'dgit-distro.ubuntu.git-check' => 'false',
486 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
487 'dgit-distro.test-dummy.ssh' => "$td/ssh",
488 'dgit-distro.test-dummy.username' => "alice",
489 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
490 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
491 'dgit-distro.test-dummy.git-url' => "$td/git",
492 'dgit-distro.test-dummy.git-host' => "git",
493 'dgit-distro.test-dummy.git-path' => "$td/git",
494 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
495 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
496 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
497 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
500 sub git_get_config ($) {
503 our %git_get_config_memo;
504 if (exists $git_get_config_memo{$c}) {
505 return $git_get_config_memo{$c};
509 my @cmd = (@git, qw(config --), $c);
511 local ($debuglevel) = $debuglevel-2;
512 $v = cmdoutput_errok @cmd;
520 $git_get_config_memo{$c} = $v;
526 return undef if $c =~ /RETURN-UNDEF/;
527 my $v = git_get_config($c);
528 return $v if defined $v;
529 my $dv = $defcfg{$c};
530 return $dv if defined $dv;
532 badcfg "need value for one of: @_\n".
533 "$us: distro or suite appears not to be (properly) supported";
536 sub access_basedistro () {
537 if (defined $idistro) {
540 return cfg("dgit-suite.$isuite.distro",
541 "dgit.default.distro");
545 sub access_quirk () {
546 # returns (quirk name, distro to use instead or undef, quirk-specific info)
547 my $basedistro = access_basedistro();
548 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
550 if (defined $backports_quirk) {
551 my $re = $backports_quirk;
552 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
554 $re =~ s/\%/([-0-9a-z_]+)/
555 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
556 if ($isuite =~ m/^$re$/) {
557 return ('backports',"$basedistro-backports",$1);
560 return ('none',undef);
565 sub parse_cfg_bool ($$$) {
566 my ($what,$def,$v) = @_;
569 $v =~ m/^[ty1]/ ? 1 :
570 $v =~ m/^[fn0]/ ? 0 :
571 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
574 sub access_forpush_config () {
575 my $d = access_basedistro();
579 parse_cfg_bool('new-private-pushers', 0,
580 cfg("dgit-distro.$d.new-private-pushers",
583 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
586 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
587 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
588 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
589 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
592 sub access_forpush () {
593 $access_forpush //= access_forpush_config();
594 return $access_forpush;
598 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
599 badcfg "pushing but distro is configured readonly"
600 if access_forpush_config() eq '0';
602 $supplementary_message = <<'END' unless $we_are_responder;
603 Push failed, before we got started.
604 You can retry the push, after fixing the problem, if you like.
608 sub supplementary_message ($) {
610 if (!$we_are_responder) {
611 $supplementary_message = $msg;
613 } elsif ($protovsn >= 3) {
614 responder_send_command "supplementary-message ".length($msg)
616 print PO $msg or die $!;
620 sub access_distros () {
621 # Returns list of distros to try, in order
624 # 0. `instead of' distro name(s) we have been pointed to
625 # 1. the access_quirk distro, if any
626 # 2a. the user's specified distro, or failing that } basedistro
627 # 2b. the distro calculated from the suite }
628 my @l = access_basedistro();
630 my (undef,$quirkdistro) = access_quirk();
631 unshift @l, $quirkdistro;
632 unshift @l, $instead_distro;
633 @l = grep { defined } @l;
635 if (access_forpush()) {
636 @l = map { ("$_/push", $_) } @l;
644 # The nesting of these loops determines the search order. We put
645 # the key loop on the outside so that we search all the distros
646 # for each key, before going on to the next key. That means that
647 # if access_cfg is called with a more specific, and then a less
648 # specific, key, an earlier distro can override the less specific
649 # without necessarily overriding any more specific keys. (If the
650 # distro wants to override the more specific keys it can simply do
651 # so; whereas if we did the loop the other way around, it would be
652 # impossible to for an earlier distro to override a less specific
653 # key but not the more specific ones without restating the unknown
654 # values of the more specific keys.
657 # We have to deal with RETURN-UNDEF specially, so that we don't
658 # terminate the search prematurely.
660 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
663 foreach my $d (access_distros()) {
664 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
666 push @cfgs, map { "dgit.default.$_" } @realkeys;
668 my $value = cfg(@cfgs);
672 sub string_to_ssh ($) {
674 if ($spec =~ m/\s/) {
675 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
681 sub access_cfg_ssh () {
682 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
683 if (!defined $gitssh) {
686 return string_to_ssh $gitssh;
690 sub access_runeinfo ($) {
692 return ": dgit ".access_basedistro()." $info ;";
695 sub access_someuserhost ($) {
697 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
698 defined($user) && length($user) or
699 $user = access_cfg("$some-user",'username');
700 my $host = access_cfg("$some-host");
701 return length($user) ? "$user\@$host" : $host;
704 sub access_gituserhost () {
705 return access_someuserhost('git');
708 sub access_giturl (;$) {
710 my $url = access_cfg('git-url','RETURN-UNDEF');
713 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
714 return undef unless defined $proto;
717 access_gituserhost().
718 access_cfg('git-path');
720 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
723 return "$url/$package$suffix";
726 sub parsecontrolfh ($$;$) {
727 my ($fh, $desc, $allowsigned) = @_;
728 our $dpkgcontrolhash_noissigned;
731 my %opts = ('name' => $desc);
732 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
733 $c = Dpkg::Control::Hash->new(%opts);
734 $c->parse($fh,$desc) or die "parsing of $desc failed";
735 last if $allowsigned;
736 last if $dpkgcontrolhash_noissigned;
737 my $issigned= $c->get_option('is_pgp_signed');
738 if (!defined $issigned) {
739 $dpkgcontrolhash_noissigned= 1;
740 seek $fh, 0,0 or die "seek $desc: $!";
741 } elsif ($issigned) {
742 fail "control file $desc is (already) PGP-signed. ".
743 " Note that dgit push needs to modify the .dsc and then".
744 " do the signature itself";
753 my ($file, $desc) = @_;
754 my $fh = new IO::Handle;
755 open $fh, '<', $file or die "$file: $!";
756 my $c = parsecontrolfh($fh,$desc);
757 $fh->error and die $!;
763 my ($dctrl,$field) = @_;
764 my $v = $dctrl->{$field};
765 return $v if defined $v;
766 fail "missing field $field in ".$v->get_option('name');
770 my $c = Dpkg::Control::Hash->new();
771 my $p = new IO::Handle;
772 my @cmd = (qw(dpkg-parsechangelog), @_);
773 open $p, '-|', @cmd or die $!;
775 $?=0; $!=0; close $p or failedcmd @cmd;
781 defined $d or fail "getcwd failed: $!";
787 sub archive_query ($) {
789 my $query = access_cfg('archive-query','RETURN-UNDEF');
790 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
793 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
796 sub pool_dsc_subpath ($$) {
797 my ($vsn,$component) = @_; # $package is implict arg
798 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
799 return "/pool/$component/$prefix/$package/".dscfn($vsn);
802 #---------- `ftpmasterapi' archive query method (nascent) ----------
804 sub archive_api_query_cmd ($) {
806 my @cmd = qw(curl -sS);
807 my $url = access_cfg('archive-query-url');
808 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
810 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
811 foreach my $key (split /\:/, $keys) {
812 $key =~ s/\%HOST\%/$host/g;
814 fail "for $url: stat $key: $!" unless $!==ENOENT;
817 fail "config requested specific TLS key but do not know".
818 " how to get curl to use exactly that EE key ($key)";
819 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
820 # # Sadly the above line does not work because of changes
821 # # to gnutls. The real fix for #790093 may involve
822 # # new curl options.
825 # Fixing #790093 properly will involve providing a value
826 # for this on clients.
827 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
828 push @cmd, split / /, $kargs if defined $kargs;
830 push @cmd, $url.$subpath;
836 my ($data, $subpath) = @_;
837 badcfg "ftpmasterapi archive query method takes no data part"
839 my @cmd = archive_api_query_cmd($subpath);
840 my $json = cmdoutput @cmd;
841 return decode_json($json);
844 sub canonicalise_suite_ftpmasterapi () {
845 my ($proto,$data) = @_;
846 my $suites = api_query($data, 'suites');
848 foreach my $entry (@$suites) {
850 my $v = $entry->{$_};
851 defined $v && $v eq $isuite;
853 push @matched, $entry;
855 fail "unknown suite $isuite" unless @matched;
858 @matched==1 or die "multiple matches for suite $isuite\n";
859 $cn = "$matched[0]{codename}";
860 defined $cn or die "suite $isuite info has no codename\n";
861 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
863 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
868 sub archive_query_ftpmasterapi () {
869 my ($proto,$data) = @_;
870 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
872 my $digester = Digest::SHA->new(256);
873 foreach my $entry (@$info) {
875 my $vsn = "$entry->{version}";
876 my ($ok,$msg) = version_check $vsn;
877 die "bad version: $msg\n" unless $ok;
878 my $component = "$entry->{component}";
879 $component =~ m/^$component_re$/ or die "bad component";
880 my $filename = "$entry->{filename}";
881 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
882 or die "bad filename";
883 my $sha256sum = "$entry->{sha256sum}";
884 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
885 push @rows, [ $vsn, "/pool/$component/$filename",
886 $digester, $sha256sum ];
888 die "bad ftpmaster api response: $@\n".Dumper($entry)
891 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
895 #---------- `madison' archive query method ----------
897 sub archive_query_madison {
898 return map { [ @$_[0..1] ] } madison_get_parse(@_);
901 sub madison_get_parse {
902 my ($proto,$data) = @_;
903 die unless $proto eq 'madison';
905 $data= access_cfg('madison-distro','RETURN-UNDEF');
906 $data //= access_basedistro();
908 $rmad{$proto,$data,$package} ||= cmdoutput
909 qw(rmadison -asource),"-s$isuite","-u$data",$package;
910 my $rmad = $rmad{$proto,$data,$package};
913 foreach my $l (split /\n/, $rmad) {
914 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
915 \s*( [^ \t|]+ )\s* \|
916 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
917 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
918 $1 eq $package or die "$rmad $package ?";
925 $component = access_cfg('archive-query-default-component');
927 $5 eq 'source' or die "$rmad ?";
928 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
930 return sort { -version_compare($a->[0],$b->[0]); } @out;
933 sub canonicalise_suite_madison {
934 # madison canonicalises for us
935 my @r = madison_get_parse(@_);
937 "unable to canonicalise suite using package $package".
938 " which does not appear to exist in suite $isuite;".
939 " --existing-package may help";
943 #---------- `sshpsql' archive query method ----------
946 my ($data,$runeinfo,$sql) = @_;
948 $data= access_someuserhost('sshpsql').':'.
949 access_cfg('sshpsql-dbname');
951 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
952 my ($userhost,$dbname) = ($`,$'); #';
954 my @cmd = (access_cfg_ssh, $userhost,
955 access_runeinfo("ssh-psql $runeinfo").
956 " export LC_MESSAGES=C; export LC_CTYPE=C;".
957 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
959 open P, "-|", @cmd or die $!;
962 printdebug("$debugprefix>|$_|\n");
965 $!=0; $?=0; close P or failedcmd @cmd;
967 my $nrows = pop @rows;
968 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
969 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
970 @rows = map { [ split /\|/, $_ ] } @rows;
971 my $ncols = scalar @{ shift @rows };
972 die if grep { scalar @$_ != $ncols } @rows;
976 sub sql_injection_check {
977 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
980 sub archive_query_sshpsql ($$) {
981 my ($proto,$data) = @_;
982 sql_injection_check $isuite, $package;
983 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
984 SELECT source.version, component.name, files.filename, files.sha256sum
986 JOIN src_associations ON source.id = src_associations.source
987 JOIN suite ON suite.id = src_associations.suite
988 JOIN dsc_files ON dsc_files.source = source.id
989 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
990 JOIN component ON component.id = files_archive_map.component_id
991 JOIN files ON files.id = dsc_files.file
992 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
993 AND source.source='$package'
994 AND files.filename LIKE '%.dsc';
996 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
997 my $digester = Digest::SHA->new(256);
999 my ($vsn,$component,$filename,$sha256sum) = @$_;
1000 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1005 sub canonicalise_suite_sshpsql ($$) {
1006 my ($proto,$data) = @_;
1007 sql_injection_check $isuite;
1008 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1009 SELECT suite.codename
1010 FROM suite where suite_name='$isuite' or codename='$isuite';
1012 @rows = map { $_->[0] } @rows;
1013 fail "unknown suite $isuite" unless @rows;
1014 die "ambiguous $isuite: @rows ?" if @rows>1;
1018 #---------- `dummycat' archive query method ----------
1020 sub canonicalise_suite_dummycat ($$) {
1021 my ($proto,$data) = @_;
1022 my $dpath = "$data/suite.$isuite";
1023 if (!open C, "<", $dpath) {
1024 $!==ENOENT or die "$dpath: $!";
1025 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1029 chomp or die "$dpath: $!";
1031 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1035 sub archive_query_dummycat ($$) {
1036 my ($proto,$data) = @_;
1037 canonicalise_suite();
1038 my $dpath = "$data/package.$csuite.$package";
1039 if (!open C, "<", $dpath) {
1040 $!==ENOENT or die "$dpath: $!";
1041 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1049 printdebug "dummycat query $csuite $package $dpath | $_\n";
1050 my @row = split /\s+/, $_;
1051 @row==2 or die "$dpath: $_ ?";
1054 C->error and die "$dpath: $!";
1056 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1059 #---------- archive query entrypoints and rest of program ----------
1061 sub canonicalise_suite () {
1062 return if defined $csuite;
1063 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1064 $csuite = archive_query('canonicalise_suite');
1065 if ($isuite ne $csuite) {
1066 progress "canonical suite name for $isuite is $csuite";
1070 sub get_archive_dsc () {
1071 canonicalise_suite();
1072 my @vsns = archive_query('archive_query');
1073 foreach my $vinfo (@vsns) {
1074 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1075 $dscurl = access_cfg('mirror').$subpath;
1076 $dscdata = url_get($dscurl);
1078 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1083 $digester->add($dscdata);
1084 my $got = $digester->hexdigest();
1086 fail "$dscurl has hash $got but".
1087 " archive told us to expect $digest";
1089 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1090 printdebug Dumper($dscdata) if $debuglevel>1;
1091 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1092 printdebug Dumper($dsc) if $debuglevel>1;
1093 my $fmt = getfield $dsc, 'Format';
1094 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1095 $dsc_checked = !!$digester;
1101 sub check_for_git ();
1102 sub check_for_git () {
1104 my $how = access_cfg('git-check');
1105 if ($how eq 'ssh-cmd') {
1107 (access_cfg_ssh, access_gituserhost(),
1108 access_runeinfo("git-check $package").
1109 " set -e; cd ".access_cfg('git-path').";".
1110 " if test -d $package.git; then echo 1; else echo 0; fi");
1111 my $r= cmdoutput @cmd;
1112 if ($r =~ m/^divert (\w+)$/) {
1114 my ($usedistro,) = access_distros();
1115 # NB that if we are pushing, $usedistro will be $distro/push
1116 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1117 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1118 progress "diverting to $divert (using config for $instead_distro)";
1119 return check_for_git();
1121 failedcmd @cmd unless $r =~ m/^[01]$/;
1123 } elsif ($how eq 'url') {
1124 my $prefix = access_cfg('git-check-url','git-url');
1125 my $suffix = access_cfg('git-check-suffix','git-suffix',
1126 'RETURN-UNDEF') // '.git';
1127 my $url = "$prefix/$package$suffix";
1128 my @cmd = (qw(curl -sS -I), $url);
1129 my $result = cmdoutput @cmd;
1130 $result =~ m/^\S+ (404|200) /s or
1131 fail "unexpected results from git check query - ".
1132 Dumper($prefix, $result);
1134 if ($code eq '404') {
1136 } elsif ($code eq '200') {
1141 } elsif ($how eq 'true') {
1143 } elsif ($how eq 'false') {
1146 badcfg "unknown git-check \`$how'";
1150 sub create_remote_git_repo () {
1151 my $how = access_cfg('git-create');
1152 if ($how eq 'ssh-cmd') {
1154 (access_cfg_ssh, access_gituserhost(),
1155 access_runeinfo("git-create $package").
1156 "set -e; cd ".access_cfg('git-path').";".
1157 " cp -a _template $package.git");
1158 } elsif ($how eq 'true') {
1161 badcfg "unknown git-create \`$how'";
1165 our ($dsc_hash,$lastpush_hash);
1167 our $ud = '.git/dgit/unpack';
1172 mkdir $ud or die $!;
1175 sub mktree_in_ud_here () {
1176 runcmd qw(git init -q);
1177 rmtree('.git/objects');
1178 symlink '../../../../objects','.git/objects' or die $!;
1181 sub git_write_tree () {
1182 my $tree = cmdoutput @git, qw(write-tree);
1183 $tree =~ m/^\w+$/ or die "$tree ?";
1187 sub mktree_in_ud_from_only_subdir () {
1188 # changes into the subdir
1190 die unless @dirs==1;
1191 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1195 my @gitscmd = qw(find -name .git -prune -print0);
1196 debugcmd "|",@gitscmd;
1197 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1202 print STDERR "$us: warning: removing from source package: ",
1203 (messagequote $_), "\n";
1207 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1209 mktree_in_ud_here();
1210 my $format=get_source_format();
1211 if (madformat($format)) {
1214 runcmd @git, qw(add -Af);
1215 my $tree=git_write_tree();
1216 return ($tree,$dir);
1219 sub dsc_files_info () {
1220 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1221 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1222 ['Files', 'Digest::MD5', 'new()']) {
1223 my ($fname, $module, $method) = @$csumi;
1224 my $field = $dsc->{$fname};
1225 next unless defined $field;
1226 eval "use $module; 1;" or die $@;
1228 foreach (split /\n/, $field) {
1230 m/^(\w+) (\d+) (\S+)$/ or
1231 fail "could not parse .dsc $fname line \`$_'";
1232 my $digester = eval "$module"."->$method;" or die $@;
1237 Digester => $digester,
1242 fail "missing any supported Checksums-* or Files field in ".
1243 $dsc->get_option('name');
1247 map { $_->{Filename} } dsc_files_info();
1250 sub is_orig_file ($;$) {
1253 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1254 defined $base or return 1;
1258 sub make_commit ($) {
1260 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1263 sub clogp_authline ($) {
1265 my $author = getfield $clogp, 'Maintainer';
1266 $author =~ s#,.*##ms;
1267 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1268 my $authline = "$author $date";
1269 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1270 fail "unexpected commit author line format \`$authline'".
1271 " (was generated from changelog Maintainer field)";
1275 sub vendor_patches_distro ($$) {
1276 my ($checkdistro, $what) = @_;
1277 return unless defined $checkdistro;
1279 my $series = "debian/patches/\L$checkdistro\E.series";
1280 printdebug "checking for vendor-specific $series ($what)\n";
1282 if (!open SERIES, "<", $series) {
1283 die "$series $!" unless $!==ENOENT;
1292 Unfortunately, this source package uses a feature of dpkg-source where
1293 the same source package unpacks to different source code on different
1294 distros. dgit cannot safely operate on such packages on affected
1295 distros, because the meaning of source packages is not stable.
1297 Please ask the distro/maintainer to remove the distro-specific series
1298 files and use a different technique (if necessary, uploading actually
1299 different packages, if different distros are supposed to have
1303 fail "Found active distro-specific series file for".
1304 " $checkdistro ($what): $series, cannot continue";
1306 die "$series $!" if SERIES->error;
1310 sub check_for_vendor_patches () {
1311 # This dpkg-source feature doesn't seem to be documented anywhere!
1312 # But it can be found in the changelog (reformatted):
1314 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1315 # Author: Raphael Hertzog <hertzog@debian.org>
1316 # Date: Sun Oct 3 09:36:48 2010 +0200
1318 # dpkg-source: correctly create .pc/.quilt_series with alternate
1321 # If you have debian/patches/ubuntu.series and you were
1322 # unpacking the source package on ubuntu, quilt was still
1323 # directed to debian/patches/series instead of
1324 # debian/patches/ubuntu.series.
1326 # debian/changelog | 3 +++
1327 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1328 # 2 files changed, 6 insertions(+), 1 deletion(-)
1331 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1332 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1333 "Dpkg::Vendor \`current vendor'");
1334 vendor_patches_distro(access_basedistro(),
1335 "distro being accessed");
1338 sub generate_commit_from_dsc () {
1342 foreach my $fi (dsc_files_info()) {
1343 my $f = $fi->{Filename};
1344 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1346 link "../../../$f", $f
1350 complete_file_from_dsc('.', $fi);
1352 if (is_orig_file($f)) {
1353 link $f, "../../../../$f"
1359 my $dscfn = "$package.dsc";
1361 open D, ">", $dscfn or die "$dscfn: $!";
1362 print D $dscdata or die "$dscfn: $!";
1363 close D or die "$dscfn: $!";
1364 my @cmd = qw(dpkg-source);
1365 push @cmd, '--no-check' if $dsc_checked;
1366 push @cmd, qw(-x --), $dscfn;
1369 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1370 check_for_vendor_patches() if madformat($dsc->{format});
1371 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1372 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1373 my $authline = clogp_authline $clogp;
1374 my $changes = getfield $clogp, 'Changes';
1375 open C, ">../commit.tmp" or die $!;
1376 print C <<END or die $!;
1383 # imported from the archive
1386 my $outputhash = make_commit qw(../commit.tmp);
1387 my $cversion = getfield $clogp, 'Version';
1388 progress "synthesised git commit from .dsc $cversion";
1389 if ($lastpush_hash) {
1390 runcmd @git, qw(reset --hard), $lastpush_hash;
1391 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1392 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1393 my $oversion = getfield $oldclogp, 'Version';
1395 version_compare($oversion, $cversion);
1397 # git upload/ is earlier vsn than archive, use archive
1398 open C, ">../commit2.tmp" or die $!;
1399 print C <<END or die $!;
1401 parent $lastpush_hash
1406 Record $package ($cversion) in archive suite $csuite
1408 $outputhash = make_commit qw(../commit2.tmp);
1409 } elsif ($vcmp > 0) {
1410 print STDERR <<END or die $!;
1412 Version actually in archive: $cversion (older)
1413 Last allegedly pushed/uploaded: $oversion (newer or same)
1416 $outputhash = $lastpush_hash;
1418 $outputhash = $lastpush_hash;
1421 changedir '../../../..';
1422 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1423 'DGIT_ARCHIVE', $outputhash;
1424 cmdoutput @git, qw(log -n2), $outputhash;
1425 # ... gives git a chance to complain if our commit is malformed
1430 sub complete_file_from_dsc ($$) {
1431 our ($dstdir, $fi) = @_;
1432 # Ensures that we have, in $dir, the file $fi, with the correct
1433 # contents. (Downloading it from alongside $dscurl if necessary.)
1435 my $f = $fi->{Filename};
1436 my $tf = "$dstdir/$f";
1439 if (stat_exists $tf) {
1440 progress "using existing $f";
1443 $furl =~ s{/[^/]+$}{};
1445 die "$f ?" unless $f =~ m/^${package}_/;
1446 die "$f ?" if $f =~ m#/#;
1447 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1448 next if !act_local();
1452 open F, "<", "$tf" or die "$tf: $!";
1453 $fi->{Digester}->reset();
1454 $fi->{Digester}->addfile(*F);
1455 F->error and die $!;
1456 my $got = $fi->{Digester}->hexdigest();
1457 $got eq $fi->{Hash} or
1458 fail "file $f has hash $got but .dsc".
1459 " demands hash $fi->{Hash} ".
1460 ($downloaded ? "(got wrong file from archive!)"
1461 : "(perhaps you should delete this file?)");
1464 sub ensure_we_have_orig () {
1465 foreach my $fi (dsc_files_info()) {
1466 my $f = $fi->{Filename};
1467 next unless is_orig_file($f);
1468 complete_file_from_dsc('..', $fi);
1472 sub git_fetch_us () {
1473 my @specs = (fetchspec());
1475 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1477 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1480 my $tagpat = debiantag('*',access_basedistro);
1482 git_for_each_ref("refs/tags/".$tagpat, sub {
1483 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1484 printdebug "currently $fullrefname=$objid\n";
1485 $here{$fullrefname} = $objid;
1487 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1488 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1489 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1490 printdebug "offered $lref=$objid\n";
1491 if (!defined $here{$lref}) {
1492 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1493 runcmd_ordryrun_local @upd;
1494 } elsif ($here{$lref} eq $objid) {
1497 "Not updateting $lref from $here{$lref} to $objid.\n";
1502 sub fetch_from_archive () {
1503 # ensures that lrref() is what is actually in the archive,
1504 # one way or another
1508 foreach my $field (@ourdscfield) {
1509 $dsc_hash = $dsc->{$field};
1510 last if defined $dsc_hash;
1512 if (defined $dsc_hash) {
1513 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1515 progress "last upload to archive specified git hash";
1517 progress "last upload to archive has NO git hash";
1520 progress "no version available from the archive";
1523 $lastpush_hash = git_get_ref(lrref());
1524 printdebug "previous reference hash=$lastpush_hash\n";
1526 if (defined $dsc_hash) {
1527 fail "missing remote git history even though dsc has hash -".
1528 " could not find ref ".lrref().
1529 " (should have been fetched from ".access_giturl()."#".rrref().")"
1530 unless $lastpush_hash;
1532 ensure_we_have_orig();
1533 if ($dsc_hash eq $lastpush_hash) {
1534 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1535 print STDERR <<END or die $!;
1537 Git commit in archive is behind the last version allegedly pushed/uploaded.
1538 Commit referred to by archive: $dsc_hash
1539 Last allegedly pushed/uploaded: $lastpush_hash
1542 $hash = $lastpush_hash;
1544 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1545 "descendant of archive's .dsc hash ($dsc_hash)";
1548 $hash = generate_commit_from_dsc();
1549 } elsif ($lastpush_hash) {
1550 # only in git, not in the archive yet
1551 $hash = $lastpush_hash;
1552 print STDERR <<END or die $!;
1554 Package not found in the archive, but has allegedly been pushed using dgit.
1558 printdebug "nothing found!\n";
1559 if (defined $skew_warning_vsn) {
1560 print STDERR <<END or die $!;
1562 Warning: relevant archive skew detected.
1563 Archive allegedly contains $skew_warning_vsn
1564 But we were not able to obtain any version from the archive or git.
1570 printdebug "current hash=$hash\n";
1571 if ($lastpush_hash) {
1572 fail "not fast forward on last upload branch!".
1573 " (archive's version left in DGIT_ARCHIVE)"
1574 unless is_fast_fwd($lastpush_hash, $hash);
1576 if (defined $skew_warning_vsn) {
1578 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1579 my $clogf = ".git/dgit/changelog.tmp";
1580 runcmd shell_cmd "exec >$clogf",
1581 @git, qw(cat-file blob), "$hash:debian/changelog";
1582 my $gotclogp = parsechangelog("-l$clogf");
1583 my $got_vsn = getfield $gotclogp, 'Version';
1584 printdebug "SKEW CHECK GOT $got_vsn\n";
1585 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1586 print STDERR <<END or die $!;
1588 Warning: archive skew detected. Using the available version:
1589 Archive allegedly contains $skew_warning_vsn
1590 We were able to obtain only $got_vsn
1595 if ($lastpush_hash ne $hash) {
1596 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1600 dryrun_report @upd_cmd;
1606 sub set_local_git_config ($$) {
1608 runcmd @git, qw(config), $k, $v;
1611 sub setup_mergechangelogs () {
1612 my $driver = 'dpkg-mergechangelogs';
1613 my $cb = "merge.$driver";
1614 my $attrs = '.git/info/attributes';
1615 ensuredir '.git/info';
1617 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1618 if (!open ATTRS, "<", $attrs) {
1619 $!==ENOENT or die "$attrs: $!";
1623 next if m{^debian/changelog\s};
1624 print NATTRS $_, "\n" or die $!;
1626 ATTRS->error and die $!;
1629 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1632 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1633 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1635 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1640 canonicalise_suite();
1641 badusage "dry run makes no sense with clone" unless act_local();
1642 my $hasgit = check_for_git();
1643 mkdir $dstdir or die "$dstdir $!";
1645 runcmd @git, qw(init -q);
1646 my $giturl = access_giturl(1);
1647 if (defined $giturl) {
1648 set_local_git_config "remote.$remotename.fetch", fetchspec();
1649 open H, "> .git/HEAD" or die $!;
1650 print H "ref: ".lref()."\n" or die $!;
1652 runcmd @git, qw(remote add), 'origin', $giturl;
1655 progress "fetching existing git history";
1657 runcmd_ordryrun_local @git, qw(fetch origin);
1659 progress "starting new git history";
1661 fetch_from_archive() or no_such_package;
1662 my $vcsgiturl = $dsc->{'Vcs-Git'};
1663 if (length $vcsgiturl) {
1664 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1665 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1667 setup_mergechangelogs();
1668 runcmd @git, qw(reset --hard), lrref();
1669 printdone "ready for work in $dstdir";
1673 if (check_for_git()) {
1676 fetch_from_archive() or no_such_package();
1677 printdone "fetched into ".lrref();
1682 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1684 printdone "fetched to ".lrref()." and merged into HEAD";
1687 sub check_not_dirty () {
1688 return if $ignoredirty;
1689 my @cmd = (@git, qw(diff --quiet HEAD));
1691 $!=0; $?=0; system @cmd;
1692 return if !$! && !$?;
1693 if (!$! && $?==256) {
1694 fail "working tree is dirty (does not match HEAD)";
1700 sub commit_admin ($) {
1703 runcmd_ordryrun_local @git, qw(commit -m), $m;
1706 sub commit_quilty_patch () {
1707 my $output = cmdoutput @git, qw(status --porcelain);
1709 foreach my $l (split /\n/, $output) {
1710 next unless $l =~ m/\S/;
1711 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1715 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1717 progress "nothing quilty to commit, ok.";
1720 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1721 commit_admin "Commit Debian 3.0 (quilt) metadata";
1724 sub get_source_format () {
1725 if (!open F, "debian/source/format") {
1726 die $! unless $!==&ENOENT;
1730 F->error and die $!;
1737 return 0 unless $format eq '3.0 (quilt)';
1738 if ($quilt_mode eq 'nocheck') {
1739 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1742 progress "Format \`$format', checking/updating patch stack";
1746 sub push_parse_changelog ($) {
1749 my $clogp = Dpkg::Control::Hash->new();
1750 $clogp->load($clogpfn) or die;
1752 $package = getfield $clogp, 'Source';
1753 my $cversion = getfield $clogp, 'Version';
1754 my $tag = debiantag($cversion, access_basedistro);
1755 runcmd @git, qw(check-ref-format), $tag;
1757 my $dscfn = dscfn($cversion);
1759 return ($clogp, $cversion, $tag, $dscfn);
1762 sub push_parse_dsc ($$$) {
1763 my ($dscfn,$dscfnwhat, $cversion) = @_;
1764 $dsc = parsecontrol($dscfn,$dscfnwhat);
1765 my $dversion = getfield $dsc, 'Version';
1766 my $dscpackage = getfield $dsc, 'Source';
1767 ($dscpackage eq $package && $dversion eq $cversion) or
1768 fail "$dscfn is for $dscpackage $dversion".
1769 " but debian/changelog is for $package $cversion";
1772 sub push_mktag ($$$$$$$) {
1773 my ($head,$clogp,$tag,
1775 $changesfile,$changesfilewhat,
1778 $dsc->{$ourdscfield[0]} = $head;
1779 $dsc->save("$dscfn.tmp") or die $!;
1781 my $changes = parsecontrol($changesfile,$changesfilewhat);
1782 foreach my $field (qw(Source Distribution Version)) {
1783 $changes->{$field} eq $clogp->{$field} or
1784 fail "changes field $field \`$changes->{$field}'".
1785 " does not match changelog \`$clogp->{$field}'";
1788 my $cversion = getfield $clogp, 'Version';
1789 my $clogsuite = getfield $clogp, 'Distribution';
1791 # We make the git tag by hand because (a) that makes it easier
1792 # to control the "tagger" (b) we can do remote signing
1793 my $authline = clogp_authline $clogp;
1794 my $delibs = join(" ", "",@deliberatelies);
1795 my $declaredistro = access_basedistro();
1796 open TO, '>', $tfn->('.tmp') or die $!;
1797 print TO <<END or die $!;
1803 $package release $cversion for $clogsuite ($csuite) [dgit]
1804 [dgit distro=$declaredistro$delibs]
1806 foreach my $ref (sort keys %previously) {
1807 print TO <<END or die $!;
1808 [dgit previously:$ref=$previously{$ref}]
1814 my $tagobjfn = $tfn->('.tmp');
1816 if (!defined $keyid) {
1817 $keyid = access_cfg('keyid','RETURN-UNDEF');
1819 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1820 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1821 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1822 push @sign_cmd, $tfn->('.tmp');
1823 runcmd_ordryrun @sign_cmd;
1825 $tagobjfn = $tfn->('.signed.tmp');
1826 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1827 $tfn->('.tmp'), $tfn->('.tmp.asc');
1834 sub sign_changes ($) {
1835 my ($changesfile) = @_;
1837 my @debsign_cmd = @debsign;
1838 push @debsign_cmd, "-k$keyid" if defined $keyid;
1839 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1840 push @debsign_cmd, $changesfile;
1841 runcmd_ordryrun @debsign_cmd;
1846 my ($forceflag) = @_;
1847 printdebug "actually entering push\n";
1848 supplementary_message(<<'END');
1849 Push failed, while preparing your push.
1850 You can retry the push, after fixing the problem, if you like.
1854 access_giturl(); # check that success is vaguely likely
1856 my $clogpfn = ".git/dgit/changelog.822.tmp";
1857 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1859 responder_send_file('parsed-changelog', $clogpfn);
1861 my ($clogp, $cversion, $tag, $dscfn) =
1862 push_parse_changelog("$clogpfn");
1864 my $dscpath = "$buildproductsdir/$dscfn";
1865 stat_exists $dscpath or
1866 fail "looked for .dsc $dscfn, but $!;".
1867 " maybe you forgot to build";
1869 responder_send_file('dsc', $dscpath);
1871 push_parse_dsc($dscpath, $dscfn, $cversion);
1873 my $format = getfield $dsc, 'Format';
1874 printdebug "format $format\n";
1875 if (madformat($format)) {
1876 commit_quilty_patch();
1880 progress "checking that $dscfn corresponds to HEAD";
1881 runcmd qw(dpkg-source -x --),
1882 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1883 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1884 check_for_vendor_patches() if madformat($dsc->{format});
1885 changedir '../../../..';
1886 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1887 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1888 debugcmd "+",@diffcmd;
1890 my $r = system @diffcmd;
1893 fail "$dscfn specifies a different tree to your HEAD commit;".
1894 " perhaps you forgot to build".
1895 ($diffopt eq '--exit-code' ? "" :
1896 " (run with -D to see full diff output)");
1901 my $head = git_rev_parse('HEAD');
1902 if (!$changesfile) {
1903 my $multi = "$buildproductsdir/".
1904 "${package}_".(stripepoch $cversion)."_multi.changes";
1905 if (stat_exists "$multi") {
1906 $changesfile = $multi;
1908 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1909 my @cs = glob "$buildproductsdir/$pat";
1910 fail "failed to find unique changes file".
1911 " (looked for $pat in $buildproductsdir, or $multi);".
1912 " perhaps you need to use dgit -C"
1914 ($changesfile) = @cs;
1917 $changesfile = "$buildproductsdir/$changesfile";
1920 responder_send_file('changes',$changesfile);
1921 responder_send_command("param head $head");
1922 responder_send_command("param csuite $csuite");
1924 if (deliberately_not_fast_forward) {
1925 git_for_each_ref(lrfetchrefs, sub {
1926 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1927 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1928 responder_send_command("previously $rrefname=$objid");
1929 $previously{$rrefname} = $objid;
1933 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1936 supplementary_message(<<'END');
1937 Push failed, while signing the tag.
1938 You can retry the push, after fixing the problem, if you like.
1940 # If we manage to sign but fail to record it anywhere, it's fine.
1941 if ($we_are_responder) {
1942 $tagobjfn = $tfn->('.signed.tmp');
1943 responder_receive_files('signed-tag', $tagobjfn);
1946 push_mktag($head,$clogp,$tag,
1948 $changesfile,$changesfile,
1951 supplementary_message(<<'END');
1952 Push failed, *after* signing the tag.
1953 If you want to try again, you should use a new version number.
1956 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1957 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1958 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1960 supplementary_message(<<'END');
1961 Push failed, while updating the remote git repository - see messages above.
1962 If you want to try again, you should use a new version number.
1964 if (!check_for_git()) {
1965 create_remote_git_repo();
1967 runcmd_ordryrun @git, qw(push),access_giturl(),
1968 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1969 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1971 supplementary_message(<<'END');
1972 Push failed, after updating the remote git repository.
1973 If you want to try again, you must use a new version number.
1975 if ($we_are_responder) {
1976 my $dryrunsuffix = act_local() ? "" : ".tmp";
1977 responder_receive_files('signed-dsc-changes',
1978 "$dscpath$dryrunsuffix",
1979 "$changesfile$dryrunsuffix");
1982 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1984 progress "[new .dsc left in $dscpath.tmp]";
1986 sign_changes $changesfile;
1989 supplementary_message(<<'END');
1990 Push failed, while uploading package(s) to the archive server.
1991 You can retry the upload of exactly these same files with dput of:
1993 If that .changes file is broken, you will need to use a new version
1994 number for your next attempt at the upload.
1996 my $host = access_cfg('upload-host','RETURN-UNDEF');
1997 my @hostarg = defined($host) ? ($host,) : ();
1998 runcmd_ordryrun @dput, @hostarg, $changesfile;
1999 printdone "pushed and uploaded $cversion";
2001 supplementary_message('');
2002 responder_send_command("complete");
2008 badusage "-p is not allowed with clone; specify as argument instead"
2009 if defined $package;
2012 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2013 ($package,$isuite) = @ARGV;
2014 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2015 ($package,$dstdir) = @ARGV;
2016 } elsif (@ARGV==3) {
2017 ($package,$isuite,$dstdir) = @ARGV;
2019 badusage "incorrect arguments to dgit clone";
2021 $dstdir ||= "$package";
2023 if (stat_exists $dstdir) {
2024 fail "$dstdir already exists";
2028 if ($rmonerror && !$dryrun_level) {
2029 $cwd_remove= getcwd();
2031 return unless defined $cwd_remove;
2032 if (!chdir "$cwd_remove") {
2033 return if $!==&ENOENT;
2034 die "chdir $cwd_remove: $!";
2036 rmtree($dstdir) or die "remove $dstdir: $!\n";
2041 $cwd_remove = undef;
2044 sub branchsuite () {
2045 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2046 if ($branch =~ m#$lbranch_re#o) {
2053 sub fetchpullargs () {
2054 if (!defined $package) {
2055 my $sourcep = parsecontrol('debian/control','debian/control');
2056 $package = getfield $sourcep, 'Source';
2059 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2061 my $clogp = parsechangelog();
2062 $isuite = getfield $clogp, 'Distribution';
2064 canonicalise_suite();
2065 progress "fetching from suite $csuite";
2066 } elsif (@ARGV==1) {
2068 canonicalise_suite();
2070 badusage "incorrect arguments to dgit fetch or dgit pull";
2089 badusage "-p is not allowed with dgit push" if defined $package;
2091 my $clogp = parsechangelog();
2092 $package = getfield $clogp, 'Source';
2095 } elsif (@ARGV==1) {
2096 ($specsuite) = (@ARGV);
2098 badusage "incorrect arguments to dgit push";
2100 $isuite = getfield $clogp, 'Distribution';
2102 local ($package) = $existing_package; # this is a hack
2103 canonicalise_suite();
2105 canonicalise_suite();
2107 if (defined $specsuite &&
2108 $specsuite ne $isuite &&
2109 $specsuite ne $csuite) {
2110 fail "dgit push: changelog specifies $isuite ($csuite)".
2111 " but command line specifies $specsuite";
2113 supplementary_message(<<'END');
2114 Push failed, while checking state of the archive.
2115 You can retry the push, after fixing the problem, if you like.
2117 if (check_for_git()) {
2121 if (fetch_from_archive()) {
2122 if (is_fast_fwd(lrref(), 'HEAD')) {
2124 } elsif (deliberately_not_fast_forward) {
2127 fail "dgit push: HEAD is not a descendant".
2128 " of the archive's version.\n".
2129 "dgit: To overwrite its contents,".
2130 " use git merge -s ours ".lrref().".\n".
2131 "dgit: To rewind history, if permitted by the archive,".
2132 " use --deliberately-not-fast-forward";
2136 fail "package appears to be new in this suite;".
2137 " if this is intentional, use --new";
2142 #---------- remote commands' implementation ----------
2144 sub cmd_remote_push_build_host {
2145 my ($nrargs) = shift @ARGV;
2146 my (@rargs) = @ARGV[0..$nrargs-1];
2147 @ARGV = @ARGV[$nrargs..$#ARGV];
2149 my ($dir,$vsnwant) = @rargs;
2150 # vsnwant is a comma-separated list; we report which we have
2151 # chosen in our ready response (so other end can tell if they
2154 $we_are_responder = 1;
2155 $us .= " (build host)";
2159 open PI, "<&STDIN" or die $!;
2160 open STDIN, "/dev/null" or die $!;
2161 open PO, ">&STDOUT" or die $!;
2163 open STDOUT, ">&STDERR" or die $!;
2167 ($protovsn) = grep {
2168 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2169 } @rpushprotovsn_support;
2171 fail "build host has dgit rpush protocol versions ".
2172 (join ",", @rpushprotovsn_support).
2173 " but invocation host has $vsnwant"
2174 unless defined $protovsn;
2176 responder_send_command("dgit-remote-push-ready $protovsn");
2182 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2183 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2184 # a good error message)
2190 my $report = i_child_report();
2191 if (defined $report) {
2192 printdebug "($report)\n";
2193 } elsif ($i_child_pid) {
2194 printdebug "(killing build host child $i_child_pid)\n";
2195 kill 15, $i_child_pid;
2197 if (defined $i_tmp && !defined $initiator_tempdir) {
2199 eval { rmtree $i_tmp; };
2203 END { i_cleanup(); }
2206 my ($base,$selector,@args) = @_;
2207 $selector =~ s/\-/_/g;
2208 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2215 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2223 push @rargs, join ",", @rpushprotovsn_support;
2226 push @rdgit, @ropts;
2227 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2229 my @cmd = (@ssh, $host, shellquote @rdgit);
2232 if (defined $initiator_tempdir) {
2233 rmtree $initiator_tempdir;
2234 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2235 $i_tmp = $initiator_tempdir;
2239 $i_child_pid = open2(\*RO, \*RI, @cmd);
2241 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2242 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2243 $supplementary_message = '' unless $protovsn >= 3;
2245 my ($icmd,$iargs) = initiator_expect {
2246 m/^(\S+)(?: (.*))?$/;
2249 i_method "i_resp", $icmd, $iargs;
2253 sub i_resp_progress ($) {
2255 my $msg = protocol_read_bytes \*RO, $rhs;
2259 sub i_resp_supplementary_message ($) {
2261 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2264 sub i_resp_complete {
2265 my $pid = $i_child_pid;
2266 $i_child_pid = undef; # prevents killing some other process with same pid
2267 printdebug "waiting for build host child $pid...\n";
2268 my $got = waitpid $pid, 0;
2269 die $! unless $got == $pid;
2270 die "build host child failed $?" if $?;
2273 printdebug "all done\n";
2277 sub i_resp_file ($) {
2279 my $localname = i_method "i_localname", $keyword;
2280 my $localpath = "$i_tmp/$localname";
2281 stat_exists $localpath and
2282 badproto \*RO, "file $keyword ($localpath) twice";
2283 protocol_receive_file \*RO, $localpath;
2284 i_method "i_file", $keyword;
2289 sub i_resp_param ($) {
2290 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2294 sub i_resp_previously ($) {
2295 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2296 or badproto \*RO, "bad previously spec";
2297 my $r = system qw(git check-ref-format), $1;
2298 die "bad previously ref spec ($r)" if $r;
2299 $previously{$1} = $2;
2304 sub i_resp_want ($) {
2306 die "$keyword ?" if $i_wanted{$keyword}++;
2307 my @localpaths = i_method "i_want", $keyword;
2308 printdebug "[[ $keyword @localpaths\n";
2309 foreach my $localpath (@localpaths) {
2310 protocol_send_file \*RI, $localpath;
2312 print RI "files-end\n" or die $!;
2315 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2317 sub i_localname_parsed_changelog {
2318 return "remote-changelog.822";
2320 sub i_file_parsed_changelog {
2321 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2322 push_parse_changelog "$i_tmp/remote-changelog.822";
2323 die if $i_dscfn =~ m#/|^\W#;
2326 sub i_localname_dsc {
2327 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2332 sub i_localname_changes {
2333 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2334 $i_changesfn = $i_dscfn;
2335 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2336 return $i_changesfn;
2338 sub i_file_changes { }
2340 sub i_want_signed_tag {
2341 printdebug Dumper(\%i_param, $i_dscfn);
2342 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2343 && defined $i_param{'csuite'}
2344 or badproto \*RO, "premature desire for signed-tag";
2345 my $head = $i_param{'head'};
2346 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2348 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2350 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2353 push_mktag $head, $i_clogp, $i_tag,
2355 $i_changesfn, 'remote changes',
2356 sub { "tag$_[0]"; };
2361 sub i_want_signed_dsc_changes {
2362 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2363 sign_changes $i_changesfn;
2364 return ($i_dscfn, $i_changesfn);
2367 #---------- building etc. ----------
2373 #----- `3.0 (quilt)' handling -----
2375 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2377 sub quiltify_dpkg_commit ($$$;$) {
2378 my ($patchname,$author,$msg, $xinfo) = @_;
2382 my $descfn = ".git/dgit/quilt-description.tmp";
2383 open O, '>', $descfn or die "$descfn: $!";
2386 $msg =~ s/^\s+$/ ./mg;
2387 print O <<END or die $!;
2397 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2398 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2399 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2400 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2404 sub quiltify_trees_differ ($$) {
2406 # returns 1 iff the two tree objects differ other than in debian/
2408 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2409 my $diffs= cmdoutput @cmd;
2410 foreach my $f (split /\0/, $diffs) {
2411 next if $f eq 'debian';
2417 sub quiltify_tree_sentinelfiles ($) {
2418 # lists the `sentinel' files present in the tree
2420 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2421 qw(-- debian/rules debian/control);
2427 my ($clogp,$target) = @_;
2429 # Quilt patchification algorithm
2431 # We search backwards through the history of the main tree's HEAD
2432 # (T) looking for a start commit S whose tree object is identical
2433 # to to the patch tip tree (ie the tree corresponding to the
2434 # current dpkg-committed patch series). For these purposes
2435 # `identical' disregards anything in debian/ - this wrinkle is
2436 # necessary because dpkg-source treates debian/ specially.
2438 # We can only traverse edges where at most one of the ancestors'
2439 # trees differs (in changes outside in debian/). And we cannot
2440 # handle edges which change .pc/ or debian/patches. To avoid
2441 # going down a rathole we avoid traversing edges which introduce
2442 # debian/rules or debian/control. And we set a limit on the
2443 # number of edges we are willing to look at.
2445 # If we succeed, we walk forwards again. For each traversed edge
2446 # PC (with P parent, C child) (starting with P=S and ending with
2447 # C=T) to we do this:
2449 # - dpkg-source --commit with a patch name and message derived from C
2450 # After traversing PT, we git commit the changes which
2451 # should be contained within debian/patches.
2453 changedir '../fake';
2454 mktree_in_ud_here();
2456 runcmd @git, 'add', '.';
2457 my $oldtiptree=git_write_tree();
2458 changedir '../work';
2460 # The search for the path S..T is breadth-first. We maintain a
2461 # todo list containing search nodes. A search node identifies a
2462 # commit, and looks something like this:
2464 # Commit => $git_commit_id,
2465 # Child => $c, # or undef if P=T
2466 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2467 # Nontrivial => true iff $p..$c has relevant changes
2474 my %considered; # saves being exponential on some weird graphs
2476 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2479 my ($search,$whynot) = @_;
2480 printdebug " search NOT $search->{Commit} $whynot\n";
2481 $search->{Whynot} = $whynot;
2482 push @nots, $search;
2483 no warnings qw(exiting);
2492 my $c = shift @todo;
2493 next if $considered{$c->{Commit}}++;
2495 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2497 printdebug "quiltify investigate $c->{Commit}\n";
2500 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2501 printdebug " search finished hooray!\n";
2506 if ($quilt_mode eq 'nofix') {
2507 fail "quilt fixup required but quilt mode is \`nofix'\n".
2508 "HEAD commit $c->{Commit} differs from tree implied by ".
2509 " debian/patches (tree object $oldtiptree)";
2511 if ($quilt_mode eq 'smash') {
2512 printdebug " search quitting smash\n";
2516 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2517 $not->($c, "has $c_sentinels not $t_sentinels")
2518 if $c_sentinels ne $t_sentinels;
2520 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2521 $commitdata =~ m/\n\n/;
2523 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2524 @parents = map { { Commit => $_, Child => $c } } @parents;
2526 $not->($c, "root commit") if !@parents;
2528 foreach my $p (@parents) {
2529 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2531 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2532 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2534 foreach my $p (@parents) {
2535 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2537 my @cmd= (@git, qw(diff-tree -r --name-only),
2538 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2539 my $patchstackchange = cmdoutput @cmd;
2540 if (length $patchstackchange) {
2541 $patchstackchange =~ s/\n/,/g;
2542 $not->($p, "changed $patchstackchange");
2545 printdebug " search queue P=$p->{Commit} ",
2546 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2552 printdebug "quiltify want to smash\n";
2555 my $x = $_[0]{Commit};
2556 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2559 my $reportnot = sub {
2561 my $s = $abbrev->($notp);
2562 my $c = $notp->{Child};
2563 $s .= "..".$abbrev->($c) if $c;
2564 $s .= ": ".$notp->{Whynot};
2567 if ($quilt_mode eq 'linear') {
2568 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2569 foreach my $notp (@nots) {
2570 print STDERR "$us: ", $reportnot->($notp), "\n";
2572 fail "quilt fixup naive history linearisation failed.\n".
2573 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2574 } elsif ($quilt_mode eq 'smash') {
2575 } elsif ($quilt_mode eq 'auto') {
2576 progress "quilt fixup cannot be linear, smashing...";
2578 die "$quilt_mode ?";
2583 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2585 quiltify_dpkg_commit "auto-$version-$target-$time",
2586 (getfield $clogp, 'Maintainer'),
2587 "Automatically generated patch ($clogp->{Version})\n".
2588 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2592 progress "quiltify linearisation planning successful, executing...";
2594 for (my $p = $sref_S;
2595 my $c = $p->{Child};
2597 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2598 next unless $p->{Nontrivial};
2600 my $cc = $c->{Commit};
2602 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2603 $commitdata =~ m/\n\n/ or die "$c ?";
2606 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2609 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2612 my $patchname = $title;
2613 $patchname =~ s/[.:]$//;
2614 $patchname =~ y/ A-Z/-a-z/;
2615 $patchname =~ y/-a-z0-9_.+=~//cd;
2616 $patchname =~ s/^\W/x-$&/;
2617 $patchname = substr($patchname,0,40);
2620 stat "debian/patches/$patchname$index";
2622 $!==ENOENT or die "$patchname$index $!";
2624 runcmd @git, qw(checkout -q), $cc;
2626 # We use the tip's changelog so that dpkg-source doesn't
2627 # produce complaining messages from dpkg-parsechangelog. None
2628 # of the information dpkg-source gets from the changelog is
2629 # actually relevant - it gets put into the original message
2630 # which dpkg-source provides our stunt editor, and then
2632 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2634 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2635 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2637 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2640 runcmd @git, qw(checkout -q master);
2643 sub build_maybe_quilt_fixup () {
2644 my $format=get_source_format;
2645 return unless madformat $format;
2648 check_for_vendor_patches();
2651 # - honour any existing .pc in case it has any strangeness
2652 # - determine the git commit corresponding to the tip of
2653 # the patch stack (if there is one)
2654 # - if there is such a git commit, convert each subsequent
2655 # git commit into a quilt patch with dpkg-source --commit
2656 # - otherwise convert all the differences in the tree into
2657 # a single git commit
2661 # Our git tree doesn't necessarily contain .pc. (Some versions of
2662 # dgit would include the .pc in the git tree.) If there isn't
2663 # one, we need to generate one by unpacking the patches that we
2666 # We first look for a .pc in the git tree. If there is one, we
2667 # will use it. (This is not the normal case.)
2669 # Otherwise need to regenerate .pc so that dpkg-source --commit
2670 # can work. We do this as follows:
2671 # 1. Collect all relevant .orig from parent directory
2672 # 2. Generate a debian.tar.gz out of
2673 # debian/{patches,rules,source/format}
2674 # 3. Generate a fake .dsc containing just these fields:
2675 # Format Source Version Files
2676 # 4. Extract the fake .dsc
2677 # Now the fake .dsc has a .pc directory.
2678 # (In fact we do this in every case, because in future we will
2679 # want to search for a good base commit for generating patches.)
2681 # Then we can actually do the dpkg-source --commit
2682 # 1. Make a new working tree with the same object
2683 # store as our main tree and check out the main
2685 # 2. Copy .pc from the fake's extraction, if necessary
2686 # 3. Run dpkg-source --commit
2687 # 4. If the result has changes to debian/, then
2688 # - git-add them them
2689 # - git-add .pc if we had a .pc in-tree
2691 # 5. If we had a .pc in-tree, delete it, and git-commit
2692 # 6. Back in the main tree, fast forward to the new HEAD
2694 my $clogp = parsechangelog();
2695 my $headref = git_rev_parse('HEAD');
2700 my $upstreamversion=$version;
2701 $upstreamversion =~ s/-[^-]*$//;
2703 my $fakeversion="$upstreamversion-~~DGITFAKE";
2705 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2706 print $fakedsc <<END or die $!;
2709 Version: $fakeversion
2713 my $dscaddfile=sub {
2716 my $md = new Digest::MD5;
2718 my $fh = new IO::File $b, '<' or die "$b $!";
2723 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2726 foreach my $f (<../../../../*>) { #/){
2727 my $b=$f; $b =~ s{.*/}{};
2728 next unless is_orig_file $b, srcfn $upstreamversion,'';
2729 link $f, $b or die "$b $!";
2733 my @files=qw(debian/source/format debian/rules);
2734 if (stat_exists '../../../debian/patches') {
2735 push @files, 'debian/patches';
2738 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2739 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2741 $dscaddfile->($debtar);
2742 close $fakedsc or die $!;
2744 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2746 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2747 rename $fakexdir, "fake" or die "$fakexdir $!";
2749 mkdir "work" or die $!;
2751 mktree_in_ud_here();
2752 runcmd @git, qw(reset --hard), $headref;
2755 if (stat_exists ".pc") {
2757 progress "Tree already contains .pc - will use it then delete it.";
2760 rename '../fake/.pc','.pc' or die $!;
2763 quiltify($clogp,$headref);
2765 if (!open P, '>>', ".pc/applied-patches") {
2766 $!==&ENOENT or die $!;
2771 commit_quilty_patch();
2773 if ($mustdeletepc) {
2774 runcmd @git, qw(rm -rqf .pc);
2775 commit_admin "Commit removal of .pc (quilt series tracking data)";
2778 changedir '../../../..';
2779 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2782 sub quilt_fixup_editor () {
2783 my $descfn = $ENV{$fakeeditorenv};
2784 my $editing = $ARGV[$#ARGV];
2785 open I1, '<', $descfn or die "$descfn: $!";
2786 open I2, '<', $editing or die "$editing: $!";
2787 unlink $editing or die "$editing: $!";
2788 open O, '>', $editing or die "$editing: $!";
2789 while (<I1>) { print O or die $!; } I1->error and die $!;
2792 $copying ||= m/^\-\-\- /;
2793 next unless $copying;
2796 I2->error and die $!;
2801 #----- other building -----
2804 if ($cleanmode eq 'dpkg-source') {
2805 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2806 } elsif ($cleanmode eq 'dpkg-source-d') {
2807 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2808 } elsif ($cleanmode eq 'git') {
2809 runcmd_ordryrun_local @git, qw(clean -xdf);
2810 } elsif ($cleanmode eq 'git-ff') {
2811 runcmd_ordryrun_local @git, qw(clean -xdff);
2812 } elsif ($cleanmode eq 'check') {
2813 my $leftovers = cmdoutput @git, qw(clean -xdn);
2814 if (length $leftovers) {
2815 print STDERR $leftovers, "\n" or die $!;
2816 fail "tree contains uncommitted files and --clean=check specified";
2818 } elsif ($cleanmode eq 'none') {
2825 badusage "clean takes no additional arguments" if @ARGV;
2830 badusage "-p is not allowed when building" if defined $package;
2833 my $clogp = parsechangelog();
2834 $isuite = getfield $clogp, 'Distribution';
2835 $package = getfield $clogp, 'Source';
2836 $version = getfield $clogp, 'Version';
2837 build_maybe_quilt_fixup();
2840 sub changesopts () {
2841 my @opts =@changesopts[1..$#changesopts];
2842 if (!defined $changes_since_version) {
2843 my @vsns = archive_query('archive_query');
2844 my @quirk = access_quirk();
2845 if ($quirk[0] eq 'backports') {
2846 local $isuite = $quirk[2];
2848 canonicalise_suite();
2849 push @vsns, archive_query('archive_query');
2852 @vsns = map { $_->[0] } @vsns;
2853 @vsns = sort { -version_compare($a, $b) } @vsns;
2854 $changes_since_version = $vsns[0];
2855 progress "changelog will contain changes since $vsns[0]";
2857 $changes_since_version = '_';
2858 progress "package seems new, not specifying -v<version>";
2861 if ($changes_since_version ne '_') {
2862 unshift @opts, "-v$changes_since_version";
2867 sub massage_dbp_args ($) {
2869 return unless $cleanmode =~ m/git|none/;
2870 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2871 my @newcmd = shift @$cmd;
2872 # -nc has the side effect of specifying -b if nothing else specified
2873 push @newcmd, '-nc';
2874 # and some combinations of -S, -b, et al, are errors, rather than
2875 # later simply overriding earlier
2876 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2877 push @newcmd, @$cmd;
2883 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2884 massage_dbp_args \@dbp;
2885 runcmd_ordryrun_local @dbp;
2886 printdone "build successful\n";
2891 my @dbp = @dpkgbuildpackage;
2892 massage_dbp_args \@dbp;
2894 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2895 "--git-builder=@dbp");
2896 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2897 canonicalise_suite();
2898 push @cmd, "--git-debian-branch=".lbranch();
2900 push @cmd, changesopts();
2901 runcmd_ordryrun_local @cmd, @ARGV;
2902 printdone "build successful\n";
2907 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2908 $dscfn = dscfn($version);
2909 if ($cleanmode eq 'dpkg-source') {
2910 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2912 } elsif ($cleanmode eq 'dpkg-source-d') {
2913 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2916 my $pwd = must_getcwd();
2917 my $leafdir = basename $pwd;
2919 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2921 runcmd_ordryrun_local qw(sh -ec),
2922 'exec >$1; shift; exec "$@"','x',
2923 "../$sourcechanges",
2924 @dpkggenchanges, qw(-S), changesopts();
2928 sub cmd_build_source {
2929 badusage "build-source takes no additional arguments" if @ARGV;
2931 printdone "source built, results in $dscfn and $sourcechanges";
2937 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2939 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2940 stat_exists $sourcechanges
2941 or fail "$sourcechanges (in parent directory): $!";
2942 foreach my $cf (glob $pat) {
2943 next if $cf eq $sourcechanges;
2944 unlink $cf or fail "remove $cf: $!";
2947 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2948 my @changesfiles = glob $pat;
2949 @changesfiles = sort {
2950 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2953 fail "wrong number of different changes files (@changesfiles)"
2954 unless @changesfiles;
2955 runcmd_ordryrun_local @mergechanges, @changesfiles;
2956 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2958 stat_exists $multichanges or fail "$multichanges: $!";
2960 printdone "build successful, results in $multichanges\n" or die $!;
2963 sub cmd_quilt_fixup {
2964 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2965 my $clogp = parsechangelog();
2966 $version = getfield $clogp, 'Version';
2967 $package = getfield $clogp, 'Source';
2968 build_maybe_quilt_fixup();
2971 sub cmd_archive_api_query {
2972 badusage "need only 1 subpath argument" unless @ARGV==1;
2973 my ($subpath) = @ARGV;
2974 my @cmd = archive_api_query_cmd($subpath);
2976 exec @cmd or fail "exec curl: $!\n";
2979 sub cmd_clone_dgit_repos_server {
2980 badusage "need destination argument" unless @ARGV==1;
2981 my ($destdir) = @ARGV;
2982 $package = '_dgit-repos-server';
2983 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2985 exec @cmd or fail "exec git clone: $!\n";
2988 sub cmd_setup_mergechangelogs {
2989 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2990 setup_mergechangelogs();
2993 #---------- argument parsing and main program ----------
2996 print "dgit version $our_version\n" or die $!;
3003 if (defined $ENV{'DGIT_SSH'}) {
3004 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3005 } elsif (defined $ENV{'GIT_SSH'}) {
3006 @ssh = ($ENV{'GIT_SSH'});
3010 last unless $ARGV[0] =~ m/^-/;
3014 if (m/^--dry-run$/) {
3017 } elsif (m/^--damp-run$/) {
3020 } elsif (m/^--no-sign$/) {
3023 } elsif (m/^--help$/) {
3025 } elsif (m/^--version$/) {
3027 } elsif (m/^--new$/) {
3030 } elsif (m/^--since-version=([^_]+|_)$/) {
3032 $changes_since_version = $1;
3033 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3034 ($om = $opts_opt_map{$1}) &&
3038 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3039 !$opts_opt_cmdonly{$1} &&
3040 ($om = $opts_opt_map{$1})) {
3043 } elsif (m/^--existing-package=(.*)/s) {
3045 $existing_package = $1;
3046 } elsif (m/^--initiator-tempdir=(.*)/s) {
3047 $initiator_tempdir = $1;
3048 $initiator_tempdir =~ m#^/# or
3049 badusage "--initiator-tempdir must be used specify an".
3050 " absolute, not relative, directory."
3051 } elsif (m/^--distro=(.*)/s) {
3054 } elsif (m/^--build-products-dir=(.*)/s) {
3056 $buildproductsdir = $1;
3057 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3060 } elsif (m/^--clean=(.*)$/s) {
3061 badusage "unknown cleaning mode \`$1'";
3062 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3065 } elsif (m/^--quilt=(.*)$/s) {
3066 badusage "unknown quilt fixup mode \`$1'";
3067 } elsif (m/^--ignore-dirty$/s) {
3070 } elsif (m/^--no-quilt-fixup$/s) {
3072 $quilt_mode = 'nocheck';
3073 } elsif (m/^--no-rm-on-error$/s) {
3076 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3078 push @deliberatelies, $&;
3080 badusage "unknown long option \`$_'";
3087 } elsif (s/^-L/-/) {
3090 } elsif (s/^-h/-/) {
3092 } elsif (s/^-D/-/) {
3096 } elsif (s/^-N/-/) {
3099 } elsif (s/^-v([^_]+|_)$//s) {
3101 $changes_since_version = $1;
3104 push @changesopts, $_;
3106 } elsif (s/^-c(.*=.*)//s) {
3108 push @git, '-c', $1;
3109 } elsif (s/^-d(.+)//s) {
3112 } elsif (s/^-C(.+)//s) {
3115 if ($changesfile =~ s#^(.*)/##) {
3116 $buildproductsdir = $1;
3118 } elsif (s/^-k(.+)//s) {
3120 } elsif (m/^-[vdCk]$/) {
3122 "option \`$_' requires an argument (and no space before the argument)";
3123 } elsif (s/^-wn$//s) {
3125 $cleanmode = 'none';
3126 } elsif (s/^-wg$//s) {
3129 } elsif (s/^-wgf$//s) {
3131 $cleanmode = 'git-ff';
3132 } elsif (s/^-wd$//s) {
3134 $cleanmode = 'dpkg-source';
3135 } elsif (s/^-wdd$//s) {
3137 $cleanmode = 'dpkg-source-d';
3138 } elsif (s/^-wc$//s) {
3140 $cleanmode = 'check';
3142 badusage "unknown short option \`$_'";
3149 if ($ENV{$fakeeditorenv}) {
3150 quilt_fixup_editor();
3155 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3156 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3157 if $dryrun_level == 1;
3159 print STDERR $helpmsg or die $!;
3162 my $cmd = shift @ARGV;
3165 if (!defined $quilt_mode) {
3166 local $access_forpush;
3167 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3168 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3170 $quilt_mode =~ m/^($quilt_modes_re)$/
3171 or badcfg "unknown quilt-mode \`$quilt_mode'";
3175 my $fn = ${*::}{"cmd_$cmd"};
3176 $fn or badusage "unknown operation $cmd";