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-check' => 'url',
448 'dgit-distro.debian.git-check-suffix' => '/info/refs',
449 'dgit-distro.debian/push.git-url' => '',
450 'dgit-distro.debian/push.git-host' => 'dgit-git.debian.net',
451 'dgit-distro.debian/push.git-user-force' => 'dgit',
452 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
453 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
454 'dgit-distro.debian/push.git-create' => 'true',
455 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
456 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
457 # 'dgit-distro.debian.archive-query-tls-key',
458 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
459 # ^ this does not work because curl is broken nowadays
460 # Fixing #790093 properly will involve providing providing the key
461 # in some pacagke and maybe updating these paths.
463 # 'dgit-distro.debian.archive-query-tls-curl-args',
464 # '--ca-path=/etc/ssl/ca-debian',
465 # ^ this is a workaround but works (only) on DSA-administered machines
466 'dgit-distro.debian.diverts.alioth' => '/alioth',
467 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
468 'dgit-distro.debian.git-url-suffix' => '',
469 'dgit-distro.debian/push.diverts.alioth' => '/alioth',
470 'dgit-distro.debian/alioth.git-host' => 'git.debian.org',
471 'dgit-distro.debian/alioth.git-user-force' => '',
472 'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
473 'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
474 'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
475 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
476 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
477 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
478 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
479 'dgit-distro.ubuntu.git-check' => 'false',
480 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
481 'dgit-distro.test-dummy.ssh' => "$td/ssh",
482 'dgit-distro.test-dummy.username' => "alice",
483 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
484 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
485 'dgit-distro.test-dummy.git-url' => "$td/git",
486 'dgit-distro.test-dummy.git-host' => "git",
487 'dgit-distro.test-dummy.git-path' => "$td/git",
488 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
489 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
490 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
491 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
494 sub git_get_config ($) {
497 our %git_get_config_memo;
498 if (exists $git_get_config_memo{$c}) {
499 return $git_get_config_memo{$c};
503 my @cmd = (@git, qw(config --), $c);
505 local ($debuglevel) = $debuglevel-2;
506 $v = cmdoutput_errok @cmd;
514 $git_get_config_memo{$c} = $v;
520 return undef if $c =~ /RETURN-UNDEF/;
521 my $v = git_get_config($c);
522 return $v if defined $v;
523 my $dv = $defcfg{$c};
524 return $dv if defined $dv;
526 badcfg "need value for one of: @_\n".
527 "$us: distro or suite appears not to be (properly) supported";
530 sub access_basedistro () {
531 if (defined $idistro) {
534 return cfg("dgit-suite.$isuite.distro",
535 "dgit.default.distro");
539 sub access_quirk () {
540 # returns (quirk name, distro to use instead or undef, quirk-specific info)
541 my $basedistro = access_basedistro();
542 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
544 if (defined $backports_quirk) {
545 my $re = $backports_quirk;
546 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
548 $re =~ s/\%/([-0-9a-z_]+)/
549 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
550 if ($isuite =~ m/^$re$/) {
551 return ('backports',"$basedistro-backports",$1);
554 return ('none',undef);
557 our $access_pushing = 0;
563 sub access_distros () {
564 # Returns list of distros to try, in order
567 # 0. `instead of' distro name(s) we have been pointed to
568 # 1. the access_quirk distro, if any
569 # 2a. the user's specified distro, or failing that } basedistro
570 # 2b. the distro calculated from the suite }
571 my @l = access_basedistro();
573 my (undef,$quirkdistro) = access_quirk();
574 unshift @l, $quirkdistro;
575 unshift @l, $instead_distro;
576 @l = grep { defined } @l;
578 if ($access_pushing) {
579 @l = map { ("$_/push", $_) } @l;
587 # The nesting of these loops determines the search order. We put
588 # the key loop on the outside so that we search all the distros
589 # for each key, before going on to the next key. That means that
590 # if access_cfg is called with a more specific, and then a less
591 # specific, key, an earlier distro can override the less specific
592 # without necessarily overriding any more specific keys. (If the
593 # distro wants to override the more specific keys it can simply do
594 # so; whereas if we did the loop the other way around, it would be
595 # impossible to for an earlier distro to override a less specific
596 # key but not the more specific ones without restating the unknown
597 # values of the more specific keys.
600 # We have to deal with RETURN-UNDEF specially, so that we don't
601 # terminate the search prematurely.
603 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
606 foreach my $d (access_distros()) {
607 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
609 push @cfgs, map { "dgit.default.$_" } @realkeys;
611 my $value = cfg(@cfgs);
615 sub string_to_ssh ($) {
617 if ($spec =~ m/\s/) {
618 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
624 sub access_cfg_ssh () {
625 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
626 if (!defined $gitssh) {
629 return string_to_ssh $gitssh;
633 sub access_runeinfo ($) {
635 return ": dgit ".access_basedistro()." $info ;";
638 sub access_someuserhost ($) {
640 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
641 defined($user) && length($user) or
642 $user = access_cfg("$some-user",'username');
643 my $host = access_cfg("$some-host");
644 return length($user) ? "$user\@$host" : $host;
647 sub access_gituserhost () {
648 return access_someuserhost('git');
651 sub access_giturl (;$) {
653 my $url = access_cfg('git-url','RETURN-UNDEF');
656 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
657 return undef unless defined $proto;
660 access_gituserhost().
661 access_cfg('git-path');
663 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
666 return "$url/$package$suffix";
669 sub parsecontrolfh ($$;$) {
670 my ($fh, $desc, $allowsigned) = @_;
671 our $dpkgcontrolhash_noissigned;
674 my %opts = ('name' => $desc);
675 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
676 $c = Dpkg::Control::Hash->new(%opts);
677 $c->parse($fh,$desc) or die "parsing of $desc failed";
678 last if $allowsigned;
679 last if $dpkgcontrolhash_noissigned;
680 my $issigned= $c->get_option('is_pgp_signed');
681 if (!defined $issigned) {
682 $dpkgcontrolhash_noissigned= 1;
683 seek $fh, 0,0 or die "seek $desc: $!";
684 } elsif ($issigned) {
685 fail "control file $desc is (already) PGP-signed. ".
686 " Note that dgit push needs to modify the .dsc and then".
687 " do the signature itself";
696 my ($file, $desc) = @_;
697 my $fh = new IO::Handle;
698 open $fh, '<', $file or die "$file: $!";
699 my $c = parsecontrolfh($fh,$desc);
700 $fh->error and die $!;
706 my ($dctrl,$field) = @_;
707 my $v = $dctrl->{$field};
708 return $v if defined $v;
709 fail "missing field $field in ".$v->get_option('name');
713 my $c = Dpkg::Control::Hash->new();
714 my $p = new IO::Handle;
715 my @cmd = (qw(dpkg-parsechangelog), @_);
716 open $p, '-|', @cmd or die $!;
718 $?=0; $!=0; close $p or failedcmd @cmd;
724 defined $d or fail "getcwd failed: $!";
730 sub archive_query ($) {
732 my $query = access_cfg('archive-query','RETURN-UNDEF');
733 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
736 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
739 sub pool_dsc_subpath ($$) {
740 my ($vsn,$component) = @_; # $package is implict arg
741 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
742 return "/pool/$component/$prefix/$package/".dscfn($vsn);
745 #---------- `ftpmasterapi' archive query method (nascent) ----------
747 sub archive_api_query_cmd ($) {
749 my @cmd = qw(curl -sS);
750 my $url = access_cfg('archive-query-url');
751 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
753 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
754 foreach my $key (split /\:/, $keys) {
755 $key =~ s/\%HOST\%/$host/g;
757 fail "for $url: stat $key: $!" unless $!==ENOENT;
760 fail "config requested specific TLS key but do not know".
761 " how to get curl to use exactly that EE key ($key)";
762 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
763 # # Sadly the above line does not work because of changes
764 # # to gnutls. The real fix for #790093 may involve
765 # # new curl options.
768 # Fixing #790093 properly will involve providing a value
769 # for this on clients.
770 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
771 push @cmd, split / /, $kargs if defined $kargs;
773 push @cmd, $url.$subpath;
779 my ($data, $subpath) = @_;
780 badcfg "ftpmasterapi archive query method takes no data part"
782 my @cmd = archive_api_query_cmd($subpath);
783 my $json = cmdoutput @cmd;
784 return decode_json($json);
787 sub canonicalise_suite_ftpmasterapi () {
788 my ($proto,$data) = @_;
789 my $suites = api_query($data, 'suites');
791 foreach my $entry (@$suites) {
793 my $v = $entry->{$_};
794 defined $v && $v eq $isuite;
796 push @matched, $entry;
798 fail "unknown suite $isuite" unless @matched;
801 @matched==1 or die "multiple matches for suite $isuite\n";
802 $cn = "$matched[0]{codename}";
803 defined $cn or die "suite $isuite info has no codename\n";
804 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
806 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
811 sub archive_query_ftpmasterapi () {
812 my ($proto,$data) = @_;
813 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
815 my $digester = Digest::SHA->new(256);
816 foreach my $entry (@$info) {
818 my $vsn = "$entry->{version}";
819 my ($ok,$msg) = version_check $vsn;
820 die "bad version: $msg\n" unless $ok;
821 my $component = "$entry->{component}";
822 $component =~ m/^$component_re$/ or die "bad component";
823 my $filename = "$entry->{filename}";
824 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
825 or die "bad filename";
826 my $sha256sum = "$entry->{sha256sum}";
827 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
828 push @rows, [ $vsn, "/pool/$component/$filename",
829 $digester, $sha256sum ];
831 die "bad ftpmaster api response: $@\n".Dumper($entry)
834 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
838 #---------- `madison' archive query method ----------
840 sub archive_query_madison {
841 return map { [ @$_[0..1] ] } madison_get_parse(@_);
844 sub madison_get_parse {
845 my ($proto,$data) = @_;
846 die unless $proto eq 'madison';
848 $data= access_cfg('madison-distro','RETURN-UNDEF');
849 $data //= access_basedistro();
851 $rmad{$proto,$data,$package} ||= cmdoutput
852 qw(rmadison -asource),"-s$isuite","-u$data",$package;
853 my $rmad = $rmad{$proto,$data,$package};
856 foreach my $l (split /\n/, $rmad) {
857 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
858 \s*( [^ \t|]+ )\s* \|
859 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
860 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
861 $1 eq $package or die "$rmad $package ?";
868 $component = access_cfg('archive-query-default-component');
870 $5 eq 'source' or die "$rmad ?";
871 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
873 return sort { -version_compare($a->[0],$b->[0]); } @out;
876 sub canonicalise_suite_madison {
877 # madison canonicalises for us
878 my @r = madison_get_parse(@_);
880 "unable to canonicalise suite using package $package".
881 " which does not appear to exist in suite $isuite;".
882 " --existing-package may help";
886 #---------- `sshpsql' archive query method ----------
889 my ($data,$runeinfo,$sql) = @_;
891 $data= access_someuserhost('sshpsql').':'.
892 access_cfg('sshpsql-dbname');
894 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
895 my ($userhost,$dbname) = ($`,$'); #';
897 my @cmd = (access_cfg_ssh, $userhost,
898 access_runeinfo("ssh-psql $runeinfo").
899 " export LC_MESSAGES=C; export LC_CTYPE=C;".
900 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
902 open P, "-|", @cmd or die $!;
905 printdebug("$debugprefix>|$_|\n");
908 $!=0; $?=0; close P or failedcmd @cmd;
910 my $nrows = pop @rows;
911 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
912 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
913 @rows = map { [ split /\|/, $_ ] } @rows;
914 my $ncols = scalar @{ shift @rows };
915 die if grep { scalar @$_ != $ncols } @rows;
919 sub sql_injection_check {
920 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
923 sub archive_query_sshpsql ($$) {
924 my ($proto,$data) = @_;
925 sql_injection_check $isuite, $package;
926 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
927 SELECT source.version, component.name, files.filename, files.sha256sum
929 JOIN src_associations ON source.id = src_associations.source
930 JOIN suite ON suite.id = src_associations.suite
931 JOIN dsc_files ON dsc_files.source = source.id
932 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
933 JOIN component ON component.id = files_archive_map.component_id
934 JOIN files ON files.id = dsc_files.file
935 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
936 AND source.source='$package'
937 AND files.filename LIKE '%.dsc';
939 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
940 my $digester = Digest::SHA->new(256);
942 my ($vsn,$component,$filename,$sha256sum) = @$_;
943 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
948 sub canonicalise_suite_sshpsql ($$) {
949 my ($proto,$data) = @_;
950 sql_injection_check $isuite;
951 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
952 SELECT suite.codename
953 FROM suite where suite_name='$isuite' or codename='$isuite';
955 @rows = map { $_->[0] } @rows;
956 fail "unknown suite $isuite" unless @rows;
957 die "ambiguous $isuite: @rows ?" if @rows>1;
961 #---------- `dummycat' archive query method ----------
963 sub canonicalise_suite_dummycat ($$) {
964 my ($proto,$data) = @_;
965 my $dpath = "$data/suite.$isuite";
966 if (!open C, "<", $dpath) {
967 $!==ENOENT or die "$dpath: $!";
968 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
972 chomp or die "$dpath: $!";
974 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
978 sub archive_query_dummycat ($$) {
979 my ($proto,$data) = @_;
980 canonicalise_suite();
981 my $dpath = "$data/package.$csuite.$package";
982 if (!open C, "<", $dpath) {
983 $!==ENOENT or die "$dpath: $!";
984 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
992 printdebug "dummycat query $csuite $package $dpath | $_\n";
993 my @row = split /\s+/, $_;
994 @row==2 or die "$dpath: $_ ?";
997 C->error and die "$dpath: $!";
999 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1002 #---------- archive query entrypoints and rest of program ----------
1004 sub canonicalise_suite () {
1005 return if defined $csuite;
1006 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1007 $csuite = archive_query('canonicalise_suite');
1008 if ($isuite ne $csuite) {
1009 progress "canonical suite name for $isuite is $csuite";
1013 sub get_archive_dsc () {
1014 canonicalise_suite();
1015 my @vsns = archive_query('archive_query');
1016 foreach my $vinfo (@vsns) {
1017 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1018 $dscurl = access_cfg('mirror').$subpath;
1019 $dscdata = url_get($dscurl);
1021 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1026 $digester->add($dscdata);
1027 my $got = $digester->hexdigest();
1029 fail "$dscurl has hash $got but".
1030 " archive told us to expect $digest";
1032 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1033 printdebug Dumper($dscdata) if $debuglevel>1;
1034 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1035 printdebug Dumper($dsc) if $debuglevel>1;
1036 my $fmt = getfield $dsc, 'Format';
1037 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1038 $dsc_checked = !!$digester;
1044 sub check_for_git ();
1045 sub check_for_git () {
1047 my $how = access_cfg('git-check');
1048 if ($how eq 'ssh-cmd') {
1050 (access_cfg_ssh, access_gituserhost(),
1051 access_runeinfo("git-check $package").
1052 " set -e; cd ".access_cfg('git-path').";".
1053 " if test -d $package.git; then echo 1; else echo 0; fi");
1054 my $r= cmdoutput @cmd;
1055 if ($r =~ m/^divert (\w+)$/) {
1057 my ($usedistro,) = access_distros();
1058 # NB that if we are pushing, $usedistro will be $distro/push
1059 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1060 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1061 progress "diverting to $divert (using config for $instead_distro)";
1062 return check_for_git();
1064 failedcmd @cmd unless $r =~ m/^[01]$/;
1066 } elsif ($how eq 'url') {
1067 my $prefix = access_cfg('git-check-url','git-url');
1068 my $suffix = access_cfg('git-check-suffix','git-suffix',
1069 'RETURN-UNDEF') // '.git';
1070 my $url = "$prefix/$package$suffix";
1071 my @cmd = (qw(curl -sS -I), $url);
1072 my $result = cmdoutput @cmd;
1073 $result =~ m/^\S+ (404|200) /s or
1074 fail "unexpected results from git check query - ".
1075 Dumper($prefix, $result);
1077 if ($code eq '404') {
1079 } elsif ($code eq '200') {
1084 } elsif ($how eq 'true') {
1086 } elsif ($how eq 'false') {
1089 badcfg "unknown git-check \`$how'";
1093 sub create_remote_git_repo () {
1094 my $how = access_cfg('git-create');
1095 if ($how eq 'ssh-cmd') {
1097 (access_cfg_ssh, access_gituserhost(),
1098 access_runeinfo("git-create $package").
1099 "set -e; cd ".access_cfg('git-path').";".
1100 " cp -a _template $package.git");
1101 } elsif ($how eq 'true') {
1104 badcfg "unknown git-create \`$how'";
1108 our ($dsc_hash,$lastpush_hash);
1110 our $ud = '.git/dgit/unpack';
1115 mkdir $ud or die $!;
1118 sub mktree_in_ud_here () {
1119 runcmd qw(git init -q);
1120 rmtree('.git/objects');
1121 symlink '../../../../objects','.git/objects' or die $!;
1124 sub git_write_tree () {
1125 my $tree = cmdoutput @git, qw(write-tree);
1126 $tree =~ m/^\w+$/ or die "$tree ?";
1130 sub mktree_in_ud_from_only_subdir () {
1131 # changes into the subdir
1133 die unless @dirs==1;
1134 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1137 fail "source package contains .git directory" if stat_exists '.git';
1138 mktree_in_ud_here();
1139 my $format=get_source_format();
1140 if (madformat($format)) {
1143 runcmd @git, qw(add -Af);
1144 my $tree=git_write_tree();
1145 return ($tree,$dir);
1148 sub dsc_files_info () {
1149 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1150 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1151 ['Files', 'Digest::MD5', 'new()']) {
1152 my ($fname, $module, $method) = @$csumi;
1153 my $field = $dsc->{$fname};
1154 next unless defined $field;
1155 eval "use $module; 1;" or die $@;
1157 foreach (split /\n/, $field) {
1159 m/^(\w+) (\d+) (\S+)$/ or
1160 fail "could not parse .dsc $fname line \`$_'";
1161 my $digester = eval "$module"."->$method;" or die $@;
1166 Digester => $digester,
1171 fail "missing any supported Checksums-* or Files field in ".
1172 $dsc->get_option('name');
1176 map { $_->{Filename} } dsc_files_info();
1179 sub is_orig_file ($;$) {
1182 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1183 defined $base or return 1;
1187 sub make_commit ($) {
1189 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1192 sub clogp_authline ($) {
1194 my $author = getfield $clogp, 'Maintainer';
1195 $author =~ s#,.*##ms;
1196 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1197 my $authline = "$author $date";
1198 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1199 fail "unexpected commit author line format \`$authline'".
1200 " (was generated from changelog Maintainer field)";
1204 sub vendor_patches_distro ($$) {
1205 my ($checkdistro, $what) = @_;
1206 return unless defined $checkdistro;
1208 my $series = "debian/patches/\L$checkdistro\E.series";
1209 printdebug "checking for vendor-specific $series ($what)\n";
1211 if (!open SERIES, "<", $series) {
1212 die "$series $!" unless $!==ENOENT;
1221 Unfortunately, this source package uses a feature of dpkg-source where
1222 the same source package unpacks to different source code on different
1223 distros. dgit cannot safely operate on such packages on affected
1224 distros, because the meaning of source packages is not stable.
1226 Please ask the distro/maintainer to remove the distro-specific series
1227 files and use a different technique (if necessary, uploading actually
1228 different packages, if different distros are supposed to have
1232 fail "Found active distro-specific series file for".
1233 " $checkdistro ($what): $series, cannot continue";
1235 die "$series $!" if SERIES->error;
1239 sub check_for_vendor_patches () {
1240 # This dpkg-source feature doesn't seem to be documented anywhere!
1241 # But it can be found in the changelog (reformatted):
1243 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1244 # Author: Raphael Hertzog <hertzog@debian.org>
1245 # Date: Sun Oct 3 09:36:48 2010 +0200
1247 # dpkg-source: correctly create .pc/.quilt_series with alternate
1250 # If you have debian/patches/ubuntu.series and you were
1251 # unpacking the source package on ubuntu, quilt was still
1252 # directed to debian/patches/series instead of
1253 # debian/patches/ubuntu.series.
1255 # debian/changelog | 3 +++
1256 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1257 # 2 files changed, 6 insertions(+), 1 deletion(-)
1260 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1261 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1262 "Dpkg::Vendor \`current vendor'");
1263 vendor_patches_distro(access_basedistro(),
1264 "distro being accessed");
1267 sub generate_commit_from_dsc () {
1271 foreach my $fi (dsc_files_info()) {
1272 my $f = $fi->{Filename};
1273 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1275 link "../../../$f", $f
1279 complete_file_from_dsc('.', $fi);
1281 if (is_orig_file($f)) {
1282 link $f, "../../../../$f"
1288 my $dscfn = "$package.dsc";
1290 open D, ">", $dscfn or die "$dscfn: $!";
1291 print D $dscdata or die "$dscfn: $!";
1292 close D or die "$dscfn: $!";
1293 my @cmd = qw(dpkg-source);
1294 push @cmd, '--no-check' if $dsc_checked;
1295 push @cmd, qw(-x --), $dscfn;
1298 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1299 check_for_vendor_patches() if madformat($dsc->{format});
1300 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1301 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1302 my $authline = clogp_authline $clogp;
1303 my $changes = getfield $clogp, 'Changes';
1304 open C, ">../commit.tmp" or die $!;
1305 print C <<END or die $!;
1312 # imported from the archive
1315 my $outputhash = make_commit qw(../commit.tmp);
1316 my $cversion = getfield $clogp, 'Version';
1317 progress "synthesised git commit from .dsc $cversion";
1318 if ($lastpush_hash) {
1319 runcmd @git, qw(reset --hard), $lastpush_hash;
1320 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1321 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1322 my $oversion = getfield $oldclogp, 'Version';
1324 version_compare($oversion, $cversion);
1326 # git upload/ is earlier vsn than archive, use archive
1327 open C, ">../commit2.tmp" or die $!;
1328 print C <<END or die $!;
1330 parent $lastpush_hash
1335 Record $package ($cversion) in archive suite $csuite
1337 $outputhash = make_commit qw(../commit2.tmp);
1338 } elsif ($vcmp > 0) {
1339 print STDERR <<END or die $!;
1341 Version actually in archive: $cversion (older)
1342 Last allegedly pushed/uploaded: $oversion (newer or same)
1345 $outputhash = $lastpush_hash;
1347 $outputhash = $lastpush_hash;
1350 changedir '../../../..';
1351 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1352 'DGIT_ARCHIVE', $outputhash;
1353 cmdoutput @git, qw(log -n2), $outputhash;
1354 # ... gives git a chance to complain if our commit is malformed
1359 sub complete_file_from_dsc ($$) {
1360 our ($dstdir, $fi) = @_;
1361 # Ensures that we have, in $dir, the file $fi, with the correct
1362 # contents. (Downloading it from alongside $dscurl if necessary.)
1364 my $f = $fi->{Filename};
1365 my $tf = "$dstdir/$f";
1368 if (stat_exists $tf) {
1369 progress "using existing $f";
1372 $furl =~ s{/[^/]+$}{};
1374 die "$f ?" unless $f =~ m/^${package}_/;
1375 die "$f ?" if $f =~ m#/#;
1376 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1377 next if !act_local();
1381 open F, "<", "$tf" or die "$tf: $!";
1382 $fi->{Digester}->reset();
1383 $fi->{Digester}->addfile(*F);
1384 F->error and die $!;
1385 my $got = $fi->{Digester}->hexdigest();
1386 $got eq $fi->{Hash} or
1387 fail "file $f has hash $got but .dsc".
1388 " demands hash $fi->{Hash} ".
1389 ($downloaded ? "(got wrong file from archive!)"
1390 : "(perhaps you should delete this file?)");
1393 sub ensure_we_have_orig () {
1394 foreach my $fi (dsc_files_info()) {
1395 my $f = $fi->{Filename};
1396 next unless is_orig_file($f);
1397 complete_file_from_dsc('..', $fi);
1401 sub git_fetch_us () {
1402 my @specs = (fetchspec());
1404 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1406 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1409 my $tagpat = debiantag('*',access_basedistro);
1411 git_for_each_ref("refs/tags/".$tagpat, sub {
1412 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1413 printdebug "currently $fullrefname=$objid\n";
1414 $here{$fullrefname} = $objid;
1416 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1417 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1418 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1419 printdebug "offered $lref=$objid\n";
1420 if (!defined $here{$lref}) {
1421 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1422 runcmd_ordryrun_local @upd;
1423 } elsif ($here{$lref} eq $objid) {
1426 "Not updateting $lref from $here{$lref} to $objid.\n";
1431 sub fetch_from_archive () {
1432 # ensures that lrref() is what is actually in the archive,
1433 # one way or another
1437 foreach my $field (@ourdscfield) {
1438 $dsc_hash = $dsc->{$field};
1439 last if defined $dsc_hash;
1441 if (defined $dsc_hash) {
1442 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1444 progress "last upload to archive specified git hash";
1446 progress "last upload to archive has NO git hash";
1449 progress "no version available from the archive";
1452 $lastpush_hash = git_get_ref(lrref());
1453 printdebug "previous reference hash=$lastpush_hash\n";
1455 if (defined $dsc_hash) {
1456 fail "missing remote git history even though dsc has hash -".
1457 " could not find ref ".lrref().
1458 " (should have been fetched from ".access_giturl()."#".rrref().")"
1459 unless $lastpush_hash;
1461 ensure_we_have_orig();
1462 if ($dsc_hash eq $lastpush_hash) {
1463 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1464 print STDERR <<END or die $!;
1466 Git commit in archive is behind the last version allegedly pushed/uploaded.
1467 Commit referred to by archive: $dsc_hash
1468 Last allegedly pushed/uploaded: $lastpush_hash
1471 $hash = $lastpush_hash;
1473 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1474 "descendant of archive's .dsc hash ($dsc_hash)";
1477 $hash = generate_commit_from_dsc();
1478 } elsif ($lastpush_hash) {
1479 # only in git, not in the archive yet
1480 $hash = $lastpush_hash;
1481 print STDERR <<END or die $!;
1483 Package not found in the archive, but has allegedly been pushed using dgit.
1487 printdebug "nothing found!\n";
1488 if (defined $skew_warning_vsn) {
1489 print STDERR <<END or die $!;
1491 Warning: relevant archive skew detected.
1492 Archive allegedly contains $skew_warning_vsn
1493 But we were not able to obtain any version from the archive or git.
1499 printdebug "current hash=$hash\n";
1500 if ($lastpush_hash) {
1501 fail "not fast forward on last upload branch!".
1502 " (archive's version left in DGIT_ARCHIVE)"
1503 unless is_fast_fwd($lastpush_hash, $hash);
1505 if (defined $skew_warning_vsn) {
1507 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1508 my $clogf = ".git/dgit/changelog.tmp";
1509 runcmd shell_cmd "exec >$clogf",
1510 @git, qw(cat-file blob), "$hash:debian/changelog";
1511 my $gotclogp = parsechangelog("-l$clogf");
1512 my $got_vsn = getfield $gotclogp, 'Version';
1513 printdebug "SKEW CHECK GOT $got_vsn\n";
1514 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1515 print STDERR <<END or die $!;
1517 Warning: archive skew detected. Using the available version:
1518 Archive allegedly contains $skew_warning_vsn
1519 We were able to obtain only $got_vsn
1524 if ($lastpush_hash ne $hash) {
1525 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1529 dryrun_report @upd_cmd;
1535 sub set_local_git_config ($$) {
1537 runcmd @git, qw(config), $k, $v;
1540 sub setup_mergechangelogs () {
1541 my $driver = 'dpkg-mergechangelogs';
1542 my $cb = "merge.$driver";
1543 my $attrs = '.git/info/attributes';
1544 ensuredir '.git/info';
1546 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1547 if (!open ATTRS, "<", $attrs) {
1548 $!==ENOENT or die "$attrs: $!";
1552 next if m{^debian/changelog\s};
1553 print NATTRS $_, "\n" or die $!;
1555 ATTRS->error and die $!;
1558 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1561 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1562 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1564 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1569 canonicalise_suite();
1570 badusage "dry run makes no sense with clone" unless act_local();
1571 my $hasgit = check_for_git();
1572 mkdir $dstdir or die "$dstdir $!";
1574 runcmd @git, qw(init -q);
1575 my $giturl = access_giturl(1);
1576 if (defined $giturl) {
1577 set_local_git_config "remote.$remotename.fetch", fetchspec();
1578 open H, "> .git/HEAD" or die $!;
1579 print H "ref: ".lref()."\n" or die $!;
1581 runcmd @git, qw(remote add), 'origin', $giturl;
1584 progress "fetching existing git history";
1586 runcmd_ordryrun_local @git, qw(fetch origin);
1588 progress "starting new git history";
1590 fetch_from_archive() or no_such_package;
1591 my $vcsgiturl = $dsc->{'Vcs-Git'};
1592 if (length $vcsgiturl) {
1593 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1594 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1596 setup_mergechangelogs();
1597 runcmd @git, qw(reset --hard), lrref();
1598 printdone "ready for work in $dstdir";
1602 if (check_for_git()) {
1605 fetch_from_archive() or no_such_package();
1606 printdone "fetched into ".lrref();
1611 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1613 printdone "fetched to ".lrref()." and merged into HEAD";
1616 sub check_not_dirty () {
1617 return if $ignoredirty;
1618 my @cmd = (@git, qw(diff --quiet HEAD));
1620 $!=0; $?=0; system @cmd;
1621 return if !$! && !$?;
1622 if (!$! && $?==256) {
1623 fail "working tree is dirty (does not match HEAD)";
1629 sub commit_admin ($) {
1632 runcmd_ordryrun_local @git, qw(commit -m), $m;
1635 sub commit_quilty_patch () {
1636 my $output = cmdoutput @git, qw(status --porcelain);
1638 foreach my $l (split /\n/, $output) {
1639 next unless $l =~ m/\S/;
1640 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1644 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1646 progress "nothing quilty to commit, ok.";
1649 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1650 commit_admin "Commit Debian 3.0 (quilt) metadata";
1653 sub get_source_format () {
1654 if (!open F, "debian/source/format") {
1655 die $! unless $!==&ENOENT;
1659 F->error and die $!;
1666 return 0 unless $format eq '3.0 (quilt)';
1667 if ($quilt_mode eq 'nocheck') {
1668 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1671 progress "Format \`$format', checking/updating patch stack";
1675 sub push_parse_changelog ($) {
1678 my $clogp = Dpkg::Control::Hash->new();
1679 $clogp->load($clogpfn) or die;
1681 $package = getfield $clogp, 'Source';
1682 my $cversion = getfield $clogp, 'Version';
1683 my $tag = debiantag($cversion, access_basedistro);
1684 runcmd @git, qw(check-ref-format), $tag;
1686 my $dscfn = dscfn($cversion);
1688 return ($clogp, $cversion, $tag, $dscfn);
1691 sub push_parse_dsc ($$$) {
1692 my ($dscfn,$dscfnwhat, $cversion) = @_;
1693 $dsc = parsecontrol($dscfn,$dscfnwhat);
1694 my $dversion = getfield $dsc, 'Version';
1695 my $dscpackage = getfield $dsc, 'Source';
1696 ($dscpackage eq $package && $dversion eq $cversion) or
1697 fail "$dscfn is for $dscpackage $dversion".
1698 " but debian/changelog is for $package $cversion";
1701 sub push_mktag ($$$$$$$) {
1702 my ($head,$clogp,$tag,
1704 $changesfile,$changesfilewhat,
1707 $dsc->{$ourdscfield[0]} = $head;
1708 $dsc->save("$dscfn.tmp") or die $!;
1710 my $changes = parsecontrol($changesfile,$changesfilewhat);
1711 foreach my $field (qw(Source Distribution Version)) {
1712 $changes->{$field} eq $clogp->{$field} or
1713 fail "changes field $field \`$changes->{$field}'".
1714 " does not match changelog \`$clogp->{$field}'";
1717 my $cversion = getfield $clogp, 'Version';
1718 my $clogsuite = getfield $clogp, 'Distribution';
1720 # We make the git tag by hand because (a) that makes it easier
1721 # to control the "tagger" (b) we can do remote signing
1722 my $authline = clogp_authline $clogp;
1723 my $delibs = join(" ", "",@deliberatelies);
1724 my $declaredistro = access_basedistro();
1725 open TO, '>', $tfn->('.tmp') or die $!;
1726 print TO <<END or die $!;
1732 $package release $cversion for $clogsuite ($csuite) [dgit]
1733 [dgit distro=$declaredistro$delibs]
1735 foreach my $ref (sort keys %previously) {
1736 print TO <<END or die $!;
1737 [dgit previously:$ref=$previously{$ref}]
1743 my $tagobjfn = $tfn->('.tmp');
1745 if (!defined $keyid) {
1746 $keyid = access_cfg('keyid','RETURN-UNDEF');
1748 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1749 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1750 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1751 push @sign_cmd, $tfn->('.tmp');
1752 runcmd_ordryrun @sign_cmd;
1754 $tagobjfn = $tfn->('.signed.tmp');
1755 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1756 $tfn->('.tmp'), $tfn->('.tmp.asc');
1763 sub sign_changes ($) {
1764 my ($changesfile) = @_;
1766 my @debsign_cmd = @debsign;
1767 push @debsign_cmd, "-k$keyid" if defined $keyid;
1768 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1769 push @debsign_cmd, $changesfile;
1770 runcmd_ordryrun @debsign_cmd;
1775 my ($forceflag) = @_;
1776 printdebug "actually entering push\n";
1779 access_giturl(); # check that success is vaguely likely
1781 my $clogpfn = ".git/dgit/changelog.822.tmp";
1782 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1784 responder_send_file('parsed-changelog', $clogpfn);
1786 my ($clogp, $cversion, $tag, $dscfn) =
1787 push_parse_changelog("$clogpfn");
1789 my $dscpath = "$buildproductsdir/$dscfn";
1790 stat_exists $dscpath or
1791 fail "looked for .dsc $dscfn, but $!;".
1792 " maybe you forgot to build";
1794 responder_send_file('dsc', $dscpath);
1796 push_parse_dsc($dscpath, $dscfn, $cversion);
1798 my $format = getfield $dsc, 'Format';
1799 printdebug "format $format\n";
1800 if (madformat($format)) {
1801 commit_quilty_patch();
1805 progress "checking that $dscfn corresponds to HEAD";
1806 runcmd qw(dpkg-source -x --),
1807 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1808 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1809 check_for_vendor_patches() if madformat($dsc->{format});
1810 changedir '../../../..';
1811 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1812 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1813 debugcmd "+",@diffcmd;
1815 my $r = system @diffcmd;
1818 fail "$dscfn specifies a different tree to your HEAD commit;".
1819 " perhaps you forgot to build".
1820 ($diffopt eq '--exit-code' ? "" :
1821 " (run with -D to see full diff output)");
1827 #do fast forward check and maybe fake merge
1828 # if (!is_fast_fwd(mainbranch
1829 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1830 # map { lref($_).":".rref($_) }
1832 my $head = git_rev_parse('HEAD');
1833 if (!$changesfile) {
1834 my $multi = "$buildproductsdir/".
1835 "${package}_".(stripepoch $cversion)."_multi.changes";
1836 if (stat_exists "$multi") {
1837 $changesfile = $multi;
1839 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1840 my @cs = glob "$buildproductsdir/$pat";
1841 fail "failed to find unique changes file".
1842 " (looked for $pat in $buildproductsdir, or $multi);".
1843 " perhaps you need to use dgit -C"
1845 ($changesfile) = @cs;
1848 $changesfile = "$buildproductsdir/$changesfile";
1851 responder_send_file('changes',$changesfile);
1852 responder_send_command("param head $head");
1853 responder_send_command("param csuite $csuite");
1855 if (deliberately_not_fast_forward) {
1856 git_for_each_ref(lrfetchrefs, sub {
1857 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1858 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1859 responder_send_command("previously $rrefname=$objid");
1860 $previously{$rrefname} = $objid;
1864 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1867 if ($we_are_responder) {
1868 $tagobjfn = $tfn->('.signed.tmp');
1869 responder_receive_files('signed-tag', $tagobjfn);
1872 push_mktag($head,$clogp,$tag,
1874 $changesfile,$changesfile,
1878 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1879 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1880 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1882 if (!check_for_git()) {
1883 create_remote_git_repo();
1885 runcmd_ordryrun @git, qw(push),access_giturl(),
1886 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1887 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1889 if ($we_are_responder) {
1890 my $dryrunsuffix = act_local() ? "" : ".tmp";
1891 responder_receive_files('signed-dsc-changes',
1892 "$dscpath$dryrunsuffix",
1893 "$changesfile$dryrunsuffix");
1896 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1898 progress "[new .dsc left in $dscpath.tmp]";
1900 sign_changes $changesfile;
1903 my $host = access_cfg('upload-host','RETURN-UNDEF');
1904 my @hostarg = defined($host) ? ($host,) : ();
1905 runcmd_ordryrun @dput, @hostarg, $changesfile;
1906 printdone "pushed and uploaded $cversion";
1908 responder_send_command("complete");
1914 badusage "-p is not allowed with clone; specify as argument instead"
1915 if defined $package;
1918 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1919 ($package,$isuite) = @ARGV;
1920 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1921 ($package,$dstdir) = @ARGV;
1922 } elsif (@ARGV==3) {
1923 ($package,$isuite,$dstdir) = @ARGV;
1925 badusage "incorrect arguments to dgit clone";
1927 $dstdir ||= "$package";
1929 if (stat_exists $dstdir) {
1930 fail "$dstdir already exists";
1934 if ($rmonerror && !$dryrun_level) {
1935 $cwd_remove= getcwd();
1937 return unless defined $cwd_remove;
1938 if (!chdir "$cwd_remove") {
1939 return if $!==&ENOENT;
1940 die "chdir $cwd_remove: $!";
1942 rmtree($dstdir) or die "remove $dstdir: $!\n";
1947 $cwd_remove = undef;
1950 sub branchsuite () {
1951 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1952 if ($branch =~ m#$lbranch_re#o) {
1959 sub fetchpullargs () {
1960 if (!defined $package) {
1961 my $sourcep = parsecontrol('debian/control','debian/control');
1962 $package = getfield $sourcep, 'Source';
1965 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1967 my $clogp = parsechangelog();
1968 $isuite = getfield $clogp, 'Distribution';
1970 canonicalise_suite();
1971 progress "fetching from suite $csuite";
1972 } elsif (@ARGV==1) {
1974 canonicalise_suite();
1976 badusage "incorrect arguments to dgit fetch or dgit pull";
1995 badusage "-p is not allowed with dgit push" if defined $package;
1997 my $clogp = parsechangelog();
1998 $package = getfield $clogp, 'Source';
2001 } elsif (@ARGV==1) {
2002 ($specsuite) = (@ARGV);
2004 badusage "incorrect arguments to dgit push";
2006 $isuite = getfield $clogp, 'Distribution';
2008 local ($package) = $existing_package; # this is a hack
2009 canonicalise_suite();
2011 canonicalise_suite();
2013 if (defined $specsuite &&
2014 $specsuite ne $isuite &&
2015 $specsuite ne $csuite) {
2016 fail "dgit push: changelog specifies $isuite ($csuite)".
2017 " but command line specifies $specsuite";
2019 if (check_for_git()) {
2023 if (fetch_from_archive()) {
2024 if (is_fast_fwd(lrref(), 'HEAD')) {
2026 } elsif (deliberately_not_fast_forward) {
2029 fail "dgit push: HEAD is not a descendant".
2030 " of the archive's version.\n".
2031 "dgit: To overwrite its contents,".
2032 " use git merge -s ours ".lrref().".\n".
2033 "dgit: To rewind history, if permitted by the archive,".
2034 " use --deliberately-not-fast-forward";
2038 fail "package appears to be new in this suite;".
2039 " if this is intentional, use --new";
2044 #---------- remote commands' implementation ----------
2046 sub cmd_remote_push_build_host {
2048 my ($nrargs) = shift @ARGV;
2049 my (@rargs) = @ARGV[0..$nrargs-1];
2050 @ARGV = @ARGV[$nrargs..$#ARGV];
2052 my ($dir,$vsnwant) = @rargs;
2053 # vsnwant is a comma-separated list; we report which we have
2054 # chosen in our ready response (so other end can tell if they
2057 $we_are_responder = 1;
2058 $us .= " (build host)";
2060 open PI, "<&STDIN" or die $!;
2061 open STDIN, "/dev/null" or die $!;
2062 open PO, ">&STDOUT" or die $!;
2064 open STDOUT, ">&STDERR" or die $!;
2068 fail "build host has dgit rpush protocol version".
2069 " $rpushprotovsn but invocation host has $vsnwant"
2070 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2072 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2078 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2079 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2080 # a good error message)
2086 my $report = i_child_report();
2087 if (defined $report) {
2088 printdebug "($report)\n";
2089 } elsif ($i_child_pid) {
2090 printdebug "(killing build host child $i_child_pid)\n";
2091 kill 15, $i_child_pid;
2093 if (defined $i_tmp && !defined $initiator_tempdir) {
2095 eval { rmtree $i_tmp; };
2099 END { i_cleanup(); }
2102 my ($base,$selector,@args) = @_;
2103 $selector =~ s/\-/_/g;
2104 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2111 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2118 my @rargs = ($dir,$rpushprotovsn);
2121 push @rdgit, @ropts;
2122 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2124 my @cmd = (@ssh, $host, shellquote @rdgit);
2127 if (defined $initiator_tempdir) {
2128 rmtree $initiator_tempdir;
2129 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2130 $i_tmp = $initiator_tempdir;
2134 $i_child_pid = open2(\*RO, \*RI, @cmd);
2136 initiator_expect { m/^dgit-remote-push-ready/ };
2138 my ($icmd,$iargs) = initiator_expect {
2139 m/^(\S+)(?: (.*))?$/;
2142 i_method "i_resp", $icmd, $iargs;
2146 sub i_resp_progress ($) {
2148 my $msg = protocol_read_bytes \*RO, $rhs;
2152 sub i_resp_complete {
2153 my $pid = $i_child_pid;
2154 $i_child_pid = undef; # prevents killing some other process with same pid
2155 printdebug "waiting for build host child $pid...\n";
2156 my $got = waitpid $pid, 0;
2157 die $! unless $got == $pid;
2158 die "build host child failed $?" if $?;
2161 printdebug "all done\n";
2165 sub i_resp_file ($) {
2167 my $localname = i_method "i_localname", $keyword;
2168 my $localpath = "$i_tmp/$localname";
2169 stat_exists $localpath and
2170 badproto \*RO, "file $keyword ($localpath) twice";
2171 protocol_receive_file \*RO, $localpath;
2172 i_method "i_file", $keyword;
2177 sub i_resp_param ($) {
2178 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2182 sub i_resp_previously ($) {
2183 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2184 or badproto \*RO, "bad previously spec";
2185 my $r = system qw(git check-ref-format), $1;
2186 die "bad previously ref spec ($r)" if $r;
2187 $previously{$1} = $2;
2192 sub i_resp_want ($) {
2194 die "$keyword ?" if $i_wanted{$keyword}++;
2195 my @localpaths = i_method "i_want", $keyword;
2196 printdebug "[[ $keyword @localpaths\n";
2197 foreach my $localpath (@localpaths) {
2198 protocol_send_file \*RI, $localpath;
2200 print RI "files-end\n" or die $!;
2203 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2205 sub i_localname_parsed_changelog {
2206 return "remote-changelog.822";
2208 sub i_file_parsed_changelog {
2209 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2210 push_parse_changelog "$i_tmp/remote-changelog.822";
2211 die if $i_dscfn =~ m#/|^\W#;
2214 sub i_localname_dsc {
2215 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2220 sub i_localname_changes {
2221 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2222 $i_changesfn = $i_dscfn;
2223 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2224 return $i_changesfn;
2226 sub i_file_changes { }
2228 sub i_want_signed_tag {
2229 printdebug Dumper(\%i_param, $i_dscfn);
2230 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2231 && defined $i_param{'csuite'}
2232 or badproto \*RO, "premature desire for signed-tag";
2233 my $head = $i_param{'head'};
2234 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2236 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2238 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2241 push_mktag $head, $i_clogp, $i_tag,
2243 $i_changesfn, 'remote changes',
2244 sub { "tag$_[0]"; };
2249 sub i_want_signed_dsc_changes {
2250 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2251 sign_changes $i_changesfn;
2252 return ($i_dscfn, $i_changesfn);
2255 #---------- building etc. ----------
2261 #----- `3.0 (quilt)' handling -----
2263 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2265 sub quiltify_dpkg_commit ($$$;$) {
2266 my ($patchname,$author,$msg, $xinfo) = @_;
2270 my $descfn = ".git/dgit/quilt-description.tmp";
2271 open O, '>', $descfn or die "$descfn: $!";
2274 $msg =~ s/^\s+$/ ./mg;
2275 print O <<END or die $!;
2285 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2286 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2287 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2288 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2292 sub quiltify_trees_differ ($$) {
2294 # returns 1 iff the two tree objects differ other than in debian/
2296 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2297 my $diffs= cmdoutput @cmd;
2298 foreach my $f (split /\0/, $diffs) {
2299 next if $f eq 'debian';
2305 sub quiltify_tree_sentinelfiles ($) {
2306 # lists the `sentinel' files present in the tree
2308 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2309 qw(-- debian/rules debian/control);
2315 my ($clogp,$target) = @_;
2317 # Quilt patchification algorithm
2319 # We search backwards through the history of the main tree's HEAD
2320 # (T) looking for a start commit S whose tree object is identical
2321 # to to the patch tip tree (ie the tree corresponding to the
2322 # current dpkg-committed patch series). For these purposes
2323 # `identical' disregards anything in debian/ - this wrinkle is
2324 # necessary because dpkg-source treates debian/ specially.
2326 # We can only traverse edges where at most one of the ancestors'
2327 # trees differs (in changes outside in debian/). And we cannot
2328 # handle edges which change .pc/ or debian/patches. To avoid
2329 # going down a rathole we avoid traversing edges which introduce
2330 # debian/rules or debian/control. And we set a limit on the
2331 # number of edges we are willing to look at.
2333 # If we succeed, we walk forwards again. For each traversed edge
2334 # PC (with P parent, C child) (starting with P=S and ending with
2335 # C=T) to we do this:
2337 # - dpkg-source --commit with a patch name and message derived from C
2338 # After traversing PT, we git commit the changes which
2339 # should be contained within debian/patches.
2341 changedir '../fake';
2342 mktree_in_ud_here();
2344 runcmd @git, 'add', '.';
2345 my $oldtiptree=git_write_tree();
2346 changedir '../work';
2348 # The search for the path S..T is breadth-first. We maintain a
2349 # todo list containing search nodes. A search node identifies a
2350 # commit, and looks something like this:
2352 # Commit => $git_commit_id,
2353 # Child => $c, # or undef if P=T
2354 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2355 # Nontrivial => true iff $p..$c has relevant changes
2362 my %considered; # saves being exponential on some weird graphs
2364 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2367 my ($search,$whynot) = @_;
2368 printdebug " search NOT $search->{Commit} $whynot\n";
2369 $search->{Whynot} = $whynot;
2370 push @nots, $search;
2371 no warnings qw(exiting);
2380 my $c = shift @todo;
2381 next if $considered{$c->{Commit}}++;
2383 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2385 printdebug "quiltify investigate $c->{Commit}\n";
2388 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2389 printdebug " search finished hooray!\n";
2394 if ($quilt_mode eq 'nofix') {
2395 fail "quilt fixup required but quilt mode is \`nofix'\n".
2396 "HEAD commit $c->{Commit} differs from tree implied by ".
2397 " debian/patches (tree object $oldtiptree)";
2399 if ($quilt_mode eq 'smash') {
2400 printdebug " search quitting smash\n";
2404 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2405 $not->($c, "has $c_sentinels not $t_sentinels")
2406 if $c_sentinels ne $t_sentinels;
2408 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2409 $commitdata =~ m/\n\n/;
2411 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2412 @parents = map { { Commit => $_, Child => $c } } @parents;
2414 $not->($c, "root commit") if !@parents;
2416 foreach my $p (@parents) {
2417 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2419 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2420 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2422 foreach my $p (@parents) {
2423 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2425 my @cmd= (@git, qw(diff-tree -r --name-only),
2426 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2427 my $patchstackchange = cmdoutput @cmd;
2428 if (length $patchstackchange) {
2429 $patchstackchange =~ s/\n/,/g;
2430 $not->($p, "changed $patchstackchange");
2433 printdebug " search queue P=$p->{Commit} ",
2434 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2440 printdebug "quiltify want to smash\n";
2443 my $x = $_[0]{Commit};
2444 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2447 my $reportnot = sub {
2449 my $s = $abbrev->($notp);
2450 my $c = $notp->{Child};
2451 $s .= "..".$abbrev->($c) if $c;
2452 $s .= ": ".$notp->{Whynot};
2455 if ($quilt_mode eq 'linear') {
2456 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2457 foreach my $notp (@nots) {
2458 print STDERR "$us: ", $reportnot->($notp), "\n";
2460 fail "quilt fixup naive history linearisation failed.\n".
2461 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2462 } elsif ($quilt_mode eq 'smash') {
2463 } elsif ($quilt_mode eq 'auto') {
2464 progress "quilt fixup cannot be linear, smashing...";
2466 die "$quilt_mode ?";
2471 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2473 quiltify_dpkg_commit "auto-$version-$target-$time",
2474 (getfield $clogp, 'Maintainer'),
2475 "Automatically generated patch ($clogp->{Version})\n".
2476 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2480 progress "quiltify linearisation planning successful, executing...";
2482 for (my $p = $sref_S;
2483 my $c = $p->{Child};
2485 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2486 next unless $p->{Nontrivial};
2488 my $cc = $c->{Commit};
2490 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2491 $commitdata =~ m/\n\n/ or die "$c ?";
2494 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2497 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2500 my $patchname = $title;
2501 $patchname =~ s/[.:]$//;
2502 $patchname =~ y/ A-Z/-a-z/;
2503 $patchname =~ y/-a-z0-9_.+=~//cd;
2504 $patchname =~ s/^\W/x-$&/;
2505 $patchname = substr($patchname,0,40);
2508 stat "debian/patches/$patchname$index";
2510 $!==ENOENT or die "$patchname$index $!";
2512 runcmd @git, qw(checkout -q), $cc;
2514 # We use the tip's changelog so that dpkg-source doesn't
2515 # produce complaining messages from dpkg-parsechangelog. None
2516 # of the information dpkg-source gets from the changelog is
2517 # actually relevant - it gets put into the original message
2518 # which dpkg-source provides our stunt editor, and then
2520 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2522 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2523 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2525 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2528 runcmd @git, qw(checkout -q master);
2531 sub build_maybe_quilt_fixup () {
2532 my $format=get_source_format;
2533 return unless madformat $format;
2536 check_for_vendor_patches();
2539 # - honour any existing .pc in case it has any strangeness
2540 # - determine the git commit corresponding to the tip of
2541 # the patch stack (if there is one)
2542 # - if there is such a git commit, convert each subsequent
2543 # git commit into a quilt patch with dpkg-source --commit
2544 # - otherwise convert all the differences in the tree into
2545 # a single git commit
2549 # Our git tree doesn't necessarily contain .pc. (Some versions of
2550 # dgit would include the .pc in the git tree.) If there isn't
2551 # one, we need to generate one by unpacking the patches that we
2554 # We first look for a .pc in the git tree. If there is one, we
2555 # will use it. (This is not the normal case.)
2557 # Otherwise need to regenerate .pc so that dpkg-source --commit
2558 # can work. We do this as follows:
2559 # 1. Collect all relevant .orig from parent directory
2560 # 2. Generate a debian.tar.gz out of
2561 # debian/{patches,rules,source/format}
2562 # 3. Generate a fake .dsc containing just these fields:
2563 # Format Source Version Files
2564 # 4. Extract the fake .dsc
2565 # Now the fake .dsc has a .pc directory.
2566 # (In fact we do this in every case, because in future we will
2567 # want to search for a good base commit for generating patches.)
2569 # Then we can actually do the dpkg-source --commit
2570 # 1. Make a new working tree with the same object
2571 # store as our main tree and check out the main
2573 # 2. Copy .pc from the fake's extraction, if necessary
2574 # 3. Run dpkg-source --commit
2575 # 4. If the result has changes to debian/, then
2576 # - git-add them them
2577 # - git-add .pc if we had a .pc in-tree
2579 # 5. If we had a .pc in-tree, delete it, and git-commit
2580 # 6. Back in the main tree, fast forward to the new HEAD
2582 my $clogp = parsechangelog();
2583 my $headref = git_rev_parse('HEAD');
2588 my $upstreamversion=$version;
2589 $upstreamversion =~ s/-[^-]*$//;
2591 my $fakeversion="$upstreamversion-~~DGITFAKE";
2593 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2594 print $fakedsc <<END or die $!;
2597 Version: $fakeversion
2601 my $dscaddfile=sub {
2604 my $md = new Digest::MD5;
2606 my $fh = new IO::File $b, '<' or die "$b $!";
2611 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2614 foreach my $f (<../../../../*>) { #/){
2615 my $b=$f; $b =~ s{.*/}{};
2616 next unless is_orig_file $b, srcfn $upstreamversion,'';
2617 link $f, $b or die "$b $!";
2621 my @files=qw(debian/source/format debian/rules);
2622 if (stat_exists '../../../debian/patches') {
2623 push @files, 'debian/patches';
2626 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2627 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2629 $dscaddfile->($debtar);
2630 close $fakedsc or die $!;
2632 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2634 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2635 rename $fakexdir, "fake" or die "$fakexdir $!";
2637 mkdir "work" or die $!;
2639 mktree_in_ud_here();
2640 runcmd @git, qw(reset --hard), $headref;
2643 if (stat_exists ".pc") {
2645 progress "Tree already contains .pc - will use it then delete it.";
2648 rename '../fake/.pc','.pc' or die $!;
2651 quiltify($clogp,$headref);
2653 if (!open P, '>>', ".pc/applied-patches") {
2654 $!==&ENOENT or die $!;
2659 commit_quilty_patch();
2661 if ($mustdeletepc) {
2662 runcmd @git, qw(rm -rqf .pc);
2663 commit_admin "Commit removal of .pc (quilt series tracking data)";
2666 changedir '../../../..';
2667 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2670 sub quilt_fixup_editor () {
2671 my $descfn = $ENV{$fakeeditorenv};
2672 my $editing = $ARGV[$#ARGV];
2673 open I1, '<', $descfn or die "$descfn: $!";
2674 open I2, '<', $editing or die "$editing: $!";
2675 unlink $editing or die "$editing: $!";
2676 open O, '>', $editing or die "$editing: $!";
2677 while (<I1>) { print O or die $!; } I1->error and die $!;
2680 $copying ||= m/^\-\-\- /;
2681 next unless $copying;
2684 I2->error and die $!;
2689 #----- other building -----
2692 if ($cleanmode eq 'dpkg-source') {
2693 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2694 } elsif ($cleanmode eq 'dpkg-source-d') {
2695 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2696 } elsif ($cleanmode eq 'git') {
2697 runcmd_ordryrun_local @git, qw(clean -xdf);
2698 } elsif ($cleanmode eq 'git-ff') {
2699 runcmd_ordryrun_local @git, qw(clean -xdff);
2700 } elsif ($cleanmode eq 'check') {
2701 my $leftovers = cmdoutput @git, qw(clean -xdn);
2702 if (length $leftovers) {
2703 print STDERR $leftovers, "\n" or die $!;
2704 fail "tree contains uncommitted files and --clean=check specified";
2706 } elsif ($cleanmode eq 'none') {
2713 badusage "clean takes no additional arguments" if @ARGV;
2718 badusage "-p is not allowed when building" if defined $package;
2721 my $clogp = parsechangelog();
2722 $isuite = getfield $clogp, 'Distribution';
2723 $package = getfield $clogp, 'Source';
2724 $version = getfield $clogp, 'Version';
2725 build_maybe_quilt_fixup();
2728 sub changesopts () {
2729 my @opts =@changesopts[1..$#changesopts];
2730 if (!defined $changes_since_version) {
2731 my @vsns = archive_query('archive_query');
2732 my @quirk = access_quirk();
2733 if ($quirk[0] eq 'backports') {
2734 local $isuite = $quirk[2];
2736 canonicalise_suite();
2737 push @vsns, archive_query('archive_query');
2740 @vsns = map { $_->[0] } @vsns;
2741 @vsns = sort { -version_compare($a, $b) } @vsns;
2742 $changes_since_version = $vsns[0];
2743 progress "changelog will contain changes since $vsns[0]";
2745 $changes_since_version = '_';
2746 progress "package seems new, not specifying -v<version>";
2749 if ($changes_since_version ne '_') {
2750 unshift @opts, "-v$changes_since_version";
2755 sub massage_dbp_args ($) {
2757 return unless $cleanmode =~ m/git|none/;
2758 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2759 my @newcmd = shift @$cmd;
2760 # -nc has the side effect of specifying -b if nothing else specified
2761 push @newcmd, '-nc';
2762 # and some combinations of -S, -b, et al, are errors, rather than
2763 # later simply overriding earlier
2764 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2765 push @newcmd, @$cmd;
2771 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2772 massage_dbp_args \@dbp;
2773 runcmd_ordryrun_local @dbp;
2774 printdone "build successful\n";
2779 my @dbp = @dpkgbuildpackage;
2780 massage_dbp_args \@dbp;
2782 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2783 "--git-builder=@dbp");
2784 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2785 canonicalise_suite();
2786 push @cmd, "--git-debian-branch=".lbranch();
2788 push @cmd, changesopts();
2789 runcmd_ordryrun_local @cmd, @ARGV;
2790 printdone "build successful\n";
2795 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2796 $dscfn = dscfn($version);
2797 if ($cleanmode eq 'dpkg-source') {
2798 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2800 } elsif ($cleanmode eq 'dpkg-source-d') {
2801 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2804 my $pwd = must_getcwd();
2805 my $leafdir = basename $pwd;
2807 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2809 runcmd_ordryrun_local qw(sh -ec),
2810 'exec >$1; shift; exec "$@"','x',
2811 "../$sourcechanges",
2812 @dpkggenchanges, qw(-S), changesopts();
2816 sub cmd_build_source {
2817 badusage "build-source takes no additional arguments" if @ARGV;
2819 printdone "source built, results in $dscfn and $sourcechanges";
2825 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2827 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2828 stat_exists $sourcechanges
2829 or fail "$sourcechanges (in parent directory): $!";
2830 foreach my $cf (glob $pat) {
2831 next if $cf eq $sourcechanges;
2832 unlink $cf or fail "remove $cf: $!";
2835 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2836 my @changesfiles = glob $pat;
2837 @changesfiles = sort {
2838 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2841 fail "wrong number of different changes files (@changesfiles)"
2842 unless @changesfiles;
2843 runcmd_ordryrun_local @mergechanges, @changesfiles;
2844 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2846 stat_exists $multichanges or fail "$multichanges: $!";
2848 printdone "build successful, results in $multichanges\n" or die $!;
2851 sub cmd_quilt_fixup {
2852 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2853 my $clogp = parsechangelog();
2854 $version = getfield $clogp, 'Version';
2855 $package = getfield $clogp, 'Source';
2856 build_maybe_quilt_fixup();
2859 sub cmd_archive_api_query {
2860 badusage "need only 1 subpath argument" unless @ARGV==1;
2861 my ($subpath) = @ARGV;
2862 my @cmd = archive_api_query_cmd($subpath);
2864 exec @cmd or fail "exec curl: $!\n";
2867 sub cmd_clone_dgit_repos_server {
2868 badusage "need destination argument" unless @ARGV==1;
2869 my ($destdir) = @ARGV;
2870 $package = '_dgit-repos-server';
2871 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2873 exec @cmd or fail "exec git clone: $!\n";
2876 sub cmd_setup_mergechangelogs {
2877 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2878 setup_mergechangelogs();
2881 #---------- argument parsing and main program ----------
2884 print "dgit version $our_version\n" or die $!;
2891 if (defined $ENV{'DGIT_SSH'}) {
2892 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2893 } elsif (defined $ENV{'GIT_SSH'}) {
2894 @ssh = ($ENV{'GIT_SSH'});
2898 last unless $ARGV[0] =~ m/^-/;
2902 if (m/^--dry-run$/) {
2905 } elsif (m/^--damp-run$/) {
2908 } elsif (m/^--no-sign$/) {
2911 } elsif (m/^--help$/) {
2913 } elsif (m/^--version$/) {
2915 } elsif (m/^--new$/) {
2918 } elsif (m/^--since-version=([^_]+|_)$/) {
2920 $changes_since_version = $1;
2921 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2922 ($om = $opts_opt_map{$1}) &&
2926 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2927 !$opts_opt_cmdonly{$1} &&
2928 ($om = $opts_opt_map{$1})) {
2931 } elsif (m/^--existing-package=(.*)/s) {
2933 $existing_package = $1;
2934 } elsif (m/^--initiator-tempdir=(.*)/s) {
2935 $initiator_tempdir = $1;
2936 $initiator_tempdir =~ m#^/# or
2937 badusage "--initiator-tempdir must be used specify an".
2938 " absolute, not relative, directory."
2939 } elsif (m/^--distro=(.*)/s) {
2942 } elsif (m/^--build-products-dir=(.*)/s) {
2944 $buildproductsdir = $1;
2945 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2948 } elsif (m/^--clean=(.*)$/s) {
2949 badusage "unknown cleaning mode \`$1'";
2950 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2953 } elsif (m/^--quilt=(.*)$/s) {
2954 badusage "unknown quilt fixup mode \`$1'";
2955 } elsif (m/^--ignore-dirty$/s) {
2958 } elsif (m/^--no-quilt-fixup$/s) {
2960 $quilt_mode = 'nocheck';
2961 } elsif (m/^--no-rm-on-error$/s) {
2964 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2966 push @deliberatelies, $&;
2968 badusage "unknown long option \`$_'";
2975 } elsif (s/^-L/-/) {
2978 } elsif (s/^-h/-/) {
2980 } elsif (s/^-D/-/) {
2984 } elsif (s/^-N/-/) {
2987 } elsif (s/^-v([^_]+|_)$//s) {
2989 $changes_since_version = $1;
2992 push @changesopts, $_;
2994 } elsif (s/^-c(.*=.*)//s) {
2996 push @git, '-c', $1;
2997 } elsif (s/^-d(.+)//s) {
3000 } elsif (s/^-C(.+)//s) {
3003 if ($changesfile =~ s#^(.*)/##) {
3004 $buildproductsdir = $1;
3006 } elsif (s/^-k(.+)//s) {
3008 } elsif (m/^-[vdCk]$/) {
3010 "option \`$_' requires an argument (and no space before the argument)";
3011 } elsif (s/^-wn$//s) {
3013 $cleanmode = 'none';
3014 } elsif (s/^-wg$//s) {
3017 } elsif (s/^-wgf$//s) {
3019 $cleanmode = 'git-ff';
3020 } elsif (s/^-wd$//s) {
3022 $cleanmode = 'dpkg-source';
3023 } elsif (s/^-wdd$//s) {
3025 $cleanmode = 'dpkg-source-d';
3026 } elsif (s/^-wc$//s) {
3028 $cleanmode = 'check';
3030 badusage "unknown short option \`$_'";
3037 if ($ENV{$fakeeditorenv}) {
3038 quilt_fixup_editor();
3042 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3043 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3044 if $dryrun_level == 1;
3046 print STDERR $helpmsg or die $!;
3049 my $cmd = shift @ARGV;
3052 if (!defined $quilt_mode) {
3053 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3054 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3056 $quilt_mode =~ m/^($quilt_modes_re)$/
3057 or badcfg "unknown quilt-mode \`$quilt_mode'";
3061 my $fn = ${*::}{"cmd_$cmd"};
3062 $fn or badusage "unknown operation $cmd";