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_support = qw(2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
60 our $cleanmode = 'dpkg-source';
61 our $changes_since_version;
63 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
64 our $we_are_responder;
65 our $initiator_tempdir;
67 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
69 our $suite_re = '[-+.0-9a-z]+';
72 our (@dget) = qw(dget);
73 our (@curl) = qw(curl -f);
74 our (@dput) = qw(dput);
75 our (@debsign) = qw(debsign);
77 our (@sbuild) = qw(sbuild -A);
79 our (@dgit) = qw(dgit);
80 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
81 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
82 our (@dpkggenchanges) = qw(dpkg-genchanges);
83 our (@mergechanges) = qw(mergechanges -f);
84 our (@changesopts) = ('');
86 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
89 'debsign' => \@debsign,
94 'dpkg-source' => \@dpkgsource,
95 'dpkg-buildpackage' => \@dpkgbuildpackage,
96 'dpkg-genchanges' => \@dpkggenchanges,
97 'ch' => \@changesopts,
98 'mergechanges' => \@mergechanges);
100 our %opts_opt_cmdonly = ('gpg' => 1);
106 our $remotename = 'dgit';
107 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
111 sub lbranch () { return "$branchprefix/$csuite"; }
112 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
113 sub lref () { return "refs/heads/".lbranch(); }
114 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
115 sub rrref () { return server_ref($csuite); }
117 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
127 return "${package}_".(stripepoch $vsn).$sfx
132 return srcfn($vsn,".dsc");
141 foreach my $f (@end) {
143 warn "$us: cleanup: $@" if length $@;
147 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
149 sub no_such_package () {
150 print STDERR "$us: package $package does not exist in suite $isuite\n";
156 return "+".rrref().":".lrref();
161 printdebug "CD $newdir\n";
162 chdir $newdir or die "chdir: $newdir: $!";
165 sub deliberately ($) {
167 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
170 sub deliberately_not_fast_forward () {
171 foreach (qw(not-fast-forward fresh-repo)) {
172 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
176 #---------- remote protocol support, common ----------
178 # remote push initiator/responder protocol:
179 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
180 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
181 # < dgit-remote-push-ready <actual-proto-vsn>
183 # > file parsed-changelog
184 # [indicates that output of dpkg-parsechangelog follows]
185 # > data-block NBYTES
186 # > [NBYTES bytes of data (no newline)]
187 # [maybe some more blocks]
199 # [indicates that signed tag is wanted]
200 # < data-block NBYTES
201 # < [NBYTES bytes of data (no newline)]
202 # [maybe some more blocks]
206 # > want signed-dsc-changes
207 # < data-block NBYTES [transfer of signed dsc]
209 # < data-block NBYTES [transfer of signed changes]
217 sub i_child_report () {
218 # Sees if our child has died, and reap it if so. Returns a string
219 # describing how it died if it failed, or undef otherwise.
220 return undef unless $i_child_pid;
221 my $got = waitpid $i_child_pid, WNOHANG;
222 return undef if $got <= 0;
223 die unless $got == $i_child_pid;
224 $i_child_pid = undef;
225 return undef unless $?;
226 return "build host child ".waitstatusmsg();
231 fail "connection lost: $!" if $fh->error;
232 fail "protocol violation; $m not expected";
235 sub badproto_badread ($$) {
237 fail "connection lost: $!" if $!;
238 my $report = i_child_report();
239 fail $report if defined $report;
240 badproto $fh, "eof (reading $wh)";
243 sub protocol_expect (&$) {
244 my ($match, $fh) = @_;
247 defined && chomp or badproto_badread $fh, "protocol message";
255 badproto $fh, "\`$_'";
258 sub protocol_send_file ($$) {
259 my ($fh, $ourfn) = @_;
260 open PF, "<", $ourfn or die "$ourfn: $!";
263 my $got = read PF, $d, 65536;
264 die "$ourfn: $!" unless defined $got;
266 print $fh "data-block ".length($d)."\n" or die $!;
267 print $fh $d or die $!;
269 PF->error and die "$ourfn $!";
270 print $fh "data-end\n" or die $!;
274 sub protocol_read_bytes ($$) {
275 my ($fh, $nbytes) = @_;
276 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
278 my $got = read $fh, $d, $nbytes;
279 $got==$nbytes or badproto_badread $fh, "data block";
283 sub protocol_receive_file ($$) {
284 my ($fh, $ourfn) = @_;
285 printdebug "() $ourfn\n";
286 open PF, ">", $ourfn or die "$ourfn: $!";
288 my ($y,$l) = protocol_expect {
289 m/^data-block (.*)$/ ? (1,$1) :
290 m/^data-end$/ ? (0,) :
294 my $d = protocol_read_bytes $fh, $l;
295 print PF $d or die $!;
300 #---------- remote protocol support, responder ----------
302 sub responder_send_command ($) {
304 return unless $we_are_responder;
305 # called even without $we_are_responder
306 printdebug ">> $command\n";
307 print PO $command, "\n" or die $!;
310 sub responder_send_file ($$) {
311 my ($keyword, $ourfn) = @_;
312 return unless $we_are_responder;
313 printdebug "]] $keyword $ourfn\n";
314 responder_send_command "file $keyword";
315 protocol_send_file \*PO, $ourfn;
318 sub responder_receive_files ($@) {
319 my ($keyword, @ourfns) = @_;
320 die unless $we_are_responder;
321 printdebug "[[ $keyword @ourfns\n";
322 responder_send_command "want $keyword";
323 foreach my $fn (@ourfns) {
324 protocol_receive_file \*PI, $fn;
327 protocol_expect { m/^files-end$/ } \*PI;
330 #---------- remote protocol support, initiator ----------
332 sub initiator_expect (&) {
334 protocol_expect { &$match } \*RO;
337 #---------- end remote code ----------
340 if ($we_are_responder) {
342 responder_send_command "progress ".length($m) or die $!;
343 print PO $m or die $!;
353 $ua = LWP::UserAgent->new();
357 progress "downloading $what...";
358 my $r = $ua->get(@_) or die $!;
359 return undef if $r->code == 404;
360 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
361 return $r->decoded_content(charset => 'none');
364 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
369 failedcmd @_ if system @_;
372 sub act_local () { return $dryrun_level <= 1; }
373 sub act_scary () { return !$dryrun_level; }
376 if (!$dryrun_level) {
377 progress "dgit ok: @_";
379 progress "would be ok: @_ (but dry run only)";
384 printcmd(\*STDERR,$debugprefix."#",@_);
387 sub runcmd_ordryrun {
395 sub runcmd_ordryrun_local {
404 my ($first_shell, @cmd) = @_;
405 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
408 our $helpmsg = <<END;
410 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
411 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
412 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
413 dgit [dgit-opts] push [dgit-opts] [suite]
414 dgit [dgit-opts] rpush build-host:build-dir ...
415 important dgit options:
416 -k<keyid> sign tag and package with <keyid> instead of default
417 --dry-run -n do not change anything, but go through the motions
418 --damp-run -L like --dry-run but make local changes, without signing
419 --new -N allow introducing a new package
420 --debug -D increase debug level
421 -c<name>=<value> set git config option (used directly by dgit too)
424 our $later_warning_msg = <<END;
425 Perhaps the upload is stuck in incoming. Using the version from git.
429 print STDERR "$us: @_\n", $helpmsg or die $!;
434 @ARGV or badusage "too few arguments";
435 return scalar shift @ARGV;
439 print $helpmsg or die $!;
443 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
445 our %defcfg = ('dgit.default.distro' => 'debian',
446 'dgit.default.username' => '',
447 'dgit.default.archive-query-default-component' => 'main',
448 'dgit.default.ssh' => 'ssh',
449 'dgit.default.archive-query' => 'madison:',
450 'dgit.default.sshpsql-dbname' => 'service=projectb',
451 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
452 'dgit-distro.debian.git-check' => 'url',
453 'dgit-distro.debian.git-check-suffix' => '/info/refs',
454 'dgit-distro.debian.new-private-pushers' => 't',
455 'dgit-distro.debian/push.git-url' => '',
456 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
457 'dgit-distro.debian/push.git-user-force' => 'dgit',
458 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
459 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
460 'dgit-distro.debian/push.git-create' => 'true',
461 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
462 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
463 # 'dgit-distro.debian.archive-query-tls-key',
464 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
465 # ^ this does not work because curl is broken nowadays
466 # Fixing #790093 properly will involve providing providing the key
467 # in some pacagke and maybe updating these paths.
469 # 'dgit-distro.debian.archive-query-tls-curl-args',
470 # '--ca-path=/etc/ssl/ca-debian',
471 # ^ this is a workaround but works (only) on DSA-administered machines
472 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
473 'dgit-distro.debian.git-url-suffix' => '',
474 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
475 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
476 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
477 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
478 'dgit-distro.ubuntu.git-check' => 'false',
479 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
480 'dgit-distro.test-dummy.ssh' => "$td/ssh",
481 'dgit-distro.test-dummy.username' => "alice",
482 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
483 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
484 'dgit-distro.test-dummy.git-url' => "$td/git",
485 'dgit-distro.test-dummy.git-host' => "git",
486 'dgit-distro.test-dummy.git-path' => "$td/git",
487 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
488 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
489 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
490 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
493 sub git_get_config ($) {
496 our %git_get_config_memo;
497 if (exists $git_get_config_memo{$c}) {
498 return $git_get_config_memo{$c};
502 my @cmd = (@git, qw(config --), $c);
504 local ($debuglevel) = $debuglevel-2;
505 $v = cmdoutput_errok @cmd;
513 $git_get_config_memo{$c} = $v;
519 return undef if $c =~ /RETURN-UNDEF/;
520 my $v = git_get_config($c);
521 return $v if defined $v;
522 my $dv = $defcfg{$c};
523 return $dv if defined $dv;
525 badcfg "need value for one of: @_\n".
526 "$us: distro or suite appears not to be (properly) supported";
529 sub access_basedistro () {
530 if (defined $idistro) {
533 return cfg("dgit-suite.$isuite.distro",
534 "dgit.default.distro");
538 sub access_quirk () {
539 # returns (quirk name, distro to use instead or undef, quirk-specific info)
540 my $basedistro = access_basedistro();
541 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
543 if (defined $backports_quirk) {
544 my $re = $backports_quirk;
545 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
547 $re =~ s/\%/([-0-9a-z_]+)/
548 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
549 if ($isuite =~ m/^$re$/) {
550 return ('backports',"$basedistro-backports",$1);
553 return ('none',undef);
558 sub parse_cfg_bool ($$$) {
559 my ($what,$def,$v) = @_;
562 $v =~ m/^[ty1]/ ? 1 :
563 $v =~ m/^[fn0]/ ? 0 :
564 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
567 sub access_forpush_config () {
568 my $d = access_basedistro();
572 parse_cfg_bool('new-private-pushers', 0,
573 cfg("dgit-distro.$d.new-private-pushers",
576 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
579 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
580 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
581 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
582 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
585 sub access_forpush () {
586 $access_forpush //= access_forpush_config();
587 return $access_forpush;
591 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
592 badcfg "pushing but distro is configured readonly"
593 if access_forpush_config() eq '0';
597 sub access_distros () {
598 # Returns list of distros to try, in order
601 # 0. `instead of' distro name(s) we have been pointed to
602 # 1. the access_quirk distro, if any
603 # 2a. the user's specified distro, or failing that } basedistro
604 # 2b. the distro calculated from the suite }
605 my @l = access_basedistro();
607 my (undef,$quirkdistro) = access_quirk();
608 unshift @l, $quirkdistro;
609 unshift @l, $instead_distro;
610 @l = grep { defined } @l;
612 if (access_forpush()) {
613 @l = map { ("$_/push", $_) } @l;
621 # The nesting of these loops determines the search order. We put
622 # the key loop on the outside so that we search all the distros
623 # for each key, before going on to the next key. That means that
624 # if access_cfg is called with a more specific, and then a less
625 # specific, key, an earlier distro can override the less specific
626 # without necessarily overriding any more specific keys. (If the
627 # distro wants to override the more specific keys it can simply do
628 # so; whereas if we did the loop the other way around, it would be
629 # impossible to for an earlier distro to override a less specific
630 # key but not the more specific ones without restating the unknown
631 # values of the more specific keys.
634 # We have to deal with RETURN-UNDEF specially, so that we don't
635 # terminate the search prematurely.
637 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
640 foreach my $d (access_distros()) {
641 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
643 push @cfgs, map { "dgit.default.$_" } @realkeys;
645 my $value = cfg(@cfgs);
649 sub string_to_ssh ($) {
651 if ($spec =~ m/\s/) {
652 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
658 sub access_cfg_ssh () {
659 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
660 if (!defined $gitssh) {
663 return string_to_ssh $gitssh;
667 sub access_runeinfo ($) {
669 return ": dgit ".access_basedistro()." $info ;";
672 sub access_someuserhost ($) {
674 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
675 defined($user) && length($user) or
676 $user = access_cfg("$some-user",'username');
677 my $host = access_cfg("$some-host");
678 return length($user) ? "$user\@$host" : $host;
681 sub access_gituserhost () {
682 return access_someuserhost('git');
685 sub access_giturl (;$) {
687 my $url = access_cfg('git-url','RETURN-UNDEF');
690 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
691 return undef unless defined $proto;
694 access_gituserhost().
695 access_cfg('git-path');
697 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
700 return "$url/$package$suffix";
703 sub parsecontrolfh ($$;$) {
704 my ($fh, $desc, $allowsigned) = @_;
705 our $dpkgcontrolhash_noissigned;
708 my %opts = ('name' => $desc);
709 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
710 $c = Dpkg::Control::Hash->new(%opts);
711 $c->parse($fh,$desc) or die "parsing of $desc failed";
712 last if $allowsigned;
713 last if $dpkgcontrolhash_noissigned;
714 my $issigned= $c->get_option('is_pgp_signed');
715 if (!defined $issigned) {
716 $dpkgcontrolhash_noissigned= 1;
717 seek $fh, 0,0 or die "seek $desc: $!";
718 } elsif ($issigned) {
719 fail "control file $desc is (already) PGP-signed. ".
720 " Note that dgit push needs to modify the .dsc and then".
721 " do the signature itself";
730 my ($file, $desc) = @_;
731 my $fh = new IO::Handle;
732 open $fh, '<', $file or die "$file: $!";
733 my $c = parsecontrolfh($fh,$desc);
734 $fh->error and die $!;
740 my ($dctrl,$field) = @_;
741 my $v = $dctrl->{$field};
742 return $v if defined $v;
743 fail "missing field $field in ".$v->get_option('name');
747 my $c = Dpkg::Control::Hash->new();
748 my $p = new IO::Handle;
749 my @cmd = (qw(dpkg-parsechangelog), @_);
750 open $p, '-|', @cmd or die $!;
752 $?=0; $!=0; close $p or failedcmd @cmd;
758 defined $d or fail "getcwd failed: $!";
764 sub archive_query ($) {
766 my $query = access_cfg('archive-query','RETURN-UNDEF');
767 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
770 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
773 sub pool_dsc_subpath ($$) {
774 my ($vsn,$component) = @_; # $package is implict arg
775 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
776 return "/pool/$component/$prefix/$package/".dscfn($vsn);
779 #---------- `ftpmasterapi' archive query method (nascent) ----------
781 sub archive_api_query_cmd ($) {
783 my @cmd = qw(curl -sS);
784 my $url = access_cfg('archive-query-url');
785 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
787 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
788 foreach my $key (split /\:/, $keys) {
789 $key =~ s/\%HOST\%/$host/g;
791 fail "for $url: stat $key: $!" unless $!==ENOENT;
794 fail "config requested specific TLS key but do not know".
795 " how to get curl to use exactly that EE key ($key)";
796 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
797 # # Sadly the above line does not work because of changes
798 # # to gnutls. The real fix for #790093 may involve
799 # # new curl options.
802 # Fixing #790093 properly will involve providing a value
803 # for this on clients.
804 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
805 push @cmd, split / /, $kargs if defined $kargs;
807 push @cmd, $url.$subpath;
813 my ($data, $subpath) = @_;
814 badcfg "ftpmasterapi archive query method takes no data part"
816 my @cmd = archive_api_query_cmd($subpath);
817 my $json = cmdoutput @cmd;
818 return decode_json($json);
821 sub canonicalise_suite_ftpmasterapi () {
822 my ($proto,$data) = @_;
823 my $suites = api_query($data, 'suites');
825 foreach my $entry (@$suites) {
827 my $v = $entry->{$_};
828 defined $v && $v eq $isuite;
830 push @matched, $entry;
832 fail "unknown suite $isuite" unless @matched;
835 @matched==1 or die "multiple matches for suite $isuite\n";
836 $cn = "$matched[0]{codename}";
837 defined $cn or die "suite $isuite info has no codename\n";
838 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
840 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
845 sub archive_query_ftpmasterapi () {
846 my ($proto,$data) = @_;
847 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
849 my $digester = Digest::SHA->new(256);
850 foreach my $entry (@$info) {
852 my $vsn = "$entry->{version}";
853 my ($ok,$msg) = version_check $vsn;
854 die "bad version: $msg\n" unless $ok;
855 my $component = "$entry->{component}";
856 $component =~ m/^$component_re$/ or die "bad component";
857 my $filename = "$entry->{filename}";
858 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
859 or die "bad filename";
860 my $sha256sum = "$entry->{sha256sum}";
861 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
862 push @rows, [ $vsn, "/pool/$component/$filename",
863 $digester, $sha256sum ];
865 die "bad ftpmaster api response: $@\n".Dumper($entry)
868 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
872 #---------- `madison' archive query method ----------
874 sub archive_query_madison {
875 return map { [ @$_[0..1] ] } madison_get_parse(@_);
878 sub madison_get_parse {
879 my ($proto,$data) = @_;
880 die unless $proto eq 'madison';
882 $data= access_cfg('madison-distro','RETURN-UNDEF');
883 $data //= access_basedistro();
885 $rmad{$proto,$data,$package} ||= cmdoutput
886 qw(rmadison -asource),"-s$isuite","-u$data",$package;
887 my $rmad = $rmad{$proto,$data,$package};
890 foreach my $l (split /\n/, $rmad) {
891 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
892 \s*( [^ \t|]+ )\s* \|
893 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
894 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
895 $1 eq $package or die "$rmad $package ?";
902 $component = access_cfg('archive-query-default-component');
904 $5 eq 'source' or die "$rmad ?";
905 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
907 return sort { -version_compare($a->[0],$b->[0]); } @out;
910 sub canonicalise_suite_madison {
911 # madison canonicalises for us
912 my @r = madison_get_parse(@_);
914 "unable to canonicalise suite using package $package".
915 " which does not appear to exist in suite $isuite;".
916 " --existing-package may help";
920 #---------- `sshpsql' archive query method ----------
923 my ($data,$runeinfo,$sql) = @_;
925 $data= access_someuserhost('sshpsql').':'.
926 access_cfg('sshpsql-dbname');
928 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
929 my ($userhost,$dbname) = ($`,$'); #';
931 my @cmd = (access_cfg_ssh, $userhost,
932 access_runeinfo("ssh-psql $runeinfo").
933 " export LC_MESSAGES=C; export LC_CTYPE=C;".
934 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
936 open P, "-|", @cmd or die $!;
939 printdebug("$debugprefix>|$_|\n");
942 $!=0; $?=0; close P or failedcmd @cmd;
944 my $nrows = pop @rows;
945 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
946 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
947 @rows = map { [ split /\|/, $_ ] } @rows;
948 my $ncols = scalar @{ shift @rows };
949 die if grep { scalar @$_ != $ncols } @rows;
953 sub sql_injection_check {
954 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
957 sub archive_query_sshpsql ($$) {
958 my ($proto,$data) = @_;
959 sql_injection_check $isuite, $package;
960 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
961 SELECT source.version, component.name, files.filename, files.sha256sum
963 JOIN src_associations ON source.id = src_associations.source
964 JOIN suite ON suite.id = src_associations.suite
965 JOIN dsc_files ON dsc_files.source = source.id
966 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
967 JOIN component ON component.id = files_archive_map.component_id
968 JOIN files ON files.id = dsc_files.file
969 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
970 AND source.source='$package'
971 AND files.filename LIKE '%.dsc';
973 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
974 my $digester = Digest::SHA->new(256);
976 my ($vsn,$component,$filename,$sha256sum) = @$_;
977 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
982 sub canonicalise_suite_sshpsql ($$) {
983 my ($proto,$data) = @_;
984 sql_injection_check $isuite;
985 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
986 SELECT suite.codename
987 FROM suite where suite_name='$isuite' or codename='$isuite';
989 @rows = map { $_->[0] } @rows;
990 fail "unknown suite $isuite" unless @rows;
991 die "ambiguous $isuite: @rows ?" if @rows>1;
995 #---------- `dummycat' archive query method ----------
997 sub canonicalise_suite_dummycat ($$) {
998 my ($proto,$data) = @_;
999 my $dpath = "$data/suite.$isuite";
1000 if (!open C, "<", $dpath) {
1001 $!==ENOENT or die "$dpath: $!";
1002 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1006 chomp or die "$dpath: $!";
1008 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1012 sub archive_query_dummycat ($$) {
1013 my ($proto,$data) = @_;
1014 canonicalise_suite();
1015 my $dpath = "$data/package.$csuite.$package";
1016 if (!open C, "<", $dpath) {
1017 $!==ENOENT or die "$dpath: $!";
1018 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1026 printdebug "dummycat query $csuite $package $dpath | $_\n";
1027 my @row = split /\s+/, $_;
1028 @row==2 or die "$dpath: $_ ?";
1031 C->error and die "$dpath: $!";
1033 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1036 #---------- archive query entrypoints and rest of program ----------
1038 sub canonicalise_suite () {
1039 return if defined $csuite;
1040 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1041 $csuite = archive_query('canonicalise_suite');
1042 if ($isuite ne $csuite) {
1043 progress "canonical suite name for $isuite is $csuite";
1047 sub get_archive_dsc () {
1048 canonicalise_suite();
1049 my @vsns = archive_query('archive_query');
1050 foreach my $vinfo (@vsns) {
1051 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1052 $dscurl = access_cfg('mirror').$subpath;
1053 $dscdata = url_get($dscurl);
1055 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1060 $digester->add($dscdata);
1061 my $got = $digester->hexdigest();
1063 fail "$dscurl has hash $got but".
1064 " archive told us to expect $digest";
1066 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1067 printdebug Dumper($dscdata) if $debuglevel>1;
1068 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1069 printdebug Dumper($dsc) if $debuglevel>1;
1070 my $fmt = getfield $dsc, 'Format';
1071 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1072 $dsc_checked = !!$digester;
1078 sub check_for_git ();
1079 sub check_for_git () {
1081 my $how = access_cfg('git-check');
1082 if ($how eq 'ssh-cmd') {
1084 (access_cfg_ssh, access_gituserhost(),
1085 access_runeinfo("git-check $package").
1086 " set -e; cd ".access_cfg('git-path').";".
1087 " if test -d $package.git; then echo 1; else echo 0; fi");
1088 my $r= cmdoutput @cmd;
1089 if ($r =~ m/^divert (\w+)$/) {
1091 my ($usedistro,) = access_distros();
1092 # NB that if we are pushing, $usedistro will be $distro/push
1093 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1094 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1095 progress "diverting to $divert (using config for $instead_distro)";
1096 return check_for_git();
1098 failedcmd @cmd unless $r =~ m/^[01]$/;
1100 } elsif ($how eq 'url') {
1101 my $prefix = access_cfg('git-check-url','git-url');
1102 my $suffix = access_cfg('git-check-suffix','git-suffix',
1103 'RETURN-UNDEF') // '.git';
1104 my $url = "$prefix/$package$suffix";
1105 my @cmd = (qw(curl -sS -I), $url);
1106 my $result = cmdoutput @cmd;
1107 $result =~ m/^\S+ (404|200) /s or
1108 fail "unexpected results from git check query - ".
1109 Dumper($prefix, $result);
1111 if ($code eq '404') {
1113 } elsif ($code eq '200') {
1118 } elsif ($how eq 'true') {
1120 } elsif ($how eq 'false') {
1123 badcfg "unknown git-check \`$how'";
1127 sub create_remote_git_repo () {
1128 my $how = access_cfg('git-create');
1129 if ($how eq 'ssh-cmd') {
1131 (access_cfg_ssh, access_gituserhost(),
1132 access_runeinfo("git-create $package").
1133 "set -e; cd ".access_cfg('git-path').";".
1134 " cp -a _template $package.git");
1135 } elsif ($how eq 'true') {
1138 badcfg "unknown git-create \`$how'";
1142 our ($dsc_hash,$lastpush_hash);
1144 our $ud = '.git/dgit/unpack';
1149 mkdir $ud or die $!;
1152 sub mktree_in_ud_here () {
1153 runcmd qw(git init -q);
1154 rmtree('.git/objects');
1155 symlink '../../../../objects','.git/objects' or die $!;
1158 sub git_write_tree () {
1159 my $tree = cmdoutput @git, qw(write-tree);
1160 $tree =~ m/^\w+$/ or die "$tree ?";
1164 sub mktree_in_ud_from_only_subdir () {
1165 # changes into the subdir
1167 die unless @dirs==1;
1168 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1172 my @gitscmd = qw(find -name .git -prune -print0);
1173 debugcmd "|",@gitscmd;
1174 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1179 print STDERR "$us: warning: removing from source package: ",
1180 (messagequote $_), "\n";
1184 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1186 mktree_in_ud_here();
1187 my $format=get_source_format();
1188 if (madformat($format)) {
1191 runcmd @git, qw(add -Af);
1192 my $tree=git_write_tree();
1193 return ($tree,$dir);
1196 sub dsc_files_info () {
1197 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1198 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1199 ['Files', 'Digest::MD5', 'new()']) {
1200 my ($fname, $module, $method) = @$csumi;
1201 my $field = $dsc->{$fname};
1202 next unless defined $field;
1203 eval "use $module; 1;" or die $@;
1205 foreach (split /\n/, $field) {
1207 m/^(\w+) (\d+) (\S+)$/ or
1208 fail "could not parse .dsc $fname line \`$_'";
1209 my $digester = eval "$module"."->$method;" or die $@;
1214 Digester => $digester,
1219 fail "missing any supported Checksums-* or Files field in ".
1220 $dsc->get_option('name');
1224 map { $_->{Filename} } dsc_files_info();
1227 sub is_orig_file ($;$) {
1230 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1231 defined $base or return 1;
1235 sub make_commit ($) {
1237 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1240 sub clogp_authline ($) {
1242 my $author = getfield $clogp, 'Maintainer';
1243 $author =~ s#,.*##ms;
1244 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1245 my $authline = "$author $date";
1246 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1247 fail "unexpected commit author line format \`$authline'".
1248 " (was generated from changelog Maintainer field)";
1252 sub vendor_patches_distro ($$) {
1253 my ($checkdistro, $what) = @_;
1254 return unless defined $checkdistro;
1256 my $series = "debian/patches/\L$checkdistro\E.series";
1257 printdebug "checking for vendor-specific $series ($what)\n";
1259 if (!open SERIES, "<", $series) {
1260 die "$series $!" unless $!==ENOENT;
1269 Unfortunately, this source package uses a feature of dpkg-source where
1270 the same source package unpacks to different source code on different
1271 distros. dgit cannot safely operate on such packages on affected
1272 distros, because the meaning of source packages is not stable.
1274 Please ask the distro/maintainer to remove the distro-specific series
1275 files and use a different technique (if necessary, uploading actually
1276 different packages, if different distros are supposed to have
1280 fail "Found active distro-specific series file for".
1281 " $checkdistro ($what): $series, cannot continue";
1283 die "$series $!" if SERIES->error;
1287 sub check_for_vendor_patches () {
1288 # This dpkg-source feature doesn't seem to be documented anywhere!
1289 # But it can be found in the changelog (reformatted):
1291 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1292 # Author: Raphael Hertzog <hertzog@debian.org>
1293 # Date: Sun Oct 3 09:36:48 2010 +0200
1295 # dpkg-source: correctly create .pc/.quilt_series with alternate
1298 # If you have debian/patches/ubuntu.series and you were
1299 # unpacking the source package on ubuntu, quilt was still
1300 # directed to debian/patches/series instead of
1301 # debian/patches/ubuntu.series.
1303 # debian/changelog | 3 +++
1304 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1305 # 2 files changed, 6 insertions(+), 1 deletion(-)
1308 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1309 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1310 "Dpkg::Vendor \`current vendor'");
1311 vendor_patches_distro(access_basedistro(),
1312 "distro being accessed");
1315 sub generate_commit_from_dsc () {
1319 foreach my $fi (dsc_files_info()) {
1320 my $f = $fi->{Filename};
1321 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1323 link "../../../$f", $f
1327 complete_file_from_dsc('.', $fi);
1329 if (is_orig_file($f)) {
1330 link $f, "../../../../$f"
1336 my $dscfn = "$package.dsc";
1338 open D, ">", $dscfn or die "$dscfn: $!";
1339 print D $dscdata or die "$dscfn: $!";
1340 close D or die "$dscfn: $!";
1341 my @cmd = qw(dpkg-source);
1342 push @cmd, '--no-check' if $dsc_checked;
1343 push @cmd, qw(-x --), $dscfn;
1346 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1347 check_for_vendor_patches() if madformat($dsc->{format});
1348 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1349 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1350 my $authline = clogp_authline $clogp;
1351 my $changes = getfield $clogp, 'Changes';
1352 open C, ">../commit.tmp" or die $!;
1353 print C <<END or die $!;
1360 # imported from the archive
1363 my $outputhash = make_commit qw(../commit.tmp);
1364 my $cversion = getfield $clogp, 'Version';
1365 progress "synthesised git commit from .dsc $cversion";
1366 if ($lastpush_hash) {
1367 runcmd @git, qw(reset --hard), $lastpush_hash;
1368 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1369 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1370 my $oversion = getfield $oldclogp, 'Version';
1372 version_compare($oversion, $cversion);
1374 # git upload/ is earlier vsn than archive, use archive
1375 open C, ">../commit2.tmp" or die $!;
1376 print C <<END or die $!;
1378 parent $lastpush_hash
1383 Record $package ($cversion) in archive suite $csuite
1385 $outputhash = make_commit qw(../commit2.tmp);
1386 } elsif ($vcmp > 0) {
1387 print STDERR <<END or die $!;
1389 Version actually in archive: $cversion (older)
1390 Last allegedly pushed/uploaded: $oversion (newer or same)
1393 $outputhash = $lastpush_hash;
1395 $outputhash = $lastpush_hash;
1398 changedir '../../../..';
1399 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1400 'DGIT_ARCHIVE', $outputhash;
1401 cmdoutput @git, qw(log -n2), $outputhash;
1402 # ... gives git a chance to complain if our commit is malformed
1407 sub complete_file_from_dsc ($$) {
1408 our ($dstdir, $fi) = @_;
1409 # Ensures that we have, in $dir, the file $fi, with the correct
1410 # contents. (Downloading it from alongside $dscurl if necessary.)
1412 my $f = $fi->{Filename};
1413 my $tf = "$dstdir/$f";
1416 if (stat_exists $tf) {
1417 progress "using existing $f";
1420 $furl =~ s{/[^/]+$}{};
1422 die "$f ?" unless $f =~ m/^${package}_/;
1423 die "$f ?" if $f =~ m#/#;
1424 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1425 next if !act_local();
1429 open F, "<", "$tf" or die "$tf: $!";
1430 $fi->{Digester}->reset();
1431 $fi->{Digester}->addfile(*F);
1432 F->error and die $!;
1433 my $got = $fi->{Digester}->hexdigest();
1434 $got eq $fi->{Hash} or
1435 fail "file $f has hash $got but .dsc".
1436 " demands hash $fi->{Hash} ".
1437 ($downloaded ? "(got wrong file from archive!)"
1438 : "(perhaps you should delete this file?)");
1441 sub ensure_we_have_orig () {
1442 foreach my $fi (dsc_files_info()) {
1443 my $f = $fi->{Filename};
1444 next unless is_orig_file($f);
1445 complete_file_from_dsc('..', $fi);
1449 sub git_fetch_us () {
1450 my @specs = (fetchspec());
1452 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1454 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1457 my $tagpat = debiantag('*',access_basedistro);
1459 git_for_each_ref("refs/tags/".$tagpat, sub {
1460 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1461 printdebug "currently $fullrefname=$objid\n";
1462 $here{$fullrefname} = $objid;
1464 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1465 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1466 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1467 printdebug "offered $lref=$objid\n";
1468 if (!defined $here{$lref}) {
1469 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1470 runcmd_ordryrun_local @upd;
1471 } elsif ($here{$lref} eq $objid) {
1474 "Not updateting $lref from $here{$lref} to $objid.\n";
1479 sub fetch_from_archive () {
1480 # ensures that lrref() is what is actually in the archive,
1481 # one way or another
1485 foreach my $field (@ourdscfield) {
1486 $dsc_hash = $dsc->{$field};
1487 last if defined $dsc_hash;
1489 if (defined $dsc_hash) {
1490 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1492 progress "last upload to archive specified git hash";
1494 progress "last upload to archive has NO git hash";
1497 progress "no version available from the archive";
1500 $lastpush_hash = git_get_ref(lrref());
1501 printdebug "previous reference hash=$lastpush_hash\n";
1503 if (defined $dsc_hash) {
1504 fail "missing remote git history even though dsc has hash -".
1505 " could not find ref ".lrref().
1506 " (should have been fetched from ".access_giturl()."#".rrref().")"
1507 unless $lastpush_hash;
1509 ensure_we_have_orig();
1510 if ($dsc_hash eq $lastpush_hash) {
1511 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1512 print STDERR <<END or die $!;
1514 Git commit in archive is behind the last version allegedly pushed/uploaded.
1515 Commit referred to by archive: $dsc_hash
1516 Last allegedly pushed/uploaded: $lastpush_hash
1519 $hash = $lastpush_hash;
1521 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1522 "descendant of archive's .dsc hash ($dsc_hash)";
1525 $hash = generate_commit_from_dsc();
1526 } elsif ($lastpush_hash) {
1527 # only in git, not in the archive yet
1528 $hash = $lastpush_hash;
1529 print STDERR <<END or die $!;
1531 Package not found in the archive, but has allegedly been pushed using dgit.
1535 printdebug "nothing found!\n";
1536 if (defined $skew_warning_vsn) {
1537 print STDERR <<END or die $!;
1539 Warning: relevant archive skew detected.
1540 Archive allegedly contains $skew_warning_vsn
1541 But we were not able to obtain any version from the archive or git.
1547 printdebug "current hash=$hash\n";
1548 if ($lastpush_hash) {
1549 fail "not fast forward on last upload branch!".
1550 " (archive's version left in DGIT_ARCHIVE)"
1551 unless is_fast_fwd($lastpush_hash, $hash);
1553 if (defined $skew_warning_vsn) {
1555 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1556 my $clogf = ".git/dgit/changelog.tmp";
1557 runcmd shell_cmd "exec >$clogf",
1558 @git, qw(cat-file blob), "$hash:debian/changelog";
1559 my $gotclogp = parsechangelog("-l$clogf");
1560 my $got_vsn = getfield $gotclogp, 'Version';
1561 printdebug "SKEW CHECK GOT $got_vsn\n";
1562 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1563 print STDERR <<END or die $!;
1565 Warning: archive skew detected. Using the available version:
1566 Archive allegedly contains $skew_warning_vsn
1567 We were able to obtain only $got_vsn
1572 if ($lastpush_hash ne $hash) {
1573 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1577 dryrun_report @upd_cmd;
1583 sub set_local_git_config ($$) {
1585 runcmd @git, qw(config), $k, $v;
1588 sub setup_mergechangelogs () {
1589 my $driver = 'dpkg-mergechangelogs';
1590 my $cb = "merge.$driver";
1591 my $attrs = '.git/info/attributes';
1592 ensuredir '.git/info';
1594 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1595 if (!open ATTRS, "<", $attrs) {
1596 $!==ENOENT or die "$attrs: $!";
1600 next if m{^debian/changelog\s};
1601 print NATTRS $_, "\n" or die $!;
1603 ATTRS->error and die $!;
1606 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1609 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1610 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1612 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1617 canonicalise_suite();
1618 badusage "dry run makes no sense with clone" unless act_local();
1619 my $hasgit = check_for_git();
1620 mkdir $dstdir or die "$dstdir $!";
1622 runcmd @git, qw(init -q);
1623 my $giturl = access_giturl(1);
1624 if (defined $giturl) {
1625 set_local_git_config "remote.$remotename.fetch", fetchspec();
1626 open H, "> .git/HEAD" or die $!;
1627 print H "ref: ".lref()."\n" or die $!;
1629 runcmd @git, qw(remote add), 'origin', $giturl;
1632 progress "fetching existing git history";
1634 runcmd_ordryrun_local @git, qw(fetch origin);
1636 progress "starting new git history";
1638 fetch_from_archive() or no_such_package;
1639 my $vcsgiturl = $dsc->{'Vcs-Git'};
1640 if (length $vcsgiturl) {
1641 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1642 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1644 setup_mergechangelogs();
1645 runcmd @git, qw(reset --hard), lrref();
1646 printdone "ready for work in $dstdir";
1650 if (check_for_git()) {
1653 fetch_from_archive() or no_such_package();
1654 printdone "fetched into ".lrref();
1659 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1661 printdone "fetched to ".lrref()." and merged into HEAD";
1664 sub check_not_dirty () {
1665 return if $ignoredirty;
1666 my @cmd = (@git, qw(diff --quiet HEAD));
1668 $!=0; $?=0; system @cmd;
1669 return if !$! && !$?;
1670 if (!$! && $?==256) {
1671 fail "working tree is dirty (does not match HEAD)";
1677 sub commit_admin ($) {
1680 runcmd_ordryrun_local @git, qw(commit -m), $m;
1683 sub commit_quilty_patch () {
1684 my $output = cmdoutput @git, qw(status --porcelain);
1686 foreach my $l (split /\n/, $output) {
1687 next unless $l =~ m/\S/;
1688 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1692 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1694 progress "nothing quilty to commit, ok.";
1697 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1698 commit_admin "Commit Debian 3.0 (quilt) metadata";
1701 sub get_source_format () {
1702 if (!open F, "debian/source/format") {
1703 die $! unless $!==&ENOENT;
1707 F->error and die $!;
1714 return 0 unless $format eq '3.0 (quilt)';
1715 if ($quilt_mode eq 'nocheck') {
1716 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1719 progress "Format \`$format', checking/updating patch stack";
1723 sub push_parse_changelog ($) {
1726 my $clogp = Dpkg::Control::Hash->new();
1727 $clogp->load($clogpfn) or die;
1729 $package = getfield $clogp, 'Source';
1730 my $cversion = getfield $clogp, 'Version';
1731 my $tag = debiantag($cversion, access_basedistro);
1732 runcmd @git, qw(check-ref-format), $tag;
1734 my $dscfn = dscfn($cversion);
1736 return ($clogp, $cversion, $tag, $dscfn);
1739 sub push_parse_dsc ($$$) {
1740 my ($dscfn,$dscfnwhat, $cversion) = @_;
1741 $dsc = parsecontrol($dscfn,$dscfnwhat);
1742 my $dversion = getfield $dsc, 'Version';
1743 my $dscpackage = getfield $dsc, 'Source';
1744 ($dscpackage eq $package && $dversion eq $cversion) or
1745 fail "$dscfn is for $dscpackage $dversion".
1746 " but debian/changelog is for $package $cversion";
1749 sub push_mktag ($$$$$$$) {
1750 my ($head,$clogp,$tag,
1752 $changesfile,$changesfilewhat,
1755 $dsc->{$ourdscfield[0]} = $head;
1756 $dsc->save("$dscfn.tmp") or die $!;
1758 my $changes = parsecontrol($changesfile,$changesfilewhat);
1759 foreach my $field (qw(Source Distribution Version)) {
1760 $changes->{$field} eq $clogp->{$field} or
1761 fail "changes field $field \`$changes->{$field}'".
1762 " does not match changelog \`$clogp->{$field}'";
1765 my $cversion = getfield $clogp, 'Version';
1766 my $clogsuite = getfield $clogp, 'Distribution';
1768 # We make the git tag by hand because (a) that makes it easier
1769 # to control the "tagger" (b) we can do remote signing
1770 my $authline = clogp_authline $clogp;
1771 my $delibs = join(" ", "",@deliberatelies);
1772 my $declaredistro = access_basedistro();
1773 open TO, '>', $tfn->('.tmp') or die $!;
1774 print TO <<END or die $!;
1780 $package release $cversion for $clogsuite ($csuite) [dgit]
1781 [dgit distro=$declaredistro$delibs]
1783 foreach my $ref (sort keys %previously) {
1784 print TO <<END or die $!;
1785 [dgit previously:$ref=$previously{$ref}]
1791 my $tagobjfn = $tfn->('.tmp');
1793 if (!defined $keyid) {
1794 $keyid = access_cfg('keyid','RETURN-UNDEF');
1796 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1797 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1798 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1799 push @sign_cmd, $tfn->('.tmp');
1800 runcmd_ordryrun @sign_cmd;
1802 $tagobjfn = $tfn->('.signed.tmp');
1803 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1804 $tfn->('.tmp'), $tfn->('.tmp.asc');
1811 sub sign_changes ($) {
1812 my ($changesfile) = @_;
1814 my @debsign_cmd = @debsign;
1815 push @debsign_cmd, "-k$keyid" if defined $keyid;
1816 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1817 push @debsign_cmd, $changesfile;
1818 runcmd_ordryrun @debsign_cmd;
1823 my ($forceflag) = @_;
1824 printdebug "actually entering push\n";
1827 access_giturl(); # check that success is vaguely likely
1829 my $clogpfn = ".git/dgit/changelog.822.tmp";
1830 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1832 responder_send_file('parsed-changelog', $clogpfn);
1834 my ($clogp, $cversion, $tag, $dscfn) =
1835 push_parse_changelog("$clogpfn");
1837 my $dscpath = "$buildproductsdir/$dscfn";
1838 stat_exists $dscpath or
1839 fail "looked for .dsc $dscfn, but $!;".
1840 " maybe you forgot to build";
1842 responder_send_file('dsc', $dscpath);
1844 push_parse_dsc($dscpath, $dscfn, $cversion);
1846 my $format = getfield $dsc, 'Format';
1847 printdebug "format $format\n";
1848 if (madformat($format)) {
1849 commit_quilty_patch();
1853 progress "checking that $dscfn corresponds to HEAD";
1854 runcmd qw(dpkg-source -x --),
1855 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1856 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1857 check_for_vendor_patches() if madformat($dsc->{format});
1858 changedir '../../../..';
1859 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1860 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1861 debugcmd "+",@diffcmd;
1863 my $r = system @diffcmd;
1866 fail "$dscfn specifies a different tree to your HEAD commit;".
1867 " perhaps you forgot to build".
1868 ($diffopt eq '--exit-code' ? "" :
1869 " (run with -D to see full diff output)");
1874 my $head = git_rev_parse('HEAD');
1875 if (!$changesfile) {
1876 my $multi = "$buildproductsdir/".
1877 "${package}_".(stripepoch $cversion)."_multi.changes";
1878 if (stat_exists "$multi") {
1879 $changesfile = $multi;
1881 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1882 my @cs = glob "$buildproductsdir/$pat";
1883 fail "failed to find unique changes file".
1884 " (looked for $pat in $buildproductsdir, or $multi);".
1885 " perhaps you need to use dgit -C"
1887 ($changesfile) = @cs;
1890 $changesfile = "$buildproductsdir/$changesfile";
1893 responder_send_file('changes',$changesfile);
1894 responder_send_command("param head $head");
1895 responder_send_command("param csuite $csuite");
1897 if (deliberately_not_fast_forward) {
1898 git_for_each_ref(lrfetchrefs, sub {
1899 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1900 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1901 responder_send_command("previously $rrefname=$objid");
1902 $previously{$rrefname} = $objid;
1906 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1909 if ($we_are_responder) {
1910 $tagobjfn = $tfn->('.signed.tmp');
1911 responder_receive_files('signed-tag', $tagobjfn);
1914 push_mktag($head,$clogp,$tag,
1916 $changesfile,$changesfile,
1920 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1921 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1922 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1924 if (!check_for_git()) {
1925 create_remote_git_repo();
1927 runcmd_ordryrun @git, qw(push),access_giturl(),
1928 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1929 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1931 if ($we_are_responder) {
1932 my $dryrunsuffix = act_local() ? "" : ".tmp";
1933 responder_receive_files('signed-dsc-changes',
1934 "$dscpath$dryrunsuffix",
1935 "$changesfile$dryrunsuffix");
1938 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1940 progress "[new .dsc left in $dscpath.tmp]";
1942 sign_changes $changesfile;
1945 my $host = access_cfg('upload-host','RETURN-UNDEF');
1946 my @hostarg = defined($host) ? ($host,) : ();
1947 runcmd_ordryrun @dput, @hostarg, $changesfile;
1948 printdone "pushed and uploaded $cversion";
1950 responder_send_command("complete");
1956 badusage "-p is not allowed with clone; specify as argument instead"
1957 if defined $package;
1960 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1961 ($package,$isuite) = @ARGV;
1962 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1963 ($package,$dstdir) = @ARGV;
1964 } elsif (@ARGV==3) {
1965 ($package,$isuite,$dstdir) = @ARGV;
1967 badusage "incorrect arguments to dgit clone";
1969 $dstdir ||= "$package";
1971 if (stat_exists $dstdir) {
1972 fail "$dstdir already exists";
1976 if ($rmonerror && !$dryrun_level) {
1977 $cwd_remove= getcwd();
1979 return unless defined $cwd_remove;
1980 if (!chdir "$cwd_remove") {
1981 return if $!==&ENOENT;
1982 die "chdir $cwd_remove: $!";
1984 rmtree($dstdir) or die "remove $dstdir: $!\n";
1989 $cwd_remove = undef;
1992 sub branchsuite () {
1993 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1994 if ($branch =~ m#$lbranch_re#o) {
2001 sub fetchpullargs () {
2002 if (!defined $package) {
2003 my $sourcep = parsecontrol('debian/control','debian/control');
2004 $package = getfield $sourcep, 'Source';
2007 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2009 my $clogp = parsechangelog();
2010 $isuite = getfield $clogp, 'Distribution';
2012 canonicalise_suite();
2013 progress "fetching from suite $csuite";
2014 } elsif (@ARGV==1) {
2016 canonicalise_suite();
2018 badusage "incorrect arguments to dgit fetch or dgit pull";
2037 badusage "-p is not allowed with dgit push" if defined $package;
2039 my $clogp = parsechangelog();
2040 $package = getfield $clogp, 'Source';
2043 } elsif (@ARGV==1) {
2044 ($specsuite) = (@ARGV);
2046 badusage "incorrect arguments to dgit push";
2048 $isuite = getfield $clogp, 'Distribution';
2050 local ($package) = $existing_package; # this is a hack
2051 canonicalise_suite();
2053 canonicalise_suite();
2055 if (defined $specsuite &&
2056 $specsuite ne $isuite &&
2057 $specsuite ne $csuite) {
2058 fail "dgit push: changelog specifies $isuite ($csuite)".
2059 " but command line specifies $specsuite";
2061 if (check_for_git()) {
2065 if (fetch_from_archive()) {
2066 if (is_fast_fwd(lrref(), 'HEAD')) {
2068 } elsif (deliberately_not_fast_forward) {
2071 fail "dgit push: HEAD is not a descendant".
2072 " of the archive's version.\n".
2073 "dgit: To overwrite its contents,".
2074 " use git merge -s ours ".lrref().".\n".
2075 "dgit: To rewind history, if permitted by the archive,".
2076 " use --deliberately-not-fast-forward";
2080 fail "package appears to be new in this suite;".
2081 " if this is intentional, use --new";
2086 #---------- remote commands' implementation ----------
2088 sub cmd_remote_push_build_host {
2090 my ($nrargs) = shift @ARGV;
2091 my (@rargs) = @ARGV[0..$nrargs-1];
2092 @ARGV = @ARGV[$nrargs..$#ARGV];
2094 my ($dir,$vsnwant) = @rargs;
2095 # vsnwant is a comma-separated list; we report which we have
2096 # chosen in our ready response (so other end can tell if they
2099 $we_are_responder = 1;
2100 $us .= " (build host)";
2102 open PI, "<&STDIN" or die $!;
2103 open STDIN, "/dev/null" or die $!;
2104 open PO, ">&STDOUT" or die $!;
2106 open STDOUT, ">&STDERR" or die $!;
2110 ($protovsn) = grep {
2111 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2112 } @rpushprotovsn_support;
2114 fail "build host has dgit rpush protocol versions ".
2115 (join ",", @rpushprotovsn_support).
2116 " but invocation host has $vsnwant"
2117 unless defined $protovsn;
2119 responder_send_command("dgit-remote-push-ready $protovsn");
2125 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2126 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2127 # a good error message)
2133 my $report = i_child_report();
2134 if (defined $report) {
2135 printdebug "($report)\n";
2136 } elsif ($i_child_pid) {
2137 printdebug "(killing build host child $i_child_pid)\n";
2138 kill 15, $i_child_pid;
2140 if (defined $i_tmp && !defined $initiator_tempdir) {
2142 eval { rmtree $i_tmp; };
2146 END { i_cleanup(); }
2149 my ($base,$selector,@args) = @_;
2150 $selector =~ s/\-/_/g;
2151 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2158 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2166 push @rargs, join ",", @rpushprotovsn_support;
2169 push @rdgit, @ropts;
2170 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2172 my @cmd = (@ssh, $host, shellquote @rdgit);
2175 if (defined $initiator_tempdir) {
2176 rmtree $initiator_tempdir;
2177 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2178 $i_tmp = $initiator_tempdir;
2182 $i_child_pid = open2(\*RO, \*RI, @cmd);
2184 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2185 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2187 my ($icmd,$iargs) = initiator_expect {
2188 m/^(\S+)(?: (.*))?$/;
2191 i_method "i_resp", $icmd, $iargs;
2195 sub i_resp_progress ($) {
2197 my $msg = protocol_read_bytes \*RO, $rhs;
2201 sub i_resp_complete {
2202 my $pid = $i_child_pid;
2203 $i_child_pid = undef; # prevents killing some other process with same pid
2204 printdebug "waiting for build host child $pid...\n";
2205 my $got = waitpid $pid, 0;
2206 die $! unless $got == $pid;
2207 die "build host child failed $?" if $?;
2210 printdebug "all done\n";
2214 sub i_resp_file ($) {
2216 my $localname = i_method "i_localname", $keyword;
2217 my $localpath = "$i_tmp/$localname";
2218 stat_exists $localpath and
2219 badproto \*RO, "file $keyword ($localpath) twice";
2220 protocol_receive_file \*RO, $localpath;
2221 i_method "i_file", $keyword;
2226 sub i_resp_param ($) {
2227 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2231 sub i_resp_previously ($) {
2232 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2233 or badproto \*RO, "bad previously spec";
2234 my $r = system qw(git check-ref-format), $1;
2235 die "bad previously ref spec ($r)" if $r;
2236 $previously{$1} = $2;
2241 sub i_resp_want ($) {
2243 die "$keyword ?" if $i_wanted{$keyword}++;
2244 my @localpaths = i_method "i_want", $keyword;
2245 printdebug "[[ $keyword @localpaths\n";
2246 foreach my $localpath (@localpaths) {
2247 protocol_send_file \*RI, $localpath;
2249 print RI "files-end\n" or die $!;
2252 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2254 sub i_localname_parsed_changelog {
2255 return "remote-changelog.822";
2257 sub i_file_parsed_changelog {
2258 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2259 push_parse_changelog "$i_tmp/remote-changelog.822";
2260 die if $i_dscfn =~ m#/|^\W#;
2263 sub i_localname_dsc {
2264 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2269 sub i_localname_changes {
2270 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2271 $i_changesfn = $i_dscfn;
2272 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2273 return $i_changesfn;
2275 sub i_file_changes { }
2277 sub i_want_signed_tag {
2278 printdebug Dumper(\%i_param, $i_dscfn);
2279 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2280 && defined $i_param{'csuite'}
2281 or badproto \*RO, "premature desire for signed-tag";
2282 my $head = $i_param{'head'};
2283 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2285 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2287 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2290 push_mktag $head, $i_clogp, $i_tag,
2292 $i_changesfn, 'remote changes',
2293 sub { "tag$_[0]"; };
2298 sub i_want_signed_dsc_changes {
2299 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2300 sign_changes $i_changesfn;
2301 return ($i_dscfn, $i_changesfn);
2304 #---------- building etc. ----------
2310 #----- `3.0 (quilt)' handling -----
2312 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2314 sub quiltify_dpkg_commit ($$$;$) {
2315 my ($patchname,$author,$msg, $xinfo) = @_;
2319 my $descfn = ".git/dgit/quilt-description.tmp";
2320 open O, '>', $descfn or die "$descfn: $!";
2323 $msg =~ s/^\s+$/ ./mg;
2324 print O <<END or die $!;
2334 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2335 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2336 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2337 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2341 sub quiltify_trees_differ ($$) {
2343 # returns 1 iff the two tree objects differ other than in debian/
2345 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2346 my $diffs= cmdoutput @cmd;
2347 foreach my $f (split /\0/, $diffs) {
2348 next if $f eq 'debian';
2354 sub quiltify_tree_sentinelfiles ($) {
2355 # lists the `sentinel' files present in the tree
2357 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2358 qw(-- debian/rules debian/control);
2364 my ($clogp,$target) = @_;
2366 # Quilt patchification algorithm
2368 # We search backwards through the history of the main tree's HEAD
2369 # (T) looking for a start commit S whose tree object is identical
2370 # to to the patch tip tree (ie the tree corresponding to the
2371 # current dpkg-committed patch series). For these purposes
2372 # `identical' disregards anything in debian/ - this wrinkle is
2373 # necessary because dpkg-source treates debian/ specially.
2375 # We can only traverse edges where at most one of the ancestors'
2376 # trees differs (in changes outside in debian/). And we cannot
2377 # handle edges which change .pc/ or debian/patches. To avoid
2378 # going down a rathole we avoid traversing edges which introduce
2379 # debian/rules or debian/control. And we set a limit on the
2380 # number of edges we are willing to look at.
2382 # If we succeed, we walk forwards again. For each traversed edge
2383 # PC (with P parent, C child) (starting with P=S and ending with
2384 # C=T) to we do this:
2386 # - dpkg-source --commit with a patch name and message derived from C
2387 # After traversing PT, we git commit the changes which
2388 # should be contained within debian/patches.
2390 changedir '../fake';
2391 mktree_in_ud_here();
2393 runcmd @git, 'add', '.';
2394 my $oldtiptree=git_write_tree();
2395 changedir '../work';
2397 # The search for the path S..T is breadth-first. We maintain a
2398 # todo list containing search nodes. A search node identifies a
2399 # commit, and looks something like this:
2401 # Commit => $git_commit_id,
2402 # Child => $c, # or undef if P=T
2403 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2404 # Nontrivial => true iff $p..$c has relevant changes
2411 my %considered; # saves being exponential on some weird graphs
2413 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2416 my ($search,$whynot) = @_;
2417 printdebug " search NOT $search->{Commit} $whynot\n";
2418 $search->{Whynot} = $whynot;
2419 push @nots, $search;
2420 no warnings qw(exiting);
2429 my $c = shift @todo;
2430 next if $considered{$c->{Commit}}++;
2432 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2434 printdebug "quiltify investigate $c->{Commit}\n";
2437 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2438 printdebug " search finished hooray!\n";
2443 if ($quilt_mode eq 'nofix') {
2444 fail "quilt fixup required but quilt mode is \`nofix'\n".
2445 "HEAD commit $c->{Commit} differs from tree implied by ".
2446 " debian/patches (tree object $oldtiptree)";
2448 if ($quilt_mode eq 'smash') {
2449 printdebug " search quitting smash\n";
2453 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2454 $not->($c, "has $c_sentinels not $t_sentinels")
2455 if $c_sentinels ne $t_sentinels;
2457 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2458 $commitdata =~ m/\n\n/;
2460 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2461 @parents = map { { Commit => $_, Child => $c } } @parents;
2463 $not->($c, "root commit") if !@parents;
2465 foreach my $p (@parents) {
2466 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2468 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2469 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2471 foreach my $p (@parents) {
2472 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2474 my @cmd= (@git, qw(diff-tree -r --name-only),
2475 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2476 my $patchstackchange = cmdoutput @cmd;
2477 if (length $patchstackchange) {
2478 $patchstackchange =~ s/\n/,/g;
2479 $not->($p, "changed $patchstackchange");
2482 printdebug " search queue P=$p->{Commit} ",
2483 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2489 printdebug "quiltify want to smash\n";
2492 my $x = $_[0]{Commit};
2493 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2496 my $reportnot = sub {
2498 my $s = $abbrev->($notp);
2499 my $c = $notp->{Child};
2500 $s .= "..".$abbrev->($c) if $c;
2501 $s .= ": ".$notp->{Whynot};
2504 if ($quilt_mode eq 'linear') {
2505 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2506 foreach my $notp (@nots) {
2507 print STDERR "$us: ", $reportnot->($notp), "\n";
2509 fail "quilt fixup naive history linearisation failed.\n".
2510 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2511 } elsif ($quilt_mode eq 'smash') {
2512 } elsif ($quilt_mode eq 'auto') {
2513 progress "quilt fixup cannot be linear, smashing...";
2515 die "$quilt_mode ?";
2520 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2522 quiltify_dpkg_commit "auto-$version-$target-$time",
2523 (getfield $clogp, 'Maintainer'),
2524 "Automatically generated patch ($clogp->{Version})\n".
2525 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2529 progress "quiltify linearisation planning successful, executing...";
2531 for (my $p = $sref_S;
2532 my $c = $p->{Child};
2534 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2535 next unless $p->{Nontrivial};
2537 my $cc = $c->{Commit};
2539 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2540 $commitdata =~ m/\n\n/ or die "$c ?";
2543 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2546 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2549 my $patchname = $title;
2550 $patchname =~ s/[.:]$//;
2551 $patchname =~ y/ A-Z/-a-z/;
2552 $patchname =~ y/-a-z0-9_.+=~//cd;
2553 $patchname =~ s/^\W/x-$&/;
2554 $patchname = substr($patchname,0,40);
2557 stat "debian/patches/$patchname$index";
2559 $!==ENOENT or die "$patchname$index $!";
2561 runcmd @git, qw(checkout -q), $cc;
2563 # We use the tip's changelog so that dpkg-source doesn't
2564 # produce complaining messages from dpkg-parsechangelog. None
2565 # of the information dpkg-source gets from the changelog is
2566 # actually relevant - it gets put into the original message
2567 # which dpkg-source provides our stunt editor, and then
2569 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2571 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2572 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2574 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2577 runcmd @git, qw(checkout -q master);
2580 sub build_maybe_quilt_fixup () {
2581 my $format=get_source_format;
2582 return unless madformat $format;
2585 check_for_vendor_patches();
2588 # - honour any existing .pc in case it has any strangeness
2589 # - determine the git commit corresponding to the tip of
2590 # the patch stack (if there is one)
2591 # - if there is such a git commit, convert each subsequent
2592 # git commit into a quilt patch with dpkg-source --commit
2593 # - otherwise convert all the differences in the tree into
2594 # a single git commit
2598 # Our git tree doesn't necessarily contain .pc. (Some versions of
2599 # dgit would include the .pc in the git tree.) If there isn't
2600 # one, we need to generate one by unpacking the patches that we
2603 # We first look for a .pc in the git tree. If there is one, we
2604 # will use it. (This is not the normal case.)
2606 # Otherwise need to regenerate .pc so that dpkg-source --commit
2607 # can work. We do this as follows:
2608 # 1. Collect all relevant .orig from parent directory
2609 # 2. Generate a debian.tar.gz out of
2610 # debian/{patches,rules,source/format}
2611 # 3. Generate a fake .dsc containing just these fields:
2612 # Format Source Version Files
2613 # 4. Extract the fake .dsc
2614 # Now the fake .dsc has a .pc directory.
2615 # (In fact we do this in every case, because in future we will
2616 # want to search for a good base commit for generating patches.)
2618 # Then we can actually do the dpkg-source --commit
2619 # 1. Make a new working tree with the same object
2620 # store as our main tree and check out the main
2622 # 2. Copy .pc from the fake's extraction, if necessary
2623 # 3. Run dpkg-source --commit
2624 # 4. If the result has changes to debian/, then
2625 # - git-add them them
2626 # - git-add .pc if we had a .pc in-tree
2628 # 5. If we had a .pc in-tree, delete it, and git-commit
2629 # 6. Back in the main tree, fast forward to the new HEAD
2631 my $clogp = parsechangelog();
2632 my $headref = git_rev_parse('HEAD');
2637 my $upstreamversion=$version;
2638 $upstreamversion =~ s/-[^-]*$//;
2640 my $fakeversion="$upstreamversion-~~DGITFAKE";
2642 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2643 print $fakedsc <<END or die $!;
2646 Version: $fakeversion
2650 my $dscaddfile=sub {
2653 my $md = new Digest::MD5;
2655 my $fh = new IO::File $b, '<' or die "$b $!";
2660 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2663 foreach my $f (<../../../../*>) { #/){
2664 my $b=$f; $b =~ s{.*/}{};
2665 next unless is_orig_file $b, srcfn $upstreamversion,'';
2666 link $f, $b or die "$b $!";
2670 my @files=qw(debian/source/format debian/rules);
2671 if (stat_exists '../../../debian/patches') {
2672 push @files, 'debian/patches';
2675 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2676 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2678 $dscaddfile->($debtar);
2679 close $fakedsc or die $!;
2681 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2683 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2684 rename $fakexdir, "fake" or die "$fakexdir $!";
2686 mkdir "work" or die $!;
2688 mktree_in_ud_here();
2689 runcmd @git, qw(reset --hard), $headref;
2692 if (stat_exists ".pc") {
2694 progress "Tree already contains .pc - will use it then delete it.";
2697 rename '../fake/.pc','.pc' or die $!;
2700 quiltify($clogp,$headref);
2702 if (!open P, '>>', ".pc/applied-patches") {
2703 $!==&ENOENT or die $!;
2708 commit_quilty_patch();
2710 if ($mustdeletepc) {
2711 runcmd @git, qw(rm -rqf .pc);
2712 commit_admin "Commit removal of .pc (quilt series tracking data)";
2715 changedir '../../../..';
2716 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2719 sub quilt_fixup_editor () {
2720 my $descfn = $ENV{$fakeeditorenv};
2721 my $editing = $ARGV[$#ARGV];
2722 open I1, '<', $descfn or die "$descfn: $!";
2723 open I2, '<', $editing or die "$editing: $!";
2724 unlink $editing or die "$editing: $!";
2725 open O, '>', $editing or die "$editing: $!";
2726 while (<I1>) { print O or die $!; } I1->error and die $!;
2729 $copying ||= m/^\-\-\- /;
2730 next unless $copying;
2733 I2->error and die $!;
2738 #----- other building -----
2741 if ($cleanmode eq 'dpkg-source') {
2742 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2743 } elsif ($cleanmode eq 'dpkg-source-d') {
2744 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2745 } elsif ($cleanmode eq 'git') {
2746 runcmd_ordryrun_local @git, qw(clean -xdf);
2747 } elsif ($cleanmode eq 'git-ff') {
2748 runcmd_ordryrun_local @git, qw(clean -xdff);
2749 } elsif ($cleanmode eq 'check') {
2750 my $leftovers = cmdoutput @git, qw(clean -xdn);
2751 if (length $leftovers) {
2752 print STDERR $leftovers, "\n" or die $!;
2753 fail "tree contains uncommitted files and --clean=check specified";
2755 } elsif ($cleanmode eq 'none') {
2762 badusage "clean takes no additional arguments" if @ARGV;
2767 badusage "-p is not allowed when building" if defined $package;
2770 my $clogp = parsechangelog();
2771 $isuite = getfield $clogp, 'Distribution';
2772 $package = getfield $clogp, 'Source';
2773 $version = getfield $clogp, 'Version';
2774 build_maybe_quilt_fixup();
2777 sub changesopts () {
2778 my @opts =@changesopts[1..$#changesopts];
2779 if (!defined $changes_since_version) {
2780 my @vsns = archive_query('archive_query');
2781 my @quirk = access_quirk();
2782 if ($quirk[0] eq 'backports') {
2783 local $isuite = $quirk[2];
2785 canonicalise_suite();
2786 push @vsns, archive_query('archive_query');
2789 @vsns = map { $_->[0] } @vsns;
2790 @vsns = sort { -version_compare($a, $b) } @vsns;
2791 $changes_since_version = $vsns[0];
2792 progress "changelog will contain changes since $vsns[0]";
2794 $changes_since_version = '_';
2795 progress "package seems new, not specifying -v<version>";
2798 if ($changes_since_version ne '_') {
2799 unshift @opts, "-v$changes_since_version";
2804 sub massage_dbp_args ($) {
2806 return unless $cleanmode =~ m/git|none/;
2807 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2808 my @newcmd = shift @$cmd;
2809 # -nc has the side effect of specifying -b if nothing else specified
2810 push @newcmd, '-nc';
2811 # and some combinations of -S, -b, et al, are errors, rather than
2812 # later simply overriding earlier
2813 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2814 push @newcmd, @$cmd;
2820 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2821 massage_dbp_args \@dbp;
2822 runcmd_ordryrun_local @dbp;
2823 printdone "build successful\n";
2828 my @dbp = @dpkgbuildpackage;
2829 massage_dbp_args \@dbp;
2831 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2832 "--git-builder=@dbp");
2833 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2834 canonicalise_suite();
2835 push @cmd, "--git-debian-branch=".lbranch();
2837 push @cmd, changesopts();
2838 runcmd_ordryrun_local @cmd, @ARGV;
2839 printdone "build successful\n";
2844 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2845 $dscfn = dscfn($version);
2846 if ($cleanmode eq 'dpkg-source') {
2847 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2849 } elsif ($cleanmode eq 'dpkg-source-d') {
2850 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2853 my $pwd = must_getcwd();
2854 my $leafdir = basename $pwd;
2856 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2858 runcmd_ordryrun_local qw(sh -ec),
2859 'exec >$1; shift; exec "$@"','x',
2860 "../$sourcechanges",
2861 @dpkggenchanges, qw(-S), changesopts();
2865 sub cmd_build_source {
2866 badusage "build-source takes no additional arguments" if @ARGV;
2868 printdone "source built, results in $dscfn and $sourcechanges";
2874 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2876 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2877 stat_exists $sourcechanges
2878 or fail "$sourcechanges (in parent directory): $!";
2879 foreach my $cf (glob $pat) {
2880 next if $cf eq $sourcechanges;
2881 unlink $cf or fail "remove $cf: $!";
2884 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2885 my @changesfiles = glob $pat;
2886 @changesfiles = sort {
2887 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2890 fail "wrong number of different changes files (@changesfiles)"
2891 unless @changesfiles;
2892 runcmd_ordryrun_local @mergechanges, @changesfiles;
2893 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2895 stat_exists $multichanges or fail "$multichanges: $!";
2897 printdone "build successful, results in $multichanges\n" or die $!;
2900 sub cmd_quilt_fixup {
2901 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2902 my $clogp = parsechangelog();
2903 $version = getfield $clogp, 'Version';
2904 $package = getfield $clogp, 'Source';
2905 build_maybe_quilt_fixup();
2908 sub cmd_archive_api_query {
2909 badusage "need only 1 subpath argument" unless @ARGV==1;
2910 my ($subpath) = @ARGV;
2911 my @cmd = archive_api_query_cmd($subpath);
2913 exec @cmd or fail "exec curl: $!\n";
2916 sub cmd_clone_dgit_repos_server {
2917 badusage "need destination argument" unless @ARGV==1;
2918 my ($destdir) = @ARGV;
2919 $package = '_dgit-repos-server';
2920 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2922 exec @cmd or fail "exec git clone: $!\n";
2925 sub cmd_setup_mergechangelogs {
2926 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2927 setup_mergechangelogs();
2930 #---------- argument parsing and main program ----------
2933 print "dgit version $our_version\n" or die $!;
2940 if (defined $ENV{'DGIT_SSH'}) {
2941 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2942 } elsif (defined $ENV{'GIT_SSH'}) {
2943 @ssh = ($ENV{'GIT_SSH'});
2947 last unless $ARGV[0] =~ m/^-/;
2951 if (m/^--dry-run$/) {
2954 } elsif (m/^--damp-run$/) {
2957 } elsif (m/^--no-sign$/) {
2960 } elsif (m/^--help$/) {
2962 } elsif (m/^--version$/) {
2964 } elsif (m/^--new$/) {
2967 } elsif (m/^--since-version=([^_]+|_)$/) {
2969 $changes_since_version = $1;
2970 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2971 ($om = $opts_opt_map{$1}) &&
2975 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2976 !$opts_opt_cmdonly{$1} &&
2977 ($om = $opts_opt_map{$1})) {
2980 } elsif (m/^--existing-package=(.*)/s) {
2982 $existing_package = $1;
2983 } elsif (m/^--initiator-tempdir=(.*)/s) {
2984 $initiator_tempdir = $1;
2985 $initiator_tempdir =~ m#^/# or
2986 badusage "--initiator-tempdir must be used specify an".
2987 " absolute, not relative, directory."
2988 } elsif (m/^--distro=(.*)/s) {
2991 } elsif (m/^--build-products-dir=(.*)/s) {
2993 $buildproductsdir = $1;
2994 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2997 } elsif (m/^--clean=(.*)$/s) {
2998 badusage "unknown cleaning mode \`$1'";
2999 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3002 } elsif (m/^--quilt=(.*)$/s) {
3003 badusage "unknown quilt fixup mode \`$1'";
3004 } elsif (m/^--ignore-dirty$/s) {
3007 } elsif (m/^--no-quilt-fixup$/s) {
3009 $quilt_mode = 'nocheck';
3010 } elsif (m/^--no-rm-on-error$/s) {
3013 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3015 push @deliberatelies, $&;
3017 badusage "unknown long option \`$_'";
3024 } elsif (s/^-L/-/) {
3027 } elsif (s/^-h/-/) {
3029 } elsif (s/^-D/-/) {
3033 } elsif (s/^-N/-/) {
3036 } elsif (s/^-v([^_]+|_)$//s) {
3038 $changes_since_version = $1;
3041 push @changesopts, $_;
3043 } elsif (s/^-c(.*=.*)//s) {
3045 push @git, '-c', $1;
3046 } elsif (s/^-d(.+)//s) {
3049 } elsif (s/^-C(.+)//s) {
3052 if ($changesfile =~ s#^(.*)/##) {
3053 $buildproductsdir = $1;
3055 } elsif (s/^-k(.+)//s) {
3057 } elsif (m/^-[vdCk]$/) {
3059 "option \`$_' requires an argument (and no space before the argument)";
3060 } elsif (s/^-wn$//s) {
3062 $cleanmode = 'none';
3063 } elsif (s/^-wg$//s) {
3066 } elsif (s/^-wgf$//s) {
3068 $cleanmode = 'git-ff';
3069 } elsif (s/^-wd$//s) {
3071 $cleanmode = 'dpkg-source';
3072 } elsif (s/^-wdd$//s) {
3074 $cleanmode = 'dpkg-source-d';
3075 } elsif (s/^-wc$//s) {
3077 $cleanmode = 'check';
3079 badusage "unknown short option \`$_'";
3086 if ($ENV{$fakeeditorenv}) {
3087 quilt_fixup_editor();
3092 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3093 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3094 if $dryrun_level == 1;
3096 print STDERR $helpmsg or die $!;
3099 my $cmd = shift @ARGV;
3102 if (!defined $quilt_mode) {
3103 local $access_forpush;
3104 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3105 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3107 $quilt_mode =~ m/^($quilt_modes_re)$/
3108 or badcfg "unknown quilt-mode \`$quilt_mode'";
3112 my $fn = ${*::}{"cmd_$cmd"};
3113 $fn or badusage "unknown operation $cmd";