3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 $SIG{__WARN__} = sub { die $_[0]; };
26 use Dpkg::Control::Hash;
28 use File::Temp qw(tempdir);
38 our $our_version = 'UNRELEASED'; ###substituted###
40 our $rpushprotovsn = 2;
42 our $isuite = 'unstable';
48 our $dryrun_level = 0;
50 our $buildproductsdir = '..';
56 our $existing_package = 'dpkg';
57 our $cleanmode = 'dpkg-source';
58 our $changes_since_version;
60 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
61 our $we_are_responder;
62 our $initiator_tempdir;
64 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
66 our $suite_re = '[-+.0-9a-z]+';
69 our (@dget) = qw(dget);
70 our (@curl) = qw(curl -f);
71 our (@dput) = qw(dput);
72 our (@debsign) = qw(debsign);
74 our (@sbuild) = qw(sbuild -A);
76 our (@dgit) = qw(dgit);
77 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
78 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
79 our (@dpkggenchanges) = qw(dpkg-genchanges);
80 our (@mergechanges) = qw(mergechanges -f);
81 our (@changesopts) = ('');
83 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
86 'debsign' => \@debsign,
91 'dpkg-source' => \@dpkgsource,
92 'dpkg-buildpackage' => \@dpkgbuildpackage,
93 'dpkg-genchanges' => \@dpkggenchanges,
94 'ch' => \@changesopts,
95 'mergechanges' => \@mergechanges);
97 our %opts_opt_cmdonly = ('gpg' => 1);
103 our $remotename = 'dgit';
104 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
108 sub lbranch () { return "$branchprefix/$csuite"; }
109 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
110 sub lref () { return "refs/heads/".lbranch(); }
111 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
112 sub rrref () { return server_ref($csuite); }
114 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
124 return "${package}_".(stripepoch $vsn).$sfx
129 return srcfn($vsn,".dsc");
138 foreach my $f (@end) {
140 warn "$us: cleanup: $@" if length $@;
144 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
146 sub no_such_package () {
147 print STDERR "$us: package $package does not exist in suite $isuite\n";
153 return "+".rrref().":".lrref();
158 printdebug "CD $newdir\n";
159 chdir $newdir or die "chdir: $newdir: $!";
162 sub deliberately ($) {
164 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
167 sub deliberately_not_fast_forward () {
168 foreach (qw(not-fast-forward fresh-repo)) {
169 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
173 #---------- remote protocol support, common ----------
175 # remote push initiator/responder protocol:
176 # < dgit-remote-push-ready [optional extra info ignored by old initiators]
178 # > file parsed-changelog
179 # [indicates that output of dpkg-parsechangelog follows]
180 # > data-block NBYTES
181 # > [NBYTES bytes of data (no newline)]
182 # [maybe some more blocks]
194 # [indicates that signed tag is wanted]
195 # < data-block NBYTES
196 # < [NBYTES bytes of data (no newline)]
197 # [maybe some more blocks]
201 # > want signed-dsc-changes
202 # < data-block NBYTES [transfer of signed dsc]
204 # < data-block NBYTES [transfer of signed changes]
212 sub i_child_report () {
213 # Sees if our child has died, and reap it if so. Returns a string
214 # describing how it died if it failed, or undef otherwise.
215 return undef unless $i_child_pid;
216 my $got = waitpid $i_child_pid, WNOHANG;
217 return undef if $got <= 0;
218 die unless $got == $i_child_pid;
219 $i_child_pid = undef;
220 return undef unless $?;
221 return "build host child ".waitstatusmsg();
226 fail "connection lost: $!" if $fh->error;
227 fail "protocol violation; $m not expected";
230 sub badproto_badread ($$) {
232 fail "connection lost: $!" if $!;
233 my $report = i_child_report();
234 fail $report if defined $report;
235 badproto $fh, "eof (reading $wh)";
238 sub protocol_expect (&$) {
239 my ($match, $fh) = @_;
242 defined && chomp or badproto_badread $fh, "protocol message";
250 badproto $fh, "\`$_'";
253 sub protocol_send_file ($$) {
254 my ($fh, $ourfn) = @_;
255 open PF, "<", $ourfn or die "$ourfn: $!";
258 my $got = read PF, $d, 65536;
259 die "$ourfn: $!" unless defined $got;
261 print $fh "data-block ".length($d)."\n" or die $!;
262 print $fh $d or die $!;
264 PF->error and die "$ourfn $!";
265 print $fh "data-end\n" or die $!;
269 sub protocol_read_bytes ($$) {
270 my ($fh, $nbytes) = @_;
271 $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
273 my $got = read $fh, $d, $nbytes;
274 $got==$nbytes or badproto_badread $fh, "data block";
278 sub protocol_receive_file ($$) {
279 my ($fh, $ourfn) = @_;
280 printdebug "() $ourfn\n";
281 open PF, ">", $ourfn or die "$ourfn: $!";
283 my ($y,$l) = protocol_expect {
284 m/^data-block (.*)$/ ? (1,$1) :
285 m/^data-end$/ ? (0,) :
289 my $d = protocol_read_bytes $fh, $l;
290 print PF $d or die $!;
295 #---------- remote protocol support, responder ----------
297 sub responder_send_command ($) {
299 return unless $we_are_responder;
300 # called even without $we_are_responder
301 printdebug ">> $command\n";
302 print PO $command, "\n" or die $!;
305 sub responder_send_file ($$) {
306 my ($keyword, $ourfn) = @_;
307 return unless $we_are_responder;
308 printdebug "]] $keyword $ourfn\n";
309 responder_send_command "file $keyword";
310 protocol_send_file \*PO, $ourfn;
313 sub responder_receive_files ($@) {
314 my ($keyword, @ourfns) = @_;
315 die unless $we_are_responder;
316 printdebug "[[ $keyword @ourfns\n";
317 responder_send_command "want $keyword";
318 foreach my $fn (@ourfns) {
319 protocol_receive_file \*PI, $fn;
322 protocol_expect { m/^files-end$/ } \*PI;
325 #---------- remote protocol support, initiator ----------
327 sub initiator_expect (&) {
329 protocol_expect { &$match } \*RO;
332 #---------- end remote code ----------
335 if ($we_are_responder) {
337 responder_send_command "progress ".length($m) or die $!;
338 print PO $m or die $!;
348 $ua = LWP::UserAgent->new();
352 progress "downloading $what...";
353 my $r = $ua->get(@_) or die $!;
354 return undef if $r->code == 404;
355 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
356 return $r->decoded_content(charset => 'none');
359 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
364 failedcmd @_ if system @_;
367 sub act_local () { return $dryrun_level <= 1; }
368 sub act_scary () { return !$dryrun_level; }
371 if (!$dryrun_level) {
372 progress "dgit ok: @_";
374 progress "would be ok: @_ (but dry run only)";
379 printcmd(\*STDERR,$debugprefix."#",@_);
382 sub runcmd_ordryrun {
390 sub runcmd_ordryrun_local {
399 my ($first_shell, @cmd) = @_;
400 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
403 our $helpmsg = <<END;
405 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
406 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
407 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
408 dgit [dgit-opts] push [dgit-opts] [suite]
409 dgit [dgit-opts] rpush build-host:build-dir ...
410 important dgit options:
411 -k<keyid> sign tag and package with <keyid> instead of default
412 --dry-run -n do not change anything, but go through the motions
413 --damp-run -L like --dry-run but make local changes, without signing
414 --new -N allow introducing a new package
415 --debug -D increase debug level
416 -c<name>=<value> set git config option (used directly by dgit too)
419 our $later_warning_msg = <<END;
420 Perhaps the upload is stuck in incoming. Using the version from git.
424 print STDERR "$us: @_\n", $helpmsg or die $!;
429 @ARGV or badusage "too few arguments";
430 return scalar shift @ARGV;
434 print $helpmsg or die $!;
438 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
440 our %defcfg = ('dgit.default.distro' => 'debian',
441 'dgit.default.username' => '',
442 'dgit.default.archive-query-default-component' => 'main',
443 'dgit.default.ssh' => 'ssh',
444 'dgit.default.archive-query' => 'madison:',
445 'dgit.default.sshpsql-dbname' => 'service=projectb',
446 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
447 'dgit-distro.debian.git-host' => 'dgit-git.debian.net',
448 'dgit-distro.debian.git-user-force' => 'dgit',
449 'dgit-distro.debian.git-proto' => 'git+ssh://',
450 'dgit-distro.debian.git-path' => '/dgit/debian/repos',
451 'dgit-distro.debian.git-create' => 'true',
452 'dgit-distro.debian.git-check' => 'ssh-cmd',
453 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
454 # 'dgit-distro.debian.archive-query-tls-key',
455 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
456 # ^ this does not work because curl is broken nowadays
457 # Fixing #790093 properly will involve providing providing the key
458 # in some pacagke and maybe updating these paths.
460 # 'dgit-distro.debian.archive-query-tls-curl-args',
461 # '--ca-path=/etc/ssl/ca-debian',
462 # ^ this is a workaround but works (only) on DSA-administered machines
463 'dgit-distro.debian.diverts.alioth' => '/alioth',
464 'dgit-distro.debian/push.diverts.alioth' => '/alioth',
465 'dgit-distro.debian/alioth.git-host' => 'git.debian.org',
466 'dgit-distro.debian/alioth.git-user-force' => '',
467 'dgit-distro.debian/alioth.git-proto' => 'git+ssh://',
468 'dgit-distro.debian/alioth.git-path' => '/git/dgit-repos/repos',
469 'dgit-distro.debian/alioth.git-create' => 'ssh-cmd',
470 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
471 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
472 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
473 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
474 'dgit-distro.ubuntu.git-check' => 'false',
475 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
476 'dgit-distro.test-dummy.ssh' => "$td/ssh",
477 'dgit-distro.test-dummy.username' => "alice",
478 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
479 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
480 'dgit-distro.test-dummy.git-url' => "$td/git",
481 'dgit-distro.test-dummy.git-host' => "git",
482 'dgit-distro.test-dummy.git-path' => "$td/git",
483 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
484 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
485 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
486 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
489 sub git_get_config ($) {
492 our %git_get_config_memo;
493 if (exists $git_get_config_memo{$c}) {
494 return $git_get_config_memo{$c};
498 my @cmd = (@git, qw(config --), $c);
500 local ($debuglevel) = $debuglevel-2;
501 $v = cmdoutput_errok @cmd;
509 $git_get_config_memo{$c} = $v;
515 return undef if $c =~ /RETURN-UNDEF/;
516 my $v = git_get_config($c);
517 return $v if defined $v;
518 my $dv = $defcfg{$c};
519 return $dv if defined $dv;
521 badcfg "need value for one of: @_\n".
522 "$us: distro or suite appears not to be (properly) supported";
525 sub access_basedistro () {
526 if (defined $idistro) {
529 return cfg("dgit-suite.$isuite.distro",
530 "dgit.default.distro");
534 sub access_quirk () {
535 # returns (quirk name, distro to use instead or undef, quirk-specific info)
536 my $basedistro = access_basedistro();
537 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
539 if (defined $backports_quirk) {
540 my $re = $backports_quirk;
541 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
543 $re =~ s/\%/([-0-9a-z_]+)/
544 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
545 if ($isuite =~ m/^$re$/) {
546 return ('backports',"$basedistro-backports",$1);
549 return ('none',undef);
552 our $access_pushing = 0;
558 sub access_distros () {
559 # Returns list of distros to try, in order
562 # 0. `instead of' distro name(s) we have been pointed to
563 # 1. the access_quirk distro, if any
564 # 2a. the user's specified distro, or failing that } basedistro
565 # 2b. the distro calculated from the suite }
566 my @l = access_basedistro();
568 my (undef,$quirkdistro) = access_quirk();
569 unshift @l, $quirkdistro;
570 unshift @l, $instead_distro;
571 @l = grep { defined } @l;
573 if ($access_pushing) {
574 @l = map { ("$_/push", $_) } @l;
582 # The nesting of these loops determines the search order. We put
583 # the key loop on the outside so that we search all the distros
584 # for each key, before going on to the next key. That means that
585 # if access_cfg is called with a more specific, and then a less
586 # specific, key, an earlier distro can override the less specific
587 # without necessarily overriding any more specific keys. (If the
588 # distro wants to override the more specific keys it can simply do
589 # so; whereas if we did the loop the other way around, it would be
590 # impossible to for an earlier distro to override a less specific
591 # key but not the more specific ones without restating the unknown
592 # values of the more specific keys.
595 # We have to deal with RETURN-UNDEF specially, so that we don't
596 # terminate the search prematurely.
598 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
601 foreach my $d (access_distros()) {
602 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
604 push @cfgs, map { "dgit.default.$_" } @realkeys;
606 my $value = cfg(@cfgs);
610 sub string_to_ssh ($) {
612 if ($spec =~ m/\s/) {
613 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
619 sub access_cfg_ssh () {
620 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
621 if (!defined $gitssh) {
624 return string_to_ssh $gitssh;
628 sub access_runeinfo ($) {
630 return ": dgit ".access_basedistro()." $info ;";
633 sub access_someuserhost ($) {
635 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
636 defined($user) && length($user) or
637 $user = access_cfg("$some-user",'username');
638 my $host = access_cfg("$some-host");
639 return length($user) ? "$user\@$host" : $host;
642 sub access_gituserhost () {
643 return access_someuserhost('git');
646 sub access_giturl (;$) {
648 my $url = access_cfg('git-url','RETURN-UNDEF');
651 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
652 return undef unless defined $proto;
655 access_gituserhost().
656 access_cfg('git-path');
658 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
661 return "$url/$package$suffix";
664 sub parsecontrolfh ($$;$) {
665 my ($fh, $desc, $allowsigned) = @_;
666 our $dpkgcontrolhash_noissigned;
669 my %opts = ('name' => $desc);
670 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
671 $c = Dpkg::Control::Hash->new(%opts);
672 $c->parse($fh,$desc) or die "parsing of $desc failed";
673 last if $allowsigned;
674 last if $dpkgcontrolhash_noissigned;
675 my $issigned= $c->get_option('is_pgp_signed');
676 if (!defined $issigned) {
677 $dpkgcontrolhash_noissigned= 1;
678 seek $fh, 0,0 or die "seek $desc: $!";
679 } elsif ($issigned) {
680 fail "control file $desc is (already) PGP-signed. ".
681 " Note that dgit push needs to modify the .dsc and then".
682 " do the signature itself";
691 my ($file, $desc) = @_;
692 my $fh = new IO::Handle;
693 open $fh, '<', $file or die "$file: $!";
694 my $c = parsecontrolfh($fh,$desc);
695 $fh->error and die $!;
701 my ($dctrl,$field) = @_;
702 my $v = $dctrl->{$field};
703 return $v if defined $v;
704 fail "missing field $field in ".$v->get_option('name');
708 my $c = Dpkg::Control::Hash->new();
709 my $p = new IO::Handle;
710 my @cmd = (qw(dpkg-parsechangelog), @_);
711 open $p, '-|', @cmd or die $!;
713 $?=0; $!=0; close $p or failedcmd @cmd;
719 defined $d or fail "getcwd failed: $!";
725 sub archive_query ($) {
727 my $query = access_cfg('archive-query','RETURN-UNDEF');
728 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
731 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
734 sub pool_dsc_subpath ($$) {
735 my ($vsn,$component) = @_; # $package is implict arg
736 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
737 return "/pool/$component/$prefix/$package/".dscfn($vsn);
740 #---------- `ftpmasterapi' archive query method (nascent) ----------
742 sub archive_api_query_cmd ($) {
744 my @cmd = qw(curl -sS);
745 my $url = access_cfg('archive-query-url');
746 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
748 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
749 foreach my $key (split /\:/, $keys) {
750 $key =~ s/\%HOST\%/$host/g;
752 fail "for $url: stat $key: $!" unless $!==ENOENT;
755 fail "config requested specific TLS key but do not know".
756 " how to get curl to use exactly that EE key ($key)";
757 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
758 # # Sadly the above line does not work because of changes
759 # # to gnutls. The real fix for #790093 may involve
760 # # new curl options.
763 # Fixing #790093 properly will involve providing a value
764 # for this on clients.
765 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
766 push @cmd, split / /, $kargs if defined $kargs;
768 push @cmd, $url.$subpath;
774 my ($data, $subpath) = @_;
775 badcfg "ftpmasterapi archive query method takes no data part"
777 my @cmd = archive_api_query_cmd($subpath);
778 my $json = cmdoutput @cmd;
779 return decode_json($json);
782 sub canonicalise_suite_ftpmasterapi () {
783 my ($proto,$data) = @_;
784 my $suites = api_query($data, 'suites');
786 foreach my $entry (@$suites) {
788 my $v = $entry->{$_};
789 defined $v && $v eq $isuite;
791 push @matched, $entry;
793 fail "unknown suite $isuite" unless @matched;
796 @matched==1 or die "multiple matches for suite $isuite\n";
797 $cn = "$matched[0]{codename}";
798 defined $cn or die "suite $isuite info has no codename\n";
799 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
801 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
806 sub archive_query_ftpmasterapi () {
807 my ($proto,$data) = @_;
808 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
810 my $digester = Digest::SHA->new(256);
811 foreach my $entry (@$info) {
813 my $vsn = "$entry->{version}";
814 my ($ok,$msg) = version_check $vsn;
815 die "bad version: $msg\n" unless $ok;
816 my $component = "$entry->{component}";
817 $component =~ m/^$component_re$/ or die "bad component";
818 my $filename = "$entry->{filename}";
819 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
820 or die "bad filename";
821 my $sha256sum = "$entry->{sha256sum}";
822 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
823 push @rows, [ $vsn, "/pool/$component/$filename",
824 $digester, $sha256sum ];
826 die "bad ftpmaster api response: $@\n".Dumper($entry)
829 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
833 #---------- `madison' archive query method ----------
835 sub archive_query_madison {
836 return map { [ @$_[0..1] ] } madison_get_parse(@_);
839 sub madison_get_parse {
840 my ($proto,$data) = @_;
841 die unless $proto eq 'madison';
843 $data= access_cfg('madison-distro','RETURN-UNDEF');
844 $data //= access_basedistro();
846 $rmad{$proto,$data,$package} ||= cmdoutput
847 qw(rmadison -asource),"-s$isuite","-u$data",$package;
848 my $rmad = $rmad{$proto,$data,$package};
851 foreach my $l (split /\n/, $rmad) {
852 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
853 \s*( [^ \t|]+ )\s* \|
854 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
855 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
856 $1 eq $package or die "$rmad $package ?";
863 $component = access_cfg('archive-query-default-component');
865 $5 eq 'source' or die "$rmad ?";
866 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
868 return sort { -version_compare($a->[0],$b->[0]); } @out;
871 sub canonicalise_suite_madison {
872 # madison canonicalises for us
873 my @r = madison_get_parse(@_);
875 "unable to canonicalise suite using package $package".
876 " which does not appear to exist in suite $isuite;".
877 " --existing-package may help";
881 #---------- `sshpsql' archive query method ----------
884 my ($data,$runeinfo,$sql) = @_;
886 $data= access_someuserhost('sshpsql').':'.
887 access_cfg('sshpsql-dbname');
889 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
890 my ($userhost,$dbname) = ($`,$'); #';
892 my @cmd = (access_cfg_ssh, $userhost,
893 access_runeinfo("ssh-psql $runeinfo").
894 " export LC_MESSAGES=C; export LC_CTYPE=C;".
895 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
897 open P, "-|", @cmd or die $!;
900 printdebug("$debugprefix>|$_|\n");
903 $!=0; $?=0; close P or failedcmd @cmd;
905 my $nrows = pop @rows;
906 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
907 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
908 @rows = map { [ split /\|/, $_ ] } @rows;
909 my $ncols = scalar @{ shift @rows };
910 die if grep { scalar @$_ != $ncols } @rows;
914 sub sql_injection_check {
915 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
918 sub archive_query_sshpsql ($$) {
919 my ($proto,$data) = @_;
920 sql_injection_check $isuite, $package;
921 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
922 SELECT source.version, component.name, files.filename, files.sha256sum
924 JOIN src_associations ON source.id = src_associations.source
925 JOIN suite ON suite.id = src_associations.suite
926 JOIN dsc_files ON dsc_files.source = source.id
927 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
928 JOIN component ON component.id = files_archive_map.component_id
929 JOIN files ON files.id = dsc_files.file
930 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
931 AND source.source='$package'
932 AND files.filename LIKE '%.dsc';
934 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
935 my $digester = Digest::SHA->new(256);
937 my ($vsn,$component,$filename,$sha256sum) = @$_;
938 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
943 sub canonicalise_suite_sshpsql ($$) {
944 my ($proto,$data) = @_;
945 sql_injection_check $isuite;
946 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
947 SELECT suite.codename
948 FROM suite where suite_name='$isuite' or codename='$isuite';
950 @rows = map { $_->[0] } @rows;
951 fail "unknown suite $isuite" unless @rows;
952 die "ambiguous $isuite: @rows ?" if @rows>1;
956 #---------- `dummycat' archive query method ----------
958 sub canonicalise_suite_dummycat ($$) {
959 my ($proto,$data) = @_;
960 my $dpath = "$data/suite.$isuite";
961 if (!open C, "<", $dpath) {
962 $!==ENOENT or die "$dpath: $!";
963 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
967 chomp or die "$dpath: $!";
969 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
973 sub archive_query_dummycat ($$) {
974 my ($proto,$data) = @_;
975 canonicalise_suite();
976 my $dpath = "$data/package.$csuite.$package";
977 if (!open C, "<", $dpath) {
978 $!==ENOENT or die "$dpath: $!";
979 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
987 printdebug "dummycat query $csuite $package $dpath | $_\n";
988 my @row = split /\s+/, $_;
989 @row==2 or die "$dpath: $_ ?";
992 C->error and die "$dpath: $!";
994 return sort { -version_compare($a->[0],$b->[0]); } @rows;
997 #---------- archive query entrypoints and rest of program ----------
999 sub canonicalise_suite () {
1000 return if defined $csuite;
1001 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1002 $csuite = archive_query('canonicalise_suite');
1003 if ($isuite ne $csuite) {
1004 progress "canonical suite name for $isuite is $csuite";
1008 sub get_archive_dsc () {
1009 canonicalise_suite();
1010 my @vsns = archive_query('archive_query');
1011 foreach my $vinfo (@vsns) {
1012 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1013 $dscurl = access_cfg('mirror').$subpath;
1014 $dscdata = url_get($dscurl);
1016 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1021 $digester->add($dscdata);
1022 my $got = $digester->hexdigest();
1024 fail "$dscurl has hash $got but".
1025 " archive told us to expect $digest";
1027 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1028 printdebug Dumper($dscdata) if $debuglevel>1;
1029 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1030 printdebug Dumper($dsc) if $debuglevel>1;
1031 my $fmt = getfield $dsc, 'Format';
1032 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1033 $dsc_checked = !!$digester;
1039 sub check_for_git ();
1040 sub check_for_git () {
1042 my $how = access_cfg('git-check');
1043 if ($how eq 'ssh-cmd') {
1045 (access_cfg_ssh, access_gituserhost(),
1046 access_runeinfo("git-check $package").
1047 " set -e; cd ".access_cfg('git-path').";".
1048 " if test -d $package.git; then echo 1; else echo 0; fi");
1049 my $r= cmdoutput @cmd;
1050 if ($r =~ m/^divert (\w+)$/) {
1052 my ($usedistro,) = access_distros();
1053 # NB that if we are pushing, $usedistro will be $distro/push
1054 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1055 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1056 progress "diverting to $divert (using config for $instead_distro)";
1057 return check_for_git();
1059 failedcmd @cmd unless $r =~ m/^[01]$/;
1061 } elsif ($how eq 'url') {
1062 my $prefix = access_cfg('git-check-url','git-url');
1063 my $suffix = access_cfg('git-check-suffix','git-suffix',
1064 'RETURN-UNDEF') // '.git';
1065 my $url = "$prefix/$package$suffix";
1066 my @cmd = (qw(curl -sS -I), $url);
1067 my $result = cmdoutput @cmd;
1068 $result =~ m/^\S+ (404|200) /s or
1069 fail "unexpected results from git check query - ".
1070 Dumper($prefix, $result);
1072 if ($code eq '404') {
1074 } elsif ($code eq '200') {
1079 } elsif ($how eq 'true') {
1081 } elsif ($how eq 'false') {
1084 badcfg "unknown git-check \`$how'";
1088 sub create_remote_git_repo () {
1089 my $how = access_cfg('git-create');
1090 if ($how eq 'ssh-cmd') {
1092 (access_cfg_ssh, access_gituserhost(),
1093 access_runeinfo("git-create $package").
1094 "set -e; cd ".access_cfg('git-path').";".
1095 " cp -a _template $package.git");
1096 } elsif ($how eq 'true') {
1099 badcfg "unknown git-create \`$how'";
1103 our ($dsc_hash,$lastpush_hash);
1105 our $ud = '.git/dgit/unpack';
1110 mkdir $ud or die $!;
1113 sub mktree_in_ud_here () {
1114 runcmd qw(git init -q);
1115 rmtree('.git/objects');
1116 symlink '../../../../objects','.git/objects' or die $!;
1119 sub git_write_tree () {
1120 my $tree = cmdoutput @git, qw(write-tree);
1121 $tree =~ m/^\w+$/ or die "$tree ?";
1125 sub mktree_in_ud_from_only_subdir () {
1126 # changes into the subdir
1128 die unless @dirs==1;
1129 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1132 fail "source package contains .git directory" if stat_exists '.git';
1133 mktree_in_ud_here();
1134 my $format=get_source_format();
1135 if (madformat($format)) {
1138 runcmd @git, qw(add -Af);
1139 my $tree=git_write_tree();
1140 return ($tree,$dir);
1143 sub dsc_files_info () {
1144 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1145 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1146 ['Files', 'Digest::MD5', 'new()']) {
1147 my ($fname, $module, $method) = @$csumi;
1148 my $field = $dsc->{$fname};
1149 next unless defined $field;
1150 eval "use $module; 1;" or die $@;
1152 foreach (split /\n/, $field) {
1154 m/^(\w+) (\d+) (\S+)$/ or
1155 fail "could not parse .dsc $fname line \`$_'";
1156 my $digester = eval "$module"."->$method;" or die $@;
1161 Digester => $digester,
1166 fail "missing any supported Checksums-* or Files field in ".
1167 $dsc->get_option('name');
1171 map { $_->{Filename} } dsc_files_info();
1174 sub is_orig_file ($;$) {
1177 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1178 defined $base or return 1;
1182 sub make_commit ($) {
1184 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1187 sub clogp_authline ($) {
1189 my $author = getfield $clogp, 'Maintainer';
1190 $author =~ s#,.*##ms;
1191 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1192 my $authline = "$author $date";
1193 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1194 fail "unexpected commit author line format \`$authline'".
1195 " (was generated from changelog Maintainer field)";
1199 sub vendor_patches_distro ($$) {
1200 my ($checkdistro, $what) = @_;
1201 return unless defined $checkdistro;
1203 my $series = "debian/patches/\L$checkdistro\E.series";
1204 printdebug "checking for vendor-specific $series ($what)\n";
1206 if (!open SERIES, "<", $series) {
1207 die "$series $!" unless $!==ENOENT;
1216 Unfortunately, this source package uses a feature of dpkg-source where
1217 the same source package unpacks to different source code on different
1218 distros. dgit cannot safely operate on such packages on affected
1219 distros, because the meaning of source packages is not stable.
1221 Please ask the distro/maintainer to remove the distro-specific series
1222 files and use a different technique (if necessary, uploading actually
1223 different packages, if different distros are supposed to have
1227 fail "Found active distro-specific series file for".
1228 " $checkdistro ($what): $series, cannot continue";
1230 die "$series $!" if SERIES->error;
1234 sub check_for_vendor_patches () {
1235 # This dpkg-source feature doesn't seem to be documented anywhere!
1236 # But it can be found in the changelog (reformatted):
1238 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1239 # Author: Raphael Hertzog <hertzog@debian.org>
1240 # Date: Sun Oct 3 09:36:48 2010 +0200
1242 # dpkg-source: correctly create .pc/.quilt_series with alternate
1245 # If you have debian/patches/ubuntu.series and you were
1246 # unpacking the source package on ubuntu, quilt was still
1247 # directed to debian/patches/series instead of
1248 # debian/patches/ubuntu.series.
1250 # debian/changelog | 3 +++
1251 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1252 # 2 files changed, 6 insertions(+), 1 deletion(-)
1255 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1256 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1257 "Dpkg::Vendor \`current vendor'");
1258 vendor_patches_distro(access_basedistro(),
1259 "distro being accessed");
1262 sub generate_commit_from_dsc () {
1266 foreach my $fi (dsc_files_info()) {
1267 my $f = $fi->{Filename};
1268 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1270 link "../../../$f", $f
1274 complete_file_from_dsc('.', $fi);
1276 if (is_orig_file($f)) {
1277 link $f, "../../../../$f"
1283 my $dscfn = "$package.dsc";
1285 open D, ">", $dscfn or die "$dscfn: $!";
1286 print D $dscdata or die "$dscfn: $!";
1287 close D or die "$dscfn: $!";
1288 my @cmd = qw(dpkg-source);
1289 push @cmd, '--no-check' if $dsc_checked;
1290 push @cmd, qw(-x --), $dscfn;
1293 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1294 check_for_vendor_patches() if madformat($dsc->{format});
1295 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1296 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1297 my $authline = clogp_authline $clogp;
1298 my $changes = getfield $clogp, 'Changes';
1299 open C, ">../commit.tmp" or die $!;
1300 print C <<END or die $!;
1307 # imported from the archive
1310 my $outputhash = make_commit qw(../commit.tmp);
1311 my $cversion = getfield $clogp, 'Version';
1312 progress "synthesised git commit from .dsc $cversion";
1313 if ($lastpush_hash) {
1314 runcmd @git, qw(reset --hard), $lastpush_hash;
1315 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1316 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1317 my $oversion = getfield $oldclogp, 'Version';
1319 version_compare($oversion, $cversion);
1321 # git upload/ is earlier vsn than archive, use archive
1322 open C, ">../commit2.tmp" or die $!;
1323 print C <<END or die $!;
1325 parent $lastpush_hash
1330 Record $package ($cversion) in archive suite $csuite
1332 $outputhash = make_commit qw(../commit2.tmp);
1333 } elsif ($vcmp > 0) {
1334 print STDERR <<END or die $!;
1336 Version actually in archive: $cversion (older)
1337 Last allegedly pushed/uploaded: $oversion (newer or same)
1340 $outputhash = $lastpush_hash;
1342 $outputhash = $lastpush_hash;
1345 changedir '../../../..';
1346 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1347 'DGIT_ARCHIVE', $outputhash;
1348 cmdoutput @git, qw(log -n2), $outputhash;
1349 # ... gives git a chance to complain if our commit is malformed
1354 sub complete_file_from_dsc ($$) {
1355 our ($dstdir, $fi) = @_;
1356 # Ensures that we have, in $dir, the file $fi, with the correct
1357 # contents. (Downloading it from alongside $dscurl if necessary.)
1359 my $f = $fi->{Filename};
1360 my $tf = "$dstdir/$f";
1363 if (stat_exists $tf) {
1364 progress "using existing $f";
1367 $furl =~ s{/[^/]+$}{};
1369 die "$f ?" unless $f =~ m/^${package}_/;
1370 die "$f ?" if $f =~ m#/#;
1371 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1372 next if !act_local();
1376 open F, "<", "$tf" or die "$tf: $!";
1377 $fi->{Digester}->reset();
1378 $fi->{Digester}->addfile(*F);
1379 F->error and die $!;
1380 my $got = $fi->{Digester}->hexdigest();
1381 $got eq $fi->{Hash} or
1382 fail "file $f has hash $got but .dsc".
1383 " demands hash $fi->{Hash} ".
1384 ($downloaded ? "(got wrong file from archive!)"
1385 : "(perhaps you should delete this file?)");
1388 sub ensure_we_have_orig () {
1389 foreach my $fi (dsc_files_info()) {
1390 my $f = $fi->{Filename};
1391 next unless is_orig_file($f);
1392 complete_file_from_dsc('..', $fi);
1396 sub git_fetch_us () {
1397 my @specs = (fetchspec());
1399 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1401 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1404 my $tagpat = debiantag('*',access_basedistro);
1406 git_for_each_ref("refs/tags/".$tagpat, sub {
1407 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1408 printdebug "currently $fullrefname=$objid\n";
1409 $here{$fullrefname} = $objid;
1411 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1412 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1413 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1414 printdebug "offered $lref=$objid\n";
1415 if (!defined $here{$lref}) {
1416 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1417 runcmd_ordryrun_local @upd;
1418 } elsif ($here{$lref} eq $objid) {
1421 "Not updateting $lref from $here{$lref} to $objid.\n";
1426 sub fetch_from_archive () {
1427 # ensures that lrref() is what is actually in the archive,
1428 # one way or another
1432 foreach my $field (@ourdscfield) {
1433 $dsc_hash = $dsc->{$field};
1434 last if defined $dsc_hash;
1436 if (defined $dsc_hash) {
1437 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1439 progress "last upload to archive specified git hash";
1441 progress "last upload to archive has NO git hash";
1444 progress "no version available from the archive";
1447 $lastpush_hash = git_get_ref(lrref());
1448 printdebug "previous reference hash=$lastpush_hash\n";
1450 if (defined $dsc_hash) {
1451 fail "missing remote git history even though dsc has hash -".
1452 " could not find ref ".lrref().
1453 " (should have been fetched from ".access_giturl()."#".rrref().")"
1454 unless $lastpush_hash;
1456 ensure_we_have_orig();
1457 if ($dsc_hash eq $lastpush_hash) {
1458 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1459 print STDERR <<END or die $!;
1461 Git commit in archive is behind the last version allegedly pushed/uploaded.
1462 Commit referred to by archive: $dsc_hash
1463 Last allegedly pushed/uploaded: $lastpush_hash
1466 $hash = $lastpush_hash;
1468 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1469 "descendant of archive's .dsc hash ($dsc_hash)";
1472 $hash = generate_commit_from_dsc();
1473 } elsif ($lastpush_hash) {
1474 # only in git, not in the archive yet
1475 $hash = $lastpush_hash;
1476 print STDERR <<END or die $!;
1478 Package not found in the archive, but has allegedly been pushed using dgit.
1482 printdebug "nothing found!\n";
1483 if (defined $skew_warning_vsn) {
1484 print STDERR <<END or die $!;
1486 Warning: relevant archive skew detected.
1487 Archive allegedly contains $skew_warning_vsn
1488 But we were not able to obtain any version from the archive or git.
1494 printdebug "current hash=$hash\n";
1495 if ($lastpush_hash) {
1496 fail "not fast forward on last upload branch!".
1497 " (archive's version left in DGIT_ARCHIVE)"
1498 unless is_fast_fwd($lastpush_hash, $hash);
1500 if (defined $skew_warning_vsn) {
1502 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1503 my $clogf = ".git/dgit/changelog.tmp";
1504 runcmd shell_cmd "exec >$clogf",
1505 @git, qw(cat-file blob), "$hash:debian/changelog";
1506 my $gotclogp = parsechangelog("-l$clogf");
1507 my $got_vsn = getfield $gotclogp, 'Version';
1508 printdebug "SKEW CHECK GOT $got_vsn\n";
1509 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1510 print STDERR <<END or die $!;
1512 Warning: archive skew detected. Using the available version:
1513 Archive allegedly contains $skew_warning_vsn
1514 We were able to obtain only $got_vsn
1519 if ($lastpush_hash ne $hash) {
1520 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1524 dryrun_report @upd_cmd;
1530 sub set_local_git_config ($$) {
1532 runcmd @git, qw(config), $k, $v;
1535 sub setup_mergechangelogs () {
1536 my $driver = 'dpkg-mergechangelogs';
1537 my $cb = "merge.$driver";
1538 my $attrs = '.git/info/attributes';
1539 ensuredir '.git/info';
1541 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1542 if (!open ATTRS, "<", $attrs) {
1543 $!==ENOENT or die "$attrs: $!";
1547 next if m{^debian/changelog\s};
1548 print NATTRS $_, "\n" or die $!;
1550 ATTRS->error and die $!;
1553 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1556 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1557 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1559 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1564 canonicalise_suite();
1565 badusage "dry run makes no sense with clone" unless act_local();
1566 my $hasgit = check_for_git();
1567 mkdir $dstdir or die "$dstdir $!";
1569 runcmd @git, qw(init -q);
1570 my $giturl = access_giturl(1);
1571 if (defined $giturl) {
1572 set_local_git_config "remote.$remotename.fetch", fetchspec();
1573 open H, "> .git/HEAD" or die $!;
1574 print H "ref: ".lref()."\n" or die $!;
1576 runcmd @git, qw(remote add), 'origin', $giturl;
1579 progress "fetching existing git history";
1581 runcmd_ordryrun_local @git, qw(fetch origin);
1583 progress "starting new git history";
1585 fetch_from_archive() or no_such_package;
1586 my $vcsgiturl = $dsc->{'Vcs-Git'};
1587 if (length $vcsgiturl) {
1588 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1589 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1591 setup_mergechangelogs();
1592 runcmd @git, qw(reset --hard), lrref();
1593 printdone "ready for work in $dstdir";
1597 if (check_for_git()) {
1600 fetch_from_archive() or no_such_package();
1601 printdone "fetched into ".lrref();
1606 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1608 printdone "fetched to ".lrref()." and merged into HEAD";
1611 sub check_not_dirty () {
1612 return if $ignoredirty;
1613 my @cmd = (@git, qw(diff --quiet HEAD));
1615 $!=0; $?=0; system @cmd;
1616 return if !$! && !$?;
1617 if (!$! && $?==256) {
1618 fail "working tree is dirty (does not match HEAD)";
1624 sub commit_admin ($) {
1627 runcmd_ordryrun_local @git, qw(commit -m), $m;
1630 sub commit_quilty_patch () {
1631 my $output = cmdoutput @git, qw(status --porcelain);
1633 foreach my $l (split /\n/, $output) {
1634 next unless $l =~ m/\S/;
1635 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1639 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1641 progress "nothing quilty to commit, ok.";
1644 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1645 commit_admin "Commit Debian 3.0 (quilt) metadata";
1648 sub get_source_format () {
1649 if (!open F, "debian/source/format") {
1650 die $! unless $!==&ENOENT;
1654 F->error and die $!;
1661 return 0 unless $format eq '3.0 (quilt)';
1662 if ($quilt_mode eq 'nocheck') {
1663 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1666 progress "Format \`$format', checking/updating patch stack";
1670 sub push_parse_changelog ($) {
1673 my $clogp = Dpkg::Control::Hash->new();
1674 $clogp->load($clogpfn) or die;
1676 $package = getfield $clogp, 'Source';
1677 my $cversion = getfield $clogp, 'Version';
1678 my $tag = debiantag($cversion, access_basedistro);
1679 runcmd @git, qw(check-ref-format), $tag;
1681 my $dscfn = dscfn($cversion);
1683 return ($clogp, $cversion, $tag, $dscfn);
1686 sub push_parse_dsc ($$$) {
1687 my ($dscfn,$dscfnwhat, $cversion) = @_;
1688 $dsc = parsecontrol($dscfn,$dscfnwhat);
1689 my $dversion = getfield $dsc, 'Version';
1690 my $dscpackage = getfield $dsc, 'Source';
1691 ($dscpackage eq $package && $dversion eq $cversion) or
1692 fail "$dscfn is for $dscpackage $dversion".
1693 " but debian/changelog is for $package $cversion";
1696 sub push_mktag ($$$$$$$) {
1697 my ($head,$clogp,$tag,
1699 $changesfile,$changesfilewhat,
1702 $dsc->{$ourdscfield[0]} = $head;
1703 $dsc->save("$dscfn.tmp") or die $!;
1705 my $changes = parsecontrol($changesfile,$changesfilewhat);
1706 foreach my $field (qw(Source Distribution Version)) {
1707 $changes->{$field} eq $clogp->{$field} or
1708 fail "changes field $field \`$changes->{$field}'".
1709 " does not match changelog \`$clogp->{$field}'";
1712 my $cversion = getfield $clogp, 'Version';
1713 my $clogsuite = getfield $clogp, 'Distribution';
1715 # We make the git tag by hand because (a) that makes it easier
1716 # to control the "tagger" (b) we can do remote signing
1717 my $authline = clogp_authline $clogp;
1718 my $delibs = join(" ", "",@deliberatelies);
1719 my $declaredistro = access_basedistro();
1720 open TO, '>', $tfn->('.tmp') or die $!;
1721 print TO <<END or die $!;
1727 $package release $cversion for $clogsuite ($csuite) [dgit]
1728 [dgit distro=$declaredistro$delibs]
1730 foreach my $ref (sort keys %previously) {
1731 print TO <<END or die $!;
1732 [dgit previously:$ref=$previously{$ref}]
1738 my $tagobjfn = $tfn->('.tmp');
1740 if (!defined $keyid) {
1741 $keyid = access_cfg('keyid','RETURN-UNDEF');
1743 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1744 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1745 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1746 push @sign_cmd, $tfn->('.tmp');
1747 runcmd_ordryrun @sign_cmd;
1749 $tagobjfn = $tfn->('.signed.tmp');
1750 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1751 $tfn->('.tmp'), $tfn->('.tmp.asc');
1758 sub sign_changes ($) {
1759 my ($changesfile) = @_;
1761 my @debsign_cmd = @debsign;
1762 push @debsign_cmd, "-k$keyid" if defined $keyid;
1763 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1764 push @debsign_cmd, $changesfile;
1765 runcmd_ordryrun @debsign_cmd;
1770 my ($forceflag) = @_;
1771 printdebug "actually entering push\n";
1774 access_giturl(); # check that success is vaguely likely
1776 my $clogpfn = ".git/dgit/changelog.822.tmp";
1777 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1779 responder_send_file('parsed-changelog', $clogpfn);
1781 my ($clogp, $cversion, $tag, $dscfn) =
1782 push_parse_changelog("$clogpfn");
1784 my $dscpath = "$buildproductsdir/$dscfn";
1785 stat_exists $dscpath or
1786 fail "looked for .dsc $dscfn, but $!;".
1787 " maybe you forgot to build";
1789 responder_send_file('dsc', $dscpath);
1791 push_parse_dsc($dscpath, $dscfn, $cversion);
1793 my $format = getfield $dsc, 'Format';
1794 printdebug "format $format\n";
1795 if (madformat($format)) {
1796 commit_quilty_patch();
1800 progress "checking that $dscfn corresponds to HEAD";
1801 runcmd qw(dpkg-source -x --),
1802 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1803 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1804 check_for_vendor_patches() if madformat($dsc->{format});
1805 changedir '../../../..';
1806 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1807 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1808 debugcmd "+",@diffcmd;
1810 my $r = system @diffcmd;
1813 fail "$dscfn specifies a different tree to your HEAD commit;".
1814 " perhaps you forgot to build".
1815 ($diffopt eq '--exit-code' ? "" :
1816 " (run with -D to see full diff output)");
1822 #do fast forward check and maybe fake merge
1823 # if (!is_fast_fwd(mainbranch
1824 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1825 # map { lref($_).":".rref($_) }
1827 my $head = git_rev_parse('HEAD');
1828 if (!$changesfile) {
1829 my $multi = "$buildproductsdir/".
1830 "${package}_".(stripepoch $cversion)."_multi.changes";
1831 if (stat_exists "$multi") {
1832 $changesfile = $multi;
1834 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1835 my @cs = glob "$buildproductsdir/$pat";
1836 fail "failed to find unique changes file".
1837 " (looked for $pat in $buildproductsdir, or $multi);".
1838 " perhaps you need to use dgit -C"
1840 ($changesfile) = @cs;
1843 $changesfile = "$buildproductsdir/$changesfile";
1846 responder_send_file('changes',$changesfile);
1847 responder_send_command("param head $head");
1848 responder_send_command("param csuite $csuite");
1850 if (deliberately_not_fast_forward) {
1851 git_for_each_ref(lrfetchrefs, sub {
1852 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1853 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1854 responder_send_command("previously $rrefname=$objid");
1855 $previously{$rrefname} = $objid;
1859 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1862 if ($we_are_responder) {
1863 $tagobjfn = $tfn->('.signed.tmp');
1864 responder_receive_files('signed-tag', $tagobjfn);
1867 push_mktag($head,$clogp,$tag,
1869 $changesfile,$changesfile,
1873 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1874 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1875 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1877 if (!check_for_git()) {
1878 create_remote_git_repo();
1880 runcmd_ordryrun @git, qw(push),access_giturl(),
1881 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1882 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1884 if ($we_are_responder) {
1885 my $dryrunsuffix = act_local() ? "" : ".tmp";
1886 responder_receive_files('signed-dsc-changes',
1887 "$dscpath$dryrunsuffix",
1888 "$changesfile$dryrunsuffix");
1891 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1893 progress "[new .dsc left in $dscpath.tmp]";
1895 sign_changes $changesfile;
1898 my $host = access_cfg('upload-host','RETURN-UNDEF');
1899 my @hostarg = defined($host) ? ($host,) : ();
1900 runcmd_ordryrun @dput, @hostarg, $changesfile;
1901 printdone "pushed and uploaded $cversion";
1903 responder_send_command("complete");
1909 badusage "-p is not allowed with clone; specify as argument instead"
1910 if defined $package;
1913 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1914 ($package,$isuite) = @ARGV;
1915 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1916 ($package,$dstdir) = @ARGV;
1917 } elsif (@ARGV==3) {
1918 ($package,$isuite,$dstdir) = @ARGV;
1920 badusage "incorrect arguments to dgit clone";
1922 $dstdir ||= "$package";
1924 if (stat_exists $dstdir) {
1925 fail "$dstdir already exists";
1929 if ($rmonerror && !$dryrun_level) {
1930 $cwd_remove= getcwd();
1932 return unless defined $cwd_remove;
1933 if (!chdir "$cwd_remove") {
1934 return if $!==&ENOENT;
1935 die "chdir $cwd_remove: $!";
1937 rmtree($dstdir) or die "remove $dstdir: $!\n";
1942 $cwd_remove = undef;
1945 sub branchsuite () {
1946 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1947 if ($branch =~ m#$lbranch_re#o) {
1954 sub fetchpullargs () {
1955 if (!defined $package) {
1956 my $sourcep = parsecontrol('debian/control','debian/control');
1957 $package = getfield $sourcep, 'Source';
1960 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1962 my $clogp = parsechangelog();
1963 $isuite = getfield $clogp, 'Distribution';
1965 canonicalise_suite();
1966 progress "fetching from suite $csuite";
1967 } elsif (@ARGV==1) {
1969 canonicalise_suite();
1971 badusage "incorrect arguments to dgit fetch or dgit pull";
1990 badusage "-p is not allowed with dgit push" if defined $package;
1992 my $clogp = parsechangelog();
1993 $package = getfield $clogp, 'Source';
1996 } elsif (@ARGV==1) {
1997 ($specsuite) = (@ARGV);
1999 badusage "incorrect arguments to dgit push";
2001 $isuite = getfield $clogp, 'Distribution';
2003 local ($package) = $existing_package; # this is a hack
2004 canonicalise_suite();
2006 canonicalise_suite();
2008 if (defined $specsuite &&
2009 $specsuite ne $isuite &&
2010 $specsuite ne $csuite) {
2011 fail "dgit push: changelog specifies $isuite ($csuite)".
2012 " but command line specifies $specsuite";
2014 if (check_for_git()) {
2018 if (fetch_from_archive()) {
2019 if (is_fast_fwd(lrref(), 'HEAD')) {
2021 } elsif (deliberately_not_fast_forward) {
2024 fail "dgit push: HEAD is not a descendant".
2025 " of the archive's version.\n".
2026 "dgit: To overwrite its contents,".
2027 " use git merge -s ours ".lrref().".\n".
2028 "dgit: To rewind history, if permitted by the archive,".
2029 " use --deliberately-not-fast-forward";
2033 fail "package appears to be new in this suite;".
2034 " if this is intentional, use --new";
2039 #---------- remote commands' implementation ----------
2041 sub cmd_remote_push_build_host {
2043 my ($nrargs) = shift @ARGV;
2044 my (@rargs) = @ARGV[0..$nrargs-1];
2045 @ARGV = @ARGV[$nrargs..$#ARGV];
2047 my ($dir,$vsnwant) = @rargs;
2048 # vsnwant is a comma-separated list; we report which we have
2049 # chosen in our ready response (so other end can tell if they
2052 $we_are_responder = 1;
2053 $us .= " (build host)";
2055 open PI, "<&STDIN" or die $!;
2056 open STDIN, "/dev/null" or die $!;
2057 open PO, ">&STDOUT" or die $!;
2059 open STDOUT, ">&STDERR" or die $!;
2063 fail "build host has dgit rpush protocol version".
2064 " $rpushprotovsn but invocation host has $vsnwant"
2065 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2067 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2073 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2074 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2075 # a good error message)
2081 my $report = i_child_report();
2082 if (defined $report) {
2083 printdebug "($report)\n";
2084 } elsif ($i_child_pid) {
2085 printdebug "(killing build host child $i_child_pid)\n";
2086 kill 15, $i_child_pid;
2088 if (defined $i_tmp && !defined $initiator_tempdir) {
2090 eval { rmtree $i_tmp; };
2094 END { i_cleanup(); }
2097 my ($base,$selector,@args) = @_;
2098 $selector =~ s/\-/_/g;
2099 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2106 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2113 my @rargs = ($dir,$rpushprotovsn);
2116 push @rdgit, @ropts;
2117 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2119 my @cmd = (@ssh, $host, shellquote @rdgit);
2122 if (defined $initiator_tempdir) {
2123 rmtree $initiator_tempdir;
2124 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2125 $i_tmp = $initiator_tempdir;
2129 $i_child_pid = open2(\*RO, \*RI, @cmd);
2131 initiator_expect { m/^dgit-remote-push-ready/ };
2133 my ($icmd,$iargs) = initiator_expect {
2134 m/^(\S+)(?: (.*))?$/;
2137 i_method "i_resp", $icmd, $iargs;
2141 sub i_resp_progress ($) {
2143 my $msg = protocol_read_bytes \*RO, $rhs;
2147 sub i_resp_complete {
2148 my $pid = $i_child_pid;
2149 $i_child_pid = undef; # prevents killing some other process with same pid
2150 printdebug "waiting for build host child $pid...\n";
2151 my $got = waitpid $pid, 0;
2152 die $! unless $got == $pid;
2153 die "build host child failed $?" if $?;
2156 printdebug "all done\n";
2160 sub i_resp_file ($) {
2162 my $localname = i_method "i_localname", $keyword;
2163 my $localpath = "$i_tmp/$localname";
2164 stat_exists $localpath and
2165 badproto \*RO, "file $keyword ($localpath) twice";
2166 protocol_receive_file \*RO, $localpath;
2167 i_method "i_file", $keyword;
2172 sub i_resp_param ($) {
2173 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2177 sub i_resp_previously ($) {
2178 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2179 or badproto \*RO, "bad previously spec";
2180 my $r = system qw(git check-ref-format), $1;
2181 die "bad previously ref spec ($r)" if $r;
2182 $previously{$1} = $2;
2187 sub i_resp_want ($) {
2189 die "$keyword ?" if $i_wanted{$keyword}++;
2190 my @localpaths = i_method "i_want", $keyword;
2191 printdebug "[[ $keyword @localpaths\n";
2192 foreach my $localpath (@localpaths) {
2193 protocol_send_file \*RI, $localpath;
2195 print RI "files-end\n" or die $!;
2198 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2200 sub i_localname_parsed_changelog {
2201 return "remote-changelog.822";
2203 sub i_file_parsed_changelog {
2204 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2205 push_parse_changelog "$i_tmp/remote-changelog.822";
2206 die if $i_dscfn =~ m#/|^\W#;
2209 sub i_localname_dsc {
2210 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2215 sub i_localname_changes {
2216 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2217 $i_changesfn = $i_dscfn;
2218 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2219 return $i_changesfn;
2221 sub i_file_changes { }
2223 sub i_want_signed_tag {
2224 printdebug Dumper(\%i_param, $i_dscfn);
2225 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2226 && defined $i_param{'csuite'}
2227 or badproto \*RO, "premature desire for signed-tag";
2228 my $head = $i_param{'head'};
2229 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2231 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2233 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2236 push_mktag $head, $i_clogp, $i_tag,
2238 $i_changesfn, 'remote changes',
2239 sub { "tag$_[0]"; };
2244 sub i_want_signed_dsc_changes {
2245 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2246 sign_changes $i_changesfn;
2247 return ($i_dscfn, $i_changesfn);
2250 #---------- building etc. ----------
2256 #----- `3.0 (quilt)' handling -----
2258 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2260 sub quiltify_dpkg_commit ($$$;$) {
2261 my ($patchname,$author,$msg, $xinfo) = @_;
2265 my $descfn = ".git/dgit/quilt-description.tmp";
2266 open O, '>', $descfn or die "$descfn: $!";
2269 $msg =~ s/^\s+$/ ./mg;
2270 print O <<END or die $!;
2280 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2281 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2282 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2283 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2287 sub quiltify_trees_differ ($$) {
2289 # returns 1 iff the two tree objects differ other than in debian/
2291 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2292 my $diffs= cmdoutput @cmd;
2293 foreach my $f (split /\0/, $diffs) {
2294 next if $f eq 'debian';
2300 sub quiltify_tree_sentinelfiles ($) {
2301 # lists the `sentinel' files present in the tree
2303 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2304 qw(-- debian/rules debian/control);
2310 my ($clogp,$target) = @_;
2312 # Quilt patchification algorithm
2314 # We search backwards through the history of the main tree's HEAD
2315 # (T) looking for a start commit S whose tree object is identical
2316 # to to the patch tip tree (ie the tree corresponding to the
2317 # current dpkg-committed patch series). For these purposes
2318 # `identical' disregards anything in debian/ - this wrinkle is
2319 # necessary because dpkg-source treates debian/ specially.
2321 # We can only traverse edges where at most one of the ancestors'
2322 # trees differs (in changes outside in debian/). And we cannot
2323 # handle edges which change .pc/ or debian/patches. To avoid
2324 # going down a rathole we avoid traversing edges which introduce
2325 # debian/rules or debian/control. And we set a limit on the
2326 # number of edges we are willing to look at.
2328 # If we succeed, we walk forwards again. For each traversed edge
2329 # PC (with P parent, C child) (starting with P=S and ending with
2330 # C=T) to we do this:
2332 # - dpkg-source --commit with a patch name and message derived from C
2333 # After traversing PT, we git commit the changes which
2334 # should be contained within debian/patches.
2336 changedir '../fake';
2337 mktree_in_ud_here();
2339 runcmd @git, 'add', '.';
2340 my $oldtiptree=git_write_tree();
2341 changedir '../work';
2343 # The search for the path S..T is breadth-first. We maintain a
2344 # todo list containing search nodes. A search node identifies a
2345 # commit, and looks something like this:
2347 # Commit => $git_commit_id,
2348 # Child => $c, # or undef if P=T
2349 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2350 # Nontrivial => true iff $p..$c has relevant changes
2357 my %considered; # saves being exponential on some weird graphs
2359 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2362 my ($search,$whynot) = @_;
2363 printdebug " search NOT $search->{Commit} $whynot\n";
2364 $search->{Whynot} = $whynot;
2365 push @nots, $search;
2366 no warnings qw(exiting);
2375 my $c = shift @todo;
2376 next if $considered{$c->{Commit}}++;
2378 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2380 printdebug "quiltify investigate $c->{Commit}\n";
2383 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2384 printdebug " search finished hooray!\n";
2389 if ($quilt_mode eq 'nofix') {
2390 fail "quilt fixup required but quilt mode is \`nofix'\n".
2391 "HEAD commit $c->{Commit} differs from tree implied by ".
2392 " debian/patches (tree object $oldtiptree)";
2394 if ($quilt_mode eq 'smash') {
2395 printdebug " search quitting smash\n";
2399 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2400 $not->($c, "has $c_sentinels not $t_sentinels")
2401 if $c_sentinels ne $t_sentinels;
2403 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2404 $commitdata =~ m/\n\n/;
2406 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2407 @parents = map { { Commit => $_, Child => $c } } @parents;
2409 $not->($c, "root commit") if !@parents;
2411 foreach my $p (@parents) {
2412 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2414 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2415 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2417 foreach my $p (@parents) {
2418 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2420 my @cmd= (@git, qw(diff-tree -r --name-only),
2421 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2422 my $patchstackchange = cmdoutput @cmd;
2423 if (length $patchstackchange) {
2424 $patchstackchange =~ s/\n/,/g;
2425 $not->($p, "changed $patchstackchange");
2428 printdebug " search queue P=$p->{Commit} ",
2429 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2435 printdebug "quiltify want to smash\n";
2438 my $x = $_[0]{Commit};
2439 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2442 my $reportnot = sub {
2444 my $s = $abbrev->($notp);
2445 my $c = $notp->{Child};
2446 $s .= "..".$abbrev->($c) if $c;
2447 $s .= ": ".$notp->{Whynot};
2450 if ($quilt_mode eq 'linear') {
2451 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2452 foreach my $notp (@nots) {
2453 print STDERR "$us: ", $reportnot->($notp), "\n";
2455 fail "quilt fixup naive history linearisation failed.\n".
2456 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2457 } elsif ($quilt_mode eq 'smash') {
2458 } elsif ($quilt_mode eq 'auto') {
2459 progress "quilt fixup cannot be linear, smashing...";
2461 die "$quilt_mode ?";
2466 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2468 quiltify_dpkg_commit "auto-$version-$target-$time",
2469 (getfield $clogp, 'Maintainer'),
2470 "Automatically generated patch ($clogp->{Version})\n".
2471 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2475 progress "quiltify linearisation planning successful, executing...";
2477 for (my $p = $sref_S;
2478 my $c = $p->{Child};
2480 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2481 next unless $p->{Nontrivial};
2483 my $cc = $c->{Commit};
2485 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2486 $commitdata =~ m/\n\n/ or die "$c ?";
2489 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2492 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2495 my $patchname = $title;
2496 $patchname =~ s/[.:]$//;
2497 $patchname =~ y/ A-Z/-a-z/;
2498 $patchname =~ y/-a-z0-9_.+=~//cd;
2499 $patchname =~ s/^\W/x-$&/;
2500 $patchname = substr($patchname,0,40);
2503 stat "debian/patches/$patchname$index";
2505 $!==ENOENT or die "$patchname$index $!";
2507 runcmd @git, qw(checkout -q), $cc;
2509 # We use the tip's changelog so that dpkg-source doesn't
2510 # produce complaining messages from dpkg-parsechangelog. None
2511 # of the information dpkg-source gets from the changelog is
2512 # actually relevant - it gets put into the original message
2513 # which dpkg-source provides our stunt editor, and then
2515 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2517 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2518 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2520 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2523 runcmd @git, qw(checkout -q master);
2526 sub build_maybe_quilt_fixup () {
2527 my $format=get_source_format;
2528 return unless madformat $format;
2531 check_for_vendor_patches();
2534 # - honour any existing .pc in case it has any strangeness
2535 # - determine the git commit corresponding to the tip of
2536 # the patch stack (if there is one)
2537 # - if there is such a git commit, convert each subsequent
2538 # git commit into a quilt patch with dpkg-source --commit
2539 # - otherwise convert all the differences in the tree into
2540 # a single git commit
2544 # Our git tree doesn't necessarily contain .pc. (Some versions of
2545 # dgit would include the .pc in the git tree.) If there isn't
2546 # one, we need to generate one by unpacking the patches that we
2549 # We first look for a .pc in the git tree. If there is one, we
2550 # will use it. (This is not the normal case.)
2552 # Otherwise need to regenerate .pc so that dpkg-source --commit
2553 # can work. We do this as follows:
2554 # 1. Collect all relevant .orig from parent directory
2555 # 2. Generate a debian.tar.gz out of
2556 # debian/{patches,rules,source/format}
2557 # 3. Generate a fake .dsc containing just these fields:
2558 # Format Source Version Files
2559 # 4. Extract the fake .dsc
2560 # Now the fake .dsc has a .pc directory.
2561 # (In fact we do this in every case, because in future we will
2562 # want to search for a good base commit for generating patches.)
2564 # Then we can actually do the dpkg-source --commit
2565 # 1. Make a new working tree with the same object
2566 # store as our main tree and check out the main
2568 # 2. Copy .pc from the fake's extraction, if necessary
2569 # 3. Run dpkg-source --commit
2570 # 4. If the result has changes to debian/, then
2571 # - git-add them them
2572 # - git-add .pc if we had a .pc in-tree
2574 # 5. If we had a .pc in-tree, delete it, and git-commit
2575 # 6. Back in the main tree, fast forward to the new HEAD
2577 my $clogp = parsechangelog();
2578 my $headref = git_rev_parse('HEAD');
2583 my $upstreamversion=$version;
2584 $upstreamversion =~ s/-[^-]*$//;
2586 my $fakeversion="$upstreamversion-~~DGITFAKE";
2588 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2589 print $fakedsc <<END or die $!;
2592 Version: $fakeversion
2596 my $dscaddfile=sub {
2599 my $md = new Digest::MD5;
2601 my $fh = new IO::File $b, '<' or die "$b $!";
2606 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2609 foreach my $f (<../../../../*>) { #/){
2610 my $b=$f; $b =~ s{.*/}{};
2611 next unless is_orig_file $b, srcfn $upstreamversion,'';
2612 link $f, $b or die "$b $!";
2616 my @files=qw(debian/source/format debian/rules);
2617 if (stat_exists '../../../debian/patches') {
2618 push @files, 'debian/patches';
2621 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2622 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2624 $dscaddfile->($debtar);
2625 close $fakedsc or die $!;
2627 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2629 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2630 rename $fakexdir, "fake" or die "$fakexdir $!";
2632 mkdir "work" or die $!;
2634 mktree_in_ud_here();
2635 runcmd @git, qw(reset --hard), $headref;
2638 if (stat_exists ".pc") {
2640 progress "Tree already contains .pc - will use it then delete it.";
2643 rename '../fake/.pc','.pc' or die $!;
2646 quiltify($clogp,$headref);
2648 if (!open P, '>>', ".pc/applied-patches") {
2649 $!==&ENOENT or die $!;
2654 commit_quilty_patch();
2656 if ($mustdeletepc) {
2657 runcmd @git, qw(rm -rqf .pc);
2658 commit_admin "Commit removal of .pc (quilt series tracking data)";
2661 changedir '../../../..';
2662 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2665 sub quilt_fixup_editor () {
2666 my $descfn = $ENV{$fakeeditorenv};
2667 my $editing = $ARGV[$#ARGV];
2668 open I1, '<', $descfn or die "$descfn: $!";
2669 open I2, '<', $editing or die "$editing: $!";
2670 unlink $editing or die "$editing: $!";
2671 open O, '>', $editing or die "$editing: $!";
2672 while (<I1>) { print O or die $!; } I1->error and die $!;
2675 $copying ||= m/^\-\-\- /;
2676 next unless $copying;
2679 I2->error and die $!;
2684 #----- other building -----
2687 if ($cleanmode eq 'dpkg-source') {
2688 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2689 } elsif ($cleanmode eq 'dpkg-source-d') {
2690 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2691 } elsif ($cleanmode eq 'git') {
2692 runcmd_ordryrun_local @git, qw(clean -xdf);
2693 } elsif ($cleanmode eq 'git-ff') {
2694 runcmd_ordryrun_local @git, qw(clean -xdff);
2695 } elsif ($cleanmode eq 'check') {
2696 my $leftovers = cmdoutput @git, qw(clean -xdn);
2697 if (length $leftovers) {
2698 print STDERR $leftovers, "\n" or die $!;
2699 fail "tree contains uncommitted files and --clean=check specified";
2701 } elsif ($cleanmode eq 'none') {
2708 badusage "clean takes no additional arguments" if @ARGV;
2713 badusage "-p is not allowed when building" if defined $package;
2716 my $clogp = parsechangelog();
2717 $isuite = getfield $clogp, 'Distribution';
2718 $package = getfield $clogp, 'Source';
2719 $version = getfield $clogp, 'Version';
2720 build_maybe_quilt_fixup();
2723 sub changesopts () {
2724 my @opts =@changesopts[1..$#changesopts];
2725 if (!defined $changes_since_version) {
2726 my @vsns = archive_query('archive_query');
2727 my @quirk = access_quirk();
2728 if ($quirk[0] eq 'backports') {
2729 local $isuite = $quirk[2];
2731 canonicalise_suite();
2732 push @vsns, archive_query('archive_query');
2735 @vsns = map { $_->[0] } @vsns;
2736 @vsns = sort { -version_compare($a, $b) } @vsns;
2737 $changes_since_version = $vsns[0];
2738 progress "changelog will contain changes since $vsns[0]";
2740 $changes_since_version = '_';
2741 progress "package seems new, not specifying -v<version>";
2744 if ($changes_since_version ne '_') {
2745 unshift @opts, "-v$changes_since_version";
2750 sub massage_dbp_args ($) {
2752 return unless $cleanmode =~ m/git|none/;
2753 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2754 my @newcmd = shift @$cmd;
2755 # -nc has the side effect of specifying -b if nothing else specified
2756 push @newcmd, '-nc';
2757 # and some combinations of -S, -b, et al, are errors, rather than
2758 # later simply overriding earlier
2759 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2760 push @newcmd, @$cmd;
2766 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2767 massage_dbp_args \@dbp;
2768 runcmd_ordryrun_local @dbp;
2769 printdone "build successful\n";
2774 my @dbp = @dpkgbuildpackage;
2775 massage_dbp_args \@dbp;
2777 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2778 "--git-builder=@dbp");
2779 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2780 canonicalise_suite();
2781 push @cmd, "--git-debian-branch=".lbranch();
2783 push @cmd, changesopts();
2784 runcmd_ordryrun_local @cmd, @ARGV;
2785 printdone "build successful\n";
2790 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2791 $dscfn = dscfn($version);
2792 if ($cleanmode eq 'dpkg-source') {
2793 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2795 } elsif ($cleanmode eq 'dpkg-source-d') {
2796 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2799 my $pwd = must_getcwd();
2800 my $leafdir = basename $pwd;
2802 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2804 runcmd_ordryrun_local qw(sh -ec),
2805 'exec >$1; shift; exec "$@"','x',
2806 "../$sourcechanges",
2807 @dpkggenchanges, qw(-S), changesopts();
2811 sub cmd_build_source {
2812 badusage "build-source takes no additional arguments" if @ARGV;
2814 printdone "source built, results in $dscfn and $sourcechanges";
2820 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2822 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2823 stat_exists $sourcechanges
2824 or fail "$sourcechanges (in parent directory): $!";
2825 foreach my $cf (glob $pat) {
2826 next if $cf eq $sourcechanges;
2827 unlink $cf or fail "remove $cf: $!";
2830 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2831 my @changesfiles = glob $pat;
2832 @changesfiles = sort {
2833 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2836 fail "wrong number of different changes files (@changesfiles)"
2837 unless @changesfiles;
2838 runcmd_ordryrun_local @mergechanges, @changesfiles;
2839 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2841 stat_exists $multichanges or fail "$multichanges: $!";
2843 printdone "build successful, results in $multichanges\n" or die $!;
2846 sub cmd_quilt_fixup {
2847 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2848 my $clogp = parsechangelog();
2849 $version = getfield $clogp, 'Version';
2850 $package = getfield $clogp, 'Source';
2851 build_maybe_quilt_fixup();
2854 sub cmd_archive_api_query {
2855 badusage "need only 1 subpath argument" unless @ARGV==1;
2856 my ($subpath) = @ARGV;
2857 my @cmd = archive_api_query_cmd($subpath);
2859 exec @cmd or fail "exec curl: $!\n";
2862 sub cmd_clone_dgit_repos_server {
2863 badusage "need destination argument" unless @ARGV==1;
2864 my ($destdir) = @ARGV;
2865 $package = '_dgit-repos-server';
2866 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2868 exec @cmd or fail "exec git clone: $!\n";
2871 sub cmd_setup_mergechangelogs {
2872 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2873 setup_mergechangelogs();
2876 #---------- argument parsing and main program ----------
2879 print "dgit version $our_version\n" or die $!;
2886 if (defined $ENV{'DGIT_SSH'}) {
2887 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2888 } elsif (defined $ENV{'GIT_SSH'}) {
2889 @ssh = ($ENV{'GIT_SSH'});
2893 last unless $ARGV[0] =~ m/^-/;
2897 if (m/^--dry-run$/) {
2900 } elsif (m/^--damp-run$/) {
2903 } elsif (m/^--no-sign$/) {
2906 } elsif (m/^--help$/) {
2908 } elsif (m/^--version$/) {
2910 } elsif (m/^--new$/) {
2913 } elsif (m/^--since-version=([^_]+|_)$/) {
2915 $changes_since_version = $1;
2916 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2917 ($om = $opts_opt_map{$1}) &&
2921 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2922 !$opts_opt_cmdonly{$1} &&
2923 ($om = $opts_opt_map{$1})) {
2926 } elsif (m/^--existing-package=(.*)/s) {
2928 $existing_package = $1;
2929 } elsif (m/^--initiator-tempdir=(.*)/s) {
2930 $initiator_tempdir = $1;
2931 $initiator_tempdir =~ m#^/# or
2932 badusage "--initiator-tempdir must be used specify an".
2933 " absolute, not relative, directory."
2934 } elsif (m/^--distro=(.*)/s) {
2937 } elsif (m/^--build-products-dir=(.*)/s) {
2939 $buildproductsdir = $1;
2940 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2943 } elsif (m/^--clean=(.*)$/s) {
2944 badusage "unknown cleaning mode \`$1'";
2945 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2948 } elsif (m/^--quilt=(.*)$/s) {
2949 badusage "unknown quilt fixup mode \`$1'";
2950 } elsif (m/^--ignore-dirty$/s) {
2953 } elsif (m/^--no-quilt-fixup$/s) {
2955 $quilt_mode = 'nocheck';
2956 } elsif (m/^--no-rm-on-error$/s) {
2959 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2961 push @deliberatelies, $&;
2963 badusage "unknown long option \`$_'";
2970 } elsif (s/^-L/-/) {
2973 } elsif (s/^-h/-/) {
2975 } elsif (s/^-D/-/) {
2979 } elsif (s/^-N/-/) {
2982 } elsif (s/^-v([^_]+|_)$//s) {
2984 $changes_since_version = $1;
2987 push @changesopts, $_;
2989 } elsif (s/^-c(.*=.*)//s) {
2991 push @git, '-c', $1;
2992 } elsif (s/^-d(.+)//s) {
2995 } elsif (s/^-C(.+)//s) {
2998 if ($changesfile =~ s#^(.*)/##) {
2999 $buildproductsdir = $1;
3001 } elsif (s/^-k(.+)//s) {
3003 } elsif (m/^-[vdCk]$/) {
3005 "option \`$_' requires an argument (and no space before the argument)";
3006 } elsif (s/^-wn$//s) {
3008 $cleanmode = 'none';
3009 } elsif (s/^-wg$//s) {
3012 } elsif (s/^-wgf$//s) {
3014 $cleanmode = 'git-ff';
3015 } elsif (s/^-wd$//s) {
3017 $cleanmode = 'dpkg-source';
3018 } elsif (s/^-wdd$//s) {
3020 $cleanmode = 'dpkg-source-d';
3021 } elsif (s/^-wc$//s) {
3023 $cleanmode = 'check';
3025 badusage "unknown short option \`$_'";
3032 if ($ENV{$fakeeditorenv}) {
3033 quilt_fixup_editor();
3037 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3038 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3039 if $dryrun_level == 1;
3041 print STDERR $helpmsg or die $!;
3044 my $cmd = shift @ARGV;
3047 if (!defined $quilt_mode) {
3048 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3049 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3051 $quilt_mode =~ m/^($quilt_modes_re)$/
3052 or badcfg "unknown quilt-mode \`$quilt_mode'";
3056 my $fn = ${*::}{"cmd_$cmd"};
3057 $fn or badusage "unknown operation $cmd";