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;
1169 my @gitscmd = qw(find -name .git -prune -print0);
1170 debugcmd "|",@gitscmd;
1171 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1176 print STDERR "$us: warning: removing from source package: ",
1177 (messagequote $_), "\n";
1181 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1183 mktree_in_ud_here();
1184 my $format=get_source_format();
1185 if (madformat($format)) {
1188 runcmd @git, qw(add -Af);
1189 my $tree=git_write_tree();
1190 return ($tree,$dir);
1193 sub dsc_files_info () {
1194 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1195 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1196 ['Files', 'Digest::MD5', 'new()']) {
1197 my ($fname, $module, $method) = @$csumi;
1198 my $field = $dsc->{$fname};
1199 next unless defined $field;
1200 eval "use $module; 1;" or die $@;
1202 foreach (split /\n/, $field) {
1204 m/^(\w+) (\d+) (\S+)$/ or
1205 fail "could not parse .dsc $fname line \`$_'";
1206 my $digester = eval "$module"."->$method;" or die $@;
1211 Digester => $digester,
1216 fail "missing any supported Checksums-* or Files field in ".
1217 $dsc->get_option('name');
1221 map { $_->{Filename} } dsc_files_info();
1224 sub is_orig_file ($;$) {
1227 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1228 defined $base or return 1;
1232 sub make_commit ($) {
1234 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1237 sub clogp_authline ($) {
1239 my $author = getfield $clogp, 'Maintainer';
1240 $author =~ s#,.*##ms;
1241 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1242 my $authline = "$author $date";
1243 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1244 fail "unexpected commit author line format \`$authline'".
1245 " (was generated from changelog Maintainer field)";
1249 sub vendor_patches_distro ($$) {
1250 my ($checkdistro, $what) = @_;
1251 return unless defined $checkdistro;
1253 my $series = "debian/patches/\L$checkdistro\E.series";
1254 printdebug "checking for vendor-specific $series ($what)\n";
1256 if (!open SERIES, "<", $series) {
1257 die "$series $!" unless $!==ENOENT;
1266 Unfortunately, this source package uses a feature of dpkg-source where
1267 the same source package unpacks to different source code on different
1268 distros. dgit cannot safely operate on such packages on affected
1269 distros, because the meaning of source packages is not stable.
1271 Please ask the distro/maintainer to remove the distro-specific series
1272 files and use a different technique (if necessary, uploading actually
1273 different packages, if different distros are supposed to have
1277 fail "Found active distro-specific series file for".
1278 " $checkdistro ($what): $series, cannot continue";
1280 die "$series $!" if SERIES->error;
1284 sub check_for_vendor_patches () {
1285 # This dpkg-source feature doesn't seem to be documented anywhere!
1286 # But it can be found in the changelog (reformatted):
1288 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1289 # Author: Raphael Hertzog <hertzog@debian.org>
1290 # Date: Sun Oct 3 09:36:48 2010 +0200
1292 # dpkg-source: correctly create .pc/.quilt_series with alternate
1295 # If you have debian/patches/ubuntu.series and you were
1296 # unpacking the source package on ubuntu, quilt was still
1297 # directed to debian/patches/series instead of
1298 # debian/patches/ubuntu.series.
1300 # debian/changelog | 3 +++
1301 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1302 # 2 files changed, 6 insertions(+), 1 deletion(-)
1305 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1306 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1307 "Dpkg::Vendor \`current vendor'");
1308 vendor_patches_distro(access_basedistro(),
1309 "distro being accessed");
1312 sub generate_commit_from_dsc () {
1316 foreach my $fi (dsc_files_info()) {
1317 my $f = $fi->{Filename};
1318 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1320 link "../../../$f", $f
1324 complete_file_from_dsc('.', $fi);
1326 if (is_orig_file($f)) {
1327 link $f, "../../../../$f"
1333 my $dscfn = "$package.dsc";
1335 open D, ">", $dscfn or die "$dscfn: $!";
1336 print D $dscdata or die "$dscfn: $!";
1337 close D or die "$dscfn: $!";
1338 my @cmd = qw(dpkg-source);
1339 push @cmd, '--no-check' if $dsc_checked;
1340 push @cmd, qw(-x --), $dscfn;
1343 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1344 check_for_vendor_patches() if madformat($dsc->{format});
1345 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1346 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1347 my $authline = clogp_authline $clogp;
1348 my $changes = getfield $clogp, 'Changes';
1349 open C, ">../commit.tmp" or die $!;
1350 print C <<END or die $!;
1357 # imported from the archive
1360 my $outputhash = make_commit qw(../commit.tmp);
1361 my $cversion = getfield $clogp, 'Version';
1362 progress "synthesised git commit from .dsc $cversion";
1363 if ($lastpush_hash) {
1364 runcmd @git, qw(reset --hard), $lastpush_hash;
1365 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1366 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1367 my $oversion = getfield $oldclogp, 'Version';
1369 version_compare($oversion, $cversion);
1371 # git upload/ is earlier vsn than archive, use archive
1372 open C, ">../commit2.tmp" or die $!;
1373 print C <<END or die $!;
1375 parent $lastpush_hash
1380 Record $package ($cversion) in archive suite $csuite
1382 $outputhash = make_commit qw(../commit2.tmp);
1383 } elsif ($vcmp > 0) {
1384 print STDERR <<END or die $!;
1386 Version actually in archive: $cversion (older)
1387 Last allegedly pushed/uploaded: $oversion (newer or same)
1390 $outputhash = $lastpush_hash;
1392 $outputhash = $lastpush_hash;
1395 changedir '../../../..';
1396 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1397 'DGIT_ARCHIVE', $outputhash;
1398 cmdoutput @git, qw(log -n2), $outputhash;
1399 # ... gives git a chance to complain if our commit is malformed
1404 sub complete_file_from_dsc ($$) {
1405 our ($dstdir, $fi) = @_;
1406 # Ensures that we have, in $dir, the file $fi, with the correct
1407 # contents. (Downloading it from alongside $dscurl if necessary.)
1409 my $f = $fi->{Filename};
1410 my $tf = "$dstdir/$f";
1413 if (stat_exists $tf) {
1414 progress "using existing $f";
1417 $furl =~ s{/[^/]+$}{};
1419 die "$f ?" unless $f =~ m/^${package}_/;
1420 die "$f ?" if $f =~ m#/#;
1421 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1422 next if !act_local();
1426 open F, "<", "$tf" or die "$tf: $!";
1427 $fi->{Digester}->reset();
1428 $fi->{Digester}->addfile(*F);
1429 F->error and die $!;
1430 my $got = $fi->{Digester}->hexdigest();
1431 $got eq $fi->{Hash} or
1432 fail "file $f has hash $got but .dsc".
1433 " demands hash $fi->{Hash} ".
1434 ($downloaded ? "(got wrong file from archive!)"
1435 : "(perhaps you should delete this file?)");
1438 sub ensure_we_have_orig () {
1439 foreach my $fi (dsc_files_info()) {
1440 my $f = $fi->{Filename};
1441 next unless is_orig_file($f);
1442 complete_file_from_dsc('..', $fi);
1446 sub git_fetch_us () {
1447 my @specs = (fetchspec());
1449 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1451 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1454 my $tagpat = debiantag('*',access_basedistro);
1456 git_for_each_ref("refs/tags/".$tagpat, sub {
1457 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1458 printdebug "currently $fullrefname=$objid\n";
1459 $here{$fullrefname} = $objid;
1461 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1462 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1463 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1464 printdebug "offered $lref=$objid\n";
1465 if (!defined $here{$lref}) {
1466 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1467 runcmd_ordryrun_local @upd;
1468 } elsif ($here{$lref} eq $objid) {
1471 "Not updateting $lref from $here{$lref} to $objid.\n";
1476 sub fetch_from_archive () {
1477 # ensures that lrref() is what is actually in the archive,
1478 # one way or another
1482 foreach my $field (@ourdscfield) {
1483 $dsc_hash = $dsc->{$field};
1484 last if defined $dsc_hash;
1486 if (defined $dsc_hash) {
1487 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1489 progress "last upload to archive specified git hash";
1491 progress "last upload to archive has NO git hash";
1494 progress "no version available from the archive";
1497 $lastpush_hash = git_get_ref(lrref());
1498 printdebug "previous reference hash=$lastpush_hash\n";
1500 if (defined $dsc_hash) {
1501 fail "missing remote git history even though dsc has hash -".
1502 " could not find ref ".lrref().
1503 " (should have been fetched from ".access_giturl()."#".rrref().")"
1504 unless $lastpush_hash;
1506 ensure_we_have_orig();
1507 if ($dsc_hash eq $lastpush_hash) {
1508 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1509 print STDERR <<END or die $!;
1511 Git commit in archive is behind the last version allegedly pushed/uploaded.
1512 Commit referred to by archive: $dsc_hash
1513 Last allegedly pushed/uploaded: $lastpush_hash
1516 $hash = $lastpush_hash;
1518 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1519 "descendant of archive's .dsc hash ($dsc_hash)";
1522 $hash = generate_commit_from_dsc();
1523 } elsif ($lastpush_hash) {
1524 # only in git, not in the archive yet
1525 $hash = $lastpush_hash;
1526 print STDERR <<END or die $!;
1528 Package not found in the archive, but has allegedly been pushed using dgit.
1532 printdebug "nothing found!\n";
1533 if (defined $skew_warning_vsn) {
1534 print STDERR <<END or die $!;
1536 Warning: relevant archive skew detected.
1537 Archive allegedly contains $skew_warning_vsn
1538 But we were not able to obtain any version from the archive or git.
1544 printdebug "current hash=$hash\n";
1545 if ($lastpush_hash) {
1546 fail "not fast forward on last upload branch!".
1547 " (archive's version left in DGIT_ARCHIVE)"
1548 unless is_fast_fwd($lastpush_hash, $hash);
1550 if (defined $skew_warning_vsn) {
1552 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1553 my $clogf = ".git/dgit/changelog.tmp";
1554 runcmd shell_cmd "exec >$clogf",
1555 @git, qw(cat-file blob), "$hash:debian/changelog";
1556 my $gotclogp = parsechangelog("-l$clogf");
1557 my $got_vsn = getfield $gotclogp, 'Version';
1558 printdebug "SKEW CHECK GOT $got_vsn\n";
1559 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1560 print STDERR <<END or die $!;
1562 Warning: archive skew detected. Using the available version:
1563 Archive allegedly contains $skew_warning_vsn
1564 We were able to obtain only $got_vsn
1569 if ($lastpush_hash ne $hash) {
1570 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1574 dryrun_report @upd_cmd;
1580 sub set_local_git_config ($$) {
1582 runcmd @git, qw(config), $k, $v;
1585 sub setup_mergechangelogs () {
1586 my $driver = 'dpkg-mergechangelogs';
1587 my $cb = "merge.$driver";
1588 my $attrs = '.git/info/attributes';
1589 ensuredir '.git/info';
1591 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1592 if (!open ATTRS, "<", $attrs) {
1593 $!==ENOENT or die "$attrs: $!";
1597 next if m{^debian/changelog\s};
1598 print NATTRS $_, "\n" or die $!;
1600 ATTRS->error and die $!;
1603 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1606 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1607 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1609 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1614 canonicalise_suite();
1615 badusage "dry run makes no sense with clone" unless act_local();
1616 my $hasgit = check_for_git();
1617 mkdir $dstdir or die "$dstdir $!";
1619 runcmd @git, qw(init -q);
1620 my $giturl = access_giturl(1);
1621 if (defined $giturl) {
1622 set_local_git_config "remote.$remotename.fetch", fetchspec();
1623 open H, "> .git/HEAD" or die $!;
1624 print H "ref: ".lref()."\n" or die $!;
1626 runcmd @git, qw(remote add), 'origin', $giturl;
1629 progress "fetching existing git history";
1631 runcmd_ordryrun_local @git, qw(fetch origin);
1633 progress "starting new git history";
1635 fetch_from_archive() or no_such_package;
1636 my $vcsgiturl = $dsc->{'Vcs-Git'};
1637 if (length $vcsgiturl) {
1638 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1639 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1641 setup_mergechangelogs();
1642 runcmd @git, qw(reset --hard), lrref();
1643 printdone "ready for work in $dstdir";
1647 if (check_for_git()) {
1650 fetch_from_archive() or no_such_package();
1651 printdone "fetched into ".lrref();
1656 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1658 printdone "fetched to ".lrref()." and merged into HEAD";
1661 sub check_not_dirty () {
1662 return if $ignoredirty;
1663 my @cmd = (@git, qw(diff --quiet HEAD));
1665 $!=0; $?=0; system @cmd;
1666 return if !$! && !$?;
1667 if (!$! && $?==256) {
1668 fail "working tree is dirty (does not match HEAD)";
1674 sub commit_admin ($) {
1677 runcmd_ordryrun_local @git, qw(commit -m), $m;
1680 sub commit_quilty_patch () {
1681 my $output = cmdoutput @git, qw(status --porcelain);
1683 foreach my $l (split /\n/, $output) {
1684 next unless $l =~ m/\S/;
1685 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1689 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1691 progress "nothing quilty to commit, ok.";
1694 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1695 commit_admin "Commit Debian 3.0 (quilt) metadata";
1698 sub get_source_format () {
1699 if (!open F, "debian/source/format") {
1700 die $! unless $!==&ENOENT;
1704 F->error and die $!;
1711 return 0 unless $format eq '3.0 (quilt)';
1712 if ($quilt_mode eq 'nocheck') {
1713 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1716 progress "Format \`$format', checking/updating patch stack";
1720 sub push_parse_changelog ($) {
1723 my $clogp = Dpkg::Control::Hash->new();
1724 $clogp->load($clogpfn) or die;
1726 $package = getfield $clogp, 'Source';
1727 my $cversion = getfield $clogp, 'Version';
1728 my $tag = debiantag($cversion, access_basedistro);
1729 runcmd @git, qw(check-ref-format), $tag;
1731 my $dscfn = dscfn($cversion);
1733 return ($clogp, $cversion, $tag, $dscfn);
1736 sub push_parse_dsc ($$$) {
1737 my ($dscfn,$dscfnwhat, $cversion) = @_;
1738 $dsc = parsecontrol($dscfn,$dscfnwhat);
1739 my $dversion = getfield $dsc, 'Version';
1740 my $dscpackage = getfield $dsc, 'Source';
1741 ($dscpackage eq $package && $dversion eq $cversion) or
1742 fail "$dscfn is for $dscpackage $dversion".
1743 " but debian/changelog is for $package $cversion";
1746 sub push_mktag ($$$$$$$) {
1747 my ($head,$clogp,$tag,
1749 $changesfile,$changesfilewhat,
1752 $dsc->{$ourdscfield[0]} = $head;
1753 $dsc->save("$dscfn.tmp") or die $!;
1755 my $changes = parsecontrol($changesfile,$changesfilewhat);
1756 foreach my $field (qw(Source Distribution Version)) {
1757 $changes->{$field} eq $clogp->{$field} or
1758 fail "changes field $field \`$changes->{$field}'".
1759 " does not match changelog \`$clogp->{$field}'";
1762 my $cversion = getfield $clogp, 'Version';
1763 my $clogsuite = getfield $clogp, 'Distribution';
1765 # We make the git tag by hand because (a) that makes it easier
1766 # to control the "tagger" (b) we can do remote signing
1767 my $authline = clogp_authline $clogp;
1768 my $delibs = join(" ", "",@deliberatelies);
1769 my $declaredistro = access_basedistro();
1770 open TO, '>', $tfn->('.tmp') or die $!;
1771 print TO <<END or die $!;
1777 $package release $cversion for $clogsuite ($csuite) [dgit]
1778 [dgit distro=$declaredistro$delibs]
1780 foreach my $ref (sort keys %previously) {
1781 print TO <<END or die $!;
1782 [dgit previously:$ref=$previously{$ref}]
1788 my $tagobjfn = $tfn->('.tmp');
1790 if (!defined $keyid) {
1791 $keyid = access_cfg('keyid','RETURN-UNDEF');
1793 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1794 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1795 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1796 push @sign_cmd, $tfn->('.tmp');
1797 runcmd_ordryrun @sign_cmd;
1799 $tagobjfn = $tfn->('.signed.tmp');
1800 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1801 $tfn->('.tmp'), $tfn->('.tmp.asc');
1808 sub sign_changes ($) {
1809 my ($changesfile) = @_;
1811 my @debsign_cmd = @debsign;
1812 push @debsign_cmd, "-k$keyid" if defined $keyid;
1813 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1814 push @debsign_cmd, $changesfile;
1815 runcmd_ordryrun @debsign_cmd;
1820 my ($forceflag) = @_;
1821 printdebug "actually entering push\n";
1824 access_giturl(); # check that success is vaguely likely
1826 my $clogpfn = ".git/dgit/changelog.822.tmp";
1827 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1829 responder_send_file('parsed-changelog', $clogpfn);
1831 my ($clogp, $cversion, $tag, $dscfn) =
1832 push_parse_changelog("$clogpfn");
1834 my $dscpath = "$buildproductsdir/$dscfn";
1835 stat_exists $dscpath or
1836 fail "looked for .dsc $dscfn, but $!;".
1837 " maybe you forgot to build";
1839 responder_send_file('dsc', $dscpath);
1841 push_parse_dsc($dscpath, $dscfn, $cversion);
1843 my $format = getfield $dsc, 'Format';
1844 printdebug "format $format\n";
1845 if (madformat($format)) {
1846 commit_quilty_patch();
1850 progress "checking that $dscfn corresponds to HEAD";
1851 runcmd qw(dpkg-source -x --),
1852 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1853 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1854 check_for_vendor_patches() if madformat($dsc->{format});
1855 changedir '../../../..';
1856 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1857 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1858 debugcmd "+",@diffcmd;
1860 my $r = system @diffcmd;
1863 fail "$dscfn specifies a different tree to your HEAD commit;".
1864 " perhaps you forgot to build".
1865 ($diffopt eq '--exit-code' ? "" :
1866 " (run with -D to see full diff output)");
1871 my $head = git_rev_parse('HEAD');
1872 if (!$changesfile) {
1873 my $multi = "$buildproductsdir/".
1874 "${package}_".(stripepoch $cversion)."_multi.changes";
1875 if (stat_exists "$multi") {
1876 $changesfile = $multi;
1878 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1879 my @cs = glob "$buildproductsdir/$pat";
1880 fail "failed to find unique changes file".
1881 " (looked for $pat in $buildproductsdir, or $multi);".
1882 " perhaps you need to use dgit -C"
1884 ($changesfile) = @cs;
1887 $changesfile = "$buildproductsdir/$changesfile";
1890 responder_send_file('changes',$changesfile);
1891 responder_send_command("param head $head");
1892 responder_send_command("param csuite $csuite");
1894 if (deliberately_not_fast_forward) {
1895 git_for_each_ref(lrfetchrefs, sub {
1896 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1897 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1898 responder_send_command("previously $rrefname=$objid");
1899 $previously{$rrefname} = $objid;
1903 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1906 if ($we_are_responder) {
1907 $tagobjfn = $tfn->('.signed.tmp');
1908 responder_receive_files('signed-tag', $tagobjfn);
1911 push_mktag($head,$clogp,$tag,
1913 $changesfile,$changesfile,
1917 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1918 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1919 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1921 if (!check_for_git()) {
1922 create_remote_git_repo();
1924 runcmd_ordryrun @git, qw(push),access_giturl(),
1925 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1926 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1928 if ($we_are_responder) {
1929 my $dryrunsuffix = act_local() ? "" : ".tmp";
1930 responder_receive_files('signed-dsc-changes',
1931 "$dscpath$dryrunsuffix",
1932 "$changesfile$dryrunsuffix");
1935 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1937 progress "[new .dsc left in $dscpath.tmp]";
1939 sign_changes $changesfile;
1942 my $host = access_cfg('upload-host','RETURN-UNDEF');
1943 my @hostarg = defined($host) ? ($host,) : ();
1944 runcmd_ordryrun @dput, @hostarg, $changesfile;
1945 printdone "pushed and uploaded $cversion";
1947 responder_send_command("complete");
1953 badusage "-p is not allowed with clone; specify as argument instead"
1954 if defined $package;
1957 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1958 ($package,$isuite) = @ARGV;
1959 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1960 ($package,$dstdir) = @ARGV;
1961 } elsif (@ARGV==3) {
1962 ($package,$isuite,$dstdir) = @ARGV;
1964 badusage "incorrect arguments to dgit clone";
1966 $dstdir ||= "$package";
1968 if (stat_exists $dstdir) {
1969 fail "$dstdir already exists";
1973 if ($rmonerror && !$dryrun_level) {
1974 $cwd_remove= getcwd();
1976 return unless defined $cwd_remove;
1977 if (!chdir "$cwd_remove") {
1978 return if $!==&ENOENT;
1979 die "chdir $cwd_remove: $!";
1981 rmtree($dstdir) or die "remove $dstdir: $!\n";
1986 $cwd_remove = undef;
1989 sub branchsuite () {
1990 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1991 if ($branch =~ m#$lbranch_re#o) {
1998 sub fetchpullargs () {
1999 if (!defined $package) {
2000 my $sourcep = parsecontrol('debian/control','debian/control');
2001 $package = getfield $sourcep, 'Source';
2004 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2006 my $clogp = parsechangelog();
2007 $isuite = getfield $clogp, 'Distribution';
2009 canonicalise_suite();
2010 progress "fetching from suite $csuite";
2011 } elsif (@ARGV==1) {
2013 canonicalise_suite();
2015 badusage "incorrect arguments to dgit fetch or dgit pull";
2034 badusage "-p is not allowed with dgit push" if defined $package;
2036 my $clogp = parsechangelog();
2037 $package = getfield $clogp, 'Source';
2040 } elsif (@ARGV==1) {
2041 ($specsuite) = (@ARGV);
2043 badusage "incorrect arguments to dgit push";
2045 $isuite = getfield $clogp, 'Distribution';
2047 local ($package) = $existing_package; # this is a hack
2048 canonicalise_suite();
2050 canonicalise_suite();
2052 if (defined $specsuite &&
2053 $specsuite ne $isuite &&
2054 $specsuite ne $csuite) {
2055 fail "dgit push: changelog specifies $isuite ($csuite)".
2056 " but command line specifies $specsuite";
2058 if (check_for_git()) {
2062 if (fetch_from_archive()) {
2063 if (is_fast_fwd(lrref(), 'HEAD')) {
2065 } elsif (deliberately_not_fast_forward) {
2068 fail "dgit push: HEAD is not a descendant".
2069 " of the archive's version.\n".
2070 "dgit: To overwrite its contents,".
2071 " use git merge -s ours ".lrref().".\n".
2072 "dgit: To rewind history, if permitted by the archive,".
2073 " use --deliberately-not-fast-forward";
2077 fail "package appears to be new in this suite;".
2078 " if this is intentional, use --new";
2083 #---------- remote commands' implementation ----------
2085 sub cmd_remote_push_build_host {
2087 my ($nrargs) = shift @ARGV;
2088 my (@rargs) = @ARGV[0..$nrargs-1];
2089 @ARGV = @ARGV[$nrargs..$#ARGV];
2091 my ($dir,$vsnwant) = @rargs;
2092 # vsnwant is a comma-separated list; we report which we have
2093 # chosen in our ready response (so other end can tell if they
2096 $we_are_responder = 1;
2097 $us .= " (build host)";
2099 open PI, "<&STDIN" or die $!;
2100 open STDIN, "/dev/null" or die $!;
2101 open PO, ">&STDOUT" or die $!;
2103 open STDOUT, ">&STDERR" or die $!;
2107 fail "build host has dgit rpush protocol version".
2108 " $rpushprotovsn but invocation host has $vsnwant"
2109 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2111 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2117 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2118 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2119 # a good error message)
2125 my $report = i_child_report();
2126 if (defined $report) {
2127 printdebug "($report)\n";
2128 } elsif ($i_child_pid) {
2129 printdebug "(killing build host child $i_child_pid)\n";
2130 kill 15, $i_child_pid;
2132 if (defined $i_tmp && !defined $initiator_tempdir) {
2134 eval { rmtree $i_tmp; };
2138 END { i_cleanup(); }
2141 my ($base,$selector,@args) = @_;
2142 $selector =~ s/\-/_/g;
2143 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2150 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2157 my @rargs = ($dir,$rpushprotovsn);
2160 push @rdgit, @ropts;
2161 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2163 my @cmd = (@ssh, $host, shellquote @rdgit);
2166 if (defined $initiator_tempdir) {
2167 rmtree $initiator_tempdir;
2168 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2169 $i_tmp = $initiator_tempdir;
2173 $i_child_pid = open2(\*RO, \*RI, @cmd);
2175 initiator_expect { m/^dgit-remote-push-ready/ };
2177 my ($icmd,$iargs) = initiator_expect {
2178 m/^(\S+)(?: (.*))?$/;
2181 i_method "i_resp", $icmd, $iargs;
2185 sub i_resp_progress ($) {
2187 my $msg = protocol_read_bytes \*RO, $rhs;
2191 sub i_resp_complete {
2192 my $pid = $i_child_pid;
2193 $i_child_pid = undef; # prevents killing some other process with same pid
2194 printdebug "waiting for build host child $pid...\n";
2195 my $got = waitpid $pid, 0;
2196 die $! unless $got == $pid;
2197 die "build host child failed $?" if $?;
2200 printdebug "all done\n";
2204 sub i_resp_file ($) {
2206 my $localname = i_method "i_localname", $keyword;
2207 my $localpath = "$i_tmp/$localname";
2208 stat_exists $localpath and
2209 badproto \*RO, "file $keyword ($localpath) twice";
2210 protocol_receive_file \*RO, $localpath;
2211 i_method "i_file", $keyword;
2216 sub i_resp_param ($) {
2217 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2221 sub i_resp_previously ($) {
2222 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2223 or badproto \*RO, "bad previously spec";
2224 my $r = system qw(git check-ref-format), $1;
2225 die "bad previously ref spec ($r)" if $r;
2226 $previously{$1} = $2;
2231 sub i_resp_want ($) {
2233 die "$keyword ?" if $i_wanted{$keyword}++;
2234 my @localpaths = i_method "i_want", $keyword;
2235 printdebug "[[ $keyword @localpaths\n";
2236 foreach my $localpath (@localpaths) {
2237 protocol_send_file \*RI, $localpath;
2239 print RI "files-end\n" or die $!;
2242 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2244 sub i_localname_parsed_changelog {
2245 return "remote-changelog.822";
2247 sub i_file_parsed_changelog {
2248 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2249 push_parse_changelog "$i_tmp/remote-changelog.822";
2250 die if $i_dscfn =~ m#/|^\W#;
2253 sub i_localname_dsc {
2254 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2259 sub i_localname_changes {
2260 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2261 $i_changesfn = $i_dscfn;
2262 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2263 return $i_changesfn;
2265 sub i_file_changes { }
2267 sub i_want_signed_tag {
2268 printdebug Dumper(\%i_param, $i_dscfn);
2269 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2270 && defined $i_param{'csuite'}
2271 or badproto \*RO, "premature desire for signed-tag";
2272 my $head = $i_param{'head'};
2273 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2275 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2277 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2280 push_mktag $head, $i_clogp, $i_tag,
2282 $i_changesfn, 'remote changes',
2283 sub { "tag$_[0]"; };
2288 sub i_want_signed_dsc_changes {
2289 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2290 sign_changes $i_changesfn;
2291 return ($i_dscfn, $i_changesfn);
2294 #---------- building etc. ----------
2300 #----- `3.0 (quilt)' handling -----
2302 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2304 sub quiltify_dpkg_commit ($$$;$) {
2305 my ($patchname,$author,$msg, $xinfo) = @_;
2309 my $descfn = ".git/dgit/quilt-description.tmp";
2310 open O, '>', $descfn or die "$descfn: $!";
2313 $msg =~ s/^\s+$/ ./mg;
2314 print O <<END or die $!;
2324 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2325 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2326 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2327 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2331 sub quiltify_trees_differ ($$) {
2333 # returns 1 iff the two tree objects differ other than in debian/
2335 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2336 my $diffs= cmdoutput @cmd;
2337 foreach my $f (split /\0/, $diffs) {
2338 next if $f eq 'debian';
2344 sub quiltify_tree_sentinelfiles ($) {
2345 # lists the `sentinel' files present in the tree
2347 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2348 qw(-- debian/rules debian/control);
2354 my ($clogp,$target) = @_;
2356 # Quilt patchification algorithm
2358 # We search backwards through the history of the main tree's HEAD
2359 # (T) looking for a start commit S whose tree object is identical
2360 # to to the patch tip tree (ie the tree corresponding to the
2361 # current dpkg-committed patch series). For these purposes
2362 # `identical' disregards anything in debian/ - this wrinkle is
2363 # necessary because dpkg-source treates debian/ specially.
2365 # We can only traverse edges where at most one of the ancestors'
2366 # trees differs (in changes outside in debian/). And we cannot
2367 # handle edges which change .pc/ or debian/patches. To avoid
2368 # going down a rathole we avoid traversing edges which introduce
2369 # debian/rules or debian/control. And we set a limit on the
2370 # number of edges we are willing to look at.
2372 # If we succeed, we walk forwards again. For each traversed edge
2373 # PC (with P parent, C child) (starting with P=S and ending with
2374 # C=T) to we do this:
2376 # - dpkg-source --commit with a patch name and message derived from C
2377 # After traversing PT, we git commit the changes which
2378 # should be contained within debian/patches.
2380 changedir '../fake';
2381 mktree_in_ud_here();
2383 runcmd @git, 'add', '.';
2384 my $oldtiptree=git_write_tree();
2385 changedir '../work';
2387 # The search for the path S..T is breadth-first. We maintain a
2388 # todo list containing search nodes. A search node identifies a
2389 # commit, and looks something like this:
2391 # Commit => $git_commit_id,
2392 # Child => $c, # or undef if P=T
2393 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2394 # Nontrivial => true iff $p..$c has relevant changes
2401 my %considered; # saves being exponential on some weird graphs
2403 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2406 my ($search,$whynot) = @_;
2407 printdebug " search NOT $search->{Commit} $whynot\n";
2408 $search->{Whynot} = $whynot;
2409 push @nots, $search;
2410 no warnings qw(exiting);
2419 my $c = shift @todo;
2420 next if $considered{$c->{Commit}}++;
2422 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2424 printdebug "quiltify investigate $c->{Commit}\n";
2427 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2428 printdebug " search finished hooray!\n";
2433 if ($quilt_mode eq 'nofix') {
2434 fail "quilt fixup required but quilt mode is \`nofix'\n".
2435 "HEAD commit $c->{Commit} differs from tree implied by ".
2436 " debian/patches (tree object $oldtiptree)";
2438 if ($quilt_mode eq 'smash') {
2439 printdebug " search quitting smash\n";
2443 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2444 $not->($c, "has $c_sentinels not $t_sentinels")
2445 if $c_sentinels ne $t_sentinels;
2447 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2448 $commitdata =~ m/\n\n/;
2450 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2451 @parents = map { { Commit => $_, Child => $c } } @parents;
2453 $not->($c, "root commit") if !@parents;
2455 foreach my $p (@parents) {
2456 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2458 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2459 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2461 foreach my $p (@parents) {
2462 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2464 my @cmd= (@git, qw(diff-tree -r --name-only),
2465 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2466 my $patchstackchange = cmdoutput @cmd;
2467 if (length $patchstackchange) {
2468 $patchstackchange =~ s/\n/,/g;
2469 $not->($p, "changed $patchstackchange");
2472 printdebug " search queue P=$p->{Commit} ",
2473 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2479 printdebug "quiltify want to smash\n";
2482 my $x = $_[0]{Commit};
2483 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2486 my $reportnot = sub {
2488 my $s = $abbrev->($notp);
2489 my $c = $notp->{Child};
2490 $s .= "..".$abbrev->($c) if $c;
2491 $s .= ": ".$notp->{Whynot};
2494 if ($quilt_mode eq 'linear') {
2495 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2496 foreach my $notp (@nots) {
2497 print STDERR "$us: ", $reportnot->($notp), "\n";
2499 fail "quilt fixup naive history linearisation failed.\n".
2500 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2501 } elsif ($quilt_mode eq 'smash') {
2502 } elsif ($quilt_mode eq 'auto') {
2503 progress "quilt fixup cannot be linear, smashing...";
2505 die "$quilt_mode ?";
2510 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2512 quiltify_dpkg_commit "auto-$version-$target-$time",
2513 (getfield $clogp, 'Maintainer'),
2514 "Automatically generated patch ($clogp->{Version})\n".
2515 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2519 progress "quiltify linearisation planning successful, executing...";
2521 for (my $p = $sref_S;
2522 my $c = $p->{Child};
2524 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2525 next unless $p->{Nontrivial};
2527 my $cc = $c->{Commit};
2529 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2530 $commitdata =~ m/\n\n/ or die "$c ?";
2533 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2536 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2539 my $patchname = $title;
2540 $patchname =~ s/[.:]$//;
2541 $patchname =~ y/ A-Z/-a-z/;
2542 $patchname =~ y/-a-z0-9_.+=~//cd;
2543 $patchname =~ s/^\W/x-$&/;
2544 $patchname = substr($patchname,0,40);
2547 stat "debian/patches/$patchname$index";
2549 $!==ENOENT or die "$patchname$index $!";
2551 runcmd @git, qw(checkout -q), $cc;
2553 # We use the tip's changelog so that dpkg-source doesn't
2554 # produce complaining messages from dpkg-parsechangelog. None
2555 # of the information dpkg-source gets from the changelog is
2556 # actually relevant - it gets put into the original message
2557 # which dpkg-source provides our stunt editor, and then
2559 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2561 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2562 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2564 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2567 runcmd @git, qw(checkout -q master);
2570 sub build_maybe_quilt_fixup () {
2571 my $format=get_source_format;
2572 return unless madformat $format;
2575 check_for_vendor_patches();
2578 # - honour any existing .pc in case it has any strangeness
2579 # - determine the git commit corresponding to the tip of
2580 # the patch stack (if there is one)
2581 # - if there is such a git commit, convert each subsequent
2582 # git commit into a quilt patch with dpkg-source --commit
2583 # - otherwise convert all the differences in the tree into
2584 # a single git commit
2588 # Our git tree doesn't necessarily contain .pc. (Some versions of
2589 # dgit would include the .pc in the git tree.) If there isn't
2590 # one, we need to generate one by unpacking the patches that we
2593 # We first look for a .pc in the git tree. If there is one, we
2594 # will use it. (This is not the normal case.)
2596 # Otherwise need to regenerate .pc so that dpkg-source --commit
2597 # can work. We do this as follows:
2598 # 1. Collect all relevant .orig from parent directory
2599 # 2. Generate a debian.tar.gz out of
2600 # debian/{patches,rules,source/format}
2601 # 3. Generate a fake .dsc containing just these fields:
2602 # Format Source Version Files
2603 # 4. Extract the fake .dsc
2604 # Now the fake .dsc has a .pc directory.
2605 # (In fact we do this in every case, because in future we will
2606 # want to search for a good base commit for generating patches.)
2608 # Then we can actually do the dpkg-source --commit
2609 # 1. Make a new working tree with the same object
2610 # store as our main tree and check out the main
2612 # 2. Copy .pc from the fake's extraction, if necessary
2613 # 3. Run dpkg-source --commit
2614 # 4. If the result has changes to debian/, then
2615 # - git-add them them
2616 # - git-add .pc if we had a .pc in-tree
2618 # 5. If we had a .pc in-tree, delete it, and git-commit
2619 # 6. Back in the main tree, fast forward to the new HEAD
2621 my $clogp = parsechangelog();
2622 my $headref = git_rev_parse('HEAD');
2627 my $upstreamversion=$version;
2628 $upstreamversion =~ s/-[^-]*$//;
2630 my $fakeversion="$upstreamversion-~~DGITFAKE";
2632 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2633 print $fakedsc <<END or die $!;
2636 Version: $fakeversion
2640 my $dscaddfile=sub {
2643 my $md = new Digest::MD5;
2645 my $fh = new IO::File $b, '<' or die "$b $!";
2650 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2653 foreach my $f (<../../../../*>) { #/){
2654 my $b=$f; $b =~ s{.*/}{};
2655 next unless is_orig_file $b, srcfn $upstreamversion,'';
2656 link $f, $b or die "$b $!";
2660 my @files=qw(debian/source/format debian/rules);
2661 if (stat_exists '../../../debian/patches') {
2662 push @files, 'debian/patches';
2665 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2666 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2668 $dscaddfile->($debtar);
2669 close $fakedsc or die $!;
2671 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2673 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2674 rename $fakexdir, "fake" or die "$fakexdir $!";
2676 mkdir "work" or die $!;
2678 mktree_in_ud_here();
2679 runcmd @git, qw(reset --hard), $headref;
2682 if (stat_exists ".pc") {
2684 progress "Tree already contains .pc - will use it then delete it.";
2687 rename '../fake/.pc','.pc' or die $!;
2690 quiltify($clogp,$headref);
2692 if (!open P, '>>', ".pc/applied-patches") {
2693 $!==&ENOENT or die $!;
2698 commit_quilty_patch();
2700 if ($mustdeletepc) {
2701 runcmd @git, qw(rm -rqf .pc);
2702 commit_admin "Commit removal of .pc (quilt series tracking data)";
2705 changedir '../../../..';
2706 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2709 sub quilt_fixup_editor () {
2710 my $descfn = $ENV{$fakeeditorenv};
2711 my $editing = $ARGV[$#ARGV];
2712 open I1, '<', $descfn or die "$descfn: $!";
2713 open I2, '<', $editing or die "$editing: $!";
2714 unlink $editing or die "$editing: $!";
2715 open O, '>', $editing or die "$editing: $!";
2716 while (<I1>) { print O or die $!; } I1->error and die $!;
2719 $copying ||= m/^\-\-\- /;
2720 next unless $copying;
2723 I2->error and die $!;
2728 #----- other building -----
2731 if ($cleanmode eq 'dpkg-source') {
2732 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2733 } elsif ($cleanmode eq 'dpkg-source-d') {
2734 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2735 } elsif ($cleanmode eq 'git') {
2736 runcmd_ordryrun_local @git, qw(clean -xdf);
2737 } elsif ($cleanmode eq 'git-ff') {
2738 runcmd_ordryrun_local @git, qw(clean -xdff);
2739 } elsif ($cleanmode eq 'check') {
2740 my $leftovers = cmdoutput @git, qw(clean -xdn);
2741 if (length $leftovers) {
2742 print STDERR $leftovers, "\n" or die $!;
2743 fail "tree contains uncommitted files and --clean=check specified";
2745 } elsif ($cleanmode eq 'none') {
2752 badusage "clean takes no additional arguments" if @ARGV;
2757 badusage "-p is not allowed when building" if defined $package;
2760 my $clogp = parsechangelog();
2761 $isuite = getfield $clogp, 'Distribution';
2762 $package = getfield $clogp, 'Source';
2763 $version = getfield $clogp, 'Version';
2764 build_maybe_quilt_fixup();
2767 sub changesopts () {
2768 my @opts =@changesopts[1..$#changesopts];
2769 if (!defined $changes_since_version) {
2770 my @vsns = archive_query('archive_query');
2771 my @quirk = access_quirk();
2772 if ($quirk[0] eq 'backports') {
2773 local $isuite = $quirk[2];
2775 canonicalise_suite();
2776 push @vsns, archive_query('archive_query');
2779 @vsns = map { $_->[0] } @vsns;
2780 @vsns = sort { -version_compare($a, $b) } @vsns;
2781 $changes_since_version = $vsns[0];
2782 progress "changelog will contain changes since $vsns[0]";
2784 $changes_since_version = '_';
2785 progress "package seems new, not specifying -v<version>";
2788 if ($changes_since_version ne '_') {
2789 unshift @opts, "-v$changes_since_version";
2794 sub massage_dbp_args ($) {
2796 return unless $cleanmode =~ m/git|none/;
2797 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2798 my @newcmd = shift @$cmd;
2799 # -nc has the side effect of specifying -b if nothing else specified
2800 push @newcmd, '-nc';
2801 # and some combinations of -S, -b, et al, are errors, rather than
2802 # later simply overriding earlier
2803 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2804 push @newcmd, @$cmd;
2810 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2811 massage_dbp_args \@dbp;
2812 runcmd_ordryrun_local @dbp;
2813 printdone "build successful\n";
2818 my @dbp = @dpkgbuildpackage;
2819 massage_dbp_args \@dbp;
2821 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2822 "--git-builder=@dbp");
2823 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2824 canonicalise_suite();
2825 push @cmd, "--git-debian-branch=".lbranch();
2827 push @cmd, changesopts();
2828 runcmd_ordryrun_local @cmd, @ARGV;
2829 printdone "build successful\n";
2834 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2835 $dscfn = dscfn($version);
2836 if ($cleanmode eq 'dpkg-source') {
2837 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2839 } elsif ($cleanmode eq 'dpkg-source-d') {
2840 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2843 my $pwd = must_getcwd();
2844 my $leafdir = basename $pwd;
2846 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2848 runcmd_ordryrun_local qw(sh -ec),
2849 'exec >$1; shift; exec "$@"','x',
2850 "../$sourcechanges",
2851 @dpkggenchanges, qw(-S), changesopts();
2855 sub cmd_build_source {
2856 badusage "build-source takes no additional arguments" if @ARGV;
2858 printdone "source built, results in $dscfn and $sourcechanges";
2864 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2866 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2867 stat_exists $sourcechanges
2868 or fail "$sourcechanges (in parent directory): $!";
2869 foreach my $cf (glob $pat) {
2870 next if $cf eq $sourcechanges;
2871 unlink $cf or fail "remove $cf: $!";
2874 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2875 my @changesfiles = glob $pat;
2876 @changesfiles = sort {
2877 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2880 fail "wrong number of different changes files (@changesfiles)"
2881 unless @changesfiles;
2882 runcmd_ordryrun_local @mergechanges, @changesfiles;
2883 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2885 stat_exists $multichanges or fail "$multichanges: $!";
2887 printdone "build successful, results in $multichanges\n" or die $!;
2890 sub cmd_quilt_fixup {
2891 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2892 my $clogp = parsechangelog();
2893 $version = getfield $clogp, 'Version';
2894 $package = getfield $clogp, 'Source';
2895 build_maybe_quilt_fixup();
2898 sub cmd_archive_api_query {
2899 badusage "need only 1 subpath argument" unless @ARGV==1;
2900 my ($subpath) = @ARGV;
2901 my @cmd = archive_api_query_cmd($subpath);
2903 exec @cmd or fail "exec curl: $!\n";
2906 sub cmd_clone_dgit_repos_server {
2907 badusage "need destination argument" unless @ARGV==1;
2908 my ($destdir) = @ARGV;
2909 $package = '_dgit-repos-server';
2910 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2912 exec @cmd or fail "exec git clone: $!\n";
2915 sub cmd_setup_mergechangelogs {
2916 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2917 setup_mergechangelogs();
2920 #---------- argument parsing and main program ----------
2923 print "dgit version $our_version\n" or die $!;
2930 if (defined $ENV{'DGIT_SSH'}) {
2931 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2932 } elsif (defined $ENV{'GIT_SSH'}) {
2933 @ssh = ($ENV{'GIT_SSH'});
2937 last unless $ARGV[0] =~ m/^-/;
2941 if (m/^--dry-run$/) {
2944 } elsif (m/^--damp-run$/) {
2947 } elsif (m/^--no-sign$/) {
2950 } elsif (m/^--help$/) {
2952 } elsif (m/^--version$/) {
2954 } elsif (m/^--new$/) {
2957 } elsif (m/^--since-version=([^_]+|_)$/) {
2959 $changes_since_version = $1;
2960 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2961 ($om = $opts_opt_map{$1}) &&
2965 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2966 !$opts_opt_cmdonly{$1} &&
2967 ($om = $opts_opt_map{$1})) {
2970 } elsif (m/^--existing-package=(.*)/s) {
2972 $existing_package = $1;
2973 } elsif (m/^--initiator-tempdir=(.*)/s) {
2974 $initiator_tempdir = $1;
2975 $initiator_tempdir =~ m#^/# or
2976 badusage "--initiator-tempdir must be used specify an".
2977 " absolute, not relative, directory."
2978 } elsif (m/^--distro=(.*)/s) {
2981 } elsif (m/^--build-products-dir=(.*)/s) {
2983 $buildproductsdir = $1;
2984 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2987 } elsif (m/^--clean=(.*)$/s) {
2988 badusage "unknown cleaning mode \`$1'";
2989 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2992 } elsif (m/^--quilt=(.*)$/s) {
2993 badusage "unknown quilt fixup mode \`$1'";
2994 } elsif (m/^--ignore-dirty$/s) {
2997 } elsif (m/^--no-quilt-fixup$/s) {
2999 $quilt_mode = 'nocheck';
3000 } elsif (m/^--no-rm-on-error$/s) {
3003 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3005 push @deliberatelies, $&;
3007 badusage "unknown long option \`$_'";
3014 } elsif (s/^-L/-/) {
3017 } elsif (s/^-h/-/) {
3019 } elsif (s/^-D/-/) {
3023 } elsif (s/^-N/-/) {
3026 } elsif (s/^-v([^_]+|_)$//s) {
3028 $changes_since_version = $1;
3031 push @changesopts, $_;
3033 } elsif (s/^-c(.*=.*)//s) {
3035 push @git, '-c', $1;
3036 } elsif (s/^-d(.+)//s) {
3039 } elsif (s/^-C(.+)//s) {
3042 if ($changesfile =~ s#^(.*)/##) {
3043 $buildproductsdir = $1;
3045 } elsif (s/^-k(.+)//s) {
3047 } elsif (m/^-[vdCk]$/) {
3049 "option \`$_' requires an argument (and no space before the argument)";
3050 } elsif (s/^-wn$//s) {
3052 $cleanmode = 'none';
3053 } elsif (s/^-wg$//s) {
3056 } elsif (s/^-wgf$//s) {
3058 $cleanmode = 'git-ff';
3059 } elsif (s/^-wd$//s) {
3061 $cleanmode = 'dpkg-source';
3062 } elsif (s/^-wdd$//s) {
3064 $cleanmode = 'dpkg-source-d';
3065 } elsif (s/^-wc$//s) {
3067 $cleanmode = 'check';
3069 badusage "unknown short option \`$_'";
3076 if ($ENV{$fakeeditorenv}) {
3077 quilt_fixup_editor();
3081 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3082 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3083 if $dryrun_level == 1;
3085 print STDERR $helpmsg or die $!;
3088 my $cmd = shift @ARGV;
3091 if (!defined $quilt_mode) {
3092 local $access_forpush;
3093 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3094 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3096 $quilt_mode =~ m/^($quilt_modes_re)$/
3097 or badcfg "unknown quilt-mode \`$quilt_mode'";
3101 my $fn = ${*::}{"cmd_$cmd"};
3102 $fn or badusage "unknown operation $cmd";