use strict;
-use Debian::Dgit;
+use Debian::Dgit qw(:DEFAULT :playground);
setup_sigwarn();
use IO::Handle;
use IPC::Open2;
use Digest::SHA;
use Digest::MD5;
-use List::Util qw(any);
use List::MoreUtils qw(pairwise);
use Text::Glob qw(match_glob);
use Fcntl qw(:DEFAULT :flock);
our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
+our $cmd;
+our $subcommand;
our $isuite;
our $idistro;
our $package;
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
our $dodep14tag;
-our $dodep14tag_re = 'want|no|always';
our $split_brain_save;
our $we_are_responder;
our $we_are_initiator;
our (@git) = qw(git);
our (@dget) = qw(dget);
-our (@curl) = qw(curl);
+our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
our (@dput) = qw(dput);
our (@debsign) = qw(debsign);
our (@gpg) = qw(gpg);
} keys %opts_opt_map;
sub parseopts_late_defaults();
+sub setup_gitattrs(;$);
+sub check_gitattrs($$);
our $keyid;
END {
local ($@, $?);
+ return unless forkcheck_mainprocess();
print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
}
our @end;
END {
local ($?);
+ return unless forkcheck_mainprocess();
foreach my $f (@end) {
eval { $f->(); };
print STDERR "$us: cleanup: $@" if length $@;
exit 4;
}
-sub changedir ($) {
- my ($newdir) = @_;
- printdebug "CD $newdir\n";
- chdir $newdir or confess "chdir: $newdir: $!";
-}
-
sub deliberately ($) {
my ($enquiry) = @_;
return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
return opts_opt_multi_cmd @gbp_pq;
}
+sub dgit_privdir () {
+ our $dgit_privdir_made //= ensure_a_playground 'dgit';
+}
+
#---------- remote protocol support, common ----------
# remote push initiator/responder protocol:
# > param tagformat old|new
# > param maint-view MAINT-VIEW-HEAD
#
+# > param buildinfo-filename P_V_X.buildinfo # zero or more times
+# > file buildinfo # for buildinfos to sign
+#
# > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
# # goes into tag, for replay prevention
#
# [etc]
# < data-block NBYTES [transfer of signed changes]
# [etc]
+# < data-block NBYTES [transfer of each signed buildinfo
+# [etc] same number and order as "file buildinfo"]
+# ...
# < files-end
#
# > complete
our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
-sub runcmd {
- debugcmd "+",@_;
- $!=0; $?=-1;
- failedcmd @_ if system @_;
-}
-
sub act_local () { return $dryrun_level <= 1; }
sub act_scary () { return !$dryrun_level; }
return scalar shift @ARGV;
}
+sub pre_help () {
+ not_necessarily_a_tree();
+}
sub cmd_help () {
print $helpmsg or die $!;
exit 0;
our %gitcfgs;
our @gitcfgsources = qw(cmdline local global system);
+our $invoked_in_git_tree = 1;
sub git_slurp_config () {
- local ($debuglevel) = $debuglevel-2;
- local $/="\0";
-
# 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;
+ $gitcfgs{$src} = git_slurp_config_src $src;
}
}
my ($c) = @_;
foreach my $src (@gitcfgsources) {
my $l = $gitcfgs{$src}{$c};
- croak "$l $c" if $l && !ref $l;
+ confess "internal error ($l $c)" if $l && !ref $l;
printdebug"C $c ".(defined $l ?
join " ", map { messagequote "'$_'" } @$l :
"undef")."\n"
"$us: distro or suite appears not to be (properly) supported";
}
+sub not_necessarily_a_tree () {
+ # needs to be called from pre_*
+ @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
+ $invoked_in_git_tree = 0;
+}
+
sub access_basedistro__noalias () {
if (defined $idistro) {
return $idistro;
our %commit_getclogp_memo;
my $memo = $commit_getclogp_memo{$objid};
return $memo if $memo;
- mkpath '.git/dgit';
- my $mclog = ".git/dgit/clog-$objid";
+
+ my $mclog = dgit_privdir()."clog-$objid";
runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
"$objid:debian/changelog";
$commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
}
-sub must_getcwd () {
- my $d = getcwd();
- defined $d or fail "getcwd failed: $!";
- return $d;
-}
-
sub parse_dscdata () {
my $dscfh = new IO::File \$dscdata, '<' or die $!;
printdebug Dumper($dscdata) if $debuglevel>1;
return [ (getfield $pre_dsc, 'Version'), $uri ];
}
+sub file_in_archive_aptget () { return undef; }
+
#---------- `dummyapicat' archive query method ----------
sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
our ($dsc_hash,$lastpush_mergeinput);
our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
-our $ud = '.git/dgit/unpack';
-sub prep_ud (;$) {
- my ($d) = @_;
- $d //= $ud;
- rmtree($d);
- mkpath '.git/dgit';
- mkdir $d or die $!;
+sub prep_ud () {
+ dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
+ fresh_playground 'dgit/unpack';
}
sub mktree_in_ud_here () {
- runcmd qw(git init -q);
- runcmd qw(git config gc.auto 0);
- rmtree('.git/objects');
- symlink '../../../../objects','.git/objects' or die $!;
+ playtree_setup $gitcfgs{local};
}
sub git_write_tree () {
sub mktree_in_ud_from_only_subdir ($;$) {
my ($what,$raw) = @_;
-
# changes into the subdir
+
my (@dirs) = <*/.>;
die "expected one subdir but found @dirs ?" unless @dirs==1;
$dirs[0] =~ m#^([^/]+)/\.$# or die;
sub clogp_authline ($) {
my ($clogp) = @_;
my $author = getfield $clogp, 'Maintainer';
- $author =~ s#,.*##ms;
+ if ($author =~ m/^[^"\@]+\,/) {
+ # single entry Maintainer field with unquoted comma
+ $author = ($& =~ y/,//rd).$'; # strip the comma
+ }
+ # git wants a single author; any remaining commas in $author
+ # are by now preceded by @ (or "). It seems safer to punt on
+ # "..." for now rather than attempting to dequote or something.
+ $author =~ s#,.*##ms unless $author =~ m/"/;
my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
my $authline = "$author $date";
$authline =~ m/$git_authline_re/o or
# See big comment in fetch_from_archive, below.
# See also README.dsc-import.
prep_ud();
- changedir $ud;
+ changedir $playground;
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
+ my $upper_f = "$maindir/../$f";
+
+ printdebug "considering reusing $f: ";
+
+ if (link_ltarget "$upper_f,fetch", $f) {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail "accessing ../$f,fetch: $!";
+ } elsif (link_ltarget $upper_f, $f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail "accessing ../$f: $!";
+ } else {
+ printdebug "absent.\n";
+ }
- printdebug "considering linking $f: ";
-
- link_ltarget "../../../../$f", $f
- or ((printdebug "($!) "), 0)
- or $!==&ENOENT
- or die "$f $!";
-
- printdebug "linked.\n";
-
- complete_file_from_dsc('.', $fi)
+ my $refetched;
+ complete_file_from_dsc('.', $fi, \$refetched)
or next;
- if (is_orig_file_in_dsc($f, \@dfi)) {
- link $f, "../../../../$f"
- or $!==&EEXIST
- or die "$f $!";
+ printdebug "considering saving $f: ";
+
+ if (link $f, $upper_f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != EEXIST) {
+ fail "saving ../$f: $!";
+ } elsif (!$refetched) {
+ printdebug "no need.\n";
+ } elsif (link $f, "$upper_f,fetch") {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != EEXIST) {
+ fail "saving ../$f,fetch: $!";
+ } else {
+ printdebug "cannot.\n";
}
}
if defined $compr_ext && !defined $cname;
my $compr_proc =
new Dpkg::Compression::Process compression => $cname;
- my @compr_cmd = $compr_proc->get_uncompress_cmdline();
+ @compr_cmd = $compr_proc->get_uncompress_cmdline();
my $compr_fh = new IO::Handle;
my $compr_pid = open $compr_fh, "-|" // die $!;
if (!$compr_pid) {
!$? or failedcmd @tarcmd;
close $input or
- (@compr_cmd ? failedcmd @compr_cmd
+ (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
: die $!);
# finally, we have the results in "tarball", but maybe
# with the wrong permissions
my $authline = clogp_authline $clogp;
my $changes = getfield $clogp, 'Changes';
+ $changes =~ s/^\n//; # Changes: \n
my $cversion = getfield $clogp, 'Version';
if (@tartrees) {
local $ENV{GIT_AUTHOR_DATE} = $authline[2];
my $path = $ENV{PATH} or die;
+
+ # we use ../../gbp-pq-output, which (given that we are in
+ # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
+ # is .git/dgit.
foreach my $use_absurd (qw(0 1)) {
runcmd @git, qw(checkout -q unpa);
@output = $lastpush_mergeinput;
}
}
- changedir '../../../..';
- rmtree($ud);
+ changedir $maindir;
+ rmtree $playground;
return @output;
}
-sub complete_file_from_dsc ($$) {
- our ($dstdir, $fi) = @_;
- # Ensures that we have, in $dir, the file $fi, with the correct
+sub complete_file_from_dsc ($$;$) {
+ our ($dstdir, $fi, $refetched) = @_;
+ # Ensures that we have, in $dstdir, the file $fi, with the correct
# contents. (Downloading it from alongside $dscurl if necessary.)
+ # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
+ # and will set $$refetched=1 if it did so (or tried to).
my $f = $fi->{Filename};
my $tf = "$dstdir/$f";
my $downloaded = 0;
+ my $got;
+ my $checkhash = sub {
+ open F, "<", "$tf" or die "$tf: $!";
+ $fi->{Digester}->reset();
+ $fi->{Digester}->addfile(*F);
+ F->error and die $!;
+ $got = $fi->{Digester}->hexdigest();
+ return $got eq $fi->{Hash};
+ };
+
if (stat_exists $tf) {
- progress "using existing $f";
+ if ($checkhash->()) {
+ progress "using existing $f";
+ return 1;
+ }
+ if (!$refetched) {
+ fail "file $f has hash $got but .dsc".
+ " demands hash $fi->{Hash} ".
+ "(perhaps you should delete this file?)";
+ }
+ progress "need to fetch correct version of $f";
+ unlink $tf or die "$tf $!";
+ $$refetched = 1;
} else {
printdebug "$tf does not exist, need to fetch\n";
- my $furl = $dscurl;
- $furl =~ s{/[^/]+$}{};
- $furl .= "/$f";
- die "$f ?" unless $f =~ m/^\Q${package}\E_/;
- die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
- return 0 if !act_local();
- $downloaded = 1;
- }
-
- open F, "<", "$tf" or die "$tf: $!";
- $fi->{Digester}->reset();
- $fi->{Digester}->addfile(*F);
- F->error and die $!;
- my $got = $fi->{Digester}->hexdigest();
- $got eq $fi->{Hash} or
+ }
+
+ my $furl = $dscurl;
+ $furl =~ s{/[^/]+$}{};
+ $furl .= "/$f";
+ die "$f ?" unless $f =~ m/^\Q${package}\E_/;
+ die "$f ?" if $f =~ m#/#;
+ runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
+ return 0 if !act_local();
+
+ $checkhash->() or
fail "file $f has hash $got but .dsc".
" demands hash $fi->{Hash} ".
- ($downloaded ? "(got wrong file from archive!)"
- : "(perhaps you should delete this file?)");
+ "(got wrong file from archive!)";
return 1;
}
# (If we deleted them unconditionally, then we might end up
# re-fetching the same git objects each time dgit fetch was run.)
#
-# So, leach use of lrfetchrefs needs to be accompanied by arrangements
+# So, each use of lrfetchrefs needs to be accompanied by arrangements
# in git_fetch_us to fetch the refs in question, and possibly a call
# to lrfetchref_used.
}
sub git_lrfetch_sane {
- my ($supplementary, @specs) = @_;
+ my ($url, $supplementary, @specs) = @_;
# Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
# at least as regards @specs. Also leave the results in
# %lrfetchrefs_f, and arrange for lrfetchref_used to be
# git fetch to try to generate it. If we don't manage to generate
# the target state, we try again.
- my $url = access_giturl();
-
printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
my $specre = join '|', map {
push @specs, $rewritemap;
push @specs, qw(heads/*) if deliberately_not_fast_forward;
- git_lrfetch_sane 0, @specs;
+ my $url = access_giturl();
+ git_lrfetch_sane $url, 0, @specs;
my %here;
my @tagpats = debiantags('*',access_nomdistro);
} elsif ($here{$lref} eq $objid) {
lrfetchref_used $fullrefname;
} else {
- print STDERR \
- "Not updateting $lref from $here{$lref} to $objid.\n";
+ print STDERR
+ "Not updating $lref from $here{$lref} to $objid.\n";
}
});
}
}
}
+sub parse_dsc_field_def_dsc_distro () {
+ $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
+ dgit.default.distro);
+}
+
sub parse_dsc_field ($$) {
my ($dsc, $what) = @_;
my $f;
$f = $dsc->{$field};
last if defined $f;
}
+
if (!defined $f) {
progress "$what: NO git hash";
+ parse_dsc_field_def_dsc_distro();
} elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
= $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
progress "$what: specified git info ($dsc_distro)";
$dsc_hint_tag = [ $dsc_hint_tag ];
} elsif ($f =~ m/^\w+\s*$/) {
$dsc_hash = $&;
- $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
- dgit.default.distro);
+ parse_dsc_field_def_dsc_distro();
$dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
$dsc_distro ];
progress "$what: specified git hash";
or fail <<END;
.dsc Dgit metadata is in context of distro $dsc_distro
for which we have no configured url;
-.dsc provices hinted url with protocol $proto which is unsafe.
+.dsc provides hinted url with protocol $proto which is unsafe.
(can be overridden by config - consult documentation)
END
$url = $dsc_hint_url;
}
- git_lrfetch_sane 1, @fetch;
+ git_lrfetch_sane $url, 1, @fetch;
return $lrf;
};
END
foreach my $t (@tags) {
my $fullrefname = $lrf.'/'.$t;
- print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
+# print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
next unless $lrfetchrefs_f{$fullrefname};
next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
lrfetchref_used $fullrefname;
my $author = clogp_authline $useclogp;
my $cversion = getfield $useclogp, 'Version';
- my $mcf = ".git/dgit/mergecommit";
+ my $mcf = dgit_privdir()."/mergecommit";
open MC, ">", $mcf or die "$mcf $!";
print MC <<END or die $!;
tree $tree
fetch_from_archive_record_1($hash);
if (defined $skew_warning_vsn) {
- mkpath '.git/dgit';
printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
my $gotclogp = commit_getclogp($hash);
my $got_vsn = getfield $gotclogp, 'Version';
lrfetchref_used lrfetchref();
+ check_gitattrs($hash, "fetched source tree");
+
unshift @end, $del_lrfetchrefs;
return $hash;
}
my $driver = 'dpkg-mergechangelogs';
my $cb = "merge.$driver";
- my $attrs = '.git/info/attributes';
- ensuredir '.git/info';
+ confess unless defined $maindir;
+ my $attrs = "$maindir_gitcommon/info/attributes";
+ ensuredir "$maindir_gitcommon/info";
open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
if (!open ATTRS, "<", $attrs) {
set_local_git_config $k, 'true';
}
+sub open_main_gitattrs () {
+ confess 'internal error no maindir' unless defined $maindir;
+ my $gai = new IO::File "$maindir_gitcommon/info/attributes"
+ or $!==ENOENT
+ or die "open $maindir_gitcommon/info/attributes: $!";
+ return $gai;
+}
+
+sub is_gitattrs_setup () {
+ my $gai = open_main_gitattrs();
+ return 0 unless $gai;
+ while (<$gai>) {
+ return 1 if m{^\[attr\]dgit-defuse-attrs\s};
+ }
+ $gai->error and die $!;
+ return 0;
+}
+
+sub setup_gitattrs (;$) {
+ my ($always) = @_;
+ return unless $always || access_cfg_bool(1, 'setup-gitattributes');
+
+ if (is_gitattrs_setup()) {
+ progress <<END;
+[attr]dgit-defuse-attrs already found in .git/info/attributes
+ not doing further gitattributes setup
+END
+ return;
+ }
+ my $af = "$maindir_gitcommon/info/attributes";
+ ensuredir "$maindir_gitcommon/info";
+ open GAO, "> $af.new" or die $!;
+ print GAO <<END or die $!;
+* dgit-defuse-attrs
+[attr]dgit-defuse-attrs $negate_harmful_gitattrs
+# ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
+END
+ my $gai = open_main_gitattrs();
+ if ($gai) {
+ while (<$gai>) {
+ chomp;
+ print GAO $_, "\n" or die $!;
+ }
+ $gai->error and die $!;
+ }
+ close GAO or die $!;
+ rename "$af.new", "$af" or die "install $af: $!";
+}
+
sub setup_new_tree () {
setup_mergechangelogs();
setup_useremail();
+ setup_gitattrs();
+}
+
+sub check_gitattrs ($$) {
+ my ($treeish, $what) = @_;
+
+ return if is_gitattrs_setup;
+
+ local $/="\0";
+ my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
+ debugcmd "|",@cmd;
+ my $gafl = new IO::File;
+ open $gafl, "-|", @cmd or die $!;
+ while (<$gafl>) {
+ chomp or die;
+ s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
+ next if $1 == 0;
+ next unless m{(?:^|/)\.gitattributes$};
+
+ # oh dear, found one
+ print STDERR <<END;
+dgit: warning: $what contains .gitattributes
+dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
+END
+ close $gafl;
+ return;
+ }
+ # tree contains no .gitattributes files
+ $?=0; $!=0; close $gafl or failedcmd @cmd;
}
+
sub multisuite_suite_child ($$$) {
my ($tsuite, $merginputs, $fn) = @_;
# in child, sets things up, calls $fn->(), and returns undef
my $canonsuitefh = IO::File::new_tmpfile;
my $pid = fork // die $!;
if (!$pid) {
+ forkcheck_setup();
$isuite = $tsuite;
$us .= " [$isuite]";
$debugprefix .= " ";
$before_fetch_merge->();
foreach my $tsuite (@suites[1..$#suites]) {
+ $tsuite =~ s/^-/$cbasesuite-/;
my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
sub {
@end = ();
}
sub clone ($) {
+ # in multisuite, returns twice!
+ # once in parent after first suite fetched,
+ # and then again in child after everything is finished
my ($dstdir) = @_;
badusage "dry run makes no sense with clone" unless act_local();
my $multi_fetched = fork_for_multisuite(sub {
printdebug "multi clone before fetch merge\n";
changedir $dstdir;
+ record_maindir();
});
if ($multi_fetched) {
printdebug "multi clone after fetch merge\n";
clone_set_head();
clone_finish($dstdir);
- exit 0;
+ return;
}
printdebug "clone main body\n";
mkdir $dstdir or fail "create \`$dstdir': $!";
changedir $dstdir;
runcmd @git, qw(init -q);
+ record_maindir();
+ setup_new_tree();
clone_set_head();
my $giturl = access_giturl(1);
if (defined $giturl) {
$vcsgiturl =~ s/\s+-b\s+\S+//g;
runcmd @git, qw(remote add vcs-git), $vcsgiturl;
}
- setup_new_tree();
clone_finish($dstdir);
}
my ($headref, $dgitview, $msg) = @_;
# => message fragment "$saved" describing disposition of $dgitview
return "commit id $dgitview" unless defined $split_brain_save;
- my @cmd = (shell_cmd "cd ../../../..",
+ my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
@git, qw(update-ref -m),
"dgit --dgit-view-save $msg HEAD=$headref",
$split_brain_save, $dgitview);
} else {
my $v = $i_arch_v->[0];
progress "Checking package changelog for archive version $v ...";
+ my $cd;
eval {
my @xa = ("-f$v", "-t$v");
my $vclogp = parsechangelog @xa;
- my $cv = [ (getfield $vclogp, 'Version'),
- "Version field from dpkg-parsechangelog @xa" ];
+ my $gf = sub {
+ my ($fn) = @_;
+ [ (getfield $vclogp, $fn),
+ "$fn field from dpkg-parsechangelog @xa" ];
+ };
+ my $cv = $gf->('Version');
infopair_cond_equal($i_arch_v, $cv);
+ $cd = $gf->('Distribution');
};
if ($@) {
$@ =~ s/^dgit: //gm;
fail "$@".
"Perhaps debian/changelog does not mention $v ?";
}
+ fail <<END if $cd->[0] =~ m/UNRELEASED/;
+$cd->[1] is $cd->[0]
+Your tree seems to based on earlier (not uploaded) $v.
+END
}
}
: !length $overwrite_version ? " --overwrite"
: " --overwrite=".$overwrite_version;
- mkpath '.git/dgit';
- my $pmf = ".git/dgit/pseudomerge";
+ my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
print MC <<END or die $!;
tree $tree
#
return $dgitview unless defined $archive_hash;
+ return $dgitview if deliberately_not_fast_forward();
printdebug "splitbrain_pseudomerge...\n";
rpush_handle_protovsn_bothends() if $we_are_initiator;
select_tagformat();
- my $clogpfn = ".git/dgit/changelog.822.tmp";
+ my $clogpfn = dgit_privdir()."/changelog.822.tmp";
runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
responder_send_file('parsed-changelog', $clogpfn);
if (madformat_wantfixup($format)) {
# user might have not used dgit build, so maybe do this now:
if (quiltmode_splitbrain()) {
- changedir $ud;
+ changedir $playground;
quilt_make_fake_dsc($upstreamversion);
my $cachekey;
($dgithead, $cachekey) =
$actualhead, $dgithead,
$archive_hash);
$maintviewhead = $actualhead;
- changedir '../../../..';
+ changedir $maindir;
prep_ud(); # so _only_subdir() works, below
} else {
commit_quilty_patch();
}
}
- changedir $ud;
+ changedir $playground;
progress "checking that $dscfn corresponds to HEAD";
runcmd qw(dpkg-source -x --),
- $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
+ $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
check_for_vendor_patches() if madformat($dsc->{format});
- changedir '../../../..';
+ changedir $maindir;
my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
debugcmd "+",@diffcmd;
$!=0; $?=-1;
responder_send_command("param maint-view $maintviewhead");
}
+ # Perhaps send buildinfo(s) for signing
+ my $changes_files = getfield $changes, 'Files';
+ my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
+ foreach my $bi (@buildinfos) {
+ responder_send_command("param buildinfo-filename $bi");
+ responder_send_file('buildinfo', "$buildproductsdir/$bi");
+ }
+
if (deliberately_not_fast_forward) {
git_for_each_ref(lrfetchrefs, sub {
my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
}
my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
- ".git/dgit/tag");
+ dgit_privdir()."/tag");
my @tagobjfns;
supplementary_message(<<'END');
END
if ($we_are_responder) {
my $dryrunsuffix = act_local() ? "" : ".tmp";
+ my @rfiles = ($dscpath, $changesfile);
+ push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
responder_receive_files('signed-dsc-changes',
- "$dscpath$dryrunsuffix",
- "$changesfile$dryrunsuffix");
+ map { "$_$dryrunsuffix" } @rfiles);
} else {
if (act_local()) {
rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
responder_send_command("complete");
}
+sub pre_clone () {
+ not_necessarily_a_tree();
+}
sub cmd_clone {
parseopts();
my $dstdir;
}
sub branchsuite () {
- my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
+ my @cmd = (@git, qw(symbolic-ref -q HEAD));
+ my $branch = cmdoutput_errok @cmd;
+ if (!defined $branch) {
+ $?==256 or failedcmd @cmd;
+ return undef;
+ }
if ($branch =~ m#$lbranch_re#o) {
return $1;
} else {
pull();
}
-sub cmd_push {
+sub prep_push () {
parseopts();
- badusage "-p is not allowed with dgit push" if defined $package;
+ build_or_push_prep_early();
+ pushing();
check_not_dirty();
- my $clogp = parsechangelog();
- $package = getfield $clogp, 'Source';
my $specsuite;
if (@ARGV==0) {
} elsif (@ARGV==1) {
($specsuite) = (@ARGV);
} else {
- badusage "incorrect arguments to dgit push";
+ badusage "incorrect arguments to dgit $subcommand";
}
- $isuite = getfield $clogp, 'Distribution';
- pushing();
if ($new_package) {
local ($package) = $existing_package; # this is a hack
canonicalise_suite();
if (defined $specsuite &&
$specsuite ne $isuite &&
$specsuite ne $csuite) {
- fail "dgit push: changelog specifies $isuite ($csuite)".
+ fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
" but command line specifies $specsuite";
}
+}
+
+sub cmd_push {
+ prep_push();
dopush();
}
#---------- remote commands' implementation ----------
-sub cmd_remote_push_build_host {
+sub pre_remote_push_build_host {
my ($nrargs) = shift @ARGV;
my (@rargs) = @ARGV[0..$nrargs-1];
@ARGV = @ARGV[$nrargs..$#ARGV];
" but invocation host has $vsnwant"
unless defined $protovsn;
- responder_send_command("dgit-remote-push-ready $protovsn");
changedir $dir;
+}
+sub cmd_remote_push_build_host {
+ responder_send_command("dgit-remote-push-ready $protovsn");
&cmd_push;
}
+sub pre_remote_push_responder { pre_remote_push_build_host(); }
sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
# ... for compatibility with proto vsn.1 dgit (just so that user gets
# a good error message)
}
}
-END { i_cleanup(); }
+END {
+ return unless forkcheck_mainprocess();
+ i_cleanup();
+}
sub i_method {
my ($base,$selector,@args) = @_;
{ no strict qw(refs); &{"${base}_${selector}"}(@args); }
}
+sub pre_rpush () {
+ not_necessarily_a_tree();
+}
sub cmd_rpush {
my $host = nextarg;
my $dir;
print RI "files-end\n" or die $!;
}
-our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
+our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
sub i_localname_parsed_changelog {
return "remote-changelog.822";
}
sub i_file_dsc { }
+sub i_localname_buildinfo ($) {
+ my $bi = $i_param{'buildinfo-filename'};
+ defined $bi or badproto \*RO, "buildinfo before filename";
+ defined $i_changesfn or badproto \*RO, "buildinfo before changes";
+ $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
+ or badproto \*RO, "improper buildinfo filename";
+ return $&;
+}
+sub i_file_buildinfo {
+ my $bi = $i_param{'buildinfo-filename'};
+ my $bd = parsecontrol "$i_tmp/$bi", $bi;
+ my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
+ if (!forceing [qw(buildinfo-changes-mismatch)]) {
+ files_compare_inputs($bd, $ch);
+ (getfield $bd, $_) eq (getfield $ch, $_) or
+ fail "buildinfo mismatch $_"
+ foreach qw(Source Version);
+ !defined $bd->{$_} or
+ fail "buildinfo contains $_"
+ foreach qw(Changes Changed-by Distribution);
+ }
+ push @i_buildinfos, $bi;
+ delete $i_param{'buildinfo-filename'};
+}
+
sub i_localname_changes {
defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
$i_changesfn = $i_dscfn;
sub i_want_signed_dsc_changes {
rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
sign_changes $i_changesfn;
- return ($i_dscfn, $i_changesfn);
+ return ($i_dscfn, $i_changesfn, @i_buildinfos);
}
#---------- building etc. ----------
my ($patchname,$author,$msg, $xinfo) = @_;
$xinfo //= '';
- mkpath '.git/dgit';
+ mkpath '.git/dgit'; # we are in playtree
my $descfn = ".git/dgit/quilt-description.tmp";
open O, '>', $descfn or die "$descfn: $!";
$msg =~ s/\n+/\n\n/;
# a list of unrepresentable changes (removals of upstream files
# (as messages)
local $/=undef;
- my @cmd = (@git, qw(diff-tree -z));
+ my @cmd = (@git, qw(diff-tree -z --no-renames));
push @cmd, qw(--name-only) unless $unrepres;
push @cmd, qw(-r) if $finegrained || $unrepres;
push @cmd, $x, $y;
if ($unrepres) {
eval {
- die "not a plain file\n"
- unless $newmode =~ m/^10\d{4}$/ ||
- $oldmode =~ m/^10\d{4}$/;
+ die "not a plain file or symlink\n"
+ unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
+ $oldmode =~ m/^(?:10|12)\d{4}$/;
if ($oldmode =~ m/[^0]/ &&
$newmode =~ m/[^0]/) {
- die "mode changed\n" if $oldmode ne $newmode;
+ # both old and new files exist
+ die "mode or type changed\n" if $oldmode ne $newmode;
+ die "modified symlink\n" unless $newmode =~ m/^10/;
+ } elsif ($oldmode =~ m/[^0]/) {
+ # deletion
+ die "deletion of symlink\n"
+ unless $oldmode =~ m/^10/;
} else {
- die "non-default mode\n"
- unless $newmode =~ m/^100644$/ ||
- $oldmode =~ m/^100644$/;
+ # creation
+ die "creation with non-default mode\n"
+ unless $newmode =~ m/^100644$/ or
+ $newmode =~ m/^120000$/;
}
};
if ($@) {
my $dgitview = git_rev_parse 'HEAD';
- changedir '../../../..';
+ changedir $maindir;
# 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", '>>'
+ ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
+ my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
or die $!;
my $oldcache = git_get_ref "refs/$splitbraincache";
runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
$dgitview;
- changedir '.git/dgit/unpack/work';
+ changedir "$playground/work";
my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
progress "dgit view: created ($saved)";
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 "is series file\n" if m{$series_filename_re}o;
die "too long" if length > 200;
};
return $_ unless $@;
$patchname =~ y/-a-z0-9_.+=~//cd;
$patchname =~ s/^\W/x-$&/;
$patchname = substr($patchname,0,40);
+ $patchname .= ".patch";
}
if (!defined $patchdir) {
$patchdir = '';
my $headref = git_rev_parse('HEAD');
prep_ud();
- changedir $ud;
+ changedir $playground;
my $upstreamversion = upstreamversion $version;
die 'bug' if $split_brain && !$need_split_build_invocation;
- changedir '../../../..';
+ changedir $maindir;
runcmd_ordryrun_local
- @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
+ @git, qw(pull --ff-only -q), "$playground/work", qw(master);
}
sub quilt_fixup_mkwork ($) {
my ($upstreamversion, $fn) = @_;
# calls $fn->($leafname);
- foreach my $f (<../../../../*>) { #/){
+ foreach my $f (<$maindir/../*>) { #/){
my $b=$f; $b =~ s{.*/}{};
{
local ($debuglevel) = $debuglevel-1;
debian/control debian/changelog);
foreach my $maybe (qw(debian/patches debian/source/options
debian/tests/control)) {
- next unless stat_exists "../../../$maybe";
+ next unless stat_exists "$maindir/$maybe";
push @files, $maybe;
}
my $debtar= srcfn $fakeversion,'.debian.tar.gz';
- runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
+ runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
$dscaddfile->($debtar);
close $fakedsc or die $!;
sub quilt_check_splitbrain_cache ($$) {
my ($headref, $upstreamversion) = @_;
# Called only if we are in (potentially) split brain mode.
- # Called in $ud.
+ # Called in playground.
# Computes the cache key and looks in the cache.
# Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
debugcmd "|(probably)",@cmd;
my $child = open GC, "-|"; defined $child or die $!;
if (!$child) {
- chdir '../../..' or die $!;
- if (!stat ".git/logs/refs/$splitbraincache") {
+ chdir $maindir or die $!;
+ if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
$! == ENOENT or die $!;
printdebug ">(no reflog)\n";
exit 0;
maybe_unapply_patches_again();
}
-sub build_prep_early () {
- our $build_prep_early_done //= 0;
- return if $build_prep_early_done++;
- notpushing();
- badusage "-p is not allowed when building" if defined $package;
+sub build_or_push_prep_early () {
+ our $build_or_push_prep_early_done //= 0;
+ return if $build_or_push_prep_early_done++;
+ badusage "-p is not allowed with dgit $subcommand" if defined $package;
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+}
+
+sub build_prep_early () {
+ build_or_push_prep_early();
+ notpushing();
check_not_dirty();
}
push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
if ($gbp_make_orig) {
- ensuredir '.git/dgit';
- my $ok = '.git/dgit/origs-gen-ok';
+ my $priv = dgit_privdir();
+ my $ok = "$priv/origs-gen-ok";
unlink $ok or $!==&ENOENT or die $!;
my @origs_cmd = @cmd;
push @origs_cmd, qw(--git-cleaner=true);
- push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
+ push @origs_cmd, "--git-prebuild=".
+ "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
push @origs_cmd, @ARGV;
if (act_local()) {
debugcmd @origs_cmd;
} else {
my @cmd = (@dpkgsource, qw(-b --));
if ($split_brain) {
- changedir $ud;
+ changedir $playground;
runcmd_ordryrun_local @cmd, "work";
my @udfiles = <${package}_*>;
- changedir "../../..";
+ changedir $maindir;
foreach my $f (@udfiles) {
printdebug "source copy, found $f\n";
next unless
($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
$f eq srcfn($version, $&));
printdebug "source copy, found $f - renaming\n";
- rename "$ud/$f", "../$f" or $!==ENOENT
+ rename "$playground/$f", "../$f" or $!==ENOENT
or fail "put in place new source file ($f): $!";
}
} else {
build_maybe_quilt_fixup();
}
+sub import_dsc_result {
+ my ($dstref, $newhash, $what_log, $what_msg) = @_;
+ my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
+ runcmd @cmd;
+ check_gitattrs($newhash, "source tree");
+
+ progress "dgit: import-dsc: $what_msg";
+}
+
sub cmd_import_dsc {
my $needsig = 0;
parse_dsc_field($dsc, "Dgit metadata in .dsc")
unless forceing [qw(import-dsc-with-dgit-field)];
+ parse_dsc_field_def_dsc_distro();
+
+ $isuite = 'DGIT-IMPORT-DSC';
+ $idistro //= $dsc_distro;
+
+ notpushing();
if (defined $dsc_hash) {
progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
fail "Not fast forward to $dsc_hash";
}
}
- @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
- $dstbranch, $dsc_hash);
- runcmd @cmd;
- progress "dgit: import-dsc updated git ref $dstbranch";
+ import_dsc_result $dstbranch, $dsc_hash,
+ "dgit import-dsc (Dgit): $info",
+ "updated git ref $dstbranch";
return 0;
}
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
my $here = "../$f";
- next if lstat $here;
+ if (lstat $here) {
+ next if stat $here;
+ fail "lstat $here works but stat gives $! !";
+ }
fail "stat $here: $!" unless $! == ENOENT;
my $there = $dscfn;
if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
fail "cannot import $dscfn which seems to be inside working tree!";
}
$there =~ s#/+[^/]+$## or
- fail "cannot import $dscfn which seems to not have a basename";
+ fail "import $dscfn requires ../$f, but it does not exist";
$there .= "/$f";
+ my $test = $there =~ m{^/} ? $there : "../$there";
+ stat $test or fail "import $dscfn requires $test, but: $!";
symlink $there, $here or fail "symlink $there to $here: $!";
progress "made symlink $here -> $there";
# print STDERR Dumper($fi);
}
}
- my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
- $dstbranch, $newhash);
- runcmd @cmd;
- progress "dgit: import-dsc results are in in git ref $dstbranch";
+ import_dsc_result $dstbranch, $newhash,
+ "dgit import-dsc: $info",
+ "results are in in git ref $dstbranch";
}
+sub pre_archive_api_query () {
+ not_necessarily_a_tree();
+}
sub cmd_archive_api_query {
badusage "need only 1 subpath argument" unless @ARGV==1;
my ($subpath) = @ARGV;
exec @cmd or fail "exec curl: $!\n";
}
+sub repos_server_url () {
+ $package = '_dgit-repos-server';
+ local $access_forpush = 1;
+ local $isuite = 'DGIT-REPOS-SERVER';
+ my $url = access_giturl();
+}
+
+sub pre_clone_dgit_repos_server () {
+ not_necessarily_a_tree();
+}
sub cmd_clone_dgit_repos_server {
badusage "need destination argument" unless @ARGV==1;
my ($destdir) = @ARGV;
- $package = '_dgit-repos-server';
- local $access_forpush = 0;
- my @cmd = (@git, qw(clone), access_giturl(), $destdir);
+ my $url = repos_server_url();
+ my @cmd = (@git, qw(clone), $url, $destdir);
debugcmd ">",@cmd;
exec @cmd or fail "exec git clone: $!\n";
}
+sub pre_print_dgit_repos_server_source_url () {
+ not_necessarily_a_tree();
+}
sub cmd_print_dgit_repos_server_source_url {
badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
if @ARGV;
- $package = '_dgit-repos-server';
- local $access_forpush = 0;
- my $url = access_giturl();
+ my $url = repos_server_url();
print $url, "\n" or die $!;
}
sub cmd_setup_mergechangelogs {
badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
+ local $isuite = 'DGIT-SETUP-TREE';
setup_mergechangelogs(1);
}
sub cmd_setup_useremail {
badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ local $isuite = 'DGIT-SETUP-TREE';
setup_useremail(1);
}
+sub cmd_setup_gitattributes {
+ badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
+ local $isuite = 'DGIT-SETUP-TREE';
+ setup_gitattrs(1);
+}
+
sub cmd_setup_new_tree {
badusage "no arguments allowed to dgit setup-tree" if @ARGV;
+ local $isuite = 'DGIT-SETUP-TREE';
setup_new_tree();
}
}
our (%valopts_long, %valopts_short);
+our (%funcopts_long);
our @rvalopts;
+our (@modeopt_cfgs);
sub defvalopt ($$$$) {
my ($long,$short,$val_re,$how) = @_;
" absolute, not relative, directory."
};
+sub defoptmodes ($@) {
+ my ($varref, $cfgkey, $default, %optmap) = @_;
+ my %permit;
+ while (my ($opt,$val) = each %optmap) {
+ $funcopts_long{$opt} = sub { $$varref = $val; };
+ $permit{$val} = $val;
+ }
+ push @modeopt_cfgs, {
+ Var => $varref,
+ Key => $cfgkey,
+ Default => $default,
+ Vals => \%permit
+ };
+}
+
+defoptmodes \$dodep14tag, qw( dep14tag want
+ --dep14tag want
+ --no-dep14tag no
+ --always-dep14tag always );
+
sub parseopts () {
my $om;
} elsif (m/^--overwrite=(.+)$/s) {
push @ropts, $_;
$overwrite_version = $1;
- } elsif (m/^--dep14tag$/s) {
- push @ropts, $_;
- $dodep14tag= 'want';
- } elsif (m/^--no-dep14tag$/s) {
- push @ropts, $_;
- $dodep14tag= 'no';
- } elsif (m/^--always-dep14tag$/s) {
- push @ropts, $_;
- $dodep14tag= 'always';
} elsif (m/^--delayed=(\d+)$/s) {
push @ropts, $_;
push @dput, $_;
} elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
$val = $2 ? $' : undef; #';
$valopt->($oi->{Long});
+ } elsif ($funcopts_long{$_}) {
+ push @ropts, $_;
+ $funcopts_long{$_}();
} else {
badusage "unknown long option \`$_'";
}
$quilt_mode = $1;
}
- if (!defined $dodep14tag) {
+ foreach my $moc (@modeopt_cfgs) {
local $access_forpush;
- $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
- $dodep14tag =~ m/^($dodep14tag_re)$/
- or badcfg "unknown dep14tag setting \`$dodep14tag'";
- $dodep14tag = $1;
+ my $vr = $moc->{Var};
+ next if defined $$vr;
+ $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
+ my $v = $moc->{Vals}{$$vr};
+ badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
+ $$vr = $v;
}
$need_split_build_invocation ||= quiltmode_splitbrain();
parseopts();
check_env_sanity();
-git_slurp_config();
print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
print STDERR $helpmsg or die $!;
exit 8;
}
-my $cmd = shift @ARGV;
+$cmd = $subcommand = shift @ARGV;
$cmd =~ y/-/_/;
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
+record_maindir if $invoked_in_git_tree;
+git_slurp_config();
+
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();
~ianmdlvl / dgit.git / blobdiff