use LWP::UserAgent;
use Dpkg::Control::Hash;
use File::Path;
+use File::Spec;
use File::Temp qw(tempdir);
use File::Basename;
use Dpkg::Version;
our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
our $suite_re = '[-+.0-9a-z]+';
-our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
+our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
+ | (?: git | git-ff ) (?: ,always )?
+ | check (?: ,ignores )?
+ | none
+ )}x;
our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';
our (@gbp_build) = ('');
our (@gbp_pq) = ('gbp pq');
our (@changesopts) = ('');
-our (@pbuilder) = ("sudo -E pbuilder");
-our (@cowbuilder) = ("sudo -E cowbuilder");
+our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
+our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
'curl' => \@curl,
}
sub no_such_package () {
- print STDERR f_ "%s: package %s does not exist in suite %s\n",
+ print STDERR f_ "%s: source package %s does not exist in suite %s\n",
$us, $package, $isuite;
finish 4;
}
@$l==1 or badcfg
f_ "multiple values for %s (in %s git config)", $c, $src
if @$l > 1;
+ $l->[0] =~ m/\n/ and badcfg f_
+ "value for config option %s (in %s git config) contains newline(s)!",
+ $c, $src;
return $l->[0];
}
return undef;
__ "(nominal) distro being accessed");
}
+sub check_bpd_exists () {
+ stat $buildproductsdir
+ or fail f_ "build-products-dir %s is not accessible: %s\n",
+ $buildproductsdir, $!;
+}
+
+sub dotdot_bpd_transfer_origs ($$$) {
+ my ($bpd_abs, $upstreamversion, $wanted) = @_;
+ # checks is_orig_file_of_vsn and if
+ # calls $wanted->{$leaf} and expects boolish
+
+ return if $buildproductsdir eq '..';
+
+ my $warned;
+ my $dotdot = $maindir;
+ $dotdot =~ s{/[^/]+$}{};
+ opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
+ while ($!=0, defined(my $leaf = readdir DD)) {
+ {
+ local ($debuglevel) = $debuglevel-1;
+ printdebug "DD_BPD $leaf ?\n";
+ }
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ next unless $wanted->($leaf);
+ next if lstat "$bpd_abs/$leaf";
+
+ print STDERR f_
+ "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
+ $us
+ unless $warned++;
+ $! == &ENOENT or fail f_
+ "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
+ lstat "$dotdot/$leaf" or fail f_
+ "check orig file %s in ..: %s", $leaf, $!;
+ if (-l _) {
+ stat "$dotdot/$leaf" or fail f_
+ "check targe of orig symlink %s in ..: %s", $leaf, $!;
+ my $ltarget = readlink "$dotdot/$leaf" or
+ die "readlink $dotdot/$leaf: $!";
+ if ($ltarget !~ m{^/}) {
+ $ltarget = "$dotdot/$ltarget";
+ }
+ symlink $ltarget, "$bpd_abs/$leaf"
+ or die "$ltarget $bpd_abs $leaf: $!";
+ print STDERR f_
+ "%s: cloned orig symlink from ..: %s\n",
+ $us, $leaf;
+ } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
+ print STDERR f_
+ "%s: hardlinked orig from ..: %s\n",
+ $us, $leaf;
+ } elsif ($! != EXDEV) {
+ fail f_ "failed to make %s a hardlink to %s: %s",
+ "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
+ } else {
+ symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
+ or die "$bpd_abs $dotdot $leaf $!";
+ print STDERR f_
+ "%s: symmlinked orig from .. on other filesystem: %s\n",
+ $us, $leaf;
+ }
+ }
+ die "$dotdot; $!" if $!;
+ closedir DD;
+}
+
sub generate_commits_from_dsc () {
# See big comment in fetch_from_archive, below.
# See also README.dsc-import.
prep_ud();
changedir $playground;
+ my $bpd_abs = bpd_abs();
+ my $upstreamv = upstreamversion $dsc->{version};
my @dfi = dsc_files_info();
+
+ dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
+ sub { grep { $_->{Filename} eq $_[0] } @dfi };
+
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
- my $upper_f = (bpd_abs()."/$f");
+ my $upper_f = "$bpd_abs/$f";
printdebug "considering reusing $f: ";
# from the debian/changelog, so we record the tree objects now and
# make them into commits later.
my @tartrees;
- my $upstreamv = upstreamversion $dsc->{version};
my $orig_f_base = srcfn $upstreamv, '';
foreach my $fi (@dfi) {
}
sub fetch_from_archive () {
+ check_bpd_exists();
ensure_setup_existing_tree();
# Ensures that lrref() is what is actually in the archive, one way
}
printdebug "clone main body\n";
- canonicalise_suite();
- my $hasgit = check_for_git();
mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
changedir $dstdir;
+ check_bpd_exists();
+
+ canonicalise_suite();
+ my $hasgit = check_for_git();
+
runcmd @git, qw(init -q);
record_maindir();
setup_new_tree();
}
}
+ my @cmd = (@git, qw(status -uall --ignored --porcelain));
+ push @cmd, qw(debian/source/format debian/source/options);
+ push @cmd, @forbid;
+
+ my $bad = cmdoutput @cmd;
+ if (length $bad) {
+ fail +(__
+ "you have uncommitted changes to critical files, cannot continue:\n").
+ $bad;
+ }
+
return if $includedirty;
git_check_unmodified();
# calls $fn->($leafname);
my $bpd_abs = bpd_abs();
+
+ dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
+
opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
- while ($!=0, defined(my $b = readdir QFD)) {
- my $f = bpd_abs()."/".$b;
+ while ($!=0, defined(my $leaf = readdir QFD)) {
+ my $f = bpd_abs()."/".$leaf;
{
local ($debuglevel) = $debuglevel-1;
- printdebug "QF linkorigs $b, $f ?\n";
+ printdebug "QF linkorigs bpd $leaf, $f ?\n";
}
- next unless is_orig_file_of_vsn $b, $upstreamversion;
- printdebug "QF linkorigs $b, $f Y\n";
- link_ltarget $f, $b or die "$b $!";
- $fn->($b);
+ next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+ printdebug "QF linkorigs $leaf, $f Y\n";
+ link_ltarget $f, $leaf or die "$leaf $!";
+ $fn->($leaf);
}
die "$buildproductsdir: $!" if $!;
closedir QFD;
END
my $dscaddfile=sub {
- my ($b) = @_;
+ my ($leaf) = @_;
my $md = new Digest::MD5;
- my $fh = new IO::File $b, '<' or die "$b $!";
+ my $fh = new IO::File $leaf, '<' or die "$leaf $!";
stat $fh or confess $!;
my $size = -s _;
$md->addfile($fh);
- print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
+ print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess $!;
};
unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
};
my @dl;
- foreach my $b (qw(01 02)) {
+ foreach my $bits (qw(01 02)) {
foreach my $v (qw(O2H O2A H2A)) {
- push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
+ push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
}
}
printdebug "differences \@dl @dl.\n";
#----- other building -----
-our $clean_using_builder;
-# ^ tree is to be cleaned by dpkg-source's builtin idea that it should
-# clean the tree before building (perhaps invoked indirectly by
-# whatever we are using to run the build), rather than separately
-# and explicitly by us.
+sub clean_tree_check_git ($$$) {
+ my ($honour_ignores, $message, $ignmessage) = @_;
+ my @cmd = (@git, qw(clean -dn));
+ push @cmd, qw(-x) unless $honour_ignores;
+ my $leftovers = cmdoutput @cmd;
+ if (length $leftovers) {
+ print STDERR $leftovers, "\n" or confess $!;
+ $message .= $ignmessage if $honour_ignores;
+ fail $message;
+ }
+}
+
+sub clean_tree_check_git_wd ($) {
+ my ($message) = @_;
+ return if $cleanmode =~ m{no-check};
+ return if $patches_applied_dirtily; # yuk
+ clean_tree_check_git +($cleanmode !~ m{all-check}),
+ $message, "\n".__ <<END;
+If this is just missing .gitignore entries, use a different clean
+mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
+or --clean=git (-wg/-wgf) to use \`git clean' instead.
+END
+}
+
+sub clean_tree_check () {
+ # This function needs to not care about modified but tracked files.
+ # That was done by check_not_dirty, and by now we may have run
+ # the rules clean target which might modify tracked files (!)
+ if ($cleanmode =~ m{^check}) {
+ clean_tree_check_git +($cleanmode =~ m{ignores}), __
+ "tree contains uncommitted files and --clean=check specified", '';
+ } elsif ($cleanmode =~ m{^dpkg-source}) {
+ clean_tree_check_git_wd __
+ "tree contains uncommitted files (NB dgit didn't run rules clean)";
+ } elsif ($cleanmode =~ m{^git}) {
+ clean_tree_check_git 1, __
+ "tree contains uncommited, untracked, unignored files\n".
+ "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
+ } elsif ($cleanmode eq 'none') {
+ } else {
+ confess "$cleanmode ?";
+ }
+}
sub clean_tree () {
- return if $clean_using_builder;
- if ($cleanmode eq 'dpkg-source') {
- maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
- } elsif ($cleanmode eq 'dpkg-source-d') {
+ # We always clean the tree ourselves, rather than leave it to the
+ # builder (dpkg-source, or soemthing which calls dpkg-source).
+ if ($cleanmode =~ m{^dpkg-source}) {
+ my @cmd = @dpkgbuildpackage;
+ push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
+ push @cmd, qw(-T clean);
maybe_apply_patches_dirtily();
- runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
- } elsif ($cleanmode eq 'git') {
+ runcmd_ordryrun_local @cmd;
+ clean_tree_check_git_wd __
+ "tree contains uncommitted files (after running rules clean)";
+ } elsif ($cleanmode =~ m{^git(?!-)}) {
runcmd_ordryrun_local @git, qw(clean -xdf);
- } elsif ($cleanmode eq 'git-ff') {
+ } elsif ($cleanmode =~ m{^git-ff}) {
runcmd_ordryrun_local @git, qw(clean -xdff);
- } elsif ($cleanmode eq 'check') {
- my $leftovers = cmdoutput @git, qw(clean -xdn);
- if (length $leftovers) {
- print STDERR $leftovers, "\n" or confess $!;
- fail __
- "tree contains uncommitted files and --clean=check specified";
- }
+ } elsif ($cleanmode =~ m{^check}) {
+ clean_tree_check();
} elsif ($cleanmode eq 'none') {
} else {
- die "$cleanmode ?";
+ confess "$cleanmode ?";
}
}
sub build_prep ($) {
my ($wantsrc) = @_;
build_prep_early();
- # clean the tree if we're trying to include dirty changes in the
- # source package, or we are running the builder in $maindir
- clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
+ check_bpd_exists();
+ if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
+ # Clean the tree because we're going to use the contents of
+ # $maindir. (We trying to include dirty changes in the source
+ # package, or we are running the builder in $maindir.)
+ || $cleanmode =~ m{always}) {
+ # Or because the user asked us to.
+ clean_tree();
+ } else {
+ # We don't actually need to do anything in $maindir, but we
+ # should do some kind of cleanliness check because (i) the
+ # user may have forgotten a `git add', and (ii) if the user
+ # said -wc we should still do the check.
+ clean_tree_check();
+ }
build_maybe_quilt_fixup();
if ($rmchanges) {
my $pat = changespat $version;
build_source();
midbuild_checkchanges_vanilla $wantsrc;
} else {
- if (!$clean_using_builder) {
- push @cmd, '--git-cleaner=true';
- }
+ push @cmd, '--git-cleaner=true';
}
maybe_unapply_patches_again();
if ($wantsrc & WANTSRC_BUILDER) {
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
+ # We transfer all the pieces of the dsc to the bpd, not just
+ # origs. This is by analogy with dgit fetch, which wants to
+ # keep them somewhere to avoid downloading them again.
+ # We make symlinks, though. If the user wants copies, then
+ # they can copy the parts of the dsc to the bpd using dcmd,
+ # or something.
my $here = "$buildproductsdir/$f";
if (lstat $here) {
- next if stat $here;
+ if (stat $here) {
+ next;
+ }
fail f_ "lstat %s works but stat gives %s !", $here, $!;
}
fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
+ # $f does not exist in bpd, we need to transfer it
my $there = $dscfn;
- if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
- $there = $';
- } elsif ($dscfn =~ m#^/#) {
- $there = $dscfn;
+ $there =~ s{[^/]+$}{$f} or confess "$there ?";
+ # $there is file we want, relative to user's cwd, or abs
+ printdebug "not in bpd, $f, test $there ...\n";
+ stat $there or fail f_
+ "import %s requires %s, but: %s", $dscfn, $there, $!;
+ if ($there =~ m#^(?:\./+)?\.\./+#) {
+ # $there is relative to user's cwd
+ my $there_from_parent = $';
+ if ($buildproductsdir !~ m{^/}) {
+ # abs2rel, despite its name, can take two relative paths
+ $there = File::Spec->abs2rel($there,$buildproductsdir);
+ # now $there is relative to bpd, great
+ } else {
+ $there = (dirname $maindir)."/$there_from_parent";
+ # now $there is absoute
+ }
+ } elsif ($there =~ m#^/#) {
+ # $there is absolute already
} else {
fail f_
"cannot import %s which seems to be inside working tree!",
$dscfn;
}
- $there =~ s#/+[^/]+$## or fail f_
- "import %s requires .../%s, but it does not exist",
- $dscfn, $f;
- $there .= "/$f";
- my $test = $there =~ m{^/} ? $there : "../$there";
- stat $test or fail f_
- "import %s requires %s, but: %s", $dscfn, $test, $!;
symlink $there, $here or fail f_
"symlink %s to %s: %s", $there, $here, $!;
progress f_ "made symlink %s -> %s", $here, $there;
($om = $opts_opt_map{$1})) {
push @ropts, $_;
push @$om, $2;
+ } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
+ !$opts_opt_cmdonly{$1} &&
+ ($om = $opts_opt_map{$1})) {
+ push @ropts, $_;
+ my $cmd = shift @$om;
+ @$om = ($cmd, grep { $_ ne $2 } @$om);
} elsif (m/^--(gbp|dpm)$/s) {
push @ropts, "--quilt=$1";
$quilt_mode = $1;
} elsif (s/^-wn$//s) {
push @ropts, $&;
$cleanmode = 'none';
- } elsif (s/^-wg$//s) {
+ } elsif (s/^-wg(f?)(a?)$//s) {
push @ropts, $&;
$cleanmode = 'git';
- } elsif (s/^-wgf$//s) {
- push @ropts, $&;
- $cleanmode = 'git-ff';
- } elsif (s/^-wd$//s) {
+ $cleanmode .= '-ff' if $1;
+ $cleanmode .= ',always' if $2;
+ } elsif (s/^-wd(d?)([na]?)$//s) {
push @ropts, $&;
$cleanmode = 'dpkg-source';
- } elsif (s/^-wdd$//s) {
- push @ropts, $&;
- $cleanmode = 'dpkg-source-d';
+ $cleanmode .= '-d' if $1;
+ $cleanmode .= ',no-check' if $2 eq 'n';
+ $cleanmode .= ',all-check' if $2 eq 'a';
} elsif (s/^-wc$//s) {
push @ropts, $&;
$cleanmode = 'check';
+ } elsif (s/^-wci$//s) {
+ push @ropts, $&;
+ $cleanmode = 'check,ignores';
} elsif (s/^-c([^=]*)\=(.*)$//s) {
push @git, '-c', $&;
$gitcfgs{cmdline}{$1} = [ $2 ];
if (!defined $cleanmode) {
local $access_forpush;
- $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
+ $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
+ $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
+
+ $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
$cleanmode //= 'dpkg-source';
badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
- $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
+ $cleanmode =~ m/$cleanmode_re/;
}
$buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
~ianmdlvl / dgit.git / blobdiff