# dgit
# Integration between git and Debian-style archives
#
-# Copyright (C)2013-2015 Ian Jackson
+# Copyright (C)2013-2016 Ian Jackson
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
use Debian::Dgit;
our $our_version = 'UNRELEASED'; ###substituted###
+our $absurdity = undef; ###substituted###
our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
our $tagformat;
our $tagformatfn;
+our %forceopts = map { $_=>0 }
+ qw(unrepresentable unsupported-source-format
+ dsc-changes-mismatch
+ import-gitapply-absurd
+ import-gitapply-no-absurd);
+
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
our $suite_re = '[-+.0-9a-z]+';
our (@git) = qw(git);
our (@dget) = qw(dget);
-our (@curl) = qw(curl -f);
+our (@curl) = qw(curl);
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
our $csuite;
our $instead_distro;
+if (!defined $absurdity) {
+ $absurdity = $0;
+ $absurdity =~ s{/[^/]+$}{/absurd} or die;
+}
+
sub debiantag ($$) {
my ($v,$distro) = @_;
return $tagformatfn->($v, $distro);
sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
+sub forceable_fail ($$) {
+ my ($forceoptsl, $msg) = @_;
+ fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
+ print STDERR "warning: overriding problem due to --force:\n". $msg;
+}
+
+sub forceing ($) {
+ my ($forceoptsl) = @_;
+ my @got = grep { $forceopts{$_} } @$forceoptsl;
+ return 0 unless @got;
+ print STDERR
+ "warning: skipping checks or functionality due to --force-$got[0]\n";
+}
+
sub no_such_package () {
print STDERR "$us: package $package does not exist in suite $isuite\n";
exit 4;
'dgit.default.ssh' => 'ssh',
'dgit.default.archive-query' => 'madison:',
'dgit.default.sshpsql-dbname' => 'service=projectb',
- 'dgit.default.dgit-tag-format' => 'old,new,maint',
+ 'dgit.default.dgit-tag-format' => 'new,old,maint',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
# maint means "repo server accepts split brain pushes"
'dgit-distro.debian.git-check' => 'url',
'dgit-distro.debian.git-check-suffix' => '/info/refs',
'dgit-distro.debian.new-private-pushers' => 't',
- 'dgit-distro.debian.dgit-tag-format' => 'new',
'dgit-distro.debian/push.git-url' => '',
'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
'dgit-distro.debian/push.git-user-force' => 'dgit',
'dgit-distro.test-dummy.upload-host' => 'test-dummy',
);
-our %gitcfg;
+our %gitcfgs;
+our @gitcfgsources = qw(cmdline local global system);
sub git_slurp_config () {
local ($debuglevel) = $debuglevel-2;
local $/="\0";
- my @cmd = (@git, qw(config -z --get-regexp .*));
- debugcmd "|",@cmd;
-
- open GITS, "-|", @cmd or die $!;
- while (<GITS>) {
- chomp or die;
- printdebug "=> ", (messagequote $_), "\n";
- m/\n/ or die "$_ ?";
- push @{ $gitcfg{$`} }, $'; #';
+ # This algoritm is a bit subtle, but this is needed so that for
+ # options which we want to be single-valued, we allow the
+ # different config sources to override properly. See #835858.
+ foreach my $src (@gitcfgsources) {
+ next if $src eq 'cmdline';
+ # we do this ourselves since git doesn't handle it
+
+ my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
+ debugcmd "|",@cmd;
+
+ open GITS, "-|", @cmd or die $!;
+ while (<GITS>) {
+ chomp or die;
+ printdebug "=> ", (messagequote $_), "\n";
+ m/\n/ or die "$_ ?";
+ push @{ $gitcfgs{$src}{$`} }, $'; #';
+ }
+ $!=0; $?=0;
+ close GITS
+ or ($!==0 && $?==256)
+ or failedcmd @cmd;
}
- $!=0; $?=0;
- close GITS
- or ($!==0 && $?==256)
- or failedcmd @cmd;
}
sub git_get_config ($) {
my ($c) = @_;
- my $l = $gitcfg{$c};
- printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
- if $debuglevel >= 4;
- $l or return undef;
- @$l==1 or badcfg "multiple values for $c" if @$l > 1;
- return $l->[0];
+ foreach my $src (@gitcfgsources) {
+ my $l = $gitcfgs{$src}{$c};
+ printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
+ if $debuglevel >= 4;
+ $l or next;
+ @$l==1 or badcfg "multiple values for $c".
+ " (in $src git config)" if @$l > 1;
+ return $l->[0];
+ }
+ return undef;
}
sub cfg {
sub archive_api_query_cmd ($) {
my ($subpath) = @_;
- my @cmd = qw(curl -sS);
+ my @cmd = (@curl, qw(-sS));
my $url = access_cfg('archive-query-url');
if ($url =~ m#^https://([-.0-9a-z]+)/#) {
my $host = $1;
badcfg "ftpmasterapi archive query method takes no data part"
if length $data;
my @cmd = archive_api_query_cmd($subpath);
+ my $url = $cmd[$#cmd];
+ push @cmd, qw(-w %{http_code});
my $json = cmdoutput @cmd;
+ unless ($json =~ s/\d+\d+\d$//) {
+ failedcmd_report_cmd undef, @cmd;
+ fail "curl failed to print 3-digit HTTP code";
+ }
+ my $code = $&;
+ fail "fetch of $url gave HTTP code $code"
+ unless $url =~ m#^file://# or $code =~ m/^2/;
return decode_json($json);
}
$dsc = parsecontrolfh($dscfh,$dscurl,1);
printdebug Dumper($dsc) if $debuglevel>1;
my $fmt = getfield $dsc, 'Format';
- fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
+ $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
+ "unsupported source format $fmt, sorry";
+
$dsc_checked = !!$digester;
printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
return;
my $suffix = access_cfg('git-check-suffix','git-suffix',
'RETURN-UNDEF') // '.git';
my $url = "$prefix/$package$suffix";
- my @cmd = (qw(curl -sS -I), $url);
+ my @cmd = (@curl, qw(-sS -I), $url);
my $result = cmdoutput @cmd;
$result =~ s/^\S+ 200 .*\n\r?\n//;
# curl -sS -I with https_proxy prints
return ($tree,$dir);
}
+our @files_csum_info_fields =
+ (['Checksums-Sha256','Digest::SHA', 'new(256)'],
+ ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
+ ['Files', 'Digest::MD5', 'new()']);
+
sub dsc_files_info () {
- foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
- ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
- ['Files', 'Digest::MD5', 'new()']) {
+ foreach my $csumi (@files_csum_info_fields) {
my ($fname, $module, $method) = @$csumi;
my $field = $dsc->{$fname};
next unless defined $field;
map { $_->{Filename} } dsc_files_info();
}
+sub files_compare_inputs (@) {
+ my $inputs = \@_;
+ my %record;
+ my %fchecked;
+
+ my $showinputs = sub {
+ return join "; ", map { $_->get_option('name') } @$inputs;
+ };
+
+ foreach my $in (@$inputs) {
+ my $expected_files;
+ my $in_name = $in->get_option('name');
+
+ printdebug "files_compare_inputs $in_name\n";
+
+ foreach my $csumi (@files_csum_info_fields) {
+ my ($fname) = @$csumi;
+ printdebug "files_compare_inputs $in_name $fname\n";
+
+ my $field = $in->{$fname};
+ next unless defined $field;
+
+ my @files;
+ foreach (split /\n/, $field) {
+ next unless m/\S/;
+
+ my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
+ fail "could not parse $in_name $fname line \`$_'";
+
+ printdebug "files_compare_inputs $in_name $fname $f\n";
+
+ push @files, $f;
+
+ my $re = \ $record{$f}{$fname};
+ if (defined $$re) {
+ $fchecked{$f}{$in_name} = 1;
+ $$re eq $info or
+ fail "hash or size of $f varies in $fname fields".
+ " (between: ".$showinputs->().")";
+ } else {
+ $$re = $info;
+ }
+ }
+ @files = sort @files;
+ $expected_files //= \@files;
+ "@$expected_files" eq "@files" or
+ fail "file list in $in_name varies between hash fields!";
+ }
+ $expected_files or
+ fail "$in_name has no files list field(s)";
+ }
+ printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
+ if $debuglevel>=2;
+
+ grep { keys %$_ == @$inputs-1 } values %fchecked
+ or fail "no file appears in all file lists".
+ " (looked in: ".$showinputs->().")";
+}
+
sub is_orig_file_in_dsc ($$) {
my ($f, $dsc_files_info) = @_;
return 0 if @$dsc_files_info <= 1;
printdebug "import clog $r1clogp->{version} becomes r1\n";
}
die $! if CLOGS->error;
- close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
+ close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
$clogp or fail "package changelog has no entries!";
local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
- eval {
- runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
- gbp_pq, qw(import);
- };
- if ($@) {
- { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
- die $@;
- }
+ my $path = $ENV{PATH} or die;
+
+ foreach my $use_absurd (qw(0 1)) {
+ local $ENV{PATH} = $path;
+ if ($use_absurd) {
+ chomp $@;
+ progress "warning: $@";
+ $path = "$absurdity:$path";
+ progress "$us: trying slow absurd-git-apply...";
+ rename "../../gbp-pq-output","../../gbp-pq-output.0"
+ or $!==ENOENT
+ or die $!;
+ }
+ eval {
+ die "forbid absurd git-apply\n" if $use_absurd
+ && forceing [qw(import-gitapply-no-absurd)];
+ die "only absurd git-apply!\n" if !$use_absurd
+ && forceing [qw(import-gitapply-absurd)];
+
+ local $ENV{PATH} = $path if $use_absurd;
+
+ my @showcmd = (gbp_pq, qw(import));
+ my @realcmd = shell_cmd
+ 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
+ debugcmd "+",@realcmd;
+ if (system @realcmd) {
+ die +(shellquote @showcmd).
+ " failed: ".
+ failedcmd_waitstatus()."\n";
+ }
- my $gapplied = git_rev_parse('HEAD');
- my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
- $gappliedtree eq $dappliedtree or
- fail <<END;
+ my $gapplied = git_rev_parse('HEAD');
+ my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
+ $gappliedtree eq $dappliedtree or
+ fail <<END;
gbp-pq import and dpkg-source disagree!
gbp-pq import gave commit $gapplied
gbp-pq import gave tree $gappliedtree
dpkg-source --before-build gave tree $dappliedtree
END
- $rawimport_hash = $gapplied;
+ $rawimport_hash = $gapplied;
+ };
+ last unless $@;
+ }
+ if ($@) {
+ { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
+ die $@;
+ }
}
progress "synthesised git commit from .dsc $cversion";
$furl .= "/$f";
die "$f ?" unless $f =~ m/^\Q${package}\E_/;
die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
+ runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
return 0 if !act_local();
$downloaded = 1;
}
push @specs, qw(heads/*) if deliberately_not_fast_forward;
# This is rather miserable:
- # When git-fetch --prune is passed a fetchspec ending with a *,
+ # When git fetch --prune is passed a fetchspec ending with a *,
# it does a plausible thing. If there is no * then:
# - it matches subpaths too, even if the supplied refspec
# starts refs, and behaves completely madly if the source
# We want to fetch a fixed ref, and we don't know in advance
# if it exists, so this is not suitable.
#
- # Our workaround is to use git-ls-remote. git-ls-remote has its
+ # Our workaround is to use git ls-remote. git ls-remote has its
# own qairks. Notably, it has the absurd multi-tail-matching
- # behaviour: git-ls-remote R refs/foo can report refs/foo AND
+ # behaviour: git ls-remote R refs/foo can report refs/foo AND
# refs/refs/foo etc.
#
# Also, we want an idempotent snapshot, but we have to make two
- # calls to the remote: one to git-ls-remote and to git-fetch. The
- # solution is use git-ls-remote to obtain a target state, and
- # git-fetch to try to generate it. If we don't manage to generate
+ # calls to the remote: one to git ls-remote and to git fetch. The
+ # solution is use git ls-remote to obtain a target state, and
+ # git fetch to try to generate it. If we don't manage to generate
# the target state, we try again.
my $specre = join '|', map {
my ($objid,$rrefname) = ($1,$2);
if (!$wanted_rref->($rrefname)) {
print STDERR <<END;
-warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
+warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
END
next;
}
if (!exists $wantr{$rrefname}) {
if ($wanted_rref->($rrefname)) {
printdebug <<END;
-git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
+git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
END
} else {
print STDERR <<END
-warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
+warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
END
}
runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
next if $got eq $want;
if (!defined $objgot{$want}) {
print STDERR <<END;
-warning: git-ls-remote suggests we want $lrefname
+warning: git ls-remote suggests we want $lrefname
warning: and it should refer to $want
-warning: but git-fetch didn't fetch that object to any relevant ref.
+warning: but git fetch didn't fetch that object to any relevant ref.
warning: This may be due to a race with someone updating the server.
warning: Will try again...
END
next FETCH_ITERATION;
}
printdebug <<END;
-git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
+git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
END
runcmd_ordryrun_local @git, qw(update-ref -m),
- "dgit fetch git-fetch fixup", $lrefname, $want;
+ "dgit fetch git fetch fixup", $lrefname, $want;
$lrfetchrefs_f{$lrefname} = $want;
}
last;
}
- printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
+ printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
Dumper(\%lrfetchrefs_f);
my %here;
}
sub fetch_from_archive () {
+ ensure_setup_existing_tree();
+
# Ensures that lrref() is what is actually in the archive, one way
# or another, according to us - ie this client's
# appropritaely-updated archive view. Also returns the commit id.
$setup->('name', 'DEBFULLNAME');
}
+sub ensure_setup_existing_tree () {
+ my $k = "remote.$remotename.skipdefaultupdate";
+ my $c = git_get_config $k;
+ return if defined $c;
+ set_local_git_config $k, 'true';
+}
+
sub setup_new_tree () {
setup_mergechangelogs();
setup_useremail();
}
my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
runcmd_ordryrun_local @git, qw(add -f), @adds;
- commit_admin "Commit Debian 3.0 (quilt) metadata";
+ commit_admin <<END
+Commit Debian 3.0 (quilt) metadata
+
+[dgit ($our_version) quilt-fixup]
+END
}
sub get_source_format () {
return $dgitview if is_fast_fwd $archive_hash, $dgitview;
- my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
- my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
- my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
- my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
- my $i_archive = [ $archive_hash, "current archive contents" ];
-
- printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
-
- infopair_cond_equal($i_dgit, $i_archive);
- infopair_cond_ff($i_dep14, $i_dgit);
- $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ if (defined $overwrite_version) {
+ } elsif (!eval {
+ my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
+ my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
+ my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
+ my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
+ my $i_archive = [ $archive_hash, "current archive contents" ];
+
+ printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
+
+ infopair_cond_equal($i_dgit, $i_archive);
+ infopair_cond_ff($i_dep14, $i_dgit);
+ infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
+ 1;
+ }) {
+ print STDERR <<END;
+$us: check failed (maybe --overwrite is needed, consult documentation)
+END
+ die "$@";
+ }
my $r = pseudomerge_make_commit
$clogp, $dgitview, $archive_hash, $i_arch_v,
"dgit --quilt=$quilt_mode",
(defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
-Declare fast forward from $overwrite_version
+Declare fast forward from $i_arch_v->[0]
END_OVERWR
Make fast forward from $i_arch_v->[0]
END_MAKEFF
my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
- my @tagformats = access_cfg_tagformats();
- my @t_overwr =
- map { $_->($i_arch_v->[0], access_basedistro) }
- (grep { m/^(?:old|hist)$/ } @tagformats)
- ? \&debiantags : \&debiantag_new;
- my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
- my $i_archive = [ $archive_hash, "current archive contents" ];
-
- infopair_cond_equal($i_overwr, $i_archive);
-
return $head if is_fast_fwd $archive_hash, $head;
my $m = "Declare fast forward from $i_arch_v->[0]";
$upstreamversion =~ s/-[^-]*$//;
changedir $ud;
quilt_make_fake_dsc($upstreamversion);
- my ($dgitview, $cachekey) =
+ my $cachekey;
+ ($dgithead, $cachekey) =
quilt_check_splitbrain_cache($actualhead, $upstreamversion);
- $dgitview or fail
+ $dgithead or fail
"--quilt=$quilt_mode but no cached dgit view:
perhaps tree changed since dgit build[-source] ?";
$split_brain = 1;
$dgithead = splitbrain_pseudomerge($clogp,
- $actualhead, $dgitview,
+ $actualhead, $dgithead,
$archive_hash);
$maintviewhead = $actualhead;
changedir '../../../..';
my ($tree,$dir) = mktree_in_ud_from_only_subdir();
check_for_vendor_patches() if madformat($dsc->{format});
changedir '../../../..';
- my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
- my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
+ my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
debugcmd "+",@diffcmd;
$!=0; $?=-1;
my $r = system @diffcmd;
if ($r) {
if ($r==256) {
- fail "$dscfn specifies a different tree to your HEAD commit;".
- " perhaps you forgot to build".
- ($diffopt eq '--exit-code' ? "" :
- " (run with -D to see full diff output)");
+ my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
+ fail <<END
+HEAD specifies a different tree to $dscfn:
+$diffs
+Perhaps you forgot to build. Or perhaps there is a problem with your
+ source tree (see dgit(7) for some hints). To see a full diff, run
+ git diff $tree HEAD
+END
} else {
failedcmd @diffcmd;
}
$changesfile = "$buildproductsdir/$changesfile";
}
+ # Check that changes and .dsc agree enough
+ $changesfile =~ m{[^/]*$};
+ files_compare_inputs($dsc, parsecontrol($changesfile,$&))
+ unless forceing [qw(dsc-changes-mismatch)];
+
# Checks complete, we're going to try and go ahead:
responder_send_file('changes',$changesfile);
push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
}
- runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
+ runcmd_ordryrun @git,
+ qw(-c push.followTags=false push), access_giturl(), @pushrefs;
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
}
if (stat $dstdir) {
rmtree($dstdir) or die "remove $dstdir: $!\n";
- } elsif (!grep { $! == $_ }
+ } elsif (grep { $! == $_ }
(ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
} else {
print STDERR "check whether to remove $dstdir: $!\n";
}
}
-sub quiltify_trees_differ ($$;$$) {
- my ($x,$y,$finegrained,$ignorenamesr) = @_;
+sub quiltify_trees_differ ($$;$$$) {
+ my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
# returns true iff the two tree objects differ other than in debian/
# with $finegrained,
# returns bitmask 01 - differ in upstream files except .gitignore
# 02 - differ in .gitignore
# if $ignorenamesr is defined, $ingorenamesr->{$fn}
# is set for each modified .gitignore filename $fn
+ # if $unrepres is defined, array ref to which is appeneded
+ # a list of unrepresentable changes (removals of upstream files
+ # (as messages)
local $/=undef;
- my @cmd = (@git, qw(diff-tree --name-only -z));
- push @cmd, qw(-r) if $finegrained;
+ my @cmd = (@git, qw(diff-tree -z));
+ push @cmd, qw(--name-only) unless $unrepres;
+ push @cmd, qw(-r) if $finegrained || $unrepres;
push @cmd, $x, $y;
my $diffs= cmdoutput @cmd;
my $r = 0;
+ my @lmodes;
foreach my $f (split /\0/, $diffs) {
+ if ($unrepres && !@lmodes) {
+ @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
+ next;
+ }
+ my ($oldmode,$newmode) = @lmodes;
+ @lmodes = ();
+
next if $f =~ m#^debian(?:/.*)?$#s;
+
+ if ($unrepres) {
+ eval {
+ die "deleted\n" unless $newmode =~ m/[^0]/;
+ die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
+ if ($oldmode =~ m/[^0]/) {
+ die "mode changed\n" if $oldmode ne $newmode;
+ } else {
+ die "non-default mode\n" unless $newmode =~ m/^100644$/;
+ }
+ };
+ if ($@) {
+ local $/="\n"; chomp $@;
+ push @$unrepres, [ $f, $@ ];
+ }
+ }
+
my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
$r |= $isignore ? 02 : 01;
$ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
if ($quilt_mode =~ m/gbp|unapplied/ &&
- ($diffbits->{H2O} & 01)) {
+ ($diffbits->{O2H} & 01)) {
my $msg =
"--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
" but git tree differs from orig in upstream files.";
.gitignores: but, such patches exist in debian/patches.
END
}
- if (($diffbits->{H2O} & 02) && # user has modified .gitignore
+ if (($diffbits->{O2H} & 02) && # user has modified .gitignore
!($diffbits->{O2A} & 02)) { # patches do not change .gitignore
quiltify_splitbrain_needed();
progress "dgit view: creating patch to represent .gitignore changes";
print SERIES "auto-gitignore\n" or die $!;
close SERIES or die $!;
runcmd @git, qw(add -- debian/patches/series), $gipatch;
- commit_admin "Commit patch to update .gitignore";
+ commit_admin <<END
+Commit patch to update .gitignore
+
+[dgit ($our_version) update-gitignore-quilt-fixup]
+END
}
- my $dgitview = git_rev_parse 'refs/heads/dgit-view';
+ my $dgitview = git_rev_parse 'HEAD';
changedir '../../../..';
+ # When we no longer need to support squeeze, use --create-reflog
+ # instead of this:
ensuredir ".git/logs/refs/dgit-intern";
my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
or die $!;
+
+ my $oldcache = git_get_ref "refs/$splitbraincache";
+ if ($oldcache eq $dgitview) {
+ my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
+ # git update-ref doesn't always update, in this case. *sigh*
+ my $dummy = make_commit_text <<END;
+tree $tree
+parent $dgitview
+author Dgit <dgit\@example.com> 1000000000 +0000
+committer Dgit <dgit\@example.com> 1000000000 +0000
+
+Dummy commit - do not use
+END
+ runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
+ "refs/$splitbraincache", $dummy;
+ }
runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
$dgitview;
$msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
+ my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
+ $strip_nls->();
+
my $title = $1;
- my $patchname = $title;
- $patchname =~ s/[.:]$//;
- $patchname =~ y/ A-Z/-a-z/;
- $patchname =~ y/-a-z0-9_.+=~//cd;
- $patchname =~ s/^\W/x-$&/;
- $patchname = substr($patchname,0,40);
+ my $patchname;
+ my $patchdir;
+
+ my $gbp_check_suitable = sub {
+ $_ = shift;
+ my ($what) = @_;
+
+ eval {
+ die "contains unexpected slashes\n" if m{//} || m{/$};
+ die "contains leading punctuation\n" if m{^\W} || m{/\W};
+ die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
+ die "too long" if length > 200;
+ };
+ return $_ unless $@;
+ print STDERR "quiltifying commit $cc:".
+ " ignoring/dropping Gbp-Pq $what: $@";
+ return undef;
+ };
+
+ if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
+ gbp-pq-name: \s* )
+ (\S+) \s* \n //ixm) {
+ $patchname = $gbp_check_suitable->($1, 'Name');
+ }
+ if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
+ gbp-pq-topic: \s* )
+ (\S+) \s* \n //ixm) {
+ $patchdir = $gbp_check_suitable->($1, 'Topic');
+ }
+
+ $strip_nls->();
+
+ if (!defined $patchname) {
+ $patchname = $title;
+ $patchname =~ s/[.:]$//;
+ use Text::Iconv;
+ eval {
+ my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
+ my $translitname = $converter->convert($patchname);
+ die unless defined $translitname;
+ $patchname = $translitname;
+ };
+ print STDERR
+ "dgit: patch title transliteration error: $@"
+ if $@;
+ $patchname =~ y/ A-Z/-a-z/;
+ $patchname =~ y/-a-z0-9_.+=~//cd;
+ $patchname =~ s/^\W/x-$&/;
+ $patchname = substr($patchname,0,40);
+ }
+ if (!defined $patchdir) {
+ $patchdir = '';
+ }
+ if (length $patchdir) {
+ $patchname = "$patchdir/$patchname";
+ }
+ if ($patchname =~ m{^(.*)/}) {
+ mkpath "debian/patches/$1";
+ }
+
my $index;
for ($index='';
stat "debian/patches/$patchname$index";
sub quilt_fixup_delete_pc () {
runcmd @git, qw(rm -rqf .pc);
- commit_admin "Commit removal of .pc (quilt series tracking data)";
+ commit_admin <<END
+Commit removal of .pc (quilt series tracking data)
+
+[dgit ($our_version) upgrade quilt-remove-pc]
+END
}
sub quilt_fixup_singlepatch ($$$) {
my $srcshash = Digest::SHA->new(256);
my %sfs = ( %INC, '$0(dgit)' => $0 );
foreach my $sfk (sort keys %sfs) {
- next unless m/^\$0\b/ || m{^Debian/Dgit\b};
+ next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
$srcshash->add($sfk," ");
$srcshash->add(hashfile($sfs{$sfk}));
$srcshash->add("\n");
push @cachekey, $srcshash->hexdigest();
$splitbrain_cachekey = "@cachekey";
- my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
+ my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
$splitbraincache);
printdebug "splitbrain cachekey $splitbrain_cachekey\n";
debugcmd "|(probably)",@cmd;
# 2. Copy .pc from the fake's extraction, if necessary
# 3. Run dpkg-source --commit
# 4. If the result has changes to debian/, then
- # - git-add them them
- # - git-add .pc if we had a .pc in-tree
- # - git-commit
- # 5. If we had a .pc in-tree, delete it, and git-commit
+ # - git add them them
+ # - git add .pc if we had a .pc in-tree
+ # - git commit
+ # 5. If we had a .pc in-tree, delete it, and git commit
# 6. Back in the main tree, fast forward to the new HEAD
# Another situation we may have to cope with is gbp-style
# We would want to detect these, so we know to escape into
# quilt_fixup_gbp. However, this is in general not possible.
# Consider a package with a one patch which the dgit user reverts
- # (with git-revert or the moral equivalent).
+ # (with git revert or the moral equivalent).
#
# That is indistinguishable in contents from a patches-unapplied
# tree. And looking at the history to distinguish them is not
ensuredir '.pc';
- runcmd qw(sh -ec),
- 'exec dpkg-source --before-build . >/dev/null';
+ my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
+ $!=0; $?=-1;
+ if (system @bbcmd) {
+ failedcmd @bbcmd if $? < 0;
+ fail <<END;
+failed to apply your git tree's patch stack (from debian/patches/) to
+ the corresponding upstream tarball(s). Your source tree and .orig
+ are probably too inconsistent. dgit can only fix up certain kinds of
+ anomaly (depending on the quilt mode). See --quilt= in dgit(1).
+END
+ }
changedir '..';
# be. This is mostly for error reporting.
my %editedignores;
+ my @unrepres;
my $diffbits = {
# H = user's HEAD
# O = orig, without patches applied
# A = "applied", ie orig with H's debian/patches applied
- H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
+ O2H => quiltify_trees_differ($unapplied,$headref, 1,
+ \%editedignores, \@unrepres),
H2A => quiltify_trees_differ($headref, $oldtiptree,1),
O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
};
my @dl;
foreach my $b (qw(01 02)) {
- foreach my $v (qw(H2O O2A H2A)) {
+ foreach my $v (qw(O2H O2A H2A)) {
push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
}
}
printdebug "differences \@dl @dl.\n";
progress sprintf
+"$us: base trees orig=%.20s o+d/p=%.20s",
+ $unapplied, $oldtiptree;
+ progress sprintf
"$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
"$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
$dl[0], $dl[1], $dl[3], $dl[4],
$dl[2], $dl[5];
+ if (@unrepres) {
+ print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
+ foreach @unrepres;
+ forceable_fail [qw(unrepresentable)], <<END;
+HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
+END
+ }
+
my @failsuggestion;
- if (!($diffbits->{H2O} & $diffbits->{O2A})) {
+ if (!($diffbits->{O2H} & $diffbits->{O2A})) {
push @failsuggestion, "This might be a patches-unapplied branch.";
} elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
push @failsuggestion, "This might be a patches-applied branch.";
}
push @failsuggestion, "Maybe you need to specify one of".
- " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
+ " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
if (quiltmode_splitbrain()) {
quiltify_splitbrain($clogp, $unapplied, $headref,
return $r;
}
+sub in_parent (&) {
+ my ($fn) = @_;
+ my $wasdir = must_getcwd();
+ changedir "..";
+ $fn->();
+ changedir $wasdir;
+}
+
+sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
+ my ($msg_if_onlyone) = @_;
+ # If there is only one .changes file, fail with $msg_if_onlyone,
+ # or if that is undef, be a no-op.
+ # Returns the changes file to report to the user.
+ my $pat = changespat $version;
+ my @changesfiles = glob $pat;
+ @changesfiles = sort {
+ ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
+ or $a cmp $b
+ } @changesfiles;
+ my $result;
+ if (@changesfiles==1) {
+ fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
+only one changes file from build (@changesfiles)
+END
+ $result = $changesfiles[0];
+ } elsif (@changesfiles==2) {
+ my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
+ foreach my $l (split /\n/, getfield $binchanges, 'Files') {
+ fail "$l found in binaries changes file $binchanges"
+ if $l =~ m/\.dsc$/;
+ }
+ runcmd_ordryrun_local @mergechanges, @changesfiles;
+ my $multichanges = changespat $version,'multi';
+ if (act_local()) {
+ stat_exists $multichanges or fail "$multichanges: $!";
+ foreach my $cf (glob $pat) {
+ next if $cf eq $multichanges;
+ rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ }
+ }
+ $result = $multichanges;
+ } else {
+ fail "wrong number of different changes files (@changesfiles)";
+ }
+ printdone "build successful, results in $result\n" or die $!;
+}
+
+sub postbuild_mergechanges_vanilla ($) {
+ my ($wantsrc) = @_;
+ if ($wantsrc == 1) {
+ in_parent {
+ postbuild_mergechanges(undef);
+ };
+ } else {
+ printdone "build successful\n";
+ }
+}
+
sub cmd_build {
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
runcmd_ordryrun_local @dbp;
}
maybe_unapply_patches_again();
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
+}
+
+sub pre_gbp_build {
+ $quilt_mode //= 'gbp';
}
sub cmd_gbp_build {
}
maybe_unapply_patches_again();
if ($wantsrc < 2) {
- unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
- canonicalise_suite();
- push @cmd, "--git-debian-branch=".lbranch();
- }
push @cmd, changesopts();
runcmd_ordryrun_local @cmd, @ARGV;
}
- printdone "build successful\n";
+ postbuild_mergechanges_vanilla $wantsrc;
}
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
if (!$rmchanges) {
my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
@unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
- fail "changes files other than source matching $pat".
- " already present (@unwanted);".
- " building would result in ambiguity about the intended results"
+ fail <<END
+changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
+Suggest you delete @unwanted.
+END
if @unwanted;
}
- my $wasdir = must_getcwd();
- changedir "..";
- if (act_local()) {
- stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
- stat_exists $sourcechanges
- or fail "$sourcechanges (in parent directory): $!";
- }
- runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
- my @changesfiles = glob $pat;
- @changesfiles = sort {
- ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
- or $a cmp $b
- } @changesfiles;
- fail "wrong number of different changes files (@changesfiles)"
- unless @changesfiles==2;
- my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
- foreach my $l (split /\n/, getfield $binchanges, 'Files') {
- fail "$l found in binaries changes file $binchanges"
- if $l =~ m/\.dsc$/;
- }
- runcmd_ordryrun_local @mergechanges, @changesfiles;
- my $multichanges = changespat $version,'multi';
- if (act_local()) {
- stat_exists $multichanges or fail "$multichanges: $!";
- foreach my $cf (glob $pat) {
- next if $cf eq $multichanges;
- rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
+ in_parent {
+ if (act_local()) {
+ stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
+ stat_exists $sourcechanges
+ or fail "$sourcechanges (in parent directory): $!";
}
- }
- changedir $wasdir;
+ runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
+ };
maybe_unapply_patches_again();
- printdone "build successful, results in $multichanges\n" or die $!;
+ in_parent {
+ postbuild_mergechanges(<<END);
+perhaps you need to pass -A ? (sbuild's default is to build only
+arch-specific binaries; dgit 1.4 used to override that.)
+END
+ };
}
sub cmd_quilt_fixup {
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
my @cmd = archive_api_query_cmd($subpath);
+ push @cmd, qw(-f);
debugcmd ">",@cmd;
exec @cmd or fail "exec curl: $!\n";
}
defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
-defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
-
defvalopt '', '-C', '.+', sub {
($changesfile) = (@_);
if ($changesfile =~ s#^(.*)/##) {
($om = $opts_opt_map{$1})) {
push @ropts, $_;
push @$om, $2;
+ } elsif (m/^--(gbp|dpm)$/s) {
+ push @ropts, "--quilt=$1";
+ $quilt_mode = $1;
} elsif (m/^--ignore-dirty$/s) {
push @ropts, $_;
$ignoredirty = 1;
} elsif (m/^--deliberately-($deliberately_re)$/s) {
push @ropts, $_;
push @deliberatelies, $&;
+ } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
+ push @ropts, $&;
+ $forceopts{$1} = 1;
+ $_='';
+ } elsif (m/^--force-/) {
+ print STDERR
+ "$us: warning: ignoring unknown force option $_\n";
+ $_='';
} elsif (m/^--dgit-tag-format=(old|new)$/s) {
# undocumented, for testing
push @ropts, $_;
} elsif (s/^-wc$//s) {
push @ropts, $&;
$cleanmode = 'check';
+ } elsif (s/^-c([^=]*)\=(.*)$//s) {
+ push @git, '-c', $&;
+ $gitcfgs{cmdline}{$1} = [ $2 ];
+ } elsif (s/^-c([^=]+)$//s) {
+ push @git, '-c', $&;
+ $gitcfgs{cmdline}{$1} = [ 'true' ];
} elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
$val = $'; #';
$val = undef unless length $val;
}
}
+sub check_env_sanity () {
+ my $blocked = new POSIX::SigSet;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
+
+ eval {
+ foreach my $name (qw(PIPE CHLD)) {
+ my $signame = "SIG$name";
+ my $signum = eval "POSIX::$signame" // die;
+ ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
+ die "$signame is set to something other than SIG_DFL\n";
+ $blocked->ismember($signum) and
+ die "$signame is blocked\n";
+ }
+ };
+ return unless $@;
+ chomp $@;
+ fail <<END;
+On entry to dgit, $@
+This is a bug produced by something in in your execution environment.
+Giving up.
+END
+}
+
+
sub finalise_opts_opts () {
foreach my $k (keys %opts_opt_map) {
my $om = $opts_opt_map{$k};
}
foreach my $c (access_cfg_cfgs("opts-$k")) {
- my $vl = $gitcfg{$c};
- printdebug "CL $c ",
- ($vl ? join " ", map { shellquote } @$vl : ""),
+ my @vl =
+ map { $_ ? @$_ : () }
+ map { $gitcfgs{$_}{$c} }
+ reverse @gitcfgsources;
+ printdebug "CL $c ", (join " ", map { shellquote } @vl),
"\n" if $debuglevel >= 4;
- next unless $vl;
+ next unless @vl;
badcfg "cannot configure options for $k"
if $opts_opt_cmdonly{$k};
my $insertpos = $opts_cfg_insertpos{$k};
@$om = ( @$om[0..$insertpos-1],
- @$vl,
+ @vl,
@$om[$insertpos..$#$om] );
}
}
}
parseopts();
+check_env_sanity();
git_slurp_config();
print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
my $cmd = shift @ARGV;
$cmd =~ y/-/_/;
+my $pre_fn = ${*::}{"pre_$cmd"};
+$pre_fn->() if $pre_fn;
+
if (!defined $rmchanges) {
local $access_forpush;
$rmchanges = access_cfg_bool(0, 'rm-old-changes');
~ianmdlvl / dgit.git / blobdiff