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)");
1826 my $head = git_rev_parse('HEAD');
1827 if (!$changesfile) {
1828 my $multi = "$buildproductsdir/".
1829 "${package}_".(stripepoch $cversion)."_multi.changes";
1830 if (stat_exists "$multi") {
1831 $changesfile = $multi;
1833 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1834 my @cs = glob "$buildproductsdir/$pat";
1835 fail "failed to find unique changes file".
1836 " (looked for $pat in $buildproductsdir, or $multi);".
1837 " perhaps you need to use dgit -C"
1839 ($changesfile) = @cs;
1842 $changesfile = "$buildproductsdir/$changesfile";
1845 responder_send_file('changes',$changesfile);
1846 responder_send_command("param head $head");
1847 responder_send_command("param csuite $csuite");
1849 if (deliberately_not_fast_forward) {
1850 git_for_each_ref(lrfetchrefs, sub {
1851 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1852 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1853 responder_send_command("previously $rrefname=$objid");
1854 $previously{$rrefname} = $objid;
1858 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1861 if ($we_are_responder) {
1862 $tagobjfn = $tfn->('.signed.tmp');
1863 responder_receive_files('signed-tag', $tagobjfn);
1866 push_mktag($head,$clogp,$tag,
1868 $changesfile,$changesfile,
1872 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1873 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1874 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1876 if (!check_for_git()) {
1877 create_remote_git_repo();
1879 runcmd_ordryrun @git, qw(push),access_giturl(),
1880 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1881 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1883 if ($we_are_responder) {
1884 my $dryrunsuffix = act_local() ? "" : ".tmp";
1885 responder_receive_files('signed-dsc-changes',
1886 "$dscpath$dryrunsuffix",
1887 "$changesfile$dryrunsuffix");
1890 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1892 progress "[new .dsc left in $dscpath.tmp]";
1894 sign_changes $changesfile;
1897 my $host = access_cfg('upload-host','RETURN-UNDEF');
1898 my @hostarg = defined($host) ? ($host,) : ();
1899 runcmd_ordryrun @dput, @hostarg, $changesfile;
1900 printdone "pushed and uploaded $cversion";
1902 responder_send_command("complete");
1908 badusage "-p is not allowed with clone; specify as argument instead"
1909 if defined $package;
1912 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1913 ($package,$isuite) = @ARGV;
1914 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1915 ($package,$dstdir) = @ARGV;
1916 } elsif (@ARGV==3) {
1917 ($package,$isuite,$dstdir) = @ARGV;
1919 badusage "incorrect arguments to dgit clone";
1921 $dstdir ||= "$package";
1923 if (stat_exists $dstdir) {
1924 fail "$dstdir already exists";
1928 if ($rmonerror && !$dryrun_level) {
1929 $cwd_remove= getcwd();
1931 return unless defined $cwd_remove;
1932 if (!chdir "$cwd_remove") {
1933 return if $!==&ENOENT;
1934 die "chdir $cwd_remove: $!";
1936 rmtree($dstdir) or die "remove $dstdir: $!\n";
1941 $cwd_remove = undef;
1944 sub branchsuite () {
1945 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1946 if ($branch =~ m#$lbranch_re#o) {
1953 sub fetchpullargs () {
1954 if (!defined $package) {
1955 my $sourcep = parsecontrol('debian/control','debian/control');
1956 $package = getfield $sourcep, 'Source';
1959 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1961 my $clogp = parsechangelog();
1962 $isuite = getfield $clogp, 'Distribution';
1964 canonicalise_suite();
1965 progress "fetching from suite $csuite";
1966 } elsif (@ARGV==1) {
1968 canonicalise_suite();
1970 badusage "incorrect arguments to dgit fetch or dgit pull";
1989 badusage "-p is not allowed with dgit push" if defined $package;
1991 my $clogp = parsechangelog();
1992 $package = getfield $clogp, 'Source';
1995 } elsif (@ARGV==1) {
1996 ($specsuite) = (@ARGV);
1998 badusage "incorrect arguments to dgit push";
2000 $isuite = getfield $clogp, 'Distribution';
2002 local ($package) = $existing_package; # this is a hack
2003 canonicalise_suite();
2005 canonicalise_suite();
2007 if (defined $specsuite &&
2008 $specsuite ne $isuite &&
2009 $specsuite ne $csuite) {
2010 fail "dgit push: changelog specifies $isuite ($csuite)".
2011 " but command line specifies $specsuite";
2013 if (check_for_git()) {
2017 if (fetch_from_archive()) {
2018 if (is_fast_fwd(lrref(), 'HEAD')) {
2020 } elsif (deliberately_not_fast_forward) {
2023 fail "dgit push: HEAD is not a descendant".
2024 " of the archive's version.\n".
2025 "dgit: To overwrite its contents,".
2026 " use git merge -s ours ".lrref().".\n".
2027 "dgit: To rewind history, if permitted by the archive,".
2028 " use --deliberately-not-fast-forward";
2032 fail "package appears to be new in this suite;".
2033 " if this is intentional, use --new";
2038 #---------- remote commands' implementation ----------
2040 sub cmd_remote_push_build_host {
2042 my ($nrargs) = shift @ARGV;
2043 my (@rargs) = @ARGV[0..$nrargs-1];
2044 @ARGV = @ARGV[$nrargs..$#ARGV];
2046 my ($dir,$vsnwant) = @rargs;
2047 # vsnwant is a comma-separated list; we report which we have
2048 # chosen in our ready response (so other end can tell if they
2051 $we_are_responder = 1;
2052 $us .= " (build host)";
2054 open PI, "<&STDIN" or die $!;
2055 open STDIN, "/dev/null" or die $!;
2056 open PO, ">&STDOUT" or die $!;
2058 open STDOUT, ">&STDERR" or die $!;
2062 fail "build host has dgit rpush protocol version".
2063 " $rpushprotovsn but invocation host has $vsnwant"
2064 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2066 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2072 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2073 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2074 # a good error message)
2080 my $report = i_child_report();
2081 if (defined $report) {
2082 printdebug "($report)\n";
2083 } elsif ($i_child_pid) {
2084 printdebug "(killing build host child $i_child_pid)\n";
2085 kill 15, $i_child_pid;
2087 if (defined $i_tmp && !defined $initiator_tempdir) {
2089 eval { rmtree $i_tmp; };
2093 END { i_cleanup(); }
2096 my ($base,$selector,@args) = @_;
2097 $selector =~ s/\-/_/g;
2098 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2105 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2112 my @rargs = ($dir,$rpushprotovsn);
2115 push @rdgit, @ropts;
2116 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2118 my @cmd = (@ssh, $host, shellquote @rdgit);
2121 if (defined $initiator_tempdir) {
2122 rmtree $initiator_tempdir;
2123 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2124 $i_tmp = $initiator_tempdir;
2128 $i_child_pid = open2(\*RO, \*RI, @cmd);
2130 initiator_expect { m/^dgit-remote-push-ready/ };
2132 my ($icmd,$iargs) = initiator_expect {
2133 m/^(\S+)(?: (.*))?$/;
2136 i_method "i_resp", $icmd, $iargs;
2140 sub i_resp_progress ($) {
2142 my $msg = protocol_read_bytes \*RO, $rhs;
2146 sub i_resp_complete {
2147 my $pid = $i_child_pid;
2148 $i_child_pid = undef; # prevents killing some other process with same pid
2149 printdebug "waiting for build host child $pid...\n";
2150 my $got = waitpid $pid, 0;
2151 die $! unless $got == $pid;
2152 die "build host child failed $?" if $?;
2155 printdebug "all done\n";
2159 sub i_resp_file ($) {
2161 my $localname = i_method "i_localname", $keyword;
2162 my $localpath = "$i_tmp/$localname";
2163 stat_exists $localpath and
2164 badproto \*RO, "file $keyword ($localpath) twice";
2165 protocol_receive_file \*RO, $localpath;
2166 i_method "i_file", $keyword;
2171 sub i_resp_param ($) {
2172 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2176 sub i_resp_previously ($) {
2177 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2178 or badproto \*RO, "bad previously spec";
2179 my $r = system qw(git check-ref-format), $1;
2180 die "bad previously ref spec ($r)" if $r;
2181 $previously{$1} = $2;
2186 sub i_resp_want ($) {
2188 die "$keyword ?" if $i_wanted{$keyword}++;
2189 my @localpaths = i_method "i_want", $keyword;
2190 printdebug "[[ $keyword @localpaths\n";
2191 foreach my $localpath (@localpaths) {
2192 protocol_send_file \*RI, $localpath;
2194 print RI "files-end\n" or die $!;
2197 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2199 sub i_localname_parsed_changelog {
2200 return "remote-changelog.822";
2202 sub i_file_parsed_changelog {
2203 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2204 push_parse_changelog "$i_tmp/remote-changelog.822";
2205 die if $i_dscfn =~ m#/|^\W#;
2208 sub i_localname_dsc {
2209 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2214 sub i_localname_changes {
2215 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2216 $i_changesfn = $i_dscfn;
2217 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2218 return $i_changesfn;
2220 sub i_file_changes { }
2222 sub i_want_signed_tag {
2223 printdebug Dumper(\%i_param, $i_dscfn);
2224 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2225 && defined $i_param{'csuite'}
2226 or badproto \*RO, "premature desire for signed-tag";
2227 my $head = $i_param{'head'};
2228 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2230 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2232 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2235 push_mktag $head, $i_clogp, $i_tag,
2237 $i_changesfn, 'remote changes',
2238 sub { "tag$_[0]"; };
2243 sub i_want_signed_dsc_changes {
2244 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2245 sign_changes $i_changesfn;
2246 return ($i_dscfn, $i_changesfn);
2249 #---------- building etc. ----------
2255 #----- `3.0 (quilt)' handling -----
2257 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2259 sub quiltify_dpkg_commit ($$$;$) {
2260 my ($patchname,$author,$msg, $xinfo) = @_;
2264 my $descfn = ".git/dgit/quilt-description.tmp";
2265 open O, '>', $descfn or die "$descfn: $!";
2268 $msg =~ s/^\s+$/ ./mg;
2269 print O <<END or die $!;
2279 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2280 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2281 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2282 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2286 sub quiltify_trees_differ ($$) {
2288 # returns 1 iff the two tree objects differ other than in debian/
2290 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2291 my $diffs= cmdoutput @cmd;
2292 foreach my $f (split /\0/, $diffs) {
2293 next if $f eq 'debian';
2299 sub quiltify_tree_sentinelfiles ($) {
2300 # lists the `sentinel' files present in the tree
2302 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2303 qw(-- debian/rules debian/control);
2309 my ($clogp,$target) = @_;
2311 # Quilt patchification algorithm
2313 # We search backwards through the history of the main tree's HEAD
2314 # (T) looking for a start commit S whose tree object is identical
2315 # to to the patch tip tree (ie the tree corresponding to the
2316 # current dpkg-committed patch series). For these purposes
2317 # `identical' disregards anything in debian/ - this wrinkle is
2318 # necessary because dpkg-source treates debian/ specially.
2320 # We can only traverse edges where at most one of the ancestors'
2321 # trees differs (in changes outside in debian/). And we cannot
2322 # handle edges which change .pc/ or debian/patches. To avoid
2323 # going down a rathole we avoid traversing edges which introduce
2324 # debian/rules or debian/control. And we set a limit on the
2325 # number of edges we are willing to look at.
2327 # If we succeed, we walk forwards again. For each traversed edge
2328 # PC (with P parent, C child) (starting with P=S and ending with
2329 # C=T) to we do this:
2331 # - dpkg-source --commit with a patch name and message derived from C
2332 # After traversing PT, we git commit the changes which
2333 # should be contained within debian/patches.
2335 changedir '../fake';
2336 mktree_in_ud_here();
2338 runcmd @git, 'add', '.';
2339 my $oldtiptree=git_write_tree();
2340 changedir '../work';
2342 # The search for the path S..T is breadth-first. We maintain a
2343 # todo list containing search nodes. A search node identifies a
2344 # commit, and looks something like this:
2346 # Commit => $git_commit_id,
2347 # Child => $c, # or undef if P=T
2348 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2349 # Nontrivial => true iff $p..$c has relevant changes
2356 my %considered; # saves being exponential on some weird graphs
2358 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2361 my ($search,$whynot) = @_;
2362 printdebug " search NOT $search->{Commit} $whynot\n";
2363 $search->{Whynot} = $whynot;
2364 push @nots, $search;
2365 no warnings qw(exiting);
2374 my $c = shift @todo;
2375 next if $considered{$c->{Commit}}++;
2377 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2379 printdebug "quiltify investigate $c->{Commit}\n";
2382 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2383 printdebug " search finished hooray!\n";
2388 if ($quilt_mode eq 'nofix') {
2389 fail "quilt fixup required but quilt mode is \`nofix'\n".
2390 "HEAD commit $c->{Commit} differs from tree implied by ".
2391 " debian/patches (tree object $oldtiptree)";
2393 if ($quilt_mode eq 'smash') {
2394 printdebug " search quitting smash\n";
2398 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2399 $not->($c, "has $c_sentinels not $t_sentinels")
2400 if $c_sentinels ne $t_sentinels;
2402 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2403 $commitdata =~ m/\n\n/;
2405 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2406 @parents = map { { Commit => $_, Child => $c } } @parents;
2408 $not->($c, "root commit") if !@parents;
2410 foreach my $p (@parents) {
2411 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2413 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2414 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2416 foreach my $p (@parents) {
2417 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2419 my @cmd= (@git, qw(diff-tree -r --name-only),
2420 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2421 my $patchstackchange = cmdoutput @cmd;
2422 if (length $patchstackchange) {
2423 $patchstackchange =~ s/\n/,/g;
2424 $not->($p, "changed $patchstackchange");
2427 printdebug " search queue P=$p->{Commit} ",
2428 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2434 printdebug "quiltify want to smash\n";
2437 my $x = $_[0]{Commit};
2438 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2441 my $reportnot = sub {
2443 my $s = $abbrev->($notp);
2444 my $c = $notp->{Child};
2445 $s .= "..".$abbrev->($c) if $c;
2446 $s .= ": ".$notp->{Whynot};
2449 if ($quilt_mode eq 'linear') {
2450 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2451 foreach my $notp (@nots) {
2452 print STDERR "$us: ", $reportnot->($notp), "\n";
2454 fail "quilt fixup naive history linearisation failed.\n".
2455 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2456 } elsif ($quilt_mode eq 'smash') {
2457 } elsif ($quilt_mode eq 'auto') {
2458 progress "quilt fixup cannot be linear, smashing...";
2460 die "$quilt_mode ?";
2465 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2467 quiltify_dpkg_commit "auto-$version-$target-$time",
2468 (getfield $clogp, 'Maintainer'),
2469 "Automatically generated patch ($clogp->{Version})\n".
2470 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2474 progress "quiltify linearisation planning successful, executing...";
2476 for (my $p = $sref_S;
2477 my $c = $p->{Child};
2479 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2480 next unless $p->{Nontrivial};
2482 my $cc = $c->{Commit};
2484 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2485 $commitdata =~ m/\n\n/ or die "$c ?";
2488 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2491 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2494 my $patchname = $title;
2495 $patchname =~ s/[.:]$//;
2496 $patchname =~ y/ A-Z/-a-z/;
2497 $patchname =~ y/-a-z0-9_.+=~//cd;
2498 $patchname =~ s/^\W/x-$&/;
2499 $patchname = substr($patchname,0,40);
2502 stat "debian/patches/$patchname$index";
2504 $!==ENOENT or die "$patchname$index $!";
2506 runcmd @git, qw(checkout -q), $cc;
2508 # We use the tip's changelog so that dpkg-source doesn't
2509 # produce complaining messages from dpkg-parsechangelog. None
2510 # of the information dpkg-source gets from the changelog is
2511 # actually relevant - it gets put into the original message
2512 # which dpkg-source provides our stunt editor, and then
2514 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2516 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2517 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2519 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2522 runcmd @git, qw(checkout -q master);
2525 sub build_maybe_quilt_fixup () {
2526 my $format=get_source_format;
2527 return unless madformat $format;
2530 check_for_vendor_patches();
2533 # - honour any existing .pc in case it has any strangeness
2534 # - determine the git commit corresponding to the tip of
2535 # the patch stack (if there is one)
2536 # - if there is such a git commit, convert each subsequent
2537 # git commit into a quilt patch with dpkg-source --commit
2538 # - otherwise convert all the differences in the tree into
2539 # a single git commit
2543 # Our git tree doesn't necessarily contain .pc. (Some versions of
2544 # dgit would include the .pc in the git tree.) If there isn't
2545 # one, we need to generate one by unpacking the patches that we
2548 # We first look for a .pc in the git tree. If there is one, we
2549 # will use it. (This is not the normal case.)
2551 # Otherwise need to regenerate .pc so that dpkg-source --commit
2552 # can work. We do this as follows:
2553 # 1. Collect all relevant .orig from parent directory
2554 # 2. Generate a debian.tar.gz out of
2555 # debian/{patches,rules,source/format}
2556 # 3. Generate a fake .dsc containing just these fields:
2557 # Format Source Version Files
2558 # 4. Extract the fake .dsc
2559 # Now the fake .dsc has a .pc directory.
2560 # (In fact we do this in every case, because in future we will
2561 # want to search for a good base commit for generating patches.)
2563 # Then we can actually do the dpkg-source --commit
2564 # 1. Make a new working tree with the same object
2565 # store as our main tree and check out the main
2567 # 2. Copy .pc from the fake's extraction, if necessary
2568 # 3. Run dpkg-source --commit
2569 # 4. If the result has changes to debian/, then
2570 # - git-add them them
2571 # - git-add .pc if we had a .pc in-tree
2573 # 5. If we had a .pc in-tree, delete it, and git-commit
2574 # 6. Back in the main tree, fast forward to the new HEAD
2576 my $clogp = parsechangelog();
2577 my $headref = git_rev_parse('HEAD');
2582 my $upstreamversion=$version;
2583 $upstreamversion =~ s/-[^-]*$//;
2585 my $fakeversion="$upstreamversion-~~DGITFAKE";
2587 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2588 print $fakedsc <<END or die $!;
2591 Version: $fakeversion
2595 my $dscaddfile=sub {
2598 my $md = new Digest::MD5;
2600 my $fh = new IO::File $b, '<' or die "$b $!";
2605 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2608 foreach my $f (<../../../../*>) { #/){
2609 my $b=$f; $b =~ s{.*/}{};
2610 next unless is_orig_file $b, srcfn $upstreamversion,'';
2611 link $f, $b or die "$b $!";
2615 my @files=qw(debian/source/format debian/rules);
2616 if (stat_exists '../../../debian/patches') {
2617 push @files, 'debian/patches';
2620 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2621 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2623 $dscaddfile->($debtar);
2624 close $fakedsc or die $!;
2626 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2628 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2629 rename $fakexdir, "fake" or die "$fakexdir $!";
2631 mkdir "work" or die $!;
2633 mktree_in_ud_here();
2634 runcmd @git, qw(reset --hard), $headref;
2637 if (stat_exists ".pc") {
2639 progress "Tree already contains .pc - will use it then delete it.";
2642 rename '../fake/.pc','.pc' or die $!;
2645 quiltify($clogp,$headref);
2647 if (!open P, '>>', ".pc/applied-patches") {
2648 $!==&ENOENT or die $!;
2653 commit_quilty_patch();
2655 if ($mustdeletepc) {
2656 runcmd @git, qw(rm -rqf .pc);
2657 commit_admin "Commit removal of .pc (quilt series tracking data)";
2660 changedir '../../../..';
2661 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2664 sub quilt_fixup_editor () {
2665 my $descfn = $ENV{$fakeeditorenv};
2666 my $editing = $ARGV[$#ARGV];
2667 open I1, '<', $descfn or die "$descfn: $!";
2668 open I2, '<', $editing or die "$editing: $!";
2669 unlink $editing or die "$editing: $!";
2670 open O, '>', $editing or die "$editing: $!";
2671 while (<I1>) { print O or die $!; } I1->error and die $!;
2674 $copying ||= m/^\-\-\- /;
2675 next unless $copying;
2678 I2->error and die $!;
2683 #----- other building -----
2686 if ($cleanmode eq 'dpkg-source') {
2687 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2688 } elsif ($cleanmode eq 'dpkg-source-d') {
2689 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2690 } elsif ($cleanmode eq 'git') {
2691 runcmd_ordryrun_local @git, qw(clean -xdf);
2692 } elsif ($cleanmode eq 'git-ff') {
2693 runcmd_ordryrun_local @git, qw(clean -xdff);
2694 } elsif ($cleanmode eq 'check') {
2695 my $leftovers = cmdoutput @git, qw(clean -xdn);
2696 if (length $leftovers) {
2697 print STDERR $leftovers, "\n" or die $!;
2698 fail "tree contains uncommitted files and --clean=check specified";
2700 } elsif ($cleanmode eq 'none') {
2707 badusage "clean takes no additional arguments" if @ARGV;
2712 badusage "-p is not allowed when building" if defined $package;
2715 my $clogp = parsechangelog();
2716 $isuite = getfield $clogp, 'Distribution';
2717 $package = getfield $clogp, 'Source';
2718 $version = getfield $clogp, 'Version';
2719 build_maybe_quilt_fixup();
2722 sub changesopts () {
2723 my @opts =@changesopts[1..$#changesopts];
2724 if (!defined $changes_since_version) {
2725 my @vsns = archive_query('archive_query');
2726 my @quirk = access_quirk();
2727 if ($quirk[0] eq 'backports') {
2728 local $isuite = $quirk[2];
2730 canonicalise_suite();
2731 push @vsns, archive_query('archive_query');
2734 @vsns = map { $_->[0] } @vsns;
2735 @vsns = sort { -version_compare($a, $b) } @vsns;
2736 $changes_since_version = $vsns[0];
2737 progress "changelog will contain changes since $vsns[0]";
2739 $changes_since_version = '_';
2740 progress "package seems new, not specifying -v<version>";
2743 if ($changes_since_version ne '_') {
2744 unshift @opts, "-v$changes_since_version";
2749 sub massage_dbp_args ($) {
2751 return unless $cleanmode =~ m/git|none/;
2752 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2753 my @newcmd = shift @$cmd;
2754 # -nc has the side effect of specifying -b if nothing else specified
2755 push @newcmd, '-nc';
2756 # and some combinations of -S, -b, et al, are errors, rather than
2757 # later simply overriding earlier
2758 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2759 push @newcmd, @$cmd;
2765 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2766 massage_dbp_args \@dbp;
2767 runcmd_ordryrun_local @dbp;
2768 printdone "build successful\n";
2773 my @dbp = @dpkgbuildpackage;
2774 massage_dbp_args \@dbp;
2776 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2777 "--git-builder=@dbp");
2778 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2779 canonicalise_suite();
2780 push @cmd, "--git-debian-branch=".lbranch();
2782 push @cmd, changesopts();
2783 runcmd_ordryrun_local @cmd, @ARGV;
2784 printdone "build successful\n";
2789 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2790 $dscfn = dscfn($version);
2791 if ($cleanmode eq 'dpkg-source') {
2792 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2794 } elsif ($cleanmode eq 'dpkg-source-d') {
2795 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2798 my $pwd = must_getcwd();
2799 my $leafdir = basename $pwd;
2801 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2803 runcmd_ordryrun_local qw(sh -ec),
2804 'exec >$1; shift; exec "$@"','x',
2805 "../$sourcechanges",
2806 @dpkggenchanges, qw(-S), changesopts();
2810 sub cmd_build_source {
2811 badusage "build-source takes no additional arguments" if @ARGV;
2813 printdone "source built, results in $dscfn and $sourcechanges";
2819 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2821 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2822 stat_exists $sourcechanges
2823 or fail "$sourcechanges (in parent directory): $!";
2824 foreach my $cf (glob $pat) {
2825 next if $cf eq $sourcechanges;
2826 unlink $cf or fail "remove $cf: $!";
2829 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2830 my @changesfiles = glob $pat;
2831 @changesfiles = sort {
2832 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2835 fail "wrong number of different changes files (@changesfiles)"
2836 unless @changesfiles;
2837 runcmd_ordryrun_local @mergechanges, @changesfiles;
2838 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2840 stat_exists $multichanges or fail "$multichanges: $!";
2842 printdone "build successful, results in $multichanges\n" or die $!;
2845 sub cmd_quilt_fixup {
2846 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2847 my $clogp = parsechangelog();
2848 $version = getfield $clogp, 'Version';
2849 $package = getfield $clogp, 'Source';
2850 build_maybe_quilt_fixup();
2853 sub cmd_archive_api_query {
2854 badusage "need only 1 subpath argument" unless @ARGV==1;
2855 my ($subpath) = @ARGV;
2856 my @cmd = archive_api_query_cmd($subpath);
2858 exec @cmd or fail "exec curl: $!\n";
2861 sub cmd_clone_dgit_repos_server {
2862 badusage "need destination argument" unless @ARGV==1;
2863 my ($destdir) = @ARGV;
2864 $package = '_dgit-repos-server';
2865 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2867 exec @cmd or fail "exec git clone: $!\n";
2870 sub cmd_setup_mergechangelogs {
2871 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2872 setup_mergechangelogs();
2875 #---------- argument parsing and main program ----------
2878 print "dgit version $our_version\n" or die $!;
2885 if (defined $ENV{'DGIT_SSH'}) {
2886 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2887 } elsif (defined $ENV{'GIT_SSH'}) {
2888 @ssh = ($ENV{'GIT_SSH'});
2892 last unless $ARGV[0] =~ m/^-/;
2896 if (m/^--dry-run$/) {
2899 } elsif (m/^--damp-run$/) {
2902 } elsif (m/^--no-sign$/) {
2905 } elsif (m/^--help$/) {
2907 } elsif (m/^--version$/) {
2909 } elsif (m/^--new$/) {
2912 } elsif (m/^--since-version=([^_]+|_)$/) {
2914 $changes_since_version = $1;
2915 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2916 ($om = $opts_opt_map{$1}) &&
2920 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2921 !$opts_opt_cmdonly{$1} &&
2922 ($om = $opts_opt_map{$1})) {
2925 } elsif (m/^--existing-package=(.*)/s) {
2927 $existing_package = $1;
2928 } elsif (m/^--initiator-tempdir=(.*)/s) {
2929 $initiator_tempdir = $1;
2930 $initiator_tempdir =~ m#^/# or
2931 badusage "--initiator-tempdir must be used specify an".
2932 " absolute, not relative, directory."
2933 } elsif (m/^--distro=(.*)/s) {
2936 } elsif (m/^--build-products-dir=(.*)/s) {
2938 $buildproductsdir = $1;
2939 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2942 } elsif (m/^--clean=(.*)$/s) {
2943 badusage "unknown cleaning mode \`$1'";
2944 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2947 } elsif (m/^--quilt=(.*)$/s) {
2948 badusage "unknown quilt fixup mode \`$1'";
2949 } elsif (m/^--ignore-dirty$/s) {
2952 } elsif (m/^--no-quilt-fixup$/s) {
2954 $quilt_mode = 'nocheck';
2955 } elsif (m/^--no-rm-on-error$/s) {
2958 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2960 push @deliberatelies, $&;
2962 badusage "unknown long option \`$_'";
2969 } elsif (s/^-L/-/) {
2972 } elsif (s/^-h/-/) {
2974 } elsif (s/^-D/-/) {
2978 } elsif (s/^-N/-/) {
2981 } elsif (s/^-v([^_]+|_)$//s) {
2983 $changes_since_version = $1;
2986 push @changesopts, $_;
2988 } elsif (s/^-c(.*=.*)//s) {
2990 push @git, '-c', $1;
2991 } elsif (s/^-d(.+)//s) {
2994 } elsif (s/^-C(.+)//s) {
2997 if ($changesfile =~ s#^(.*)/##) {
2998 $buildproductsdir = $1;
3000 } elsif (s/^-k(.+)//s) {
3002 } elsif (m/^-[vdCk]$/) {
3004 "option \`$_' requires an argument (and no space before the argument)";
3005 } elsif (s/^-wn$//s) {
3007 $cleanmode = 'none';
3008 } elsif (s/^-wg$//s) {
3011 } elsif (s/^-wgf$//s) {
3013 $cleanmode = 'git-ff';
3014 } elsif (s/^-wd$//s) {
3016 $cleanmode = 'dpkg-source';
3017 } elsif (s/^-wdd$//s) {
3019 $cleanmode = 'dpkg-source-d';
3020 } elsif (s/^-wc$//s) {
3022 $cleanmode = 'check';
3024 badusage "unknown short option \`$_'";
3031 if ($ENV{$fakeeditorenv}) {
3032 quilt_fixup_editor();
3036 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3037 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3038 if $dryrun_level == 1;
3040 print STDERR $helpmsg or die $!;
3043 my $cmd = shift @ARGV;
3046 if (!defined $quilt_mode) {
3047 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3048 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3050 $quilt_mode =~ m/^($quilt_modes_re)$/
3051 or badcfg "unknown quilt-mode \`$quilt_mode'";
3055 my $fn = ${*::}{"cmd_$cmd"};
3056 $fn or badusage "unknown operation $cmd";