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/>.
21 $SIG{__WARN__} = sub { die $_[0]; };
26 use Dpkg::Control::Hash;
28 use File::Temp qw(tempdir);
38 our $our_version = 'UNRELEASED'; ###substituted###
40 our $rpushprotovsn = 2;
42 our $isuite = 'unstable';
48 our $dryrun_level = 0;
50 our $buildproductsdir = '..';
56 our $existing_package = 'dpkg';
57 our $cleanmode = 'dpkg-source';
58 our $changes_since_version;
60 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
61 our $we_are_responder;
62 our $initiator_tempdir;
64 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
66 our $suite_re = '[-+.0-9a-z]+';
69 our (@dget) = qw(dget);
70 our (@curl) = qw(curl -f);
71 our (@dput) = qw(dput);
72 our (@debsign) = qw(debsign);
74 our (@sbuild) = qw(sbuild -A);
76 our (@dgit) = qw(dgit);
77 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
78 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
79 our (@dpkggenchanges) = qw(dpkg-genchanges);
80 our (@mergechanges) = qw(mergechanges -f);
81 our (@changesopts) = ('');
83 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
86 'debsign' => \@debsign,
91 'dpkg-source' => \@dpkgsource,
92 'dpkg-buildpackage' => \@dpkgbuildpackage,
93 'dpkg-genchanges' => \@dpkggenchanges,
94 'ch' => \@changesopts,
95 'mergechanges' => \@mergechanges);
97 our %opts_opt_cmdonly = ('gpg' => 1);
103 our $remotename = 'dgit';
104 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
108 sub lbranch () { return "$branchprefix/$csuite"; }
109 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
110 sub lref () { return "refs/heads/".lbranch(); }
111 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
112 sub rrref () { return server_ref($csuite); }
114 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
124 return "${package}_".(stripepoch $vsn).$sfx
129 return srcfn($vsn,".dsc");
138 foreach my $f (@end) {
140 warn "$us: cleanup: $@" if length $@;
144 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
146 sub no_such_package () {
147 print STDERR "$us: package $package does not exist in suite $isuite\n";
153 return "+".rrref().":".lrref();
158 printdebug "CD $newdir\n";
159 chdir $newdir or die "chdir: $newdir: $!";
162 sub deliberately ($) {
164 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
167 sub deliberately_not_fast_forward () {
168 foreach (qw(not-fast-forward fresh-repo)) {
169 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
173 #---------- remote protocol support, common ----------
175 # remote push initiator/responder protocol:
176 # < dgit-remote-push-ready [optional extra info ignored by old initiators]
178 # > file parsed-changelog
179 # [indicates that output of dpkg-parsechangelog follows]
180 # > data-block NBYTES
181 # > [NBYTES bytes of data (no newline)]
182 # [maybe some more blocks]
194 # [indicates that signed tag is wanted]
195 # < data-block NBYTES
196 # < [NBYTES bytes of data (no newline)]
197 # [maybe some more blocks]
201 # > want signed-dsc-changes
202 # < data-block NBYTES [transfer of signed dsc]
204 # < data-block NBYTES [transfer of signed changes]
212 sub i_child_report () {
213 # Sees if our child has died, and reap it if so. Returns a string
214 # describing how it died if it failed, or undef otherwise.
215 return undef unless $i_child_pid;
216 my $got = waitpid $i_child_pid, WNOHANG;
217 return undef if $got <= 0;
218 die unless $got == $i_child_pid;
219 $i_child_pid = undef;
220 return undef unless $?;
221 return "build host child ".waitstatusmsg();
226 fail "connection lost: $!" if $fh->error;
227 fail "protocol violation; $m not expected";
230 sub badproto_badread ($$) {
232 fail "connection lost: $!" if $!;
233 my $report = i_child_report();
234 fail $report if defined $report;
235 badproto $fh, "eof (reading $wh)";
238 sub protocol_expect (&$) {
239 my ($match, $fh) = @_;
242 defined && chomp or badproto_badread $fh, "protocol message";
250 badproto $fh, "\`$_'";
253 sub protocol_send_file ($$) {
254 my ($fh, $ourfn) = @_;
255 open PF, "<", $ourfn or die "$ourfn: $!";
258 my $got = read PF, $d, 65536;
259 die "$ourfn: $!" unless defined $got;
261 print $fh "data-block ".length($d)."\n" or die $!;
262 print $fh $d or die $!;
264 PF->error and die "$ourfn $!";
265 print $fh "data-end\n" or die $!;
269 sub protocol_read_bytes ($$) {
270 my ($fh, $nbytes) = @_;
271 $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
273 my $got = read $fh, $d, $nbytes;
274 $got==$nbytes or badproto_badread $fh, "data block";
278 sub protocol_receive_file ($$) {
279 my ($fh, $ourfn) = @_;
280 printdebug "() $ourfn\n";
281 open PF, ">", $ourfn or die "$ourfn: $!";
283 my ($y,$l) = protocol_expect {
284 m/^data-block (.*)$/ ? (1,$1) :
285 m/^data-end$/ ? (0,) :
289 my $d = protocol_read_bytes $fh, $l;
290 print PF $d or die $!;
295 #---------- remote protocol support, responder ----------
297 sub responder_send_command ($) {
299 return unless $we_are_responder;
300 # called even without $we_are_responder
301 printdebug ">> $command\n";
302 print PO $command, "\n" or die $!;
305 sub responder_send_file ($$) {
306 my ($keyword, $ourfn) = @_;
307 return unless $we_are_responder;
308 printdebug "]] $keyword $ourfn\n";
309 responder_send_command "file $keyword";
310 protocol_send_file \*PO, $ourfn;
313 sub responder_receive_files ($@) {
314 my ($keyword, @ourfns) = @_;
315 die unless $we_are_responder;
316 printdebug "[[ $keyword @ourfns\n";
317 responder_send_command "want $keyword";
318 foreach my $fn (@ourfns) {
319 protocol_receive_file \*PI, $fn;
322 protocol_expect { m/^files-end$/ } \*PI;
325 #---------- remote protocol support, initiator ----------
327 sub initiator_expect (&) {
329 protocol_expect { &$match } \*RO;
332 #---------- end remote code ----------
335 if ($we_are_responder) {
337 responder_send_command "progress ".length($m) or die $!;
338 print PO $m or die $!;
348 $ua = LWP::UserAgent->new();
352 progress "downloading $what...";
353 my $r = $ua->get(@_) or die $!;
354 return undef if $r->code == 404;
355 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
356 return $r->decoded_content(charset => 'none');
359 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
364 failedcmd @_ if system @_;
367 sub act_local () { return $dryrun_level <= 1; }
368 sub act_scary () { return !$dryrun_level; }
371 if (!$dryrun_level) {
372 progress "dgit ok: @_";
374 progress "would be ok: @_ (but dry run only)";
379 printcmd(\*STDERR,$debugprefix."#",@_);
382 sub runcmd_ordryrun {
390 sub runcmd_ordryrun_local {
399 my ($first_shell, @cmd) = @_;
400 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
403 our $helpmsg = <<END;
405 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
406 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
407 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
408 dgit [dgit-opts] push [dgit-opts] [suite]
409 dgit [dgit-opts] rpush build-host:build-dir ...
410 important dgit options:
411 -k<keyid> sign tag and package with <keyid> instead of default
412 --dry-run -n do not change anything, but go through the motions
413 --damp-run -L like --dry-run but make local changes, without signing
414 --new -N allow introducing a new package
415 --debug -D increase debug level
416 -c<name>=<value> set git config option (used directly by dgit too)
419 our $later_warning_msg = <<END;
420 Perhaps the upload is stuck in incoming. Using the version from git.
424 print STDERR "$us: @_\n", $helpmsg or die $!;
429 @ARGV or badusage "too few arguments";
430 return scalar shift @ARGV;
434 print $helpmsg or die $!;
438 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
440 our %defcfg = ('dgit.default.distro' => 'debian',
441 'dgit.default.username' => '',
442 'dgit.default.archive-query-default-component' => 'main',
443 'dgit.default.ssh' => 'ssh',
444 'dgit.default.archive-query' => 'madison:',
445 'dgit.default.sshpsql-dbname' => 'service=projectb',
446 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
447 'dgit-distro.debian.git-host' => 'dgit-git.debian.net',
448 'dgit-distro.debian.git-user-force' => 'dgit',
449 'dgit-distro.debian.git-proto' => 'git+ssh://',
450 'dgit-distro.debian.git-path' => '/dgit/debian/repos',
451 'dgit-distro.debian.git-create' => 'true',
452 'dgit-distro.debian.git-check' => 'ssh-cmd',
453 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
454 # 'dgit-distro.debian.archive-query-tls-key',
455 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
456 # ^ this does not work because curl is broken nowadays
457 # Fixing #790093 properly will involve providing providing the key
458 # in some pacagke and maybe updating these paths.
460 # 'dgit-distro.debian.archive-query-tls-curl-args',
461 # '--ca-path=/etc/ssl/ca-debian',
462 # ^ this is a workaround but works (only) on DSA-administered machines
463 'dgit-distro.debian.diverts.alioth' => '/alioth',
464 'dgit-distro.debian/push.diverts.alioth' => '/alioth',
465 'dgit-distro.debian/alioth.git-host' => 'git.debian.org',
466 'dgit-distro.debian/alioth.git-user-force' => '',
467 'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
468 'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
469 'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
470 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
471 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
472 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
473 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
474 'dgit-distro.ubuntu.git-check' => 'false',
475 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
476 'dgit-distro.test-dummy.ssh' => "$td/ssh",
477 'dgit-distro.test-dummy.username' => "alice",
478 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
479 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
480 'dgit-distro.test-dummy.git-url' => "$td/git",
481 'dgit-distro.test-dummy.git-host' => "git",
482 'dgit-distro.test-dummy.git-path' => "$td/git",
483 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
484 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
485 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
486 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
489 sub git_get_config ($) {
492 our %git_get_config_memo;
493 if (exists $git_get_config_memo{$c}) {
494 return $git_get_config_memo{$c};
498 my @cmd = (@git, qw(config --), $c);
500 local ($debuglevel) = $debuglevel-2;
501 $v = cmdoutput_errok @cmd;
509 $git_get_config_memo{$c} = $v;
515 return undef if $c =~ /RETURN-UNDEF/;
516 my $v = git_get_config($c);
517 return $v if defined $v;
518 my $dv = $defcfg{$c};
519 return $dv if defined $dv;
521 badcfg "need value for one of: @_\n".
522 "$us: distro or suite appears not to be (properly) supported";
525 sub access_basedistro () {
526 if (defined $idistro) {
529 return cfg("dgit-suite.$isuite.distro",
530 "dgit.default.distro");
534 sub access_quirk () {
535 # returns (quirk name, distro to use instead or undef, quirk-specific info)
536 my $basedistro = access_basedistro();
537 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
539 if (defined $backports_quirk) {
540 my $re = $backports_quirk;
541 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
543 $re =~ s/\%/([-0-9a-z_]+)/
544 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
545 if ($isuite =~ m/^$re$/) {
546 return ('backports',"$basedistro-backports",$1);
549 return ('none',undef);
552 our $access_pushing = 0;
558 sub access_distros () {
559 # Returns list of distros to try, in order
562 # 0. `instead of' distro name(s) we have been pointed to
563 # 1. the access_quirk distro, if any
564 # 2a. the user's specified distro, or failing that } basedistro
565 # 2b. the distro calculated from the suite }
566 my @l = access_basedistro();
568 my (undef,$quirkdistro) = access_quirk();
569 unshift @l, $quirkdistro;
570 unshift @l, $instead_distro;
571 @l = grep { defined } @l;
573 if ($access_pushing) {
574 @l = map { ("$_/push", $_) } @l;
582 # The nesting of these loops determines the search order. We put
583 # the key loop on the outside so that we search all the distros
584 # for each key, before going on to the next key. That means that
585 # if access_cfg is called with a more specific, and then a less
586 # specific, key, an earlier distro can override the less specific
587 # without necessarily overriding any more specific keys. (If the
588 # distro wants to override the more specific keys it can simply do
589 # so; whereas if we did the loop the other way around, it would be
590 # impossible to for an earlier distro to override a less specific
591 # key but not the more specific ones without restating the unknown
592 # values of the more specific keys.
595 # We have to deal with RETURN-UNDEF specially, so that we don't
596 # terminate the search prematurely.
598 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
601 foreach my $d (access_distros()) {
602 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
604 push @cfgs, map { "dgit.default.$_" } @realkeys;
606 my $value = cfg(@cfgs);
610 sub string_to_ssh ($) {
612 if ($spec =~ m/\s/) {
613 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
619 sub access_cfg_ssh () {
620 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
621 if (!defined $gitssh) {
624 return string_to_ssh $gitssh;
628 sub access_runeinfo ($) {
630 return ": dgit ".access_basedistro()." $info ;";
633 sub access_someuserhost ($) {
635 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
636 defined($user) && length($user) or
637 $user = access_cfg("$some-user",'username');
638 my $host = access_cfg("$some-host");
639 return length($user) ? "$user\@$host" : $host;
642 sub access_gituserhost () {
643 return access_someuserhost('git');
646 sub access_giturl (;$) {
648 my $url = access_cfg('git-url','RETURN-UNDEF');
650 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
651 return undef unless defined $proto;
654 access_gituserhost().
655 access_cfg('git-path');
657 return "$url/$package.git";
660 sub parsecontrolfh ($$;$) {
661 my ($fh, $desc, $allowsigned) = @_;
662 our $dpkgcontrolhash_noissigned;
665 my %opts = ('name' => $desc);
666 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
667 $c = Dpkg::Control::Hash->new(%opts);
668 $c->parse($fh,$desc) or die "parsing of $desc failed";
669 last if $allowsigned;
670 last if $dpkgcontrolhash_noissigned;
671 my $issigned= $c->get_option('is_pgp_signed');
672 if (!defined $issigned) {
673 $dpkgcontrolhash_noissigned= 1;
674 seek $fh, 0,0 or die "seek $desc: $!";
675 } elsif ($issigned) {
676 fail "control file $desc is (already) PGP-signed. ".
677 " Note that dgit push needs to modify the .dsc and then".
678 " do the signature itself";
687 my ($file, $desc) = @_;
688 my $fh = new IO::Handle;
689 open $fh, '<', $file or die "$file: $!";
690 my $c = parsecontrolfh($fh,$desc);
691 $fh->error and die $!;
697 my ($dctrl,$field) = @_;
698 my $v = $dctrl->{$field};
699 return $v if defined $v;
700 fail "missing field $field in ".$v->get_option('name');
704 my $c = Dpkg::Control::Hash->new();
705 my $p = new IO::Handle;
706 my @cmd = (qw(dpkg-parsechangelog), @_);
707 open $p, '-|', @cmd or die $!;
709 $?=0; $!=0; close $p or failedcmd @cmd;
715 defined $d or fail "getcwd failed: $!";
721 sub archive_query ($) {
723 my $query = access_cfg('archive-query','RETURN-UNDEF');
724 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
727 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
730 sub pool_dsc_subpath ($$) {
731 my ($vsn,$component) = @_; # $package is implict arg
732 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
733 return "/pool/$component/$prefix/$package/".dscfn($vsn);
736 #---------- `ftpmasterapi' archive query method (nascent) ----------
738 sub archive_api_query_cmd ($) {
740 my @cmd = qw(curl -sS);
741 my $url = access_cfg('archive-query-url');
742 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
744 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
745 foreach my $key (split /\:/, $keys) {
746 $key =~ s/\%HOST\%/$host/g;
748 fail "for $url: stat $key: $!" unless $!==ENOENT;
751 fail "config requested specific TLS key but do not know".
752 " how to get curl to use exactly that EE key ($key)";
753 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
754 # # Sadly the above line does not work because of changes
755 # # to gnutls. The real fix for #790093 may involve
756 # # new curl options.
759 # Fixing #790093 properly will involve providing a value
760 # for this on clients.
761 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
762 push @cmd, split / /, $kargs if defined $kargs;
764 push @cmd, $url.$subpath;
770 my ($data, $subpath) = @_;
771 badcfg "ftpmasterapi archive query method takes no data part"
773 my @cmd = archive_api_query_cmd($subpath);
774 my $json = cmdoutput @cmd;
775 return decode_json($json);
778 sub canonicalise_suite_ftpmasterapi () {
779 my ($proto,$data) = @_;
780 my $suites = api_query($data, 'suites');
782 foreach my $entry (@$suites) {
784 my $v = $entry->{$_};
785 defined $v && $v eq $isuite;
787 push @matched, $entry;
789 fail "unknown suite $isuite" unless @matched;
792 @matched==1 or die "multiple matches for suite $isuite\n";
793 $cn = "$matched[0]{codename}";
794 defined $cn or die "suite $isuite info has no codename\n";
795 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
797 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
802 sub archive_query_ftpmasterapi () {
803 my ($proto,$data) = @_;
804 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
806 my $digester = Digest::SHA->new(256);
807 foreach my $entry (@$info) {
809 my $vsn = "$entry->{version}";
810 my ($ok,$msg) = version_check $vsn;
811 die "bad version: $msg\n" unless $ok;
812 my $component = "$entry->{component}";
813 $component =~ m/^$component_re$/ or die "bad component";
814 my $filename = "$entry->{filename}";
815 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
816 or die "bad filename";
817 my $sha256sum = "$entry->{sha256sum}";
818 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
819 push @rows, [ $vsn, "/pool/$component/$filename",
820 $digester, $sha256sum ];
822 die "bad ftpmaster api response: $@\n".Dumper($entry)
825 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
829 #---------- `madison' archive query method ----------
831 sub archive_query_madison {
832 return map { [ @$_[0..1] ] } madison_get_parse(@_);
835 sub madison_get_parse {
836 my ($proto,$data) = @_;
837 die unless $proto eq 'madison';
839 $data= access_cfg('madison-distro','RETURN-UNDEF');
840 $data //= access_basedistro();
842 $rmad{$proto,$data,$package} ||= cmdoutput
843 qw(rmadison -asource),"-s$isuite","-u$data",$package;
844 my $rmad = $rmad{$proto,$data,$package};
847 foreach my $l (split /\n/, $rmad) {
848 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
849 \s*( [^ \t|]+ )\s* \|
850 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
851 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
852 $1 eq $package or die "$rmad $package ?";
859 $component = access_cfg('archive-query-default-component');
861 $5 eq 'source' or die "$rmad ?";
862 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
864 return sort { -version_compare($a->[0],$b->[0]); } @out;
867 sub canonicalise_suite_madison {
868 # madison canonicalises for us
869 my @r = madison_get_parse(@_);
871 "unable to canonicalise suite using package $package".
872 " which does not appear to exist in suite $isuite;".
873 " --existing-package may help";
877 #---------- `sshpsql' archive query method ----------
880 my ($data,$runeinfo,$sql) = @_;
882 $data= access_someuserhost('sshpsql').':'.
883 access_cfg('sshpsql-dbname');
885 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
886 my ($userhost,$dbname) = ($`,$'); #';
888 my @cmd = (access_cfg_ssh, $userhost,
889 access_runeinfo("ssh-psql $runeinfo").
890 " export LC_MESSAGES=C; export LC_CTYPE=C;".
891 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
893 open P, "-|", @cmd or die $!;
896 printdebug("$debugprefix>|$_|\n");
899 $!=0; $?=0; close P or failedcmd @cmd;
901 my $nrows = pop @rows;
902 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
903 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
904 @rows = map { [ split /\|/, $_ ] } @rows;
905 my $ncols = scalar @{ shift @rows };
906 die if grep { scalar @$_ != $ncols } @rows;
910 sub sql_injection_check {
911 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
914 sub archive_query_sshpsql ($$) {
915 my ($proto,$data) = @_;
916 sql_injection_check $isuite, $package;
917 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
918 SELECT source.version, component.name, files.filename, files.sha256sum
920 JOIN src_associations ON source.id = src_associations.source
921 JOIN suite ON suite.id = src_associations.suite
922 JOIN dsc_files ON dsc_files.source = source.id
923 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
924 JOIN component ON component.id = files_archive_map.component_id
925 JOIN files ON files.id = dsc_files.file
926 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
927 AND source.source='$package'
928 AND files.filename LIKE '%.dsc';
930 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
931 my $digester = Digest::SHA->new(256);
933 my ($vsn,$component,$filename,$sha256sum) = @$_;
934 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
939 sub canonicalise_suite_sshpsql ($$) {
940 my ($proto,$data) = @_;
941 sql_injection_check $isuite;
942 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
943 SELECT suite.codename
944 FROM suite where suite_name='$isuite' or codename='$isuite';
946 @rows = map { $_->[0] } @rows;
947 fail "unknown suite $isuite" unless @rows;
948 die "ambiguous $isuite: @rows ?" if @rows>1;
952 #---------- `dummycat' archive query method ----------
954 sub canonicalise_suite_dummycat ($$) {
955 my ($proto,$data) = @_;
956 my $dpath = "$data/suite.$isuite";
957 if (!open C, "<", $dpath) {
958 $!==ENOENT or die "$dpath: $!";
959 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
963 chomp or die "$dpath: $!";
965 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
969 sub archive_query_dummycat ($$) {
970 my ($proto,$data) = @_;
971 canonicalise_suite();
972 my $dpath = "$data/package.$csuite.$package";
973 if (!open C, "<", $dpath) {
974 $!==ENOENT or die "$dpath: $!";
975 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
983 printdebug "dummycat query $csuite $package $dpath | $_\n";
984 my @row = split /\s+/, $_;
985 @row==2 or die "$dpath: $_ ?";
988 C->error and die "$dpath: $!";
990 return sort { -version_compare($a->[0],$b->[0]); } @rows;
993 #---------- archive query entrypoints and rest of program ----------
995 sub canonicalise_suite () {
996 return if defined $csuite;
997 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
998 $csuite = archive_query('canonicalise_suite');
999 if ($isuite ne $csuite) {
1000 progress "canonical suite name for $isuite is $csuite";
1004 sub get_archive_dsc () {
1005 canonicalise_suite();
1006 my @vsns = archive_query('archive_query');
1007 foreach my $vinfo (@vsns) {
1008 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1009 $dscurl = access_cfg('mirror').$subpath;
1010 $dscdata = url_get($dscurl);
1012 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1017 $digester->add($dscdata);
1018 my $got = $digester->hexdigest();
1020 fail "$dscurl has hash $got but".
1021 " archive told us to expect $digest";
1023 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1024 printdebug Dumper($dscdata) if $debuglevel>1;
1025 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1026 printdebug Dumper($dsc) if $debuglevel>1;
1027 my $fmt = getfield $dsc, 'Format';
1028 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1029 $dsc_checked = !!$digester;
1035 sub check_for_git ();
1036 sub check_for_git () {
1038 my $how = access_cfg('git-check');
1039 if ($how eq 'ssh-cmd') {
1041 (access_cfg_ssh, access_gituserhost(),
1042 access_runeinfo("git-check $package").
1043 " set -e; cd ".access_cfg('git-path').";".
1044 " if test -d $package.git; then echo 1; else echo 0; fi");
1045 my $r= cmdoutput @cmd;
1046 if ($r =~ m/^divert (\w+)$/) {
1048 my ($usedistro,) = access_distros();
1049 # NB that if we are pushing, $usedistro will be $distro/push
1050 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1051 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1052 progress "diverting to $divert (using config for $instead_distro)";
1053 return check_for_git();
1055 failedcmd @cmd unless $r =~ m/^[01]$/;
1057 } elsif ($how eq 'true') {
1059 } elsif ($how eq 'false') {
1062 badcfg "unknown git-check \`$how'";
1066 sub create_remote_git_repo () {
1067 my $how = access_cfg('git-create');
1068 if ($how eq 'ssh-cmd') {
1070 (access_cfg_ssh, access_gituserhost(),
1071 access_runeinfo("git-create $package").
1072 "set -e; cd ".access_cfg('git-path').";".
1073 " cp -a _template $package.git");
1074 } elsif ($how eq 'true') {
1077 badcfg "unknown git-create \`$how'";
1081 our ($dsc_hash,$lastpush_hash);
1083 our $ud = '.git/dgit/unpack';
1088 mkdir $ud or die $!;
1091 sub mktree_in_ud_here () {
1092 runcmd qw(git init -q);
1093 rmtree('.git/objects');
1094 symlink '../../../../objects','.git/objects' or die $!;
1097 sub git_write_tree () {
1098 my $tree = cmdoutput @git, qw(write-tree);
1099 $tree =~ m/^\w+$/ or die "$tree ?";
1103 sub mktree_in_ud_from_only_subdir () {
1104 # changes into the subdir
1106 die unless @dirs==1;
1107 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1110 fail "source package contains .git directory" if stat_exists '.git';
1111 mktree_in_ud_here();
1112 my $format=get_source_format();
1113 if (madformat($format)) {
1116 runcmd @git, qw(add -Af);
1117 my $tree=git_write_tree();
1118 return ($tree,$dir);
1121 sub dsc_files_info () {
1122 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1123 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1124 ['Files', 'Digest::MD5', 'new()']) {
1125 my ($fname, $module, $method) = @$csumi;
1126 my $field = $dsc->{$fname};
1127 next unless defined $field;
1128 eval "use $module; 1;" or die $@;
1130 foreach (split /\n/, $field) {
1132 m/^(\w+) (\d+) (\S+)$/ or
1133 fail "could not parse .dsc $fname line \`$_'";
1134 my $digester = eval "$module"."->$method;" or die $@;
1139 Digester => $digester,
1144 fail "missing any supported Checksums-* or Files field in ".
1145 $dsc->get_option('name');
1149 map { $_->{Filename} } dsc_files_info();
1152 sub is_orig_file ($;$) {
1155 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1156 defined $base or return 1;
1160 sub make_commit ($) {
1162 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1165 sub clogp_authline ($) {
1167 my $author = getfield $clogp, 'Maintainer';
1168 $author =~ s#,.*##ms;
1169 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1170 my $authline = "$author $date";
1171 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1172 fail "unexpected commit author line format \`$authline'".
1173 " (was generated from changelog Maintainer field)";
1177 sub vendor_patches_distro ($$) {
1178 my ($checkdistro, $what) = @_;
1179 return unless defined $checkdistro;
1181 my $series = "debian/patches/\L$checkdistro\E.series";
1182 printdebug "checking for vendor-specific $series ($what)\n";
1184 if (!open SERIES, "<", $series) {
1185 die "$series $!" unless $!==ENOENT;
1194 Unfortunately, this source package uses a feature of dpkg-source where
1195 the same source package unpacks to different source code on different
1196 distros. dgit cannot safely operate on such packages on affected
1197 distros, because the meaning of source packages is not stable.
1199 Please ask the distro/maintainer to remove the distro-specific series
1200 files and use a different technique (if necessary, uploading actually
1201 different packages, if different distros are supposed to have
1205 fail "Found active distro-specific series file for".
1206 " $checkdistro ($what): $series, cannot continue";
1208 die "$series $!" if SERIES->error;
1212 sub check_for_vendor_patches () {
1213 # This dpkg-source feature doesn't seem to be documented anywhere!
1214 # But it can be found in the changelog (reformatted):
1216 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1217 # Author: Raphael Hertzog <hertzog@debian.org>
1218 # Date: Sun Oct 3 09:36:48 2010 +0200
1220 # dpkg-source: correctly create .pc/.quilt_series with alternate
1223 # If you have debian/patches/ubuntu.series and you were
1224 # unpacking the source package on ubuntu, quilt was still
1225 # directed to debian/patches/series instead of
1226 # debian/patches/ubuntu.series.
1228 # debian/changelog | 3 +++
1229 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1230 # 2 files changed, 6 insertions(+), 1 deletion(-)
1233 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1234 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1235 "Dpkg::Vendor \`current vendor'");
1236 vendor_patches_distro(access_basedistro(),
1237 "distro being accessed");
1240 sub generate_commit_from_dsc () {
1244 foreach my $fi (dsc_files_info()) {
1245 my $f = $fi->{Filename};
1246 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1248 link "../../../$f", $f
1252 complete_file_from_dsc('.', $fi);
1254 if (is_orig_file($f)) {
1255 link $f, "../../../../$f"
1261 my $dscfn = "$package.dsc";
1263 open D, ">", $dscfn or die "$dscfn: $!";
1264 print D $dscdata or die "$dscfn: $!";
1265 close D or die "$dscfn: $!";
1266 my @cmd = qw(dpkg-source);
1267 push @cmd, '--no-check' if $dsc_checked;
1268 push @cmd, qw(-x --), $dscfn;
1271 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1272 check_for_vendor_patches() if madformat($dsc->{format});
1273 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1274 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1275 my $authline = clogp_authline $clogp;
1276 my $changes = getfield $clogp, 'Changes';
1277 open C, ">../commit.tmp" or die $!;
1278 print C <<END or die $!;
1285 # imported from the archive
1288 my $outputhash = make_commit qw(../commit.tmp);
1289 my $cversion = getfield $clogp, 'Version';
1290 progress "synthesised git commit from .dsc $cversion";
1291 if ($lastpush_hash) {
1292 runcmd @git, qw(reset --hard), $lastpush_hash;
1293 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1294 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1295 my $oversion = getfield $oldclogp, 'Version';
1297 version_compare($oversion, $cversion);
1299 # git upload/ is earlier vsn than archive, use archive
1300 open C, ">../commit2.tmp" or die $!;
1301 print C <<END or die $!;
1303 parent $lastpush_hash
1308 Record $package ($cversion) in archive suite $csuite
1310 $outputhash = make_commit qw(../commit2.tmp);
1311 } elsif ($vcmp > 0) {
1312 print STDERR <<END or die $!;
1314 Version actually in archive: $cversion (older)
1315 Last allegedly pushed/uploaded: $oversion (newer or same)
1318 $outputhash = $lastpush_hash;
1320 $outputhash = $lastpush_hash;
1323 changedir '../../../..';
1324 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1325 'DGIT_ARCHIVE', $outputhash;
1326 cmdoutput @git, qw(log -n2), $outputhash;
1327 # ... gives git a chance to complain if our commit is malformed
1332 sub complete_file_from_dsc ($$) {
1333 our ($dstdir, $fi) = @_;
1334 # Ensures that we have, in $dir, the file $fi, with the correct
1335 # contents. (Downloading it from alongside $dscurl if necessary.)
1337 my $f = $fi->{Filename};
1338 my $tf = "$dstdir/$f";
1341 if (stat_exists $tf) {
1342 progress "using existing $f";
1345 $furl =~ s{/[^/]+$}{};
1347 die "$f ?" unless $f =~ m/^${package}_/;
1348 die "$f ?" if $f =~ m#/#;
1349 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1350 next if !act_local();
1354 open F, "<", "$tf" or die "$tf: $!";
1355 $fi->{Digester}->reset();
1356 $fi->{Digester}->addfile(*F);
1357 F->error and die $!;
1358 my $got = $fi->{Digester}->hexdigest();
1359 $got eq $fi->{Hash} or
1360 fail "file $f has hash $got but .dsc".
1361 " demands hash $fi->{Hash} ".
1362 ($downloaded ? "(got wrong file from archive!)"
1363 : "(perhaps you should delete this file?)");
1366 sub ensure_we_have_orig () {
1367 foreach my $fi (dsc_files_info()) {
1368 my $f = $fi->{Filename};
1369 next unless is_orig_file($f);
1370 complete_file_from_dsc('..', $fi);
1374 sub git_fetch_us () {
1375 my @specs = (fetchspec());
1377 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1379 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1382 my $tagpat = debiantag('*',access_basedistro);
1384 git_for_each_ref("refs/tags/".$tagpat, sub {
1385 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1386 printdebug "currently $fullrefname=$objid\n";
1387 $here{$fullrefname} = $objid;
1389 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1390 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1391 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1392 printdebug "offered $lref=$objid\n";
1393 if (!defined $here{$lref}) {
1394 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1395 runcmd_ordryrun_local @upd;
1396 } elsif ($here{$lref} eq $objid) {
1399 "Not updateting $lref from $here{$lref} to $objid.\n";
1404 sub fetch_from_archive () {
1405 # ensures that lrref() is what is actually in the archive,
1406 # one way or another
1410 foreach my $field (@ourdscfield) {
1411 $dsc_hash = $dsc->{$field};
1412 last if defined $dsc_hash;
1414 if (defined $dsc_hash) {
1415 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1417 progress "last upload to archive specified git hash";
1419 progress "last upload to archive has NO git hash";
1422 progress "no version available from the archive";
1425 $lastpush_hash = git_get_ref(lrref());
1426 printdebug "previous reference hash=$lastpush_hash\n";
1428 if (defined $dsc_hash) {
1429 fail "missing remote git history even though dsc has hash -".
1430 " could not find ref ".lrref().
1431 " (should have been fetched from ".access_giturl()."#".rrref().")"
1432 unless $lastpush_hash;
1434 ensure_we_have_orig();
1435 if ($dsc_hash eq $lastpush_hash) {
1436 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1437 print STDERR <<END or die $!;
1439 Git commit in archive is behind the last version allegedly pushed/uploaded.
1440 Commit referred to by archive: $dsc_hash
1441 Last allegedly pushed/uploaded: $lastpush_hash
1444 $hash = $lastpush_hash;
1446 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1447 "descendant of archive's .dsc hash ($dsc_hash)";
1450 $hash = generate_commit_from_dsc();
1451 } elsif ($lastpush_hash) {
1452 # only in git, not in the archive yet
1453 $hash = $lastpush_hash;
1454 print STDERR <<END or die $!;
1456 Package not found in the archive, but has allegedly been pushed using dgit.
1460 printdebug "nothing found!\n";
1461 if (defined $skew_warning_vsn) {
1462 print STDERR <<END or die $!;
1464 Warning: relevant archive skew detected.
1465 Archive allegedly contains $skew_warning_vsn
1466 But we were not able to obtain any version from the archive or git.
1472 printdebug "current hash=$hash\n";
1473 if ($lastpush_hash) {
1474 fail "not fast forward on last upload branch!".
1475 " (archive's version left in DGIT_ARCHIVE)"
1476 unless is_fast_fwd($lastpush_hash, $hash);
1478 if (defined $skew_warning_vsn) {
1480 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1481 my $clogf = ".git/dgit/changelog.tmp";
1482 runcmd shell_cmd "exec >$clogf",
1483 @git, qw(cat-file blob), "$hash:debian/changelog";
1484 my $gotclogp = parsechangelog("-l$clogf");
1485 my $got_vsn = getfield $gotclogp, 'Version';
1486 printdebug "SKEW CHECK GOT $got_vsn\n";
1487 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1488 print STDERR <<END or die $!;
1490 Warning: archive skew detected. Using the available version:
1491 Archive allegedly contains $skew_warning_vsn
1492 We were able to obtain only $got_vsn
1497 if ($lastpush_hash ne $hash) {
1498 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1502 dryrun_report @upd_cmd;
1508 sub set_local_git_config ($$) {
1510 runcmd @git, qw(config), $k, $v;
1513 sub setup_mergechangelogs () {
1514 my $driver = 'dpkg-mergechangelogs';
1515 my $cb = "merge.$driver";
1516 my $attrs = '.git/info/attributes';
1517 ensuredir '.git/info';
1519 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1520 if (!open ATTRS, "<", $attrs) {
1521 $!==ENOENT or die "$attrs: $!";
1525 next if m{^debian/changelog\s};
1526 print NATTRS $_, "\n" or die $!;
1528 ATTRS->error and die $!;
1531 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1534 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1535 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1537 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1542 canonicalise_suite();
1543 badusage "dry run makes no sense with clone" unless act_local();
1544 my $hasgit = check_for_git();
1545 mkdir $dstdir or die "$dstdir $!";
1547 runcmd @git, qw(init -q);
1548 my $giturl = access_giturl(1);
1549 if (defined $giturl) {
1550 set_local_git_config "remote.$remotename.fetch", fetchspec();
1551 open H, "> .git/HEAD" or die $!;
1552 print H "ref: ".lref()."\n" or die $!;
1554 runcmd @git, qw(remote add), 'origin', $giturl;
1557 progress "fetching existing git history";
1559 runcmd_ordryrun_local @git, qw(fetch origin);
1561 progress "starting new git history";
1563 fetch_from_archive() or no_such_package;
1564 my $vcsgiturl = $dsc->{'Vcs-Git'};
1565 if (length $vcsgiturl) {
1566 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1567 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1569 setup_mergechangelogs();
1570 runcmd @git, qw(reset --hard), lrref();
1571 printdone "ready for work in $dstdir";
1575 if (check_for_git()) {
1578 fetch_from_archive() or no_such_package();
1579 printdone "fetched into ".lrref();
1584 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1586 printdone "fetched to ".lrref()." and merged into HEAD";
1589 sub check_not_dirty () {
1590 return if $ignoredirty;
1591 my @cmd = (@git, qw(diff --quiet HEAD));
1593 $!=0; $?=0; system @cmd;
1594 return if !$! && !$?;
1595 if (!$! && $?==256) {
1596 fail "working tree is dirty (does not match HEAD)";
1602 sub commit_admin ($) {
1605 runcmd_ordryrun_local @git, qw(commit -m), $m;
1608 sub commit_quilty_patch () {
1609 my $output = cmdoutput @git, qw(status --porcelain);
1611 foreach my $l (split /\n/, $output) {
1612 next unless $l =~ m/\S/;
1613 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1617 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1619 progress "nothing quilty to commit, ok.";
1622 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1623 commit_admin "Commit Debian 3.0 (quilt) metadata";
1626 sub get_source_format () {
1627 if (!open F, "debian/source/format") {
1628 die $! unless $!==&ENOENT;
1632 F->error and die $!;
1639 return 0 unless $format eq '3.0 (quilt)';
1640 if ($quilt_mode eq 'nocheck') {
1641 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1644 progress "Format \`$format', checking/updating patch stack";
1648 sub push_parse_changelog ($) {
1651 my $clogp = Dpkg::Control::Hash->new();
1652 $clogp->load($clogpfn) or die;
1654 $package = getfield $clogp, 'Source';
1655 my $cversion = getfield $clogp, 'Version';
1656 my $tag = debiantag($cversion, access_basedistro);
1657 runcmd @git, qw(check-ref-format), $tag;
1659 my $dscfn = dscfn($cversion);
1661 return ($clogp, $cversion, $tag, $dscfn);
1664 sub push_parse_dsc ($$$) {
1665 my ($dscfn,$dscfnwhat, $cversion) = @_;
1666 $dsc = parsecontrol($dscfn,$dscfnwhat);
1667 my $dversion = getfield $dsc, 'Version';
1668 my $dscpackage = getfield $dsc, 'Source';
1669 ($dscpackage eq $package && $dversion eq $cversion) or
1670 fail "$dscfn is for $dscpackage $dversion".
1671 " but debian/changelog is for $package $cversion";
1674 sub push_mktag ($$$$$$$) {
1675 my ($head,$clogp,$tag,
1677 $changesfile,$changesfilewhat,
1680 $dsc->{$ourdscfield[0]} = $head;
1681 $dsc->save("$dscfn.tmp") or die $!;
1683 my $changes = parsecontrol($changesfile,$changesfilewhat);
1684 foreach my $field (qw(Source Distribution Version)) {
1685 $changes->{$field} eq $clogp->{$field} or
1686 fail "changes field $field \`$changes->{$field}'".
1687 " does not match changelog \`$clogp->{$field}'";
1690 my $cversion = getfield $clogp, 'Version';
1691 my $clogsuite = getfield $clogp, 'Distribution';
1693 # We make the git tag by hand because (a) that makes it easier
1694 # to control the "tagger" (b) we can do remote signing
1695 my $authline = clogp_authline $clogp;
1696 my $delibs = join(" ", "",@deliberatelies);
1697 my $declaredistro = access_basedistro();
1698 open TO, '>', $tfn->('.tmp') or die $!;
1699 print TO <<END or die $!;
1705 $package release $cversion for $clogsuite ($csuite) [dgit]
1706 [dgit distro=$declaredistro$delibs]
1708 foreach my $ref (sort keys %previously) {
1709 print TO <<END or die $!;
1710 [dgit previously:$ref=$previously{$ref}]
1716 my $tagobjfn = $tfn->('.tmp');
1718 if (!defined $keyid) {
1719 $keyid = access_cfg('keyid','RETURN-UNDEF');
1721 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1722 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1723 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1724 push @sign_cmd, $tfn->('.tmp');
1725 runcmd_ordryrun @sign_cmd;
1727 $tagobjfn = $tfn->('.signed.tmp');
1728 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1729 $tfn->('.tmp'), $tfn->('.tmp.asc');
1736 sub sign_changes ($) {
1737 my ($changesfile) = @_;
1739 my @debsign_cmd = @debsign;
1740 push @debsign_cmd, "-k$keyid" if defined $keyid;
1741 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1742 push @debsign_cmd, $changesfile;
1743 runcmd_ordryrun @debsign_cmd;
1748 my ($forceflag) = @_;
1749 printdebug "actually entering push\n";
1752 access_giturl(); # check that success is vaguely likely
1754 my $clogpfn = ".git/dgit/changelog.822.tmp";
1755 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1757 responder_send_file('parsed-changelog', $clogpfn);
1759 my ($clogp, $cversion, $tag, $dscfn) =
1760 push_parse_changelog("$clogpfn");
1762 my $dscpath = "$buildproductsdir/$dscfn";
1763 stat_exists $dscpath or
1764 fail "looked for .dsc $dscfn, but $!;".
1765 " maybe you forgot to build";
1767 responder_send_file('dsc', $dscpath);
1769 push_parse_dsc($dscpath, $dscfn, $cversion);
1771 my $format = getfield $dsc, 'Format';
1772 printdebug "format $format\n";
1773 if (madformat($format)) {
1774 commit_quilty_patch();
1778 progress "checking that $dscfn corresponds to HEAD";
1779 runcmd qw(dpkg-source -x --),
1780 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1781 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1782 check_for_vendor_patches() if madformat($dsc->{format});
1783 changedir '../../../..';
1784 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1785 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1786 debugcmd "+",@diffcmd;
1788 my $r = system @diffcmd;
1791 fail "$dscfn specifies a different tree to your HEAD commit;".
1792 " perhaps you forgot to build".
1793 ($diffopt eq '--exit-code' ? "" :
1794 " (run with -D to see full diff output)");
1800 #do fast forward check and maybe fake merge
1801 # if (!is_fast_fwd(mainbranch
1802 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1803 # map { lref($_).":".rref($_) }
1805 my $head = git_rev_parse('HEAD');
1806 if (!$changesfile) {
1807 my $multi = "$buildproductsdir/".
1808 "${package}_".(stripepoch $cversion)."_multi.changes";
1809 if (stat_exists "$multi") {
1810 $changesfile = $multi;
1812 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1813 my @cs = glob "$buildproductsdir/$pat";
1814 fail "failed to find unique changes file".
1815 " (looked for $pat in $buildproductsdir, or $multi);".
1816 " perhaps you need to use dgit -C"
1818 ($changesfile) = @cs;
1821 $changesfile = "$buildproductsdir/$changesfile";
1824 responder_send_file('changes',$changesfile);
1825 responder_send_command("param head $head");
1826 responder_send_command("param csuite $csuite");
1828 if (deliberately_not_fast_forward) {
1829 git_for_each_ref(lrfetchrefs, sub {
1830 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1831 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1832 responder_send_command("previously $rrefname=$objid");
1833 $previously{$rrefname} = $objid;
1837 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1840 if ($we_are_responder) {
1841 $tagobjfn = $tfn->('.signed.tmp');
1842 responder_receive_files('signed-tag', $tagobjfn);
1845 push_mktag($head,$clogp,$tag,
1847 $changesfile,$changesfile,
1851 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1852 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1853 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1855 if (!check_for_git()) {
1856 create_remote_git_repo();
1858 runcmd_ordryrun @git, qw(push),access_giturl(),
1859 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1860 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1862 if ($we_are_responder) {
1863 my $dryrunsuffix = act_local() ? "" : ".tmp";
1864 responder_receive_files('signed-dsc-changes',
1865 "$dscpath$dryrunsuffix",
1866 "$changesfile$dryrunsuffix");
1869 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1871 progress "[new .dsc left in $dscpath.tmp]";
1873 sign_changes $changesfile;
1876 my $host = access_cfg('upload-host','RETURN-UNDEF');
1877 my @hostarg = defined($host) ? ($host,) : ();
1878 runcmd_ordryrun @dput, @hostarg, $changesfile;
1879 printdone "pushed and uploaded $cversion";
1881 responder_send_command("complete");
1887 badusage "-p is not allowed with clone; specify as argument instead"
1888 if defined $package;
1891 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1892 ($package,$isuite) = @ARGV;
1893 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1894 ($package,$dstdir) = @ARGV;
1895 } elsif (@ARGV==3) {
1896 ($package,$isuite,$dstdir) = @ARGV;
1898 badusage "incorrect arguments to dgit clone";
1900 $dstdir ||= "$package";
1902 if (stat_exists $dstdir) {
1903 fail "$dstdir already exists";
1907 if ($rmonerror && !$dryrun_level) {
1908 $cwd_remove= getcwd();
1910 return unless defined $cwd_remove;
1911 if (!chdir "$cwd_remove") {
1912 return if $!==&ENOENT;
1913 die "chdir $cwd_remove: $!";
1915 rmtree($dstdir) or die "remove $dstdir: $!\n";
1920 $cwd_remove = undef;
1923 sub branchsuite () {
1924 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1925 if ($branch =~ m#$lbranch_re#o) {
1932 sub fetchpullargs () {
1933 if (!defined $package) {
1934 my $sourcep = parsecontrol('debian/control','debian/control');
1935 $package = getfield $sourcep, 'Source';
1938 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1940 my $clogp = parsechangelog();
1941 $isuite = getfield $clogp, 'Distribution';
1943 canonicalise_suite();
1944 progress "fetching from suite $csuite";
1945 } elsif (@ARGV==1) {
1947 canonicalise_suite();
1949 badusage "incorrect arguments to dgit fetch or dgit pull";
1968 badusage "-p is not allowed with dgit push" if defined $package;
1970 my $clogp = parsechangelog();
1971 $package = getfield $clogp, 'Source';
1974 } elsif (@ARGV==1) {
1975 ($specsuite) = (@ARGV);
1977 badusage "incorrect arguments to dgit push";
1979 $isuite = getfield $clogp, 'Distribution';
1981 local ($package) = $existing_package; # this is a hack
1982 canonicalise_suite();
1984 canonicalise_suite();
1986 if (defined $specsuite &&
1987 $specsuite ne $isuite &&
1988 $specsuite ne $csuite) {
1989 fail "dgit push: changelog specifies $isuite ($csuite)".
1990 " but command line specifies $specsuite";
1992 if (check_for_git()) {
1996 if (fetch_from_archive()) {
1997 if (is_fast_fwd(lrref(), 'HEAD')) {
1999 } elsif (deliberately_not_fast_forward) {
2002 fail "dgit push: HEAD is not a descendant".
2003 " of the archive's version.\n".
2004 "dgit: To overwrite its contents,".
2005 " use git merge -s ours ".lrref().".\n".
2006 "dgit: To rewind history, if permitted by the archive,".
2007 " use --deliberately-not-fast-forward";
2011 fail "package appears to be new in this suite;".
2012 " if this is intentional, use --new";
2017 #---------- remote commands' implementation ----------
2019 sub cmd_remote_push_build_host {
2021 my ($nrargs) = shift @ARGV;
2022 my (@rargs) = @ARGV[0..$nrargs-1];
2023 @ARGV = @ARGV[$nrargs..$#ARGV];
2025 my ($dir,$vsnwant) = @rargs;
2026 # vsnwant is a comma-separated list; we report which we have
2027 # chosen in our ready response (so other end can tell if they
2030 $we_are_responder = 1;
2031 $us .= " (build host)";
2033 open PI, "<&STDIN" or die $!;
2034 open STDIN, "/dev/null" or die $!;
2035 open PO, ">&STDOUT" or die $!;
2037 open STDOUT, ">&STDERR" or die $!;
2041 fail "build host has dgit rpush protocol version".
2042 " $rpushprotovsn but invocation host has $vsnwant"
2043 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2045 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2051 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2052 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2053 # a good error message)
2059 my $report = i_child_report();
2060 if (defined $report) {
2061 printdebug "($report)\n";
2062 } elsif ($i_child_pid) {
2063 printdebug "(killing build host child $i_child_pid)\n";
2064 kill 15, $i_child_pid;
2066 if (defined $i_tmp && !defined $initiator_tempdir) {
2068 eval { rmtree $i_tmp; };
2072 END { i_cleanup(); }
2075 my ($base,$selector,@args) = @_;
2076 $selector =~ s/\-/_/g;
2077 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2084 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2091 my @rargs = ($dir,$rpushprotovsn);
2094 push @rdgit, @ropts;
2095 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2097 my @cmd = (@ssh, $host, shellquote @rdgit);
2100 if (defined $initiator_tempdir) {
2101 rmtree $initiator_tempdir;
2102 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2103 $i_tmp = $initiator_tempdir;
2107 $i_child_pid = open2(\*RO, \*RI, @cmd);
2109 initiator_expect { m/^dgit-remote-push-ready/ };
2111 my ($icmd,$iargs) = initiator_expect {
2112 m/^(\S+)(?: (.*))?$/;
2115 i_method "i_resp", $icmd, $iargs;
2119 sub i_resp_progress ($) {
2121 my $msg = protocol_read_bytes \*RO, $rhs;
2125 sub i_resp_complete {
2126 my $pid = $i_child_pid;
2127 $i_child_pid = undef; # prevents killing some other process with same pid
2128 printdebug "waiting for build host child $pid...\n";
2129 my $got = waitpid $pid, 0;
2130 die $! unless $got == $pid;
2131 die "build host child failed $?" if $?;
2134 printdebug "all done\n";
2138 sub i_resp_file ($) {
2140 my $localname = i_method "i_localname", $keyword;
2141 my $localpath = "$i_tmp/$localname";
2142 stat_exists $localpath and
2143 badproto \*RO, "file $keyword ($localpath) twice";
2144 protocol_receive_file \*RO, $localpath;
2145 i_method "i_file", $keyword;
2150 sub i_resp_param ($) {
2151 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2155 sub i_resp_previously ($) {
2156 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2157 or badproto \*RO, "bad previously spec";
2158 my $r = system qw(git check-ref-format), $1;
2159 die "bad previously ref spec ($r)" if $r;
2160 $previously{$1} = $2;
2165 sub i_resp_want ($) {
2167 die "$keyword ?" if $i_wanted{$keyword}++;
2168 my @localpaths = i_method "i_want", $keyword;
2169 printdebug "[[ $keyword @localpaths\n";
2170 foreach my $localpath (@localpaths) {
2171 protocol_send_file \*RI, $localpath;
2173 print RI "files-end\n" or die $!;
2176 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2178 sub i_localname_parsed_changelog {
2179 return "remote-changelog.822";
2181 sub i_file_parsed_changelog {
2182 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2183 push_parse_changelog "$i_tmp/remote-changelog.822";
2184 die if $i_dscfn =~ m#/|^\W#;
2187 sub i_localname_dsc {
2188 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2193 sub i_localname_changes {
2194 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2195 $i_changesfn = $i_dscfn;
2196 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2197 return $i_changesfn;
2199 sub i_file_changes { }
2201 sub i_want_signed_tag {
2202 printdebug Dumper(\%i_param, $i_dscfn);
2203 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2204 && defined $i_param{'csuite'}
2205 or badproto \*RO, "premature desire for signed-tag";
2206 my $head = $i_param{'head'};
2207 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2209 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2211 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2214 push_mktag $head, $i_clogp, $i_tag,
2216 $i_changesfn, 'remote changes',
2217 sub { "tag$_[0]"; };
2222 sub i_want_signed_dsc_changes {
2223 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2224 sign_changes $i_changesfn;
2225 return ($i_dscfn, $i_changesfn);
2228 #---------- building etc. ----------
2234 #----- `3.0 (quilt)' handling -----
2236 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2238 sub quiltify_dpkg_commit ($$$;$) {
2239 my ($patchname,$author,$msg, $xinfo) = @_;
2243 my $descfn = ".git/dgit/quilt-description.tmp";
2244 open O, '>', $descfn or die "$descfn: $!";
2247 $msg =~ s/^\s+$/ ./mg;
2248 print O <<END or die $!;
2258 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2259 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2260 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2261 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2265 sub quiltify_trees_differ ($$) {
2267 # returns 1 iff the two tree objects differ other than in debian/
2269 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2270 my $diffs= cmdoutput @cmd;
2271 foreach my $f (split /\0/, $diffs) {
2272 next if $f eq 'debian';
2278 sub quiltify_tree_sentinelfiles ($) {
2279 # lists the `sentinel' files present in the tree
2281 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2282 qw(-- debian/rules debian/control);
2288 my ($clogp,$target) = @_;
2290 # Quilt patchification algorithm
2292 # We search backwards through the history of the main tree's HEAD
2293 # (T) looking for a start commit S whose tree object is identical
2294 # to to the patch tip tree (ie the tree corresponding to the
2295 # current dpkg-committed patch series). For these purposes
2296 # `identical' disregards anything in debian/ - this wrinkle is
2297 # necessary because dpkg-source treates debian/ specially.
2299 # We can only traverse edges where at most one of the ancestors'
2300 # trees differs (in changes outside in debian/). And we cannot
2301 # handle edges which change .pc/ or debian/patches. To avoid
2302 # going down a rathole we avoid traversing edges which introduce
2303 # debian/rules or debian/control. And we set a limit on the
2304 # number of edges we are willing to look at.
2306 # If we succeed, we walk forwards again. For each traversed edge
2307 # PC (with P parent, C child) (starting with P=S and ending with
2308 # C=T) to we do this:
2310 # - dpkg-source --commit with a patch name and message derived from C
2311 # After traversing PT, we git commit the changes which
2312 # should be contained within debian/patches.
2314 changedir '../fake';
2315 mktree_in_ud_here();
2317 runcmd @git, 'add', '.';
2318 my $oldtiptree=git_write_tree();
2319 changedir '../work';
2321 # The search for the path S..T is breadth-first. We maintain a
2322 # todo list containing search nodes. A search node identifies a
2323 # commit, and looks something like this:
2325 # Commit => $git_commit_id,
2326 # Child => $c, # or undef if P=T
2327 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2328 # Nontrivial => true iff $p..$c has relevant changes
2335 my %considered; # saves being exponential on some weird graphs
2337 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2340 my ($search,$whynot) = @_;
2341 printdebug " search NOT $search->{Commit} $whynot\n";
2342 $search->{Whynot} = $whynot;
2343 push @nots, $search;
2344 no warnings qw(exiting);
2353 my $c = shift @todo;
2354 next if $considered{$c->{Commit}}++;
2356 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2358 printdebug "quiltify investigate $c->{Commit}\n";
2361 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2362 printdebug " search finished hooray!\n";
2367 if ($quilt_mode eq 'nofix') {
2368 fail "quilt fixup required but quilt mode is \`nofix'\n".
2369 "HEAD commit $c->{Commit} differs from tree implied by ".
2370 " debian/patches (tree object $oldtiptree)";
2372 if ($quilt_mode eq 'smash') {
2373 printdebug " search quitting smash\n";
2377 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2378 $not->($c, "has $c_sentinels not $t_sentinels")
2379 if $c_sentinels ne $t_sentinels;
2381 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2382 $commitdata =~ m/\n\n/;
2384 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2385 @parents = map { { Commit => $_, Child => $c } } @parents;
2387 $not->($c, "root commit") if !@parents;
2389 foreach my $p (@parents) {
2390 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2392 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2393 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2395 foreach my $p (@parents) {
2396 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2398 my @cmd= (@git, qw(diff-tree -r --name-only),
2399 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2400 my $patchstackchange = cmdoutput @cmd;
2401 if (length $patchstackchange) {
2402 $patchstackchange =~ s/\n/,/g;
2403 $not->($p, "changed $patchstackchange");
2406 printdebug " search queue P=$p->{Commit} ",
2407 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2413 printdebug "quiltify want to smash\n";
2416 my $x = $_[0]{Commit};
2417 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2420 my $reportnot = sub {
2422 my $s = $abbrev->($notp);
2423 my $c = $notp->{Child};
2424 $s .= "..".$abbrev->($c) if $c;
2425 $s .= ": ".$notp->{Whynot};
2428 if ($quilt_mode eq 'linear') {
2429 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2430 foreach my $notp (@nots) {
2431 print STDERR "$us: ", $reportnot->($notp), "\n";
2433 fail "quilt fixup naive history linearisation failed.\n".
2434 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2435 } elsif ($quilt_mode eq 'smash') {
2436 } elsif ($quilt_mode eq 'auto') {
2437 progress "quilt fixup cannot be linear, smashing...";
2439 die "$quilt_mode ?";
2444 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2446 quiltify_dpkg_commit "auto-$version-$target-$time",
2447 (getfield $clogp, 'Maintainer'),
2448 "Automatically generated patch ($clogp->{Version})\n".
2449 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2453 progress "quiltify linearisation planning successful, executing...";
2455 for (my $p = $sref_S;
2456 my $c = $p->{Child};
2458 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2459 next unless $p->{Nontrivial};
2461 my $cc = $c->{Commit};
2463 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2464 $commitdata =~ m/\n\n/ or die "$c ?";
2467 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2470 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2473 my $patchname = $title;
2474 $patchname =~ s/[.:]$//;
2475 $patchname =~ y/ A-Z/-a-z/;
2476 $patchname =~ y/-a-z0-9_.+=~//cd;
2477 $patchname =~ s/^\W/x-$&/;
2478 $patchname = substr($patchname,0,40);
2481 stat "debian/patches/$patchname$index";
2483 $!==ENOENT or die "$patchname$index $!";
2485 runcmd @git, qw(checkout -q), $cc;
2487 # We use the tip's changelog so that dpkg-source doesn't
2488 # produce complaining messages from dpkg-parsechangelog. None
2489 # of the information dpkg-source gets from the changelog is
2490 # actually relevant - it gets put into the original message
2491 # which dpkg-source provides our stunt editor, and then
2493 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2495 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2496 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2498 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2501 runcmd @git, qw(checkout -q master);
2504 sub build_maybe_quilt_fixup () {
2505 my $format=get_source_format;
2506 return unless madformat $format;
2509 check_for_vendor_patches();
2512 # - honour any existing .pc in case it has any strangeness
2513 # - determine the git commit corresponding to the tip of
2514 # the patch stack (if there is one)
2515 # - if there is such a git commit, convert each subsequent
2516 # git commit into a quilt patch with dpkg-source --commit
2517 # - otherwise convert all the differences in the tree into
2518 # a single git commit
2522 # Our git tree doesn't necessarily contain .pc. (Some versions of
2523 # dgit would include the .pc in the git tree.) If there isn't
2524 # one, we need to generate one by unpacking the patches that we
2527 # We first look for a .pc in the git tree. If there is one, we
2528 # will use it. (This is not the normal case.)
2530 # Otherwise need to regenerate .pc so that dpkg-source --commit
2531 # can work. We do this as follows:
2532 # 1. Collect all relevant .orig from parent directory
2533 # 2. Generate a debian.tar.gz out of
2534 # debian/{patches,rules,source/format}
2535 # 3. Generate a fake .dsc containing just these fields:
2536 # Format Source Version Files
2537 # 4. Extract the fake .dsc
2538 # Now the fake .dsc has a .pc directory.
2539 # (In fact we do this in every case, because in future we will
2540 # want to search for a good base commit for generating patches.)
2542 # Then we can actually do the dpkg-source --commit
2543 # 1. Make a new working tree with the same object
2544 # store as our main tree and check out the main
2546 # 2. Copy .pc from the fake's extraction, if necessary
2547 # 3. Run dpkg-source --commit
2548 # 4. If the result has changes to debian/, then
2549 # - git-add them them
2550 # - git-add .pc if we had a .pc in-tree
2552 # 5. If we had a .pc in-tree, delete it, and git-commit
2553 # 6. Back in the main tree, fast forward to the new HEAD
2555 my $clogp = parsechangelog();
2556 my $headref = git_rev_parse('HEAD');
2561 my $upstreamversion=$version;
2562 $upstreamversion =~ s/-[^-]*$//;
2564 my $fakeversion="$upstreamversion-~~DGITFAKE";
2566 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2567 print $fakedsc <<END or die $!;
2570 Version: $fakeversion
2574 my $dscaddfile=sub {
2577 my $md = new Digest::MD5;
2579 my $fh = new IO::File $b, '<' or die "$b $!";
2584 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2587 foreach my $f (<../../../../*>) { #/){
2588 my $b=$f; $b =~ s{.*/}{};
2589 next unless is_orig_file $b, srcfn $upstreamversion,'';
2590 link $f, $b or die "$b $!";
2594 my @files=qw(debian/source/format debian/rules);
2595 if (stat_exists '../../../debian/patches') {
2596 push @files, 'debian/patches';
2599 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2600 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2602 $dscaddfile->($debtar);
2603 close $fakedsc or die $!;
2605 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2607 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2608 rename $fakexdir, "fake" or die "$fakexdir $!";
2610 mkdir "work" or die $!;
2612 mktree_in_ud_here();
2613 runcmd @git, qw(reset --hard), $headref;
2616 if (stat_exists ".pc") {
2618 progress "Tree already contains .pc - will use it then delete it.";
2621 rename '../fake/.pc','.pc' or die $!;
2624 quiltify($clogp,$headref);
2626 if (!open P, '>>', ".pc/applied-patches") {
2627 $!==&ENOENT or die $!;
2632 commit_quilty_patch();
2634 if ($mustdeletepc) {
2635 runcmd @git, qw(rm -rqf .pc);
2636 commit_admin "Commit removal of .pc (quilt series tracking data)";
2639 changedir '../../../..';
2640 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2643 sub quilt_fixup_editor () {
2644 my $descfn = $ENV{$fakeeditorenv};
2645 my $editing = $ARGV[$#ARGV];
2646 open I1, '<', $descfn or die "$descfn: $!";
2647 open I2, '<', $editing or die "$editing: $!";
2648 unlink $editing or die "$editing: $!";
2649 open O, '>', $editing or die "$editing: $!";
2650 while (<I1>) { print O or die $!; } I1->error and die $!;
2653 $copying ||= m/^\-\-\- /;
2654 next unless $copying;
2657 I2->error and die $!;
2662 #----- other building -----
2665 if ($cleanmode eq 'dpkg-source') {
2666 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2667 } elsif ($cleanmode eq 'dpkg-source-d') {
2668 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2669 } elsif ($cleanmode eq 'git') {
2670 runcmd_ordryrun_local @git, qw(clean -xdf);
2671 } elsif ($cleanmode eq 'git-ff') {
2672 runcmd_ordryrun_local @git, qw(clean -xdff);
2673 } elsif ($cleanmode eq 'check') {
2674 my $leftovers = cmdoutput @git, qw(clean -xdn);
2675 if (length $leftovers) {
2676 print STDERR $leftovers, "\n" or die $!;
2677 fail "tree contains uncommitted files and --clean=check specified";
2679 } elsif ($cleanmode eq 'none') {
2686 badusage "clean takes no additional arguments" if @ARGV;
2691 badusage "-p is not allowed when building" if defined $package;
2694 my $clogp = parsechangelog();
2695 $isuite = getfield $clogp, 'Distribution';
2696 $package = getfield $clogp, 'Source';
2697 $version = getfield $clogp, 'Version';
2698 build_maybe_quilt_fixup();
2701 sub changesopts () {
2702 my @opts =@changesopts[1..$#changesopts];
2703 if (!defined $changes_since_version) {
2704 my @vsns = archive_query('archive_query');
2705 my @quirk = access_quirk();
2706 if ($quirk[0] eq 'backports') {
2707 local $isuite = $quirk[2];
2709 canonicalise_suite();
2710 push @vsns, archive_query('archive_query');
2713 @vsns = map { $_->[0] } @vsns;
2714 @vsns = sort { -version_compare($a, $b) } @vsns;
2715 $changes_since_version = $vsns[0];
2716 progress "changelog will contain changes since $vsns[0]";
2718 $changes_since_version = '_';
2719 progress "package seems new, not specifying -v<version>";
2722 if ($changes_since_version ne '_') {
2723 unshift @opts, "-v$changes_since_version";
2728 sub massage_dbp_args ($) {
2730 return unless $cleanmode =~ m/git|none/;
2731 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2732 my @newcmd = shift @$cmd;
2733 # -nc has the side effect of specifying -b if nothing else specified
2734 push @newcmd, '-nc';
2735 # and some combinations of -S, -b, et al, are errors, rather than
2736 # later simply overriding earlier
2737 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2738 push @newcmd, @$cmd;
2744 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2745 massage_dbp_args \@dbp;
2746 runcmd_ordryrun_local @dbp;
2747 printdone "build successful\n";
2752 my @dbp = @dpkgbuildpackage;
2753 massage_dbp_args \@dbp;
2755 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2756 "--git-builder=@dbp");
2757 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2758 canonicalise_suite();
2759 push @cmd, "--git-debian-branch=".lbranch();
2761 push @cmd, changesopts();
2762 runcmd_ordryrun_local @cmd, @ARGV;
2763 printdone "build successful\n";
2768 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2769 $dscfn = dscfn($version);
2770 if ($cleanmode eq 'dpkg-source') {
2771 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2773 } elsif ($cleanmode eq 'dpkg-source-d') {
2774 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2777 my $pwd = must_getcwd();
2778 my $leafdir = basename $pwd;
2780 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2782 runcmd_ordryrun_local qw(sh -ec),
2783 'exec >$1; shift; exec "$@"','x',
2784 "../$sourcechanges",
2785 @dpkggenchanges, qw(-S), changesopts();
2789 sub cmd_build_source {
2790 badusage "build-source takes no additional arguments" if @ARGV;
2792 printdone "source built, results in $dscfn and $sourcechanges";
2798 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2800 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2801 stat_exists $sourcechanges
2802 or fail "$sourcechanges (in parent directory): $!";
2803 foreach my $cf (glob $pat) {
2804 next if $cf eq $sourcechanges;
2805 unlink $cf or fail "remove $cf: $!";
2808 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2809 my @changesfiles = glob $pat;
2810 @changesfiles = sort {
2811 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2814 fail "wrong number of different changes files (@changesfiles)"
2815 unless @changesfiles;
2816 runcmd_ordryrun_local @mergechanges, @changesfiles;
2817 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2819 stat_exists $multichanges or fail "$multichanges: $!";
2821 printdone "build successful, results in $multichanges\n" or die $!;
2824 sub cmd_quilt_fixup {
2825 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2826 my $clogp = parsechangelog();
2827 $version = getfield $clogp, 'Version';
2828 $package = getfield $clogp, 'Source';
2829 build_maybe_quilt_fixup();
2832 sub cmd_archive_api_query {
2833 badusage "need only 1 subpath argument" unless @ARGV==1;
2834 my ($subpath) = @ARGV;
2835 my @cmd = archive_api_query_cmd($subpath);
2837 exec @cmd or fail "exec curl: $!\n";
2840 sub cmd_clone_dgit_repos_server {
2841 badusage "need destination argument" unless @ARGV==1;
2842 my ($destdir) = @ARGV;
2843 $package = '_dgit-repos-server';
2844 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2846 exec @cmd or fail "exec git clone: $!\n";
2849 sub cmd_setup_mergechangelogs {
2850 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2851 setup_mergechangelogs();
2854 #---------- argument parsing and main program ----------
2857 print "dgit version $our_version\n" or die $!;
2864 if (defined $ENV{'DGIT_SSH'}) {
2865 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2866 } elsif (defined $ENV{'GIT_SSH'}) {
2867 @ssh = ($ENV{'GIT_SSH'});
2871 last unless $ARGV[0] =~ m/^-/;
2875 if (m/^--dry-run$/) {
2878 } elsif (m/^--damp-run$/) {
2881 } elsif (m/^--no-sign$/) {
2884 } elsif (m/^--help$/) {
2886 } elsif (m/^--version$/) {
2888 } elsif (m/^--new$/) {
2891 } elsif (m/^--since-version=([^_]+|_)$/) {
2893 $changes_since_version = $1;
2894 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2895 ($om = $opts_opt_map{$1}) &&
2899 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2900 !$opts_opt_cmdonly{$1} &&
2901 ($om = $opts_opt_map{$1})) {
2904 } elsif (m/^--existing-package=(.*)/s) {
2906 $existing_package = $1;
2907 } elsif (m/^--initiator-tempdir=(.*)/s) {
2908 $initiator_tempdir = $1;
2909 $initiator_tempdir =~ m#^/# or
2910 badusage "--initiator-tempdir must be used specify an".
2911 " absolute, not relative, directory."
2912 } elsif (m/^--distro=(.*)/s) {
2915 } elsif (m/^--build-products-dir=(.*)/s) {
2917 $buildproductsdir = $1;
2918 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2921 } elsif (m/^--clean=(.*)$/s) {
2922 badusage "unknown cleaning mode \`$1'";
2923 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2926 } elsif (m/^--quilt=(.*)$/s) {
2927 badusage "unknown quilt fixup mode \`$1'";
2928 } elsif (m/^--ignore-dirty$/s) {
2931 } elsif (m/^--no-quilt-fixup$/s) {
2933 $quilt_mode = 'nocheck';
2934 } elsif (m/^--no-rm-on-error$/s) {
2937 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2939 push @deliberatelies, $&;
2941 badusage "unknown long option \`$_'";
2948 } elsif (s/^-L/-/) {
2951 } elsif (s/^-h/-/) {
2953 } elsif (s/^-D/-/) {
2957 } elsif (s/^-N/-/) {
2960 } elsif (s/^-v([^_]+|_)$//s) {
2962 $changes_since_version = $1;
2965 push @changesopts, $_;
2967 } elsif (s/^-c(.*=.*)//s) {
2969 push @git, '-c', $1;
2970 } elsif (s/^-d(.+)//s) {
2973 } elsif (s/^-C(.+)//s) {
2976 if ($changesfile =~ s#^(.*)/##) {
2977 $buildproductsdir = $1;
2979 } elsif (s/^-k(.+)//s) {
2981 } elsif (m/^-[vdCk]$/) {
2983 "option \`$_' requires an argument (and no space before the argument)";
2984 } elsif (s/^-wn$//s) {
2986 $cleanmode = 'none';
2987 } elsif (s/^-wg$//s) {
2990 } elsif (s/^-wgf$//s) {
2992 $cleanmode = 'git-ff';
2993 } elsif (s/^-wd$//s) {
2995 $cleanmode = 'dpkg-source';
2996 } elsif (s/^-wdd$//s) {
2998 $cleanmode = 'dpkg-source-d';
2999 } elsif (s/^-wc$//s) {
3001 $cleanmode = 'check';
3003 badusage "unknown short option \`$_'";
3010 if ($ENV{$fakeeditorenv}) {
3011 quilt_fixup_editor();
3015 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3016 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3017 if $dryrun_level == 1;
3019 print STDERR $helpmsg or die $!;
3022 my $cmd = shift @ARGV;
3025 if (!defined $quilt_mode) {
3026 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3027 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3029 $quilt_mode =~ m/^($quilt_modes_re)$/
3030 or badcfg "unknown quilt-mode \`$quilt_mode'";
3034 my $fn = ${*::}{"cmd_$cmd"};
3035 $fn or badusage "unknown operation $cmd";