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;
64 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
65 our $we_are_responder;
66 our $initiator_tempdir;
68 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
70 our $suite_re = '[-+.0-9a-z]+';
71 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
74 our (@dget) = qw(dget);
75 our (@curl) = qw(curl -f);
76 our (@dput) = qw(dput);
77 our (@debsign) = qw(debsign);
79 our (@sbuild) = qw(sbuild);
81 our (@dgit) = qw(dgit);
82 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
83 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
84 our (@dpkggenchanges) = qw(dpkg-genchanges);
85 our (@mergechanges) = qw(mergechanges -f);
86 our (@changesopts) = ('');
88 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
91 'debsign' => \@debsign,
97 'dpkg-source' => \@dpkgsource,
98 'dpkg-buildpackage' => \@dpkgbuildpackage,
99 'dpkg-genchanges' => \@dpkggenchanges,
100 'ch' => \@changesopts,
101 'mergechanges' => \@mergechanges);
103 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
104 our %opts_cfg_insertpos = map {
106 scalar @{ $opts_opt_map{$_} }
107 } keys %opts_opt_map;
109 sub finalise_opts_opts();
115 our $supplementary_message = '';
119 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
122 our $remotename = 'dgit';
123 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
127 sub lbranch () { return "$branchprefix/$csuite"; }
128 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
129 sub lref () { return "refs/heads/".lbranch(); }
130 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
131 sub rrref () { return server_ref($csuite); }
133 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
143 return "${package}_".(stripepoch $vsn).$sfx
148 return srcfn($vsn,".dsc");
151 sub changespat ($;$) {
152 my ($vsn, $arch) = @_;
153 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
162 foreach my $f (@end) {
164 print STDERR "$us: cleanup: $@" if length $@;
168 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
170 sub no_such_package () {
171 print STDERR "$us: package $package does not exist in suite $isuite\n";
177 return "+".rrref().":".lrref();
182 printdebug "CD $newdir\n";
183 chdir $newdir or die "chdir: $newdir: $!";
186 sub deliberately ($) {
188 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
191 sub deliberately_not_fast_forward () {
192 foreach (qw(not-fast-forward fresh-repo)) {
193 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
197 #---------- remote protocol support, common ----------
199 # remote push initiator/responder protocol:
200 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
201 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
202 # < dgit-remote-push-ready <actual-proto-vsn>
204 # > file parsed-changelog
205 # [indicates that output of dpkg-parsechangelog follows]
206 # > data-block NBYTES
207 # > [NBYTES bytes of data (no newline)]
208 # [maybe some more blocks]
220 # [indicates that signed tag is wanted]
221 # < data-block NBYTES
222 # < [NBYTES bytes of data (no newline)]
223 # [maybe some more blocks]
227 # > want signed-dsc-changes
228 # < data-block NBYTES [transfer of signed dsc]
230 # < data-block NBYTES [transfer of signed changes]
238 sub i_child_report () {
239 # Sees if our child has died, and reap it if so. Returns a string
240 # describing how it died if it failed, or undef otherwise.
241 return undef unless $i_child_pid;
242 my $got = waitpid $i_child_pid, WNOHANG;
243 return undef if $got <= 0;
244 die unless $got == $i_child_pid;
245 $i_child_pid = undef;
246 return undef unless $?;
247 return "build host child ".waitstatusmsg();
252 fail "connection lost: $!" if $fh->error;
253 fail "protocol violation; $m not expected";
256 sub badproto_badread ($$) {
258 fail "connection lost: $!" if $!;
259 my $report = i_child_report();
260 fail $report if defined $report;
261 badproto $fh, "eof (reading $wh)";
264 sub protocol_expect (&$) {
265 my ($match, $fh) = @_;
268 defined && chomp or badproto_badread $fh, "protocol message";
276 badproto $fh, "\`$_'";
279 sub protocol_send_file ($$) {
280 my ($fh, $ourfn) = @_;
281 open PF, "<", $ourfn or die "$ourfn: $!";
284 my $got = read PF, $d, 65536;
285 die "$ourfn: $!" unless defined $got;
287 print $fh "data-block ".length($d)."\n" or die $!;
288 print $fh $d or die $!;
290 PF->error and die "$ourfn $!";
291 print $fh "data-end\n" or die $!;
295 sub protocol_read_bytes ($$) {
296 my ($fh, $nbytes) = @_;
297 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
299 my $got = read $fh, $d, $nbytes;
300 $got==$nbytes or badproto_badread $fh, "data block";
304 sub protocol_receive_file ($$) {
305 my ($fh, $ourfn) = @_;
306 printdebug "() $ourfn\n";
307 open PF, ">", $ourfn or die "$ourfn: $!";
309 my ($y,$l) = protocol_expect {
310 m/^data-block (.*)$/ ? (1,$1) :
311 m/^data-end$/ ? (0,) :
315 my $d = protocol_read_bytes $fh, $l;
316 print PF $d or die $!;
321 #---------- remote protocol support, responder ----------
323 sub responder_send_command ($) {
325 return unless $we_are_responder;
326 # called even without $we_are_responder
327 printdebug ">> $command\n";
328 print PO $command, "\n" or die $!;
331 sub responder_send_file ($$) {
332 my ($keyword, $ourfn) = @_;
333 return unless $we_are_responder;
334 printdebug "]] $keyword $ourfn\n";
335 responder_send_command "file $keyword";
336 protocol_send_file \*PO, $ourfn;
339 sub responder_receive_files ($@) {
340 my ($keyword, @ourfns) = @_;
341 die unless $we_are_responder;
342 printdebug "[[ $keyword @ourfns\n";
343 responder_send_command "want $keyword";
344 foreach my $fn (@ourfns) {
345 protocol_receive_file \*PI, $fn;
348 protocol_expect { m/^files-end$/ } \*PI;
351 #---------- remote protocol support, initiator ----------
353 sub initiator_expect (&) {
355 protocol_expect { &$match } \*RO;
358 #---------- end remote code ----------
361 if ($we_are_responder) {
363 responder_send_command "progress ".length($m) or die $!;
364 print PO $m or die $!;
374 $ua = LWP::UserAgent->new();
378 progress "downloading $what...";
379 my $r = $ua->get(@_) or die $!;
380 return undef if $r->code == 404;
381 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
382 return $r->decoded_content(charset => 'none');
385 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
390 failedcmd @_ if system @_;
393 sub act_local () { return $dryrun_level <= 1; }
394 sub act_scary () { return !$dryrun_level; }
397 if (!$dryrun_level) {
398 progress "dgit ok: @_";
400 progress "would be ok: @_ (but dry run only)";
405 printcmd(\*STDERR,$debugprefix."#",@_);
408 sub runcmd_ordryrun {
416 sub runcmd_ordryrun_local {
425 my ($first_shell, @cmd) = @_;
426 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
429 our $helpmsg = <<END;
431 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
432 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
433 dgit [dgit-opts] build [dpkg-buildpackage-opts]
434 dgit [dgit-opts] sbuild [sbuild-opts]
435 dgit [dgit-opts] push [dgit-opts] [suite]
436 dgit [dgit-opts] rpush build-host:build-dir ...
437 important dgit options:
438 -k<keyid> sign tag and package with <keyid> instead of default
439 --dry-run -n do not change anything, but go through the motions
440 --damp-run -L like --dry-run but make local changes, without signing
441 --new -N allow introducing a new package
442 --debug -D increase debug level
443 -c<name>=<value> set git config option (used directly by dgit too)
446 our $later_warning_msg = <<END;
447 Perhaps the upload is stuck in incoming. Using the version from git.
451 print STDERR "$us: @_\n", $helpmsg or die $!;
456 @ARGV or badusage "too few arguments";
457 return scalar shift @ARGV;
461 print $helpmsg or die $!;
465 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
467 our %defcfg = ('dgit.default.distro' => 'debian',
468 'dgit.default.username' => '',
469 'dgit.default.archive-query-default-component' => 'main',
470 'dgit.default.ssh' => 'ssh',
471 'dgit.default.archive-query' => 'madison:',
472 'dgit.default.sshpsql-dbname' => 'service=projectb',
473 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
474 'dgit-distro.debian.git-check' => 'url',
475 'dgit-distro.debian.git-check-suffix' => '/info/refs',
476 'dgit-distro.debian.new-private-pushers' => 't',
477 'dgit-distro.debian/push.git-url' => '',
478 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
479 'dgit-distro.debian/push.git-user-force' => 'dgit',
480 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
481 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
482 'dgit-distro.debian/push.git-create' => 'true',
483 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
484 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
485 # 'dgit-distro.debian.archive-query-tls-key',
486 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
487 # ^ this does not work because curl is broken nowadays
488 # Fixing #790093 properly will involve providing providing the key
489 # in some pacagke and maybe updating these paths.
491 # 'dgit-distro.debian.archive-query-tls-curl-args',
492 # '--ca-path=/etc/ssl/ca-debian',
493 # ^ this is a workaround but works (only) on DSA-administered machines
494 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
495 'dgit-distro.debian.git-url-suffix' => '',
496 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
497 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
498 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
499 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
500 'dgit-distro.ubuntu.git-check' => 'false',
501 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
502 'dgit-distro.test-dummy.ssh' => "$td/ssh",
503 'dgit-distro.test-dummy.username' => "alice",
504 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
505 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
506 'dgit-distro.test-dummy.git-url' => "$td/git",
507 'dgit-distro.test-dummy.git-host' => "git",
508 'dgit-distro.test-dummy.git-path' => "$td/git",
509 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
510 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
511 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
512 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
517 sub git_slurp_config () {
518 local ($debuglevel) = $debuglevel-2;
521 my @cmd = (@git, qw(config -z --get-regexp .*));
524 open GITS, "-|", @cmd or failedcmd @cmd;
527 printdebug "=> ", (messagequote $_), "\n";
529 push @{ $gitcfg{$`} }, $'; #';
533 or ($!==0 && $?==256)
537 sub git_get_config ($) {
540 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
543 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
549 return undef if $c =~ /RETURN-UNDEF/;
550 my $v = git_get_config($c);
551 return $v if defined $v;
552 my $dv = $defcfg{$c};
553 return $dv if defined $dv;
555 badcfg "need value for one of: @_\n".
556 "$us: distro or suite appears not to be (properly) supported";
559 sub access_basedistro () {
560 if (defined $idistro) {
563 return cfg("dgit-suite.$isuite.distro",
564 "dgit.default.distro");
568 sub access_quirk () {
569 # returns (quirk name, distro to use instead or undef, quirk-specific info)
570 my $basedistro = access_basedistro();
571 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
573 if (defined $backports_quirk) {
574 my $re = $backports_quirk;
575 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
577 $re =~ s/\%/([-0-9a-z_]+)/
578 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
579 if ($isuite =~ m/^$re$/) {
580 return ('backports',"$basedistro-backports",$1);
583 return ('none',undef);
588 sub parse_cfg_bool ($$$) {
589 my ($what,$def,$v) = @_;
592 $v =~ m/^[ty1]/ ? 1 :
593 $v =~ m/^[fn0]/ ? 0 :
594 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
597 sub access_forpush_config () {
598 my $d = access_basedistro();
602 parse_cfg_bool('new-private-pushers', 0,
603 cfg("dgit-distro.$d.new-private-pushers",
606 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
609 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
610 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
611 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
612 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
615 sub access_forpush () {
616 $access_forpush //= access_forpush_config();
617 return $access_forpush;
621 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
622 badcfg "pushing but distro is configured readonly"
623 if access_forpush_config() eq '0';
625 $supplementary_message = <<'END' unless $we_are_responder;
626 Push failed, before we got started.
627 You can retry the push, after fixing the problem, if you like.
629 finalise_opts_opts();
633 finalise_opts_opts();
636 sub supplementary_message ($) {
638 if (!$we_are_responder) {
639 $supplementary_message = $msg;
641 } elsif ($protovsn >= 3) {
642 responder_send_command "supplementary-message ".length($msg)
644 print PO $msg or die $!;
648 sub access_distros () {
649 # Returns list of distros to try, in order
652 # 0. `instead of' distro name(s) we have been pointed to
653 # 1. the access_quirk distro, if any
654 # 2a. the user's specified distro, or failing that } basedistro
655 # 2b. the distro calculated from the suite }
656 my @l = access_basedistro();
658 my (undef,$quirkdistro) = access_quirk();
659 unshift @l, $quirkdistro;
660 unshift @l, $instead_distro;
661 @l = grep { defined } @l;
663 if (access_forpush()) {
664 @l = map { ("$_/push", $_) } @l;
669 sub access_cfg_cfgs (@) {
672 # The nesting of these loops determines the search order. We put
673 # the key loop on the outside so that we search all the distros
674 # for each key, before going on to the next key. That means that
675 # if access_cfg is called with a more specific, and then a less
676 # specific, key, an earlier distro can override the less specific
677 # without necessarily overriding any more specific keys. (If the
678 # distro wants to override the more specific keys it can simply do
679 # so; whereas if we did the loop the other way around, it would be
680 # impossible to for an earlier distro to override a less specific
681 # key but not the more specific ones without restating the unknown
682 # values of the more specific keys.
685 # We have to deal with RETURN-UNDEF specially, so that we don't
686 # terminate the search prematurely.
688 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
691 foreach my $d (access_distros()) {
692 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
694 push @cfgs, map { "dgit.default.$_" } @realkeys;
701 my (@cfgs) = access_cfg_cfgs(@keys);
702 my $value = cfg(@cfgs);
706 sub access_cfg_bool ($$) {
707 my ($def, @keys) = @_;
708 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
711 sub string_to_ssh ($) {
713 if ($spec =~ m/\s/) {
714 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
720 sub access_cfg_ssh () {
721 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
722 if (!defined $gitssh) {
725 return string_to_ssh $gitssh;
729 sub access_runeinfo ($) {
731 return ": dgit ".access_basedistro()." $info ;";
734 sub access_someuserhost ($) {
736 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
737 defined($user) && length($user) or
738 $user = access_cfg("$some-user",'username');
739 my $host = access_cfg("$some-host");
740 return length($user) ? "$user\@$host" : $host;
743 sub access_gituserhost () {
744 return access_someuserhost('git');
747 sub access_giturl (;$) {
749 my $url = access_cfg('git-url','RETURN-UNDEF');
752 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
753 return undef unless defined $proto;
756 access_gituserhost().
757 access_cfg('git-path');
759 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
762 return "$url/$package$suffix";
765 sub parsecontrolfh ($$;$) {
766 my ($fh, $desc, $allowsigned) = @_;
767 our $dpkgcontrolhash_noissigned;
770 my %opts = ('name' => $desc);
771 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
772 $c = Dpkg::Control::Hash->new(%opts);
773 $c->parse($fh,$desc) or die "parsing of $desc failed";
774 last if $allowsigned;
775 last if $dpkgcontrolhash_noissigned;
776 my $issigned= $c->get_option('is_pgp_signed');
777 if (!defined $issigned) {
778 $dpkgcontrolhash_noissigned= 1;
779 seek $fh, 0,0 or die "seek $desc: $!";
780 } elsif ($issigned) {
781 fail "control file $desc is (already) PGP-signed. ".
782 " Note that dgit push needs to modify the .dsc and then".
783 " do the signature itself";
792 my ($file, $desc) = @_;
793 my $fh = new IO::Handle;
794 open $fh, '<', $file or die "$file: $!";
795 my $c = parsecontrolfh($fh,$desc);
796 $fh->error and die $!;
802 my ($dctrl,$field) = @_;
803 my $v = $dctrl->{$field};
804 return $v if defined $v;
805 fail "missing field $field in ".$v->get_option('name');
809 my $c = Dpkg::Control::Hash->new();
810 my $p = new IO::Handle;
811 my @cmd = (qw(dpkg-parsechangelog), @_);
812 open $p, '-|', @cmd or die $!;
814 $?=0; $!=0; close $p or failedcmd @cmd;
820 defined $d or fail "getcwd failed: $!";
826 sub archive_query ($) {
828 my $query = access_cfg('archive-query','RETURN-UNDEF');
829 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
832 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
835 sub pool_dsc_subpath ($$) {
836 my ($vsn,$component) = @_; # $package is implict arg
837 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
838 return "/pool/$component/$prefix/$package/".dscfn($vsn);
841 #---------- `ftpmasterapi' archive query method (nascent) ----------
843 sub archive_api_query_cmd ($) {
845 my @cmd = qw(curl -sS);
846 my $url = access_cfg('archive-query-url');
847 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
849 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
850 foreach my $key (split /\:/, $keys) {
851 $key =~ s/\%HOST\%/$host/g;
853 fail "for $url: stat $key: $!" unless $!==ENOENT;
856 fail "config requested specific TLS key but do not know".
857 " how to get curl to use exactly that EE key ($key)";
858 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
859 # # Sadly the above line does not work because of changes
860 # # to gnutls. The real fix for #790093 may involve
861 # # new curl options.
864 # Fixing #790093 properly will involve providing a value
865 # for this on clients.
866 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
867 push @cmd, split / /, $kargs if defined $kargs;
869 push @cmd, $url.$subpath;
875 my ($data, $subpath) = @_;
876 badcfg "ftpmasterapi archive query method takes no data part"
878 my @cmd = archive_api_query_cmd($subpath);
879 my $json = cmdoutput @cmd;
880 return decode_json($json);
883 sub canonicalise_suite_ftpmasterapi () {
884 my ($proto,$data) = @_;
885 my $suites = api_query($data, 'suites');
887 foreach my $entry (@$suites) {
889 my $v = $entry->{$_};
890 defined $v && $v eq $isuite;
892 push @matched, $entry;
894 fail "unknown suite $isuite" unless @matched;
897 @matched==1 or die "multiple matches for suite $isuite\n";
898 $cn = "$matched[0]{codename}";
899 defined $cn or die "suite $isuite info has no codename\n";
900 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
902 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
907 sub archive_query_ftpmasterapi () {
908 my ($proto,$data) = @_;
909 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
911 my $digester = Digest::SHA->new(256);
912 foreach my $entry (@$info) {
914 my $vsn = "$entry->{version}";
915 my ($ok,$msg) = version_check $vsn;
916 die "bad version: $msg\n" unless $ok;
917 my $component = "$entry->{component}";
918 $component =~ m/^$component_re$/ or die "bad component";
919 my $filename = "$entry->{filename}";
920 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
921 or die "bad filename";
922 my $sha256sum = "$entry->{sha256sum}";
923 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
924 push @rows, [ $vsn, "/pool/$component/$filename",
925 $digester, $sha256sum ];
927 die "bad ftpmaster api response: $@\n".Dumper($entry)
930 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
934 #---------- `madison' archive query method ----------
936 sub archive_query_madison {
937 return map { [ @$_[0..1] ] } madison_get_parse(@_);
940 sub madison_get_parse {
941 my ($proto,$data) = @_;
942 die unless $proto eq 'madison';
944 $data= access_cfg('madison-distro','RETURN-UNDEF');
945 $data //= access_basedistro();
947 $rmad{$proto,$data,$package} ||= cmdoutput
948 qw(rmadison -asource),"-s$isuite","-u$data",$package;
949 my $rmad = $rmad{$proto,$data,$package};
952 foreach my $l (split /\n/, $rmad) {
953 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
954 \s*( [^ \t|]+ )\s* \|
955 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
956 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
957 $1 eq $package or die "$rmad $package ?";
964 $component = access_cfg('archive-query-default-component');
966 $5 eq 'source' or die "$rmad ?";
967 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
969 return sort { -version_compare($a->[0],$b->[0]); } @out;
972 sub canonicalise_suite_madison {
973 # madison canonicalises for us
974 my @r = madison_get_parse(@_);
976 "unable to canonicalise suite using package $package".
977 " which does not appear to exist in suite $isuite;".
978 " --existing-package may help";
982 #---------- `sshpsql' archive query method ----------
985 my ($data,$runeinfo,$sql) = @_;
987 $data= access_someuserhost('sshpsql').':'.
988 access_cfg('sshpsql-dbname');
990 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
991 my ($userhost,$dbname) = ($`,$'); #';
993 my @cmd = (access_cfg_ssh, $userhost,
994 access_runeinfo("ssh-psql $runeinfo").
995 " export LC_MESSAGES=C; export LC_CTYPE=C;".
996 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
998 open P, "-|", @cmd or die $!;
1001 printdebug(">|$_|\n");
1004 $!=0; $?=0; close P or failedcmd @cmd;
1006 my $nrows = pop @rows;
1007 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1008 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1009 @rows = map { [ split /\|/, $_ ] } @rows;
1010 my $ncols = scalar @{ shift @rows };
1011 die if grep { scalar @$_ != $ncols } @rows;
1015 sub sql_injection_check {
1016 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1019 sub archive_query_sshpsql ($$) {
1020 my ($proto,$data) = @_;
1021 sql_injection_check $isuite, $package;
1022 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1023 SELECT source.version, component.name, files.filename, files.sha256sum
1025 JOIN src_associations ON source.id = src_associations.source
1026 JOIN suite ON suite.id = src_associations.suite
1027 JOIN dsc_files ON dsc_files.source = source.id
1028 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1029 JOIN component ON component.id = files_archive_map.component_id
1030 JOIN files ON files.id = dsc_files.file
1031 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1032 AND source.source='$package'
1033 AND files.filename LIKE '%.dsc';
1035 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1036 my $digester = Digest::SHA->new(256);
1038 my ($vsn,$component,$filename,$sha256sum) = @$_;
1039 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1044 sub canonicalise_suite_sshpsql ($$) {
1045 my ($proto,$data) = @_;
1046 sql_injection_check $isuite;
1047 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1048 SELECT suite.codename
1049 FROM suite where suite_name='$isuite' or codename='$isuite';
1051 @rows = map { $_->[0] } @rows;
1052 fail "unknown suite $isuite" unless @rows;
1053 die "ambiguous $isuite: @rows ?" if @rows>1;
1057 #---------- `dummycat' archive query method ----------
1059 sub canonicalise_suite_dummycat ($$) {
1060 my ($proto,$data) = @_;
1061 my $dpath = "$data/suite.$isuite";
1062 if (!open C, "<", $dpath) {
1063 $!==ENOENT or die "$dpath: $!";
1064 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1068 chomp or die "$dpath: $!";
1070 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1074 sub archive_query_dummycat ($$) {
1075 my ($proto,$data) = @_;
1076 canonicalise_suite();
1077 my $dpath = "$data/package.$csuite.$package";
1078 if (!open C, "<", $dpath) {
1079 $!==ENOENT or die "$dpath: $!";
1080 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1088 printdebug "dummycat query $csuite $package $dpath | $_\n";
1089 my @row = split /\s+/, $_;
1090 @row==2 or die "$dpath: $_ ?";
1093 C->error and die "$dpath: $!";
1095 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1098 #---------- archive query entrypoints and rest of program ----------
1100 sub canonicalise_suite () {
1101 return if defined $csuite;
1102 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1103 $csuite = archive_query('canonicalise_suite');
1104 if ($isuite ne $csuite) {
1105 progress "canonical suite name for $isuite is $csuite";
1109 sub get_archive_dsc () {
1110 canonicalise_suite();
1111 my @vsns = archive_query('archive_query');
1112 foreach my $vinfo (@vsns) {
1113 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1114 $dscurl = access_cfg('mirror').$subpath;
1115 $dscdata = url_get($dscurl);
1117 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1122 $digester->add($dscdata);
1123 my $got = $digester->hexdigest();
1125 fail "$dscurl has hash $got but".
1126 " archive told us to expect $digest";
1128 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1129 printdebug Dumper($dscdata) if $debuglevel>1;
1130 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1131 printdebug Dumper($dsc) if $debuglevel>1;
1132 my $fmt = getfield $dsc, 'Format';
1133 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1134 $dsc_checked = !!$digester;
1140 sub check_for_git ();
1141 sub check_for_git () {
1143 my $how = access_cfg('git-check');
1144 if ($how eq 'ssh-cmd') {
1146 (access_cfg_ssh, access_gituserhost(),
1147 access_runeinfo("git-check $package").
1148 " set -e; cd ".access_cfg('git-path').";".
1149 " if test -d $package.git; then echo 1; else echo 0; fi");
1150 my $r= cmdoutput @cmd;
1151 if ($r =~ m/^divert (\w+)$/) {
1153 my ($usedistro,) = access_distros();
1154 # NB that if we are pushing, $usedistro will be $distro/push
1155 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1156 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1157 progress "diverting to $divert (using config for $instead_distro)";
1158 return check_for_git();
1160 failedcmd @cmd unless $r =~ m/^[01]$/;
1162 } elsif ($how eq 'url') {
1163 my $prefix = access_cfg('git-check-url','git-url');
1164 my $suffix = access_cfg('git-check-suffix','git-suffix',
1165 'RETURN-UNDEF') // '.git';
1166 my $url = "$prefix/$package$suffix";
1167 my @cmd = (qw(curl -sS -I), $url);
1168 my $result = cmdoutput @cmd;
1169 $result =~ s/^\S+ 200 .*\n\r?\n//;
1170 # curl -sS -I with https_proxy prints
1171 # HTTP/1.0 200 Connection established
1172 $result =~ m/^\S+ (404|200) /s or
1173 fail "unexpected results from git check query - ".
1174 Dumper($prefix, $result);
1176 if ($code eq '404') {
1178 } elsif ($code eq '200') {
1183 } elsif ($how eq 'true') {
1185 } elsif ($how eq 'false') {
1188 badcfg "unknown git-check \`$how'";
1192 sub create_remote_git_repo () {
1193 my $how = access_cfg('git-create');
1194 if ($how eq 'ssh-cmd') {
1196 (access_cfg_ssh, access_gituserhost(),
1197 access_runeinfo("git-create $package").
1198 "set -e; cd ".access_cfg('git-path').";".
1199 " cp -a _template $package.git");
1200 } elsif ($how eq 'true') {
1203 badcfg "unknown git-create \`$how'";
1207 our ($dsc_hash,$lastpush_hash);
1209 our $ud = '.git/dgit/unpack';
1214 mkdir $ud or die $!;
1217 sub mktree_in_ud_here () {
1218 runcmd qw(git init -q);
1219 rmtree('.git/objects');
1220 symlink '../../../../objects','.git/objects' or die $!;
1223 sub git_write_tree () {
1224 my $tree = cmdoutput @git, qw(write-tree);
1225 $tree =~ m/^\w+$/ or die "$tree ?";
1229 sub remove_stray_gits () {
1230 my @gitscmd = qw(find -name .git -prune -print0);
1231 debugcmd "|",@gitscmd;
1232 open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1237 print STDERR "$us: warning: removing from source package: ",
1238 (messagequote $_), "\n";
1242 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1245 sub mktree_in_ud_from_only_subdir () {
1246 # changes into the subdir
1248 die unless @dirs==1;
1249 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1253 remove_stray_gits();
1254 mktree_in_ud_here();
1255 my ($format, $fopts) = get_source_format();
1256 if (madformat($format)) {
1259 runcmd @git, qw(add -Af);
1260 my $tree=git_write_tree();
1261 return ($tree,$dir);
1264 sub dsc_files_info () {
1265 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1266 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1267 ['Files', 'Digest::MD5', 'new()']) {
1268 my ($fname, $module, $method) = @$csumi;
1269 my $field = $dsc->{$fname};
1270 next unless defined $field;
1271 eval "use $module; 1;" or die $@;
1273 foreach (split /\n/, $field) {
1275 m/^(\w+) (\d+) (\S+)$/ or
1276 fail "could not parse .dsc $fname line \`$_'";
1277 my $digester = eval "$module"."->$method;" or die $@;
1282 Digester => $digester,
1287 fail "missing any supported Checksums-* or Files field in ".
1288 $dsc->get_option('name');
1292 map { $_->{Filename} } dsc_files_info();
1295 sub is_orig_file ($;$) {
1298 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1299 defined $base or return 1;
1303 sub make_commit ($) {
1305 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1308 sub clogp_authline ($) {
1310 my $author = getfield $clogp, 'Maintainer';
1311 $author =~ s#,.*##ms;
1312 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1313 my $authline = "$author $date";
1314 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1315 fail "unexpected commit author line format \`$authline'".
1316 " (was generated from changelog Maintainer field)";
1320 sub vendor_patches_distro ($$) {
1321 my ($checkdistro, $what) = @_;
1322 return unless defined $checkdistro;
1324 my $series = "debian/patches/\L$checkdistro\E.series";
1325 printdebug "checking for vendor-specific $series ($what)\n";
1327 if (!open SERIES, "<", $series) {
1328 die "$series $!" unless $!==ENOENT;
1337 Unfortunately, this source package uses a feature of dpkg-source where
1338 the same source package unpacks to different source code on different
1339 distros. dgit cannot safely operate on such packages on affected
1340 distros, because the meaning of source packages is not stable.
1342 Please ask the distro/maintainer to remove the distro-specific series
1343 files and use a different technique (if necessary, uploading actually
1344 different packages, if different distros are supposed to have
1348 fail "Found active distro-specific series file for".
1349 " $checkdistro ($what): $series, cannot continue";
1351 die "$series $!" if SERIES->error;
1355 sub check_for_vendor_patches () {
1356 # This dpkg-source feature doesn't seem to be documented anywhere!
1357 # But it can be found in the changelog (reformatted):
1359 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1360 # Author: Raphael Hertzog <hertzog@debian.org>
1361 # Date: Sun Oct 3 09:36:48 2010 +0200
1363 # dpkg-source: correctly create .pc/.quilt_series with alternate
1366 # If you have debian/patches/ubuntu.series and you were
1367 # unpacking the source package on ubuntu, quilt was still
1368 # directed to debian/patches/series instead of
1369 # debian/patches/ubuntu.series.
1371 # debian/changelog | 3 +++
1372 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1373 # 2 files changed, 6 insertions(+), 1 deletion(-)
1376 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1377 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1378 "Dpkg::Vendor \`current vendor'");
1379 vendor_patches_distro(access_basedistro(),
1380 "distro being accessed");
1383 sub generate_commit_from_dsc () {
1387 foreach my $fi (dsc_files_info()) {
1388 my $f = $fi->{Filename};
1389 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1391 link_ltarget "../../../$f", $f
1395 complete_file_from_dsc('.', $fi)
1398 if (is_orig_file($f)) {
1399 link $f, "../../../../$f"
1405 my $dscfn = "$package.dsc";
1407 open D, ">", $dscfn or die "$dscfn: $!";
1408 print D $dscdata or die "$dscfn: $!";
1409 close D or die "$dscfn: $!";
1410 my @cmd = qw(dpkg-source);
1411 push @cmd, '--no-check' if $dsc_checked;
1412 push @cmd, qw(-x --), $dscfn;
1415 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1416 check_for_vendor_patches() if madformat($dsc->{format});
1417 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1418 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1419 my $authline = clogp_authline $clogp;
1420 my $changes = getfield $clogp, 'Changes';
1421 open C, ">../commit.tmp" or die $!;
1422 print C <<END or die $!;
1429 # imported from the archive
1432 my $outputhash = make_commit qw(../commit.tmp);
1433 my $cversion = getfield $clogp, 'Version';
1434 progress "synthesised git commit from .dsc $cversion";
1435 if ($lastpush_hash) {
1436 runcmd @git, qw(reset --hard), $lastpush_hash;
1437 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1438 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1439 my $oversion = getfield $oldclogp, 'Version';
1441 version_compare($oversion, $cversion);
1443 # git upload/ is earlier vsn than archive, use archive
1444 open C, ">../commit2.tmp" or die $!;
1445 print C <<END or die $!;
1447 parent $lastpush_hash
1452 Record $package ($cversion) in archive suite $csuite
1454 $outputhash = make_commit qw(../commit2.tmp);
1455 } elsif ($vcmp > 0) {
1456 print STDERR <<END or die $!;
1458 Version actually in archive: $cversion (older)
1459 Last allegedly pushed/uploaded: $oversion (newer or same)
1462 $outputhash = $lastpush_hash;
1464 $outputhash = $lastpush_hash;
1467 changedir '../../../..';
1468 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1469 'DGIT_ARCHIVE', $outputhash;
1470 cmdoutput @git, qw(log -n2), $outputhash;
1471 # ... gives git a chance to complain if our commit is malformed
1476 sub complete_file_from_dsc ($$) {
1477 our ($dstdir, $fi) = @_;
1478 # Ensures that we have, in $dir, the file $fi, with the correct
1479 # contents. (Downloading it from alongside $dscurl if necessary.)
1481 my $f = $fi->{Filename};
1482 my $tf = "$dstdir/$f";
1485 if (stat_exists $tf) {
1486 progress "using existing $f";
1489 $furl =~ s{/[^/]+$}{};
1491 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1492 die "$f ?" if $f =~ m#/#;
1493 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1494 return 0 if !act_local();
1498 open F, "<", "$tf" or die "$tf: $!";
1499 $fi->{Digester}->reset();
1500 $fi->{Digester}->addfile(*F);
1501 F->error and die $!;
1502 my $got = $fi->{Digester}->hexdigest();
1503 $got eq $fi->{Hash} or
1504 fail "file $f has hash $got but .dsc".
1505 " demands hash $fi->{Hash} ".
1506 ($downloaded ? "(got wrong file from archive!)"
1507 : "(perhaps you should delete this file?)");
1512 sub ensure_we_have_orig () {
1513 foreach my $fi (dsc_files_info()) {
1514 my $f = $fi->{Filename};
1515 next unless is_orig_file($f);
1516 complete_file_from_dsc('..', $fi)
1521 sub git_fetch_us () {
1522 my @specs = (fetchspec());
1524 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1526 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1529 my $tagpat = debiantag('*',access_basedistro);
1531 git_for_each_ref("refs/tags/".$tagpat, sub {
1532 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1533 printdebug "currently $fullrefname=$objid\n";
1534 $here{$fullrefname} = $objid;
1536 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1537 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1538 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1539 printdebug "offered $lref=$objid\n";
1540 if (!defined $here{$lref}) {
1541 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1542 runcmd_ordryrun_local @upd;
1543 } elsif ($here{$lref} eq $objid) {
1546 "Not updateting $lref from $here{$lref} to $objid.\n";
1551 sub fetch_from_archive () {
1552 # ensures that lrref() is what is actually in the archive,
1553 # one way or another
1557 foreach my $field (@ourdscfield) {
1558 $dsc_hash = $dsc->{$field};
1559 last if defined $dsc_hash;
1561 if (defined $dsc_hash) {
1562 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1564 progress "last upload to archive specified git hash";
1566 progress "last upload to archive has NO git hash";
1569 progress "no version available from the archive";
1572 $lastpush_hash = git_get_ref(lrref());
1573 printdebug "previous reference hash=$lastpush_hash\n";
1575 if (defined $dsc_hash) {
1576 fail "missing remote git history even though dsc has hash -".
1577 " could not find ref ".lrref().
1578 " (should have been fetched from ".access_giturl()."#".rrref().")"
1579 unless $lastpush_hash;
1581 ensure_we_have_orig();
1582 if ($dsc_hash eq $lastpush_hash) {
1583 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1584 print STDERR <<END or die $!;
1586 Git commit in archive is behind the last version allegedly pushed/uploaded.
1587 Commit referred to by archive: $dsc_hash
1588 Last allegedly pushed/uploaded: $lastpush_hash
1591 $hash = $lastpush_hash;
1593 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1594 "descendant of archive's .dsc hash ($dsc_hash)";
1597 $hash = generate_commit_from_dsc();
1598 } elsif ($lastpush_hash) {
1599 # only in git, not in the archive yet
1600 $hash = $lastpush_hash;
1601 print STDERR <<END or die $!;
1603 Package not found in the archive, but has allegedly been pushed using dgit.
1607 printdebug "nothing found!\n";
1608 if (defined $skew_warning_vsn) {
1609 print STDERR <<END or die $!;
1611 Warning: relevant archive skew detected.
1612 Archive allegedly contains $skew_warning_vsn
1613 But we were not able to obtain any version from the archive or git.
1619 printdebug "current hash=$hash\n";
1620 if ($lastpush_hash) {
1621 fail "not fast forward on last upload branch!".
1622 " (archive's version left in DGIT_ARCHIVE)"
1623 unless is_fast_fwd($lastpush_hash, $hash);
1625 if (defined $skew_warning_vsn) {
1627 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1628 my $clogf = ".git/dgit/changelog.tmp";
1629 runcmd shell_cmd "exec >$clogf",
1630 @git, qw(cat-file blob), "$hash:debian/changelog";
1631 my $gotclogp = parsechangelog("-l$clogf");
1632 my $got_vsn = getfield $gotclogp, 'Version';
1633 printdebug "SKEW CHECK GOT $got_vsn\n";
1634 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1635 print STDERR <<END or die $!;
1637 Warning: archive skew detected. Using the available version:
1638 Archive allegedly contains $skew_warning_vsn
1639 We were able to obtain only $got_vsn
1644 if ($lastpush_hash ne $hash) {
1645 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1649 dryrun_report @upd_cmd;
1655 sub set_local_git_config ($$) {
1657 runcmd @git, qw(config), $k, $v;
1660 sub setup_mergechangelogs (;$) {
1662 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1664 my $driver = 'dpkg-mergechangelogs';
1665 my $cb = "merge.$driver";
1666 my $attrs = '.git/info/attributes';
1667 ensuredir '.git/info';
1669 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1670 if (!open ATTRS, "<", $attrs) {
1671 $!==ENOENT or die "$attrs: $!";
1675 next if m{^debian/changelog\s};
1676 print NATTRS $_, "\n" or die $!;
1678 ATTRS->error and die $!;
1681 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1684 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1685 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1687 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1690 sub setup_useremail (;$) {
1692 return unless $always || access_cfg_bool(1, 'setup-useremail');
1695 my ($k, $envvar) = @_;
1696 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1697 return unless defined $v;
1698 set_local_git_config "user.$k", $v;
1701 $setup->('email', 'DEBEMAIL');
1702 $setup->('name', 'DEBFULLNAME');
1705 sub setup_new_tree () {
1706 setup_mergechangelogs();
1712 canonicalise_suite();
1713 badusage "dry run makes no sense with clone" unless act_local();
1714 my $hasgit = check_for_git();
1715 mkdir $dstdir or fail "create \`$dstdir': $!";
1717 runcmd @git, qw(init -q);
1718 my $giturl = access_giturl(1);
1719 if (defined $giturl) {
1720 set_local_git_config "remote.$remotename.fetch", fetchspec();
1721 open H, "> .git/HEAD" or die $!;
1722 print H "ref: ".lref()."\n" or die $!;
1724 runcmd @git, qw(remote add), 'origin', $giturl;
1727 progress "fetching existing git history";
1729 runcmd_ordryrun_local @git, qw(fetch origin);
1731 progress "starting new git history";
1733 fetch_from_archive() or no_such_package;
1734 my $vcsgiturl = $dsc->{'Vcs-Git'};
1735 if (length $vcsgiturl) {
1736 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1737 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1740 runcmd @git, qw(reset --hard), lrref();
1741 printdone "ready for work in $dstdir";
1745 if (check_for_git()) {
1748 fetch_from_archive() or no_such_package();
1749 printdone "fetched into ".lrref();
1754 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1756 printdone "fetched to ".lrref()." and merged into HEAD";
1759 sub check_not_dirty () {
1760 foreach my $f (qw(local-options local-patch-header)) {
1761 if (stat_exists "debian/source/$f") {
1762 fail "git tree contains debian/source/$f";
1766 return if $ignoredirty;
1768 my @cmd = (@git, qw(diff --quiet HEAD));
1770 $!=0; $?=0; system @cmd;
1771 return if !$! && !$?;
1772 if (!$! && $?==256) {
1773 fail "working tree is dirty (does not match HEAD)";
1779 sub commit_admin ($) {
1782 runcmd_ordryrun_local @git, qw(commit -m), $m;
1785 sub commit_quilty_patch () {
1786 my $output = cmdoutput @git, qw(status --porcelain);
1788 foreach my $l (split /\n/, $output) {
1789 next unless $l =~ m/\S/;
1790 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1794 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1796 progress "nothing quilty to commit, ok.";
1799 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1800 runcmd_ordryrun_local @git, qw(add -f), @adds;
1801 commit_admin "Commit Debian 3.0 (quilt) metadata";
1804 sub get_source_format () {
1806 if (open F, "debian/source/options") {
1810 s/\s+$//; # ignore missing final newline
1812 my ($k, $v) = ($`, $'); #');
1813 $v =~ s/^"(.*)"$/$1/;
1819 F->error and die $!;
1822 die $! unless $!==&ENOENT;
1825 if (!open F, "debian/source/format") {
1826 die $! unless $!==&ENOENT;
1830 F->error and die $!;
1832 return ($_, \%options);
1837 return 0 unless $format eq '3.0 (quilt)';
1838 if ($quilt_mode eq 'nocheck') {
1839 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1842 progress "Format \`$format', checking/updating patch stack";
1846 sub push_parse_changelog ($) {
1849 my $clogp = Dpkg::Control::Hash->new();
1850 $clogp->load($clogpfn) or die;
1852 $package = getfield $clogp, 'Source';
1853 my $cversion = getfield $clogp, 'Version';
1854 my $tag = debiantag($cversion, access_basedistro);
1855 runcmd @git, qw(check-ref-format), $tag;
1857 my $dscfn = dscfn($cversion);
1859 return ($clogp, $cversion, $tag, $dscfn);
1862 sub push_parse_dsc ($$$) {
1863 my ($dscfn,$dscfnwhat, $cversion) = @_;
1864 $dsc = parsecontrol($dscfn,$dscfnwhat);
1865 my $dversion = getfield $dsc, 'Version';
1866 my $dscpackage = getfield $dsc, 'Source';
1867 ($dscpackage eq $package && $dversion eq $cversion) or
1868 fail "$dscfn is for $dscpackage $dversion".
1869 " but debian/changelog is for $package $cversion";
1872 sub push_mktag ($$$$$$$) {
1873 my ($head,$clogp,$tag,
1875 $changesfile,$changesfilewhat,
1878 $dsc->{$ourdscfield[0]} = $head;
1879 $dsc->save("$dscfn.tmp") or die $!;
1881 my $changes = parsecontrol($changesfile,$changesfilewhat);
1882 foreach my $field (qw(Source Distribution Version)) {
1883 $changes->{$field} eq $clogp->{$field} or
1884 fail "changes field $field \`$changes->{$field}'".
1885 " does not match changelog \`$clogp->{$field}'";
1888 my $cversion = getfield $clogp, 'Version';
1889 my $clogsuite = getfield $clogp, 'Distribution';
1891 # We make the git tag by hand because (a) that makes it easier
1892 # to control the "tagger" (b) we can do remote signing
1893 my $authline = clogp_authline $clogp;
1894 my $delibs = join(" ", "",@deliberatelies);
1895 my $declaredistro = access_basedistro();
1896 open TO, '>', $tfn->('.tmp') or die $!;
1897 print TO <<END or die $!;
1903 $package release $cversion for $clogsuite ($csuite) [dgit]
1904 [dgit distro=$declaredistro$delibs]
1906 foreach my $ref (sort keys %previously) {
1907 print TO <<END or die $!;
1908 [dgit previously:$ref=$previously{$ref}]
1914 my $tagobjfn = $tfn->('.tmp');
1916 if (!defined $keyid) {
1917 $keyid = access_cfg('keyid','RETURN-UNDEF');
1919 if (!defined $keyid) {
1920 $keyid = getfield $clogp, 'Maintainer';
1922 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1923 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1924 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1925 push @sign_cmd, $tfn->('.tmp');
1926 runcmd_ordryrun @sign_cmd;
1928 $tagobjfn = $tfn->('.signed.tmp');
1929 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1930 $tfn->('.tmp'), $tfn->('.tmp.asc');
1937 sub sign_changes ($) {
1938 my ($changesfile) = @_;
1940 my @debsign_cmd = @debsign;
1941 push @debsign_cmd, "-k$keyid" if defined $keyid;
1942 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1943 push @debsign_cmd, $changesfile;
1944 runcmd_ordryrun @debsign_cmd;
1949 my ($forceflag) = @_;
1950 printdebug "actually entering push\n";
1951 supplementary_message(<<'END');
1952 Push failed, while preparing your push.
1953 You can retry the push, after fixing the problem, if you like.
1957 access_giturl(); # check that success is vaguely likely
1959 my $clogpfn = ".git/dgit/changelog.822.tmp";
1960 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1962 responder_send_file('parsed-changelog', $clogpfn);
1964 my ($clogp, $cversion, $tag, $dscfn) =
1965 push_parse_changelog("$clogpfn");
1967 my $dscpath = "$buildproductsdir/$dscfn";
1968 stat_exists $dscpath or
1969 fail "looked for .dsc $dscfn, but $!;".
1970 " maybe you forgot to build";
1972 responder_send_file('dsc', $dscpath);
1974 push_parse_dsc($dscpath, $dscfn, $cversion);
1976 my $format = getfield $dsc, 'Format';
1977 printdebug "format $format\n";
1978 if (madformat($format)) {
1979 commit_quilty_patch();
1983 progress "checking that $dscfn corresponds to HEAD";
1984 runcmd qw(dpkg-source -x --),
1985 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1986 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1987 check_for_vendor_patches() if madformat($dsc->{format});
1988 changedir '../../../..';
1989 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1990 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1991 debugcmd "+",@diffcmd;
1993 my $r = system @diffcmd;
1996 fail "$dscfn specifies a different tree to your HEAD commit;".
1997 " perhaps you forgot to build".
1998 ($diffopt eq '--exit-code' ? "" :
1999 " (run with -D to see full diff output)");
2004 my $head = git_rev_parse('HEAD');
2005 if (!$changesfile) {
2006 my $multi = "$buildproductsdir/".changespat $cversion,'multi';
2007 if (stat_exists "$multi") {
2008 $changesfile = $multi;
2010 my $pat = changespat $cversion;
2011 my @cs = glob "$buildproductsdir/$pat";
2012 fail "failed to find unique changes file".
2013 " (looked for $pat in $buildproductsdir, or $multi);".
2014 " perhaps you need to use dgit -C"
2016 ($changesfile) = @cs;
2019 $changesfile = "$buildproductsdir/$changesfile";
2022 responder_send_file('changes',$changesfile);
2023 responder_send_command("param head $head");
2024 responder_send_command("param csuite $csuite");
2026 if (deliberately_not_fast_forward) {
2027 git_for_each_ref(lrfetchrefs, sub {
2028 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2029 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2030 responder_send_command("previously $rrefname=$objid");
2031 $previously{$rrefname} = $objid;
2035 my $tfn = sub { ".git/dgit/tag$_[0]"; };
2038 supplementary_message(<<'END');
2039 Push failed, while signing the tag.
2040 You can retry the push, after fixing the problem, if you like.
2042 # If we manage to sign but fail to record it anywhere, it's fine.
2043 if ($we_are_responder) {
2044 $tagobjfn = $tfn->('.signed.tmp');
2045 responder_receive_files('signed-tag', $tagobjfn);
2048 push_mktag($head,$clogp,$tag,
2050 $changesfile,$changesfile,
2053 supplementary_message(<<'END');
2054 Push failed, *after* signing the tag.
2055 If you want to try again, you should use a new version number.
2058 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2059 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2060 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2062 supplementary_message(<<'END');
2063 Push failed, while updating the remote git repository - see messages above.
2064 If you want to try again, you should use a new version number.
2066 if (!check_for_git()) {
2067 create_remote_git_repo();
2069 runcmd_ordryrun @git, qw(push),access_giturl(),
2070 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2071 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2073 supplementary_message(<<'END');
2074 Push failed, after updating the remote git repository.
2075 If you want to try again, you must use a new version number.
2077 if ($we_are_responder) {
2078 my $dryrunsuffix = act_local() ? "" : ".tmp";
2079 responder_receive_files('signed-dsc-changes',
2080 "$dscpath$dryrunsuffix",
2081 "$changesfile$dryrunsuffix");
2084 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2086 progress "[new .dsc left in $dscpath.tmp]";
2088 sign_changes $changesfile;
2091 supplementary_message(<<END);
2092 Push failed, while uploading package(s) to the archive server.
2093 You can retry the upload of exactly these same files with dput of:
2095 If that .changes file is broken, you will need to use a new version
2096 number for your next attempt at the upload.
2098 my $host = access_cfg('upload-host','RETURN-UNDEF');
2099 my @hostarg = defined($host) ? ($host,) : ();
2100 runcmd_ordryrun @dput, @hostarg, $changesfile;
2101 printdone "pushed and uploaded $cversion";
2103 supplementary_message('');
2104 responder_send_command("complete");
2111 badusage "-p is not allowed with clone; specify as argument instead"
2112 if defined $package;
2115 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2116 ($package,$isuite) = @ARGV;
2117 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2118 ($package,$dstdir) = @ARGV;
2119 } elsif (@ARGV==3) {
2120 ($package,$isuite,$dstdir) = @ARGV;
2122 badusage "incorrect arguments to dgit clone";
2124 $dstdir ||= "$package";
2126 if (stat_exists $dstdir) {
2127 fail "$dstdir already exists";
2131 if ($rmonerror && !$dryrun_level) {
2132 $cwd_remove= getcwd();
2134 return unless defined $cwd_remove;
2135 if (!chdir "$cwd_remove") {
2136 return if $!==&ENOENT;
2137 die "chdir $cwd_remove: $!";
2140 rmtree($dstdir) or die "remove $dstdir: $!\n";
2141 } elsif (!grep { $! == $_ }
2142 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2144 print STDERR "check whether to remove $dstdir: $!\n";
2150 $cwd_remove = undef;
2153 sub branchsuite () {
2154 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2155 if ($branch =~ m#$lbranch_re#o) {
2162 sub fetchpullargs () {
2164 if (!defined $package) {
2165 my $sourcep = parsecontrol('debian/control','debian/control');
2166 $package = getfield $sourcep, 'Source';
2169 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2171 my $clogp = parsechangelog();
2172 $isuite = getfield $clogp, 'Distribution';
2174 canonicalise_suite();
2175 progress "fetching from suite $csuite";
2176 } elsif (@ARGV==1) {
2178 canonicalise_suite();
2180 badusage "incorrect arguments to dgit fetch or dgit pull";
2199 badusage "-p is not allowed with dgit push" if defined $package;
2201 my $clogp = parsechangelog();
2202 $package = getfield $clogp, 'Source';
2205 } elsif (@ARGV==1) {
2206 ($specsuite) = (@ARGV);
2208 badusage "incorrect arguments to dgit push";
2210 $isuite = getfield $clogp, 'Distribution';
2212 local ($package) = $existing_package; # this is a hack
2213 canonicalise_suite();
2215 canonicalise_suite();
2217 if (defined $specsuite &&
2218 $specsuite ne $isuite &&
2219 $specsuite ne $csuite) {
2220 fail "dgit push: changelog specifies $isuite ($csuite)".
2221 " but command line specifies $specsuite";
2223 supplementary_message(<<'END');
2224 Push failed, while checking state of the archive.
2225 You can retry the push, after fixing the problem, if you like.
2227 if (check_for_git()) {
2231 if (fetch_from_archive()) {
2232 if (is_fast_fwd(lrref(), 'HEAD')) {
2234 } elsif (deliberately_not_fast_forward) {
2237 fail "dgit push: HEAD is not a descendant".
2238 " of the archive's version.\n".
2239 "dgit: To overwrite its contents,".
2240 " use git merge -s ours ".lrref().".\n".
2241 "dgit: To rewind history, if permitted by the archive,".
2242 " use --deliberately-not-fast-forward";
2246 fail "package appears to be new in this suite;".
2247 " if this is intentional, use --new";
2252 #---------- remote commands' implementation ----------
2254 sub cmd_remote_push_build_host {
2255 my ($nrargs) = shift @ARGV;
2256 my (@rargs) = @ARGV[0..$nrargs-1];
2257 @ARGV = @ARGV[$nrargs..$#ARGV];
2259 my ($dir,$vsnwant) = @rargs;
2260 # vsnwant is a comma-separated list; we report which we have
2261 # chosen in our ready response (so other end can tell if they
2264 $we_are_responder = 1;
2265 $us .= " (build host)";
2269 open PI, "<&STDIN" or die $!;
2270 open STDIN, "/dev/null" or die $!;
2271 open PO, ">&STDOUT" or die $!;
2273 open STDOUT, ">&STDERR" or die $!;
2277 ($protovsn) = grep {
2278 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2279 } @rpushprotovsn_support;
2281 fail "build host has dgit rpush protocol versions ".
2282 (join ",", @rpushprotovsn_support).
2283 " but invocation host has $vsnwant"
2284 unless defined $protovsn;
2286 responder_send_command("dgit-remote-push-ready $protovsn");
2292 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2293 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2294 # a good error message)
2300 my $report = i_child_report();
2301 if (defined $report) {
2302 printdebug "($report)\n";
2303 } elsif ($i_child_pid) {
2304 printdebug "(killing build host child $i_child_pid)\n";
2305 kill 15, $i_child_pid;
2307 if (defined $i_tmp && !defined $initiator_tempdir) {
2309 eval { rmtree $i_tmp; };
2313 END { i_cleanup(); }
2316 my ($base,$selector,@args) = @_;
2317 $selector =~ s/\-/_/g;
2318 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2325 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2333 push @rargs, join ",", @rpushprotovsn_support;
2336 push @rdgit, @ropts;
2337 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2339 my @cmd = (@ssh, $host, shellquote @rdgit);
2342 if (defined $initiator_tempdir) {
2343 rmtree $initiator_tempdir;
2344 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2345 $i_tmp = $initiator_tempdir;
2349 $i_child_pid = open2(\*RO, \*RI, @cmd);
2351 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2352 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2353 $supplementary_message = '' unless $protovsn >= 3;
2355 my ($icmd,$iargs) = initiator_expect {
2356 m/^(\S+)(?: (.*))?$/;
2359 i_method "i_resp", $icmd, $iargs;
2363 sub i_resp_progress ($) {
2365 my $msg = protocol_read_bytes \*RO, $rhs;
2369 sub i_resp_supplementary_message ($) {
2371 $supplementary_message = protocol_read_bytes \*RO, $rhs;
2374 sub i_resp_complete {
2375 my $pid = $i_child_pid;
2376 $i_child_pid = undef; # prevents killing some other process with same pid
2377 printdebug "waiting for build host child $pid...\n";
2378 my $got = waitpid $pid, 0;
2379 die $! unless $got == $pid;
2380 die "build host child failed $?" if $?;
2383 printdebug "all done\n";
2387 sub i_resp_file ($) {
2389 my $localname = i_method "i_localname", $keyword;
2390 my $localpath = "$i_tmp/$localname";
2391 stat_exists $localpath and
2392 badproto \*RO, "file $keyword ($localpath) twice";
2393 protocol_receive_file \*RO, $localpath;
2394 i_method "i_file", $keyword;
2399 sub i_resp_param ($) {
2400 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2404 sub i_resp_previously ($) {
2405 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2406 or badproto \*RO, "bad previously spec";
2407 my $r = system qw(git check-ref-format), $1;
2408 die "bad previously ref spec ($r)" if $r;
2409 $previously{$1} = $2;
2414 sub i_resp_want ($) {
2416 die "$keyword ?" if $i_wanted{$keyword}++;
2417 my @localpaths = i_method "i_want", $keyword;
2418 printdebug "[[ $keyword @localpaths\n";
2419 foreach my $localpath (@localpaths) {
2420 protocol_send_file \*RI, $localpath;
2422 print RI "files-end\n" or die $!;
2425 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2427 sub i_localname_parsed_changelog {
2428 return "remote-changelog.822";
2430 sub i_file_parsed_changelog {
2431 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2432 push_parse_changelog "$i_tmp/remote-changelog.822";
2433 die if $i_dscfn =~ m#/|^\W#;
2436 sub i_localname_dsc {
2437 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2442 sub i_localname_changes {
2443 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2444 $i_changesfn = $i_dscfn;
2445 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2446 return $i_changesfn;
2448 sub i_file_changes { }
2450 sub i_want_signed_tag {
2451 printdebug Dumper(\%i_param, $i_dscfn);
2452 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2453 && defined $i_param{'csuite'}
2454 or badproto \*RO, "premature desire for signed-tag";
2455 my $head = $i_param{'head'};
2456 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2458 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2460 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2463 push_mktag $head, $i_clogp, $i_tag,
2465 $i_changesfn, 'remote changes',
2466 sub { "tag$_[0]"; };
2471 sub i_want_signed_dsc_changes {
2472 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2473 sign_changes $i_changesfn;
2474 return ($i_dscfn, $i_changesfn);
2477 #---------- building etc. ----------
2483 #----- `3.0 (quilt)' handling -----
2485 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2487 sub quiltify_dpkg_commit ($$$;$) {
2488 my ($patchname,$author,$msg, $xinfo) = @_;
2492 my $descfn = ".git/dgit/quilt-description.tmp";
2493 open O, '>', $descfn or die "$descfn: $!";
2496 $msg =~ s/^\s+$/ ./mg;
2497 print O <<END or die $!;
2507 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2508 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2509 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2510 runcmd @dpkgsource, qw(--commit .), $patchname;
2514 sub quiltify_trees_differ ($$) {
2516 # returns 1 iff the two tree objects differ other than in debian/
2518 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2519 my $diffs= cmdoutput @cmd;
2520 foreach my $f (split /\0/, $diffs) {
2521 next if $f eq 'debian';
2527 sub quiltify_tree_sentinelfiles ($) {
2528 # lists the `sentinel' files present in the tree
2530 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2531 qw(-- debian/rules debian/control);
2537 my ($clogp,$target) = @_;
2539 # Quilt patchification algorithm
2541 # We search backwards through the history of the main tree's HEAD
2542 # (T) looking for a start commit S whose tree object is identical
2543 # to to the patch tip tree (ie the tree corresponding to the
2544 # current dpkg-committed patch series). For these purposes
2545 # `identical' disregards anything in debian/ - this wrinkle is
2546 # necessary because dpkg-source treates debian/ specially.
2548 # We can only traverse edges where at most one of the ancestors'
2549 # trees differs (in changes outside in debian/). And we cannot
2550 # handle edges which change .pc/ or debian/patches. To avoid
2551 # going down a rathole we avoid traversing edges which introduce
2552 # debian/rules or debian/control. And we set a limit on the
2553 # number of edges we are willing to look at.
2555 # If we succeed, we walk forwards again. For each traversed edge
2556 # PC (with P parent, C child) (starting with P=S and ending with
2557 # C=T) to we do this:
2559 # - dpkg-source --commit with a patch name and message derived from C
2560 # After traversing PT, we git commit the changes which
2561 # should be contained within debian/patches.
2563 changedir '../fake';
2564 remove_stray_gits();
2565 mktree_in_ud_here();
2567 runcmd @git, qw(add -Af .);
2568 my $oldtiptree=git_write_tree();
2569 changedir '../work';
2571 # The search for the path S..T is breadth-first. We maintain a
2572 # todo list containing search nodes. A search node identifies a
2573 # commit, and looks something like this:
2575 # Commit => $git_commit_id,
2576 # Child => $c, # or undef if P=T
2577 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2578 # Nontrivial => true iff $p..$c has relevant changes
2585 my %considered; # saves being exponential on some weird graphs
2587 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2590 my ($search,$whynot) = @_;
2591 printdebug " search NOT $search->{Commit} $whynot\n";
2592 $search->{Whynot} = $whynot;
2593 push @nots, $search;
2594 no warnings qw(exiting);
2603 my $c = shift @todo;
2604 next if $considered{$c->{Commit}}++;
2606 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2608 printdebug "quiltify investigate $c->{Commit}\n";
2611 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2612 printdebug " search finished hooray!\n";
2617 if ($quilt_mode eq 'nofix') {
2618 fail "quilt fixup required but quilt mode is \`nofix'\n".
2619 "HEAD commit $c->{Commit} differs from tree implied by ".
2620 " debian/patches (tree object $oldtiptree)";
2622 if ($quilt_mode eq 'smash') {
2623 printdebug " search quitting smash\n";
2627 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2628 $not->($c, "has $c_sentinels not $t_sentinels")
2629 if $c_sentinels ne $t_sentinels;
2631 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2632 $commitdata =~ m/\n\n/;
2634 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2635 @parents = map { { Commit => $_, Child => $c } } @parents;
2637 $not->($c, "root commit") if !@parents;
2639 foreach my $p (@parents) {
2640 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2642 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2643 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2645 foreach my $p (@parents) {
2646 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2648 my @cmd= (@git, qw(diff-tree -r --name-only),
2649 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2650 my $patchstackchange = cmdoutput @cmd;
2651 if (length $patchstackchange) {
2652 $patchstackchange =~ s/\n/,/g;
2653 $not->($p, "changed $patchstackchange");
2656 printdebug " search queue P=$p->{Commit} ",
2657 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2663 printdebug "quiltify want to smash\n";
2666 my $x = $_[0]{Commit};
2667 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2670 my $reportnot = sub {
2672 my $s = $abbrev->($notp);
2673 my $c = $notp->{Child};
2674 $s .= "..".$abbrev->($c) if $c;
2675 $s .= ": ".$notp->{Whynot};
2678 if ($quilt_mode eq 'linear') {
2679 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2680 foreach my $notp (@nots) {
2681 print STDERR "$us: ", $reportnot->($notp), "\n";
2683 fail "quilt fixup naive history linearisation failed.\n".
2684 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2685 } elsif ($quilt_mode eq 'smash') {
2686 } elsif ($quilt_mode eq 'auto') {
2687 progress "quilt fixup cannot be linear, smashing...";
2689 die "$quilt_mode ?";
2694 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2696 quiltify_dpkg_commit "auto-$version-$target-$time",
2697 (getfield $clogp, 'Maintainer'),
2698 "Automatically generated patch ($clogp->{Version})\n".
2699 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2703 progress "quiltify linearisation planning successful, executing...";
2705 for (my $p = $sref_S;
2706 my $c = $p->{Child};
2708 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2709 next unless $p->{Nontrivial};
2711 my $cc = $c->{Commit};
2713 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2714 $commitdata =~ m/\n\n/ or die "$c ?";
2717 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2720 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2723 my $patchname = $title;
2724 $patchname =~ s/[.:]$//;
2725 $patchname =~ y/ A-Z/-a-z/;
2726 $patchname =~ y/-a-z0-9_.+=~//cd;
2727 $patchname =~ s/^\W/x-$&/;
2728 $patchname = substr($patchname,0,40);
2731 stat "debian/patches/$patchname$index";
2733 $!==ENOENT or die "$patchname$index $!";
2735 runcmd @git, qw(checkout -q), $cc;
2737 # We use the tip's changelog so that dpkg-source doesn't
2738 # produce complaining messages from dpkg-parsechangelog. None
2739 # of the information dpkg-source gets from the changelog is
2740 # actually relevant - it gets put into the original message
2741 # which dpkg-source provides our stunt editor, and then
2743 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2745 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2746 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2748 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2751 runcmd @git, qw(checkout -q master);
2754 sub build_maybe_quilt_fixup () {
2755 my ($format,$fopts) = get_source_format;
2756 return unless madformat $format;
2759 check_for_vendor_patches();
2761 my $clogp = parsechangelog();
2762 my $headref = git_rev_parse('HEAD');
2767 my $upstreamversion=$version;
2768 $upstreamversion =~ s/-[^-]*$//;
2770 if ($fopts->{'single-debian-patch'}) {
2771 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2773 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2776 changedir '../../../..';
2777 runcmd_ordryrun_local
2778 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2781 sub quilt_fixup_mkwork ($) {
2784 mkdir "work" or die $!;
2786 mktree_in_ud_here();
2787 runcmd @git, qw(reset --hard), $headref;
2790 sub quilt_fixup_linkorigs ($$) {
2791 my ($upstreamversion, $fn) = @_;
2792 # calls $fn->($leafname);
2794 foreach my $f (<../../../../*>) { #/){
2795 my $b=$f; $b =~ s{.*/}{};
2797 local ($debuglevel) = $debuglevel-1;
2798 printdebug "QF linkorigs $b, $f ?\n";
2800 next unless is_orig_file $b, srcfn $upstreamversion,'';
2801 printdebug "QF linkorigs $b, $f Y\n";
2802 link_ltarget $f, $b or die "$b $!";
2807 sub quilt_fixup_delete_pc () {
2808 runcmd @git, qw(rm -rqf .pc);
2809 commit_admin "Commit removal of .pc (quilt series tracking data)";
2812 sub quilt_fixup_singlepatch ($$$) {
2813 my ($clogp, $headref, $upstreamversion) = @_;
2815 progress "starting quiltify (single-debian-patch)";
2817 # dpkg-source --commit generates new patches even if
2818 # single-debian-patch is in debian/source/options. In order to
2819 # get it to generate debian/patches/debian-changes, it is
2820 # necessary to build the source package.
2822 quilt_fixup_linkorigs($upstreamversion, sub { });
2823 quilt_fixup_mkwork($headref);
2825 rmtree("debian/patches");
2827 runcmd @dpkgsource, qw(-b .);
2829 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2830 rename srcfn("$upstreamversion", "/debian/patches"),
2831 "work/debian/patches";
2834 commit_quilty_patch();
2839 sub quilt_fixup_multipatch ($$$) {
2840 my ($clogp, $headref, $upstreamversion) = @_;
2842 progress "starting quiltify (multiple patches, $quilt_mode mode)";
2845 # - honour any existing .pc in case it has any strangeness
2846 # - determine the git commit corresponding to the tip of
2847 # the patch stack (if there is one)
2848 # - if there is such a git commit, convert each subsequent
2849 # git commit into a quilt patch with dpkg-source --commit
2850 # - otherwise convert all the differences in the tree into
2851 # a single git commit
2855 # Our git tree doesn't necessarily contain .pc. (Some versions of
2856 # dgit would include the .pc in the git tree.) If there isn't
2857 # one, we need to generate one by unpacking the patches that we
2860 # We first look for a .pc in the git tree. If there is one, we
2861 # will use it. (This is not the normal case.)
2863 # Otherwise need to regenerate .pc so that dpkg-source --commit
2864 # can work. We do this as follows:
2865 # 1. Collect all relevant .orig from parent directory
2866 # 2. Generate a debian.tar.gz out of
2867 # debian/{patches,rules,source/format,source/options}
2868 # 3. Generate a fake .dsc containing just these fields:
2869 # Format Source Version Files
2870 # 4. Extract the fake .dsc
2871 # Now the fake .dsc has a .pc directory.
2872 # (In fact we do this in every case, because in future we will
2873 # want to search for a good base commit for generating patches.)
2875 # Then we can actually do the dpkg-source --commit
2876 # 1. Make a new working tree with the same object
2877 # store as our main tree and check out the main
2879 # 2. Copy .pc from the fake's extraction, if necessary
2880 # 3. Run dpkg-source --commit
2881 # 4. If the result has changes to debian/, then
2882 # - git-add them them
2883 # - git-add .pc if we had a .pc in-tree
2885 # 5. If we had a .pc in-tree, delete it, and git-commit
2886 # 6. Back in the main tree, fast forward to the new HEAD
2888 my $fakeversion="$upstreamversion-~~DGITFAKE";
2890 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2891 print $fakedsc <<END or die $!;
2894 Version: $fakeversion
2898 my $dscaddfile=sub {
2901 my $md = new Digest::MD5;
2903 my $fh = new IO::File $b, '<' or die "$b $!";
2908 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2911 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2913 my @files=qw(debian/source/format debian/rules);
2914 foreach my $maybe (qw(debian/patches debian/source/options)) {
2915 next unless stat_exists "../../../$maybe";
2916 push @files, $maybe;
2919 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2920 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2922 $dscaddfile->($debtar);
2923 close $fakedsc or die $!;
2925 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2927 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2928 rename $fakexdir, "fake" or die "$fakexdir $!";
2930 quilt_fixup_mkwork($headref);
2933 if (stat_exists ".pc") {
2935 progress "Tree already contains .pc - will use it then delete it.";
2938 rename '../fake/.pc','.pc' or die $!;
2941 quiltify($clogp,$headref);
2943 if (!open P, '>>', ".pc/applied-patches") {
2944 $!==&ENOENT or die $!;
2949 commit_quilty_patch();
2951 if ($mustdeletepc) {
2952 quilt_fixup_delete_pc();
2956 sub quilt_fixup_editor () {
2957 my $descfn = $ENV{$fakeeditorenv};
2958 my $editing = $ARGV[$#ARGV];
2959 open I1, '<', $descfn or die "$descfn: $!";
2960 open I2, '<', $editing or die "$editing: $!";
2961 unlink $editing or die "$editing: $!";
2962 open O, '>', $editing or die "$editing: $!";
2963 while (<I1>) { print O or die $!; } I1->error and die $!;
2966 $copying ||= m/^\-\-\- /;
2967 next unless $copying;
2970 I2->error and die $!;
2975 #----- other building -----
2977 our $suppress_clean;
2980 return if $suppress_clean;
2981 if ($cleanmode eq 'dpkg-source') {
2982 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2983 } elsif ($cleanmode eq 'dpkg-source-d') {
2984 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2985 } elsif ($cleanmode eq 'git') {
2986 runcmd_ordryrun_local @git, qw(clean -xdf);
2987 } elsif ($cleanmode eq 'git-ff') {
2988 runcmd_ordryrun_local @git, qw(clean -xdff);
2989 } elsif ($cleanmode eq 'check') {
2990 my $leftovers = cmdoutput @git, qw(clean -xdn);
2991 if (length $leftovers) {
2992 print STDERR $leftovers, "\n" or die $!;
2993 fail "tree contains uncommitted files and --clean=check specified";
2995 } elsif ($cleanmode eq 'none') {
3002 badusage "clean takes no additional arguments" if @ARGV;
3009 badusage "-p is not allowed when building" if defined $package;
3012 my $clogp = parsechangelog();
3013 $isuite = getfield $clogp, 'Distribution';
3014 $package = getfield $clogp, 'Source';
3015 $version = getfield $clogp, 'Version';
3016 build_maybe_quilt_fixup();
3018 my $pat = changespat $version;
3019 foreach my $f (glob "$buildproductsdir/$pat") {
3021 unlink $f or fail "remove old changes file $f: $!";
3023 progress "would remove $f";
3029 sub changesopts_initial () {
3030 my @opts =@changesopts[1..$#changesopts];
3033 sub changesopts_version () {
3034 if (!defined $changes_since_version) {
3035 my @vsns = archive_query('archive_query');
3036 my @quirk = access_quirk();
3037 if ($quirk[0] eq 'backports') {
3038 local $isuite = $quirk[2];
3040 canonicalise_suite();
3041 push @vsns, archive_query('archive_query');
3044 @vsns = map { $_->[0] } @vsns;
3045 @vsns = sort { -version_compare($a, $b) } @vsns;
3046 $changes_since_version = $vsns[0];
3047 progress "changelog will contain changes since $vsns[0]";
3049 $changes_since_version = '_';
3050 progress "package seems new, not specifying -v<version>";
3053 if ($changes_since_version ne '_') {
3054 return ("-v$changes_since_version");
3060 sub changesopts () {
3061 return (changesopts_initial(), changesopts_version());
3064 sub massage_dbp_args ($;$) {
3065 my ($cmd,$xargs) = @_;
3066 if ($cleanmode eq 'dpkg-source') {
3067 $suppress_clean = 1;
3070 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3071 my @newcmd = shift @$cmd;
3072 # -nc has the side effect of specifying -b if nothing else specified
3073 push @newcmd, '-nc';
3074 # and some combinations of -S, -b, et al, are errors, rather than
3075 # later simply overriding earlier
3076 push @newcmd, '-F' unless grep { m/^-[bBASFgG]$/ } (@$cmd, @$xargs);
3077 push @newcmd, @$cmd;
3082 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3083 massage_dbp_args \@dbp;
3085 push @dbp, changesopts_version();
3086 runcmd_ordryrun_local @dbp;
3087 printdone "build successful\n";
3091 my @dbp = @dpkgbuildpackage;
3092 massage_dbp_args \@dbp, \@ARGV;
3095 if (length executable_on_path('git-buildpackage')) {
3096 @cmd = qw(git-buildpackage);
3098 @cmd = qw(gbp buildpackage);
3100 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3102 if ($cleanmode eq 'dpkg-source') {
3103 $suppress_clean = 1;
3105 push @cmd, '--git-cleaner=true';
3108 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3109 canonicalise_suite();
3110 push @cmd, "--git-debian-branch=".lbranch();
3112 push @cmd, changesopts();
3113 runcmd_ordryrun_local @cmd, @ARGV;
3114 printdone "build successful\n";
3116 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3119 if ($cleanmode =~ m/^dpkg-source/) {
3120 # dpkg-source will clean, so we shouldn't
3121 $suppress_clean = 1;
3124 $sourcechanges = changespat $version,'source';
3125 $dscfn = dscfn($version);
3126 if ($cleanmode eq 'dpkg-source') {
3127 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3129 } elsif ($cleanmode eq 'dpkg-source-d') {
3130 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3133 my $pwd = must_getcwd();
3134 my $leafdir = basename $pwd;
3136 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
3138 runcmd_ordryrun_local qw(sh -ec),
3139 'exec >$1; shift; exec "$@"','x',
3140 "../$sourcechanges",
3141 @dpkggenchanges, qw(-S), changesopts();
3145 sub cmd_build_source {
3146 badusage "build-source takes no additional arguments" if @ARGV;
3148 printdone "source built, results in $dscfn and $sourcechanges";
3154 my $pat = changespat $version;
3156 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3157 stat_exists $sourcechanges
3158 or fail "$sourcechanges (in parent directory): $!";
3159 foreach my $cf (glob $pat) {
3160 next if $cf eq $sourcechanges;
3161 unlink $cf or fail "remove $cf: $!";
3164 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3165 my @changesfiles = glob $pat;
3166 @changesfiles = sort {
3167 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3170 fail "wrong number of different changes files (@changesfiles)"
3171 unless @changesfiles==2;
3172 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3173 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3174 fail "$l found in binaries changes file $binchanges"
3177 runcmd_ordryrun_local @mergechanges, @changesfiles;
3178 my $multichanges = changespat $version,'multi';
3180 stat_exists $multichanges or fail "$multichanges: $!";
3181 foreach my $cf (glob $pat) {
3182 next if $cf eq $multichanges;
3183 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3186 printdone "build successful, results in $multichanges\n" or die $!;
3189 sub cmd_quilt_fixup {
3190 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3191 my $clogp = parsechangelog();
3192 $version = getfield $clogp, 'Version';
3193 $package = getfield $clogp, 'Source';
3196 build_maybe_quilt_fixup();
3199 sub cmd_archive_api_query {
3200 badusage "need only 1 subpath argument" unless @ARGV==1;
3201 my ($subpath) = @ARGV;
3202 my @cmd = archive_api_query_cmd($subpath);
3204 exec @cmd or fail "exec curl: $!\n";
3207 sub cmd_clone_dgit_repos_server {
3208 badusage "need destination argument" unless @ARGV==1;
3209 my ($destdir) = @ARGV;
3210 $package = '_dgit-repos-server';
3211 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3213 exec @cmd or fail "exec git clone: $!\n";
3216 sub cmd_setup_mergechangelogs {
3217 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3218 setup_mergechangelogs(1);
3221 sub cmd_setup_useremail {
3222 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3226 sub cmd_setup_new_tree {
3227 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3231 #---------- argument parsing and main program ----------
3234 print "dgit version $our_version\n" or die $!;
3238 our (%valopts_long, %valopts_short);
3241 sub defvalopt ($$$$) {
3242 my ($long,$short,$val_re,$how) = @_;
3243 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3244 $valopts_long{$long} = $oi;
3245 $valopts_short{$short} = $oi;
3246 # $how subref should:
3247 # do whatever assignemnt or thing it likes with $_[0]
3248 # if the option should not be passed on to remote, @rvalopts=()
3249 # or $how can be a scalar ref, meaning simply assign the value
3252 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3253 defvalopt '--distro', '-d', '.+', \$idistro;
3254 defvalopt '', '-k', '.+', \$keyid;
3255 defvalopt '--existing-package','', '.*', \$existing_package;
3256 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3257 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3258 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3260 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3262 defvalopt '', '-C', '.+', sub {
3263 ($changesfile) = (@_);
3264 if ($changesfile =~ s#^(.*)/##) {
3265 $buildproductsdir = $1;
3269 defvalopt '--initiator-tempdir','','.*', sub {
3270 ($initiator_tempdir) = (@_);
3271 $initiator_tempdir =~ m#^/# or
3272 badusage "--initiator-tempdir must be used specify an".
3273 " absolute, not relative, directory."
3279 if (defined $ENV{'DGIT_SSH'}) {
3280 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3281 } elsif (defined $ENV{'GIT_SSH'}) {
3282 @ssh = ($ENV{'GIT_SSH'});
3290 if (!defined $val) {
3291 badusage "$what needs a value" unless @ARGV;
3293 push @rvalopts, $val;
3295 badusage "bad value \`$val' for $what" unless
3296 $val =~ m/^$oi->{Re}$(?!\n)/s;
3297 my $how = $oi->{How};
3298 if (ref($how) eq 'SCALAR') {
3303 push @ropts, @rvalopts;
3307 last unless $ARGV[0] =~ m/^-/;
3311 if (m/^--dry-run$/) {
3314 } elsif (m/^--damp-run$/) {
3317 } elsif (m/^--no-sign$/) {
3320 } elsif (m/^--help$/) {
3322 } elsif (m/^--version$/) {
3324 } elsif (m/^--new$/) {
3327 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3328 ($om = $opts_opt_map{$1}) &&
3332 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3333 !$opts_opt_cmdonly{$1} &&
3334 ($om = $opts_opt_map{$1})) {
3337 } elsif (m/^--ignore-dirty$/s) {
3340 } elsif (m/^--no-quilt-fixup$/s) {
3342 $quilt_mode = 'nocheck';
3343 } elsif (m/^--no-rm-on-error$/s) {
3346 } elsif (m/^--(no-)?rm-old-changes$/s) {
3349 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3351 push @deliberatelies, $&;
3352 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3353 $val = $2 ? $' : undef; #';
3354 $valopt->($oi->{Long});
3356 badusage "unknown long option \`$_'";
3363 } elsif (s/^-L/-/) {
3366 } elsif (s/^-h/-/) {
3368 } elsif (s/^-D/-/) {
3372 } elsif (s/^-N/-/) {
3377 push @changesopts, $_;
3379 } elsif (s/^-wn$//s) {
3381 $cleanmode = 'none';
3382 } elsif (s/^-wg$//s) {
3385 } elsif (s/^-wgf$//s) {
3387 $cleanmode = 'git-ff';
3388 } elsif (s/^-wd$//s) {
3390 $cleanmode = 'dpkg-source';
3391 } elsif (s/^-wdd$//s) {
3393 $cleanmode = 'dpkg-source-d';
3394 } elsif (s/^-wc$//s) {
3396 $cleanmode = 'check';
3397 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3399 $val = undef unless length $val;
3400 $valopt->($oi->{Short});
3403 badusage "unknown short option \`$_'";
3410 sub finalise_opts_opts () {
3411 foreach my $k (keys %opts_opt_map) {
3412 my $om = $opts_opt_map{$k};
3414 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3416 badcfg "cannot set command for $k"
3417 unless length $om->[0];
3421 foreach my $c (access_cfg_cfgs("opts-$k")) {
3422 my $vl = $gitcfg{$c};
3423 printdebug "CL $c ",
3424 ($vl ? join " ", map { shellquote } @$vl : ""),
3425 "\n" if $debuglevel >= 4;
3427 badcfg "cannot configure options for $k"
3428 if $opts_opt_cmdonly{$k};
3429 my $insertpos = $opts_cfg_insertpos{$k};
3430 @$om = ( @$om[0..$insertpos-1],
3432 @$om[$insertpos..$#$om] );
3437 if ($ENV{$fakeeditorenv}) {
3439 quilt_fixup_editor();
3445 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3446 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3447 if $dryrun_level == 1;
3449 print STDERR $helpmsg or die $!;
3452 my $cmd = shift @ARGV;
3455 if (!defined $rmchanges) {
3456 local $access_forpush;
3457 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3460 if (!defined $quilt_mode) {
3461 local $access_forpush;
3462 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3463 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3465 $quilt_mode =~ m/^($quilt_modes_re)$/
3466 or badcfg "unknown quilt-mode \`$quilt_mode'";
3470 if (!defined $cleanmode) {
3471 local $access_forpush;
3472 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3473 $cleanmode //= 'dpkg-source';
3475 badcfg "unknown clean-mode \`$cleanmode'" unless
3476 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3479 my $fn = ${*::}{"cmd_$cmd"};
3480 $fn or badusage "unknown operation $cmd";