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' => 'push.dgit.debian.org',
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);
552 sub access_forpush_config () {
553 my $d = access_basedistro();
554 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
557 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
558 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
559 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
560 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
563 sub access_forpush () {
564 $access_forpush //= access_forpush_config();
565 return $access_forpush;
569 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
570 badcfg "pushing but distro is configured readonly"
571 if access_forpush_config() eq '0';
575 sub access_distros () {
576 # Returns list of distros to try, in order
579 # 0. `instead of' distro name(s) we have been pointed to
580 # 1. the access_quirk distro, if any
581 # 2a. the user's specified distro, or failing that } basedistro
582 # 2b. the distro calculated from the suite }
583 my @l = access_basedistro();
585 my (undef,$quirkdistro) = access_quirk();
586 unshift @l, $quirkdistro;
587 unshift @l, $instead_distro;
588 @l = grep { defined } @l;
590 if (access_forpush()) {
591 @l = map { ("$_/push", $_) } @l;
599 # The nesting of these loops determines the search order. We put
600 # the key loop on the outside so that we search all the distros
601 # for each key, before going on to the next key. That means that
602 # if access_cfg is called with a more specific, and then a less
603 # specific, key, an earlier distro can override the less specific
604 # without necessarily overriding any more specific keys. (If the
605 # distro wants to override the more specific keys it can simply do
606 # so; whereas if we did the loop the other way around, it would be
607 # impossible to for an earlier distro to override a less specific
608 # key but not the more specific ones without restating the unknown
609 # values of the more specific keys.
612 # We have to deal with RETURN-UNDEF specially, so that we don't
613 # terminate the search prematurely.
615 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
618 foreach my $d (access_distros()) {
619 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
621 push @cfgs, map { "dgit.default.$_" } @realkeys;
623 my $value = cfg(@cfgs);
627 sub string_to_ssh ($) {
629 if ($spec =~ m/\s/) {
630 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
636 sub access_cfg_ssh () {
637 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
638 if (!defined $gitssh) {
641 return string_to_ssh $gitssh;
645 sub access_runeinfo ($) {
647 return ": dgit ".access_basedistro()." $info ;";
650 sub access_someuserhost ($) {
652 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
653 defined($user) && length($user) or
654 $user = access_cfg("$some-user",'username');
655 my $host = access_cfg("$some-host");
656 return length($user) ? "$user\@$host" : $host;
659 sub access_gituserhost () {
660 return access_someuserhost('git');
663 sub access_giturl (;$) {
665 my $url = access_cfg('git-url','RETURN-UNDEF');
668 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
669 return undef unless defined $proto;
672 access_gituserhost().
673 access_cfg('git-path');
675 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
678 return "$url/$package$suffix";
681 sub parsecontrolfh ($$;$) {
682 my ($fh, $desc, $allowsigned) = @_;
683 our $dpkgcontrolhash_noissigned;
686 my %opts = ('name' => $desc);
687 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
688 $c = Dpkg::Control::Hash->new(%opts);
689 $c->parse($fh,$desc) or die "parsing of $desc failed";
690 last if $allowsigned;
691 last if $dpkgcontrolhash_noissigned;
692 my $issigned= $c->get_option('is_pgp_signed');
693 if (!defined $issigned) {
694 $dpkgcontrolhash_noissigned= 1;
695 seek $fh, 0,0 or die "seek $desc: $!";
696 } elsif ($issigned) {
697 fail "control file $desc is (already) PGP-signed. ".
698 " Note that dgit push needs to modify the .dsc and then".
699 " do the signature itself";
708 my ($file, $desc) = @_;
709 my $fh = new IO::Handle;
710 open $fh, '<', $file or die "$file: $!";
711 my $c = parsecontrolfh($fh,$desc);
712 $fh->error and die $!;
718 my ($dctrl,$field) = @_;
719 my $v = $dctrl->{$field};
720 return $v if defined $v;
721 fail "missing field $field in ".$v->get_option('name');
725 my $c = Dpkg::Control::Hash->new();
726 my $p = new IO::Handle;
727 my @cmd = (qw(dpkg-parsechangelog), @_);
728 open $p, '-|', @cmd or die $!;
730 $?=0; $!=0; close $p or failedcmd @cmd;
736 defined $d or fail "getcwd failed: $!";
742 sub archive_query ($) {
744 my $query = access_cfg('archive-query','RETURN-UNDEF');
745 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
748 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
751 sub pool_dsc_subpath ($$) {
752 my ($vsn,$component) = @_; # $package is implict arg
753 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
754 return "/pool/$component/$prefix/$package/".dscfn($vsn);
757 #---------- `ftpmasterapi' archive query method (nascent) ----------
759 sub archive_api_query_cmd ($) {
761 my @cmd = qw(curl -sS);
762 my $url = access_cfg('archive-query-url');
763 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
765 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
766 foreach my $key (split /\:/, $keys) {
767 $key =~ s/\%HOST\%/$host/g;
769 fail "for $url: stat $key: $!" unless $!==ENOENT;
772 fail "config requested specific TLS key but do not know".
773 " how to get curl to use exactly that EE key ($key)";
774 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
775 # # Sadly the above line does not work because of changes
776 # # to gnutls. The real fix for #790093 may involve
777 # # new curl options.
780 # Fixing #790093 properly will involve providing a value
781 # for this on clients.
782 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
783 push @cmd, split / /, $kargs if defined $kargs;
785 push @cmd, $url.$subpath;
791 my ($data, $subpath) = @_;
792 badcfg "ftpmasterapi archive query method takes no data part"
794 my @cmd = archive_api_query_cmd($subpath);
795 my $json = cmdoutput @cmd;
796 return decode_json($json);
799 sub canonicalise_suite_ftpmasterapi () {
800 my ($proto,$data) = @_;
801 my $suites = api_query($data, 'suites');
803 foreach my $entry (@$suites) {
805 my $v = $entry->{$_};
806 defined $v && $v eq $isuite;
808 push @matched, $entry;
810 fail "unknown suite $isuite" unless @matched;
813 @matched==1 or die "multiple matches for suite $isuite\n";
814 $cn = "$matched[0]{codename}";
815 defined $cn or die "suite $isuite info has no codename\n";
816 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
818 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
823 sub archive_query_ftpmasterapi () {
824 my ($proto,$data) = @_;
825 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
827 my $digester = Digest::SHA->new(256);
828 foreach my $entry (@$info) {
830 my $vsn = "$entry->{version}";
831 my ($ok,$msg) = version_check $vsn;
832 die "bad version: $msg\n" unless $ok;
833 my $component = "$entry->{component}";
834 $component =~ m/^$component_re$/ or die "bad component";
835 my $filename = "$entry->{filename}";
836 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
837 or die "bad filename";
838 my $sha256sum = "$entry->{sha256sum}";
839 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
840 push @rows, [ $vsn, "/pool/$component/$filename",
841 $digester, $sha256sum ];
843 die "bad ftpmaster api response: $@\n".Dumper($entry)
846 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
850 #---------- `madison' archive query method ----------
852 sub archive_query_madison {
853 return map { [ @$_[0..1] ] } madison_get_parse(@_);
856 sub madison_get_parse {
857 my ($proto,$data) = @_;
858 die unless $proto eq 'madison';
860 $data= access_cfg('madison-distro','RETURN-UNDEF');
861 $data //= access_basedistro();
863 $rmad{$proto,$data,$package} ||= cmdoutput
864 qw(rmadison -asource),"-s$isuite","-u$data",$package;
865 my $rmad = $rmad{$proto,$data,$package};
868 foreach my $l (split /\n/, $rmad) {
869 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
870 \s*( [^ \t|]+ )\s* \|
871 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
872 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
873 $1 eq $package or die "$rmad $package ?";
880 $component = access_cfg('archive-query-default-component');
882 $5 eq 'source' or die "$rmad ?";
883 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
885 return sort { -version_compare($a->[0],$b->[0]); } @out;
888 sub canonicalise_suite_madison {
889 # madison canonicalises for us
890 my @r = madison_get_parse(@_);
892 "unable to canonicalise suite using package $package".
893 " which does not appear to exist in suite $isuite;".
894 " --existing-package may help";
898 #---------- `sshpsql' archive query method ----------
901 my ($data,$runeinfo,$sql) = @_;
903 $data= access_someuserhost('sshpsql').':'.
904 access_cfg('sshpsql-dbname');
906 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
907 my ($userhost,$dbname) = ($`,$'); #';
909 my @cmd = (access_cfg_ssh, $userhost,
910 access_runeinfo("ssh-psql $runeinfo").
911 " export LC_MESSAGES=C; export LC_CTYPE=C;".
912 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
914 open P, "-|", @cmd or die $!;
917 printdebug("$debugprefix>|$_|\n");
920 $!=0; $?=0; close P or failedcmd @cmd;
922 my $nrows = pop @rows;
923 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
924 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
925 @rows = map { [ split /\|/, $_ ] } @rows;
926 my $ncols = scalar @{ shift @rows };
927 die if grep { scalar @$_ != $ncols } @rows;
931 sub sql_injection_check {
932 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
935 sub archive_query_sshpsql ($$) {
936 my ($proto,$data) = @_;
937 sql_injection_check $isuite, $package;
938 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
939 SELECT source.version, component.name, files.filename, files.sha256sum
941 JOIN src_associations ON source.id = src_associations.source
942 JOIN suite ON suite.id = src_associations.suite
943 JOIN dsc_files ON dsc_files.source = source.id
944 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
945 JOIN component ON component.id = files_archive_map.component_id
946 JOIN files ON files.id = dsc_files.file
947 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
948 AND source.source='$package'
949 AND files.filename LIKE '%.dsc';
951 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
952 my $digester = Digest::SHA->new(256);
954 my ($vsn,$component,$filename,$sha256sum) = @$_;
955 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
960 sub canonicalise_suite_sshpsql ($$) {
961 my ($proto,$data) = @_;
962 sql_injection_check $isuite;
963 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
964 SELECT suite.codename
965 FROM suite where suite_name='$isuite' or codename='$isuite';
967 @rows = map { $_->[0] } @rows;
968 fail "unknown suite $isuite" unless @rows;
969 die "ambiguous $isuite: @rows ?" if @rows>1;
973 #---------- `dummycat' archive query method ----------
975 sub canonicalise_suite_dummycat ($$) {
976 my ($proto,$data) = @_;
977 my $dpath = "$data/suite.$isuite";
978 if (!open C, "<", $dpath) {
979 $!==ENOENT or die "$dpath: $!";
980 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
984 chomp or die "$dpath: $!";
986 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
990 sub archive_query_dummycat ($$) {
991 my ($proto,$data) = @_;
992 canonicalise_suite();
993 my $dpath = "$data/package.$csuite.$package";
994 if (!open C, "<", $dpath) {
995 $!==ENOENT or die "$dpath: $!";
996 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1004 printdebug "dummycat query $csuite $package $dpath | $_\n";
1005 my @row = split /\s+/, $_;
1006 @row==2 or die "$dpath: $_ ?";
1009 C->error and die "$dpath: $!";
1011 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1014 #---------- archive query entrypoints and rest of program ----------
1016 sub canonicalise_suite () {
1017 return if defined $csuite;
1018 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1019 $csuite = archive_query('canonicalise_suite');
1020 if ($isuite ne $csuite) {
1021 progress "canonical suite name for $isuite is $csuite";
1025 sub get_archive_dsc () {
1026 canonicalise_suite();
1027 my @vsns = archive_query('archive_query');
1028 foreach my $vinfo (@vsns) {
1029 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1030 $dscurl = access_cfg('mirror').$subpath;
1031 $dscdata = url_get($dscurl);
1033 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1038 $digester->add($dscdata);
1039 my $got = $digester->hexdigest();
1041 fail "$dscurl has hash $got but".
1042 " archive told us to expect $digest";
1044 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1045 printdebug Dumper($dscdata) if $debuglevel>1;
1046 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1047 printdebug Dumper($dsc) if $debuglevel>1;
1048 my $fmt = getfield $dsc, 'Format';
1049 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1050 $dsc_checked = !!$digester;
1056 sub check_for_git ();
1057 sub check_for_git () {
1059 my $how = access_cfg('git-check');
1060 if ($how eq 'ssh-cmd') {
1062 (access_cfg_ssh, access_gituserhost(),
1063 access_runeinfo("git-check $package").
1064 " set -e; cd ".access_cfg('git-path').";".
1065 " if test -d $package.git; then echo 1; else echo 0; fi");
1066 my $r= cmdoutput @cmd;
1067 if ($r =~ m/^divert (\w+)$/) {
1069 my ($usedistro,) = access_distros();
1070 # NB that if we are pushing, $usedistro will be $distro/push
1071 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1072 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1073 progress "diverting to $divert (using config for $instead_distro)";
1074 return check_for_git();
1076 failedcmd @cmd unless $r =~ m/^[01]$/;
1078 } elsif ($how eq 'url') {
1079 my $prefix = access_cfg('git-check-url','git-url');
1080 my $suffix = access_cfg('git-check-suffix','git-suffix',
1081 'RETURN-UNDEF') // '.git';
1082 my $url = "$prefix/$package$suffix";
1083 my @cmd = (qw(curl -sS -I), $url);
1084 my $result = cmdoutput @cmd;
1085 $result =~ m/^\S+ (404|200) /s or
1086 fail "unexpected results from git check query - ".
1087 Dumper($prefix, $result);
1089 if ($code eq '404') {
1091 } elsif ($code eq '200') {
1096 } elsif ($how eq 'true') {
1098 } elsif ($how eq 'false') {
1101 badcfg "unknown git-check \`$how'";
1105 sub create_remote_git_repo () {
1106 my $how = access_cfg('git-create');
1107 if ($how eq 'ssh-cmd') {
1109 (access_cfg_ssh, access_gituserhost(),
1110 access_runeinfo("git-create $package").
1111 "set -e; cd ".access_cfg('git-path').";".
1112 " cp -a _template $package.git");
1113 } elsif ($how eq 'true') {
1116 badcfg "unknown git-create \`$how'";
1120 our ($dsc_hash,$lastpush_hash);
1122 our $ud = '.git/dgit/unpack';
1127 mkdir $ud or die $!;
1130 sub mktree_in_ud_here () {
1131 runcmd qw(git init -q);
1132 rmtree('.git/objects');
1133 symlink '../../../../objects','.git/objects' or die $!;
1136 sub git_write_tree () {
1137 my $tree = cmdoutput @git, qw(write-tree);
1138 $tree =~ m/^\w+$/ or die "$tree ?";
1142 sub mktree_in_ud_from_only_subdir () {
1143 # changes into the subdir
1145 die unless @dirs==1;
1146 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1149 fail "source package contains .git directory" if stat_exists '.git';
1150 mktree_in_ud_here();
1151 my $format=get_source_format();
1152 if (madformat($format)) {
1155 runcmd @git, qw(add -Af);
1156 my $tree=git_write_tree();
1157 return ($tree,$dir);
1160 sub dsc_files_info () {
1161 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1162 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1163 ['Files', 'Digest::MD5', 'new()']) {
1164 my ($fname, $module, $method) = @$csumi;
1165 my $field = $dsc->{$fname};
1166 next unless defined $field;
1167 eval "use $module; 1;" or die $@;
1169 foreach (split /\n/, $field) {
1171 m/^(\w+) (\d+) (\S+)$/ or
1172 fail "could not parse .dsc $fname line \`$_'";
1173 my $digester = eval "$module"."->$method;" or die $@;
1178 Digester => $digester,
1183 fail "missing any supported Checksums-* or Files field in ".
1184 $dsc->get_option('name');
1188 map { $_->{Filename} } dsc_files_info();
1191 sub is_orig_file ($;$) {
1194 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1195 defined $base or return 1;
1199 sub make_commit ($) {
1201 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1204 sub clogp_authline ($) {
1206 my $author = getfield $clogp, 'Maintainer';
1207 $author =~ s#,.*##ms;
1208 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1209 my $authline = "$author $date";
1210 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1211 fail "unexpected commit author line format \`$authline'".
1212 " (was generated from changelog Maintainer field)";
1216 sub vendor_patches_distro ($$) {
1217 my ($checkdistro, $what) = @_;
1218 return unless defined $checkdistro;
1220 my $series = "debian/patches/\L$checkdistro\E.series";
1221 printdebug "checking for vendor-specific $series ($what)\n";
1223 if (!open SERIES, "<", $series) {
1224 die "$series $!" unless $!==ENOENT;
1233 Unfortunately, this source package uses a feature of dpkg-source where
1234 the same source package unpacks to different source code on different
1235 distros. dgit cannot safely operate on such packages on affected
1236 distros, because the meaning of source packages is not stable.
1238 Please ask the distro/maintainer to remove the distro-specific series
1239 files and use a different technique (if necessary, uploading actually
1240 different packages, if different distros are supposed to have
1244 fail "Found active distro-specific series file for".
1245 " $checkdistro ($what): $series, cannot continue";
1247 die "$series $!" if SERIES->error;
1251 sub check_for_vendor_patches () {
1252 # This dpkg-source feature doesn't seem to be documented anywhere!
1253 # But it can be found in the changelog (reformatted):
1255 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1256 # Author: Raphael Hertzog <hertzog@debian.org>
1257 # Date: Sun Oct 3 09:36:48 2010 +0200
1259 # dpkg-source: correctly create .pc/.quilt_series with alternate
1262 # If you have debian/patches/ubuntu.series and you were
1263 # unpacking the source package on ubuntu, quilt was still
1264 # directed to debian/patches/series instead of
1265 # debian/patches/ubuntu.series.
1267 # debian/changelog | 3 +++
1268 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1269 # 2 files changed, 6 insertions(+), 1 deletion(-)
1272 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1273 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1274 "Dpkg::Vendor \`current vendor'");
1275 vendor_patches_distro(access_basedistro(),
1276 "distro being accessed");
1279 sub generate_commit_from_dsc () {
1283 foreach my $fi (dsc_files_info()) {
1284 my $f = $fi->{Filename};
1285 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1287 link "../../../$f", $f
1291 complete_file_from_dsc('.', $fi);
1293 if (is_orig_file($f)) {
1294 link $f, "../../../../$f"
1300 my $dscfn = "$package.dsc";
1302 open D, ">", $dscfn or die "$dscfn: $!";
1303 print D $dscdata or die "$dscfn: $!";
1304 close D or die "$dscfn: $!";
1305 my @cmd = qw(dpkg-source);
1306 push @cmd, '--no-check' if $dsc_checked;
1307 push @cmd, qw(-x --), $dscfn;
1310 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1311 check_for_vendor_patches() if madformat($dsc->{format});
1312 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1313 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1314 my $authline = clogp_authline $clogp;
1315 my $changes = getfield $clogp, 'Changes';
1316 open C, ">../commit.tmp" or die $!;
1317 print C <<END or die $!;
1324 # imported from the archive
1327 my $outputhash = make_commit qw(../commit.tmp);
1328 my $cversion = getfield $clogp, 'Version';
1329 progress "synthesised git commit from .dsc $cversion";
1330 if ($lastpush_hash) {
1331 runcmd @git, qw(reset --hard), $lastpush_hash;
1332 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1333 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1334 my $oversion = getfield $oldclogp, 'Version';
1336 version_compare($oversion, $cversion);
1338 # git upload/ is earlier vsn than archive, use archive
1339 open C, ">../commit2.tmp" or die $!;
1340 print C <<END or die $!;
1342 parent $lastpush_hash
1347 Record $package ($cversion) in archive suite $csuite
1349 $outputhash = make_commit qw(../commit2.tmp);
1350 } elsif ($vcmp > 0) {
1351 print STDERR <<END or die $!;
1353 Version actually in archive: $cversion (older)
1354 Last allegedly pushed/uploaded: $oversion (newer or same)
1357 $outputhash = $lastpush_hash;
1359 $outputhash = $lastpush_hash;
1362 changedir '../../../..';
1363 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1364 'DGIT_ARCHIVE', $outputhash;
1365 cmdoutput @git, qw(log -n2), $outputhash;
1366 # ... gives git a chance to complain if our commit is malformed
1371 sub complete_file_from_dsc ($$) {
1372 our ($dstdir, $fi) = @_;
1373 # Ensures that we have, in $dir, the file $fi, with the correct
1374 # contents. (Downloading it from alongside $dscurl if necessary.)
1376 my $f = $fi->{Filename};
1377 my $tf = "$dstdir/$f";
1380 if (stat_exists $tf) {
1381 progress "using existing $f";
1384 $furl =~ s{/[^/]+$}{};
1386 die "$f ?" unless $f =~ m/^${package}_/;
1387 die "$f ?" if $f =~ m#/#;
1388 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1389 next if !act_local();
1393 open F, "<", "$tf" or die "$tf: $!";
1394 $fi->{Digester}->reset();
1395 $fi->{Digester}->addfile(*F);
1396 F->error and die $!;
1397 my $got = $fi->{Digester}->hexdigest();
1398 $got eq $fi->{Hash} or
1399 fail "file $f has hash $got but .dsc".
1400 " demands hash $fi->{Hash} ".
1401 ($downloaded ? "(got wrong file from archive!)"
1402 : "(perhaps you should delete this file?)");
1405 sub ensure_we_have_orig () {
1406 foreach my $fi (dsc_files_info()) {
1407 my $f = $fi->{Filename};
1408 next unless is_orig_file($f);
1409 complete_file_from_dsc('..', $fi);
1413 sub git_fetch_us () {
1414 my @specs = (fetchspec());
1416 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1418 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1421 my $tagpat = debiantag('*',access_basedistro);
1423 git_for_each_ref("refs/tags/".$tagpat, sub {
1424 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1425 printdebug "currently $fullrefname=$objid\n";
1426 $here{$fullrefname} = $objid;
1428 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1429 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1430 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1431 printdebug "offered $lref=$objid\n";
1432 if (!defined $here{$lref}) {
1433 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1434 runcmd_ordryrun_local @upd;
1435 } elsif ($here{$lref} eq $objid) {
1438 "Not updateting $lref from $here{$lref} to $objid.\n";
1443 sub fetch_from_archive () {
1444 # ensures that lrref() is what is actually in the archive,
1445 # one way or another
1449 foreach my $field (@ourdscfield) {
1450 $dsc_hash = $dsc->{$field};
1451 last if defined $dsc_hash;
1453 if (defined $dsc_hash) {
1454 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1456 progress "last upload to archive specified git hash";
1458 progress "last upload to archive has NO git hash";
1461 progress "no version available from the archive";
1464 $lastpush_hash = git_get_ref(lrref());
1465 printdebug "previous reference hash=$lastpush_hash\n";
1467 if (defined $dsc_hash) {
1468 fail "missing remote git history even though dsc has hash -".
1469 " could not find ref ".lrref().
1470 " (should have been fetched from ".access_giturl()."#".rrref().")"
1471 unless $lastpush_hash;
1473 ensure_we_have_orig();
1474 if ($dsc_hash eq $lastpush_hash) {
1475 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1476 print STDERR <<END or die $!;
1478 Git commit in archive is behind the last version allegedly pushed/uploaded.
1479 Commit referred to by archive: $dsc_hash
1480 Last allegedly pushed/uploaded: $lastpush_hash
1483 $hash = $lastpush_hash;
1485 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1486 "descendant of archive's .dsc hash ($dsc_hash)";
1489 $hash = generate_commit_from_dsc();
1490 } elsif ($lastpush_hash) {
1491 # only in git, not in the archive yet
1492 $hash = $lastpush_hash;
1493 print STDERR <<END or die $!;
1495 Package not found in the archive, but has allegedly been pushed using dgit.
1499 printdebug "nothing found!\n";
1500 if (defined $skew_warning_vsn) {
1501 print STDERR <<END or die $!;
1503 Warning: relevant archive skew detected.
1504 Archive allegedly contains $skew_warning_vsn
1505 But we were not able to obtain any version from the archive or git.
1511 printdebug "current hash=$hash\n";
1512 if ($lastpush_hash) {
1513 fail "not fast forward on last upload branch!".
1514 " (archive's version left in DGIT_ARCHIVE)"
1515 unless is_fast_fwd($lastpush_hash, $hash);
1517 if (defined $skew_warning_vsn) {
1519 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1520 my $clogf = ".git/dgit/changelog.tmp";
1521 runcmd shell_cmd "exec >$clogf",
1522 @git, qw(cat-file blob), "$hash:debian/changelog";
1523 my $gotclogp = parsechangelog("-l$clogf");
1524 my $got_vsn = getfield $gotclogp, 'Version';
1525 printdebug "SKEW CHECK GOT $got_vsn\n";
1526 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1527 print STDERR <<END or die $!;
1529 Warning: archive skew detected. Using the available version:
1530 Archive allegedly contains $skew_warning_vsn
1531 We were able to obtain only $got_vsn
1536 if ($lastpush_hash ne $hash) {
1537 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1541 dryrun_report @upd_cmd;
1547 sub set_local_git_config ($$) {
1549 runcmd @git, qw(config), $k, $v;
1552 sub setup_mergechangelogs () {
1553 my $driver = 'dpkg-mergechangelogs';
1554 my $cb = "merge.$driver";
1555 my $attrs = '.git/info/attributes';
1556 ensuredir '.git/info';
1558 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1559 if (!open ATTRS, "<", $attrs) {
1560 $!==ENOENT or die "$attrs: $!";
1564 next if m{^debian/changelog\s};
1565 print NATTRS $_, "\n" or die $!;
1567 ATTRS->error and die $!;
1570 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1573 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1574 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1576 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1581 canonicalise_suite();
1582 badusage "dry run makes no sense with clone" unless act_local();
1583 my $hasgit = check_for_git();
1584 mkdir $dstdir or die "$dstdir $!";
1586 runcmd @git, qw(init -q);
1587 my $giturl = access_giturl(1);
1588 if (defined $giturl) {
1589 set_local_git_config "remote.$remotename.fetch", fetchspec();
1590 open H, "> .git/HEAD" or die $!;
1591 print H "ref: ".lref()."\n" or die $!;
1593 runcmd @git, qw(remote add), 'origin', $giturl;
1596 progress "fetching existing git history";
1598 runcmd_ordryrun_local @git, qw(fetch origin);
1600 progress "starting new git history";
1602 fetch_from_archive() or no_such_package;
1603 my $vcsgiturl = $dsc->{'Vcs-Git'};
1604 if (length $vcsgiturl) {
1605 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1606 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1608 setup_mergechangelogs();
1609 runcmd @git, qw(reset --hard), lrref();
1610 printdone "ready for work in $dstdir";
1614 if (check_for_git()) {
1617 fetch_from_archive() or no_such_package();
1618 printdone "fetched into ".lrref();
1623 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1625 printdone "fetched to ".lrref()." and merged into HEAD";
1628 sub check_not_dirty () {
1629 return if $ignoredirty;
1630 my @cmd = (@git, qw(diff --quiet HEAD));
1632 $!=0; $?=0; system @cmd;
1633 return if !$! && !$?;
1634 if (!$! && $?==256) {
1635 fail "working tree is dirty (does not match HEAD)";
1641 sub commit_admin ($) {
1644 runcmd_ordryrun_local @git, qw(commit -m), $m;
1647 sub commit_quilty_patch () {
1648 my $output = cmdoutput @git, qw(status --porcelain);
1650 foreach my $l (split /\n/, $output) {
1651 next unless $l =~ m/\S/;
1652 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1656 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1658 progress "nothing quilty to commit, ok.";
1661 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1662 commit_admin "Commit Debian 3.0 (quilt) metadata";
1665 sub get_source_format () {
1666 if (!open F, "debian/source/format") {
1667 die $! unless $!==&ENOENT;
1671 F->error and die $!;
1678 return 0 unless $format eq '3.0 (quilt)';
1679 if ($quilt_mode eq 'nocheck') {
1680 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1683 progress "Format \`$format', checking/updating patch stack";
1687 sub push_parse_changelog ($) {
1690 my $clogp = Dpkg::Control::Hash->new();
1691 $clogp->load($clogpfn) or die;
1693 $package = getfield $clogp, 'Source';
1694 my $cversion = getfield $clogp, 'Version';
1695 my $tag = debiantag($cversion, access_basedistro);
1696 runcmd @git, qw(check-ref-format), $tag;
1698 my $dscfn = dscfn($cversion);
1700 return ($clogp, $cversion, $tag, $dscfn);
1703 sub push_parse_dsc ($$$) {
1704 my ($dscfn,$dscfnwhat, $cversion) = @_;
1705 $dsc = parsecontrol($dscfn,$dscfnwhat);
1706 my $dversion = getfield $dsc, 'Version';
1707 my $dscpackage = getfield $dsc, 'Source';
1708 ($dscpackage eq $package && $dversion eq $cversion) or
1709 fail "$dscfn is for $dscpackage $dversion".
1710 " but debian/changelog is for $package $cversion";
1713 sub push_mktag ($$$$$$$) {
1714 my ($head,$clogp,$tag,
1716 $changesfile,$changesfilewhat,
1719 $dsc->{$ourdscfield[0]} = $head;
1720 $dsc->save("$dscfn.tmp") or die $!;
1722 my $changes = parsecontrol($changesfile,$changesfilewhat);
1723 foreach my $field (qw(Source Distribution Version)) {
1724 $changes->{$field} eq $clogp->{$field} or
1725 fail "changes field $field \`$changes->{$field}'".
1726 " does not match changelog \`$clogp->{$field}'";
1729 my $cversion = getfield $clogp, 'Version';
1730 my $clogsuite = getfield $clogp, 'Distribution';
1732 # We make the git tag by hand because (a) that makes it easier
1733 # to control the "tagger" (b) we can do remote signing
1734 my $authline = clogp_authline $clogp;
1735 my $delibs = join(" ", "",@deliberatelies);
1736 my $declaredistro = access_basedistro();
1737 open TO, '>', $tfn->('.tmp') or die $!;
1738 print TO <<END or die $!;
1744 $package release $cversion for $clogsuite ($csuite) [dgit]
1745 [dgit distro=$declaredistro$delibs]
1747 foreach my $ref (sort keys %previously) {
1748 print TO <<END or die $!;
1749 [dgit previously:$ref=$previously{$ref}]
1755 my $tagobjfn = $tfn->('.tmp');
1757 if (!defined $keyid) {
1758 $keyid = access_cfg('keyid','RETURN-UNDEF');
1760 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1761 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1762 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1763 push @sign_cmd, $tfn->('.tmp');
1764 runcmd_ordryrun @sign_cmd;
1766 $tagobjfn = $tfn->('.signed.tmp');
1767 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1768 $tfn->('.tmp'), $tfn->('.tmp.asc');
1775 sub sign_changes ($) {
1776 my ($changesfile) = @_;
1778 my @debsign_cmd = @debsign;
1779 push @debsign_cmd, "-k$keyid" if defined $keyid;
1780 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1781 push @debsign_cmd, $changesfile;
1782 runcmd_ordryrun @debsign_cmd;
1787 my ($forceflag) = @_;
1788 printdebug "actually entering push\n";
1791 access_giturl(); # check that success is vaguely likely
1793 my $clogpfn = ".git/dgit/changelog.822.tmp";
1794 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1796 responder_send_file('parsed-changelog', $clogpfn);
1798 my ($clogp, $cversion, $tag, $dscfn) =
1799 push_parse_changelog("$clogpfn");
1801 my $dscpath = "$buildproductsdir/$dscfn";
1802 stat_exists $dscpath or
1803 fail "looked for .dsc $dscfn, but $!;".
1804 " maybe you forgot to build";
1806 responder_send_file('dsc', $dscpath);
1808 push_parse_dsc($dscpath, $dscfn, $cversion);
1810 my $format = getfield $dsc, 'Format';
1811 printdebug "format $format\n";
1812 if (madformat($format)) {
1813 commit_quilty_patch();
1817 progress "checking that $dscfn corresponds to HEAD";
1818 runcmd qw(dpkg-source -x --),
1819 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1820 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1821 check_for_vendor_patches() if madformat($dsc->{format});
1822 changedir '../../../..';
1823 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1824 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1825 debugcmd "+",@diffcmd;
1827 my $r = system @diffcmd;
1830 fail "$dscfn specifies a different tree to your HEAD commit;".
1831 " perhaps you forgot to build".
1832 ($diffopt eq '--exit-code' ? "" :
1833 " (run with -D to see full diff output)");
1838 my $head = git_rev_parse('HEAD');
1839 if (!$changesfile) {
1840 my $multi = "$buildproductsdir/".
1841 "${package}_".(stripepoch $cversion)."_multi.changes";
1842 if (stat_exists "$multi") {
1843 $changesfile = $multi;
1845 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1846 my @cs = glob "$buildproductsdir/$pat";
1847 fail "failed to find unique changes file".
1848 " (looked for $pat in $buildproductsdir, or $multi);".
1849 " perhaps you need to use dgit -C"
1851 ($changesfile) = @cs;
1854 $changesfile = "$buildproductsdir/$changesfile";
1857 responder_send_file('changes',$changesfile);
1858 responder_send_command("param head $head");
1859 responder_send_command("param csuite $csuite");
1861 if (deliberately_not_fast_forward) {
1862 git_for_each_ref(lrfetchrefs, sub {
1863 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1864 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1865 responder_send_command("previously $rrefname=$objid");
1866 $previously{$rrefname} = $objid;
1870 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1873 if ($we_are_responder) {
1874 $tagobjfn = $tfn->('.signed.tmp');
1875 responder_receive_files('signed-tag', $tagobjfn);
1878 push_mktag($head,$clogp,$tag,
1880 $changesfile,$changesfile,
1884 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1885 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1886 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1888 if (!check_for_git()) {
1889 create_remote_git_repo();
1891 runcmd_ordryrun @git, qw(push),access_giturl(),
1892 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1893 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1895 if ($we_are_responder) {
1896 my $dryrunsuffix = act_local() ? "" : ".tmp";
1897 responder_receive_files('signed-dsc-changes',
1898 "$dscpath$dryrunsuffix",
1899 "$changesfile$dryrunsuffix");
1902 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1904 progress "[new .dsc left in $dscpath.tmp]";
1906 sign_changes $changesfile;
1909 my $host = access_cfg('upload-host','RETURN-UNDEF');
1910 my @hostarg = defined($host) ? ($host,) : ();
1911 runcmd_ordryrun @dput, @hostarg, $changesfile;
1912 printdone "pushed and uploaded $cversion";
1914 responder_send_command("complete");
1920 badusage "-p is not allowed with clone; specify as argument instead"
1921 if defined $package;
1924 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1925 ($package,$isuite) = @ARGV;
1926 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1927 ($package,$dstdir) = @ARGV;
1928 } elsif (@ARGV==3) {
1929 ($package,$isuite,$dstdir) = @ARGV;
1931 badusage "incorrect arguments to dgit clone";
1933 $dstdir ||= "$package";
1935 if (stat_exists $dstdir) {
1936 fail "$dstdir already exists";
1940 if ($rmonerror && !$dryrun_level) {
1941 $cwd_remove= getcwd();
1943 return unless defined $cwd_remove;
1944 if (!chdir "$cwd_remove") {
1945 return if $!==&ENOENT;
1946 die "chdir $cwd_remove: $!";
1948 rmtree($dstdir) or die "remove $dstdir: $!\n";
1953 $cwd_remove = undef;
1956 sub branchsuite () {
1957 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1958 if ($branch =~ m#$lbranch_re#o) {
1965 sub fetchpullargs () {
1966 if (!defined $package) {
1967 my $sourcep = parsecontrol('debian/control','debian/control');
1968 $package = getfield $sourcep, 'Source';
1971 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1973 my $clogp = parsechangelog();
1974 $isuite = getfield $clogp, 'Distribution';
1976 canonicalise_suite();
1977 progress "fetching from suite $csuite";
1978 } elsif (@ARGV==1) {
1980 canonicalise_suite();
1982 badusage "incorrect arguments to dgit fetch or dgit pull";
2001 badusage "-p is not allowed with dgit push" if defined $package;
2003 my $clogp = parsechangelog();
2004 $package = getfield $clogp, 'Source';
2007 } elsif (@ARGV==1) {
2008 ($specsuite) = (@ARGV);
2010 badusage "incorrect arguments to dgit push";
2012 $isuite = getfield $clogp, 'Distribution';
2014 local ($package) = $existing_package; # this is a hack
2015 canonicalise_suite();
2017 canonicalise_suite();
2019 if (defined $specsuite &&
2020 $specsuite ne $isuite &&
2021 $specsuite ne $csuite) {
2022 fail "dgit push: changelog specifies $isuite ($csuite)".
2023 " but command line specifies $specsuite";
2025 if (check_for_git()) {
2029 if (fetch_from_archive()) {
2030 if (is_fast_fwd(lrref(), 'HEAD')) {
2032 } elsif (deliberately_not_fast_forward) {
2035 fail "dgit push: HEAD is not a descendant".
2036 " of the archive's version.\n".
2037 "dgit: To overwrite its contents,".
2038 " use git merge -s ours ".lrref().".\n".
2039 "dgit: To rewind history, if permitted by the archive,".
2040 " use --deliberately-not-fast-forward";
2044 fail "package appears to be new in this suite;".
2045 " if this is intentional, use --new";
2050 #---------- remote commands' implementation ----------
2052 sub cmd_remote_push_build_host {
2054 my ($nrargs) = shift @ARGV;
2055 my (@rargs) = @ARGV[0..$nrargs-1];
2056 @ARGV = @ARGV[$nrargs..$#ARGV];
2058 my ($dir,$vsnwant) = @rargs;
2059 # vsnwant is a comma-separated list; we report which we have
2060 # chosen in our ready response (so other end can tell if they
2063 $we_are_responder = 1;
2064 $us .= " (build host)";
2066 open PI, "<&STDIN" or die $!;
2067 open STDIN, "/dev/null" or die $!;
2068 open PO, ">&STDOUT" or die $!;
2070 open STDOUT, ">&STDERR" or die $!;
2074 fail "build host has dgit rpush protocol version".
2075 " $rpushprotovsn but invocation host has $vsnwant"
2076 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2078 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2084 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2085 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2086 # a good error message)
2092 my $report = i_child_report();
2093 if (defined $report) {
2094 printdebug "($report)\n";
2095 } elsif ($i_child_pid) {
2096 printdebug "(killing build host child $i_child_pid)\n";
2097 kill 15, $i_child_pid;
2099 if (defined $i_tmp && !defined $initiator_tempdir) {
2101 eval { rmtree $i_tmp; };
2105 END { i_cleanup(); }
2108 my ($base,$selector,@args) = @_;
2109 $selector =~ s/\-/_/g;
2110 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2117 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2124 my @rargs = ($dir,$rpushprotovsn);
2127 push @rdgit, @ropts;
2128 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2130 my @cmd = (@ssh, $host, shellquote @rdgit);
2133 if (defined $initiator_tempdir) {
2134 rmtree $initiator_tempdir;
2135 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2136 $i_tmp = $initiator_tempdir;
2140 $i_child_pid = open2(\*RO, \*RI, @cmd);
2142 initiator_expect { m/^dgit-remote-push-ready/ };
2144 my ($icmd,$iargs) = initiator_expect {
2145 m/^(\S+)(?: (.*))?$/;
2148 i_method "i_resp", $icmd, $iargs;
2152 sub i_resp_progress ($) {
2154 my $msg = protocol_read_bytes \*RO, $rhs;
2158 sub i_resp_complete {
2159 my $pid = $i_child_pid;
2160 $i_child_pid = undef; # prevents killing some other process with same pid
2161 printdebug "waiting for build host child $pid...\n";
2162 my $got = waitpid $pid, 0;
2163 die $! unless $got == $pid;
2164 die "build host child failed $?" if $?;
2167 printdebug "all done\n";
2171 sub i_resp_file ($) {
2173 my $localname = i_method "i_localname", $keyword;
2174 my $localpath = "$i_tmp/$localname";
2175 stat_exists $localpath and
2176 badproto \*RO, "file $keyword ($localpath) twice";
2177 protocol_receive_file \*RO, $localpath;
2178 i_method "i_file", $keyword;
2183 sub i_resp_param ($) {
2184 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2188 sub i_resp_previously ($) {
2189 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2190 or badproto \*RO, "bad previously spec";
2191 my $r = system qw(git check-ref-format), $1;
2192 die "bad previously ref spec ($r)" if $r;
2193 $previously{$1} = $2;
2198 sub i_resp_want ($) {
2200 die "$keyword ?" if $i_wanted{$keyword}++;
2201 my @localpaths = i_method "i_want", $keyword;
2202 printdebug "[[ $keyword @localpaths\n";
2203 foreach my $localpath (@localpaths) {
2204 protocol_send_file \*RI, $localpath;
2206 print RI "files-end\n" or die $!;
2209 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2211 sub i_localname_parsed_changelog {
2212 return "remote-changelog.822";
2214 sub i_file_parsed_changelog {
2215 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2216 push_parse_changelog "$i_tmp/remote-changelog.822";
2217 die if $i_dscfn =~ m#/|^\W#;
2220 sub i_localname_dsc {
2221 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2226 sub i_localname_changes {
2227 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2228 $i_changesfn = $i_dscfn;
2229 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2230 return $i_changesfn;
2232 sub i_file_changes { }
2234 sub i_want_signed_tag {
2235 printdebug Dumper(\%i_param, $i_dscfn);
2236 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2237 && defined $i_param{'csuite'}
2238 or badproto \*RO, "premature desire for signed-tag";
2239 my $head = $i_param{'head'};
2240 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2242 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2244 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2247 push_mktag $head, $i_clogp, $i_tag,
2249 $i_changesfn, 'remote changes',
2250 sub { "tag$_[0]"; };
2255 sub i_want_signed_dsc_changes {
2256 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2257 sign_changes $i_changesfn;
2258 return ($i_dscfn, $i_changesfn);
2261 #---------- building etc. ----------
2267 #----- `3.0 (quilt)' handling -----
2269 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2271 sub quiltify_dpkg_commit ($$$;$) {
2272 my ($patchname,$author,$msg, $xinfo) = @_;
2276 my $descfn = ".git/dgit/quilt-description.tmp";
2277 open O, '>', $descfn or die "$descfn: $!";
2280 $msg =~ s/^\s+$/ ./mg;
2281 print O <<END or die $!;
2291 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2292 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2293 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2294 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2298 sub quiltify_trees_differ ($$) {
2300 # returns 1 iff the two tree objects differ other than in debian/
2302 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2303 my $diffs= cmdoutput @cmd;
2304 foreach my $f (split /\0/, $diffs) {
2305 next if $f eq 'debian';
2311 sub quiltify_tree_sentinelfiles ($) {
2312 # lists the `sentinel' files present in the tree
2314 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2315 qw(-- debian/rules debian/control);
2321 my ($clogp,$target) = @_;
2323 # Quilt patchification algorithm
2325 # We search backwards through the history of the main tree's HEAD
2326 # (T) looking for a start commit S whose tree object is identical
2327 # to to the patch tip tree (ie the tree corresponding to the
2328 # current dpkg-committed patch series). For these purposes
2329 # `identical' disregards anything in debian/ - this wrinkle is
2330 # necessary because dpkg-source treates debian/ specially.
2332 # We can only traverse edges where at most one of the ancestors'
2333 # trees differs (in changes outside in debian/). And we cannot
2334 # handle edges which change .pc/ or debian/patches. To avoid
2335 # going down a rathole we avoid traversing edges which introduce
2336 # debian/rules or debian/control. And we set a limit on the
2337 # number of edges we are willing to look at.
2339 # If we succeed, we walk forwards again. For each traversed edge
2340 # PC (with P parent, C child) (starting with P=S and ending with
2341 # C=T) to we do this:
2343 # - dpkg-source --commit with a patch name and message derived from C
2344 # After traversing PT, we git commit the changes which
2345 # should be contained within debian/patches.
2347 changedir '../fake';
2348 mktree_in_ud_here();
2350 runcmd @git, 'add', '.';
2351 my $oldtiptree=git_write_tree();
2352 changedir '../work';
2354 # The search for the path S..T is breadth-first. We maintain a
2355 # todo list containing search nodes. A search node identifies a
2356 # commit, and looks something like this:
2358 # Commit => $git_commit_id,
2359 # Child => $c, # or undef if P=T
2360 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2361 # Nontrivial => true iff $p..$c has relevant changes
2368 my %considered; # saves being exponential on some weird graphs
2370 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2373 my ($search,$whynot) = @_;
2374 printdebug " search NOT $search->{Commit} $whynot\n";
2375 $search->{Whynot} = $whynot;
2376 push @nots, $search;
2377 no warnings qw(exiting);
2386 my $c = shift @todo;
2387 next if $considered{$c->{Commit}}++;
2389 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2391 printdebug "quiltify investigate $c->{Commit}\n";
2394 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2395 printdebug " search finished hooray!\n";
2400 if ($quilt_mode eq 'nofix') {
2401 fail "quilt fixup required but quilt mode is \`nofix'\n".
2402 "HEAD commit $c->{Commit} differs from tree implied by ".
2403 " debian/patches (tree object $oldtiptree)";
2405 if ($quilt_mode eq 'smash') {
2406 printdebug " search quitting smash\n";
2410 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2411 $not->($c, "has $c_sentinels not $t_sentinels")
2412 if $c_sentinels ne $t_sentinels;
2414 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2415 $commitdata =~ m/\n\n/;
2417 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2418 @parents = map { { Commit => $_, Child => $c } } @parents;
2420 $not->($c, "root commit") if !@parents;
2422 foreach my $p (@parents) {
2423 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2425 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2426 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2428 foreach my $p (@parents) {
2429 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2431 my @cmd= (@git, qw(diff-tree -r --name-only),
2432 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2433 my $patchstackchange = cmdoutput @cmd;
2434 if (length $patchstackchange) {
2435 $patchstackchange =~ s/\n/,/g;
2436 $not->($p, "changed $patchstackchange");
2439 printdebug " search queue P=$p->{Commit} ",
2440 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2446 printdebug "quiltify want to smash\n";
2449 my $x = $_[0]{Commit};
2450 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2453 my $reportnot = sub {
2455 my $s = $abbrev->($notp);
2456 my $c = $notp->{Child};
2457 $s .= "..".$abbrev->($c) if $c;
2458 $s .= ": ".$notp->{Whynot};
2461 if ($quilt_mode eq 'linear') {
2462 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2463 foreach my $notp (@nots) {
2464 print STDERR "$us: ", $reportnot->($notp), "\n";
2466 fail "quilt fixup naive history linearisation failed.\n".
2467 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2468 } elsif ($quilt_mode eq 'smash') {
2469 } elsif ($quilt_mode eq 'auto') {
2470 progress "quilt fixup cannot be linear, smashing...";
2472 die "$quilt_mode ?";
2477 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2479 quiltify_dpkg_commit "auto-$version-$target-$time",
2480 (getfield $clogp, 'Maintainer'),
2481 "Automatically generated patch ($clogp->{Version})\n".
2482 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2486 progress "quiltify linearisation planning successful, executing...";
2488 for (my $p = $sref_S;
2489 my $c = $p->{Child};
2491 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2492 next unless $p->{Nontrivial};
2494 my $cc = $c->{Commit};
2496 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2497 $commitdata =~ m/\n\n/ or die "$c ?";
2500 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2503 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2506 my $patchname = $title;
2507 $patchname =~ s/[.:]$//;
2508 $patchname =~ y/ A-Z/-a-z/;
2509 $patchname =~ y/-a-z0-9_.+=~//cd;
2510 $patchname =~ s/^\W/x-$&/;
2511 $patchname = substr($patchname,0,40);
2514 stat "debian/patches/$patchname$index";
2516 $!==ENOENT or die "$patchname$index $!";
2518 runcmd @git, qw(checkout -q), $cc;
2520 # We use the tip's changelog so that dpkg-source doesn't
2521 # produce complaining messages from dpkg-parsechangelog. None
2522 # of the information dpkg-source gets from the changelog is
2523 # actually relevant - it gets put into the original message
2524 # which dpkg-source provides our stunt editor, and then
2526 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2528 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2529 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2531 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2534 runcmd @git, qw(checkout -q master);
2537 sub build_maybe_quilt_fixup () {
2538 my $format=get_source_format;
2539 return unless madformat $format;
2542 check_for_vendor_patches();
2545 # - honour any existing .pc in case it has any strangeness
2546 # - determine the git commit corresponding to the tip of
2547 # the patch stack (if there is one)
2548 # - if there is such a git commit, convert each subsequent
2549 # git commit into a quilt patch with dpkg-source --commit
2550 # - otherwise convert all the differences in the tree into
2551 # a single git commit
2555 # Our git tree doesn't necessarily contain .pc. (Some versions of
2556 # dgit would include the .pc in the git tree.) If there isn't
2557 # one, we need to generate one by unpacking the patches that we
2560 # We first look for a .pc in the git tree. If there is one, we
2561 # will use it. (This is not the normal case.)
2563 # Otherwise need to regenerate .pc so that dpkg-source --commit
2564 # can work. We do this as follows:
2565 # 1. Collect all relevant .orig from parent directory
2566 # 2. Generate a debian.tar.gz out of
2567 # debian/{patches,rules,source/format}
2568 # 3. Generate a fake .dsc containing just these fields:
2569 # Format Source Version Files
2570 # 4. Extract the fake .dsc
2571 # Now the fake .dsc has a .pc directory.
2572 # (In fact we do this in every case, because in future we will
2573 # want to search for a good base commit for generating patches.)
2575 # Then we can actually do the dpkg-source --commit
2576 # 1. Make a new working tree with the same object
2577 # store as our main tree and check out the main
2579 # 2. Copy .pc from the fake's extraction, if necessary
2580 # 3. Run dpkg-source --commit
2581 # 4. If the result has changes to debian/, then
2582 # - git-add them them
2583 # - git-add .pc if we had a .pc in-tree
2585 # 5. If we had a .pc in-tree, delete it, and git-commit
2586 # 6. Back in the main tree, fast forward to the new HEAD
2588 my $clogp = parsechangelog();
2589 my $headref = git_rev_parse('HEAD');
2594 my $upstreamversion=$version;
2595 $upstreamversion =~ s/-[^-]*$//;
2597 my $fakeversion="$upstreamversion-~~DGITFAKE";
2599 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2600 print $fakedsc <<END or die $!;
2603 Version: $fakeversion
2607 my $dscaddfile=sub {
2610 my $md = new Digest::MD5;
2612 my $fh = new IO::File $b, '<' or die "$b $!";
2617 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2620 foreach my $f (<../../../../*>) { #/){
2621 my $b=$f; $b =~ s{.*/}{};
2622 next unless is_orig_file $b, srcfn $upstreamversion,'';
2623 link $f, $b or die "$b $!";
2627 my @files=qw(debian/source/format debian/rules);
2628 if (stat_exists '../../../debian/patches') {
2629 push @files, 'debian/patches';
2632 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2633 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2635 $dscaddfile->($debtar);
2636 close $fakedsc or die $!;
2638 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2640 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2641 rename $fakexdir, "fake" or die "$fakexdir $!";
2643 mkdir "work" or die $!;
2645 mktree_in_ud_here();
2646 runcmd @git, qw(reset --hard), $headref;
2649 if (stat_exists ".pc") {
2651 progress "Tree already contains .pc - will use it then delete it.";
2654 rename '../fake/.pc','.pc' or die $!;
2657 quiltify($clogp,$headref);
2659 if (!open P, '>>', ".pc/applied-patches") {
2660 $!==&ENOENT or die $!;
2665 commit_quilty_patch();
2667 if ($mustdeletepc) {
2668 runcmd @git, qw(rm -rqf .pc);
2669 commit_admin "Commit removal of .pc (quilt series tracking data)";
2672 changedir '../../../..';
2673 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2676 sub quilt_fixup_editor () {
2677 my $descfn = $ENV{$fakeeditorenv};
2678 my $editing = $ARGV[$#ARGV];
2679 open I1, '<', $descfn or die "$descfn: $!";
2680 open I2, '<', $editing or die "$editing: $!";
2681 unlink $editing or die "$editing: $!";
2682 open O, '>', $editing or die "$editing: $!";
2683 while (<I1>) { print O or die $!; } I1->error and die $!;
2686 $copying ||= m/^\-\-\- /;
2687 next unless $copying;
2690 I2->error and die $!;
2695 #----- other building -----
2698 if ($cleanmode eq 'dpkg-source') {
2699 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2700 } elsif ($cleanmode eq 'dpkg-source-d') {
2701 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2702 } elsif ($cleanmode eq 'git') {
2703 runcmd_ordryrun_local @git, qw(clean -xdf);
2704 } elsif ($cleanmode eq 'git-ff') {
2705 runcmd_ordryrun_local @git, qw(clean -xdff);
2706 } elsif ($cleanmode eq 'check') {
2707 my $leftovers = cmdoutput @git, qw(clean -xdn);
2708 if (length $leftovers) {
2709 print STDERR $leftovers, "\n" or die $!;
2710 fail "tree contains uncommitted files and --clean=check specified";
2712 } elsif ($cleanmode eq 'none') {
2719 badusage "clean takes no additional arguments" if @ARGV;
2724 badusage "-p is not allowed when building" if defined $package;
2727 my $clogp = parsechangelog();
2728 $isuite = getfield $clogp, 'Distribution';
2729 $package = getfield $clogp, 'Source';
2730 $version = getfield $clogp, 'Version';
2731 build_maybe_quilt_fixup();
2734 sub changesopts () {
2735 my @opts =@changesopts[1..$#changesopts];
2736 if (!defined $changes_since_version) {
2737 my @vsns = archive_query('archive_query');
2738 my @quirk = access_quirk();
2739 if ($quirk[0] eq 'backports') {
2740 local $isuite = $quirk[2];
2742 canonicalise_suite();
2743 push @vsns, archive_query('archive_query');
2746 @vsns = map { $_->[0] } @vsns;
2747 @vsns = sort { -version_compare($a, $b) } @vsns;
2748 $changes_since_version = $vsns[0];
2749 progress "changelog will contain changes since $vsns[0]";
2751 $changes_since_version = '_';
2752 progress "package seems new, not specifying -v<version>";
2755 if ($changes_since_version ne '_') {
2756 unshift @opts, "-v$changes_since_version";
2761 sub massage_dbp_args ($) {
2763 return unless $cleanmode =~ m/git|none/;
2764 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2765 my @newcmd = shift @$cmd;
2766 # -nc has the side effect of specifying -b if nothing else specified
2767 push @newcmd, '-nc';
2768 # and some combinations of -S, -b, et al, are errors, rather than
2769 # later simply overriding earlier
2770 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2771 push @newcmd, @$cmd;
2777 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2778 massage_dbp_args \@dbp;
2779 runcmd_ordryrun_local @dbp;
2780 printdone "build successful\n";
2785 my @dbp = @dpkgbuildpackage;
2786 massage_dbp_args \@dbp;
2788 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2789 "--git-builder=@dbp");
2790 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2791 canonicalise_suite();
2792 push @cmd, "--git-debian-branch=".lbranch();
2794 push @cmd, changesopts();
2795 runcmd_ordryrun_local @cmd, @ARGV;
2796 printdone "build successful\n";
2801 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2802 $dscfn = dscfn($version);
2803 if ($cleanmode eq 'dpkg-source') {
2804 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2806 } elsif ($cleanmode eq 'dpkg-source-d') {
2807 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2810 my $pwd = must_getcwd();
2811 my $leafdir = basename $pwd;
2813 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2815 runcmd_ordryrun_local qw(sh -ec),
2816 'exec >$1; shift; exec "$@"','x',
2817 "../$sourcechanges",
2818 @dpkggenchanges, qw(-S), changesopts();
2822 sub cmd_build_source {
2823 badusage "build-source takes no additional arguments" if @ARGV;
2825 printdone "source built, results in $dscfn and $sourcechanges";
2831 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2833 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2834 stat_exists $sourcechanges
2835 or fail "$sourcechanges (in parent directory): $!";
2836 foreach my $cf (glob $pat) {
2837 next if $cf eq $sourcechanges;
2838 unlink $cf or fail "remove $cf: $!";
2841 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2842 my @changesfiles = glob $pat;
2843 @changesfiles = sort {
2844 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2847 fail "wrong number of different changes files (@changesfiles)"
2848 unless @changesfiles;
2849 runcmd_ordryrun_local @mergechanges, @changesfiles;
2850 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2852 stat_exists $multichanges or fail "$multichanges: $!";
2854 printdone "build successful, results in $multichanges\n" or die $!;
2857 sub cmd_quilt_fixup {
2858 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2859 my $clogp = parsechangelog();
2860 $version = getfield $clogp, 'Version';
2861 $package = getfield $clogp, 'Source';
2862 build_maybe_quilt_fixup();
2865 sub cmd_archive_api_query {
2866 badusage "need only 1 subpath argument" unless @ARGV==1;
2867 my ($subpath) = @ARGV;
2868 my @cmd = archive_api_query_cmd($subpath);
2870 exec @cmd or fail "exec curl: $!\n";
2873 sub cmd_clone_dgit_repos_server {
2874 badusage "need destination argument" unless @ARGV==1;
2875 my ($destdir) = @ARGV;
2876 $package = '_dgit-repos-server';
2877 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2879 exec @cmd or fail "exec git clone: $!\n";
2882 sub cmd_setup_mergechangelogs {
2883 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2884 setup_mergechangelogs();
2887 #---------- argument parsing and main program ----------
2890 print "dgit version $our_version\n" or die $!;
2897 if (defined $ENV{'DGIT_SSH'}) {
2898 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2899 } elsif (defined $ENV{'GIT_SSH'}) {
2900 @ssh = ($ENV{'GIT_SSH'});
2904 last unless $ARGV[0] =~ m/^-/;
2908 if (m/^--dry-run$/) {
2911 } elsif (m/^--damp-run$/) {
2914 } elsif (m/^--no-sign$/) {
2917 } elsif (m/^--help$/) {
2919 } elsif (m/^--version$/) {
2921 } elsif (m/^--new$/) {
2924 } elsif (m/^--since-version=([^_]+|_)$/) {
2926 $changes_since_version = $1;
2927 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2928 ($om = $opts_opt_map{$1}) &&
2932 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2933 !$opts_opt_cmdonly{$1} &&
2934 ($om = $opts_opt_map{$1})) {
2937 } elsif (m/^--existing-package=(.*)/s) {
2939 $existing_package = $1;
2940 } elsif (m/^--initiator-tempdir=(.*)/s) {
2941 $initiator_tempdir = $1;
2942 $initiator_tempdir =~ m#^/# or
2943 badusage "--initiator-tempdir must be used specify an".
2944 " absolute, not relative, directory."
2945 } elsif (m/^--distro=(.*)/s) {
2948 } elsif (m/^--build-products-dir=(.*)/s) {
2950 $buildproductsdir = $1;
2951 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2954 } elsif (m/^--clean=(.*)$/s) {
2955 badusage "unknown cleaning mode \`$1'";
2956 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2959 } elsif (m/^--quilt=(.*)$/s) {
2960 badusage "unknown quilt fixup mode \`$1'";
2961 } elsif (m/^--ignore-dirty$/s) {
2964 } elsif (m/^--no-quilt-fixup$/s) {
2966 $quilt_mode = 'nocheck';
2967 } elsif (m/^--no-rm-on-error$/s) {
2970 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2972 push @deliberatelies, $&;
2974 badusage "unknown long option \`$_'";
2981 } elsif (s/^-L/-/) {
2984 } elsif (s/^-h/-/) {
2986 } elsif (s/^-D/-/) {
2990 } elsif (s/^-N/-/) {
2993 } elsif (s/^-v([^_]+|_)$//s) {
2995 $changes_since_version = $1;
2998 push @changesopts, $_;
3000 } elsif (s/^-c(.*=.*)//s) {
3002 push @git, '-c', $1;
3003 } elsif (s/^-d(.+)//s) {
3006 } elsif (s/^-C(.+)//s) {
3009 if ($changesfile =~ s#^(.*)/##) {
3010 $buildproductsdir = $1;
3012 } elsif (s/^-k(.+)//s) {
3014 } elsif (m/^-[vdCk]$/) {
3016 "option \`$_' requires an argument (and no space before the argument)";
3017 } elsif (s/^-wn$//s) {
3019 $cleanmode = 'none';
3020 } elsif (s/^-wg$//s) {
3023 } elsif (s/^-wgf$//s) {
3025 $cleanmode = 'git-ff';
3026 } elsif (s/^-wd$//s) {
3028 $cleanmode = 'dpkg-source';
3029 } elsif (s/^-wdd$//s) {
3031 $cleanmode = 'dpkg-source-d';
3032 } elsif (s/^-wc$//s) {
3034 $cleanmode = 'check';
3036 badusage "unknown short option \`$_'";
3043 if ($ENV{$fakeeditorenv}) {
3044 quilt_fixup_editor();
3048 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3049 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3050 if $dryrun_level == 1;
3052 print STDERR $helpmsg or die $!;
3055 my $cmd = shift @ARGV;
3058 if (!defined $quilt_mode) {
3059 local $access_forpush;
3060 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3061 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3063 $quilt_mode =~ m/^($quilt_modes_re)$/
3064 or badcfg "unknown quilt-mode \`$quilt_mode'";
3068 my $fn = ${*::}{"cmd_$cmd"};
3069 $fn or badusage "unknown operation $cmd";