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 $pat = changespat $cversion;
2007 my @cs = glob "$buildproductsdir/$pat";
2008 fail "failed to find unique changes file".
2009 " (looked for $pat in $buildproductsdir);".
2010 " perhaps you need to use dgit -C"
2012 ($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 -q --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();
3013 my $pat = changespat $version;
3014 foreach my $f (glob "$buildproductsdir/$pat") {
3016 unlink $f or fail "remove old changes file $f: $!";
3018 progress "would remove $f";
3024 sub changesopts_initial () {
3025 my @opts =@changesopts[1..$#changesopts];
3028 sub changesopts_version () {
3029 if (!defined $changes_since_version) {
3030 my @vsns = archive_query('archive_query');
3031 my @quirk = access_quirk();
3032 if ($quirk[0] eq 'backports') {
3033 local $isuite = $quirk[2];
3035 canonicalise_suite();
3036 push @vsns, archive_query('archive_query');
3039 @vsns = map { $_->[0] } @vsns;
3040 @vsns = sort { -version_compare($a, $b) } @vsns;
3041 $changes_since_version = $vsns[0];
3042 progress "changelog will contain changes since $vsns[0]";
3044 $changes_since_version = '_';
3045 progress "package seems new, not specifying -v<version>";
3048 if ($changes_since_version ne '_') {
3049 return ("-v$changes_since_version");
3055 sub changesopts () {
3056 return (changesopts_initial(), changesopts_version());
3059 sub massage_dbp_args ($;$) {
3060 my ($cmd,$xargs) = @_;
3061 if ($cleanmode eq 'dpkg-source') {
3062 $suppress_clean = 1;
3065 debugcmd '#massaging#', @$cmd if $debuglevel>1;
3066 my @newcmd = shift @$cmd;
3067 # -nc has the side effect of specifying -b if nothing else specified
3068 push @newcmd, '-nc';
3069 # and some combinations of -S, -b, et al, are errors, rather than
3070 # later simply overriding earlier
3071 push @newcmd, '-F' unless grep { m/^-[bBASFgG]$/ } (@$cmd, @$xargs);
3072 push @newcmd, @$cmd;
3077 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3078 massage_dbp_args \@dbp;
3080 push @dbp, changesopts_version();
3081 runcmd_ordryrun_local @dbp;
3082 printdone "build successful\n";
3086 my @dbp = @dpkgbuildpackage;
3087 massage_dbp_args \@dbp, \@ARGV;
3090 if (length executable_on_path('git-buildpackage')) {
3091 @cmd = qw(git-buildpackage);
3093 @cmd = qw(gbp buildpackage);
3095 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3097 if ($cleanmode eq 'dpkg-source') {
3098 $suppress_clean = 1;
3100 push @cmd, '--git-cleaner=true';
3103 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3104 canonicalise_suite();
3105 push @cmd, "--git-debian-branch=".lbranch();
3107 push @cmd, changesopts();
3108 runcmd_ordryrun_local @cmd, @ARGV;
3109 printdone "build successful\n";
3111 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3114 if ($cleanmode =~ m/^dpkg-source/) {
3115 # dpkg-source will clean, so we shouldn't
3116 $suppress_clean = 1;
3119 $sourcechanges = changespat $version,'source';
3121 unlink "../$sourcechanges" or $!==ENOENT
3122 or fail "remove $sourcechanges: $!";
3124 $dscfn = dscfn($version);
3125 if ($cleanmode eq 'dpkg-source') {
3126 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3128 } elsif ($cleanmode eq 'dpkg-source-d') {
3129 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3132 my $pwd = must_getcwd();
3133 my $leafdir = basename $pwd;
3135 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
3137 runcmd_ordryrun_local qw(sh -ec),
3138 'exec >$1; shift; exec "$@"','x',
3139 "../$sourcechanges",
3140 @dpkggenchanges, qw(-S), changesopts();
3144 sub cmd_build_source {
3145 badusage "build-source takes no additional arguments" if @ARGV;
3147 printdone "source built, results in $dscfn and $sourcechanges";
3152 my $pat = changespat $version;
3154 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3155 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3156 fail "changes files other than source matching $pat".
3157 " already present (@unwanted);".
3158 " building would result in ambiguity about the intended results"
3163 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3164 stat_exists $sourcechanges
3165 or fail "$sourcechanges (in parent directory): $!";
3167 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3168 my @changesfiles = glob $pat;
3169 @changesfiles = sort {
3170 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3173 fail "wrong number of different changes files (@changesfiles)"
3174 unless @changesfiles==2;
3175 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3176 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3177 fail "$l found in binaries changes file $binchanges"
3180 runcmd_ordryrun_local @mergechanges, @changesfiles;
3181 my $multichanges = changespat $version,'multi';
3183 stat_exists $multichanges or fail "$multichanges: $!";
3184 foreach my $cf (glob $pat) {
3185 next if $cf eq $multichanges;
3186 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3189 printdone "build successful, results in $multichanges\n" or die $!;
3192 sub cmd_quilt_fixup {
3193 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3194 my $clogp = parsechangelog();
3195 $version = getfield $clogp, 'Version';
3196 $package = getfield $clogp, 'Source';
3199 build_maybe_quilt_fixup();
3202 sub cmd_archive_api_query {
3203 badusage "need only 1 subpath argument" unless @ARGV==1;
3204 my ($subpath) = @ARGV;
3205 my @cmd = archive_api_query_cmd($subpath);
3207 exec @cmd or fail "exec curl: $!\n";
3210 sub cmd_clone_dgit_repos_server {
3211 badusage "need destination argument" unless @ARGV==1;
3212 my ($destdir) = @ARGV;
3213 $package = '_dgit-repos-server';
3214 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3216 exec @cmd or fail "exec git clone: $!\n";
3219 sub cmd_setup_mergechangelogs {
3220 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3221 setup_mergechangelogs(1);
3224 sub cmd_setup_useremail {
3225 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3229 sub cmd_setup_new_tree {
3230 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3234 #---------- argument parsing and main program ----------
3237 print "dgit version $our_version\n" or die $!;
3241 our (%valopts_long, %valopts_short);
3244 sub defvalopt ($$$$) {
3245 my ($long,$short,$val_re,$how) = @_;
3246 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3247 $valopts_long{$long} = $oi;
3248 $valopts_short{$short} = $oi;
3249 # $how subref should:
3250 # do whatever assignemnt or thing it likes with $_[0]
3251 # if the option should not be passed on to remote, @rvalopts=()
3252 # or $how can be a scalar ref, meaning simply assign the value
3255 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3256 defvalopt '--distro', '-d', '.+', \$idistro;
3257 defvalopt '', '-k', '.+', \$keyid;
3258 defvalopt '--existing-package','', '.*', \$existing_package;
3259 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
3260 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
3261 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
3263 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3265 defvalopt '', '-C', '.+', sub {
3266 ($changesfile) = (@_);
3267 if ($changesfile =~ s#^(.*)/##) {
3268 $buildproductsdir = $1;
3272 defvalopt '--initiator-tempdir','','.*', sub {
3273 ($initiator_tempdir) = (@_);
3274 $initiator_tempdir =~ m#^/# or
3275 badusage "--initiator-tempdir must be used specify an".
3276 " absolute, not relative, directory."
3282 if (defined $ENV{'DGIT_SSH'}) {
3283 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3284 } elsif (defined $ENV{'GIT_SSH'}) {
3285 @ssh = ($ENV{'GIT_SSH'});
3293 if (!defined $val) {
3294 badusage "$what needs a value" unless @ARGV;
3296 push @rvalopts, $val;
3298 badusage "bad value \`$val' for $what" unless
3299 $val =~ m/^$oi->{Re}$(?!\n)/s;
3300 my $how = $oi->{How};
3301 if (ref($how) eq 'SCALAR') {
3306 push @ropts, @rvalopts;
3310 last unless $ARGV[0] =~ m/^-/;
3314 if (m/^--dry-run$/) {
3317 } elsif (m/^--damp-run$/) {
3320 } elsif (m/^--no-sign$/) {
3323 } elsif (m/^--help$/) {
3325 } elsif (m/^--version$/) {
3327 } elsif (m/^--new$/) {
3330 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3331 ($om = $opts_opt_map{$1}) &&
3335 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3336 !$opts_opt_cmdonly{$1} &&
3337 ($om = $opts_opt_map{$1})) {
3340 } elsif (m/^--ignore-dirty$/s) {
3343 } elsif (m/^--no-quilt-fixup$/s) {
3345 $quilt_mode = 'nocheck';
3346 } elsif (m/^--no-rm-on-error$/s) {
3349 } elsif (m/^--(no-)?rm-old-changes$/s) {
3352 } elsif (m/^--deliberately-($deliberately_re)$/s) {
3354 push @deliberatelies, $&;
3355 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3356 $val = $2 ? $' : undef; #';
3357 $valopt->($oi->{Long});
3359 badusage "unknown long option \`$_'";
3366 } elsif (s/^-L/-/) {
3369 } elsif (s/^-h/-/) {
3371 } elsif (s/^-D/-/) {
3375 } elsif (s/^-N/-/) {
3380 push @changesopts, $_;
3382 } elsif (s/^-wn$//s) {
3384 $cleanmode = 'none';
3385 } elsif (s/^-wg$//s) {
3388 } elsif (s/^-wgf$//s) {
3390 $cleanmode = 'git-ff';
3391 } elsif (s/^-wd$//s) {
3393 $cleanmode = 'dpkg-source';
3394 } elsif (s/^-wdd$//s) {
3396 $cleanmode = 'dpkg-source-d';
3397 } elsif (s/^-wc$//s) {
3399 $cleanmode = 'check';
3400 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3402 $val = undef unless length $val;
3403 $valopt->($oi->{Short});
3406 badusage "unknown short option \`$_'";
3413 sub finalise_opts_opts () {
3414 foreach my $k (keys %opts_opt_map) {
3415 my $om = $opts_opt_map{$k};
3417 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3419 badcfg "cannot set command for $k"
3420 unless length $om->[0];
3424 foreach my $c (access_cfg_cfgs("opts-$k")) {
3425 my $vl = $gitcfg{$c};
3426 printdebug "CL $c ",
3427 ($vl ? join " ", map { shellquote } @$vl : ""),
3428 "\n" if $debuglevel >= 4;
3430 badcfg "cannot configure options for $k"
3431 if $opts_opt_cmdonly{$k};
3432 my $insertpos = $opts_cfg_insertpos{$k};
3433 @$om = ( @$om[0..$insertpos-1],
3435 @$om[$insertpos..$#$om] );
3440 if ($ENV{$fakeeditorenv}) {
3442 quilt_fixup_editor();
3448 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3449 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3450 if $dryrun_level == 1;
3452 print STDERR $helpmsg or die $!;
3455 my $cmd = shift @ARGV;
3458 if (!defined $rmchanges) {
3459 local $access_forpush;
3460 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3463 if (!defined $quilt_mode) {
3464 local $access_forpush;
3465 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3466 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3468 $quilt_mode =~ m/^($quilt_modes_re)$/
3469 or badcfg "unknown quilt-mode \`$quilt_mode'";
3473 if (!defined $cleanmode) {
3474 local $access_forpush;
3475 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3476 $cleanmode //= 'dpkg-source';
3478 badcfg "unknown clean-mode \`$cleanmode'" unless
3479 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3482 my $fn = ${*::}{"cmd_$cmd"};
3483 $fn or badusage "unknown operation $cmd";