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);
101 our %opts_opt_cmdline_opts;
102 sub finalise_opts_opts();
108 our $supplementary_message = '';
112 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
115 our $remotename = 'dgit';
116 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
120 sub lbranch () { return "$branchprefix/$csuite"; }
121 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
122 sub lref () { return "refs/heads/".lbranch(); }
123 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
124 sub rrref () { return server_ref($csuite); }
126 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
136 return "${package}_".(stripepoch $vsn).$sfx
141 return srcfn($vsn,".dsc");
150 foreach my $f (@end) {
152 warn "$us: cleanup: $@" if length $@;
156 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
158 sub no_such_package () {
159 print STDERR "$us: package $package does not exist in suite $isuite\n";
165 return "+".rrref().":".lrref();
170 printdebug "CD $newdir\n";
171 chdir $newdir or die "chdir: $newdir: $!";
174 sub deliberately ($) {
176 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
179 sub deliberately_not_fast_forward () {
180 foreach (qw(not-fast-forward fresh-repo)) {
181 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
185 #---------- remote protocol support, common ----------
187 # remote push initiator/responder protocol:
188 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
189 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
190 # < dgit-remote-push-ready <actual-proto-vsn>
192 # > file parsed-changelog
193 # [indicates that output of dpkg-parsechangelog follows]
194 # > data-block NBYTES
195 # > [NBYTES bytes of data (no newline)]
196 # [maybe some more blocks]
208 # [indicates that signed tag is wanted]
209 # < data-block NBYTES
210 # < [NBYTES bytes of data (no newline)]
211 # [maybe some more blocks]
215 # > want signed-dsc-changes
216 # < data-block NBYTES [transfer of signed dsc]
218 # < data-block NBYTES [transfer of signed changes]
226 sub i_child_report () {
227 # Sees if our child has died, and reap it if so. Returns a string
228 # describing how it died if it failed, or undef otherwise.
229 return undef unless $i_child_pid;
230 my $got = waitpid $i_child_pid, WNOHANG;
231 return undef if $got <= 0;
232 die unless $got == $i_child_pid;
233 $i_child_pid = undef;
234 return undef unless $?;
235 return "build host child ".waitstatusmsg();
240 fail "connection lost: $!" if $fh->error;
241 fail "protocol violation; $m not expected";
244 sub badproto_badread ($$) {
246 fail "connection lost: $!" if $!;
247 my $report = i_child_report();
248 fail $report if defined $report;
249 badproto $fh, "eof (reading $wh)";
252 sub protocol_expect (&$) {
253 my ($match, $fh) = @_;
256 defined && chomp or badproto_badread $fh, "protocol message";
264 badproto $fh, "\`$_'";
267 sub protocol_send_file ($$) {
268 my ($fh, $ourfn) = @_;
269 open PF, "<", $ourfn or die "$ourfn: $!";
272 my $got = read PF, $d, 65536;
273 die "$ourfn: $!" unless defined $got;
275 print $fh "data-block ".length($d)."\n" or die $!;
276 print $fh $d or die $!;
278 PF->error and die "$ourfn $!";
279 print $fh "data-end\n" or die $!;
283 sub protocol_read_bytes ($$) {
284 my ($fh, $nbytes) = @_;
285 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
287 my $got = read $fh, $d, $nbytes;
288 $got==$nbytes or badproto_badread $fh, "data block";
292 sub protocol_receive_file ($$) {
293 my ($fh, $ourfn) = @_;
294 printdebug "() $ourfn\n";
295 open PF, ">", $ourfn or die "$ourfn: $!";
297 my ($y,$l) = protocol_expect {
298 m/^data-block (.*)$/ ? (1,$1) :
299 m/^data-end$/ ? (0,) :
303 my $d = protocol_read_bytes $fh, $l;
304 print PF $d or die $!;
309 #---------- remote protocol support, responder ----------
311 sub responder_send_command ($) {
313 return unless $we_are_responder;
314 # called even without $we_are_responder
315 printdebug ">> $command\n";
316 print PO $command, "\n" or die $!;
319 sub responder_send_file ($$) {
320 my ($keyword, $ourfn) = @_;
321 return unless $we_are_responder;
322 printdebug "]] $keyword $ourfn\n";
323 responder_send_command "file $keyword";
324 protocol_send_file \*PO, $ourfn;
327 sub responder_receive_files ($@) {
328 my ($keyword, @ourfns) = @_;
329 die unless $we_are_responder;
330 printdebug "[[ $keyword @ourfns\n";
331 responder_send_command "want $keyword";
332 foreach my $fn (@ourfns) {
333 protocol_receive_file \*PI, $fn;
336 protocol_expect { m/^files-end$/ } \*PI;
339 #---------- remote protocol support, initiator ----------
341 sub initiator_expect (&) {
343 protocol_expect { &$match } \*RO;
346 #---------- end remote code ----------
349 if ($we_are_responder) {
351 responder_send_command "progress ".length($m) or die $!;
352 print PO $m or die $!;
362 $ua = LWP::UserAgent->new();
366 progress "downloading $what...";
367 my $r = $ua->get(@_) or die $!;
368 return undef if $r->code == 404;
369 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
370 return $r->decoded_content(charset => 'none');
373 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
378 failedcmd @_ if system @_;
381 sub act_local () { return $dryrun_level <= 1; }
382 sub act_scary () { return !$dryrun_level; }
385 if (!$dryrun_level) {
386 progress "dgit ok: @_";
388 progress "would be ok: @_ (but dry run only)";
393 printcmd(\*STDERR,$debugprefix."#",@_);
396 sub runcmd_ordryrun {
404 sub runcmd_ordryrun_local {
413 my ($first_shell, @cmd) = @_;
414 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
417 our $helpmsg = <<END;
419 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
420 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
421 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
422 dgit [dgit-opts] push [dgit-opts] [suite]
423 dgit [dgit-opts] rpush build-host:build-dir ...
424 important dgit options:
425 -k<keyid> sign tag and package with <keyid> instead of default
426 --dry-run -n do not change anything, but go through the motions
427 --damp-run -L like --dry-run but make local changes, without signing
428 --new -N allow introducing a new package
429 --debug -D increase debug level
430 -c<name>=<value> set git config option (used directly by dgit too)
433 our $later_warning_msg = <<END;
434 Perhaps the upload is stuck in incoming. Using the version from git.
438 print STDERR "$us: @_\n", $helpmsg or die $!;
443 @ARGV or badusage "too few arguments";
444 return scalar shift @ARGV;
448 print $helpmsg or die $!;
452 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
454 our %defcfg = ('dgit.default.distro' => 'debian',
455 'dgit.default.username' => '',
456 'dgit.default.archive-query-default-component' => 'main',
457 'dgit.default.ssh' => 'ssh',
458 'dgit.default.archive-query' => 'madison:',
459 'dgit.default.sshpsql-dbname' => 'service=projectb',
460 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
461 'dgit-distro.debian.git-check' => 'url',
462 'dgit-distro.debian.git-check-suffix' => '/info/refs',
463 'dgit-distro.debian.new-private-pushers' => 't',
464 'dgit-distro.debian/push.git-url' => '',
465 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
466 'dgit-distro.debian/push.git-user-force' => 'dgit',
467 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
468 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
469 'dgit-distro.debian/push.git-create' => 'true',
470 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
471 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
472 # 'dgit-distro.debian.archive-query-tls-key',
473 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
474 # ^ this does not work because curl is broken nowadays
475 # Fixing #790093 properly will involve providing providing the key
476 # in some pacagke and maybe updating these paths.
478 # 'dgit-distro.debian.archive-query-tls-curl-args',
479 # '--ca-path=/etc/ssl/ca-debian',
480 # ^ this is a workaround but works (only) on DSA-administered machines
481 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
482 'dgit-distro.debian.git-url-suffix' => '',
483 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
484 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
485 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
486 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
487 'dgit-distro.ubuntu.git-check' => 'false',
488 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
489 'dgit-distro.test-dummy.ssh' => "$td/ssh",
490 'dgit-distro.test-dummy.username' => "alice",
491 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
492 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
493 'dgit-distro.test-dummy.git-url' => "$td/git",
494 'dgit-distro.test-dummy.git-host' => "git",
495 'dgit-distro.test-dummy.git-path' => "$td/git",
496 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
497 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
498 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
499 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
502 sub git_get_config ($) {
505 our %git_get_config_memo;
506 if (exists $git_get_config_memo{$c}) {
507 return $git_get_config_memo{$c};
511 my @cmd = (@git, qw(config --), $c);
513 local ($debuglevel) = $debuglevel-2;
514 $v = cmdoutput_errok @cmd;
522 $git_get_config_memo{$c} = $v;
528 return undef if $c =~ /RETURN-UNDEF/;
529 my $v = git_get_config($c);
530 return $v if defined $v;
531 my $dv = $defcfg{$c};
532 return $dv if defined $dv;
534 badcfg "need value for one of: @_\n".
535 "$us: distro or suite appears not to be (properly) supported";
538 sub access_basedistro () {
539 if (defined $idistro) {
542 return cfg("dgit-suite.$isuite.distro",
543 "dgit.default.distro");
547 sub access_quirk () {
548 # returns (quirk name, distro to use instead or undef, quirk-specific info)
549 my $basedistro = access_basedistro();
550 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
552 if (defined $backports_quirk) {
553 my $re = $backports_quirk;
554 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
556 $re =~ s/\%/([-0-9a-z_]+)/
557 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
558 if ($isuite =~ m/^$re$/) {
559 return ('backports',"$basedistro-backports",$1);
562 return ('none',undef);
567 sub parse_cfg_bool ($$$) {
568 my ($what,$def,$v) = @_;
571 $v =~ m/^[ty1]/ ? 1 :
572 $v =~ m/^[fn0]/ ? 0 :
573 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
576 sub access_forpush_config () {
577 my $d = access_basedistro();
581 parse_cfg_bool('new-private-pushers', 0,
582 cfg("dgit-distro.$d.new-private-pushers",
585 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
588 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
589 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
590 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
591 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
594 sub access_forpush () {
595 $access_forpush //= access_forpush_config();
596 return $access_forpush;
600 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
601 badcfg "pushing but distro is configured readonly"
602 if access_forpush_config() eq '0';
604 $supplementary_message = <<'END' unless $we_are_responder;
605 Push failed, before we got started.
606 You can retry the push, after fixing the problem, if you like.
608 finalise_opts_opts();
612 finalise_opts_opts();
615 sub supplementary_message ($) {
617 if (!$we_are_responder) {
618 $supplementary_message = $msg;
620 } elsif ($protovsn >= 3) {
621 responder_send_command "supplementary-message ".length($msg)
623 print PO $msg or die $!;
627 sub access_distros () {
628 # Returns list of distros to try, in order
631 # 0. `instead of' distro name(s) we have been pointed to
632 # 1. the access_quirk distro, if any
633 # 2a. the user's specified distro, or failing that } basedistro
634 # 2b. the distro calculated from the suite }
635 my @l = access_basedistro();
637 my (undef,$quirkdistro) = access_quirk();
638 unshift @l, $quirkdistro;
639 unshift @l, $instead_distro;
640 @l = grep { defined } @l;
642 if (access_forpush()) {
643 @l = map { ("$_/push", $_) } @l;
651 # The nesting of these loops determines the search order. We put
652 # the key loop on the outside so that we search all the distros
653 # for each key, before going on to the next key. That means that
654 # if access_cfg is called with a more specific, and then a less
655 # specific, key, an earlier distro can override the less specific
656 # without necessarily overriding any more specific keys. (If the
657 # distro wants to override the more specific keys it can simply do
658 # so; whereas if we did the loop the other way around, it would be
659 # impossible to for an earlier distro to override a less specific
660 # key but not the more specific ones without restating the unknown
661 # values of the more specific keys.
664 # We have to deal with RETURN-UNDEF specially, so that we don't
665 # terminate the search prematurely.
667 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
670 foreach my $d (access_distros()) {
671 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
673 push @cfgs, map { "dgit.default.$_" } @realkeys;
675 my $value = cfg(@cfgs);
679 sub string_to_ssh ($) {
681 if ($spec =~ m/\s/) {
682 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
688 sub access_cfg_ssh () {
689 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
690 if (!defined $gitssh) {
693 return string_to_ssh $gitssh;
697 sub access_runeinfo ($) {
699 return ": dgit ".access_basedistro()." $info ;";
702 sub access_someuserhost ($) {
704 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
705 defined($user) && length($user) or
706 $user = access_cfg("$some-user",'username');
707 my $host = access_cfg("$some-host");
708 return length($user) ? "$user\@$host" : $host;
711 sub access_gituserhost () {
712 return access_someuserhost('git');
715 sub access_giturl (;$) {
717 my $url = access_cfg('git-url','RETURN-UNDEF');
720 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
721 return undef unless defined $proto;
724 access_gituserhost().
725 access_cfg('git-path');
727 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
730 return "$url/$package$suffix";
733 sub parsecontrolfh ($$;$) {
734 my ($fh, $desc, $allowsigned) = @_;
735 our $dpkgcontrolhash_noissigned;
738 my %opts = ('name' => $desc);
739 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
740 $c = Dpkg::Control::Hash->new(%opts);
741 $c->parse($fh,$desc) or die "parsing of $desc failed";
742 last if $allowsigned;
743 last if $dpkgcontrolhash_noissigned;
744 my $issigned= $c->get_option('is_pgp_signed');
745 if (!defined $issigned) {
746 $dpkgcontrolhash_noissigned= 1;
747 seek $fh, 0,0 or die "seek $desc: $!";
748 } elsif ($issigned) {
749 fail "control file $desc is (already) PGP-signed. ".
750 " Note that dgit push needs to modify the .dsc and then".
751 " do the signature itself";
760 my ($file, $desc) = @_;
761 my $fh = new IO::Handle;
762 open $fh, '<', $file or die "$file: $!";
763 my $c = parsecontrolfh($fh,$desc);
764 $fh->error and die $!;
770 my ($dctrl,$field) = @_;
771 my $v = $dctrl->{$field};
772 return $v if defined $v;
773 fail "missing field $field in ".$v->get_option('name');
777 my $c = Dpkg::Control::Hash->new();
778 my $p = new IO::Handle;
779 my @cmd = (qw(dpkg-parsechangelog), @_);
780 open $p, '-|', @cmd or die $!;
782 $?=0; $!=0; close $p or failedcmd @cmd;
788 defined $d or fail "getcwd failed: $!";
794 sub archive_query ($) {
796 my $query = access_cfg('archive-query','RETURN-UNDEF');
797 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
800 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
803 sub pool_dsc_subpath ($$) {
804 my ($vsn,$component) = @_; # $package is implict arg
805 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
806 return "/pool/$component/$prefix/$package/".dscfn($vsn);
809 #---------- `ftpmasterapi' archive query method (nascent) ----------
811 sub archive_api_query_cmd ($) {
813 my @cmd = qw(curl -sS);
814 my $url = access_cfg('archive-query-url');
815 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
817 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
818 foreach my $key (split /\:/, $keys) {
819 $key =~ s/\%HOST\%/$host/g;
821 fail "for $url: stat $key: $!" unless $!==ENOENT;
824 fail "config requested specific TLS key but do not know".
825 " how to get curl to use exactly that EE key ($key)";
826 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
827 # # Sadly the above line does not work because of changes
828 # # to gnutls. The real fix for #790093 may involve
829 # # new curl options.
832 # Fixing #790093 properly will involve providing a value
833 # for this on clients.
834 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
835 push @cmd, split / /, $kargs if defined $kargs;
837 push @cmd, $url.$subpath;
843 my ($data, $subpath) = @_;
844 badcfg "ftpmasterapi archive query method takes no data part"
846 my @cmd = archive_api_query_cmd($subpath);
847 my $json = cmdoutput @cmd;
848 return decode_json($json);
851 sub canonicalise_suite_ftpmasterapi () {
852 my ($proto,$data) = @_;
853 my $suites = api_query($data, 'suites');
855 foreach my $entry (@$suites) {
857 my $v = $entry->{$_};
858 defined $v && $v eq $isuite;
860 push @matched, $entry;
862 fail "unknown suite $isuite" unless @matched;
865 @matched==1 or die "multiple matches for suite $isuite\n";
866 $cn = "$matched[0]{codename}";
867 defined $cn or die "suite $isuite info has no codename\n";
868 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
870 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
875 sub archive_query_ftpmasterapi () {
876 my ($proto,$data) = @_;
877 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
879 my $digester = Digest::SHA->new(256);
880 foreach my $entry (@$info) {
882 my $vsn = "$entry->{version}";
883 my ($ok,$msg) = version_check $vsn;
884 die "bad version: $msg\n" unless $ok;
885 my $component = "$entry->{component}";
886 $component =~ m/^$component_re$/ or die "bad component";
887 my $filename = "$entry->{filename}";
888 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
889 or die "bad filename";
890 my $sha256sum = "$entry->{sha256sum}";
891 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
892 push @rows, [ $vsn, "/pool/$component/$filename",
893 $digester, $sha256sum ];
895 die "bad ftpmaster api response: $@\n".Dumper($entry)
898 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
902 #---------- `madison' archive query method ----------
904 sub archive_query_madison {
905 return map { [ @$_[0..1] ] } madison_get_parse(@_);
908 sub madison_get_parse {
909 my ($proto,$data) = @_;
910 die unless $proto eq 'madison';
912 $data= access_cfg('madison-distro','RETURN-UNDEF');
913 $data //= access_basedistro();
915 $rmad{$proto,$data,$package} ||= cmdoutput
916 qw(rmadison -asource),"-s$isuite","-u$data",$package;
917 my $rmad = $rmad{$proto,$data,$package};
920 foreach my $l (split /\n/, $rmad) {
921 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
922 \s*( [^ \t|]+ )\s* \|
923 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
924 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
925 $1 eq $package or die "$rmad $package ?";
932 $component = access_cfg('archive-query-default-component');
934 $5 eq 'source' or die "$rmad ?";
935 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
937 return sort { -version_compare($a->[0],$b->[0]); } @out;
940 sub canonicalise_suite_madison {
941 # madison canonicalises for us
942 my @r = madison_get_parse(@_);
944 "unable to canonicalise suite using package $package".
945 " which does not appear to exist in suite $isuite;".
946 " --existing-package may help";
950 #---------- `sshpsql' archive query method ----------
953 my ($data,$runeinfo,$sql) = @_;
955 $data= access_someuserhost('sshpsql').':'.
956 access_cfg('sshpsql-dbname');
958 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
959 my ($userhost,$dbname) = ($`,$'); #';
961 my @cmd = (access_cfg_ssh, $userhost,
962 access_runeinfo("ssh-psql $runeinfo").
963 " export LC_MESSAGES=C; export LC_CTYPE=C;".
964 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
966 open P, "-|", @cmd or die $!;
969 printdebug("$debugprefix>|$_|\n");
972 $!=0; $?=0; close P or failedcmd @cmd;
974 my $nrows = pop @rows;
975 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
976 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
977 @rows = map { [ split /\|/, $_ ] } @rows;
978 my $ncols = scalar @{ shift @rows };
979 die if grep { scalar @$_ != $ncols } @rows;
983 sub sql_injection_check {
984 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
987 sub archive_query_sshpsql ($$) {
988 my ($proto,$data) = @_;
989 sql_injection_check $isuite, $package;
990 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
991 SELECT source.version, component.name, files.filename, files.sha256sum
993 JOIN src_associations ON source.id = src_associations.source
994 JOIN suite ON suite.id = src_associations.suite
995 JOIN dsc_files ON dsc_files.source = source.id
996 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
997 JOIN component ON component.id = files_archive_map.component_id
998 JOIN files ON files.id = dsc_files.file
999 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1000 AND source.source='$package'
1001 AND files.filename LIKE '%.dsc';
1003 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1004 my $digester = Digest::SHA->new(256);
1006 my ($vsn,$component,$filename,$sha256sum) = @$_;
1007 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1012 sub canonicalise_suite_sshpsql ($$) {
1013 my ($proto,$data) = @_;
1014 sql_injection_check $isuite;
1015 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1016 SELECT suite.codename
1017 FROM suite where suite_name='$isuite' or codename='$isuite';
1019 @rows = map { $_->[0] } @rows;
1020 fail "unknown suite $isuite" unless @rows;
1021 die "ambiguous $isuite: @rows ?" if @rows>1;
1025 #---------- `dummycat' archive query method ----------
1027 sub canonicalise_suite_dummycat ($$) {
1028 my ($proto,$data) = @_;
1029 my $dpath = "$data/suite.$isuite";
1030 if (!open C, "<", $dpath) {
1031 $!==ENOENT or die "$dpath: $!";
1032 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1036 chomp or die "$dpath: $!";
1038 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1042 sub archive_query_dummycat ($$) {
1043 my ($proto,$data) = @_;
1044 canonicalise_suite();
1045 my $dpath = "$data/package.$csuite.$package";
1046 if (!open C, "<", $dpath) {
1047 $!==ENOENT or die "$dpath: $!";
1048 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1056 printdebug "dummycat query $csuite $package $dpath | $_\n";
1057 my @row = split /\s+/, $_;
1058 @row==2 or die "$dpath: $_ ?";
1061 C->error and die "$dpath: $!";
1063 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1066 #---------- archive query entrypoints and rest of program ----------
1068 sub canonicalise_suite () {
1069 return if defined $csuite;
1070 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1071 $csuite = archive_query('canonicalise_suite');
1072 if ($isuite ne $csuite) {
1073 progress "canonical suite name for $isuite is $csuite";
1077 sub get_archive_dsc () {
1078 canonicalise_suite();
1079 my @vsns = archive_query('archive_query');
1080 foreach my $vinfo (@vsns) {
1081 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1082 $dscurl = access_cfg('mirror').$subpath;
1083 $dscdata = url_get($dscurl);
1085 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1090 $digester->add($dscdata);
1091 my $got = $digester->hexdigest();
1093 fail "$dscurl has hash $got but".
1094 " archive told us to expect $digest";
1096 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1097 printdebug Dumper($dscdata) if $debuglevel>1;
1098 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1099 printdebug Dumper($dsc) if $debuglevel>1;
1100 my $fmt = getfield $dsc, 'Format';
1101 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1102 $dsc_checked = !!$digester;
1108 sub check_for_git ();
1109 sub check_for_git () {
1111 my $how = access_cfg('git-check');
1112 if ($how eq 'ssh-cmd') {
1114 (access_cfg_ssh, access_gituserhost(),
1115 access_runeinfo("git-check $package").
1116 " set -e; cd ".access_cfg('git-path').";".
1117 " if test -d $package.git; then echo 1; else echo 0; fi");
1118 my $r= cmdoutput @cmd;
1119 if ($r =~ m/^divert (\w+)$/) {
1121 my ($usedistro,) = access_distros();
1122 # NB that if we are pushing, $usedistro will be $distro/push
1123 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1124 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1125 progress "diverting to $divert (using config for $instead_distro)";
1126 return check_for_git();
1128 failedcmd @cmd unless $r =~ m/^[01]$/;
1130 } elsif ($how eq 'url') {
1131 my $prefix = access_cfg('git-check-url','git-url');
1132 my $suffix = access_cfg('git-check-suffix','git-suffix',
1133 'RETURN-UNDEF') // '.git';
1134 my $url = "$prefix/$package$suffix";
1135 my @cmd = (qw(curl -sS -I), $url);
1136 my $result = cmdoutput @cmd;
1137 $result =~ m/^\S+ (404|200) /s or
1138 fail "unexpected results from git check query - ".
1139 Dumper($prefix, $result);
1141 if ($code eq '404') {
1143 } elsif ($code eq '200') {
1148 } elsif ($how eq 'true') {
1150 } elsif ($how eq 'false') {
1153 badcfg "unknown git-check \`$how'";
1157 sub create_remote_git_repo () {
1158 my $how = access_cfg('git-create');
1159 if ($how eq 'ssh-cmd') {
1161 (access_cfg_ssh, access_gituserhost(),
1162 access_runeinfo("git-create $package").
1163 "set -e; cd ".access_cfg('git-path').";".
1164 " cp -a _template $package.git");
1165 } elsif ($how eq 'true') {
1168 badcfg "unknown git-create \`$how'";
1172 our ($dsc_hash,$lastpush_hash);
1174 our $ud = '.git/dgit/unpack';
1179 mkdir $ud or die $!;
1182 sub mktree_in_ud_here () {
1183 runcmd qw(git init -q);
1184 rmtree('.git/objects');
1185 symlink '../../../../objects','.git/objects' or die $!;
1188 sub git_write_tree () {
1189 my $tree = cmdoutput @git, qw(write-tree);
1190 $tree =~ m/^\w+$/ or die "$tree ?";
1194 sub mktree_in_ud_from_only_subdir () {
1195 # changes into the subdir
1197 die unless @dirs==1;
1198 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1202 my @gitscmd = qw(find -name .git -prune -print0);
1203 debugcmd "|",@gitscmd;
1204 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1209 print STDERR "$us: warning: removing from source package: ",
1210 (messagequote $_), "\n";
1214 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1216 mktree_in_ud_here();
1217 my $format=get_source_format();
1218 if (madformat($format)) {
1221 runcmd @git, qw(add -Af);
1222 my $tree=git_write_tree();
1223 return ($tree,$dir);
1226 sub dsc_files_info () {
1227 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1228 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1229 ['Files', 'Digest::MD5', 'new()']) {
1230 my ($fname, $module, $method) = @$csumi;
1231 my $field = $dsc->{$fname};
1232 next unless defined $field;
1233 eval "use $module; 1;" or die $@;
1235 foreach (split /\n/, $field) {
1237 m/^(\w+) (\d+) (\S+)$/ or
1238 fail "could not parse .dsc $fname line \`$_'";
1239 my $digester = eval "$module"."->$method;" or die $@;
1244 Digester => $digester,
1249 fail "missing any supported Checksums-* or Files field in ".
1250 $dsc->get_option('name');
1254 map { $_->{Filename} } dsc_files_info();
1257 sub is_orig_file ($;$) {
1260 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1261 defined $base or return 1;
1265 sub make_commit ($) {
1267 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1270 sub clogp_authline ($) {
1272 my $author = getfield $clogp, 'Maintainer';
1273 $author =~ s#,.*##ms;
1274 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1275 my $authline = "$author $date";
1276 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1277 fail "unexpected commit author line format \`$authline'".
1278 " (was generated from changelog Maintainer field)";
1282 sub vendor_patches_distro ($$) {
1283 my ($checkdistro, $what) = @_;
1284 return unless defined $checkdistro;
1286 my $series = "debian/patches/\L$checkdistro\E.series";
1287 printdebug "checking for vendor-specific $series ($what)\n";
1289 if (!open SERIES, "<", $series) {
1290 die "$series $!" unless $!==ENOENT;
1299 Unfortunately, this source package uses a feature of dpkg-source where
1300 the same source package unpacks to different source code on different
1301 distros. dgit cannot safely operate on such packages on affected
1302 distros, because the meaning of source packages is not stable.
1304 Please ask the distro/maintainer to remove the distro-specific series
1305 files and use a different technique (if necessary, uploading actually
1306 different packages, if different distros are supposed to have
1310 fail "Found active distro-specific series file for".
1311 " $checkdistro ($what): $series, cannot continue";
1313 die "$series $!" if SERIES->error;
1317 sub check_for_vendor_patches () {
1318 # This dpkg-source feature doesn't seem to be documented anywhere!
1319 # But it can be found in the changelog (reformatted):
1321 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1322 # Author: Raphael Hertzog <hertzog@debian.org>
1323 # Date: Sun Oct 3 09:36:48 2010 +0200
1325 # dpkg-source: correctly create .pc/.quilt_series with alternate
1328 # If you have debian/patches/ubuntu.series and you were
1329 # unpacking the source package on ubuntu, quilt was still
1330 # directed to debian/patches/series instead of
1331 # debian/patches/ubuntu.series.
1333 # debian/changelog | 3 +++
1334 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1335 # 2 files changed, 6 insertions(+), 1 deletion(-)
1338 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1339 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1340 "Dpkg::Vendor \`current vendor'");
1341 vendor_patches_distro(access_basedistro(),
1342 "distro being accessed");
1345 sub generate_commit_from_dsc () {
1349 foreach my $fi (dsc_files_info()) {
1350 my $f = $fi->{Filename};
1351 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1353 link "../../../$f", $f
1357 complete_file_from_dsc('.', $fi);
1359 if (is_orig_file($f)) {
1360 link $f, "../../../../$f"
1366 my $dscfn = "$package.dsc";
1368 open D, ">", $dscfn or die "$dscfn: $!";
1369 print D $dscdata or die "$dscfn: $!";
1370 close D or die "$dscfn: $!";
1371 my @cmd = qw(dpkg-source);
1372 push @cmd, '--no-check' if $dsc_checked;
1373 push @cmd, qw(-x --), $dscfn;
1376 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1377 check_for_vendor_patches() if madformat($dsc->{format});
1378 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1379 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1380 my $authline = clogp_authline $clogp;
1381 my $changes = getfield $clogp, 'Changes';
1382 open C, ">../commit.tmp" or die $!;
1383 print C <<END or die $!;
1390 # imported from the archive
1393 my $outputhash = make_commit qw(../commit.tmp);
1394 my $cversion = getfield $clogp, 'Version';
1395 progress "synthesised git commit from .dsc $cversion";
1396 if ($lastpush_hash) {
1397 runcmd @git, qw(reset --hard), $lastpush_hash;
1398 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1399 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1400 my $oversion = getfield $oldclogp, 'Version';
1402 version_compare($oversion, $cversion);
1404 # git upload/ is earlier vsn than archive, use archive
1405 open C, ">../commit2.tmp" or die $!;
1406 print C <<END or die $!;
1408 parent $lastpush_hash
1413 Record $package ($cversion) in archive suite $csuite
1415 $outputhash = make_commit qw(../commit2.tmp);
1416 } elsif ($vcmp > 0) {
1417 print STDERR <<END or die $!;
1419 Version actually in archive: $cversion (older)
1420 Last allegedly pushed/uploaded: $oversion (newer or same)
1423 $outputhash = $lastpush_hash;
1425 $outputhash = $lastpush_hash;
1428 changedir '../../../..';
1429 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1430 'DGIT_ARCHIVE', $outputhash;
1431 cmdoutput @git, qw(log -n2), $outputhash;
1432 # ... gives git a chance to complain if our commit is malformed
1437 sub complete_file_from_dsc ($$) {
1438 our ($dstdir, $fi) = @_;
1439 # Ensures that we have, in $dir, the file $fi, with the correct
1440 # contents. (Downloading it from alongside $dscurl if necessary.)
1442 my $f = $fi->{Filename};
1443 my $tf = "$dstdir/$f";
1446 if (stat_exists $tf) {
1447 progress "using existing $f";
1450 $furl =~ s{/[^/]+$}{};
1452 die "$f ?" unless $f =~ m/^${package}_/;
1453 die "$f ?" if $f =~ m#/#;
1454 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1455 next if !act_local();
1459 open F, "<", "$tf" or die "$tf: $!";
1460 $fi->{Digester}->reset();
1461 $fi->{Digester}->addfile(*F);
1462 F->error and die $!;
1463 my $got = $fi->{Digester}->hexdigest();
1464 $got eq $fi->{Hash} or
1465 fail "file $f has hash $got but .dsc".
1466 " demands hash $fi->{Hash} ".
1467 ($downloaded ? "(got wrong file from archive!)"
1468 : "(perhaps you should delete this file?)");
1471 sub ensure_we_have_orig () {
1472 foreach my $fi (dsc_files_info()) {
1473 my $f = $fi->{Filename};
1474 next unless is_orig_file($f);
1475 complete_file_from_dsc('..', $fi);
1479 sub git_fetch_us () {
1480 my @specs = (fetchspec());
1482 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1484 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1487 my $tagpat = debiantag('*',access_basedistro);
1489 git_for_each_ref("refs/tags/".$tagpat, sub {
1490 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1491 printdebug "currently $fullrefname=$objid\n";
1492 $here{$fullrefname} = $objid;
1494 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1495 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1496 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1497 printdebug "offered $lref=$objid\n";
1498 if (!defined $here{$lref}) {
1499 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1500 runcmd_ordryrun_local @upd;
1501 } elsif ($here{$lref} eq $objid) {
1504 "Not updateting $lref from $here{$lref} to $objid.\n";
1509 sub fetch_from_archive () {
1510 # ensures that lrref() is what is actually in the archive,
1511 # one way or another
1515 foreach my $field (@ourdscfield) {
1516 $dsc_hash = $dsc->{$field};
1517 last if defined $dsc_hash;
1519 if (defined $dsc_hash) {
1520 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1522 progress "last upload to archive specified git hash";
1524 progress "last upload to archive has NO git hash";
1527 progress "no version available from the archive";
1530 $lastpush_hash = git_get_ref(lrref());
1531 printdebug "previous reference hash=$lastpush_hash\n";
1533 if (defined $dsc_hash) {
1534 fail "missing remote git history even though dsc has hash -".
1535 " could not find ref ".lrref().
1536 " (should have been fetched from ".access_giturl()."#".rrref().")"
1537 unless $lastpush_hash;
1539 ensure_we_have_orig();
1540 if ($dsc_hash eq $lastpush_hash) {
1541 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1542 print STDERR <<END or die $!;
1544 Git commit in archive is behind the last version allegedly pushed/uploaded.
1545 Commit referred to by archive: $dsc_hash
1546 Last allegedly pushed/uploaded: $lastpush_hash
1549 $hash = $lastpush_hash;
1551 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1552 "descendant of archive's .dsc hash ($dsc_hash)";
1555 $hash = generate_commit_from_dsc();
1556 } elsif ($lastpush_hash) {
1557 # only in git, not in the archive yet
1558 $hash = $lastpush_hash;
1559 print STDERR <<END or die $!;
1561 Package not found in the archive, but has allegedly been pushed using dgit.
1565 printdebug "nothing found!\n";
1566 if (defined $skew_warning_vsn) {
1567 print STDERR <<END or die $!;
1569 Warning: relevant archive skew detected.
1570 Archive allegedly contains $skew_warning_vsn
1571 But we were not able to obtain any version from the archive or git.
1577 printdebug "current hash=$hash\n";
1578 if ($lastpush_hash) {
1579 fail "not fast forward on last upload branch!".
1580 " (archive's version left in DGIT_ARCHIVE)"
1581 unless is_fast_fwd($lastpush_hash, $hash);
1583 if (defined $skew_warning_vsn) {
1585 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1586 my $clogf = ".git/dgit/changelog.tmp";
1587 runcmd shell_cmd "exec >$clogf",
1588 @git, qw(cat-file blob), "$hash:debian/changelog";
1589 my $gotclogp = parsechangelog("-l$clogf");
1590 my $got_vsn = getfield $gotclogp, 'Version';
1591 printdebug "SKEW CHECK GOT $got_vsn\n";
1592 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1593 print STDERR <<END or die $!;
1595 Warning: archive skew detected. Using the available version:
1596 Archive allegedly contains $skew_warning_vsn
1597 We were able to obtain only $got_vsn
1602 if ($lastpush_hash ne $hash) {
1603 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1607 dryrun_report @upd_cmd;
1613 sub set_local_git_config ($$) {
1615 runcmd @git, qw(config), $k, $v;
1618 sub setup_mergechangelogs () {
1619 my $driver = 'dpkg-mergechangelogs';
1620 my $cb = "merge.$driver";
1621 my $attrs = '.git/info/attributes';
1622 ensuredir '.git/info';
1624 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1625 if (!open ATTRS, "<", $attrs) {
1626 $!==ENOENT or die "$attrs: $!";
1630 next if m{^debian/changelog\s};
1631 print NATTRS $_, "\n" or die $!;
1633 ATTRS->error and die $!;
1636 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1639 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1640 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1642 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1647 canonicalise_suite();
1648 badusage "dry run makes no sense with clone" unless act_local();
1649 my $hasgit = check_for_git();
1650 mkdir $dstdir or die "$dstdir $!";
1652 runcmd @git, qw(init -q);
1653 my $giturl = access_giturl(1);
1654 if (defined $giturl) {
1655 set_local_git_config "remote.$remotename.fetch", fetchspec();
1656 open H, "> .git/HEAD" or die $!;
1657 print H "ref: ".lref()."\n" or die $!;
1659 runcmd @git, qw(remote add), 'origin', $giturl;
1662 progress "fetching existing git history";
1664 runcmd_ordryrun_local @git, qw(fetch origin);
1666 progress "starting new git history";
1668 fetch_from_archive() or no_such_package;
1669 my $vcsgiturl = $dsc->{'Vcs-Git'};
1670 if (length $vcsgiturl) {
1671 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1672 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1674 setup_mergechangelogs();
1675 runcmd @git, qw(reset --hard), lrref();
1676 printdone "ready for work in $dstdir";
1680 if (check_for_git()) {
1683 fetch_from_archive() or no_such_package();
1684 printdone "fetched into ".lrref();
1689 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1691 printdone "fetched to ".lrref()." and merged into HEAD";
1694 sub check_not_dirty () {
1695 return if $ignoredirty;
1696 my @cmd = (@git, qw(diff --quiet HEAD));
1698 $!=0; $?=0; system @cmd;
1699 return if !$! && !$?;
1700 if (!$! && $?==256) {
1701 fail "working tree is dirty (does not match HEAD)";
1707 sub commit_admin ($) {
1710 runcmd_ordryrun_local @git, qw(commit -m), $m;
1713 sub commit_quilty_patch () {
1714 my $output = cmdoutput @git, qw(status --porcelain);
1716 foreach my $l (split /\n/, $output) {
1717 next unless $l =~ m/\S/;
1718 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1722 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1724 progress "nothing quilty to commit, ok.";
1727 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1728 commit_admin "Commit Debian 3.0 (quilt) metadata";
1731 sub get_source_format () {
1732 if (!open F, "debian/source/format") {
1733 die $! unless $!==&ENOENT;
1737 F->error and die $!;
1744 return 0 unless $format eq '3.0 (quilt)';
1745 if ($quilt_mode eq 'nocheck') {
1746 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1749 progress "Format \`$format', checking/updating patch stack";
1753 sub push_parse_changelog ($) {
1756 my $clogp = Dpkg::Control::Hash->new();
1757 $clogp->load($clogpfn) or die;
1759 $package = getfield $clogp, 'Source';
1760 my $cversion = getfield $clogp, 'Version';
1761 my $tag = debiantag($cversion, access_basedistro);
1762 runcmd @git, qw(check-ref-format), $tag;
1764 my $dscfn = dscfn($cversion);
1766 return ($clogp, $cversion, $tag, $dscfn);
1769 sub push_parse_dsc ($$$) {
1770 my ($dscfn,$dscfnwhat, $cversion) = @_;
1771 $dsc = parsecontrol($dscfn,$dscfnwhat);
1772 my $dversion = getfield $dsc, 'Version';
1773 my $dscpackage = getfield $dsc, 'Source';
1774 ($dscpackage eq $package && $dversion eq $cversion) or
1775 fail "$dscfn is for $dscpackage $dversion".
1776 " but debian/changelog is for $package $cversion";
1779 sub push_mktag ($$$$$$$) {
1780 my ($head,$clogp,$tag,
1782 $changesfile,$changesfilewhat,
1785 $dsc->{$ourdscfield[0]} = $head;
1786 $dsc->save("$dscfn.tmp") or die $!;
1788 my $changes = parsecontrol($changesfile,$changesfilewhat);
1789 foreach my $field (qw(Source Distribution Version)) {
1790 $changes->{$field} eq $clogp->{$field} or
1791 fail "changes field $field \`$changes->{$field}'".
1792 " does not match changelog \`$clogp->{$field}'";
1795 my $cversion = getfield $clogp, 'Version';
1796 my $clogsuite = getfield $clogp, 'Distribution';
1798 # We make the git tag by hand because (a) that makes it easier
1799 # to control the "tagger" (b) we can do remote signing
1800 my $authline = clogp_authline $clogp;
1801 my $delibs = join(" ", "",@deliberatelies);
1802 my $declaredistro = access_basedistro();
1803 open TO, '>', $tfn->('.tmp') or die $!;
1804 print TO <<END or die $!;
1810 $package release $cversion for $clogsuite ($csuite) [dgit]
1811 [dgit distro=$declaredistro$delibs]
1813 foreach my $ref (sort keys %previously) {
1814 print TO <<END or die $!;
1815 [dgit previously:$ref=$previously{$ref}]
1821 my $tagobjfn = $tfn->('.tmp');
1823 if (!defined $keyid) {
1824 $keyid = access_cfg('keyid','RETURN-UNDEF');
1826 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1827 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1828 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1829 push @sign_cmd, $tfn->('.tmp');
1830 runcmd_ordryrun @sign_cmd;
1832 $tagobjfn = $tfn->('.signed.tmp');
1833 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1834 $tfn->('.tmp'), $tfn->('.tmp.asc');
1841 sub sign_changes ($) {
1842 my ($changesfile) = @_;
1844 my @debsign_cmd = @debsign;
1845 push @debsign_cmd, "-k$keyid" if defined $keyid;
1846 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1847 push @debsign_cmd, $changesfile;
1848 runcmd_ordryrun @debsign_cmd;
1853 my ($forceflag) = @_;
1854 printdebug "actually entering push\n";
1855 supplementary_message(<<'END');
1856 Push failed, while preparing your push.
1857 You can retry the push, after fixing the problem, if you like.
1861 access_giturl(); # check that success is vaguely likely
1863 my $clogpfn = ".git/dgit/changelog.822.tmp";
1864 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1866 responder_send_file('parsed-changelog', $clogpfn);
1868 my ($clogp, $cversion, $tag, $dscfn) =
1869 push_parse_changelog("$clogpfn");
1871 my $dscpath = "$buildproductsdir/$dscfn";
1872 stat_exists $dscpath or
1873 fail "looked for .dsc $dscfn, but $!;".
1874 " maybe you forgot to build";
1876 responder_send_file('dsc', $dscpath);
1878 push_parse_dsc($dscpath, $dscfn, $cversion);
1880 my $format = getfield $dsc, 'Format';
1881 printdebug "format $format\n";
1882 if (madformat($format)) {
1883 commit_quilty_patch();
1887 progress "checking that $dscfn corresponds to HEAD";
1888 runcmd qw(dpkg-source -x --),
1889 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1890 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1891 check_for_vendor_patches() if madformat($dsc->{format});
1892 changedir '../../../..';
1893 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1894 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1895 debugcmd "+",@diffcmd;
1897 my $r = system @diffcmd;
1900 fail "$dscfn specifies a different tree to your HEAD commit;".
1901 " perhaps you forgot to build".
1902 ($diffopt eq '--exit-code' ? "" :
1903 " (run with -D to see full diff output)");
1908 my $head = git_rev_parse('HEAD');
1909 if (!$changesfile) {
1910 my $multi = "$buildproductsdir/".
1911 "${package}_".(stripepoch $cversion)."_multi.changes";
1912 if (stat_exists "$multi") {
1913 $changesfile = $multi;
1915 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1916 my @cs = glob "$buildproductsdir/$pat";
1917 fail "failed to find unique changes file".
1918 " (looked for $pat in $buildproductsdir, or $multi);".
1919 " perhaps you need to use dgit -C"
1921 ($changesfile) = @cs;
1924 $changesfile = "$buildproductsdir/$changesfile";
1927 responder_send_file('changes',$changesfile);
1928 responder_send_command("param head $head");
1929 responder_send_command("param csuite $csuite");
1931 if (deliberately_not_fast_forward) {
1932 git_for_each_ref(lrfetchrefs, sub {
1933 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1934 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1935 responder_send_command("previously $rrefname=$objid");
1936 $previously{$rrefname} = $objid;
1940 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1943 supplementary_message(<<'END');
1944 Push failed, while signing the tag.
1945 You can retry the push, after fixing the problem, if you like.
1947 # If we manage to sign but fail to record it anywhere, it's fine.
1948 if ($we_are_responder) {
1949 $tagobjfn = $tfn->('.signed.tmp');
1950 responder_receive_files('signed-tag', $tagobjfn);
1953 push_mktag($head,$clogp,$tag,
1955 $changesfile,$changesfile,
1958 supplementary_message(<<'END');
1959 Push failed, *after* signing the tag.
1960 If you want to try again, you should use a new version number.
1963 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1964 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1965 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1967 supplementary_message(<<'END');
1968 Push failed, while updating the remote git repository - see messages above.
1969 If you want to try again, you should use a new version number.
1971 if (!check_for_git()) {
1972 create_remote_git_repo();
1974 runcmd_ordryrun @git, qw(push),access_giturl(),
1975 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1976 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1978 supplementary_message(<<'END');
1979 Push failed, after updating the remote git repository.
1980 If you want to try again, you must use a new version number.
1982 if ($we_are_responder) {
1983 my $dryrunsuffix = act_local() ? "" : ".tmp";
1984 responder_receive_files('signed-dsc-changes',
1985 "$dscpath$dryrunsuffix",
1986 "$changesfile$dryrunsuffix");
1989 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1991 progress "[new .dsc left in $dscpath.tmp]";
1993 sign_changes $changesfile;
1996 supplementary_message(<<'END');
1997 Push failed, while uploading package(s) to the archive server.
1998 You can retry the upload of exactly these same files with dput of:
2000 If that .changes file is broken, you will need to use a new version
2001 number for your next attempt at the upload.
2003 my $host = access_cfg('upload-host','RETURN-UNDEF');
2004 my @hostarg = defined($host) ? ($host,) : ();
2005 runcmd_ordryrun @dput, @hostarg, $changesfile;
2006 printdone "pushed and uploaded $cversion";
2008 supplementary_message('');
2009 responder_send_command("complete");
2016 badusage "-p is not allowed with clone; specify as argument instead"
2017 if defined $package;
2020 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2021 ($package,$isuite) = @ARGV;
2022 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2023 ($package,$dstdir) = @ARGV;
2024 } elsif (@ARGV==3) {
2025 ($package,$isuite,$dstdir) = @ARGV;
2027 badusage "incorrect arguments to dgit clone";
2029 $dstdir ||= "$package";
2031 if (stat_exists $dstdir) {
2032 fail "$dstdir already exists";
2036 if ($rmonerror && !$dryrun_level) {
2037 $cwd_remove= getcwd();
2039 return unless defined $cwd_remove;
2040 if (!chdir "$cwd_remove") {
2041 return if $!==&ENOENT;
2042 die "chdir $cwd_remove: $!";
2044 rmtree($dstdir) or die "remove $dstdir: $!\n";
2049 $cwd_remove = undef;
2052 sub branchsuite () {
2053 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2054 if ($branch =~ m#$lbranch_re#o) {
2061 sub fetchpullargs () {
2063 if (!defined $package) {
2064 my $sourcep = parsecontrol('debian/control','debian/control');
2065 $package = getfield $sourcep, 'Source';
2068 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2070 my $clogp = parsechangelog();
2071 $isuite = getfield $clogp, 'Distribution';
2073 canonicalise_suite();
2074 progress "fetching from suite $csuite";
2075 } elsif (@ARGV==1) {
2077 canonicalise_suite();
2079 badusage "incorrect arguments to dgit fetch or dgit pull";
2098 badusage "-p is not allowed with dgit push" if defined $package;
2100 my $clogp = parsechangelog();
2101 $package = getfield $clogp, 'Source';
2104 } elsif (@ARGV==1) {
2105 ($specsuite) = (@ARGV);
2107 badusage "incorrect arguments to dgit push";
2109 $isuite = getfield $clogp, 'Distribution';
2111 local ($package) = $existing_package; # this is a hack
2112 canonicalise_suite();
2114 canonicalise_suite();
2116 if (defined $specsuite &&
2117 $specsuite ne $isuite &&
2118 $specsuite ne $csuite) {
2119 fail "dgit push: changelog specifies $isuite ($csuite)".
2120 " but command line specifies $specsuite";
2122 supplementary_message(<<'END');
2123 Push failed, while checking state of the archive.
2124 You can retry the push, after fixing the problem, if you like.
2126 if (check_for_git()) {
2130 if (fetch_from_archive()) {
2131 if (is_fast_fwd(lrref(), 'HEAD')) {
2133 } elsif (deliberately_not_fast_forward) {
2136 fail "dgit push: HEAD is not a descendant".
2137 " of the archive's version.\n".
2138 "dgit: To overwrite its contents,".
2139 " use git merge -s ours ".lrref().".\n".
2140 "dgit: To rewind history, if permitted by the archive,".
2141 " use --deliberately-not-fast-forward";
2145 fail "package appears to be new in this suite;".
2146 " if this is intentional, use --new";
2151 #---------- remote commands' implementation ----------
2153 sub cmd_remote_push_build_host {
2154 my ($nrargs) = shift @ARGV;
2155 my (@rargs) = @ARGV[0..$nrargs-1];
2156 @ARGV = @ARGV[$nrargs..$#ARGV];
2158 my ($dir,$vsnwant) = @rargs;
2159 # vsnwant is a comma-separated list; we report which we have
2160 # chosen in our ready response (so other end can tell if they
2163 $we_are_responder = 1;
2164 $us .= " (build host)";
2168 open PI, "<&STDIN" or die $!;
2169 open STDIN, "/dev/null" or die $!;
2170 open PO, ">&STDOUT" or die $!;
2172 open STDOUT, ">&STDERR" or die $!;
2176 ($protovsn) = grep {
2177 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2178 } @rpushprotovsn_support;
2180 fail "build host has dgit rpush protocol versions ".
2181 (join ",", @rpushprotovsn_support).
2182 " but invocation host has $vsnwant"
2183 unless defined $protovsn;
2185 responder_send_command("dgit-remote-push-ready $protovsn");
2191 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2192 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2193 # a good error message)
2199 my $report = i_child_report();
2200 if (defined $report) {
2201 printdebug "($report)\n";
2202 } elsif ($i_child_pid) {
2203 printdebug "(killing build host child $i_child_pid)\n";
2204 kill 15, $i_child_pid;
2206 if (defined $i_tmp && !defined $initiator_tempdir) {
2208 eval { rmtree $i_tmp; };
2212 END { i_cleanup(); }
2215 my ($base,$selector,@args) = @_;
2216 $selector =~ s/\-/_/g;
2217 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2224 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2232 push @rargs, join ",", @rpushprotovsn_support;
2235 push @rdgit, @ropts;
2236 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2238 my @cmd = (@ssh, $host, shellquote @rdgit);
2241 if (defined $initiator_tempdir) {
2242 rmtree $initiator_tempdir;
2243 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2244 $i_tmp = $initiator_tempdir;
2248 $i_child_pid = open2(\*RO, \*RI, @cmd);
2250 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2251 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2252 $supplementary_message = '' unless $protovsn >= 3;
2254 my ($icmd,$iargs) = initiator_expect {
2255 m/^(\S+)(?: (.*))?$/;
2258 i_method "i_resp", $icmd, $iargs;
2262 sub i_resp_progress ($) {
2264 my $msg = protocol_read_bytes \*RO, $rhs;
2268 sub i_resp_supplementary_message ($) {
2270 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2273 sub i_resp_complete {
2274 my $pid = $i_child_pid;
2275 $i_child_pid = undef; # prevents killing some other process with same pid
2276 printdebug "waiting for build host child $pid...\n";
2277 my $got = waitpid $pid, 0;
2278 die $! unless $got == $pid;
2279 die "build host child failed $?" if $?;
2282 printdebug "all done\n";
2286 sub i_resp_file ($) {
2288 my $localname = i_method "i_localname", $keyword;
2289 my $localpath = "$i_tmp/$localname";
2290 stat_exists $localpath and
2291 badproto \*RO, "file $keyword ($localpath) twice";
2292 protocol_receive_file \*RO, $localpath;
2293 i_method "i_file", $keyword;
2298 sub i_resp_param ($) {
2299 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2303 sub i_resp_previously ($) {
2304 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2305 or badproto \*RO, "bad previously spec";
2306 my $r = system qw(git check-ref-format), $1;
2307 die "bad previously ref spec ($r)" if $r;
2308 $previously{$1} = $2;
2313 sub i_resp_want ($) {
2315 die "$keyword ?" if $i_wanted{$keyword}++;
2316 my @localpaths = i_method "i_want", $keyword;
2317 printdebug "[[ $keyword @localpaths\n";
2318 foreach my $localpath (@localpaths) {
2319 protocol_send_file \*RI, $localpath;
2321 print RI "files-end\n" or die $!;
2324 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2326 sub i_localname_parsed_changelog {
2327 return "remote-changelog.822";
2329 sub i_file_parsed_changelog {
2330 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2331 push_parse_changelog "$i_tmp/remote-changelog.822";
2332 die if $i_dscfn =~ m#/|^\W#;
2335 sub i_localname_dsc {
2336 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2341 sub i_localname_changes {
2342 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2343 $i_changesfn = $i_dscfn;
2344 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2345 return $i_changesfn;
2347 sub i_file_changes { }
2349 sub i_want_signed_tag {
2350 printdebug Dumper(\%i_param, $i_dscfn);
2351 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2352 && defined $i_param{'csuite'}
2353 or badproto \*RO, "premature desire for signed-tag";
2354 my $head = $i_param{'head'};
2355 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2357 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2359 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2362 push_mktag $head, $i_clogp, $i_tag,
2364 $i_changesfn, 'remote changes',
2365 sub { "tag$_[0]"; };
2370 sub i_want_signed_dsc_changes {
2371 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2372 sign_changes $i_changesfn;
2373 return ($i_dscfn, $i_changesfn);
2376 #---------- building etc. ----------
2382 #----- `3.0 (quilt)' handling -----
2384 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2386 sub quiltify_dpkg_commit ($$$;$) {
2387 my ($patchname,$author,$msg, $xinfo) = @_;
2391 my $descfn = ".git/dgit/quilt-description.tmp";
2392 open O, '>', $descfn or die "$descfn: $!";
2395 $msg =~ s/^\s+$/ ./mg;
2396 print O <<END or die $!;
2406 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2407 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2408 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2409 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2413 sub quiltify_trees_differ ($$) {
2415 # returns 1 iff the two tree objects differ other than in debian/
2417 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2418 my $diffs= cmdoutput @cmd;
2419 foreach my $f (split /\0/, $diffs) {
2420 next if $f eq 'debian';
2426 sub quiltify_tree_sentinelfiles ($) {
2427 # lists the `sentinel' files present in the tree
2429 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2430 qw(-- debian/rules debian/control);
2436 my ($clogp,$target) = @_;
2438 # Quilt patchification algorithm
2440 # We search backwards through the history of the main tree's HEAD
2441 # (T) looking for a start commit S whose tree object is identical
2442 # to to the patch tip tree (ie the tree corresponding to the
2443 # current dpkg-committed patch series). For these purposes
2444 # `identical' disregards anything in debian/ - this wrinkle is
2445 # necessary because dpkg-source treates debian/ specially.
2447 # We can only traverse edges where at most one of the ancestors'
2448 # trees differs (in changes outside in debian/). And we cannot
2449 # handle edges which change .pc/ or debian/patches. To avoid
2450 # going down a rathole we avoid traversing edges which introduce
2451 # debian/rules or debian/control. And we set a limit on the
2452 # number of edges we are willing to look at.
2454 # If we succeed, we walk forwards again. For each traversed edge
2455 # PC (with P parent, C child) (starting with P=S and ending with
2456 # C=T) to we do this:
2458 # - dpkg-source --commit with a patch name and message derived from C
2459 # After traversing PT, we git commit the changes which
2460 # should be contained within debian/patches.
2462 changedir '../fake';
2463 mktree_in_ud_here();
2465 runcmd @git, 'add', '.';
2466 my $oldtiptree=git_write_tree();
2467 changedir '../work';
2469 # The search for the path S..T is breadth-first. We maintain a
2470 # todo list containing search nodes. A search node identifies a
2471 # commit, and looks something like this:
2473 # Commit => $git_commit_id,
2474 # Child => $c, # or undef if P=T
2475 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2476 # Nontrivial => true iff $p..$c has relevant changes
2483 my %considered; # saves being exponential on some weird graphs
2485 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2488 my ($search,$whynot) = @_;
2489 printdebug " search NOT $search->{Commit} $whynot\n";
2490 $search->{Whynot} = $whynot;
2491 push @nots, $search;
2492 no warnings qw(exiting);
2501 my $c = shift @todo;
2502 next if $considered{$c->{Commit}}++;
2504 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2506 printdebug "quiltify investigate $c->{Commit}\n";
2509 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2510 printdebug " search finished hooray!\n";
2515 if ($quilt_mode eq 'nofix') {
2516 fail "quilt fixup required but quilt mode is \`nofix'\n".
2517 "HEAD commit $c->{Commit} differs from tree implied by ".
2518 " debian/patches (tree object $oldtiptree)";
2520 if ($quilt_mode eq 'smash') {
2521 printdebug " search quitting smash\n";
2525 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2526 $not->($c, "has $c_sentinels not $t_sentinels")
2527 if $c_sentinels ne $t_sentinels;
2529 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2530 $commitdata =~ m/\n\n/;
2532 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2533 @parents = map { { Commit => $_, Child => $c } } @parents;
2535 $not->($c, "root commit") if !@parents;
2537 foreach my $p (@parents) {
2538 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2540 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2541 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2543 foreach my $p (@parents) {
2544 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2546 my @cmd= (@git, qw(diff-tree -r --name-only),
2547 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2548 my $patchstackchange = cmdoutput @cmd;
2549 if (length $patchstackchange) {
2550 $patchstackchange =~ s/\n/,/g;
2551 $not->($p, "changed $patchstackchange");
2554 printdebug " search queue P=$p->{Commit} ",
2555 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2561 printdebug "quiltify want to smash\n";
2564 my $x = $_[0]{Commit};
2565 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2568 my $reportnot = sub {
2570 my $s = $abbrev->($notp);
2571 my $c = $notp->{Child};
2572 $s .= "..".$abbrev->($c) if $c;
2573 $s .= ": ".$notp->{Whynot};
2576 if ($quilt_mode eq 'linear') {
2577 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2578 foreach my $notp (@nots) {
2579 print STDERR "$us: ", $reportnot->($notp), "\n";
2581 fail "quilt fixup naive history linearisation failed.\n".
2582 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2583 } elsif ($quilt_mode eq 'smash') {
2584 } elsif ($quilt_mode eq 'auto') {
2585 progress "quilt fixup cannot be linear, smashing...";
2587 die "$quilt_mode ?";
2592 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2594 quiltify_dpkg_commit "auto-$version-$target-$time",
2595 (getfield $clogp, 'Maintainer'),
2596 "Automatically generated patch ($clogp->{Version})\n".
2597 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2601 progress "quiltify linearisation planning successful, executing...";
2603 for (my $p = $sref_S;
2604 my $c = $p->{Child};
2606 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2607 next unless $p->{Nontrivial};
2609 my $cc = $c->{Commit};
2611 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2612 $commitdata =~ m/\n\n/ or die "$c ?";
2615 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2618 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2621 my $patchname = $title;
2622 $patchname =~ s/[.:]$//;
2623 $patchname =~ y/ A-Z/-a-z/;
2624 $patchname =~ y/-a-z0-9_.+=~//cd;
2625 $patchname =~ s/^\W/x-$&/;
2626 $patchname = substr($patchname,0,40);
2629 stat "debian/patches/$patchname$index";
2631 $!==ENOENT or die "$patchname$index $!";
2633 runcmd @git, qw(checkout -q), $cc;
2635 # We use the tip's changelog so that dpkg-source doesn't
2636 # produce complaining messages from dpkg-parsechangelog. None
2637 # of the information dpkg-source gets from the changelog is
2638 # actually relevant - it gets put into the original message
2639 # which dpkg-source provides our stunt editor, and then
2641 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2643 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2644 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2646 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2649 runcmd @git, qw(checkout -q master);
2652 sub build_maybe_quilt_fixup () {
2653 my $format=get_source_format;
2654 return unless madformat $format;
2657 check_for_vendor_patches();
2660 # - honour any existing .pc in case it has any strangeness
2661 # - determine the git commit corresponding to the tip of
2662 # the patch stack (if there is one)
2663 # - if there is such a git commit, convert each subsequent
2664 # git commit into a quilt patch with dpkg-source --commit
2665 # - otherwise convert all the differences in the tree into
2666 # a single git commit
2670 # Our git tree doesn't necessarily contain .pc. (Some versions of
2671 # dgit would include the .pc in the git tree.) If there isn't
2672 # one, we need to generate one by unpacking the patches that we
2675 # We first look for a .pc in the git tree. If there is one, we
2676 # will use it. (This is not the normal case.)
2678 # Otherwise need to regenerate .pc so that dpkg-source --commit
2679 # can work. We do this as follows:
2680 # 1. Collect all relevant .orig from parent directory
2681 # 2. Generate a debian.tar.gz out of
2682 # debian/{patches,rules,source/format}
2683 # 3. Generate a fake .dsc containing just these fields:
2684 # Format Source Version Files
2685 # 4. Extract the fake .dsc
2686 # Now the fake .dsc has a .pc directory.
2687 # (In fact we do this in every case, because in future we will
2688 # want to search for a good base commit for generating patches.)
2690 # Then we can actually do the dpkg-source --commit
2691 # 1. Make a new working tree with the same object
2692 # store as our main tree and check out the main
2694 # 2. Copy .pc from the fake's extraction, if necessary
2695 # 3. Run dpkg-source --commit
2696 # 4. If the result has changes to debian/, then
2697 # - git-add them them
2698 # - git-add .pc if we had a .pc in-tree
2700 # 5. If we had a .pc in-tree, delete it, and git-commit
2701 # 6. Back in the main tree, fast forward to the new HEAD
2703 my $clogp = parsechangelog();
2704 my $headref = git_rev_parse('HEAD');
2709 my $upstreamversion=$version;
2710 $upstreamversion =~ s/-[^-]*$//;
2712 my $fakeversion="$upstreamversion-~~DGITFAKE";
2714 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2715 print $fakedsc <<END or die $!;
2718 Version: $fakeversion
2722 my $dscaddfile=sub {
2725 my $md = new Digest::MD5;
2727 my $fh = new IO::File $b, '<' or die "$b $!";
2732 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2735 foreach my $f (<../../../../*>) { #/){
2736 my $b=$f; $b =~ s{.*/}{};
2737 next unless is_orig_file $b, srcfn $upstreamversion,'';
2738 link $f, $b or die "$b $!";
2742 my @files=qw(debian/source/format debian/rules);
2743 if (stat_exists '../../../debian/patches') {
2744 push @files, 'debian/patches';
2747 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2748 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2750 $dscaddfile->($debtar);
2751 close $fakedsc or die $!;
2753 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2755 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2756 rename $fakexdir, "fake" or die "$fakexdir $!";
2758 mkdir "work" or die $!;
2760 mktree_in_ud_here();
2761 runcmd @git, qw(reset --hard), $headref;
2764 if (stat_exists ".pc") {
2766 progress "Tree already contains .pc - will use it then delete it.";
2769 rename '../fake/.pc','.pc' or die $!;
2772 quiltify($clogp,$headref);
2774 if (!open P, '>>', ".pc/applied-patches") {
2775 $!==&ENOENT or die $!;
2780 commit_quilty_patch();
2782 if ($mustdeletepc) {
2783 runcmd @git, qw(rm -rqf .pc);
2784 commit_admin "Commit removal of .pc (quilt series tracking data)";
2787 changedir '../../../..';
2788 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2791 sub quilt_fixup_editor () {
2792 my $descfn = $ENV{$fakeeditorenv};
2793 my $editing = $ARGV[$#ARGV];
2794 open I1, '<', $descfn or die "$descfn: $!";
2795 open I2, '<', $editing or die "$editing: $!";
2796 unlink $editing or die "$editing: $!";
2797 open O, '>', $editing or die "$editing: $!";
2798 while (<I1>) { print O or die $!; } I1->error and die $!;
2801 $copying ||= m/^\-\-\- /;
2802 next unless $copying;
2805 I2->error and die $!;
2810 #----- other building -----
2813 if ($cleanmode eq 'dpkg-source') {
2814 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2815 } elsif ($cleanmode eq 'dpkg-source-d') {
2816 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2817 } elsif ($cleanmode eq 'git') {
2818 runcmd_ordryrun_local @git, qw(clean -xdf);
2819 } elsif ($cleanmode eq 'git-ff') {
2820 runcmd_ordryrun_local @git, qw(clean -xdff);
2821 } elsif ($cleanmode eq 'check') {
2822 my $leftovers = cmdoutput @git, qw(clean -xdn);
2823 if (length $leftovers) {
2824 print STDERR $leftovers, "\n" or die $!;
2825 fail "tree contains uncommitted files and --clean=check specified";
2827 } elsif ($cleanmode eq 'none') {
2834 badusage "clean takes no additional arguments" if @ARGV;
2841 badusage "-p is not allowed when building" if defined $package;
2844 my $clogp = parsechangelog();
2845 $isuite = getfield $clogp, 'Distribution';
2846 $package = getfield $clogp, 'Source';
2847 $version = getfield $clogp, 'Version';
2848 build_maybe_quilt_fixup();
2851 sub changesopts () {
2852 my @opts =@changesopts[1..$#changesopts];
2853 if (!defined $changes_since_version) {
2854 my @vsns = archive_query('archive_query');
2855 my @quirk = access_quirk();
2856 if ($quirk[0] eq 'backports') {
2857 local $isuite = $quirk[2];
2859 canonicalise_suite();
2860 push @vsns, archive_query('archive_query');
2863 @vsns = map { $_->[0] } @vsns;
2864 @vsns = sort { -version_compare($a, $b) } @vsns;
2865 $changes_since_version = $vsns[0];
2866 progress "changelog will contain changes since $vsns[0]";
2868 $changes_since_version = '_';
2869 progress "package seems new, not specifying -v<version>";
2872 if ($changes_since_version ne '_') {
2873 unshift @opts, "-v$changes_since_version";
2878 sub massage_dbp_args ($) {
2880 return unless $cleanmode =~ m/git|none/;
2881 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2882 my @newcmd = shift @$cmd;
2883 # -nc has the side effect of specifying -b if nothing else specified
2884 push @newcmd, '-nc';
2885 # and some combinations of -S, -b, et al, are errors, rather than
2886 # later simply overriding earlier
2887 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2888 push @newcmd, @$cmd;
2894 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2895 massage_dbp_args \@dbp;
2896 runcmd_ordryrun_local @dbp;
2897 printdone "build successful\n";
2902 my @dbp = @dpkgbuildpackage;
2903 massage_dbp_args \@dbp;
2905 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2906 "--git-builder=@dbp");
2907 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2908 canonicalise_suite();
2909 push @cmd, "--git-debian-branch=".lbranch();
2911 push @cmd, changesopts();
2912 runcmd_ordryrun_local @cmd, @ARGV;
2913 printdone "build successful\n";
2918 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2919 $dscfn = dscfn($version);
2920 if ($cleanmode eq 'dpkg-source') {
2921 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2923 } elsif ($cleanmode eq 'dpkg-source-d') {
2924 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2927 my $pwd = must_getcwd();
2928 my $leafdir = basename $pwd;
2930 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2932 runcmd_ordryrun_local qw(sh -ec),
2933 'exec >$1; shift; exec "$@"','x',
2934 "../$sourcechanges",
2935 @dpkggenchanges, qw(-S), changesopts();
2939 sub cmd_build_source {
2940 badusage "build-source takes no additional arguments" if @ARGV;
2942 printdone "source built, results in $dscfn and $sourcechanges";
2948 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2950 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2951 stat_exists $sourcechanges
2952 or fail "$sourcechanges (in parent directory): $!";
2953 foreach my $cf (glob $pat) {
2954 next if $cf eq $sourcechanges;
2955 unlink $cf or fail "remove $cf: $!";
2958 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2959 my @changesfiles = glob $pat;
2960 @changesfiles = sort {
2961 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2964 fail "wrong number of different changes files (@changesfiles)"
2965 unless @changesfiles;
2966 runcmd_ordryrun_local @mergechanges, @changesfiles;
2967 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2969 stat_exists $multichanges or fail "$multichanges: $!";
2971 printdone "build successful, results in $multichanges\n" or die $!;
2974 sub cmd_quilt_fixup {
2975 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2976 my $clogp = parsechangelog();
2977 $version = getfield $clogp, 'Version';
2978 $package = getfield $clogp, 'Source';
2979 build_maybe_quilt_fixup();
2982 sub cmd_archive_api_query {
2983 badusage "need only 1 subpath argument" unless @ARGV==1;
2984 my ($subpath) = @ARGV;
2985 my @cmd = archive_api_query_cmd($subpath);
2987 exec @cmd or fail "exec curl: $!\n";
2990 sub cmd_clone_dgit_repos_server {
2991 badusage "need destination argument" unless @ARGV==1;
2992 my ($destdir) = @ARGV;
2993 $package = '_dgit-repos-server';
2994 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2996 exec @cmd or fail "exec git clone: $!\n";
2999 sub cmd_setup_mergechangelogs {
3000 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3001 setup_mergechangelogs();
3004 #---------- argument parsing and main program ----------
3007 print "dgit version $our_version\n" or die $!;
3014 if (defined $ENV{'DGIT_SSH'}) {
3015 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3016 } elsif (defined $ENV{'GIT_SSH'}) {
3017 @ssh = ($ENV{'GIT_SSH'});
3021 last unless $ARGV[0] =~ m/^-/;
3025 if (m/^--dry-run$/) {
3028 } elsif (m/^--damp-run$/) {
3031 } elsif (m/^--no-sign$/) {
3034 } elsif (m/^--help$/) {
3036 } elsif (m/^--version$/) {
3038 } elsif (m/^--new$/) {
3041 } elsif (m/^--since-version=([^_]+|_)$/) {
3043 $changes_since_version = $1;
3044 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3045 ($om = $opts_opt_map{$1}) &&
3049 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3050 !$opts_opt_cmdonly{$1} &&
3051 ($om = $opts_opt_map{$1})) {
3053 push @{ $opts_opt_cmdline_opts{$1} }, $2;
3054 } elsif (m/^--existing-package=(.*)/s) {
3056 $existing_package = $1;
3057 } elsif (m/^--initiator-tempdir=(.*)/s) {
3058 $initiator_tempdir = $1;
3059 $initiator_tempdir =~ m#^/# or
3060 badusage "--initiator-tempdir must be used specify an".
3061 " absolute, not relative, directory."
3062 } elsif (m/^--distro=(.*)/s) {
3065 } elsif (m/^--build-products-dir=(.*)/s) {
3067 $buildproductsdir = $1;
3068 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3071 } elsif (m/^--clean=(.*)$/s) {
3072 badusage "unknown cleaning mode \`$1'";
3073 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3076 } elsif (m/^--quilt=(.*)$/s) {
3077 badusage "unknown quilt fixup mode \`$1'";
3078 } elsif (m/^--ignore-dirty$/s) {
3081 } elsif (m/^--no-quilt-fixup$/s) {
3083 $quilt_mode = 'nocheck';
3084 } elsif (m/^--no-rm-on-error$/s) {
3087 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3089 push @deliberatelies, $&;
3091 badusage "unknown long option \`$_'";
3098 } elsif (s/^-L/-/) {
3101 } elsif (s/^-h/-/) {
3103 } elsif (s/^-D/-/) {
3107 } elsif (s/^-N/-/) {
3110 } elsif (s/^-v([^_]+|_)$//s) {
3112 $changes_since_version = $1;
3115 push @changesopts, $_;
3117 } elsif (s/^-c(.*=.*)//s) {
3119 push @git, '-c', $1;
3120 } elsif (s/^-d(.+)//s) {
3123 } elsif (s/^-C(.+)//s) {
3126 if ($changesfile =~ s#^(.*)/##) {
3127 $buildproductsdir = $1;
3129 } elsif (s/^-k(.+)//s) {
3131 } elsif (m/^-[vdCk]$/) {
3133 "option \`$_' requires an argument (and no space before the argument)";
3134 } elsif (s/^-wn$//s) {
3136 $cleanmode = 'none';
3137 } elsif (s/^-wg$//s) {
3140 } elsif (s/^-wgf$//s) {
3142 $cleanmode = 'git-ff';
3143 } elsif (s/^-wd$//s) {
3145 $cleanmode = 'dpkg-source';
3146 } elsif (s/^-wdd$//s) {
3148 $cleanmode = 'dpkg-source-d';
3149 } elsif (s/^-wc$//s) {
3151 $cleanmode = 'check';
3153 badusage "unknown short option \`$_'";
3160 sub finalise_opts_opts () {
3161 foreach my $k (keys %opts_opt_cmdline_opts) {
3162 push @{ $opts_opt_map{$k} }, @{ $opts_opt_cmdline_opts{$k} };
3166 if ($ENV{$fakeeditorenv}) {
3167 quilt_fixup_editor();
3172 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3173 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3174 if $dryrun_level == 1;
3176 print STDERR $helpmsg or die $!;
3179 my $cmd = shift @ARGV;
3182 if (!defined $quilt_mode) {
3183 local $access_forpush;
3184 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3185 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3187 $quilt_mode =~ m/^($quilt_modes_re)$/
3188 or badcfg "unknown quilt-mode \`$quilt_mode'";
3192 my $fn = ${*::}{"cmd_$cmd"};
3193 $fn or badusage "unknown operation $cmd";