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/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
40 our $our_version = 'UNRELEASED'; ###substituted###
42 our $rpushprotovsn = 2;
44 our $isuite = 'unstable';
50 our $dryrun_level = 0;
52 our $buildproductsdir = '..';
58 our $existing_package = 'dpkg';
59 our $cleanmode = 'dpkg-source';
60 our $changes_since_version;
62 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
63 our $we_are_responder;
64 our $initiator_tempdir;
66 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
68 our $suite_re = '[-+.0-9a-z]+';
71 our (@dget) = qw(dget);
72 our (@curl) = qw(curl -f);
73 our (@dput) = qw(dput);
74 our (@debsign) = qw(debsign);
76 our (@sbuild) = qw(sbuild -A);
78 our (@dgit) = qw(dgit);
79 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
80 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
81 our (@dpkggenchanges) = qw(dpkg-genchanges);
82 our (@mergechanges) = qw(mergechanges -f);
83 our (@changesopts) = ('');
85 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
88 'debsign' => \@debsign,
93 'dpkg-source' => \@dpkgsource,
94 'dpkg-buildpackage' => \@dpkgbuildpackage,
95 'dpkg-genchanges' => \@dpkggenchanges,
96 'ch' => \@changesopts,
97 'mergechanges' => \@mergechanges);
99 our %opts_opt_cmdonly = ('gpg' => 1);
105 our $remotename = 'dgit';
106 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
110 sub lbranch () { return "$branchprefix/$csuite"; }
111 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
112 sub lref () { return "refs/heads/".lbranch(); }
113 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
114 sub rrref () { return server_ref($csuite); }
116 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
126 return "${package}_".(stripepoch $vsn).$sfx
131 return srcfn($vsn,".dsc");
140 foreach my $f (@end) {
142 warn "$us: cleanup: $@" if length $@;
146 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
148 sub no_such_package () {
149 print STDERR "$us: package $package does not exist in suite $isuite\n";
155 return "+".rrref().":".lrref();
160 printdebug "CD $newdir\n";
161 chdir $newdir or die "chdir: $newdir: $!";
164 sub deliberately ($) {
166 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
169 sub deliberately_not_fast_forward () {
170 foreach (qw(not-fast-forward fresh-repo)) {
171 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
175 #---------- remote protocol support, common ----------
177 # remote push initiator/responder protocol:
178 # < dgit-remote-push-ready [optional extra info ignored by old initiators]
180 # > file parsed-changelog
181 # [indicates that output of dpkg-parsechangelog follows]
182 # > data-block NBYTES
183 # > [NBYTES bytes of data (no newline)]
184 # [maybe some more blocks]
196 # [indicates that signed tag is wanted]
197 # < data-block NBYTES
198 # < [NBYTES bytes of data (no newline)]
199 # [maybe some more blocks]
203 # > want signed-dsc-changes
204 # < data-block NBYTES [transfer of signed dsc]
206 # < data-block NBYTES [transfer of signed changes]
214 sub i_child_report () {
215 # Sees if our child has died, and reap it if so. Returns a string
216 # describing how it died if it failed, or undef otherwise.
217 return undef unless $i_child_pid;
218 my $got = waitpid $i_child_pid, WNOHANG;
219 return undef if $got <= 0;
220 die unless $got == $i_child_pid;
221 $i_child_pid = undef;
222 return undef unless $?;
223 return "build host child ".waitstatusmsg();
228 fail "connection lost: $!" if $fh->error;
229 fail "protocol violation; $m not expected";
232 sub badproto_badread ($$) {
234 fail "connection lost: $!" if $!;
235 my $report = i_child_report();
236 fail $report if defined $report;
237 badproto $fh, "eof (reading $wh)";
240 sub protocol_expect (&$) {
241 my ($match, $fh) = @_;
244 defined && chomp or badproto_badread $fh, "protocol message";
252 badproto $fh, "\`$_'";
255 sub protocol_send_file ($$) {
256 my ($fh, $ourfn) = @_;
257 open PF, "<", $ourfn or die "$ourfn: $!";
260 my $got = read PF, $d, 65536;
261 die "$ourfn: $!" unless defined $got;
263 print $fh "data-block ".length($d)."\n" or die $!;
264 print $fh $d or die $!;
266 PF->error and die "$ourfn $!";
267 print $fh "data-end\n" or die $!;
271 sub protocol_read_bytes ($$) {
272 my ($fh, $nbytes) = @_;
273 $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
275 my $got = read $fh, $d, $nbytes;
276 $got==$nbytes or badproto_badread $fh, "data block";
280 sub protocol_receive_file ($$) {
281 my ($fh, $ourfn) = @_;
282 printdebug "() $ourfn\n";
283 open PF, ">", $ourfn or die "$ourfn: $!";
285 my ($y,$l) = protocol_expect {
286 m/^data-block (.*)$/ ? (1,$1) :
287 m/^data-end$/ ? (0,) :
291 my $d = protocol_read_bytes $fh, $l;
292 print PF $d or die $!;
297 #---------- remote protocol support, responder ----------
299 sub responder_send_command ($) {
301 return unless $we_are_responder;
302 # called even without $we_are_responder
303 printdebug ">> $command\n";
304 print PO $command, "\n" or die $!;
307 sub responder_send_file ($$) {
308 my ($keyword, $ourfn) = @_;
309 return unless $we_are_responder;
310 printdebug "]] $keyword $ourfn\n";
311 responder_send_command "file $keyword";
312 protocol_send_file \*PO, $ourfn;
315 sub responder_receive_files ($@) {
316 my ($keyword, @ourfns) = @_;
317 die unless $we_are_responder;
318 printdebug "[[ $keyword @ourfns\n";
319 responder_send_command "want $keyword";
320 foreach my $fn (@ourfns) {
321 protocol_receive_file \*PI, $fn;
324 protocol_expect { m/^files-end$/ } \*PI;
327 #---------- remote protocol support, initiator ----------
329 sub initiator_expect (&) {
331 protocol_expect { &$match } \*RO;
334 #---------- end remote code ----------
337 if ($we_are_responder) {
339 responder_send_command "progress ".length($m) or die $!;
340 print PO $m or die $!;
350 $ua = LWP::UserAgent->new();
354 progress "downloading $what...";
355 my $r = $ua->get(@_) or die $!;
356 return undef if $r->code == 404;
357 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
358 return $r->decoded_content(charset => 'none');
361 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
366 failedcmd @_ if system @_;
369 sub act_local () { return $dryrun_level <= 1; }
370 sub act_scary () { return !$dryrun_level; }
373 if (!$dryrun_level) {
374 progress "dgit ok: @_";
376 progress "would be ok: @_ (but dry run only)";
381 printcmd(\*STDERR,$debugprefix."#",@_);
384 sub runcmd_ordryrun {
392 sub runcmd_ordryrun_local {
401 my ($first_shell, @cmd) = @_;
402 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
405 our $helpmsg = <<END;
407 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
408 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
409 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
410 dgit [dgit-opts] push [dgit-opts] [suite]
411 dgit [dgit-opts] rpush build-host:build-dir ...
412 important dgit options:
413 -k<keyid> sign tag and package with <keyid> instead of default
414 --dry-run -n do not change anything, but go through the motions
415 --damp-run -L like --dry-run but make local changes, without signing
416 --new -N allow introducing a new package
417 --debug -D increase debug level
418 -c<name>=<value> set git config option (used directly by dgit too)
421 our $later_warning_msg = <<END;
422 Perhaps the upload is stuck in incoming. Using the version from git.
426 print STDERR "$us: @_\n", $helpmsg or die $!;
431 @ARGV or badusage "too few arguments";
432 return scalar shift @ARGV;
436 print $helpmsg or die $!;
440 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
442 our %defcfg = ('dgit.default.distro' => 'debian',
443 'dgit.default.username' => '',
444 'dgit.default.archive-query-default-component' => 'main',
445 'dgit.default.ssh' => 'ssh',
446 'dgit.default.archive-query' => 'madison:',
447 'dgit.default.sshpsql-dbname' => 'service=projectb',
448 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
449 'dgit-distro.debian.git-check' => 'url',
450 'dgit-distro.debian.git-check-suffix' => '/info/refs',
451 'dgit-distro.debian.new-private-pushers' => 't',
452 'dgit-distro.debian/push.git-url' => '',
453 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
454 'dgit-distro.debian/push.git-user-force' => 'dgit',
455 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
456 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
457 'dgit-distro.debian/push.git-create' => 'true',
458 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
459 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
460 # 'dgit-distro.debian.archive-query-tls-key',
461 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
462 # ^ this does not work because curl is broken nowadays
463 # Fixing #790093 properly will involve providing providing the key
464 # in some pacagke and maybe updating these paths.
466 # 'dgit-distro.debian.archive-query-tls-curl-args',
467 # '--ca-path=/etc/ssl/ca-debian',
468 # ^ this is a workaround but works (only) on DSA-administered machines
469 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
470 'dgit-distro.debian.git-url-suffix' => '',
471 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
472 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
473 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
474 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
475 'dgit-distro.ubuntu.git-check' => 'false',
476 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
477 'dgit-distro.test-dummy.ssh' => "$td/ssh",
478 'dgit-distro.test-dummy.username' => "alice",
479 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
480 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
481 'dgit-distro.test-dummy.git-url' => "$td/git",
482 'dgit-distro.test-dummy.git-host' => "git",
483 'dgit-distro.test-dummy.git-path' => "$td/git",
484 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
485 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
486 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
487 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
490 sub git_get_config ($) {
493 our %git_get_config_memo;
494 if (exists $git_get_config_memo{$c}) {
495 return $git_get_config_memo{$c};
499 my @cmd = (@git, qw(config --), $c);
501 local ($debuglevel) = $debuglevel-2;
502 $v = cmdoutput_errok @cmd;
510 $git_get_config_memo{$c} = $v;
516 return undef if $c =~ /RETURN-UNDEF/;
517 my $v = git_get_config($c);
518 return $v if defined $v;
519 my $dv = $defcfg{$c};
520 return $dv if defined $dv;
522 badcfg "need value for one of: @_\n".
523 "$us: distro or suite appears not to be (properly) supported";
526 sub access_basedistro () {
527 if (defined $idistro) {
530 return cfg("dgit-suite.$isuite.distro",
531 "dgit.default.distro");
535 sub access_quirk () {
536 # returns (quirk name, distro to use instead or undef, quirk-specific info)
537 my $basedistro = access_basedistro();
538 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
540 if (defined $backports_quirk) {
541 my $re = $backports_quirk;
542 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
544 $re =~ s/\%/([-0-9a-z_]+)/
545 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
546 if ($isuite =~ m/^$re$/) {
547 return ('backports',"$basedistro-backports",$1);
550 return ('none',undef);
555 sub parse_cfg_bool ($$$) {
556 my ($what,$def,$v) = @_;
559 $v =~ m/^[ty1]/ ? 1 :
560 $v =~ m/^[fn0]/ ? 0 :
561 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
564 sub access_forpush_config () {
565 my $d = access_basedistro();
569 parse_cfg_bool('new-private-pushers', 0,
570 cfg("dgit-distro.$d.new-private-pushers",
573 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
576 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
577 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
578 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
579 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
582 sub access_forpush () {
583 $access_forpush //= access_forpush_config();
584 return $access_forpush;
588 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
589 badcfg "pushing but distro is configured readonly"
590 if access_forpush_config() eq '0';
594 sub access_distros () {
595 # Returns list of distros to try, in order
598 # 0. `instead of' distro name(s) we have been pointed to
599 # 1. the access_quirk distro, if any
600 # 2a. the user's specified distro, or failing that } basedistro
601 # 2b. the distro calculated from the suite }
602 my @l = access_basedistro();
604 my (undef,$quirkdistro) = access_quirk();
605 unshift @l, $quirkdistro;
606 unshift @l, $instead_distro;
607 @l = grep { defined } @l;
609 if (access_forpush()) {
610 @l = map { ("$_/push", $_) } @l;
618 # The nesting of these loops determines the search order. We put
619 # the key loop on the outside so that we search all the distros
620 # for each key, before going on to the next key. That means that
621 # if access_cfg is called with a more specific, and then a less
622 # specific, key, an earlier distro can override the less specific
623 # without necessarily overriding any more specific keys. (If the
624 # distro wants to override the more specific keys it can simply do
625 # so; whereas if we did the loop the other way around, it would be
626 # impossible to for an earlier distro to override a less specific
627 # key but not the more specific ones without restating the unknown
628 # values of the more specific keys.
631 # We have to deal with RETURN-UNDEF specially, so that we don't
632 # terminate the search prematurely.
634 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
637 foreach my $d (access_distros()) {
638 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
640 push @cfgs, map { "dgit.default.$_" } @realkeys;
642 my $value = cfg(@cfgs);
646 sub string_to_ssh ($) {
648 if ($spec =~ m/\s/) {
649 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
655 sub access_cfg_ssh () {
656 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
657 if (!defined $gitssh) {
660 return string_to_ssh $gitssh;
664 sub access_runeinfo ($) {
666 return ": dgit ".access_basedistro()." $info ;";
669 sub access_someuserhost ($) {
671 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
672 defined($user) && length($user) or
673 $user = access_cfg("$some-user",'username');
674 my $host = access_cfg("$some-host");
675 return length($user) ? "$user\@$host" : $host;
678 sub access_gituserhost () {
679 return access_someuserhost('git');
682 sub access_giturl (;$) {
684 my $url = access_cfg('git-url','RETURN-UNDEF');
687 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
688 return undef unless defined $proto;
691 access_gituserhost().
692 access_cfg('git-path');
694 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
697 return "$url/$package$suffix";
700 sub parsecontrolfh ($$;$) {
701 my ($fh, $desc, $allowsigned) = @_;
702 our $dpkgcontrolhash_noissigned;
705 my %opts = ('name' => $desc);
706 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
707 $c = Dpkg::Control::Hash->new(%opts);
708 $c->parse($fh,$desc) or die "parsing of $desc failed";
709 last if $allowsigned;
710 last if $dpkgcontrolhash_noissigned;
711 my $issigned= $c->get_option('is_pgp_signed');
712 if (!defined $issigned) {
713 $dpkgcontrolhash_noissigned= 1;
714 seek $fh, 0,0 or die "seek $desc: $!";
715 } elsif ($issigned) {
716 fail "control file $desc is (already) PGP-signed. ".
717 " Note that dgit push needs to modify the .dsc and then".
718 " do the signature itself";
727 my ($file, $desc) = @_;
728 my $fh = new IO::Handle;
729 open $fh, '<', $file or die "$file: $!";
730 my $c = parsecontrolfh($fh,$desc);
731 $fh->error and die $!;
737 my ($dctrl,$field) = @_;
738 my $v = $dctrl->{$field};
739 return $v if defined $v;
740 fail "missing field $field in ".$v->get_option('name');
744 my $c = Dpkg::Control::Hash->new();
745 my $p = new IO::Handle;
746 my @cmd = (qw(dpkg-parsechangelog), @_);
747 open $p, '-|', @cmd or die $!;
749 $?=0; $!=0; close $p or failedcmd @cmd;
755 defined $d or fail "getcwd failed: $!";
761 sub archive_query ($) {
763 my $query = access_cfg('archive-query','RETURN-UNDEF');
764 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
767 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
770 sub pool_dsc_subpath ($$) {
771 my ($vsn,$component) = @_; # $package is implict arg
772 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
773 return "/pool/$component/$prefix/$package/".dscfn($vsn);
776 #---------- `ftpmasterapi' archive query method (nascent) ----------
778 sub archive_api_query_cmd ($) {
780 my @cmd = qw(curl -sS);
781 my $url = access_cfg('archive-query-url');
782 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
784 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
785 foreach my $key (split /\:/, $keys) {
786 $key =~ s/\%HOST\%/$host/g;
788 fail "for $url: stat $key: $!" unless $!==ENOENT;
791 fail "config requested specific TLS key but do not know".
792 " how to get curl to use exactly that EE key ($key)";
793 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
794 # # Sadly the above line does not work because of changes
795 # # to gnutls. The real fix for #790093 may involve
796 # # new curl options.
799 # Fixing #790093 properly will involve providing a value
800 # for this on clients.
801 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
802 push @cmd, split / /, $kargs if defined $kargs;
804 push @cmd, $url.$subpath;
810 my ($data, $subpath) = @_;
811 badcfg "ftpmasterapi archive query method takes no data part"
813 my @cmd = archive_api_query_cmd($subpath);
814 my $json = cmdoutput @cmd;
815 return decode_json($json);
818 sub canonicalise_suite_ftpmasterapi () {
819 my ($proto,$data) = @_;
820 my $suites = api_query($data, 'suites');
822 foreach my $entry (@$suites) {
824 my $v = $entry->{$_};
825 defined $v && $v eq $isuite;
827 push @matched, $entry;
829 fail "unknown suite $isuite" unless @matched;
832 @matched==1 or die "multiple matches for suite $isuite\n";
833 $cn = "$matched[0]{codename}";
834 defined $cn or die "suite $isuite info has no codename\n";
835 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
837 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
842 sub archive_query_ftpmasterapi () {
843 my ($proto,$data) = @_;
844 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
846 my $digester = Digest::SHA->new(256);
847 foreach my $entry (@$info) {
849 my $vsn = "$entry->{version}";
850 my ($ok,$msg) = version_check $vsn;
851 die "bad version: $msg\n" unless $ok;
852 my $component = "$entry->{component}";
853 $component =~ m/^$component_re$/ or die "bad component";
854 my $filename = "$entry->{filename}";
855 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
856 or die "bad filename";
857 my $sha256sum = "$entry->{sha256sum}";
858 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
859 push @rows, [ $vsn, "/pool/$component/$filename",
860 $digester, $sha256sum ];
862 die "bad ftpmaster api response: $@\n".Dumper($entry)
865 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
869 #---------- `madison' archive query method ----------
871 sub archive_query_madison {
872 return map { [ @$_[0..1] ] } madison_get_parse(@_);
875 sub madison_get_parse {
876 my ($proto,$data) = @_;
877 die unless $proto eq 'madison';
879 $data= access_cfg('madison-distro','RETURN-UNDEF');
880 $data //= access_basedistro();
882 $rmad{$proto,$data,$package} ||= cmdoutput
883 qw(rmadison -asource),"-s$isuite","-u$data",$package;
884 my $rmad = $rmad{$proto,$data,$package};
887 foreach my $l (split /\n/, $rmad) {
888 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
889 \s*( [^ \t|]+ )\s* \|
890 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
891 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
892 $1 eq $package or die "$rmad $package ?";
899 $component = access_cfg('archive-query-default-component');
901 $5 eq 'source' or die "$rmad ?";
902 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
904 return sort { -version_compare($a->[0],$b->[0]); } @out;
907 sub canonicalise_suite_madison {
908 # madison canonicalises for us
909 my @r = madison_get_parse(@_);
911 "unable to canonicalise suite using package $package".
912 " which does not appear to exist in suite $isuite;".
913 " --existing-package may help";
917 #---------- `sshpsql' archive query method ----------
920 my ($data,$runeinfo,$sql) = @_;
922 $data= access_someuserhost('sshpsql').':'.
923 access_cfg('sshpsql-dbname');
925 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
926 my ($userhost,$dbname) = ($`,$'); #';
928 my @cmd = (access_cfg_ssh, $userhost,
929 access_runeinfo("ssh-psql $runeinfo").
930 " export LC_MESSAGES=C; export LC_CTYPE=C;".
931 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
933 open P, "-|", @cmd or die $!;
936 printdebug("$debugprefix>|$_|\n");
939 $!=0; $?=0; close P or failedcmd @cmd;
941 my $nrows = pop @rows;
942 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
943 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
944 @rows = map { [ split /\|/, $_ ] } @rows;
945 my $ncols = scalar @{ shift @rows };
946 die if grep { scalar @$_ != $ncols } @rows;
950 sub sql_injection_check {
951 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
954 sub archive_query_sshpsql ($$) {
955 my ($proto,$data) = @_;
956 sql_injection_check $isuite, $package;
957 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
958 SELECT source.version, component.name, files.filename, files.sha256sum
960 JOIN src_associations ON source.id = src_associations.source
961 JOIN suite ON suite.id = src_associations.suite
962 JOIN dsc_files ON dsc_files.source = source.id
963 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
964 JOIN component ON component.id = files_archive_map.component_id
965 JOIN files ON files.id = dsc_files.file
966 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
967 AND source.source='$package'
968 AND files.filename LIKE '%.dsc';
970 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
971 my $digester = Digest::SHA->new(256);
973 my ($vsn,$component,$filename,$sha256sum) = @$_;
974 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
979 sub canonicalise_suite_sshpsql ($$) {
980 my ($proto,$data) = @_;
981 sql_injection_check $isuite;
982 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
983 SELECT suite.codename
984 FROM suite where suite_name='$isuite' or codename='$isuite';
986 @rows = map { $_->[0] } @rows;
987 fail "unknown suite $isuite" unless @rows;
988 die "ambiguous $isuite: @rows ?" if @rows>1;
992 #---------- `dummycat' archive query method ----------
994 sub canonicalise_suite_dummycat ($$) {
995 my ($proto,$data) = @_;
996 my $dpath = "$data/suite.$isuite";
997 if (!open C, "<", $dpath) {
998 $!==ENOENT or die "$dpath: $!";
999 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1003 chomp or die "$dpath: $!";
1005 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1009 sub archive_query_dummycat ($$) {
1010 my ($proto,$data) = @_;
1011 canonicalise_suite();
1012 my $dpath = "$data/package.$csuite.$package";
1013 if (!open C, "<", $dpath) {
1014 $!==ENOENT or die "$dpath: $!";
1015 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1023 printdebug "dummycat query $csuite $package $dpath | $_\n";
1024 my @row = split /\s+/, $_;
1025 @row==2 or die "$dpath: $_ ?";
1028 C->error and die "$dpath: $!";
1030 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1033 #---------- archive query entrypoints and rest of program ----------
1035 sub canonicalise_suite () {
1036 return if defined $csuite;
1037 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1038 $csuite = archive_query('canonicalise_suite');
1039 if ($isuite ne $csuite) {
1040 progress "canonical suite name for $isuite is $csuite";
1044 sub get_archive_dsc () {
1045 canonicalise_suite();
1046 my @vsns = archive_query('archive_query');
1047 foreach my $vinfo (@vsns) {
1048 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1049 $dscurl = access_cfg('mirror').$subpath;
1050 $dscdata = url_get($dscurl);
1052 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1057 $digester->add($dscdata);
1058 my $got = $digester->hexdigest();
1060 fail "$dscurl has hash $got but".
1061 " archive told us to expect $digest";
1063 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1064 printdebug Dumper($dscdata) if $debuglevel>1;
1065 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1066 printdebug Dumper($dsc) if $debuglevel>1;
1067 my $fmt = getfield $dsc, 'Format';
1068 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1069 $dsc_checked = !!$digester;
1075 sub check_for_git ();
1076 sub check_for_git () {
1078 my $how = access_cfg('git-check');
1079 if ($how eq 'ssh-cmd') {
1081 (access_cfg_ssh, access_gituserhost(),
1082 access_runeinfo("git-check $package").
1083 " set -e; cd ".access_cfg('git-path').";".
1084 " if test -d $package.git; then echo 1; else echo 0; fi");
1085 my $r= cmdoutput @cmd;
1086 if ($r =~ m/^divert (\w+)$/) {
1088 my ($usedistro,) = access_distros();
1089 # NB that if we are pushing, $usedistro will be $distro/push
1090 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1091 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1092 progress "diverting to $divert (using config for $instead_distro)";
1093 return check_for_git();
1095 failedcmd @cmd unless $r =~ m/^[01]$/;
1097 } elsif ($how eq 'url') {
1098 my $prefix = access_cfg('git-check-url','git-url');
1099 my $suffix = access_cfg('git-check-suffix','git-suffix',
1100 'RETURN-UNDEF') // '.git';
1101 my $url = "$prefix/$package$suffix";
1102 my @cmd = (qw(curl -sS -I), $url);
1103 my $result = cmdoutput @cmd;
1104 $result =~ m/^\S+ (404|200) /s or
1105 fail "unexpected results from git check query - ".
1106 Dumper($prefix, $result);
1108 if ($code eq '404') {
1110 } elsif ($code eq '200') {
1115 } elsif ($how eq 'true') {
1117 } elsif ($how eq 'false') {
1120 badcfg "unknown git-check \`$how'";
1124 sub create_remote_git_repo () {
1125 my $how = access_cfg('git-create');
1126 if ($how eq 'ssh-cmd') {
1128 (access_cfg_ssh, access_gituserhost(),
1129 access_runeinfo("git-create $package").
1130 "set -e; cd ".access_cfg('git-path').";".
1131 " cp -a _template $package.git");
1132 } elsif ($how eq 'true') {
1135 badcfg "unknown git-create \`$how'";
1139 our ($dsc_hash,$lastpush_hash);
1141 our $ud = '.git/dgit/unpack';
1146 mkdir $ud or die $!;
1149 sub mktree_in_ud_here () {
1150 runcmd qw(git init -q);
1151 rmtree('.git/objects');
1152 symlink '../../../../objects','.git/objects' or die $!;
1155 sub git_write_tree () {
1156 my $tree = cmdoutput @git, qw(write-tree);
1157 $tree =~ m/^\w+$/ or die "$tree ?";
1161 sub mktree_in_ud_from_only_subdir () {
1162 # changes into the subdir
1164 die unless @dirs==1;
1165 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1168 fail "source package contains .git directory" if stat_exists '.git';
1169 mktree_in_ud_here();
1170 my $format=get_source_format();
1171 if (madformat($format)) {
1174 runcmd @git, qw(add -Af);
1175 my $tree=git_write_tree();
1176 return ($tree,$dir);
1179 sub dsc_files_info () {
1180 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1181 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1182 ['Files', 'Digest::MD5', 'new()']) {
1183 my ($fname, $module, $method) = @$csumi;
1184 my $field = $dsc->{$fname};
1185 next unless defined $field;
1186 eval "use $module; 1;" or die $@;
1188 foreach (split /\n/, $field) {
1190 m/^(\w+) (\d+) (\S+)$/ or
1191 fail "could not parse .dsc $fname line \`$_'";
1192 my $digester = eval "$module"."->$method;" or die $@;
1197 Digester => $digester,
1202 fail "missing any supported Checksums-* or Files field in ".
1203 $dsc->get_option('name');
1207 map { $_->{Filename} } dsc_files_info();
1210 sub is_orig_file ($;$) {
1213 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1214 defined $base or return 1;
1218 sub make_commit ($) {
1220 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1223 sub clogp_authline ($) {
1225 my $author = getfield $clogp, 'Maintainer';
1226 $author =~ s#,.*##ms;
1227 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1228 my $authline = "$author $date";
1229 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1230 fail "unexpected commit author line format \`$authline'".
1231 " (was generated from changelog Maintainer field)";
1235 sub vendor_patches_distro ($$) {
1236 my ($checkdistro, $what) = @_;
1237 return unless defined $checkdistro;
1239 my $series = "debian/patches/\L$checkdistro\E.series";
1240 printdebug "checking for vendor-specific $series ($what)\n";
1242 if (!open SERIES, "<", $series) {
1243 die "$series $!" unless $!==ENOENT;
1252 Unfortunately, this source package uses a feature of dpkg-source where
1253 the same source package unpacks to different source code on different
1254 distros. dgit cannot safely operate on such packages on affected
1255 distros, because the meaning of source packages is not stable.
1257 Please ask the distro/maintainer to remove the distro-specific series
1258 files and use a different technique (if necessary, uploading actually
1259 different packages, if different distros are supposed to have
1263 fail "Found active distro-specific series file for".
1264 " $checkdistro ($what): $series, cannot continue";
1266 die "$series $!" if SERIES->error;
1270 sub check_for_vendor_patches () {
1271 # This dpkg-source feature doesn't seem to be documented anywhere!
1272 # But it can be found in the changelog (reformatted):
1274 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1275 # Author: Raphael Hertzog <hertzog@debian.org>
1276 # Date: Sun Oct 3 09:36:48 2010 +0200
1278 # dpkg-source: correctly create .pc/.quilt_series with alternate
1281 # If you have debian/patches/ubuntu.series and you were
1282 # unpacking the source package on ubuntu, quilt was still
1283 # directed to debian/patches/series instead of
1284 # debian/patches/ubuntu.series.
1286 # debian/changelog | 3 +++
1287 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1288 # 2 files changed, 6 insertions(+), 1 deletion(-)
1291 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1292 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1293 "Dpkg::Vendor \`current vendor'");
1294 vendor_patches_distro(access_basedistro(),
1295 "distro being accessed");
1298 sub generate_commit_from_dsc () {
1302 foreach my $fi (dsc_files_info()) {
1303 my $f = $fi->{Filename};
1304 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1306 link "../../../$f", $f
1310 complete_file_from_dsc('.', $fi);
1312 if (is_orig_file($f)) {
1313 link $f, "../../../../$f"
1319 my $dscfn = "$package.dsc";
1321 open D, ">", $dscfn or die "$dscfn: $!";
1322 print D $dscdata or die "$dscfn: $!";
1323 close D or die "$dscfn: $!";
1324 my @cmd = qw(dpkg-source);
1325 push @cmd, '--no-check' if $dsc_checked;
1326 push @cmd, qw(-x --), $dscfn;
1329 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1330 check_for_vendor_patches() if madformat($dsc->{format});
1331 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1332 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1333 my $authline = clogp_authline $clogp;
1334 my $changes = getfield $clogp, 'Changes';
1335 open C, ">../commit.tmp" or die $!;
1336 print C <<END or die $!;
1343 # imported from the archive
1346 my $outputhash = make_commit qw(../commit.tmp);
1347 my $cversion = getfield $clogp, 'Version';
1348 progress "synthesised git commit from .dsc $cversion";
1349 if ($lastpush_hash) {
1350 runcmd @git, qw(reset --hard), $lastpush_hash;
1351 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1352 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1353 my $oversion = getfield $oldclogp, 'Version';
1355 version_compare($oversion, $cversion);
1357 # git upload/ is earlier vsn than archive, use archive
1358 open C, ">../commit2.tmp" or die $!;
1359 print C <<END or die $!;
1361 parent $lastpush_hash
1366 Record $package ($cversion) in archive suite $csuite
1368 $outputhash = make_commit qw(../commit2.tmp);
1369 } elsif ($vcmp > 0) {
1370 print STDERR <<END or die $!;
1372 Version actually in archive: $cversion (older)
1373 Last allegedly pushed/uploaded: $oversion (newer or same)
1376 $outputhash = $lastpush_hash;
1378 $outputhash = $lastpush_hash;
1381 changedir '../../../..';
1382 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1383 'DGIT_ARCHIVE', $outputhash;
1384 cmdoutput @git, qw(log -n2), $outputhash;
1385 # ... gives git a chance to complain if our commit is malformed
1390 sub complete_file_from_dsc ($$) {
1391 our ($dstdir, $fi) = @_;
1392 # Ensures that we have, in $dir, the file $fi, with the correct
1393 # contents. (Downloading it from alongside $dscurl if necessary.)
1395 my $f = $fi->{Filename};
1396 my $tf = "$dstdir/$f";
1399 if (stat_exists $tf) {
1400 progress "using existing $f";
1403 $furl =~ s{/[^/]+$}{};
1405 die "$f ?" unless $f =~ m/^${package}_/;
1406 die "$f ?" if $f =~ m#/#;
1407 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1408 next if !act_local();
1412 open F, "<", "$tf" or die "$tf: $!";
1413 $fi->{Digester}->reset();
1414 $fi->{Digester}->addfile(*F);
1415 F->error and die $!;
1416 my $got = $fi->{Digester}->hexdigest();
1417 $got eq $fi->{Hash} or
1418 fail "file $f has hash $got but .dsc".
1419 " demands hash $fi->{Hash} ".
1420 ($downloaded ? "(got wrong file from archive!)"
1421 : "(perhaps you should delete this file?)");
1424 sub ensure_we_have_orig () {
1425 foreach my $fi (dsc_files_info()) {
1426 my $f = $fi->{Filename};
1427 next unless is_orig_file($f);
1428 complete_file_from_dsc('..', $fi);
1432 sub git_fetch_us () {
1433 my @specs = (fetchspec());
1435 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1437 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1440 my $tagpat = debiantag('*',access_basedistro);
1442 git_for_each_ref("refs/tags/".$tagpat, sub {
1443 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1444 printdebug "currently $fullrefname=$objid\n";
1445 $here{$fullrefname} = $objid;
1447 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1448 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1449 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1450 printdebug "offered $lref=$objid\n";
1451 if (!defined $here{$lref}) {
1452 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1453 runcmd_ordryrun_local @upd;
1454 } elsif ($here{$lref} eq $objid) {
1457 "Not updateting $lref from $here{$lref} to $objid.\n";
1462 sub fetch_from_archive () {
1463 # ensures that lrref() is what is actually in the archive,
1464 # one way or another
1468 foreach my $field (@ourdscfield) {
1469 $dsc_hash = $dsc->{$field};
1470 last if defined $dsc_hash;
1472 if (defined $dsc_hash) {
1473 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1475 progress "last upload to archive specified git hash";
1477 progress "last upload to archive has NO git hash";
1480 progress "no version available from the archive";
1483 $lastpush_hash = git_get_ref(lrref());
1484 printdebug "previous reference hash=$lastpush_hash\n";
1486 if (defined $dsc_hash) {
1487 fail "missing remote git history even though dsc has hash -".
1488 " could not find ref ".lrref().
1489 " (should have been fetched from ".access_giturl()."#".rrref().")"
1490 unless $lastpush_hash;
1492 ensure_we_have_orig();
1493 if ($dsc_hash eq $lastpush_hash) {
1494 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1495 print STDERR <<END or die $!;
1497 Git commit in archive is behind the last version allegedly pushed/uploaded.
1498 Commit referred to by archive: $dsc_hash
1499 Last allegedly pushed/uploaded: $lastpush_hash
1502 $hash = $lastpush_hash;
1504 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1505 "descendant of archive's .dsc hash ($dsc_hash)";
1508 $hash = generate_commit_from_dsc();
1509 } elsif ($lastpush_hash) {
1510 # only in git, not in the archive yet
1511 $hash = $lastpush_hash;
1512 print STDERR <<END or die $!;
1514 Package not found in the archive, but has allegedly been pushed using dgit.
1518 printdebug "nothing found!\n";
1519 if (defined $skew_warning_vsn) {
1520 print STDERR <<END or die $!;
1522 Warning: relevant archive skew detected.
1523 Archive allegedly contains $skew_warning_vsn
1524 But we were not able to obtain any version from the archive or git.
1530 printdebug "current hash=$hash\n";
1531 if ($lastpush_hash) {
1532 fail "not fast forward on last upload branch!".
1533 " (archive's version left in DGIT_ARCHIVE)"
1534 unless is_fast_fwd($lastpush_hash, $hash);
1536 if (defined $skew_warning_vsn) {
1538 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1539 my $clogf = ".git/dgit/changelog.tmp";
1540 runcmd shell_cmd "exec >$clogf",
1541 @git, qw(cat-file blob), "$hash:debian/changelog";
1542 my $gotclogp = parsechangelog("-l$clogf");
1543 my $got_vsn = getfield $gotclogp, 'Version';
1544 printdebug "SKEW CHECK GOT $got_vsn\n";
1545 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1546 print STDERR <<END or die $!;
1548 Warning: archive skew detected. Using the available version:
1549 Archive allegedly contains $skew_warning_vsn
1550 We were able to obtain only $got_vsn
1555 if ($lastpush_hash ne $hash) {
1556 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1560 dryrun_report @upd_cmd;
1566 sub set_local_git_config ($$) {
1568 runcmd @git, qw(config), $k, $v;
1571 sub setup_mergechangelogs () {
1572 my $driver = 'dpkg-mergechangelogs';
1573 my $cb = "merge.$driver";
1574 my $attrs = '.git/info/attributes';
1575 ensuredir '.git/info';
1577 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1578 if (!open ATTRS, "<", $attrs) {
1579 $!==ENOENT or die "$attrs: $!";
1583 next if m{^debian/changelog\s};
1584 print NATTRS $_, "\n" or die $!;
1586 ATTRS->error and die $!;
1589 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1592 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1593 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1595 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1600 canonicalise_suite();
1601 badusage "dry run makes no sense with clone" unless act_local();
1602 my $hasgit = check_for_git();
1603 mkdir $dstdir or die "$dstdir $!";
1605 runcmd @git, qw(init -q);
1606 my $giturl = access_giturl(1);
1607 if (defined $giturl) {
1608 set_local_git_config "remote.$remotename.fetch", fetchspec();
1609 open H, "> .git/HEAD" or die $!;
1610 print H "ref: ".lref()."\n" or die $!;
1612 runcmd @git, qw(remote add), 'origin', $giturl;
1615 progress "fetching existing git history";
1617 runcmd_ordryrun_local @git, qw(fetch origin);
1619 progress "starting new git history";
1621 fetch_from_archive() or no_such_package;
1622 my $vcsgiturl = $dsc->{'Vcs-Git'};
1623 if (length $vcsgiturl) {
1624 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1625 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1627 setup_mergechangelogs();
1628 runcmd @git, qw(reset --hard), lrref();
1629 printdone "ready for work in $dstdir";
1633 if (check_for_git()) {
1636 fetch_from_archive() or no_such_package();
1637 printdone "fetched into ".lrref();
1642 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1644 printdone "fetched to ".lrref()." and merged into HEAD";
1647 sub check_not_dirty () {
1648 return if $ignoredirty;
1649 my @cmd = (@git, qw(diff --quiet HEAD));
1651 $!=0; $?=0; system @cmd;
1652 return if !$! && !$?;
1653 if (!$! && $?==256) {
1654 fail "working tree is dirty (does not match HEAD)";
1660 sub commit_admin ($) {
1663 runcmd_ordryrun_local @git, qw(commit -m), $m;
1666 sub commit_quilty_patch () {
1667 my $output = cmdoutput @git, qw(status --porcelain);
1669 foreach my $l (split /\n/, $output) {
1670 next unless $l =~ m/\S/;
1671 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1675 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1677 progress "nothing quilty to commit, ok.";
1680 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1681 commit_admin "Commit Debian 3.0 (quilt) metadata";
1684 sub get_source_format () {
1685 if (!open F, "debian/source/format") {
1686 die $! unless $!==&ENOENT;
1690 F->error and die $!;
1697 return 0 unless $format eq '3.0 (quilt)';
1698 if ($quilt_mode eq 'nocheck') {
1699 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1702 progress "Format \`$format', checking/updating patch stack";
1706 sub push_parse_changelog ($) {
1709 my $clogp = Dpkg::Control::Hash->new();
1710 $clogp->load($clogpfn) or die;
1712 $package = getfield $clogp, 'Source';
1713 my $cversion = getfield $clogp, 'Version';
1714 my $tag = debiantag($cversion, access_basedistro);
1715 runcmd @git, qw(check-ref-format), $tag;
1717 my $dscfn = dscfn($cversion);
1719 return ($clogp, $cversion, $tag, $dscfn);
1722 sub push_parse_dsc ($$$) {
1723 my ($dscfn,$dscfnwhat, $cversion) = @_;
1724 $dsc = parsecontrol($dscfn,$dscfnwhat);
1725 my $dversion = getfield $dsc, 'Version';
1726 my $dscpackage = getfield $dsc, 'Source';
1727 ($dscpackage eq $package && $dversion eq $cversion) or
1728 fail "$dscfn is for $dscpackage $dversion".
1729 " but debian/changelog is for $package $cversion";
1732 sub push_mktag ($$$$$$$) {
1733 my ($head,$clogp,$tag,
1735 $changesfile,$changesfilewhat,
1738 $dsc->{$ourdscfield[0]} = $head;
1739 $dsc->save("$dscfn.tmp") or die $!;
1741 my $changes = parsecontrol($changesfile,$changesfilewhat);
1742 foreach my $field (qw(Source Distribution Version)) {
1743 $changes->{$field} eq $clogp->{$field} or
1744 fail "changes field $field \`$changes->{$field}'".
1745 " does not match changelog \`$clogp->{$field}'";
1748 my $cversion = getfield $clogp, 'Version';
1749 my $clogsuite = getfield $clogp, 'Distribution';
1751 # We make the git tag by hand because (a) that makes it easier
1752 # to control the "tagger" (b) we can do remote signing
1753 my $authline = clogp_authline $clogp;
1754 my $delibs = join(" ", "",@deliberatelies);
1755 my $declaredistro = access_basedistro();
1756 open TO, '>', $tfn->('.tmp') or die $!;
1757 print TO <<END or die $!;
1763 $package release $cversion for $clogsuite ($csuite) [dgit]
1764 [dgit distro=$declaredistro$delibs]
1766 foreach my $ref (sort keys %previously) {
1767 print TO <<END or die $!;
1768 [dgit previously:$ref=$previously{$ref}]
1774 my $tagobjfn = $tfn->('.tmp');
1776 if (!defined $keyid) {
1777 $keyid = access_cfg('keyid','RETURN-UNDEF');
1779 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1780 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1781 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1782 push @sign_cmd, $tfn->('.tmp');
1783 runcmd_ordryrun @sign_cmd;
1785 $tagobjfn = $tfn->('.signed.tmp');
1786 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1787 $tfn->('.tmp'), $tfn->('.tmp.asc');
1794 sub sign_changes ($) {
1795 my ($changesfile) = @_;
1797 my @debsign_cmd = @debsign;
1798 push @debsign_cmd, "-k$keyid" if defined $keyid;
1799 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1800 push @debsign_cmd, $changesfile;
1801 runcmd_ordryrun @debsign_cmd;
1806 my ($forceflag) = @_;
1807 printdebug "actually entering push\n";
1810 access_giturl(); # check that success is vaguely likely
1812 my $clogpfn = ".git/dgit/changelog.822.tmp";
1813 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1815 responder_send_file('parsed-changelog', $clogpfn);
1817 my ($clogp, $cversion, $tag, $dscfn) =
1818 push_parse_changelog("$clogpfn");
1820 my $dscpath = "$buildproductsdir/$dscfn";
1821 stat_exists $dscpath or
1822 fail "looked for .dsc $dscfn, but $!;".
1823 " maybe you forgot to build";
1825 responder_send_file('dsc', $dscpath);
1827 push_parse_dsc($dscpath, $dscfn, $cversion);
1829 my $format = getfield $dsc, 'Format';
1830 printdebug "format $format\n";
1831 if (madformat($format)) {
1832 commit_quilty_patch();
1836 progress "checking that $dscfn corresponds to HEAD";
1837 runcmd qw(dpkg-source -x --),
1838 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1839 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1840 check_for_vendor_patches() if madformat($dsc->{format});
1841 changedir '../../../..';
1842 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1843 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1844 debugcmd "+",@diffcmd;
1846 my $r = system @diffcmd;
1849 fail "$dscfn specifies a different tree to your HEAD commit;".
1850 " perhaps you forgot to build".
1851 ($diffopt eq '--exit-code' ? "" :
1852 " (run with -D to see full diff output)");
1857 my $head = git_rev_parse('HEAD');
1858 if (!$changesfile) {
1859 my $multi = "$buildproductsdir/".
1860 "${package}_".(stripepoch $cversion)."_multi.changes";
1861 if (stat_exists "$multi") {
1862 $changesfile = $multi;
1864 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1865 my @cs = glob "$buildproductsdir/$pat";
1866 fail "failed to find unique changes file".
1867 " (looked for $pat in $buildproductsdir, or $multi);".
1868 " perhaps you need to use dgit -C"
1870 ($changesfile) = @cs;
1873 $changesfile = "$buildproductsdir/$changesfile";
1876 responder_send_file('changes',$changesfile);
1877 responder_send_command("param head $head");
1878 responder_send_command("param csuite $csuite");
1880 if (deliberately_not_fast_forward) {
1881 git_for_each_ref(lrfetchrefs, sub {
1882 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1883 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1884 responder_send_command("previously $rrefname=$objid");
1885 $previously{$rrefname} = $objid;
1889 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1892 if ($we_are_responder) {
1893 $tagobjfn = $tfn->('.signed.tmp');
1894 responder_receive_files('signed-tag', $tagobjfn);
1897 push_mktag($head,$clogp,$tag,
1899 $changesfile,$changesfile,
1903 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1904 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1905 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1907 if (!check_for_git()) {
1908 create_remote_git_repo();
1910 runcmd_ordryrun @git, qw(push),access_giturl(),
1911 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1912 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1914 if ($we_are_responder) {
1915 my $dryrunsuffix = act_local() ? "" : ".tmp";
1916 responder_receive_files('signed-dsc-changes',
1917 "$dscpath$dryrunsuffix",
1918 "$changesfile$dryrunsuffix");
1921 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1923 progress "[new .dsc left in $dscpath.tmp]";
1925 sign_changes $changesfile;
1928 my $host = access_cfg('upload-host','RETURN-UNDEF');
1929 my @hostarg = defined($host) ? ($host,) : ();
1930 runcmd_ordryrun @dput, @hostarg, $changesfile;
1931 printdone "pushed and uploaded $cversion";
1933 responder_send_command("complete");
1939 badusage "-p is not allowed with clone; specify as argument instead"
1940 if defined $package;
1943 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1944 ($package,$isuite) = @ARGV;
1945 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1946 ($package,$dstdir) = @ARGV;
1947 } elsif (@ARGV==3) {
1948 ($package,$isuite,$dstdir) = @ARGV;
1950 badusage "incorrect arguments to dgit clone";
1952 $dstdir ||= "$package";
1954 if (stat_exists $dstdir) {
1955 fail "$dstdir already exists";
1959 if ($rmonerror && !$dryrun_level) {
1960 $cwd_remove= getcwd();
1962 return unless defined $cwd_remove;
1963 if (!chdir "$cwd_remove") {
1964 return if $!==&ENOENT;
1965 die "chdir $cwd_remove: $!";
1967 rmtree($dstdir) or die "remove $dstdir: $!\n";
1972 $cwd_remove = undef;
1975 sub branchsuite () {
1976 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1977 if ($branch =~ m#$lbranch_re#o) {
1984 sub fetchpullargs () {
1985 if (!defined $package) {
1986 my $sourcep = parsecontrol('debian/control','debian/control');
1987 $package = getfield $sourcep, 'Source';
1990 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1992 my $clogp = parsechangelog();
1993 $isuite = getfield $clogp, 'Distribution';
1995 canonicalise_suite();
1996 progress "fetching from suite $csuite";
1997 } elsif (@ARGV==1) {
1999 canonicalise_suite();
2001 badusage "incorrect arguments to dgit fetch or dgit pull";
2020 badusage "-p is not allowed with dgit push" if defined $package;
2022 my $clogp = parsechangelog();
2023 $package = getfield $clogp, 'Source';
2026 } elsif (@ARGV==1) {
2027 ($specsuite) = (@ARGV);
2029 badusage "incorrect arguments to dgit push";
2031 $isuite = getfield $clogp, 'Distribution';
2033 local ($package) = $existing_package; # this is a hack
2034 canonicalise_suite();
2036 canonicalise_suite();
2038 if (defined $specsuite &&
2039 $specsuite ne $isuite &&
2040 $specsuite ne $csuite) {
2041 fail "dgit push: changelog specifies $isuite ($csuite)".
2042 " but command line specifies $specsuite";
2044 if (check_for_git()) {
2048 if (fetch_from_archive()) {
2049 if (is_fast_fwd(lrref(), 'HEAD')) {
2051 } elsif (deliberately_not_fast_forward) {
2054 fail "dgit push: HEAD is not a descendant".
2055 " of the archive's version.\n".
2056 "dgit: To overwrite its contents,".
2057 " use git merge -s ours ".lrref().".\n".
2058 "dgit: To rewind history, if permitted by the archive,".
2059 " use --deliberately-not-fast-forward";
2063 fail "package appears to be new in this suite;".
2064 " if this is intentional, use --new";
2069 #---------- remote commands' implementation ----------
2071 sub cmd_remote_push_build_host {
2073 my ($nrargs) = shift @ARGV;
2074 my (@rargs) = @ARGV[0..$nrargs-1];
2075 @ARGV = @ARGV[$nrargs..$#ARGV];
2077 my ($dir,$vsnwant) = @rargs;
2078 # vsnwant is a comma-separated list; we report which we have
2079 # chosen in our ready response (so other end can tell if they
2082 $we_are_responder = 1;
2083 $us .= " (build host)";
2085 open PI, "<&STDIN" or die $!;
2086 open STDIN, "/dev/null" or die $!;
2087 open PO, ">&STDOUT" or die $!;
2089 open STDOUT, ">&STDERR" or die $!;
2093 fail "build host has dgit rpush protocol version".
2094 " $rpushprotovsn but invocation host has $vsnwant"
2095 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2097 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2103 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2104 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2105 # a good error message)
2111 my $report = i_child_report();
2112 if (defined $report) {
2113 printdebug "($report)\n";
2114 } elsif ($i_child_pid) {
2115 printdebug "(killing build host child $i_child_pid)\n";
2116 kill 15, $i_child_pid;
2118 if (defined $i_tmp && !defined $initiator_tempdir) {
2120 eval { rmtree $i_tmp; };
2124 END { i_cleanup(); }
2127 my ($base,$selector,@args) = @_;
2128 $selector =~ s/\-/_/g;
2129 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2136 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2143 my @rargs = ($dir,$rpushprotovsn);
2146 push @rdgit, @ropts;
2147 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2149 my @cmd = (@ssh, $host, shellquote @rdgit);
2152 if (defined $initiator_tempdir) {
2153 rmtree $initiator_tempdir;
2154 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2155 $i_tmp = $initiator_tempdir;
2159 $i_child_pid = open2(\*RO, \*RI, @cmd);
2161 initiator_expect { m/^dgit-remote-push-ready/ };
2163 my ($icmd,$iargs) = initiator_expect {
2164 m/^(\S+)(?: (.*))?$/;
2167 i_method "i_resp", $icmd, $iargs;
2171 sub i_resp_progress ($) {
2173 my $msg = protocol_read_bytes \*RO, $rhs;
2177 sub i_resp_complete {
2178 my $pid = $i_child_pid;
2179 $i_child_pid = undef; # prevents killing some other process with same pid
2180 printdebug "waiting for build host child $pid...\n";
2181 my $got = waitpid $pid, 0;
2182 die $! unless $got == $pid;
2183 die "build host child failed $?" if $?;
2186 printdebug "all done\n";
2190 sub i_resp_file ($) {
2192 my $localname = i_method "i_localname", $keyword;
2193 my $localpath = "$i_tmp/$localname";
2194 stat_exists $localpath and
2195 badproto \*RO, "file $keyword ($localpath) twice";
2196 protocol_receive_file \*RO, $localpath;
2197 i_method "i_file", $keyword;
2202 sub i_resp_param ($) {
2203 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2207 sub i_resp_previously ($) {
2208 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2209 or badproto \*RO, "bad previously spec";
2210 my $r = system qw(git check-ref-format), $1;
2211 die "bad previously ref spec ($r)" if $r;
2212 $previously{$1} = $2;
2217 sub i_resp_want ($) {
2219 die "$keyword ?" if $i_wanted{$keyword}++;
2220 my @localpaths = i_method "i_want", $keyword;
2221 printdebug "[[ $keyword @localpaths\n";
2222 foreach my $localpath (@localpaths) {
2223 protocol_send_file \*RI, $localpath;
2225 print RI "files-end\n" or die $!;
2228 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2230 sub i_localname_parsed_changelog {
2231 return "remote-changelog.822";
2233 sub i_file_parsed_changelog {
2234 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2235 push_parse_changelog "$i_tmp/remote-changelog.822";
2236 die if $i_dscfn =~ m#/|^\W#;
2239 sub i_localname_dsc {
2240 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2245 sub i_localname_changes {
2246 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2247 $i_changesfn = $i_dscfn;
2248 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2249 return $i_changesfn;
2251 sub i_file_changes { }
2253 sub i_want_signed_tag {
2254 printdebug Dumper(\%i_param, $i_dscfn);
2255 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2256 && defined $i_param{'csuite'}
2257 or badproto \*RO, "premature desire for signed-tag";
2258 my $head = $i_param{'head'};
2259 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2261 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2263 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2266 push_mktag $head, $i_clogp, $i_tag,
2268 $i_changesfn, 'remote changes',
2269 sub { "tag$_[0]"; };
2274 sub i_want_signed_dsc_changes {
2275 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2276 sign_changes $i_changesfn;
2277 return ($i_dscfn, $i_changesfn);
2280 #---------- building etc. ----------
2286 #----- `3.0 (quilt)' handling -----
2288 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2290 sub quiltify_dpkg_commit ($$$;$) {
2291 my ($patchname,$author,$msg, $xinfo) = @_;
2295 my $descfn = ".git/dgit/quilt-description.tmp";
2296 open O, '>', $descfn or die "$descfn: $!";
2299 $msg =~ s/^\s+$/ ./mg;
2300 print O <<END or die $!;
2310 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2311 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2312 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2313 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2317 sub quiltify_trees_differ ($$) {
2319 # returns 1 iff the two tree objects differ other than in debian/
2321 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2322 my $diffs= cmdoutput @cmd;
2323 foreach my $f (split /\0/, $diffs) {
2324 next if $f eq 'debian';
2330 sub quiltify_tree_sentinelfiles ($) {
2331 # lists the `sentinel' files present in the tree
2333 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2334 qw(-- debian/rules debian/control);
2340 my ($clogp,$target) = @_;
2342 # Quilt patchification algorithm
2344 # We search backwards through the history of the main tree's HEAD
2345 # (T) looking for a start commit S whose tree object is identical
2346 # to to the patch tip tree (ie the tree corresponding to the
2347 # current dpkg-committed patch series). For these purposes
2348 # `identical' disregards anything in debian/ - this wrinkle is
2349 # necessary because dpkg-source treates debian/ specially.
2351 # We can only traverse edges where at most one of the ancestors'
2352 # trees differs (in changes outside in debian/). And we cannot
2353 # handle edges which change .pc/ or debian/patches. To avoid
2354 # going down a rathole we avoid traversing edges which introduce
2355 # debian/rules or debian/control. And we set a limit on the
2356 # number of edges we are willing to look at.
2358 # If we succeed, we walk forwards again. For each traversed edge
2359 # PC (with P parent, C child) (starting with P=S and ending with
2360 # C=T) to we do this:
2362 # - dpkg-source --commit with a patch name and message derived from C
2363 # After traversing PT, we git commit the changes which
2364 # should be contained within debian/patches.
2366 changedir '../fake';
2367 mktree_in_ud_here();
2369 runcmd @git, 'add', '.';
2370 my $oldtiptree=git_write_tree();
2371 changedir '../work';
2373 # The search for the path S..T is breadth-first. We maintain a
2374 # todo list containing search nodes. A search node identifies a
2375 # commit, and looks something like this:
2377 # Commit => $git_commit_id,
2378 # Child => $c, # or undef if P=T
2379 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2380 # Nontrivial => true iff $p..$c has relevant changes
2387 my %considered; # saves being exponential on some weird graphs
2389 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2392 my ($search,$whynot) = @_;
2393 printdebug " search NOT $search->{Commit} $whynot\n";
2394 $search->{Whynot} = $whynot;
2395 push @nots, $search;
2396 no warnings qw(exiting);
2405 my $c = shift @todo;
2406 next if $considered{$c->{Commit}}++;
2408 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2410 printdebug "quiltify investigate $c->{Commit}\n";
2413 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2414 printdebug " search finished hooray!\n";
2419 if ($quilt_mode eq 'nofix') {
2420 fail "quilt fixup required but quilt mode is \`nofix'\n".
2421 "HEAD commit $c->{Commit} differs from tree implied by ".
2422 " debian/patches (tree object $oldtiptree)";
2424 if ($quilt_mode eq 'smash') {
2425 printdebug " search quitting smash\n";
2429 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2430 $not->($c, "has $c_sentinels not $t_sentinels")
2431 if $c_sentinels ne $t_sentinels;
2433 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2434 $commitdata =~ m/\n\n/;
2436 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2437 @parents = map { { Commit => $_, Child => $c } } @parents;
2439 $not->($c, "root commit") if !@parents;
2441 foreach my $p (@parents) {
2442 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2444 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2445 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2447 foreach my $p (@parents) {
2448 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2450 my @cmd= (@git, qw(diff-tree -r --name-only),
2451 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2452 my $patchstackchange = cmdoutput @cmd;
2453 if (length $patchstackchange) {
2454 $patchstackchange =~ s/\n/,/g;
2455 $not->($p, "changed $patchstackchange");
2458 printdebug " search queue P=$p->{Commit} ",
2459 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2465 printdebug "quiltify want to smash\n";
2468 my $x = $_[0]{Commit};
2469 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2472 my $reportnot = sub {
2474 my $s = $abbrev->($notp);
2475 my $c = $notp->{Child};
2476 $s .= "..".$abbrev->($c) if $c;
2477 $s .= ": ".$notp->{Whynot};
2480 if ($quilt_mode eq 'linear') {
2481 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2482 foreach my $notp (@nots) {
2483 print STDERR "$us: ", $reportnot->($notp), "\n";
2485 fail "quilt fixup naive history linearisation failed.\n".
2486 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2487 } elsif ($quilt_mode eq 'smash') {
2488 } elsif ($quilt_mode eq 'auto') {
2489 progress "quilt fixup cannot be linear, smashing...";
2491 die "$quilt_mode ?";
2496 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2498 quiltify_dpkg_commit "auto-$version-$target-$time",
2499 (getfield $clogp, 'Maintainer'),
2500 "Automatically generated patch ($clogp->{Version})\n".
2501 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2505 progress "quiltify linearisation planning successful, executing...";
2507 for (my $p = $sref_S;
2508 my $c = $p->{Child};
2510 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2511 next unless $p->{Nontrivial};
2513 my $cc = $c->{Commit};
2515 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2516 $commitdata =~ m/\n\n/ or die "$c ?";
2519 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2522 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2525 my $patchname = $title;
2526 $patchname =~ s/[.:]$//;
2527 $patchname =~ y/ A-Z/-a-z/;
2528 $patchname =~ y/-a-z0-9_.+=~//cd;
2529 $patchname =~ s/^\W/x-$&/;
2530 $patchname = substr($patchname,0,40);
2533 stat "debian/patches/$patchname$index";
2535 $!==ENOENT or die "$patchname$index $!";
2537 runcmd @git, qw(checkout -q), $cc;
2539 # We use the tip's changelog so that dpkg-source doesn't
2540 # produce complaining messages from dpkg-parsechangelog. None
2541 # of the information dpkg-source gets from the changelog is
2542 # actually relevant - it gets put into the original message
2543 # which dpkg-source provides our stunt editor, and then
2545 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2547 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2548 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2550 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2553 runcmd @git, qw(checkout -q master);
2556 sub build_maybe_quilt_fixup () {
2557 my $format=get_source_format;
2558 return unless madformat $format;
2561 check_for_vendor_patches();
2564 # - honour any existing .pc in case it has any strangeness
2565 # - determine the git commit corresponding to the tip of
2566 # the patch stack (if there is one)
2567 # - if there is such a git commit, convert each subsequent
2568 # git commit into a quilt patch with dpkg-source --commit
2569 # - otherwise convert all the differences in the tree into
2570 # a single git commit
2574 # Our git tree doesn't necessarily contain .pc. (Some versions of
2575 # dgit would include the .pc in the git tree.) If there isn't
2576 # one, we need to generate one by unpacking the patches that we
2579 # We first look for a .pc in the git tree. If there is one, we
2580 # will use it. (This is not the normal case.)
2582 # Otherwise need to regenerate .pc so that dpkg-source --commit
2583 # can work. We do this as follows:
2584 # 1. Collect all relevant .orig from parent directory
2585 # 2. Generate a debian.tar.gz out of
2586 # debian/{patches,rules,source/format}
2587 # 3. Generate a fake .dsc containing just these fields:
2588 # Format Source Version Files
2589 # 4. Extract the fake .dsc
2590 # Now the fake .dsc has a .pc directory.
2591 # (In fact we do this in every case, because in future we will
2592 # want to search for a good base commit for generating patches.)
2594 # Then we can actually do the dpkg-source --commit
2595 # 1. Make a new working tree with the same object
2596 # store as our main tree and check out the main
2598 # 2. Copy .pc from the fake's extraction, if necessary
2599 # 3. Run dpkg-source --commit
2600 # 4. If the result has changes to debian/, then
2601 # - git-add them them
2602 # - git-add .pc if we had a .pc in-tree
2604 # 5. If we had a .pc in-tree, delete it, and git-commit
2605 # 6. Back in the main tree, fast forward to the new HEAD
2607 my $clogp = parsechangelog();
2608 my $headref = git_rev_parse('HEAD');
2613 my $upstreamversion=$version;
2614 $upstreamversion =~ s/-[^-]*$//;
2616 my $fakeversion="$upstreamversion-~~DGITFAKE";
2618 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2619 print $fakedsc <<END or die $!;
2622 Version: $fakeversion
2626 my $dscaddfile=sub {
2629 my $md = new Digest::MD5;
2631 my $fh = new IO::File $b, '<' or die "$b $!";
2636 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2639 foreach my $f (<../../../../*>) { #/){
2640 my $b=$f; $b =~ s{.*/}{};
2641 next unless is_orig_file $b, srcfn $upstreamversion,'';
2642 link $f, $b or die "$b $!";
2646 my @files=qw(debian/source/format debian/rules);
2647 if (stat_exists '../../../debian/patches') {
2648 push @files, 'debian/patches';
2651 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2652 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2654 $dscaddfile->($debtar);
2655 close $fakedsc or die $!;
2657 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2659 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2660 rename $fakexdir, "fake" or die "$fakexdir $!";
2662 mkdir "work" or die $!;
2664 mktree_in_ud_here();
2665 runcmd @git, qw(reset --hard), $headref;
2668 if (stat_exists ".pc") {
2670 progress "Tree already contains .pc - will use it then delete it.";
2673 rename '../fake/.pc','.pc' or die $!;
2676 quiltify($clogp,$headref);
2678 if (!open P, '>>', ".pc/applied-patches") {
2679 $!==&ENOENT or die $!;
2684 commit_quilty_patch();
2686 if ($mustdeletepc) {
2687 runcmd @git, qw(rm -rqf .pc);
2688 commit_admin "Commit removal of .pc (quilt series tracking data)";
2691 changedir '../../../..';
2692 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2695 sub quilt_fixup_editor () {
2696 my $descfn = $ENV{$fakeeditorenv};
2697 my $editing = $ARGV[$#ARGV];
2698 open I1, '<', $descfn or die "$descfn: $!";
2699 open I2, '<', $editing or die "$editing: $!";
2700 unlink $editing or die "$editing: $!";
2701 open O, '>', $editing or die "$editing: $!";
2702 while (<I1>) { print O or die $!; } I1->error and die $!;
2705 $copying ||= m/^\-\-\- /;
2706 next unless $copying;
2709 I2->error and die $!;
2714 #----- other building -----
2717 if ($cleanmode eq 'dpkg-source') {
2718 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2719 } elsif ($cleanmode eq 'dpkg-source-d') {
2720 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2721 } elsif ($cleanmode eq 'git') {
2722 runcmd_ordryrun_local @git, qw(clean -xdf);
2723 } elsif ($cleanmode eq 'git-ff') {
2724 runcmd_ordryrun_local @git, qw(clean -xdff);
2725 } elsif ($cleanmode eq 'check') {
2726 my $leftovers = cmdoutput @git, qw(clean -xdn);
2727 if (length $leftovers) {
2728 print STDERR $leftovers, "\n" or die $!;
2729 fail "tree contains uncommitted files and --clean=check specified";
2731 } elsif ($cleanmode eq 'none') {
2738 badusage "clean takes no additional arguments" if @ARGV;
2743 badusage "-p is not allowed when building" if defined $package;
2746 my $clogp = parsechangelog();
2747 $isuite = getfield $clogp, 'Distribution';
2748 $package = getfield $clogp, 'Source';
2749 $version = getfield $clogp, 'Version';
2750 build_maybe_quilt_fixup();
2753 sub changesopts () {
2754 my @opts =@changesopts[1..$#changesopts];
2755 if (!defined $changes_since_version) {
2756 my @vsns = archive_query('archive_query');
2757 my @quirk = access_quirk();
2758 if ($quirk[0] eq 'backports') {
2759 local $isuite = $quirk[2];
2761 canonicalise_suite();
2762 push @vsns, archive_query('archive_query');
2765 @vsns = map { $_->[0] } @vsns;
2766 @vsns = sort { -version_compare($a, $b) } @vsns;
2767 $changes_since_version = $vsns[0];
2768 progress "changelog will contain changes since $vsns[0]";
2770 $changes_since_version = '_';
2771 progress "package seems new, not specifying -v<version>";
2774 if ($changes_since_version ne '_') {
2775 unshift @opts, "-v$changes_since_version";
2780 sub massage_dbp_args ($) {
2782 return unless $cleanmode =~ m/git|none/;
2783 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2784 my @newcmd = shift @$cmd;
2785 # -nc has the side effect of specifying -b if nothing else specified
2786 push @newcmd, '-nc';
2787 # and some combinations of -S, -b, et al, are errors, rather than
2788 # later simply overriding earlier
2789 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2790 push @newcmd, @$cmd;
2796 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2797 massage_dbp_args \@dbp;
2798 runcmd_ordryrun_local @dbp;
2799 printdone "build successful\n";
2804 my @dbp = @dpkgbuildpackage;
2805 massage_dbp_args \@dbp;
2807 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2808 "--git-builder=@dbp");
2809 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2810 canonicalise_suite();
2811 push @cmd, "--git-debian-branch=".lbranch();
2813 push @cmd, changesopts();
2814 runcmd_ordryrun_local @cmd, @ARGV;
2815 printdone "build successful\n";
2820 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2821 $dscfn = dscfn($version);
2822 if ($cleanmode eq 'dpkg-source') {
2823 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2825 } elsif ($cleanmode eq 'dpkg-source-d') {
2826 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2829 my $pwd = must_getcwd();
2830 my $leafdir = basename $pwd;
2832 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2834 runcmd_ordryrun_local qw(sh -ec),
2835 'exec >$1; shift; exec "$@"','x',
2836 "../$sourcechanges",
2837 @dpkggenchanges, qw(-S), changesopts();
2841 sub cmd_build_source {
2842 badusage "build-source takes no additional arguments" if @ARGV;
2844 printdone "source built, results in $dscfn and $sourcechanges";
2850 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2852 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2853 stat_exists $sourcechanges
2854 or fail "$sourcechanges (in parent directory): $!";
2855 foreach my $cf (glob $pat) {
2856 next if $cf eq $sourcechanges;
2857 unlink $cf or fail "remove $cf: $!";
2860 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2861 my @changesfiles = glob $pat;
2862 @changesfiles = sort {
2863 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2866 fail "wrong number of different changes files (@changesfiles)"
2867 unless @changesfiles;
2868 runcmd_ordryrun_local @mergechanges, @changesfiles;
2869 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2871 stat_exists $multichanges or fail "$multichanges: $!";
2873 printdone "build successful, results in $multichanges\n" or die $!;
2876 sub cmd_quilt_fixup {
2877 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2878 my $clogp = parsechangelog();
2879 $version = getfield $clogp, 'Version';
2880 $package = getfield $clogp, 'Source';
2881 build_maybe_quilt_fixup();
2884 sub cmd_archive_api_query {
2885 badusage "need only 1 subpath argument" unless @ARGV==1;
2886 my ($subpath) = @ARGV;
2887 my @cmd = archive_api_query_cmd($subpath);
2889 exec @cmd or fail "exec curl: $!\n";
2892 sub cmd_clone_dgit_repos_server {
2893 badusage "need destination argument" unless @ARGV==1;
2894 my ($destdir) = @ARGV;
2895 $package = '_dgit-repos-server';
2896 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2898 exec @cmd or fail "exec git clone: $!\n";
2901 sub cmd_setup_mergechangelogs {
2902 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2903 setup_mergechangelogs();
2906 #---------- argument parsing and main program ----------
2909 print "dgit version $our_version\n" or die $!;
2916 if (defined $ENV{'DGIT_SSH'}) {
2917 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2918 } elsif (defined $ENV{'GIT_SSH'}) {
2919 @ssh = ($ENV{'GIT_SSH'});
2923 last unless $ARGV[0] =~ m/^-/;
2927 if (m/^--dry-run$/) {
2930 } elsif (m/^--damp-run$/) {
2933 } elsif (m/^--no-sign$/) {
2936 } elsif (m/^--help$/) {
2938 } elsif (m/^--version$/) {
2940 } elsif (m/^--new$/) {
2943 } elsif (m/^--since-version=([^_]+|_)$/) {
2945 $changes_since_version = $1;
2946 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2947 ($om = $opts_opt_map{$1}) &&
2951 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2952 !$opts_opt_cmdonly{$1} &&
2953 ($om = $opts_opt_map{$1})) {
2956 } elsif (m/^--existing-package=(.*)/s) {
2958 $existing_package = $1;
2959 } elsif (m/^--initiator-tempdir=(.*)/s) {
2960 $initiator_tempdir = $1;
2961 $initiator_tempdir =~ m#^/# or
2962 badusage "--initiator-tempdir must be used specify an".
2963 " absolute, not relative, directory."
2964 } elsif (m/^--distro=(.*)/s) {
2967 } elsif (m/^--build-products-dir=(.*)/s) {
2969 $buildproductsdir = $1;
2970 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2973 } elsif (m/^--clean=(.*)$/s) {
2974 badusage "unknown cleaning mode \`$1'";
2975 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2978 } elsif (m/^--quilt=(.*)$/s) {
2979 badusage "unknown quilt fixup mode \`$1'";
2980 } elsif (m/^--ignore-dirty$/s) {
2983 } elsif (m/^--no-quilt-fixup$/s) {
2985 $quilt_mode = 'nocheck';
2986 } elsif (m/^--no-rm-on-error$/s) {
2989 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2991 push @deliberatelies, $&;
2993 badusage "unknown long option \`$_'";
3000 } elsif (s/^-L/-/) {
3003 } elsif (s/^-h/-/) {
3005 } elsif (s/^-D/-/) {
3009 } elsif (s/^-N/-/) {
3012 } elsif (s/^-v([^_]+|_)$//s) {
3014 $changes_since_version = $1;
3017 push @changesopts, $_;
3019 } elsif (s/^-c(.*=.*)//s) {
3021 push @git, '-c', $1;
3022 } elsif (s/^-d(.+)//s) {
3025 } elsif (s/^-C(.+)//s) {
3028 if ($changesfile =~ s#^(.*)/##) {
3029 $buildproductsdir = $1;
3031 } elsif (s/^-k(.+)//s) {
3033 } elsif (m/^-[vdCk]$/) {
3035 "option \`$_' requires an argument (and no space before the argument)";
3036 } elsif (s/^-wn$//s) {
3038 $cleanmode = 'none';
3039 } elsif (s/^-wg$//s) {
3042 } elsif (s/^-wgf$//s) {
3044 $cleanmode = 'git-ff';
3045 } elsif (s/^-wd$//s) {
3047 $cleanmode = 'dpkg-source';
3048 } elsif (s/^-wdd$//s) {
3050 $cleanmode = 'dpkg-source-d';
3051 } elsif (s/^-wc$//s) {
3053 $cleanmode = 'check';
3055 badusage "unknown short option \`$_'";
3062 if ($ENV{$fakeeditorenv}) {
3063 quilt_fixup_editor();
3067 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3068 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3069 if $dryrun_level == 1;
3071 print STDERR $helpmsg or die $!;
3074 my $cmd = shift @ARGV;
3077 if (!defined $quilt_mode) {
3078 local $access_forpush;
3079 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3080 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3082 $quilt_mode =~ m/^($quilt_modes_re)$/
3083 or badcfg "unknown quilt-mode \`$quilt_mode'";
3087 my $fn = ${*::}{"cmd_$cmd"};
3088 $fn or badusage "unknown operation $cmd";