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(3 2);
45 our $isuite = 'unstable';
51 our $dryrun_level = 0;
53 our $buildproductsdir = '..';
59 our $existing_package = 'dpkg';
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]+';
70 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
73 our (@dget) = qw(dget);
74 our (@curl) = qw(curl -f);
75 our (@dput) = qw(dput);
76 our (@debsign) = qw(debsign);
78 our (@sbuild) = qw(sbuild);
80 our (@dgit) = qw(dgit);
81 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
82 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
83 our (@dpkggenchanges) = qw(dpkg-genchanges);
84 our (@mergechanges) = qw(mergechanges -f);
85 our (@changesopts) = ('');
87 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
90 'debsign' => \@debsign,
96 'dpkg-source' => \@dpkgsource,
97 'dpkg-buildpackage' => \@dpkgbuildpackage,
98 'dpkg-genchanges' => \@dpkggenchanges,
99 'ch' => \@changesopts,
100 'mergechanges' => \@mergechanges);
102 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
103 our %opts_cfg_insertpos = map {
105 scalar @{ $opts_opt_map{$_} }
106 } keys %opts_opt_map;
108 sub finalise_opts_opts();
114 our $supplementary_message = '';
118 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
121 our $remotename = 'dgit';
122 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
126 sub lbranch () { return "$branchprefix/$csuite"; }
127 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
128 sub lref () { return "refs/heads/".lbranch(); }
129 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
130 sub rrref () { return server_ref($csuite); }
132 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
142 return "${package}_".(stripepoch $vsn).$sfx
147 return srcfn($vsn,".dsc");
156 foreach my $f (@end) {
158 print STDERR "$us: cleanup: $@" if length $@;
162 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
164 sub no_such_package () {
165 print STDERR "$us: package $package does not exist in suite $isuite\n";
171 return "+".rrref().":".lrref();
176 printdebug "CD $newdir\n";
177 chdir $newdir or die "chdir: $newdir: $!";
180 sub deliberately ($) {
182 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
185 sub deliberately_not_fast_forward () {
186 foreach (qw(not-fast-forward fresh-repo)) {
187 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
191 #---------- remote protocol support, common ----------
193 # remote push initiator/responder protocol:
194 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
195 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
196 # < dgit-remote-push-ready <actual-proto-vsn>
198 # > file parsed-changelog
199 # [indicates that output of dpkg-parsechangelog follows]
200 # > data-block NBYTES
201 # > [NBYTES bytes of data (no newline)]
202 # [maybe some more blocks]
214 # [indicates that signed tag is wanted]
215 # < data-block NBYTES
216 # < [NBYTES bytes of data (no newline)]
217 # [maybe some more blocks]
221 # > want signed-dsc-changes
222 # < data-block NBYTES [transfer of signed dsc]
224 # < data-block NBYTES [transfer of signed changes]
232 sub i_child_report () {
233 # Sees if our child has died, and reap it if so. Returns a string
234 # describing how it died if it failed, or undef otherwise.
235 return undef unless $i_child_pid;
236 my $got = waitpid $i_child_pid, WNOHANG;
237 return undef if $got <= 0;
238 die unless $got == $i_child_pid;
239 $i_child_pid = undef;
240 return undef unless $?;
241 return "build host child ".waitstatusmsg();
246 fail "connection lost: $!" if $fh->error;
247 fail "protocol violation; $m not expected";
250 sub badproto_badread ($$) {
252 fail "connection lost: $!" if $!;
253 my $report = i_child_report();
254 fail $report if defined $report;
255 badproto $fh, "eof (reading $wh)";
258 sub protocol_expect (&$) {
259 my ($match, $fh) = @_;
262 defined && chomp or badproto_badread $fh, "protocol message";
270 badproto $fh, "\`$_'";
273 sub protocol_send_file ($$) {
274 my ($fh, $ourfn) = @_;
275 open PF, "<", $ourfn or die "$ourfn: $!";
278 my $got = read PF, $d, 65536;
279 die "$ourfn: $!" unless defined $got;
281 print $fh "data-block ".length($d)."\n" or die $!;
282 print $fh $d or die $!;
284 PF->error and die "$ourfn $!";
285 print $fh "data-end\n" or die $!;
289 sub protocol_read_bytes ($$) {
290 my ($fh, $nbytes) = @_;
291 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
293 my $got = read $fh, $d, $nbytes;
294 $got==$nbytes or badproto_badread $fh, "data block";
298 sub protocol_receive_file ($$) {
299 my ($fh, $ourfn) = @_;
300 printdebug "() $ourfn\n";
301 open PF, ">", $ourfn or die "$ourfn: $!";
303 my ($y,$l) = protocol_expect {
304 m/^data-block (.*)$/ ? (1,$1) :
305 m/^data-end$/ ? (0,) :
309 my $d = protocol_read_bytes $fh, $l;
310 print PF $d or die $!;
315 #---------- remote protocol support, responder ----------
317 sub responder_send_command ($) {
319 return unless $we_are_responder;
320 # called even without $we_are_responder
321 printdebug ">> $command\n";
322 print PO $command, "\n" or die $!;
325 sub responder_send_file ($$) {
326 my ($keyword, $ourfn) = @_;
327 return unless $we_are_responder;
328 printdebug "]] $keyword $ourfn\n";
329 responder_send_command "file $keyword";
330 protocol_send_file \*PO, $ourfn;
333 sub responder_receive_files ($@) {
334 my ($keyword, @ourfns) = @_;
335 die unless $we_are_responder;
336 printdebug "[[ $keyword @ourfns\n";
337 responder_send_command "want $keyword";
338 foreach my $fn (@ourfns) {
339 protocol_receive_file \*PI, $fn;
342 protocol_expect { m/^files-end$/ } \*PI;
345 #---------- remote protocol support, initiator ----------
347 sub initiator_expect (&) {
349 protocol_expect { &$match } \*RO;
352 #---------- end remote code ----------
355 if ($we_are_responder) {
357 responder_send_command "progress ".length($m) or die $!;
358 print PO $m or die $!;
368 $ua = LWP::UserAgent->new();
372 progress "downloading $what...";
373 my $r = $ua->get(@_) or die $!;
374 return undef if $r->code == 404;
375 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
376 return $r->decoded_content(charset => 'none');
379 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
384 failedcmd @_ if system @_;
387 sub act_local () { return $dryrun_level <= 1; }
388 sub act_scary () { return !$dryrun_level; }
391 if (!$dryrun_level) {
392 progress "dgit ok: @_";
394 progress "would be ok: @_ (but dry run only)";
399 printcmd(\*STDERR,$debugprefix."#",@_);
402 sub runcmd_ordryrun {
410 sub runcmd_ordryrun_local {
419 my ($first_shell, @cmd) = @_;
420 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
423 our $helpmsg = <<END;
425 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
426 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
427 dgit [dgit-opts] build [dpkg-buildpackage-opts]
428 dgit [dgit-opts] sbuild [sbuild-opts]
429 dgit [dgit-opts] push [dgit-opts] [suite]
430 dgit [dgit-opts] rpush build-host:build-dir ...
431 important dgit options:
432 -k<keyid> sign tag and package with <keyid> instead of default
433 --dry-run -n do not change anything, but go through the motions
434 --damp-run -L like --dry-run but make local changes, without signing
435 --new -N allow introducing a new package
436 --debug -D increase debug level
437 -c<name>=<value> set git config option (used directly by dgit too)
440 our $later_warning_msg = <<END;
441 Perhaps the upload is stuck in incoming. Using the version from git.
445 print STDERR "$us: @_\n", $helpmsg or die $!;
450 @ARGV or badusage "too few arguments";
451 return scalar shift @ARGV;
455 print $helpmsg or die $!;
459 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
461 our %defcfg = ('dgit.default.distro' => 'debian',
462 'dgit.default.username' => '',
463 'dgit.default.archive-query-default-component' => 'main',
464 'dgit.default.ssh' => 'ssh',
465 'dgit.default.archive-query' => 'madison:',
466 'dgit.default.sshpsql-dbname' => 'service=projectb',
467 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
468 'dgit-distro.debian.git-check' => 'url',
469 'dgit-distro.debian.git-check-suffix' => '/info/refs',
470 'dgit-distro.debian.new-private-pushers' => 't',
471 'dgit-distro.debian/push.git-url' => '',
472 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
473 'dgit-distro.debian/push.git-user-force' => 'dgit',
474 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
475 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
476 'dgit-distro.debian/push.git-create' => 'true',
477 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
478 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
479 # 'dgit-distro.debian.archive-query-tls-key',
480 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
481 # ^ this does not work because curl is broken nowadays
482 # Fixing #790093 properly will involve providing providing the key
483 # in some pacagke and maybe updating these paths.
485 # 'dgit-distro.debian.archive-query-tls-curl-args',
486 # '--ca-path=/etc/ssl/ca-debian',
487 # ^ this is a workaround but works (only) on DSA-administered machines
488 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
489 'dgit-distro.debian.git-url-suffix' => '',
490 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
491 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
492 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
493 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
494 'dgit-distro.ubuntu.git-check' => 'false',
495 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
496 'dgit-distro.test-dummy.ssh' => "$td/ssh",
497 'dgit-distro.test-dummy.username' => "alice",
498 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
499 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
500 'dgit-distro.test-dummy.git-url' => "$td/git",
501 'dgit-distro.test-dummy.git-host' => "git",
502 'dgit-distro.test-dummy.git-path' => "$td/git",
503 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
504 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
505 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
506 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
511 sub git_slurp_config () {
512 local ($debuglevel) = $debuglevel-2;
515 my @cmd = (@git, qw(config -z --get-regexp .*));
518 open GITS, "-|", @cmd or failedcmd @cmd;
521 printdebug "=> ", (messagequote $_), "\n";
523 push @{ $gitcfg{$`} }, $'; #';
527 or ($!==0 && $?==256)
531 sub git_get_config ($) {
534 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
537 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
543 return undef if $c =~ /RETURN-UNDEF/;
544 my $v = git_get_config($c);
545 return $v if defined $v;
546 my $dv = $defcfg{$c};
547 return $dv if defined $dv;
549 badcfg "need value for one of: @_\n".
550 "$us: distro or suite appears not to be (properly) supported";
553 sub access_basedistro () {
554 if (defined $idistro) {
557 return cfg("dgit-suite.$isuite.distro",
558 "dgit.default.distro");
562 sub access_quirk () {
563 # returns (quirk name, distro to use instead or undef, quirk-specific info)
564 my $basedistro = access_basedistro();
565 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
567 if (defined $backports_quirk) {
568 my $re = $backports_quirk;
569 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
571 $re =~ s/\%/([-0-9a-z_]+)/
572 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
573 if ($isuite =~ m/^$re$/) {
574 return ('backports',"$basedistro-backports",$1);
577 return ('none',undef);
582 sub parse_cfg_bool ($$$) {
583 my ($what,$def,$v) = @_;
586 $v =~ m/^[ty1]/ ? 1 :
587 $v =~ m/^[fn0]/ ? 0 :
588 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
591 sub access_forpush_config () {
592 my $d = access_basedistro();
596 parse_cfg_bool('new-private-pushers', 0,
597 cfg("dgit-distro.$d.new-private-pushers",
600 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
603 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
604 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
605 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
606 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
609 sub access_forpush () {
610 $access_forpush //= access_forpush_config();
611 return $access_forpush;
615 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
616 badcfg "pushing but distro is configured readonly"
617 if access_forpush_config() eq '0';
619 $supplementary_message = <<'END' unless $we_are_responder;
620 Push failed, before we got started.
621 You can retry the push, after fixing the problem, if you like.
623 finalise_opts_opts();
627 finalise_opts_opts();
630 sub supplementary_message ($) {
632 if (!$we_are_responder) {
633 $supplementary_message = $msg;
635 } elsif ($protovsn >= 3) {
636 responder_send_command "supplementary-message ".length($msg)
638 print PO $msg or die $!;
642 sub access_distros () {
643 # Returns list of distros to try, in order
646 # 0. `instead of' distro name(s) we have been pointed to
647 # 1. the access_quirk distro, if any
648 # 2a. the user's specified distro, or failing that } basedistro
649 # 2b. the distro calculated from the suite }
650 my @l = access_basedistro();
652 my (undef,$quirkdistro) = access_quirk();
653 unshift @l, $quirkdistro;
654 unshift @l, $instead_distro;
655 @l = grep { defined } @l;
657 if (access_forpush()) {
658 @l = map { ("$_/push", $_) } @l;
663 sub access_cfg_cfgs (@) {
666 # The nesting of these loops determines the search order. We put
667 # the key loop on the outside so that we search all the distros
668 # for each key, before going on to the next key. That means that
669 # if access_cfg is called with a more specific, and then a less
670 # specific, key, an earlier distro can override the less specific
671 # without necessarily overriding any more specific keys. (If the
672 # distro wants to override the more specific keys it can simply do
673 # so; whereas if we did the loop the other way around, it would be
674 # impossible to for an earlier distro to override a less specific
675 # key but not the more specific ones without restating the unknown
676 # values of the more specific keys.
679 # We have to deal with RETURN-UNDEF specially, so that we don't
680 # terminate the search prematurely.
682 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
685 foreach my $d (access_distros()) {
686 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
688 push @cfgs, map { "dgit.default.$_" } @realkeys;
695 my (@cfgs) = access_cfg_cfgs(@keys);
696 my $value = cfg(@cfgs);
700 sub access_cfg_bool ($$) {
701 my ($def, @keys) = @_;
702 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
705 sub string_to_ssh ($) {
707 if ($spec =~ m/\s/) {
708 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
714 sub access_cfg_ssh () {
715 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
716 if (!defined $gitssh) {
719 return string_to_ssh $gitssh;
723 sub access_runeinfo ($) {
725 return ": dgit ".access_basedistro()." $info ;";
728 sub access_someuserhost ($) {
730 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
731 defined($user) && length($user) or
732 $user = access_cfg("$some-user",'username');
733 my $host = access_cfg("$some-host");
734 return length($user) ? "$user\@$host" : $host;
737 sub access_gituserhost () {
738 return access_someuserhost('git');
741 sub access_giturl (;$) {
743 my $url = access_cfg('git-url','RETURN-UNDEF');
746 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
747 return undef unless defined $proto;
750 access_gituserhost().
751 access_cfg('git-path');
753 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
756 return "$url/$package$suffix";
759 sub parsecontrolfh ($$;$) {
760 my ($fh, $desc, $allowsigned) = @_;
761 our $dpkgcontrolhash_noissigned;
764 my %opts = ('name' => $desc);
765 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
766 $c = Dpkg::Control::Hash->new(%opts);
767 $c->parse($fh,$desc) or die "parsing of $desc failed";
768 last if $allowsigned;
769 last if $dpkgcontrolhash_noissigned;
770 my $issigned= $c->get_option('is_pgp_signed');
771 if (!defined $issigned) {
772 $dpkgcontrolhash_noissigned= 1;
773 seek $fh, 0,0 or die "seek $desc: $!";
774 } elsif ($issigned) {
775 fail "control file $desc is (already) PGP-signed. ".
776 " Note that dgit push needs to modify the .dsc and then".
777 " do the signature itself";
786 my ($file, $desc) = @_;
787 my $fh = new IO::Handle;
788 open $fh, '<', $file or die "$file: $!";
789 my $c = parsecontrolfh($fh,$desc);
790 $fh->error and die $!;
796 my ($dctrl,$field) = @_;
797 my $v = $dctrl->{$field};
798 return $v if defined $v;
799 fail "missing field $field in ".$v->get_option('name');
803 my $c = Dpkg::Control::Hash->new();
804 my $p = new IO::Handle;
805 my @cmd = (qw(dpkg-parsechangelog), @_);
806 open $p, '-|', @cmd or die $!;
808 $?=0; $!=0; close $p or failedcmd @cmd;
814 defined $d or fail "getcwd failed: $!";
820 sub archive_query ($) {
822 my $query = access_cfg('archive-query','RETURN-UNDEF');
823 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
826 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
829 sub pool_dsc_subpath ($$) {
830 my ($vsn,$component) = @_; # $package is implict arg
831 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
832 return "/pool/$component/$prefix/$package/".dscfn($vsn);
835 #---------- `ftpmasterapi' archive query method (nascent) ----------
837 sub archive_api_query_cmd ($) {
839 my @cmd = qw(curl -sS);
840 my $url = access_cfg('archive-query-url');
841 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
843 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
844 foreach my $key (split /\:/, $keys) {
845 $key =~ s/\%HOST\%/$host/g;
847 fail "for $url: stat $key: $!" unless $!==ENOENT;
850 fail "config requested specific TLS key but do not know".
851 " how to get curl to use exactly that EE key ($key)";
852 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
853 # # Sadly the above line does not work because of changes
854 # # to gnutls. The real fix for #790093 may involve
855 # # new curl options.
858 # Fixing #790093 properly will involve providing a value
859 # for this on clients.
860 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
861 push @cmd, split / /, $kargs if defined $kargs;
863 push @cmd, $url.$subpath;
869 my ($data, $subpath) = @_;
870 badcfg "ftpmasterapi archive query method takes no data part"
872 my @cmd = archive_api_query_cmd($subpath);
873 my $json = cmdoutput @cmd;
874 return decode_json($json);
877 sub canonicalise_suite_ftpmasterapi () {
878 my ($proto,$data) = @_;
879 my $suites = api_query($data, 'suites');
881 foreach my $entry (@$suites) {
883 my $v = $entry->{$_};
884 defined $v && $v eq $isuite;
886 push @matched, $entry;
888 fail "unknown suite $isuite" unless @matched;
891 @matched==1 or die "multiple matches for suite $isuite\n";
892 $cn = "$matched[0]{codename}";
893 defined $cn or die "suite $isuite info has no codename\n";
894 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
896 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
901 sub archive_query_ftpmasterapi () {
902 my ($proto,$data) = @_;
903 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
905 my $digester = Digest::SHA->new(256);
906 foreach my $entry (@$info) {
908 my $vsn = "$entry->{version}";
909 my ($ok,$msg) = version_check $vsn;
910 die "bad version: $msg\n" unless $ok;
911 my $component = "$entry->{component}";
912 $component =~ m/^$component_re$/ or die "bad component";
913 my $filename = "$entry->{filename}";
914 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
915 or die "bad filename";
916 my $sha256sum = "$entry->{sha256sum}";
917 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
918 push @rows, [ $vsn, "/pool/$component/$filename",
919 $digester, $sha256sum ];
921 die "bad ftpmaster api response: $@\n".Dumper($entry)
924 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
928 #---------- `madison' archive query method ----------
930 sub archive_query_madison {
931 return map { [ @$_[0..1] ] } madison_get_parse(@_);
934 sub madison_get_parse {
935 my ($proto,$data) = @_;
936 die unless $proto eq 'madison';
938 $data= access_cfg('madison-distro','RETURN-UNDEF');
939 $data //= access_basedistro();
941 $rmad{$proto,$data,$package} ||= cmdoutput
942 qw(rmadison -asource),"-s$isuite","-u$data",$package;
943 my $rmad = $rmad{$proto,$data,$package};
946 foreach my $l (split /\n/, $rmad) {
947 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
948 \s*( [^ \t|]+ )\s* \|
949 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
950 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
951 $1 eq $package or die "$rmad $package ?";
958 $component = access_cfg('archive-query-default-component');
960 $5 eq 'source' or die "$rmad ?";
961 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
963 return sort { -version_compare($a->[0],$b->[0]); } @out;
966 sub canonicalise_suite_madison {
967 # madison canonicalises for us
968 my @r = madison_get_parse(@_);
970 "unable to canonicalise suite using package $package".
971 " which does not appear to exist in suite $isuite;".
972 " --existing-package may help";
976 #---------- `sshpsql' archive query method ----------
979 my ($data,$runeinfo,$sql) = @_;
981 $data= access_someuserhost('sshpsql').':'.
982 access_cfg('sshpsql-dbname');
984 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
985 my ($userhost,$dbname) = ($`,$'); #';
987 my @cmd = (access_cfg_ssh, $userhost,
988 access_runeinfo("ssh-psql $runeinfo").
989 " export LC_MESSAGES=C; export LC_CTYPE=C;".
990 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
992 open P, "-|", @cmd or die $!;
995 printdebug(">|$_|\n");
998 $!=0; $?=0; close P or failedcmd @cmd;
1000 my $nrows = pop @rows;
1001 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1002 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1003 @rows = map { [ split /\|/, $_ ] } @rows;
1004 my $ncols = scalar @{ shift @rows };
1005 die if grep { scalar @$_ != $ncols } @rows;
1009 sub sql_injection_check {
1010 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1013 sub archive_query_sshpsql ($$) {
1014 my ($proto,$data) = @_;
1015 sql_injection_check $isuite, $package;
1016 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1017 SELECT source.version, component.name, files.filename, files.sha256sum
1019 JOIN src_associations ON source.id = src_associations.source
1020 JOIN suite ON suite.id = src_associations.suite
1021 JOIN dsc_files ON dsc_files.source = source.id
1022 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1023 JOIN component ON component.id = files_archive_map.component_id
1024 JOIN files ON files.id = dsc_files.file
1025 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1026 AND source.source='$package'
1027 AND files.filename LIKE '%.dsc';
1029 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1030 my $digester = Digest::SHA->new(256);
1032 my ($vsn,$component,$filename,$sha256sum) = @$_;
1033 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1038 sub canonicalise_suite_sshpsql ($$) {
1039 my ($proto,$data) = @_;
1040 sql_injection_check $isuite;
1041 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1042 SELECT suite.codename
1043 FROM suite where suite_name='$isuite' or codename='$isuite';
1045 @rows = map { $_->[0] } @rows;
1046 fail "unknown suite $isuite" unless @rows;
1047 die "ambiguous $isuite: @rows ?" if @rows>1;
1051 #---------- `dummycat' archive query method ----------
1053 sub canonicalise_suite_dummycat ($$) {
1054 my ($proto,$data) = @_;
1055 my $dpath = "$data/suite.$isuite";
1056 if (!open C, "<", $dpath) {
1057 $!==ENOENT or die "$dpath: $!";
1058 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1062 chomp or die "$dpath: $!";
1064 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1068 sub archive_query_dummycat ($$) {
1069 my ($proto,$data) = @_;
1070 canonicalise_suite();
1071 my $dpath = "$data/package.$csuite.$package";
1072 if (!open C, "<", $dpath) {
1073 $!==ENOENT or die "$dpath: $!";
1074 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1082 printdebug "dummycat query $csuite $package $dpath | $_\n";
1083 my @row = split /\s+/, $_;
1084 @row==2 or die "$dpath: $_ ?";
1087 C->error and die "$dpath: $!";
1089 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1092 #---------- archive query entrypoints and rest of program ----------
1094 sub canonicalise_suite () {
1095 return if defined $csuite;
1096 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1097 $csuite = archive_query('canonicalise_suite');
1098 if ($isuite ne $csuite) {
1099 progress "canonical suite name for $isuite is $csuite";
1103 sub get_archive_dsc () {
1104 canonicalise_suite();
1105 my @vsns = archive_query('archive_query');
1106 foreach my $vinfo (@vsns) {
1107 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1108 $dscurl = access_cfg('mirror').$subpath;
1109 $dscdata = url_get($dscurl);
1111 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1116 $digester->add($dscdata);
1117 my $got = $digester->hexdigest();
1119 fail "$dscurl has hash $got but".
1120 " archive told us to expect $digest";
1122 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1123 printdebug Dumper($dscdata) if $debuglevel>1;
1124 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1125 printdebug Dumper($dsc) if $debuglevel>1;
1126 my $fmt = getfield $dsc, 'Format';
1127 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1128 $dsc_checked = !!$digester;
1134 sub check_for_git ();
1135 sub check_for_git () {
1137 my $how = access_cfg('git-check');
1138 if ($how eq 'ssh-cmd') {
1140 (access_cfg_ssh, access_gituserhost(),
1141 access_runeinfo("git-check $package").
1142 " set -e; cd ".access_cfg('git-path').";".
1143 " if test -d $package.git; then echo 1; else echo 0; fi");
1144 my $r= cmdoutput @cmd;
1145 if ($r =~ m/^divert (\w+)$/) {
1147 my ($usedistro,) = access_distros();
1148 # NB that if we are pushing, $usedistro will be $distro/push
1149 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1150 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1151 progress "diverting to $divert (using config for $instead_distro)";
1152 return check_for_git();
1154 failedcmd @cmd unless $r =~ m/^[01]$/;
1156 } elsif ($how eq 'url') {
1157 my $prefix = access_cfg('git-check-url','git-url');
1158 my $suffix = access_cfg('git-check-suffix','git-suffix',
1159 'RETURN-UNDEF') // '.git';
1160 my $url = "$prefix/$package$suffix";
1161 my @cmd = (qw(curl -sS -I), $url);
1162 my $result = cmdoutput @cmd;
1163 $result =~ s/^\S+ 200 .*\n\r?\n//;
1164 # curl -sS -I with https_proxy prints
1165 # HTTP/1.0 200 Connection established
1166 $result =~ m/^\S+ (404|200) /s or
1167 fail "unexpected results from git check query - ".
1168 Dumper($prefix, $result);
1170 if ($code eq '404') {
1172 } elsif ($code eq '200') {
1177 } elsif ($how eq 'true') {
1179 } elsif ($how eq 'false') {
1182 badcfg "unknown git-check \`$how'";
1186 sub create_remote_git_repo () {
1187 my $how = access_cfg('git-create');
1188 if ($how eq 'ssh-cmd') {
1190 (access_cfg_ssh, access_gituserhost(),
1191 access_runeinfo("git-create $package").
1192 "set -e; cd ".access_cfg('git-path').";".
1193 " cp -a _template $package.git");
1194 } elsif ($how eq 'true') {
1197 badcfg "unknown git-create \`$how'";
1201 our ($dsc_hash,$lastpush_hash);
1203 our $ud = '.git/dgit/unpack';
1208 mkdir $ud or die $!;
1211 sub mktree_in_ud_here () {
1212 runcmd qw(git init -q);
1213 rmtree('.git/objects');
1214 symlink '../../../../objects','.git/objects' or die $!;
1217 sub git_write_tree () {
1218 my $tree = cmdoutput @git, qw(write-tree);
1219 $tree =~ m/^\w+$/ or die "$tree ?";
1223 sub remove_stray_gits () {
1224 my @gitscmd = qw(find -name .git -prune -print0);
1225 debugcmd "|",@gitscmd;
1226 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1231 print STDERR "$us: warning: removing from source package: ",
1232 (messagequote $_), "\n";
1236 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1239 sub mktree_in_ud_from_only_subdir () {
1240 # changes into the subdir
1242 die unless @dirs==1;
1243 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1247 remove_stray_gits();
1248 mktree_in_ud_here();
1249 my ($format, $fopts) = get_source_format();
1250 if (madformat($format)) {
1253 runcmd @git, qw(add -Af);
1254 my $tree=git_write_tree();
1255 return ($tree,$dir);
1258 sub dsc_files_info () {
1259 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1260 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1261 ['Files', 'Digest::MD5', 'new()']) {
1262 my ($fname, $module, $method) = @$csumi;
1263 my $field = $dsc->{$fname};
1264 next unless defined $field;
1265 eval "use $module; 1;" or die $@;
1267 foreach (split /\n/, $field) {
1269 m/^(\w+) (\d+) (\S+)$/ or
1270 fail "could not parse .dsc $fname line \`$_'";
1271 my $digester = eval "$module"."->$method;" or die $@;
1276 Digester => $digester,
1281 fail "missing any supported Checksums-* or Files field in ".
1282 $dsc->get_option('name');
1286 map { $_->{Filename} } dsc_files_info();
1289 sub is_orig_file ($;$) {
1292 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1293 defined $base or return 1;
1297 sub make_commit ($) {
1299 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1302 sub clogp_authline ($) {
1304 my $author = getfield $clogp, 'Maintainer';
1305 $author =~ s#,.*##ms;
1306 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1307 my $authline = "$author $date";
1308 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1309 fail "unexpected commit author line format \`$authline'".
1310 " (was generated from changelog Maintainer field)";
1314 sub vendor_patches_distro ($$) {
1315 my ($checkdistro, $what) = @_;
1316 return unless defined $checkdistro;
1318 my $series = "debian/patches/\L$checkdistro\E.series";
1319 printdebug "checking for vendor-specific $series ($what)\n";
1321 if (!open SERIES, "<", $series) {
1322 die "$series $!" unless $!==ENOENT;
1331 Unfortunately, this source package uses a feature of dpkg-source where
1332 the same source package unpacks to different source code on different
1333 distros. dgit cannot safely operate on such packages on affected
1334 distros, because the meaning of source packages is not stable.
1336 Please ask the distro/maintainer to remove the distro-specific series
1337 files and use a different technique (if necessary, uploading actually
1338 different packages, if different distros are supposed to have
1342 fail "Found active distro-specific series file for".
1343 " $checkdistro ($what): $series, cannot continue";
1345 die "$series $!" if SERIES->error;
1349 sub check_for_vendor_patches () {
1350 # This dpkg-source feature doesn't seem to be documented anywhere!
1351 # But it can be found in the changelog (reformatted):
1353 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1354 # Author: Raphael Hertzog <hertzog@debian.org>
1355 # Date: Sun Oct 3 09:36:48 2010 +0200
1357 # dpkg-source: correctly create .pc/.quilt_series with alternate
1360 # If you have debian/patches/ubuntu.series and you were
1361 # unpacking the source package on ubuntu, quilt was still
1362 # directed to debian/patches/series instead of
1363 # debian/patches/ubuntu.series.
1365 # debian/changelog | 3 +++
1366 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1367 # 2 files changed, 6 insertions(+), 1 deletion(-)
1370 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1371 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1372 "Dpkg::Vendor \`current vendor'");
1373 vendor_patches_distro(access_basedistro(),
1374 "distro being accessed");
1377 sub generate_commit_from_dsc () {
1381 foreach my $fi (dsc_files_info()) {
1382 my $f = $fi->{Filename};
1383 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1385 link_ltarget "../../../$f", $f
1389 complete_file_from_dsc('.', $fi)
1392 if (is_orig_file($f)) {
1393 link $f, "../../../../$f"
1399 my $dscfn = "$package.dsc";
1401 open D, ">", $dscfn or die "$dscfn: $!";
1402 print D $dscdata or die "$dscfn: $!";
1403 close D or die "$dscfn: $!";
1404 my @cmd = qw(dpkg-source);
1405 push @cmd, '--no-check' if $dsc_checked;
1406 push @cmd, qw(-x --), $dscfn;
1409 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1410 check_for_vendor_patches() if madformat($dsc->{format});
1411 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1412 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1413 my $authline = clogp_authline $clogp;
1414 my $changes = getfield $clogp, 'Changes';
1415 open C, ">../commit.tmp" or die $!;
1416 print C <<END or die $!;
1423 # imported from the archive
1426 my $outputhash = make_commit qw(../commit.tmp);
1427 my $cversion = getfield $clogp, 'Version';
1428 progress "synthesised git commit from .dsc $cversion";
1429 if ($lastpush_hash) {
1430 runcmd @git, qw(reset --hard), $lastpush_hash;
1431 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1432 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1433 my $oversion = getfield $oldclogp, 'Version';
1435 version_compare($oversion, $cversion);
1437 # git upload/ is earlier vsn than archive, use archive
1438 open C, ">../commit2.tmp" or die $!;
1439 print C <<END or die $!;
1441 parent $lastpush_hash
1446 Record $package ($cversion) in archive suite $csuite
1448 $outputhash = make_commit qw(../commit2.tmp);
1449 } elsif ($vcmp > 0) {
1450 print STDERR <<END or die $!;
1452 Version actually in archive: $cversion (older)
1453 Last allegedly pushed/uploaded: $oversion (newer or same)
1456 $outputhash = $lastpush_hash;
1458 $outputhash = $lastpush_hash;
1461 changedir '../../../..';
1462 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1463 'DGIT_ARCHIVE', $outputhash;
1464 cmdoutput @git, qw(log -n2), $outputhash;
1465 # ... gives git a chance to complain if our commit is malformed
1470 sub complete_file_from_dsc ($$) {
1471 our ($dstdir, $fi) = @_;
1472 # Ensures that we have, in $dir, the file $fi, with the correct
1473 # contents. (Downloading it from alongside $dscurl if necessary.)
1475 my $f = $fi->{Filename};
1476 my $tf = "$dstdir/$f";
1479 if (stat_exists $tf) {
1480 progress "using existing $f";
1483 $furl =~ s{/[^/]+$}{};
1485 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1486 die "$f ?" if $f =~ m#/#;
1487 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1488 return 0 if !act_local();
1492 open F, "<", "$tf" or die "$tf: $!";
1493 $fi->{Digester}->reset();
1494 $fi->{Digester}->addfile(*F);
1495 F->error and die $!;
1496 my $got = $fi->{Digester}->hexdigest();
1497 $got eq $fi->{Hash} or
1498 fail "file $f has hash $got but .dsc".
1499 " demands hash $fi->{Hash} ".
1500 ($downloaded ? "(got wrong file from archive!)"
1501 : "(perhaps you should delete this file?)");
1506 sub ensure_we_have_orig () {
1507 foreach my $fi (dsc_files_info()) {
1508 my $f = $fi->{Filename};
1509 next unless is_orig_file($f);
1510 complete_file_from_dsc('..', $fi)
1515 sub git_fetch_us () {
1516 my @specs = (fetchspec());
1518 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1520 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1523 my $tagpat = debiantag('*',access_basedistro);
1525 git_for_each_ref("refs/tags/".$tagpat, sub {
1526 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1527 printdebug "currently $fullrefname=$objid\n";
1528 $here{$fullrefname} = $objid;
1530 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1531 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1532 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1533 printdebug "offered $lref=$objid\n";
1534 if (!defined $here{$lref}) {
1535 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1536 runcmd_ordryrun_local @upd;
1537 } elsif ($here{$lref} eq $objid) {
1540 "Not updateting $lref from $here{$lref} to $objid.\n";
1545 sub fetch_from_archive () {
1546 # ensures that lrref() is what is actually in the archive,
1547 # one way or another
1551 foreach my $field (@ourdscfield) {
1552 $dsc_hash = $dsc->{$field};
1553 last if defined $dsc_hash;
1555 if (defined $dsc_hash) {
1556 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1558 progress "last upload to archive specified git hash";
1560 progress "last upload to archive has NO git hash";
1563 progress "no version available from the archive";
1566 $lastpush_hash = git_get_ref(lrref());
1567 printdebug "previous reference hash=$lastpush_hash\n";
1569 if (defined $dsc_hash) {
1570 fail "missing remote git history even though dsc has hash -".
1571 " could not find ref ".lrref().
1572 " (should have been fetched from ".access_giturl()."#".rrref().")"
1573 unless $lastpush_hash;
1575 ensure_we_have_orig();
1576 if ($dsc_hash eq $lastpush_hash) {
1577 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1578 print STDERR <<END or die $!;
1580 Git commit in archive is behind the last version allegedly pushed/uploaded.
1581 Commit referred to by archive: $dsc_hash
1582 Last allegedly pushed/uploaded: $lastpush_hash
1585 $hash = $lastpush_hash;
1587 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1588 "descendant of archive's .dsc hash ($dsc_hash)";
1591 $hash = generate_commit_from_dsc();
1592 } elsif ($lastpush_hash) {
1593 # only in git, not in the archive yet
1594 $hash = $lastpush_hash;
1595 print STDERR <<END or die $!;
1597 Package not found in the archive, but has allegedly been pushed using dgit.
1601 printdebug "nothing found!\n";
1602 if (defined $skew_warning_vsn) {
1603 print STDERR <<END or die $!;
1605 Warning: relevant archive skew detected.
1606 Archive allegedly contains $skew_warning_vsn
1607 But we were not able to obtain any version from the archive or git.
1613 printdebug "current hash=$hash\n";
1614 if ($lastpush_hash) {
1615 fail "not fast forward on last upload branch!".
1616 " (archive's version left in DGIT_ARCHIVE)"
1617 unless is_fast_fwd($lastpush_hash, $hash);
1619 if (defined $skew_warning_vsn) {
1621 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1622 my $clogf = ".git/dgit/changelog.tmp";
1623 runcmd shell_cmd "exec >$clogf",
1624 @git, qw(cat-file blob), "$hash:debian/changelog";
1625 my $gotclogp = parsechangelog("-l$clogf");
1626 my $got_vsn = getfield $gotclogp, 'Version';
1627 printdebug "SKEW CHECK GOT $got_vsn\n";
1628 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1629 print STDERR <<END or die $!;
1631 Warning: archive skew detected. Using the available version:
1632 Archive allegedly contains $skew_warning_vsn
1633 We were able to obtain only $got_vsn
1638 if ($lastpush_hash ne $hash) {
1639 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1643 dryrun_report @upd_cmd;
1649 sub set_local_git_config ($$) {
1651 runcmd @git, qw(config), $k, $v;
1654 sub setup_mergechangelogs (;$) {
1656 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1658 my $driver = 'dpkg-mergechangelogs';
1659 my $cb = "merge.$driver";
1660 my $attrs = '.git/info/attributes';
1661 ensuredir '.git/info';
1663 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1664 if (!open ATTRS, "<", $attrs) {
1665 $!==ENOENT or die "$attrs: $!";
1669 next if m{^debian/changelog\s};
1670 print NATTRS $_, "\n" or die $!;
1672 ATTRS->error and die $!;
1675 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1678 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1679 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1681 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1684 sub setup_useremail (;$) {
1686 return unless $always || access_cfg_bool(1, 'setup-useremail');
1689 my ($k, $envvar) = @_;
1690 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1691 return unless defined $v;
1692 set_local_git_config "user.$k", $v;
1695 $setup->('email', 'DEBEMAIL');
1696 $setup->('name', 'DEBFULLNAME');
1699 sub setup_new_tree () {
1700 setup_mergechangelogs();
1706 canonicalise_suite();
1707 badusage "dry run makes no sense with clone" unless act_local();
1708 my $hasgit = check_for_git();
1709 mkdir $dstdir or fail "create \`$dstdir': $!";
1711 runcmd @git, qw(init -q);
1712 my $giturl = access_giturl(1);
1713 if (defined $giturl) {
1714 set_local_git_config "remote.$remotename.fetch", fetchspec();
1715 open H, "> .git/HEAD" or die $!;
1716 print H "ref: ".lref()."\n" or die $!;
1718 runcmd @git, qw(remote add), 'origin', $giturl;
1721 progress "fetching existing git history";
1723 runcmd_ordryrun_local @git, qw(fetch origin);
1725 progress "starting new git history";
1727 fetch_from_archive() or no_such_package;
1728 my $vcsgiturl = $dsc->{'Vcs-Git'};
1729 if (length $vcsgiturl) {
1730 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1731 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1734 runcmd @git, qw(reset --hard), lrref();
1735 printdone "ready for work in $dstdir";
1739 if (check_for_git()) {
1742 fetch_from_archive() or no_such_package();
1743 printdone "fetched into ".lrref();
1748 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1750 printdone "fetched to ".lrref()." and merged into HEAD";
1753 sub check_not_dirty () {
1754 foreach my $f (qw(local-options local-patch-header)) {
1755 if (stat_exists "debian/source/$f") {
1756 fail "git tree contains debian/source/$f";
1760 return if $ignoredirty;
1762 my @cmd = (@git, qw(diff --quiet HEAD));
1764 $!=0; $?=0; system @cmd;
1765 return if !$! && !$?;
1766 if (!$! && $?==256) {
1767 fail "working tree is dirty (does not match HEAD)";
1773 sub commit_admin ($) {
1776 runcmd_ordryrun_local @git, qw(commit -m), $m;
1779 sub commit_quilty_patch () {
1780 my $output = cmdoutput @git, qw(status --porcelain);
1782 foreach my $l (split /\n/, $output) {
1783 next unless $l =~ m/\S/;
1784 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1788 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1790 progress "nothing quilty to commit, ok.";
1793 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1794 runcmd_ordryrun_local @git, qw(add -f), @adds;
1795 commit_admin "Commit Debian 3.0 (quilt) metadata";
1798 sub get_source_format () {
1800 if (open F, "debian/source/options") {
1804 s/\s+$//; # ignore missing final newline
1806 my ($k, $v) = ($`, $'); #');
1807 $v =~ s/^"(.*)"$/$1/;
1813 F->error and die $!;
1816 die $! unless $!==&ENOENT;
1819 if (!open F, "debian/source/format") {
1820 die $! unless $!==&ENOENT;
1824 F->error and die $!;
1826 return ($_, \%options);
1831 return 0 unless $format eq '3.0 (quilt)';
1832 if ($quilt_mode eq 'nocheck') {
1833 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1836 progress "Format \`$format', checking/updating patch stack";
1840 sub push_parse_changelog ($) {
1843 my $clogp = Dpkg::Control::Hash->new();
1844 $clogp->load($clogpfn) or die;
1846 $package = getfield $clogp, 'Source';
1847 my $cversion = getfield $clogp, 'Version';
1848 my $tag = debiantag($cversion, access_basedistro);
1849 runcmd @git, qw(check-ref-format), $tag;
1851 my $dscfn = dscfn($cversion);
1853 return ($clogp, $cversion, $tag, $dscfn);
1856 sub push_parse_dsc ($$$) {
1857 my ($dscfn,$dscfnwhat, $cversion) = @_;
1858 $dsc = parsecontrol($dscfn,$dscfnwhat);
1859 my $dversion = getfield $dsc, 'Version';
1860 my $dscpackage = getfield $dsc, 'Source';
1861 ($dscpackage eq $package && $dversion eq $cversion) or
1862 fail "$dscfn is for $dscpackage $dversion".
1863 " but debian/changelog is for $package $cversion";
1866 sub push_mktag ($$$$$$$) {
1867 my ($head,$clogp,$tag,
1869 $changesfile,$changesfilewhat,
1872 $dsc->{$ourdscfield[0]} = $head;
1873 $dsc->save("$dscfn.tmp") or die $!;
1875 my $changes = parsecontrol($changesfile,$changesfilewhat);
1876 foreach my $field (qw(Source Distribution Version)) {
1877 $changes->{$field} eq $clogp->{$field} or
1878 fail "changes field $field \`$changes->{$field}'".
1879 " does not match changelog \`$clogp->{$field}'";
1882 my $cversion = getfield $clogp, 'Version';
1883 my $clogsuite = getfield $clogp, 'Distribution';
1885 # We make the git tag by hand because (a) that makes it easier
1886 # to control the "tagger" (b) we can do remote signing
1887 my $authline = clogp_authline $clogp;
1888 my $delibs = join(" ", "",@deliberatelies);
1889 my $declaredistro = access_basedistro();
1890 open TO, '>', $tfn->('.tmp') or die $!;
1891 print TO <<END or die $!;
1897 $package release $cversion for $clogsuite ($csuite) [dgit]
1898 [dgit distro=$declaredistro$delibs]
1900 foreach my $ref (sort keys %previously) {
1901 print TO <<END or die $!;
1902 [dgit previously:$ref=$previously{$ref}]
1908 my $tagobjfn = $tfn->('.tmp');
1910 if (!defined $keyid) {
1911 $keyid = access_cfg('keyid','RETURN-UNDEF');
1913 if (!defined $keyid) {
1914 $keyid = getfield $clogp, 'Maintainer';
1916 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1917 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1918 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1919 push @sign_cmd, $tfn->('.tmp');
1920 runcmd_ordryrun @sign_cmd;
1922 $tagobjfn = $tfn->('.signed.tmp');
1923 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1924 $tfn->('.tmp'), $tfn->('.tmp.asc');
1931 sub sign_changes ($) {
1932 my ($changesfile) = @_;
1934 my @debsign_cmd = @debsign;
1935 push @debsign_cmd, "-k$keyid" if defined $keyid;
1936 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1937 push @debsign_cmd, $changesfile;
1938 runcmd_ordryrun @debsign_cmd;
1943 my ($forceflag) = @_;
1944 printdebug "actually entering push\n";
1945 supplementary_message(<<'END');
1946 Push failed, while preparing your push.
1947 You can retry the push, after fixing the problem, if you like.
1951 access_giturl(); # check that success is vaguely likely
1953 my $clogpfn = ".git/dgit/changelog.822.tmp";
1954 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1956 responder_send_file('parsed-changelog', $clogpfn);
1958 my ($clogp, $cversion, $tag, $dscfn) =
1959 push_parse_changelog("$clogpfn");
1961 my $dscpath = "$buildproductsdir/$dscfn";
1962 stat_exists $dscpath or
1963 fail "looked for .dsc $dscfn, but $!;".
1964 " maybe you forgot to build";
1966 responder_send_file('dsc', $dscpath);
1968 push_parse_dsc($dscpath, $dscfn, $cversion);
1970 my $format = getfield $dsc, 'Format';
1971 printdebug "format $format\n";
1972 if (madformat($format)) {
1973 commit_quilty_patch();
1977 progress "checking that $dscfn corresponds to HEAD";
1978 runcmd qw(dpkg-source -x --),
1979 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1980 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1981 check_for_vendor_patches() if madformat($dsc->{format});
1982 changedir '../../../..';
1983 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1984 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1985 debugcmd "+",@diffcmd;
1987 my $r = system @diffcmd;
1990 fail "$dscfn specifies a different tree to your HEAD commit;".
1991 " perhaps you forgot to build".
1992 ($diffopt eq '--exit-code' ? "" :
1993 " (run with -D to see full diff output)");
1998 my $head = git_rev_parse('HEAD');
1999 if (!$changesfile) {
2000 my $multi = "$buildproductsdir/".
2001 "${package}_".(stripepoch $cversion)."_multi.changes";
2002 if (stat_exists "$multi") {
2003 $changesfile = $multi;
2005 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
2006 my @cs = glob "$buildproductsdir/$pat";
2007 fail "failed to find unique changes file".
2008 " (looked for $pat in $buildproductsdir, or $multi);".
2009 " perhaps you need to use dgit -C"
2011 ($changesfile) = @cs;
2014 $changesfile = "$buildproductsdir/$changesfile";
2017 responder_send_file('changes',$changesfile);
2018 responder_send_command("param head $head");
2019 responder_send_command("param csuite $csuite");
2021 if (deliberately_not_fast_forward) {
2022 git_for_each_ref(lrfetchrefs, sub {
2023 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2024 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2025 responder_send_command("previously $rrefname=$objid");
2026 $previously{$rrefname} = $objid;
2030 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2033 supplementary_message(<<'END');
2034 Push failed, while signing the tag.
2035 You can retry the push, after fixing the problem, if you like.
2037 # If we manage to sign but fail to record it anywhere, it's fine.
2038 if ($we_are_responder) {
2039 $tagobjfn = $tfn->('.signed.tmp');
2040 responder_receive_files('signed-tag', $tagobjfn);
2043 push_mktag($head,$clogp,$tag,
2045 $changesfile,$changesfile,
2048 supplementary_message(<<'END');
2049 Push failed, *after* signing the tag.
2050 If you want to try again, you should use a new version number.
2053 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2054 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2055 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2057 supplementary_message(<<'END');
2058 Push failed, while updating the remote git repository - see messages above.
2059 If you want to try again, you should use a new version number.
2061 if (!check_for_git()) {
2062 create_remote_git_repo();
2064 runcmd_ordryrun @git, qw(push),access_giturl(),
2065 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2066 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2068 supplementary_message(<<'END');
2069 Push failed, after updating the remote git repository.
2070 If you want to try again, you must use a new version number.
2072 if ($we_are_responder) {
2073 my $dryrunsuffix = act_local() ? "" : ".tmp";
2074 responder_receive_files('signed-dsc-changes',
2075 "$dscpath$dryrunsuffix",
2076 "$changesfile$dryrunsuffix");
2079 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2081 progress "[new .dsc left in $dscpath.tmp]";
2083 sign_changes $changesfile;
2086 supplementary_message(<<END);
2087 Push failed, while uploading package(s) to the archive server.
2088 You can retry the upload of exactly these same files with dput of:
2090 If that .changes file is broken, you will need to use a new version
2091 number for your next attempt at the upload.
2093 my $host = access_cfg('upload-host','RETURN-UNDEF');
2094 my @hostarg = defined($host) ? ($host,) : ();
2095 runcmd_ordryrun @dput, @hostarg, $changesfile;
2096 printdone "pushed and uploaded $cversion";
2098 supplementary_message('');
2099 responder_send_command("complete");
2106 badusage "-p is not allowed with clone; specify as argument instead"
2107 if defined $package;
2110 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2111 ($package,$isuite) = @ARGV;
2112 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2113 ($package,$dstdir) = @ARGV;
2114 } elsif (@ARGV==3) {
2115 ($package,$isuite,$dstdir) = @ARGV;
2117 badusage "incorrect arguments to dgit clone";
2119 $dstdir ||= "$package";
2121 if (stat_exists $dstdir) {
2122 fail "$dstdir already exists";
2126 if ($rmonerror && !$dryrun_level) {
2127 $cwd_remove= getcwd();
2129 return unless defined $cwd_remove;
2130 if (!chdir "$cwd_remove") {
2131 return if $!==&ENOENT;
2132 die "chdir $cwd_remove: $!";
2135 rmtree($dstdir) or die "remove $dstdir: $!\n";
2136 } elsif (!grep { $! == $_ }
2137 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2139 print STDERR "check whether to remove $dstdir: $!\n";
2145 $cwd_remove = undef;
2148 sub branchsuite () {
2149 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2150 if ($branch =~ m#$lbranch_re#o) {
2157 sub fetchpullargs () {
2159 if (!defined $package) {
2160 my $sourcep = parsecontrol('debian/control','debian/control');
2161 $package = getfield $sourcep, 'Source';
2164 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2166 my $clogp = parsechangelog();
2167 $isuite = getfield $clogp, 'Distribution';
2169 canonicalise_suite();
2170 progress "fetching from suite $csuite";
2171 } elsif (@ARGV==1) {
2173 canonicalise_suite();
2175 badusage "incorrect arguments to dgit fetch or dgit pull";
2194 badusage "-p is not allowed with dgit push" if defined $package;
2196 my $clogp = parsechangelog();
2197 $package = getfield $clogp, 'Source';
2200 } elsif (@ARGV==1) {
2201 ($specsuite) = (@ARGV);
2203 badusage "incorrect arguments to dgit push";
2205 $isuite = getfield $clogp, 'Distribution';
2207 local ($package) = $existing_package; # this is a hack
2208 canonicalise_suite();
2210 canonicalise_suite();
2212 if (defined $specsuite &&
2213 $specsuite ne $isuite &&
2214 $specsuite ne $csuite) {
2215 fail "dgit push: changelog specifies $isuite ($csuite)".
2216 " but command line specifies $specsuite";
2218 supplementary_message(<<'END');
2219 Push failed, while checking state of the archive.
2220 You can retry the push, after fixing the problem, if you like.
2222 if (check_for_git()) {
2226 if (fetch_from_archive()) {
2227 if (is_fast_fwd(lrref(), 'HEAD')) {
2229 } elsif (deliberately_not_fast_forward) {
2232 fail "dgit push: HEAD is not a descendant".
2233 " of the archive's version.\n".
2234 "dgit: To overwrite its contents,".
2235 " use git merge -s ours ".lrref().".\n".
2236 "dgit: To rewind history, if permitted by the archive,".
2237 " use --deliberately-not-fast-forward";
2241 fail "package appears to be new in this suite;".
2242 " if this is intentional, use --new";
2247 #---------- remote commands' implementation ----------
2249 sub cmd_remote_push_build_host {
2250 my ($nrargs) = shift @ARGV;
2251 my (@rargs) = @ARGV[0..$nrargs-1];
2252 @ARGV = @ARGV[$nrargs..$#ARGV];
2254 my ($dir,$vsnwant) = @rargs;
2255 # vsnwant is a comma-separated list; we report which we have
2256 # chosen in our ready response (so other end can tell if they
2259 $we_are_responder = 1;
2260 $us .= " (build host)";
2264 open PI, "<&STDIN" or die $!;
2265 open STDIN, "/dev/null" or die $!;
2266 open PO, ">&STDOUT" or die $!;
2268 open STDOUT, ">&STDERR" or die $!;
2272 ($protovsn) = grep {
2273 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2274 } @rpushprotovsn_support;
2276 fail "build host has dgit rpush protocol versions ".
2277 (join ",", @rpushprotovsn_support).
2278 " but invocation host has $vsnwant"
2279 unless defined $protovsn;
2281 responder_send_command("dgit-remote-push-ready $protovsn");
2287 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2288 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2289 # a good error message)
2295 my $report = i_child_report();
2296 if (defined $report) {
2297 printdebug "($report)\n";
2298 } elsif ($i_child_pid) {
2299 printdebug "(killing build host child $i_child_pid)\n";
2300 kill 15, $i_child_pid;
2302 if (defined $i_tmp && !defined $initiator_tempdir) {
2304 eval { rmtree $i_tmp; };
2308 END { i_cleanup(); }
2311 my ($base,$selector,@args) = @_;
2312 $selector =~ s/\-/_/g;
2313 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2320 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2328 push @rargs, join ",", @rpushprotovsn_support;
2331 push @rdgit, @ropts;
2332 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2334 my @cmd = (@ssh, $host, shellquote @rdgit);
2337 if (defined $initiator_tempdir) {
2338 rmtree $initiator_tempdir;
2339 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2340 $i_tmp = $initiator_tempdir;
2344 $i_child_pid = open2(\*RO, \*RI, @cmd);
2346 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2347 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2348 $supplementary_message = '' unless $protovsn >= 3;
2350 my ($icmd,$iargs) = initiator_expect {
2351 m/^(\S+)(?: (.*))?$/;
2354 i_method "i_resp", $icmd, $iargs;
2358 sub i_resp_progress ($) {
2360 my $msg = protocol_read_bytes \*RO, $rhs;
2364 sub i_resp_supplementary_message ($) {
2366 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2369 sub i_resp_complete {
2370 my $pid = $i_child_pid;
2371 $i_child_pid = undef; # prevents killing some other process with same pid
2372 printdebug "waiting for build host child $pid...\n";
2373 my $got = waitpid $pid, 0;
2374 die $! unless $got == $pid;
2375 die "build host child failed $?" if $?;
2378 printdebug "all done\n";
2382 sub i_resp_file ($) {
2384 my $localname = i_method "i_localname", $keyword;
2385 my $localpath = "$i_tmp/$localname";
2386 stat_exists $localpath and
2387 badproto \*RO, "file $keyword ($localpath) twice";
2388 protocol_receive_file \*RO, $localpath;
2389 i_method "i_file", $keyword;
2394 sub i_resp_param ($) {
2395 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2399 sub i_resp_previously ($) {
2400 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2401 or badproto \*RO, "bad previously spec";
2402 my $r = system qw(git check-ref-format), $1;
2403 die "bad previously ref spec ($r)" if $r;
2404 $previously{$1} = $2;
2409 sub i_resp_want ($) {
2411 die "$keyword ?" if $i_wanted{$keyword}++;
2412 my @localpaths = i_method "i_want", $keyword;
2413 printdebug "[[ $keyword @localpaths\n";
2414 foreach my $localpath (@localpaths) {
2415 protocol_send_file \*RI, $localpath;
2417 print RI "files-end\n" or die $!;
2420 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2422 sub i_localname_parsed_changelog {
2423 return "remote-changelog.822";
2425 sub i_file_parsed_changelog {
2426 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2427 push_parse_changelog "$i_tmp/remote-changelog.822";
2428 die if $i_dscfn =~ m#/|^\W#;
2431 sub i_localname_dsc {
2432 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2437 sub i_localname_changes {
2438 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2439 $i_changesfn = $i_dscfn;
2440 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2441 return $i_changesfn;
2443 sub i_file_changes { }
2445 sub i_want_signed_tag {
2446 printdebug Dumper(\%i_param, $i_dscfn);
2447 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2448 && defined $i_param{'csuite'}
2449 or badproto \*RO, "premature desire for signed-tag";
2450 my $head = $i_param{'head'};
2451 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2453 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2455 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2458 push_mktag $head, $i_clogp, $i_tag,
2460 $i_changesfn, 'remote changes',
2461 sub { "tag$_[0]"; };
2466 sub i_want_signed_dsc_changes {
2467 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2468 sign_changes $i_changesfn;
2469 return ($i_dscfn, $i_changesfn);
2472 #---------- building etc. ----------
2478 #----- `3.0 (quilt)' handling -----
2480 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2482 sub quiltify_dpkg_commit ($$$;$) {
2483 my ($patchname,$author,$msg, $xinfo) = @_;
2487 my $descfn = ".git/dgit/quilt-description.tmp";
2488 open O, '>', $descfn or die "$descfn: $!";
2491 $msg =~ s/^\s+$/ ./mg;
2492 print O <<END or die $!;
2502 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2503 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2504 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2505 runcmd @dpkgsource, qw(--commit .), $patchname;
2509 sub quiltify_trees_differ ($$) {
2511 # returns 1 iff the two tree objects differ other than in debian/
2513 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2514 my $diffs= cmdoutput @cmd;
2515 foreach my $f (split /\0/, $diffs) {
2516 next if $f eq 'debian';
2522 sub quiltify_tree_sentinelfiles ($) {
2523 # lists the `sentinel' files present in the tree
2525 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2526 qw(-- debian/rules debian/control);
2532 my ($clogp,$target) = @_;
2534 # Quilt patchification algorithm
2536 # We search backwards through the history of the main tree's HEAD
2537 # (T) looking for a start commit S whose tree object is identical
2538 # to to the patch tip tree (ie the tree corresponding to the
2539 # current dpkg-committed patch series). For these purposes
2540 # `identical' disregards anything in debian/ - this wrinkle is
2541 # necessary because dpkg-source treates debian/ specially.
2543 # We can only traverse edges where at most one of the ancestors'
2544 # trees differs (in changes outside in debian/). And we cannot
2545 # handle edges which change .pc/ or debian/patches. To avoid
2546 # going down a rathole we avoid traversing edges which introduce
2547 # debian/rules or debian/control. And we set a limit on the
2548 # number of edges we are willing to look at.
2550 # If we succeed, we walk forwards again. For each traversed edge
2551 # PC (with P parent, C child) (starting with P=S and ending with
2552 # C=T) to we do this:
2554 # - dpkg-source --commit with a patch name and message derived from C
2555 # After traversing PT, we git commit the changes which
2556 # should be contained within debian/patches.
2558 changedir '../fake';
2559 remove_stray_gits();
2560 mktree_in_ud_here();
2562 runcmd @git, qw(add -Af .);
2563 my $oldtiptree=git_write_tree();
2564 changedir '../work';
2566 # The search for the path S..T is breadth-first. We maintain a
2567 # todo list containing search nodes. A search node identifies a
2568 # commit, and looks something like this:
2570 # Commit => $git_commit_id,
2571 # Child => $c, # or undef if P=T
2572 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2573 # Nontrivial => true iff $p..$c has relevant changes
2580 my %considered; # saves being exponential on some weird graphs
2582 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2585 my ($search,$whynot) = @_;
2586 printdebug " search NOT $search->{Commit} $whynot\n";
2587 $search->{Whynot} = $whynot;
2588 push @nots, $search;
2589 no warnings qw(exiting);
2598 my $c = shift @todo;
2599 next if $considered{$c->{Commit}}++;
2601 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2603 printdebug "quiltify investigate $c->{Commit}\n";
2606 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2607 printdebug " search finished hooray!\n";
2612 if ($quilt_mode eq 'nofix') {
2613 fail "quilt fixup required but quilt mode is \`nofix'\n".
2614 "HEAD commit $c->{Commit} differs from tree implied by ".
2615 " debian/patches (tree object $oldtiptree)";
2617 if ($quilt_mode eq 'smash') {
2618 printdebug " search quitting smash\n";
2622 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2623 $not->($c, "has $c_sentinels not $t_sentinels")
2624 if $c_sentinels ne $t_sentinels;
2626 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2627 $commitdata =~ m/\n\n/;
2629 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2630 @parents = map { { Commit => $_, Child => $c } } @parents;
2632 $not->($c, "root commit") if !@parents;
2634 foreach my $p (@parents) {
2635 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2637 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2638 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2640 foreach my $p (@parents) {
2641 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2643 my @cmd= (@git, qw(diff-tree -r --name-only),
2644 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2645 my $patchstackchange = cmdoutput @cmd;
2646 if (length $patchstackchange) {
2647 $patchstackchange =~ s/\n/,/g;
2648 $not->($p, "changed $patchstackchange");
2651 printdebug " search queue P=$p->{Commit} ",
2652 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2658 printdebug "quiltify want to smash\n";
2661 my $x = $_[0]{Commit};
2662 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2665 my $reportnot = sub {
2667 my $s = $abbrev->($notp);
2668 my $c = $notp->{Child};
2669 $s .= "..".$abbrev->($c) if $c;
2670 $s .= ": ".$notp->{Whynot};
2673 if ($quilt_mode eq 'linear') {
2674 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2675 foreach my $notp (@nots) {
2676 print STDERR "$us: ", $reportnot->($notp), "\n";
2678 fail "quilt fixup naive history linearisation failed.\n".
2679 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2680 } elsif ($quilt_mode eq 'smash') {
2681 } elsif ($quilt_mode eq 'auto') {
2682 progress "quilt fixup cannot be linear, smashing...";
2684 die "$quilt_mode ?";
2689 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2691 quiltify_dpkg_commit "auto-$version-$target-$time",
2692 (getfield $clogp, 'Maintainer'),
2693 "Automatically generated patch ($clogp->{Version})\n".
2694 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2698 progress "quiltify linearisation planning successful, executing...";
2700 for (my $p = $sref_S;
2701 my $c = $p->{Child};
2703 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2704 next unless $p->{Nontrivial};
2706 my $cc = $c->{Commit};
2708 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2709 $commitdata =~ m/\n\n/ or die "$c ?";
2712 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2715 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2718 my $patchname = $title;
2719 $patchname =~ s/[.:]$//;
2720 $patchname =~ y/ A-Z/-a-z/;
2721 $patchname =~ y/-a-z0-9_.+=~//cd;
2722 $patchname =~ s/^\W/x-$&/;
2723 $patchname = substr($patchname,0,40);
2726 stat "debian/patches/$patchname$index";
2728 $!==ENOENT or die "$patchname$index $!";
2730 runcmd @git, qw(checkout -q), $cc;
2732 # We use the tip's changelog so that dpkg-source doesn't
2733 # produce complaining messages from dpkg-parsechangelog. None
2734 # of the information dpkg-source gets from the changelog is
2735 # actually relevant - it gets put into the original message
2736 # which dpkg-source provides our stunt editor, and then
2738 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2740 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2741 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2743 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2746 runcmd @git, qw(checkout -q master);
2749 sub build_maybe_quilt_fixup () {
2750 my ($format,$fopts) = get_source_format;
2751 return unless madformat $format;
2754 check_for_vendor_patches();
2756 my $clogp = parsechangelog();
2757 my $headref = git_rev_parse('HEAD');
2762 my $upstreamversion=$version;
2763 $upstreamversion =~ s/-[^-]*$//;
2765 if ($fopts->{'single-debian-patch'}) {
2766 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2768 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2771 changedir '../../../..';
2772 runcmd_ordryrun_local
2773 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2776 sub quilt_fixup_mkwork ($) {
2779 mkdir "work" or die $!;
2781 mktree_in_ud_here();
2782 runcmd @git, qw(reset --hard), $headref;
2785 sub quilt_fixup_linkorigs ($$) {
2786 my ($upstreamversion, $fn) = @_;
2787 # calls $fn->($leafname);
2789 foreach my $f (<../../../../*>) { #/){
2790 my $b=$f; $b =~ s{.*/}{};
2792 local ($debuglevel) = $debuglevel-1;
2793 printdebug "QF linkorigs $b, $f ?\n";
2795 next unless is_orig_file $b, srcfn $upstreamversion,'';
2796 printdebug "QF linkorigs $b, $f Y\n";
2797 link_ltarget $f, $b or die "$b $!";
2802 sub quilt_fixup_delete_pc () {
2803 runcmd @git, qw(rm -rqf .pc);
2804 commit_admin "Commit removal of .pc (quilt series tracking data)";
2807 sub quilt_fixup_singlepatch ($$$) {
2808 my ($clogp, $headref, $upstreamversion) = @_;
2810 progress "starting quiltify (single-debian-patch)";
2812 # dpkg-source --commit generates new patches even if
2813 # single-debian-patch is in debian/source/options. In order to
2814 # get it to generate debian/patches/debian-changes, it is
2815 # necessary to build the source package.
2817 quilt_fixup_linkorigs($upstreamversion, sub { });
2818 quilt_fixup_mkwork($headref);
2820 rmtree("debian/patches");
2822 runcmd @dpkgsource, qw(-b .);
2824 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2825 rename srcfn("$upstreamversion", "/debian/patches"),
2826 "work/debian/patches";
2829 commit_quilty_patch();
2834 sub quilt_fixup_multipatch ($$$) {
2835 my ($clogp, $headref, $upstreamversion) = @_;
2837 progress "starting quiltify (multiple patches, $quilt_mode mode)";
2840 # - honour any existing .pc in case it has any strangeness
2841 # - determine the git commit corresponding to the tip of
2842 # the patch stack (if there is one)
2843 # - if there is such a git commit, convert each subsequent
2844 # git commit into a quilt patch with dpkg-source --commit
2845 # - otherwise convert all the differences in the tree into
2846 # a single git commit
2850 # Our git tree doesn't necessarily contain .pc. (Some versions of
2851 # dgit would include the .pc in the git tree.) If there isn't
2852 # one, we need to generate one by unpacking the patches that we
2855 # We first look for a .pc in the git tree. If there is one, we
2856 # will use it. (This is not the normal case.)
2858 # Otherwise need to regenerate .pc so that dpkg-source --commit
2859 # can work. We do this as follows:
2860 # 1. Collect all relevant .orig from parent directory
2861 # 2. Generate a debian.tar.gz out of
2862 # debian/{patches,rules,source/format,source/options}
2863 # 3. Generate a fake .dsc containing just these fields:
2864 # Format Source Version Files
2865 # 4. Extract the fake .dsc
2866 # Now the fake .dsc has a .pc directory.
2867 # (In fact we do this in every case, because in future we will
2868 # want to search for a good base commit for generating patches.)
2870 # Then we can actually do the dpkg-source --commit
2871 # 1. Make a new working tree with the same object
2872 # store as our main tree and check out the main
2874 # 2. Copy .pc from the fake's extraction, if necessary
2875 # 3. Run dpkg-source --commit
2876 # 4. If the result has changes to debian/, then
2877 # - git-add them them
2878 # - git-add .pc if we had a .pc in-tree
2880 # 5. If we had a .pc in-tree, delete it, and git-commit
2881 # 6. Back in the main tree, fast forward to the new HEAD
2883 my $fakeversion="$upstreamversion-~~DGITFAKE";
2885 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2886 print $fakedsc <<END or die $!;
2889 Version: $fakeversion
2893 my $dscaddfile=sub {
2896 my $md = new Digest::MD5;
2898 my $fh = new IO::File $b, '<' or die "$b $!";
2903 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2906 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2908 my @files=qw(debian/source/format debian/rules);
2909 foreach my $maybe (qw(debian/patches debian/source/options)) {
2910 next unless stat_exists "../../../$maybe";
2911 push @files, $maybe;
2914 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2915 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2917 $dscaddfile->($debtar);
2918 close $fakedsc or die $!;
2920 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2922 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2923 rename $fakexdir, "fake" or die "$fakexdir $!";
2925 quilt_fixup_mkwork($headref);
2928 if (stat_exists ".pc") {
2930 progress "Tree already contains .pc - will use it then delete it.";
2933 rename '../fake/.pc','.pc' or die $!;
2936 quiltify($clogp,$headref);
2938 if (!open P, '>>', ".pc/applied-patches") {
2939 $!==&ENOENT or die $!;
2944 commit_quilty_patch();
2946 if ($mustdeletepc) {
2947 quilt_fixup_delete_pc();
2951 sub quilt_fixup_editor () {
2952 my $descfn = $ENV{$fakeeditorenv};
2953 my $editing = $ARGV[$#ARGV];
2954 open I1, '<', $descfn or die "$descfn: $!";
2955 open I2, '<', $editing or die "$editing: $!";
2956 unlink $editing or die "$editing: $!";
2957 open O, '>', $editing or die "$editing: $!";
2958 while (<I1>) { print O or die $!; } I1->error and die $!;
2961 $copying ||= m/^\-\-\- /;
2962 next unless $copying;
2965 I2->error and die $!;
2970 #----- other building -----
2972 our $suppress_clean;
2975 return if $suppress_clean;
2976 if ($cleanmode eq 'dpkg-source') {
2977 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2978 } elsif ($cleanmode eq 'dpkg-source-d') {
2979 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2980 } elsif ($cleanmode eq 'git') {
2981 runcmd_ordryrun_local @git, qw(clean -xdf);
2982 } elsif ($cleanmode eq 'git-ff') {
2983 runcmd_ordryrun_local @git, qw(clean -xdff);
2984 } elsif ($cleanmode eq 'check') {
2985 my $leftovers = cmdoutput @git, qw(clean -xdn);
2986 if (length $leftovers) {
2987 print STDERR $leftovers, "\n" or die $!;
2988 fail "tree contains uncommitted files and --clean=check specified";
2990 } elsif ($cleanmode eq 'none') {
2997 badusage "clean takes no additional arguments" if @ARGV;
3004 badusage "-p is not allowed when building" if defined $package;
3007 my $clogp = parsechangelog();
3008 $isuite = getfield $clogp, 'Distribution';
3009 $package = getfield $clogp, 'Source';
3010 $version = getfield $clogp, 'Version';
3011 build_maybe_quilt_fixup();
3014 sub changesopts_initial () {
3015 my @opts =@changesopts[1..$#changesopts];
3018 sub changesopts_version () {
3019 if (!defined $changes_since_version) {
3020 my @vsns = archive_query('archive_query');
3021 my @quirk = access_quirk();
3022 if ($quirk[0] eq 'backports') {
3023 local $isuite = $quirk[2];
3025 canonicalise_suite();
3026 push @vsns, archive_query('archive_query');
3029 @vsns = map { $_->[0] } @vsns;
3030 @vsns = sort { -version_compare($a, $b) } @vsns;
3031 $changes_since_version = $vsns[0];
3032 progress "changelog will contain changes since $vsns[0]";
3034 $changes_since_version = '_';
3035 progress "package seems new, not specifying -v<version>";
3038 if ($changes_since_version ne '_') {
3039 return ("-v$changes_since_version");
3045 sub changesopts () {
3046 return (changesopts_initial(), changesopts_version());
3049 sub massage_dbp_args ($;$) {
3050 my ($cmd,$xargs) = @_;
3051 if ($cleanmode eq 'dpkg-source') {
3052 $suppress_clean = 1;
3055 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3056 my @newcmd = shift @$cmd;
3057 # -nc has the side effect of specifying -b if nothing else specified
3058 push @newcmd, '-nc';
3059 # and some combinations of -S, -b, et al, are errors, rather than
3060 # later simply overriding earlier
3061 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } (@$cmd, @$xargs);
3062 push @newcmd, @$cmd;
3067 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3068 massage_dbp_args \@dbp;
3070 push @dbp, changesopts_version();
3071 runcmd_ordryrun_local @dbp;
3072 printdone "build successful\n";
3076 my @dbp = @dpkgbuildpackage;
3077 massage_dbp_args \@dbp, \@ARGV;
3080 if (length executable_on_path('git-buildpackage')) {
3081 @cmd = qw(git-buildpackage);
3083 @cmd = qw(gbp buildpackage);
3085 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3087 if ($cleanmode eq 'dpkg-source') {
3088 $suppress_clean = 1;
3090 push @cmd, '--git-cleaner=true';
3093 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3094 canonicalise_suite();
3095 push @cmd, "--git-debian-branch=".lbranch();
3097 push @cmd, changesopts();
3098 runcmd_ordryrun_local @cmd, @ARGV;
3099 printdone "build successful\n";
3101 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3104 if ($cleanmode =~ m/^dpkg-source/) {
3105 # dpkg-source will clean, so we shouldn't
3106 $suppress_clean = 1;
3109 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
3110 $dscfn = dscfn($version);
3111 if ($cleanmode eq 'dpkg-source') {
3112 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3114 } elsif ($cleanmode eq 'dpkg-source-d') {
3115 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3118 my $pwd = must_getcwd();
3119 my $leafdir = basename $pwd;
3121 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
3123 runcmd_ordryrun_local qw(sh -ec),
3124 'exec >$1; shift; exec "$@"','x',
3125 "../$sourcechanges",
3126 @dpkggenchanges, qw(-S), changesopts();
3130 sub cmd_build_source {
3131 badusage "build-source takes no additional arguments" if @ARGV;
3133 printdone "source built, results in $dscfn and $sourcechanges";
3139 my $pat = "${package}_".(stripepoch $version)."_*.changes";
3141 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3142 stat_exists $sourcechanges
3143 or fail "$sourcechanges (in parent directory): $!";
3144 foreach my $cf (glob $pat) {
3145 next if $cf eq $sourcechanges;
3146 unlink $cf or fail "remove $cf: $!";
3149 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3150 my @changesfiles = glob $pat;
3151 @changesfiles = sort {
3152 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3155 fail "wrong number of different changes files (@changesfiles)"
3156 unless @changesfiles;
3157 runcmd_ordryrun_local @mergechanges, @changesfiles;
3158 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
3160 stat_exists $multichanges or fail "$multichanges: $!";
3162 printdone "build successful, results in $multichanges\n" or die $!;
3165 sub cmd_quilt_fixup {
3166 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3167 my $clogp = parsechangelog();
3168 $version = getfield $clogp, 'Version';
3169 $package = getfield $clogp, 'Source';
3172 build_maybe_quilt_fixup();
3175 sub cmd_archive_api_query {
3176 badusage "need only 1 subpath argument" unless @ARGV==1;
3177 my ($subpath) = @ARGV;
3178 my @cmd = archive_api_query_cmd($subpath);
3180 exec @cmd or fail "exec curl: $!\n";
3183 sub cmd_clone_dgit_repos_server {
3184 badusage "need destination argument" unless @ARGV==1;
3185 my ($destdir) = @ARGV;
3186 $package = '_dgit-repos-server';
3187 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3189 exec @cmd or fail "exec git clone: $!\n";
3192 sub cmd_setup_mergechangelogs {
3193 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3194 setup_mergechangelogs(1);
3197 sub cmd_setup_useremail {
3198 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3202 sub cmd_setup_new_tree {
3203 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3207 #---------- argument parsing and main program ----------
3210 print "dgit version $our_version\n" or die $!;
3214 our (%valopts_long, %valopts_short);
3217 sub defvalopt ($$$$) {
3218 my ($long,$short,$val_re,$how) = @_;
3219 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3220 $valopts_long{$long} = $oi;
3221 $valopts_short{$short} = $oi;
3222 # $how subref should:
3223 # do whatever assignemnt or thing it likes with $_[0]
3224 # if the option should not be passed on to remote, @rvalopts=()
3225 # or $how can be a scalar ref, meaning simply assign the value
3228 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3229 defvalopt '--distro', '-d', '.+', \$idistro;
3230 defvalopt '', '-k', '.+', \$keyid;
3231 defvalopt '--existing-package','', '.*', \$existing_package;
3232 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3233 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3234 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3236 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3238 defvalopt '', '-C', '.+', sub {
3239 ($changesfile) = (@_);
3240 if ($changesfile =~ s#^(.*)/##) {
3241 $buildproductsdir = $1;
3245 defvalopt '--initiator-tempdir','','.*', sub {
3246 ($initiator_tempdir) = (@_);
3247 $initiator_tempdir =~ m#^/# or
3248 badusage "--initiator-tempdir must be used specify an".
3249 " absolute, not relative, directory."
3255 if (defined $ENV{'DGIT_SSH'}) {
3256 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3257 } elsif (defined $ENV{'GIT_SSH'}) {
3258 @ssh = ($ENV{'GIT_SSH'});
3266 if (!defined $val) {
3267 badusage "$what needs a value" unless @ARGV;
3269 push @rvalopts, $val;
3271 badusage "bad value \`$val' for $what" unless
3272 $val =~ m/^$oi->{Re}$(?!\n)/s;
3273 my $how = $oi->{How};
3274 if (ref($how) eq 'SCALAR') {
3279 push @ropts, @rvalopts;
3283 last unless $ARGV[0] =~ m/^-/;
3287 if (m/^--dry-run$/) {
3290 } elsif (m/^--damp-run$/) {
3293 } elsif (m/^--no-sign$/) {
3296 } elsif (m/^--help$/) {
3298 } elsif (m/^--version$/) {
3300 } elsif (m/^--new$/) {
3303 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3304 ($om = $opts_opt_map{$1}) &&
3308 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3309 !$opts_opt_cmdonly{$1} &&
3310 ($om = $opts_opt_map{$1})) {
3313 } elsif (m/^--ignore-dirty$/s) {
3316 } elsif (m/^--no-quilt-fixup$/s) {
3318 $quilt_mode = 'nocheck';
3319 } elsif (m/^--no-rm-on-error$/s) {
3322 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3324 push @deliberatelies, $&;
3325 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3326 $val = $2 ? $' : undef; #';
3327 $valopt->($oi->{Long});
3329 badusage "unknown long option \`$_'";
3336 } elsif (s/^-L/-/) {
3339 } elsif (s/^-h/-/) {
3341 } elsif (s/^-D/-/) {
3345 } elsif (s/^-N/-/) {
3350 push @changesopts, $_;
3352 } elsif (s/^-wn$//s) {
3354 $cleanmode = 'none';
3355 } elsif (s/^-wg$//s) {
3358 } elsif (s/^-wgf$//s) {
3360 $cleanmode = 'git-ff';
3361 } elsif (s/^-wd$//s) {
3363 $cleanmode = 'dpkg-source';
3364 } elsif (s/^-wdd$//s) {
3366 $cleanmode = 'dpkg-source-d';
3367 } elsif (s/^-wc$//s) {
3369 $cleanmode = 'check';
3370 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3372 $val = undef unless length $val;
3373 $valopt->($oi->{Short});
3376 badusage "unknown short option \`$_'";
3383 sub finalise_opts_opts () {
3384 foreach my $k (keys %opts_opt_map) {
3385 my $om = $opts_opt_map{$k};
3387 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3389 badcfg "cannot set command for $k"
3390 unless length $om->[0];
3394 foreach my $c (access_cfg_cfgs("opts-$k")) {
3395 my $vl = $gitcfg{$c};
3396 printdebug "CL $c ",
3397 ($vl ? join " ", map { shellquote } @$vl : ""),
3398 "\n" if $debuglevel >= 4;
3400 badcfg "cannot configure options for $k"
3401 if $opts_opt_cmdonly{$k};
3402 my $insertpos = $opts_cfg_insertpos{$k};
3403 @$om = ( @$om[0..$insertpos-1],
3405 @$om[$insertpos..$#$om] );
3410 if ($ENV{$fakeeditorenv}) {
3412 quilt_fixup_editor();
3418 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3419 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3420 if $dryrun_level == 1;
3422 print STDERR $helpmsg or die $!;
3425 my $cmd = shift @ARGV;
3428 if (!defined $quilt_mode) {
3429 local $access_forpush;
3430 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3431 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3433 $quilt_mode =~ m/^($quilt_modes_re)$/
3434 or badcfg "unknown quilt-mode \`$quilt_mode'";
3438 if (!defined $cleanmode) {
3439 local $access_forpush;
3440 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3441 $cleanmode //= 'dpkg-source';
3443 badcfg "unknown clean-mode \`$cleanmode'" unless
3444 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3447 my $fn = ${*::}{"cmd_$cmd"};
3448 $fn or badusage "unknown operation $cmd";