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.git-url' => 'https://git.dgit.debian.org',
467 'dgit-distro.debian.git-url-suffix' => '',
468 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
469 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
470 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
471 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
472 'dgit-distro.ubuntu.git-check' => 'false',
473 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
474 'dgit-distro.test-dummy.ssh' => "$td/ssh",
475 'dgit-distro.test-dummy.username' => "alice",
476 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
477 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
478 'dgit-distro.test-dummy.git-url' => "$td/git",
479 'dgit-distro.test-dummy.git-host' => "git",
480 'dgit-distro.test-dummy.git-path' => "$td/git",
481 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
482 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
483 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
484 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
487 sub git_get_config ($) {
490 our %git_get_config_memo;
491 if (exists $git_get_config_memo{$c}) {
492 return $git_get_config_memo{$c};
496 my @cmd = (@git, qw(config --), $c);
498 local ($debuglevel) = $debuglevel-2;
499 $v = cmdoutput_errok @cmd;
507 $git_get_config_memo{$c} = $v;
513 return undef if $c =~ /RETURN-UNDEF/;
514 my $v = git_get_config($c);
515 return $v if defined $v;
516 my $dv = $defcfg{$c};
517 return $dv if defined $dv;
519 badcfg "need value for one of: @_\n".
520 "$us: distro or suite appears not to be (properly) supported";
523 sub access_basedistro () {
524 if (defined $idistro) {
527 return cfg("dgit-suite.$isuite.distro",
528 "dgit.default.distro");
532 sub access_quirk () {
533 # returns (quirk name, distro to use instead or undef, quirk-specific info)
534 my $basedistro = access_basedistro();
535 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
537 if (defined $backports_quirk) {
538 my $re = $backports_quirk;
539 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
541 $re =~ s/\%/([-0-9a-z_]+)/
542 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
543 if ($isuite =~ m/^$re$/) {
544 return ('backports',"$basedistro-backports",$1);
547 return ('none',undef);
550 our $access_pushing = 0;
556 sub access_distros () {
557 # Returns list of distros to try, in order
560 # 0. `instead of' distro name(s) we have been pointed to
561 # 1. the access_quirk distro, if any
562 # 2a. the user's specified distro, or failing that } basedistro
563 # 2b. the distro calculated from the suite }
564 my @l = access_basedistro();
566 my (undef,$quirkdistro) = access_quirk();
567 unshift @l, $quirkdistro;
568 unshift @l, $instead_distro;
569 @l = grep { defined } @l;
571 if ($access_pushing) {
572 @l = map { ("$_/push", $_) } @l;
580 # The nesting of these loops determines the search order. We put
581 # the key loop on the outside so that we search all the distros
582 # for each key, before going on to the next key. That means that
583 # if access_cfg is called with a more specific, and then a less
584 # specific, key, an earlier distro can override the less specific
585 # without necessarily overriding any more specific keys. (If the
586 # distro wants to override the more specific keys it can simply do
587 # so; whereas if we did the loop the other way around, it would be
588 # impossible to for an earlier distro to override a less specific
589 # key but not the more specific ones without restating the unknown
590 # values of the more specific keys.
593 # We have to deal with RETURN-UNDEF specially, so that we don't
594 # terminate the search prematurely.
596 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
599 foreach my $d (access_distros()) {
600 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
602 push @cfgs, map { "dgit.default.$_" } @realkeys;
604 my $value = cfg(@cfgs);
608 sub string_to_ssh ($) {
610 if ($spec =~ m/\s/) {
611 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
617 sub access_cfg_ssh () {
618 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
619 if (!defined $gitssh) {
622 return string_to_ssh $gitssh;
626 sub access_runeinfo ($) {
628 return ": dgit ".access_basedistro()." $info ;";
631 sub access_someuserhost ($) {
633 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
634 defined($user) && length($user) or
635 $user = access_cfg("$some-user",'username');
636 my $host = access_cfg("$some-host");
637 return length($user) ? "$user\@$host" : $host;
640 sub access_gituserhost () {
641 return access_someuserhost('git');
644 sub access_giturl (;$) {
646 my $url = access_cfg('git-url','RETURN-UNDEF');
649 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
650 return undef unless defined $proto;
653 access_gituserhost().
654 access_cfg('git-path');
656 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
659 return "$url/$package$suffix";
662 sub parsecontrolfh ($$;$) {
663 my ($fh, $desc, $allowsigned) = @_;
664 our $dpkgcontrolhash_noissigned;
667 my %opts = ('name' => $desc);
668 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
669 $c = Dpkg::Control::Hash->new(%opts);
670 $c->parse($fh,$desc) or die "parsing of $desc failed";
671 last if $allowsigned;
672 last if $dpkgcontrolhash_noissigned;
673 my $issigned= $c->get_option('is_pgp_signed');
674 if (!defined $issigned) {
675 $dpkgcontrolhash_noissigned= 1;
676 seek $fh, 0,0 or die "seek $desc: $!";
677 } elsif ($issigned) {
678 fail "control file $desc is (already) PGP-signed. ".
679 " Note that dgit push needs to modify the .dsc and then".
680 " do the signature itself";
689 my ($file, $desc) = @_;
690 my $fh = new IO::Handle;
691 open $fh, '<', $file or die "$file: $!";
692 my $c = parsecontrolfh($fh,$desc);
693 $fh->error and die $!;
699 my ($dctrl,$field) = @_;
700 my $v = $dctrl->{$field};
701 return $v if defined $v;
702 fail "missing field $field in ".$v->get_option('name');
706 my $c = Dpkg::Control::Hash->new();
707 my $p = new IO::Handle;
708 my @cmd = (qw(dpkg-parsechangelog), @_);
709 open $p, '-|', @cmd or die $!;
711 $?=0; $!=0; close $p or failedcmd @cmd;
717 defined $d or fail "getcwd failed: $!";
723 sub archive_query ($) {
725 my $query = access_cfg('archive-query','RETURN-UNDEF');
726 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
729 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
732 sub pool_dsc_subpath ($$) {
733 my ($vsn,$component) = @_; # $package is implict arg
734 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
735 return "/pool/$component/$prefix/$package/".dscfn($vsn);
738 #---------- `ftpmasterapi' archive query method (nascent) ----------
740 sub archive_api_query_cmd ($) {
742 my @cmd = qw(curl -sS);
743 my $url = access_cfg('archive-query-url');
744 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
746 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
747 foreach my $key (split /\:/, $keys) {
748 $key =~ s/\%HOST\%/$host/g;
750 fail "for $url: stat $key: $!" unless $!==ENOENT;
753 fail "config requested specific TLS key but do not know".
754 " how to get curl to use exactly that EE key ($key)";
755 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
756 # # Sadly the above line does not work because of changes
757 # # to gnutls. The real fix for #790093 may involve
758 # # new curl options.
761 # Fixing #790093 properly will involve providing a value
762 # for this on clients.
763 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
764 push @cmd, split / /, $kargs if defined $kargs;
766 push @cmd, $url.$subpath;
772 my ($data, $subpath) = @_;
773 badcfg "ftpmasterapi archive query method takes no data part"
775 my @cmd = archive_api_query_cmd($subpath);
776 my $json = cmdoutput @cmd;
777 return decode_json($json);
780 sub canonicalise_suite_ftpmasterapi () {
781 my ($proto,$data) = @_;
782 my $suites = api_query($data, 'suites');
784 foreach my $entry (@$suites) {
786 my $v = $entry->{$_};
787 defined $v && $v eq $isuite;
789 push @matched, $entry;
791 fail "unknown suite $isuite" unless @matched;
794 @matched==1 or die "multiple matches for suite $isuite\n";
795 $cn = "$matched[0]{codename}";
796 defined $cn or die "suite $isuite info has no codename\n";
797 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
799 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
804 sub archive_query_ftpmasterapi () {
805 my ($proto,$data) = @_;
806 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
808 my $digester = Digest::SHA->new(256);
809 foreach my $entry (@$info) {
811 my $vsn = "$entry->{version}";
812 my ($ok,$msg) = version_check $vsn;
813 die "bad version: $msg\n" unless $ok;
814 my $component = "$entry->{component}";
815 $component =~ m/^$component_re$/ or die "bad component";
816 my $filename = "$entry->{filename}";
817 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
818 or die "bad filename";
819 my $sha256sum = "$entry->{sha256sum}";
820 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
821 push @rows, [ $vsn, "/pool/$component/$filename",
822 $digester, $sha256sum ];
824 die "bad ftpmaster api response: $@\n".Dumper($entry)
827 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
831 #---------- `madison' archive query method ----------
833 sub archive_query_madison {
834 return map { [ @$_[0..1] ] } madison_get_parse(@_);
837 sub madison_get_parse {
838 my ($proto,$data) = @_;
839 die unless $proto eq 'madison';
841 $data= access_cfg('madison-distro','RETURN-UNDEF');
842 $data //= access_basedistro();
844 $rmad{$proto,$data,$package} ||= cmdoutput
845 qw(rmadison -asource),"-s$isuite","-u$data",$package;
846 my $rmad = $rmad{$proto,$data,$package};
849 foreach my $l (split /\n/, $rmad) {
850 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
851 \s*( [^ \t|]+ )\s* \|
852 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
853 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
854 $1 eq $package or die "$rmad $package ?";
861 $component = access_cfg('archive-query-default-component');
863 $5 eq 'source' or die "$rmad ?";
864 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
866 return sort { -version_compare($a->[0],$b->[0]); } @out;
869 sub canonicalise_suite_madison {
870 # madison canonicalises for us
871 my @r = madison_get_parse(@_);
873 "unable to canonicalise suite using package $package".
874 " which does not appear to exist in suite $isuite;".
875 " --existing-package may help";
879 #---------- `sshpsql' archive query method ----------
882 my ($data,$runeinfo,$sql) = @_;
884 $data= access_someuserhost('sshpsql').':'.
885 access_cfg('sshpsql-dbname');
887 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
888 my ($userhost,$dbname) = ($`,$'); #';
890 my @cmd = (access_cfg_ssh, $userhost,
891 access_runeinfo("ssh-psql $runeinfo").
892 " export LC_MESSAGES=C; export LC_CTYPE=C;".
893 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
895 open P, "-|", @cmd or die $!;
898 printdebug("$debugprefix>|$_|\n");
901 $!=0; $?=0; close P or failedcmd @cmd;
903 my $nrows = pop @rows;
904 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
905 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
906 @rows = map { [ split /\|/, $_ ] } @rows;
907 my $ncols = scalar @{ shift @rows };
908 die if grep { scalar @$_ != $ncols } @rows;
912 sub sql_injection_check {
913 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
916 sub archive_query_sshpsql ($$) {
917 my ($proto,$data) = @_;
918 sql_injection_check $isuite, $package;
919 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
920 SELECT source.version, component.name, files.filename, files.sha256sum
922 JOIN src_associations ON source.id = src_associations.source
923 JOIN suite ON suite.id = src_associations.suite
924 JOIN dsc_files ON dsc_files.source = source.id
925 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
926 JOIN component ON component.id = files_archive_map.component_id
927 JOIN files ON files.id = dsc_files.file
928 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
929 AND source.source='$package'
930 AND files.filename LIKE '%.dsc';
932 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
933 my $digester = Digest::SHA->new(256);
935 my ($vsn,$component,$filename,$sha256sum) = @$_;
936 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
941 sub canonicalise_suite_sshpsql ($$) {
942 my ($proto,$data) = @_;
943 sql_injection_check $isuite;
944 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
945 SELECT suite.codename
946 FROM suite where suite_name='$isuite' or codename='$isuite';
948 @rows = map { $_->[0] } @rows;
949 fail "unknown suite $isuite" unless @rows;
950 die "ambiguous $isuite: @rows ?" if @rows>1;
954 #---------- `dummycat' archive query method ----------
956 sub canonicalise_suite_dummycat ($$) {
957 my ($proto,$data) = @_;
958 my $dpath = "$data/suite.$isuite";
959 if (!open C, "<", $dpath) {
960 $!==ENOENT or die "$dpath: $!";
961 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
965 chomp or die "$dpath: $!";
967 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
971 sub archive_query_dummycat ($$) {
972 my ($proto,$data) = @_;
973 canonicalise_suite();
974 my $dpath = "$data/package.$csuite.$package";
975 if (!open C, "<", $dpath) {
976 $!==ENOENT or die "$dpath: $!";
977 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
985 printdebug "dummycat query $csuite $package $dpath | $_\n";
986 my @row = split /\s+/, $_;
987 @row==2 or die "$dpath: $_ ?";
990 C->error and die "$dpath: $!";
992 return sort { -version_compare($a->[0],$b->[0]); } @rows;
995 #---------- archive query entrypoints and rest of program ----------
997 sub canonicalise_suite () {
998 return if defined $csuite;
999 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1000 $csuite = archive_query('canonicalise_suite');
1001 if ($isuite ne $csuite) {
1002 progress "canonical suite name for $isuite is $csuite";
1006 sub get_archive_dsc () {
1007 canonicalise_suite();
1008 my @vsns = archive_query('archive_query');
1009 foreach my $vinfo (@vsns) {
1010 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1011 $dscurl = access_cfg('mirror').$subpath;
1012 $dscdata = url_get($dscurl);
1014 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1019 $digester->add($dscdata);
1020 my $got = $digester->hexdigest();
1022 fail "$dscurl has hash $got but".
1023 " archive told us to expect $digest";
1025 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1026 printdebug Dumper($dscdata) if $debuglevel>1;
1027 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1028 printdebug Dumper($dsc) if $debuglevel>1;
1029 my $fmt = getfield $dsc, 'Format';
1030 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1031 $dsc_checked = !!$digester;
1037 sub check_for_git ();
1038 sub check_for_git () {
1040 my $how = access_cfg('git-check');
1041 if ($how eq 'ssh-cmd') {
1043 (access_cfg_ssh, access_gituserhost(),
1044 access_runeinfo("git-check $package").
1045 " set -e; cd ".access_cfg('git-path').";".
1046 " if test -d $package.git; then echo 1; else echo 0; fi");
1047 my $r= cmdoutput @cmd;
1048 if ($r =~ m/^divert (\w+)$/) {
1050 my ($usedistro,) = access_distros();
1051 # NB that if we are pushing, $usedistro will be $distro/push
1052 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1053 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1054 progress "diverting to $divert (using config for $instead_distro)";
1055 return check_for_git();
1057 failedcmd @cmd unless $r =~ m/^[01]$/;
1059 } elsif ($how eq 'url') {
1060 my $prefix = access_cfg('git-check-url','git-url');
1061 my $suffix = access_cfg('git-check-suffix','git-suffix',
1062 'RETURN-UNDEF') // '.git';
1063 my $url = "$prefix/$package$suffix";
1064 my @cmd = (qw(curl -sS -I), $url);
1065 my $result = cmdoutput @cmd;
1066 $result =~ m/^\S+ (404|200) /s or
1067 fail "unexpected results from git check query - ".
1068 Dumper($prefix, $result);
1070 if ($code eq '404') {
1072 } elsif ($code eq '200') {
1077 } elsif ($how eq 'true') {
1079 } elsif ($how eq 'false') {
1082 badcfg "unknown git-check \`$how'";
1086 sub create_remote_git_repo () {
1087 my $how = access_cfg('git-create');
1088 if ($how eq 'ssh-cmd') {
1090 (access_cfg_ssh, access_gituserhost(),
1091 access_runeinfo("git-create $package").
1092 "set -e; cd ".access_cfg('git-path').";".
1093 " cp -a _template $package.git");
1094 } elsif ($how eq 'true') {
1097 badcfg "unknown git-create \`$how'";
1101 our ($dsc_hash,$lastpush_hash);
1103 our $ud = '.git/dgit/unpack';
1108 mkdir $ud or die $!;
1111 sub mktree_in_ud_here () {
1112 runcmd qw(git init -q);
1113 rmtree('.git/objects');
1114 symlink '../../../../objects','.git/objects' or die $!;
1117 sub git_write_tree () {
1118 my $tree = cmdoutput @git, qw(write-tree);
1119 $tree =~ m/^\w+$/ or die "$tree ?";
1123 sub mktree_in_ud_from_only_subdir () {
1124 # changes into the subdir
1126 die unless @dirs==1;
1127 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1130 fail "source package contains .git directory" if stat_exists '.git';
1131 mktree_in_ud_here();
1132 my $format=get_source_format();
1133 if (madformat($format)) {
1136 runcmd @git, qw(add -Af);
1137 my $tree=git_write_tree();
1138 return ($tree,$dir);
1141 sub dsc_files_info () {
1142 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1143 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1144 ['Files', 'Digest::MD5', 'new()']) {
1145 my ($fname, $module, $method) = @$csumi;
1146 my $field = $dsc->{$fname};
1147 next unless defined $field;
1148 eval "use $module; 1;" or die $@;
1150 foreach (split /\n/, $field) {
1152 m/^(\w+) (\d+) (\S+)$/ or
1153 fail "could not parse .dsc $fname line \`$_'";
1154 my $digester = eval "$module"."->$method;" or die $@;
1159 Digester => $digester,
1164 fail "missing any supported Checksums-* or Files field in ".
1165 $dsc->get_option('name');
1169 map { $_->{Filename} } dsc_files_info();
1172 sub is_orig_file ($;$) {
1175 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1176 defined $base or return 1;
1180 sub make_commit ($) {
1182 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1185 sub clogp_authline ($) {
1187 my $author = getfield $clogp, 'Maintainer';
1188 $author =~ s#,.*##ms;
1189 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1190 my $authline = "$author $date";
1191 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1192 fail "unexpected commit author line format \`$authline'".
1193 " (was generated from changelog Maintainer field)";
1197 sub vendor_patches_distro ($$) {
1198 my ($checkdistro, $what) = @_;
1199 return unless defined $checkdistro;
1201 my $series = "debian/patches/\L$checkdistro\E.series";
1202 printdebug "checking for vendor-specific $series ($what)\n";
1204 if (!open SERIES, "<", $series) {
1205 die "$series $!" unless $!==ENOENT;
1214 Unfortunately, this source package uses a feature of dpkg-source where
1215 the same source package unpacks to different source code on different
1216 distros. dgit cannot safely operate on such packages on affected
1217 distros, because the meaning of source packages is not stable.
1219 Please ask the distro/maintainer to remove the distro-specific series
1220 files and use a different technique (if necessary, uploading actually
1221 different packages, if different distros are supposed to have
1225 fail "Found active distro-specific series file for".
1226 " $checkdistro ($what): $series, cannot continue";
1228 die "$series $!" if SERIES->error;
1232 sub check_for_vendor_patches () {
1233 # This dpkg-source feature doesn't seem to be documented anywhere!
1234 # But it can be found in the changelog (reformatted):
1236 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1237 # Author: Raphael Hertzog <hertzog@debian.org>
1238 # Date: Sun Oct 3 09:36:48 2010 +0200
1240 # dpkg-source: correctly create .pc/.quilt_series with alternate
1243 # If you have debian/patches/ubuntu.series and you were
1244 # unpacking the source package on ubuntu, quilt was still
1245 # directed to debian/patches/series instead of
1246 # debian/patches/ubuntu.series.
1248 # debian/changelog | 3 +++
1249 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1250 # 2 files changed, 6 insertions(+), 1 deletion(-)
1253 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1254 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1255 "Dpkg::Vendor \`current vendor'");
1256 vendor_patches_distro(access_basedistro(),
1257 "distro being accessed");
1260 sub generate_commit_from_dsc () {
1264 foreach my $fi (dsc_files_info()) {
1265 my $f = $fi->{Filename};
1266 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1268 link "../../../$f", $f
1272 complete_file_from_dsc('.', $fi);
1274 if (is_orig_file($f)) {
1275 link $f, "../../../../$f"
1281 my $dscfn = "$package.dsc";
1283 open D, ">", $dscfn or die "$dscfn: $!";
1284 print D $dscdata or die "$dscfn: $!";
1285 close D or die "$dscfn: $!";
1286 my @cmd = qw(dpkg-source);
1287 push @cmd, '--no-check' if $dsc_checked;
1288 push @cmd, qw(-x --), $dscfn;
1291 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1292 check_for_vendor_patches() if madformat($dsc->{format});
1293 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1294 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1295 my $authline = clogp_authline $clogp;
1296 my $changes = getfield $clogp, 'Changes';
1297 open C, ">../commit.tmp" or die $!;
1298 print C <<END or die $!;
1305 # imported from the archive
1308 my $outputhash = make_commit qw(../commit.tmp);
1309 my $cversion = getfield $clogp, 'Version';
1310 progress "synthesised git commit from .dsc $cversion";
1311 if ($lastpush_hash) {
1312 runcmd @git, qw(reset --hard), $lastpush_hash;
1313 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1314 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1315 my $oversion = getfield $oldclogp, 'Version';
1317 version_compare($oversion, $cversion);
1319 # git upload/ is earlier vsn than archive, use archive
1320 open C, ">../commit2.tmp" or die $!;
1321 print C <<END or die $!;
1323 parent $lastpush_hash
1328 Record $package ($cversion) in archive suite $csuite
1330 $outputhash = make_commit qw(../commit2.tmp);
1331 } elsif ($vcmp > 0) {
1332 print STDERR <<END or die $!;
1334 Version actually in archive: $cversion (older)
1335 Last allegedly pushed/uploaded: $oversion (newer or same)
1338 $outputhash = $lastpush_hash;
1340 $outputhash = $lastpush_hash;
1343 changedir '../../../..';
1344 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1345 'DGIT_ARCHIVE', $outputhash;
1346 cmdoutput @git, qw(log -n2), $outputhash;
1347 # ... gives git a chance to complain if our commit is malformed
1352 sub complete_file_from_dsc ($$) {
1353 our ($dstdir, $fi) = @_;
1354 # Ensures that we have, in $dir, the file $fi, with the correct
1355 # contents. (Downloading it from alongside $dscurl if necessary.)
1357 my $f = $fi->{Filename};
1358 my $tf = "$dstdir/$f";
1361 if (stat_exists $tf) {
1362 progress "using existing $f";
1365 $furl =~ s{/[^/]+$}{};
1367 die "$f ?" unless $f =~ m/^${package}_/;
1368 die "$f ?" if $f =~ m#/#;
1369 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1370 next if !act_local();
1374 open F, "<", "$tf" or die "$tf: $!";
1375 $fi->{Digester}->reset();
1376 $fi->{Digester}->addfile(*F);
1377 F->error and die $!;
1378 my $got = $fi->{Digester}->hexdigest();
1379 $got eq $fi->{Hash} or
1380 fail "file $f has hash $got but .dsc".
1381 " demands hash $fi->{Hash} ".
1382 ($downloaded ? "(got wrong file from archive!)"
1383 : "(perhaps you should delete this file?)");
1386 sub ensure_we_have_orig () {
1387 foreach my $fi (dsc_files_info()) {
1388 my $f = $fi->{Filename};
1389 next unless is_orig_file($f);
1390 complete_file_from_dsc('..', $fi);
1394 sub git_fetch_us () {
1395 my @specs = (fetchspec());
1397 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1399 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1402 my $tagpat = debiantag('*',access_basedistro);
1404 git_for_each_ref("refs/tags/".$tagpat, sub {
1405 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1406 printdebug "currently $fullrefname=$objid\n";
1407 $here{$fullrefname} = $objid;
1409 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1410 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1411 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1412 printdebug "offered $lref=$objid\n";
1413 if (!defined $here{$lref}) {
1414 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1415 runcmd_ordryrun_local @upd;
1416 } elsif ($here{$lref} eq $objid) {
1419 "Not updateting $lref from $here{$lref} to $objid.\n";
1424 sub fetch_from_archive () {
1425 # ensures that lrref() is what is actually in the archive,
1426 # one way or another
1430 foreach my $field (@ourdscfield) {
1431 $dsc_hash = $dsc->{$field};
1432 last if defined $dsc_hash;
1434 if (defined $dsc_hash) {
1435 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1437 progress "last upload to archive specified git hash";
1439 progress "last upload to archive has NO git hash";
1442 progress "no version available from the archive";
1445 $lastpush_hash = git_get_ref(lrref());
1446 printdebug "previous reference hash=$lastpush_hash\n";
1448 if (defined $dsc_hash) {
1449 fail "missing remote git history even though dsc has hash -".
1450 " could not find ref ".lrref().
1451 " (should have been fetched from ".access_giturl()."#".rrref().")"
1452 unless $lastpush_hash;
1454 ensure_we_have_orig();
1455 if ($dsc_hash eq $lastpush_hash) {
1456 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1457 print STDERR <<END or die $!;
1459 Git commit in archive is behind the last version allegedly pushed/uploaded.
1460 Commit referred to by archive: $dsc_hash
1461 Last allegedly pushed/uploaded: $lastpush_hash
1464 $hash = $lastpush_hash;
1466 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1467 "descendant of archive's .dsc hash ($dsc_hash)";
1470 $hash = generate_commit_from_dsc();
1471 } elsif ($lastpush_hash) {
1472 # only in git, not in the archive yet
1473 $hash = $lastpush_hash;
1474 print STDERR <<END or die $!;
1476 Package not found in the archive, but has allegedly been pushed using dgit.
1480 printdebug "nothing found!\n";
1481 if (defined $skew_warning_vsn) {
1482 print STDERR <<END or die $!;
1484 Warning: relevant archive skew detected.
1485 Archive allegedly contains $skew_warning_vsn
1486 But we were not able to obtain any version from the archive or git.
1492 printdebug "current hash=$hash\n";
1493 if ($lastpush_hash) {
1494 fail "not fast forward on last upload branch!".
1495 " (archive's version left in DGIT_ARCHIVE)"
1496 unless is_fast_fwd($lastpush_hash, $hash);
1498 if (defined $skew_warning_vsn) {
1500 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1501 my $clogf = ".git/dgit/changelog.tmp";
1502 runcmd shell_cmd "exec >$clogf",
1503 @git, qw(cat-file blob), "$hash:debian/changelog";
1504 my $gotclogp = parsechangelog("-l$clogf");
1505 my $got_vsn = getfield $gotclogp, 'Version';
1506 printdebug "SKEW CHECK GOT $got_vsn\n";
1507 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1508 print STDERR <<END or die $!;
1510 Warning: archive skew detected. Using the available version:
1511 Archive allegedly contains $skew_warning_vsn
1512 We were able to obtain only $got_vsn
1517 if ($lastpush_hash ne $hash) {
1518 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1522 dryrun_report @upd_cmd;
1528 sub set_local_git_config ($$) {
1530 runcmd @git, qw(config), $k, $v;
1533 sub setup_mergechangelogs () {
1534 my $driver = 'dpkg-mergechangelogs';
1535 my $cb = "merge.$driver";
1536 my $attrs = '.git/info/attributes';
1537 ensuredir '.git/info';
1539 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1540 if (!open ATTRS, "<", $attrs) {
1541 $!==ENOENT or die "$attrs: $!";
1545 next if m{^debian/changelog\s};
1546 print NATTRS $_, "\n" or die $!;
1548 ATTRS->error and die $!;
1551 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1554 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1555 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1557 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1562 canonicalise_suite();
1563 badusage "dry run makes no sense with clone" unless act_local();
1564 my $hasgit = check_for_git();
1565 mkdir $dstdir or die "$dstdir $!";
1567 runcmd @git, qw(init -q);
1568 my $giturl = access_giturl(1);
1569 if (defined $giturl) {
1570 set_local_git_config "remote.$remotename.fetch", fetchspec();
1571 open H, "> .git/HEAD" or die $!;
1572 print H "ref: ".lref()."\n" or die $!;
1574 runcmd @git, qw(remote add), 'origin', $giturl;
1577 progress "fetching existing git history";
1579 runcmd_ordryrun_local @git, qw(fetch origin);
1581 progress "starting new git history";
1583 fetch_from_archive() or no_such_package;
1584 my $vcsgiturl = $dsc->{'Vcs-Git'};
1585 if (length $vcsgiturl) {
1586 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1587 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1589 setup_mergechangelogs();
1590 runcmd @git, qw(reset --hard), lrref();
1591 printdone "ready for work in $dstdir";
1595 if (check_for_git()) {
1598 fetch_from_archive() or no_such_package();
1599 printdone "fetched into ".lrref();
1604 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1606 printdone "fetched to ".lrref()." and merged into HEAD";
1609 sub check_not_dirty () {
1610 return if $ignoredirty;
1611 my @cmd = (@git, qw(diff --quiet HEAD));
1613 $!=0; $?=0; system @cmd;
1614 return if !$! && !$?;
1615 if (!$! && $?==256) {
1616 fail "working tree is dirty (does not match HEAD)";
1622 sub commit_admin ($) {
1625 runcmd_ordryrun_local @git, qw(commit -m), $m;
1628 sub commit_quilty_patch () {
1629 my $output = cmdoutput @git, qw(status --porcelain);
1631 foreach my $l (split /\n/, $output) {
1632 next unless $l =~ m/\S/;
1633 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1637 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1639 progress "nothing quilty to commit, ok.";
1642 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1643 commit_admin "Commit Debian 3.0 (quilt) metadata";
1646 sub get_source_format () {
1647 if (!open F, "debian/source/format") {
1648 die $! unless $!==&ENOENT;
1652 F->error and die $!;
1659 return 0 unless $format eq '3.0 (quilt)';
1660 if ($quilt_mode eq 'nocheck') {
1661 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1664 progress "Format \`$format', checking/updating patch stack";
1668 sub push_parse_changelog ($) {
1671 my $clogp = Dpkg::Control::Hash->new();
1672 $clogp->load($clogpfn) or die;
1674 $package = getfield $clogp, 'Source';
1675 my $cversion = getfield $clogp, 'Version';
1676 my $tag = debiantag($cversion, access_basedistro);
1677 runcmd @git, qw(check-ref-format), $tag;
1679 my $dscfn = dscfn($cversion);
1681 return ($clogp, $cversion, $tag, $dscfn);
1684 sub push_parse_dsc ($$$) {
1685 my ($dscfn,$dscfnwhat, $cversion) = @_;
1686 $dsc = parsecontrol($dscfn,$dscfnwhat);
1687 my $dversion = getfield $dsc, 'Version';
1688 my $dscpackage = getfield $dsc, 'Source';
1689 ($dscpackage eq $package && $dversion eq $cversion) or
1690 fail "$dscfn is for $dscpackage $dversion".
1691 " but debian/changelog is for $package $cversion";
1694 sub push_mktag ($$$$$$$) {
1695 my ($head,$clogp,$tag,
1697 $changesfile,$changesfilewhat,
1700 $dsc->{$ourdscfield[0]} = $head;
1701 $dsc->save("$dscfn.tmp") or die $!;
1703 my $changes = parsecontrol($changesfile,$changesfilewhat);
1704 foreach my $field (qw(Source Distribution Version)) {
1705 $changes->{$field} eq $clogp->{$field} or
1706 fail "changes field $field \`$changes->{$field}'".
1707 " does not match changelog \`$clogp->{$field}'";
1710 my $cversion = getfield $clogp, 'Version';
1711 my $clogsuite = getfield $clogp, 'Distribution';
1713 # We make the git tag by hand because (a) that makes it easier
1714 # to control the "tagger" (b) we can do remote signing
1715 my $authline = clogp_authline $clogp;
1716 my $delibs = join(" ", "",@deliberatelies);
1717 my $declaredistro = access_basedistro();
1718 open TO, '>', $tfn->('.tmp') or die $!;
1719 print TO <<END or die $!;
1725 $package release $cversion for $clogsuite ($csuite) [dgit]
1726 [dgit distro=$declaredistro$delibs]
1728 foreach my $ref (sort keys %previously) {
1729 print TO <<END or die $!;
1730 [dgit previously:$ref=$previously{$ref}]
1736 my $tagobjfn = $tfn->('.tmp');
1738 if (!defined $keyid) {
1739 $keyid = access_cfg('keyid','RETURN-UNDEF');
1741 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1742 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1743 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1744 push @sign_cmd, $tfn->('.tmp');
1745 runcmd_ordryrun @sign_cmd;
1747 $tagobjfn = $tfn->('.signed.tmp');
1748 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1749 $tfn->('.tmp'), $tfn->('.tmp.asc');
1756 sub sign_changes ($) {
1757 my ($changesfile) = @_;
1759 my @debsign_cmd = @debsign;
1760 push @debsign_cmd, "-k$keyid" if defined $keyid;
1761 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1762 push @debsign_cmd, $changesfile;
1763 runcmd_ordryrun @debsign_cmd;
1768 my ($forceflag) = @_;
1769 printdebug "actually entering push\n";
1772 access_giturl(); # check that success is vaguely likely
1774 my $clogpfn = ".git/dgit/changelog.822.tmp";
1775 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1777 responder_send_file('parsed-changelog', $clogpfn);
1779 my ($clogp, $cversion, $tag, $dscfn) =
1780 push_parse_changelog("$clogpfn");
1782 my $dscpath = "$buildproductsdir/$dscfn";
1783 stat_exists $dscpath or
1784 fail "looked for .dsc $dscfn, but $!;".
1785 " maybe you forgot to build";
1787 responder_send_file('dsc', $dscpath);
1789 push_parse_dsc($dscpath, $dscfn, $cversion);
1791 my $format = getfield $dsc, 'Format';
1792 printdebug "format $format\n";
1793 if (madformat($format)) {
1794 commit_quilty_patch();
1798 progress "checking that $dscfn corresponds to HEAD";
1799 runcmd qw(dpkg-source -x --),
1800 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1801 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1802 check_for_vendor_patches() if madformat($dsc->{format});
1803 changedir '../../../..';
1804 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1805 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1806 debugcmd "+",@diffcmd;
1808 my $r = system @diffcmd;
1811 fail "$dscfn specifies a different tree to your HEAD commit;".
1812 " perhaps you forgot to build".
1813 ($diffopt eq '--exit-code' ? "" :
1814 " (run with -D to see full diff output)");
1819 my $head = git_rev_parse('HEAD');
1820 if (!$changesfile) {
1821 my $multi = "$buildproductsdir/".
1822 "${package}_".(stripepoch $cversion)."_multi.changes";
1823 if (stat_exists "$multi") {
1824 $changesfile = $multi;
1826 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1827 my @cs = glob "$buildproductsdir/$pat";
1828 fail "failed to find unique changes file".
1829 " (looked for $pat in $buildproductsdir, or $multi);".
1830 " perhaps you need to use dgit -C"
1832 ($changesfile) = @cs;
1835 $changesfile = "$buildproductsdir/$changesfile";
1838 responder_send_file('changes',$changesfile);
1839 responder_send_command("param head $head");
1840 responder_send_command("param csuite $csuite");
1842 if (deliberately_not_fast_forward) {
1843 git_for_each_ref(lrfetchrefs, sub {
1844 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1845 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1846 responder_send_command("previously $rrefname=$objid");
1847 $previously{$rrefname} = $objid;
1851 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1854 if ($we_are_responder) {
1855 $tagobjfn = $tfn->('.signed.tmp');
1856 responder_receive_files('signed-tag', $tagobjfn);
1859 push_mktag($head,$clogp,$tag,
1861 $changesfile,$changesfile,
1865 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1866 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1867 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1869 if (!check_for_git()) {
1870 create_remote_git_repo();
1872 runcmd_ordryrun @git, qw(push),access_giturl(),
1873 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1874 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1876 if ($we_are_responder) {
1877 my $dryrunsuffix = act_local() ? "" : ".tmp";
1878 responder_receive_files('signed-dsc-changes',
1879 "$dscpath$dryrunsuffix",
1880 "$changesfile$dryrunsuffix");
1883 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1885 progress "[new .dsc left in $dscpath.tmp]";
1887 sign_changes $changesfile;
1890 my $host = access_cfg('upload-host','RETURN-UNDEF');
1891 my @hostarg = defined($host) ? ($host,) : ();
1892 runcmd_ordryrun @dput, @hostarg, $changesfile;
1893 printdone "pushed and uploaded $cversion";
1895 responder_send_command("complete");
1901 badusage "-p is not allowed with clone; specify as argument instead"
1902 if defined $package;
1905 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1906 ($package,$isuite) = @ARGV;
1907 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1908 ($package,$dstdir) = @ARGV;
1909 } elsif (@ARGV==3) {
1910 ($package,$isuite,$dstdir) = @ARGV;
1912 badusage "incorrect arguments to dgit clone";
1914 $dstdir ||= "$package";
1916 if (stat_exists $dstdir) {
1917 fail "$dstdir already exists";
1921 if ($rmonerror && !$dryrun_level) {
1922 $cwd_remove= getcwd();
1924 return unless defined $cwd_remove;
1925 if (!chdir "$cwd_remove") {
1926 return if $!==&ENOENT;
1927 die "chdir $cwd_remove: $!";
1929 rmtree($dstdir) or die "remove $dstdir: $!\n";
1934 $cwd_remove = undef;
1937 sub branchsuite () {
1938 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1939 if ($branch =~ m#$lbranch_re#o) {
1946 sub fetchpullargs () {
1947 if (!defined $package) {
1948 my $sourcep = parsecontrol('debian/control','debian/control');
1949 $package = getfield $sourcep, 'Source';
1952 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1954 my $clogp = parsechangelog();
1955 $isuite = getfield $clogp, 'Distribution';
1957 canonicalise_suite();
1958 progress "fetching from suite $csuite";
1959 } elsif (@ARGV==1) {
1961 canonicalise_suite();
1963 badusage "incorrect arguments to dgit fetch or dgit pull";
1982 badusage "-p is not allowed with dgit push" if defined $package;
1984 my $clogp = parsechangelog();
1985 $package = getfield $clogp, 'Source';
1988 } elsif (@ARGV==1) {
1989 ($specsuite) = (@ARGV);
1991 badusage "incorrect arguments to dgit push";
1993 $isuite = getfield $clogp, 'Distribution';
1995 local ($package) = $existing_package; # this is a hack
1996 canonicalise_suite();
1998 canonicalise_suite();
2000 if (defined $specsuite &&
2001 $specsuite ne $isuite &&
2002 $specsuite ne $csuite) {
2003 fail "dgit push: changelog specifies $isuite ($csuite)".
2004 " but command line specifies $specsuite";
2006 if (check_for_git()) {
2010 if (fetch_from_archive()) {
2011 if (is_fast_fwd(lrref(), 'HEAD')) {
2013 } elsif (deliberately_not_fast_forward) {
2016 fail "dgit push: HEAD is not a descendant".
2017 " of the archive's version.\n".
2018 "dgit: To overwrite its contents,".
2019 " use git merge -s ours ".lrref().".\n".
2020 "dgit: To rewind history, if permitted by the archive,".
2021 " use --deliberately-not-fast-forward";
2025 fail "package appears to be new in this suite;".
2026 " if this is intentional, use --new";
2031 #---------- remote commands' implementation ----------
2033 sub cmd_remote_push_build_host {
2035 my ($nrargs) = shift @ARGV;
2036 my (@rargs) = @ARGV[0..$nrargs-1];
2037 @ARGV = @ARGV[$nrargs..$#ARGV];
2039 my ($dir,$vsnwant) = @rargs;
2040 # vsnwant is a comma-separated list; we report which we have
2041 # chosen in our ready response (so other end can tell if they
2044 $we_are_responder = 1;
2045 $us .= " (build host)";
2047 open PI, "<&STDIN" or die $!;
2048 open STDIN, "/dev/null" or die $!;
2049 open PO, ">&STDOUT" or die $!;
2051 open STDOUT, ">&STDERR" or die $!;
2055 fail "build host has dgit rpush protocol version".
2056 " $rpushprotovsn but invocation host has $vsnwant"
2057 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2059 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2065 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2066 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2067 # a good error message)
2073 my $report = i_child_report();
2074 if (defined $report) {
2075 printdebug "($report)\n";
2076 } elsif ($i_child_pid) {
2077 printdebug "(killing build host child $i_child_pid)\n";
2078 kill 15, $i_child_pid;
2080 if (defined $i_tmp && !defined $initiator_tempdir) {
2082 eval { rmtree $i_tmp; };
2086 END { i_cleanup(); }
2089 my ($base,$selector,@args) = @_;
2090 $selector =~ s/\-/_/g;
2091 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2098 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2105 my @rargs = ($dir,$rpushprotovsn);
2108 push @rdgit, @ropts;
2109 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2111 my @cmd = (@ssh, $host, shellquote @rdgit);
2114 if (defined $initiator_tempdir) {
2115 rmtree $initiator_tempdir;
2116 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2117 $i_tmp = $initiator_tempdir;
2121 $i_child_pid = open2(\*RO, \*RI, @cmd);
2123 initiator_expect { m/^dgit-remote-push-ready/ };
2125 my ($icmd,$iargs) = initiator_expect {
2126 m/^(\S+)(?: (.*))?$/;
2129 i_method "i_resp", $icmd, $iargs;
2133 sub i_resp_progress ($) {
2135 my $msg = protocol_read_bytes \*RO, $rhs;
2139 sub i_resp_complete {
2140 my $pid = $i_child_pid;
2141 $i_child_pid = undef; # prevents killing some other process with same pid
2142 printdebug "waiting for build host child $pid...\n";
2143 my $got = waitpid $pid, 0;
2144 die $! unless $got == $pid;
2145 die "build host child failed $?" if $?;
2148 printdebug "all done\n";
2152 sub i_resp_file ($) {
2154 my $localname = i_method "i_localname", $keyword;
2155 my $localpath = "$i_tmp/$localname";
2156 stat_exists $localpath and
2157 badproto \*RO, "file $keyword ($localpath) twice";
2158 protocol_receive_file \*RO, $localpath;
2159 i_method "i_file", $keyword;
2164 sub i_resp_param ($) {
2165 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2169 sub i_resp_previously ($) {
2170 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2171 or badproto \*RO, "bad previously spec";
2172 my $r = system qw(git check-ref-format), $1;
2173 die "bad previously ref spec ($r)" if $r;
2174 $previously{$1} = $2;
2179 sub i_resp_want ($) {
2181 die "$keyword ?" if $i_wanted{$keyword}++;
2182 my @localpaths = i_method "i_want", $keyword;
2183 printdebug "[[ $keyword @localpaths\n";
2184 foreach my $localpath (@localpaths) {
2185 protocol_send_file \*RI, $localpath;
2187 print RI "files-end\n" or die $!;
2190 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2192 sub i_localname_parsed_changelog {
2193 return "remote-changelog.822";
2195 sub i_file_parsed_changelog {
2196 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2197 push_parse_changelog "$i_tmp/remote-changelog.822";
2198 die if $i_dscfn =~ m#/|^\W#;
2201 sub i_localname_dsc {
2202 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2207 sub i_localname_changes {
2208 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2209 $i_changesfn = $i_dscfn;
2210 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2211 return $i_changesfn;
2213 sub i_file_changes { }
2215 sub i_want_signed_tag {
2216 printdebug Dumper(\%i_param, $i_dscfn);
2217 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2218 && defined $i_param{'csuite'}
2219 or badproto \*RO, "premature desire for signed-tag";
2220 my $head = $i_param{'head'};
2221 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2223 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2225 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2228 push_mktag $head, $i_clogp, $i_tag,
2230 $i_changesfn, 'remote changes',
2231 sub { "tag$_[0]"; };
2236 sub i_want_signed_dsc_changes {
2237 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2238 sign_changes $i_changesfn;
2239 return ($i_dscfn, $i_changesfn);
2242 #---------- building etc. ----------
2248 #----- `3.0 (quilt)' handling -----
2250 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2252 sub quiltify_dpkg_commit ($$$;$) {
2253 my ($patchname,$author,$msg, $xinfo) = @_;
2257 my $descfn = ".git/dgit/quilt-description.tmp";
2258 open O, '>', $descfn or die "$descfn: $!";
2261 $msg =~ s/^\s+$/ ./mg;
2262 print O <<END or die $!;
2272 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2273 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2274 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2275 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2279 sub quiltify_trees_differ ($$) {
2281 # returns 1 iff the two tree objects differ other than in debian/
2283 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2284 my $diffs= cmdoutput @cmd;
2285 foreach my $f (split /\0/, $diffs) {
2286 next if $f eq 'debian';
2292 sub quiltify_tree_sentinelfiles ($) {
2293 # lists the `sentinel' files present in the tree
2295 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2296 qw(-- debian/rules debian/control);
2302 my ($clogp,$target) = @_;
2304 # Quilt patchification algorithm
2306 # We search backwards through the history of the main tree's HEAD
2307 # (T) looking for a start commit S whose tree object is identical
2308 # to to the patch tip tree (ie the tree corresponding to the
2309 # current dpkg-committed patch series). For these purposes
2310 # `identical' disregards anything in debian/ - this wrinkle is
2311 # necessary because dpkg-source treates debian/ specially.
2313 # We can only traverse edges where at most one of the ancestors'
2314 # trees differs (in changes outside in debian/). And we cannot
2315 # handle edges which change .pc/ or debian/patches. To avoid
2316 # going down a rathole we avoid traversing edges which introduce
2317 # debian/rules or debian/control. And we set a limit on the
2318 # number of edges we are willing to look at.
2320 # If we succeed, we walk forwards again. For each traversed edge
2321 # PC (with P parent, C child) (starting with P=S and ending with
2322 # C=T) to we do this:
2324 # - dpkg-source --commit with a patch name and message derived from C
2325 # After traversing PT, we git commit the changes which
2326 # should be contained within debian/patches.
2328 changedir '../fake';
2329 mktree_in_ud_here();
2331 runcmd @git, 'add', '.';
2332 my $oldtiptree=git_write_tree();
2333 changedir '../work';
2335 # The search for the path S..T is breadth-first. We maintain a
2336 # todo list containing search nodes. A search node identifies a
2337 # commit, and looks something like this:
2339 # Commit => $git_commit_id,
2340 # Child => $c, # or undef if P=T
2341 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2342 # Nontrivial => true iff $p..$c has relevant changes
2349 my %considered; # saves being exponential on some weird graphs
2351 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2354 my ($search,$whynot) = @_;
2355 printdebug " search NOT $search->{Commit} $whynot\n";
2356 $search->{Whynot} = $whynot;
2357 push @nots, $search;
2358 no warnings qw(exiting);
2367 my $c = shift @todo;
2368 next if $considered{$c->{Commit}}++;
2370 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2372 printdebug "quiltify investigate $c->{Commit}\n";
2375 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2376 printdebug " search finished hooray!\n";
2381 if ($quilt_mode eq 'nofix') {
2382 fail "quilt fixup required but quilt mode is \`nofix'\n".
2383 "HEAD commit $c->{Commit} differs from tree implied by ".
2384 " debian/patches (tree object $oldtiptree)";
2386 if ($quilt_mode eq 'smash') {
2387 printdebug " search quitting smash\n";
2391 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2392 $not->($c, "has $c_sentinels not $t_sentinels")
2393 if $c_sentinels ne $t_sentinels;
2395 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2396 $commitdata =~ m/\n\n/;
2398 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2399 @parents = map { { Commit => $_, Child => $c } } @parents;
2401 $not->($c, "root commit") if !@parents;
2403 foreach my $p (@parents) {
2404 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2406 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2407 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2409 foreach my $p (@parents) {
2410 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2412 my @cmd= (@git, qw(diff-tree -r --name-only),
2413 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2414 my $patchstackchange = cmdoutput @cmd;
2415 if (length $patchstackchange) {
2416 $patchstackchange =~ s/\n/,/g;
2417 $not->($p, "changed $patchstackchange");
2420 printdebug " search queue P=$p->{Commit} ",
2421 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2427 printdebug "quiltify want to smash\n";
2430 my $x = $_[0]{Commit};
2431 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2434 my $reportnot = sub {
2436 my $s = $abbrev->($notp);
2437 my $c = $notp->{Child};
2438 $s .= "..".$abbrev->($c) if $c;
2439 $s .= ": ".$notp->{Whynot};
2442 if ($quilt_mode eq 'linear') {
2443 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2444 foreach my $notp (@nots) {
2445 print STDERR "$us: ", $reportnot->($notp), "\n";
2447 fail "quilt fixup naive history linearisation failed.\n".
2448 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2449 } elsif ($quilt_mode eq 'smash') {
2450 } elsif ($quilt_mode eq 'auto') {
2451 progress "quilt fixup cannot be linear, smashing...";
2453 die "$quilt_mode ?";
2458 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2460 quiltify_dpkg_commit "auto-$version-$target-$time",
2461 (getfield $clogp, 'Maintainer'),
2462 "Automatically generated patch ($clogp->{Version})\n".
2463 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2467 progress "quiltify linearisation planning successful, executing...";
2469 for (my $p = $sref_S;
2470 my $c = $p->{Child};
2472 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2473 next unless $p->{Nontrivial};
2475 my $cc = $c->{Commit};
2477 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2478 $commitdata =~ m/\n\n/ or die "$c ?";
2481 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2484 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2487 my $patchname = $title;
2488 $patchname =~ s/[.:]$//;
2489 $patchname =~ y/ A-Z/-a-z/;
2490 $patchname =~ y/-a-z0-9_.+=~//cd;
2491 $patchname =~ s/^\W/x-$&/;
2492 $patchname = substr($patchname,0,40);
2495 stat "debian/patches/$patchname$index";
2497 $!==ENOENT or die "$patchname$index $!";
2499 runcmd @git, qw(checkout -q), $cc;
2501 # We use the tip's changelog so that dpkg-source doesn't
2502 # produce complaining messages from dpkg-parsechangelog. None
2503 # of the information dpkg-source gets from the changelog is
2504 # actually relevant - it gets put into the original message
2505 # which dpkg-source provides our stunt editor, and then
2507 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2509 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2510 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2512 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2515 runcmd @git, qw(checkout -q master);
2518 sub build_maybe_quilt_fixup () {
2519 my $format=get_source_format;
2520 return unless madformat $format;
2523 check_for_vendor_patches();
2526 # - honour any existing .pc in case it has any strangeness
2527 # - determine the git commit corresponding to the tip of
2528 # the patch stack (if there is one)
2529 # - if there is such a git commit, convert each subsequent
2530 # git commit into a quilt patch with dpkg-source --commit
2531 # - otherwise convert all the differences in the tree into
2532 # a single git commit
2536 # Our git tree doesn't necessarily contain .pc. (Some versions of
2537 # dgit would include the .pc in the git tree.) If there isn't
2538 # one, we need to generate one by unpacking the patches that we
2541 # We first look for a .pc in the git tree. If there is one, we
2542 # will use it. (This is not the normal case.)
2544 # Otherwise need to regenerate .pc so that dpkg-source --commit
2545 # can work. We do this as follows:
2546 # 1. Collect all relevant .orig from parent directory
2547 # 2. Generate a debian.tar.gz out of
2548 # debian/{patches,rules,source/format}
2549 # 3. Generate a fake .dsc containing just these fields:
2550 # Format Source Version Files
2551 # 4. Extract the fake .dsc
2552 # Now the fake .dsc has a .pc directory.
2553 # (In fact we do this in every case, because in future we will
2554 # want to search for a good base commit for generating patches.)
2556 # Then we can actually do the dpkg-source --commit
2557 # 1. Make a new working tree with the same object
2558 # store as our main tree and check out the main
2560 # 2. Copy .pc from the fake's extraction, if necessary
2561 # 3. Run dpkg-source --commit
2562 # 4. If the result has changes to debian/, then
2563 # - git-add them them
2564 # - git-add .pc if we had a .pc in-tree
2566 # 5. If we had a .pc in-tree, delete it, and git-commit
2567 # 6. Back in the main tree, fast forward to the new HEAD
2569 my $clogp = parsechangelog();
2570 my $headref = git_rev_parse('HEAD');
2575 my $upstreamversion=$version;
2576 $upstreamversion =~ s/-[^-]*$//;
2578 my $fakeversion="$upstreamversion-~~DGITFAKE";
2580 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2581 print $fakedsc <<END or die $!;
2584 Version: $fakeversion
2588 my $dscaddfile=sub {
2591 my $md = new Digest::MD5;
2593 my $fh = new IO::File $b, '<' or die "$b $!";
2598 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2601 foreach my $f (<../../../../*>) { #/){
2602 my $b=$f; $b =~ s{.*/}{};
2603 next unless is_orig_file $b, srcfn $upstreamversion,'';
2604 link $f, $b or die "$b $!";
2608 my @files=qw(debian/source/format debian/rules);
2609 if (stat_exists '../../../debian/patches') {
2610 push @files, 'debian/patches';
2613 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2614 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2616 $dscaddfile->($debtar);
2617 close $fakedsc or die $!;
2619 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2621 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2622 rename $fakexdir, "fake" or die "$fakexdir $!";
2624 mkdir "work" or die $!;
2626 mktree_in_ud_here();
2627 runcmd @git, qw(reset --hard), $headref;
2630 if (stat_exists ".pc") {
2632 progress "Tree already contains .pc - will use it then delete it.";
2635 rename '../fake/.pc','.pc' or die $!;
2638 quiltify($clogp,$headref);
2640 if (!open P, '>>', ".pc/applied-patches") {
2641 $!==&ENOENT or die $!;
2646 commit_quilty_patch();
2648 if ($mustdeletepc) {
2649 runcmd @git, qw(rm -rqf .pc);
2650 commit_admin "Commit removal of .pc (quilt series tracking data)";
2653 changedir '../../../..';
2654 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2657 sub quilt_fixup_editor () {
2658 my $descfn = $ENV{$fakeeditorenv};
2659 my $editing = $ARGV[$#ARGV];
2660 open I1, '<', $descfn or die "$descfn: $!";
2661 open I2, '<', $editing or die "$editing: $!";
2662 unlink $editing or die "$editing: $!";
2663 open O, '>', $editing or die "$editing: $!";
2664 while (<I1>) { print O or die $!; } I1->error and die $!;
2667 $copying ||= m/^\-\-\- /;
2668 next unless $copying;
2671 I2->error and die $!;
2676 #----- other building -----
2679 if ($cleanmode eq 'dpkg-source') {
2680 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2681 } elsif ($cleanmode eq 'dpkg-source-d') {
2682 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2683 } elsif ($cleanmode eq 'git') {
2684 runcmd_ordryrun_local @git, qw(clean -xdf);
2685 } elsif ($cleanmode eq 'git-ff') {
2686 runcmd_ordryrun_local @git, qw(clean -xdff);
2687 } elsif ($cleanmode eq 'check') {
2688 my $leftovers = cmdoutput @git, qw(clean -xdn);
2689 if (length $leftovers) {
2690 print STDERR $leftovers, "\n" or die $!;
2691 fail "tree contains uncommitted files and --clean=check specified";
2693 } elsif ($cleanmode eq 'none') {
2700 badusage "clean takes no additional arguments" if @ARGV;
2705 badusage "-p is not allowed when building" if defined $package;
2708 my $clogp = parsechangelog();
2709 $isuite = getfield $clogp, 'Distribution';
2710 $package = getfield $clogp, 'Source';
2711 $version = getfield $clogp, 'Version';
2712 build_maybe_quilt_fixup();
2715 sub changesopts () {
2716 my @opts =@changesopts[1..$#changesopts];
2717 if (!defined $changes_since_version) {
2718 my @vsns = archive_query('archive_query');
2719 my @quirk = access_quirk();
2720 if ($quirk[0] eq 'backports') {
2721 local $isuite = $quirk[2];
2723 canonicalise_suite();
2724 push @vsns, archive_query('archive_query');
2727 @vsns = map { $_->[0] } @vsns;
2728 @vsns = sort { -version_compare($a, $b) } @vsns;
2729 $changes_since_version = $vsns[0];
2730 progress "changelog will contain changes since $vsns[0]";
2732 $changes_since_version = '_';
2733 progress "package seems new, not specifying -v<version>";
2736 if ($changes_since_version ne '_') {
2737 unshift @opts, "-v$changes_since_version";
2742 sub massage_dbp_args ($) {
2744 return unless $cleanmode =~ m/git|none/;
2745 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2746 my @newcmd = shift @$cmd;
2747 # -nc has the side effect of specifying -b if nothing else specified
2748 push @newcmd, '-nc';
2749 # and some combinations of -S, -b, et al, are errors, rather than
2750 # later simply overriding earlier
2751 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2752 push @newcmd, @$cmd;
2758 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2759 massage_dbp_args \@dbp;
2760 runcmd_ordryrun_local @dbp;
2761 printdone "build successful\n";
2766 my @dbp = @dpkgbuildpackage;
2767 massage_dbp_args \@dbp;
2769 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2770 "--git-builder=@dbp");
2771 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2772 canonicalise_suite();
2773 push @cmd, "--git-debian-branch=".lbranch();
2775 push @cmd, changesopts();
2776 runcmd_ordryrun_local @cmd, @ARGV;
2777 printdone "build successful\n";
2782 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2783 $dscfn = dscfn($version);
2784 if ($cleanmode eq 'dpkg-source') {
2785 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2787 } elsif ($cleanmode eq 'dpkg-source-d') {
2788 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2791 my $pwd = must_getcwd();
2792 my $leafdir = basename $pwd;
2794 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2796 runcmd_ordryrun_local qw(sh -ec),
2797 'exec >$1; shift; exec "$@"','x',
2798 "../$sourcechanges",
2799 @dpkggenchanges, qw(-S), changesopts();
2803 sub cmd_build_source {
2804 badusage "build-source takes no additional arguments" if @ARGV;
2806 printdone "source built, results in $dscfn and $sourcechanges";
2812 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2814 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2815 stat_exists $sourcechanges
2816 or fail "$sourcechanges (in parent directory): $!";
2817 foreach my $cf (glob $pat) {
2818 next if $cf eq $sourcechanges;
2819 unlink $cf or fail "remove $cf: $!";
2822 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2823 my @changesfiles = glob $pat;
2824 @changesfiles = sort {
2825 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2828 fail "wrong number of different changes files (@changesfiles)"
2829 unless @changesfiles;
2830 runcmd_ordryrun_local @mergechanges, @changesfiles;
2831 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2833 stat_exists $multichanges or fail "$multichanges: $!";
2835 printdone "build successful, results in $multichanges\n" or die $!;
2838 sub cmd_quilt_fixup {
2839 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2840 my $clogp = parsechangelog();
2841 $version = getfield $clogp, 'Version';
2842 $package = getfield $clogp, 'Source';
2843 build_maybe_quilt_fixup();
2846 sub cmd_archive_api_query {
2847 badusage "need only 1 subpath argument" unless @ARGV==1;
2848 my ($subpath) = @ARGV;
2849 my @cmd = archive_api_query_cmd($subpath);
2851 exec @cmd or fail "exec curl: $!\n";
2854 sub cmd_clone_dgit_repos_server {
2855 badusage "need destination argument" unless @ARGV==1;
2856 my ($destdir) = @ARGV;
2857 $package = '_dgit-repos-server';
2858 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2860 exec @cmd or fail "exec git clone: $!\n";
2863 sub cmd_setup_mergechangelogs {
2864 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2865 setup_mergechangelogs();
2868 #---------- argument parsing and main program ----------
2871 print "dgit version $our_version\n" or die $!;
2878 if (defined $ENV{'DGIT_SSH'}) {
2879 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2880 } elsif (defined $ENV{'GIT_SSH'}) {
2881 @ssh = ($ENV{'GIT_SSH'});
2885 last unless $ARGV[0] =~ m/^-/;
2889 if (m/^--dry-run$/) {
2892 } elsif (m/^--damp-run$/) {
2895 } elsif (m/^--no-sign$/) {
2898 } elsif (m/^--help$/) {
2900 } elsif (m/^--version$/) {
2902 } elsif (m/^--new$/) {
2905 } elsif (m/^--since-version=([^_]+|_)$/) {
2907 $changes_since_version = $1;
2908 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2909 ($om = $opts_opt_map{$1}) &&
2913 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2914 !$opts_opt_cmdonly{$1} &&
2915 ($om = $opts_opt_map{$1})) {
2918 } elsif (m/^--existing-package=(.*)/s) {
2920 $existing_package = $1;
2921 } elsif (m/^--initiator-tempdir=(.*)/s) {
2922 $initiator_tempdir = $1;
2923 $initiator_tempdir =~ m#^/# or
2924 badusage "--initiator-tempdir must be used specify an".
2925 " absolute, not relative, directory."
2926 } elsif (m/^--distro=(.*)/s) {
2929 } elsif (m/^--build-products-dir=(.*)/s) {
2931 $buildproductsdir = $1;
2932 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2935 } elsif (m/^--clean=(.*)$/s) {
2936 badusage "unknown cleaning mode \`$1'";
2937 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2940 } elsif (m/^--quilt=(.*)$/s) {
2941 badusage "unknown quilt fixup mode \`$1'";
2942 } elsif (m/^--ignore-dirty$/s) {
2945 } elsif (m/^--no-quilt-fixup$/s) {
2947 $quilt_mode = 'nocheck';
2948 } elsif (m/^--no-rm-on-error$/s) {
2951 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2953 push @deliberatelies, $&;
2955 badusage "unknown long option \`$_'";
2962 } elsif (s/^-L/-/) {
2965 } elsif (s/^-h/-/) {
2967 } elsif (s/^-D/-/) {
2971 } elsif (s/^-N/-/) {
2974 } elsif (s/^-v([^_]+|_)$//s) {
2976 $changes_since_version = $1;
2979 push @changesopts, $_;
2981 } elsif (s/^-c(.*=.*)//s) {
2983 push @git, '-c', $1;
2984 } elsif (s/^-d(.+)//s) {
2987 } elsif (s/^-C(.+)//s) {
2990 if ($changesfile =~ s#^(.*)/##) {
2991 $buildproductsdir = $1;
2993 } elsif (s/^-k(.+)//s) {
2995 } elsif (m/^-[vdCk]$/) {
2997 "option \`$_' requires an argument (and no space before the argument)";
2998 } elsif (s/^-wn$//s) {
3000 $cleanmode = 'none';
3001 } elsif (s/^-wg$//s) {
3004 } elsif (s/^-wgf$//s) {
3006 $cleanmode = 'git-ff';
3007 } elsif (s/^-wd$//s) {
3009 $cleanmode = 'dpkg-source';
3010 } elsif (s/^-wdd$//s) {
3012 $cleanmode = 'dpkg-source-d';
3013 } elsif (s/^-wc$//s) {
3015 $cleanmode = 'check';
3017 badusage "unknown short option \`$_'";
3024 if ($ENV{$fakeeditorenv}) {
3025 quilt_fixup_editor();
3029 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3030 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3031 if $dryrun_level == 1;
3033 print STDERR $helpmsg or die $!;
3036 my $cmd = shift @ARGV;
3039 if (!defined $quilt_mode) {
3040 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3041 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3043 $quilt_mode =~ m/^($quilt_modes_re)$/
3044 or badcfg "unknown quilt-mode \`$quilt_mode'";
3048 my $fn = ${*::}{"cmd_$cmd"};
3049 $fn or badusage "unknown operation $cmd";