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,
} keys %opts_opt_map;
sub parseopts_late_defaults();
+sub quiltify_trees_differ ($$;$$$);
sub setup_gitattrs(;$);
sub check_gitattrs($$);
}
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;
}
return 0;
}
if ($tip_patches eq '' and
- !defined git_cat_file "$walk:debian") {
+ !defined git_cat_file "$walk~:debian" and
+ !quiltify_trees_differ "$walk~", $walk
+ ) {
# (gdr classification of parent: BreakwaterStart
printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
return 1;
my $got = read PF, $d, 65536;
die "$ourfn: $!" unless defined $got;
last if !$got;
- print $fh "data-block ".length($d)."\n" or confess $!;
- print $fh $d or confess $!;
+ print $fh "data-block ".length($d)."\n" or confess "$!";
+ print $fh $d or confess "$!";
}
PF->error and die "$ourfn $!";
- print $fh "data-end\n" or confess $!;
+ print $fh "data-end\n" or confess "$!";
close PF;
}
} $fh;
last unless $y;
my $d = protocol_read_bytes $fh, $l;
- print PF $d or confess $!;
+ print PF $d or confess "$!";
}
- close PF or confess $!;
+ close PF or confess "$!";
}
#---------- remote protocol support, responder ----------
return unless $we_are_responder;
# called even without $we_are_responder
printdebug ">> $command\n";
- print PO $command, "\n" or confess $!;
+ print PO $command, "\n" or confess "$!";
}
sub responder_send_file ($$) {
sub progress {
if ($we_are_responder) {
my $m = join '', @_;
- responder_send_command "progress ".length($m) or confess $!;
- print PO $m or confess $!;
+ responder_send_command "progress ".length($m) or confess "$!";
+ print PO $m or confess "$!";
} else {
print @_, "\n";
}
}
my $what = $_[$#_];
progress "downloading $what...";
- my $r = $ua->get(@_) or confess $!;
+ my $r = $ua->get(@_) or confess "$!";
return undef if $r->code == 404;
$r->is_success or fail f_ "failed to fetch %s: %s",
$what, $r->status_line;
END
sub badusage {
- print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess $!;
+ print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
finish 8;
}
not_necessarily_a_tree();
}
sub cmd_help () {
- print __ $helpmsg or confess $!;
+ print __ $helpmsg or confess "$!";
finish 0;
}
@$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;
return;
} elsif ($protovsn >= 3) {
responder_send_command "supplementary-message ".length($msg)
- or confess $!;
- print PO $msg or confess $!;
+ or confess "$!";
+ print PO $msg or confess "$!";
}
}
}
sub parse_dscdata () {
- my $dscfh = new IO::File \$dscdata, '<' or confess $!;
+ my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
printdebug Dumper($dscdata) if $debuglevel>1;
$dsc = parsecontrolfh($dscfh,$dscurl,1);
printdebug Dumper($dsc) if $debuglevel>1;
cfg_apply_map(\$aptsuites, 'suite map',
access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
- open SRCS, ">", "$aptget_base/$sourceslist" or confess $!;
+ open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
printf SRCS "deb-src %s %s %s\n",
access_cfg('mirror'),
$aptsuites,
access_cfg('aptget-components')
- or confess $!;
+ or confess "$!";
ensuredir "$aptget_base/cache";
ensuredir "$aptget_base/lists";
- open CONF, ">", $aptget_configpath or confess $!;
+ open CONF, ">", $aptget_configpath or confess "$!";
print CONF <<END;
Debug::NoLocking "true";
APT::Get::List-Cleanup "false";
Dir::Etc::preferencesparts
)) {
ensuredir "$aptget_base/$key";
- print CONF "$key \"$quoted_base/$key\";\n" or confess $!;
+ print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
};
- my $oldatime = (time // confess $!) - 1;
+ my $oldatime = (time // confess "$!") - 1;
foreach my $oldlist (<$aptget_base/lists/*Release>) {
next unless stat_exists $oldlist;
my ($mtime) = (stat _)[9];
my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
qw(x), $mirror, @$argl);
debugcmd "-|", @cmd;
- open FIA, "-|", @cmd or confess $!;
+ open FIA, "-|", @cmd or confess "$!";
my $r = $fn->();
close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
return $r;
" export LC_MESSAGES=C; export LC_CTYPE=C;".
" ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
debugcmd "|",@cmd;
- open P, "-|", @cmd or confess $!;
+ open P, "-|", @cmd or confess "$!";
while (<P>) {
chomp or die;
printdebug(">|$_|\n");
my ($what) = @_;
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
- open GITS, "-|", @gitscmd or confess $!;
+ open GITS, "-|", @gitscmd or confess "$!";
{
local $/="\0";
while (<GITS>) {
__ "(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 target 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: ";
printdebug "considering saving $f: ";
- if (link $f, $upper_f) {
+ if (rename_link_xf 1, $f, $upper_f) {
printdebug "linked.\n";
- } elsif ((printdebug "($!) "),
+ } elsif ((printdebug "($@) "),
$! != EEXIST) {
- fail f_ "saving %s: %s", "$buildproductsdir/$f", $!;
+ fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
} elsif (!$refetched) {
printdebug "no need.\n";
- } elsif (link $f, "$upper_f,fetch") {
+ } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
printdebug "linked (using ...,fetch).\n";
- } elsif ((printdebug "($!) "),
+ } elsif ((printdebug "($@) "),
$! != EEXIST) {
- fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $!;
+ fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
} else {
printdebug "cannot.\n";
}
# 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) {
new Dpkg::Compression::Process compression => $cname;
@compr_cmd = $compr_proc->get_uncompress_cmdline();
my $compr_fh = new IO::Handle;
- my $compr_pid = open $compr_fh, "-|" // confess $!;
+ my $compr_pid = open $compr_fh, "-|" // confess "$!";
if (!$compr_pid) {
- open STDIN, "<&", $input or confess $!;
+ open STDIN, "<&", $input or confess "$!";
exec @compr_cmd;
die "dgit (child): exec $compr_cmd[0]: $!\n";
}
}
rmtree "_unpack-tar";
- mkdir "_unpack-tar" or confess $!;
+ mkdir "_unpack-tar" or confess "$!";
my @tarcmd = qw(tar -x -f -
--no-same-owner --no-same-permissions
--no-acls --no-xattrs --no-selinux);
- my $tar_pid = fork // confess $!;
+ my $tar_pid = fork // confess "$!";
if (!$tar_pid) {
- chdir "_unpack-tar" or confess $!;
- open STDIN, "<&", $input or confess $!;
+ chdir "_unpack-tar" or confess "$!";
+ open STDIN, "<&", $input or confess "$!";
exec @tarcmd;
die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
}
- $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
+ $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
!$? or failedcmd @tarcmd;
close $input or
(@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
- : confess $!);
+ : confess "$!");
# finally, we have the results in "tarball", but maybe
# with the wrong permissions
printdebug "import main commit\n";
- open C, ">../commit.tmp" or confess $!;
- print C <<END or confess $!;
+ open C, ">../commit.tmp" or confess "$!";
+ print C <<END or confess "$!";
tree $tree
END
- print C <<END or confess $! foreach @tartrees;
+ print C <<END or confess "$!" foreach @tartrees;
parent $_->{Commit}
END
- print C <<END or confess $!;
+ print C <<END or confess "$!";
author $authline
committer $authline
[dgit import $treeimporthow $package $cversion]
END
- close C or confess $!;
+ close C or confess "$!";
my $rawimport_hash = make_commit qw(../commit.tmp);
if (madformat $dsc->{format}) {
progress f_ "%s: trying slow absurd-git-apply...", $us;
rename "../../gbp-pq-output","../../gbp-pq-output.0"
or $!==ENOENT
- or confess $!;
+ or confess "$!";
}
eval {
die "forbid absurd git-apply\n" if $use_absurd
Last version pushed with dgit: %s (newer or same)
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
@output = $lastpush_mergeinput;
} else {
# Same version. Use what's in the server git branch,
open F, "<", "$tf" or die "$tf: $!";
$fi->{Digester}->reset();
$fi->{Digester}->addfile(*F);
- F->error and confess $!;
+ F->error and confess "$!";
$got = $fi->{Digester}->hexdigest();
return $got eq $fi->{Hash};
};
debugcmd "|",@lcmd;
my %wantr;
- open GITLS, "-|", @lcmd or confess $!;
+ open GITLS, "-|", @lcmd or confess "$!";
while (<GITLS>) {
printdebug "=> ", $_;
m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
}
sub fetch_from_archive () {
+ check_bpd_exists();
ensure_setup_existing_tree();
# Ensures that lrref() is what is actually in the archive, one way
printdebug "del_lrfetchrefs: $objid $fullrefname\n";
if (!$gur) {
$gur ||= new IO::Handle;
- open $gur, "|-", qw(git update-ref --stdin) or confess $!;
+ open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
}
printf $gur "delete %s %s\n", $fullrefname, $objid;
}
Last version pushed with dgit: %s
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
@mergeinputs = ($lastpush_mergeinput);
} else {
# Archive has .dsc which is not a descendant of the last dgit
Package not found in the archive, but has allegedly been pushed using dgit.
%s
END
- __ $later_warning_msg or confess $!;
+ __ $later_warning_msg or confess "$!";
} else {
printdebug "nothing found!\n";
if (defined $skew_warning_vsn) {
- print STDERR f_ <<END, $skew_warning_vsn or confess $!;
+ print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
Warning: relevant archive skew detected.
Archive allegedly contains %s
my $mcf = dgit_privdir()."/mergecommit";
open MC, ">", $mcf or die "$mcf $!";
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
tree $tree
END
my @parents = grep { $_->{Commit} } @mergeinputs;
@parents = reverse @parents if $compat_info->{ReverseParents};
- print MC <<END or confess $! foreach @parents;
+ print MC <<END or confess "$!" foreach @parents;
parent $_->{Commit}
END
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
author $author
committer $author
END
if (defined $compat_info->{Message}) {
- print MC $compat_info->{Message} or confess $!;
+ print MC $compat_info->{Message} or confess "$!";
} else {
- print MC f_ <<END, $package, $cversion, $csuite or confess $!;
+ print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
Record %s (%s) in archive suite %s
Record that
my ($mi) = (@_);
my $mversion = mergeinfo_version $mi;
printf MC " %-20s %s\n", $mversion, $mi->{Info}
- or confess $!;
+ or confess "$!";
};
$message_add_info->($mergeinputs[0]);
- print MC __ <<END or confess $!;
+ print MC __ <<END or confess "$!";
should be treated as descended from
END
$message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
}
- close MC or confess $!;
+ close MC or confess "$!";
$hash = make_commit $mcf;
} else {
$hash = $mergeinputs[0]{Commit};
my $got_vsn = getfield $gotclogp, 'Version';
printdebug "SKEW CHECK GOT $got_vsn\n";
if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
- print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
+ print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
Warning: archive skew detected. Using the available version:
Archive allegedly contains %s
while (<ATTRS>) {
chomp;
next if m{^debian/changelog\s};
- print NATTRS $_, "\n" or confess $!;
+ print NATTRS $_, "\n" or confess "$!";
}
- ATTRS->error and confess $!;
+ ATTRS->error and confess "$!";
close ATTRS;
}
- print NATTRS "debian/changelog merge=$driver\n" or confess $!;
+ print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
close NATTRS;
set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
printdebug "is_gitattrs_setup: found old macro\n";
return 0;
}
- $gai->error and confess $!;
+ $gai->error and confess "$!";
printdebug "is_gitattrs_setup: found nothing\n";
return undef;
}
my $af = "$maindir_gitcommon/info/attributes";
ensuredir "$maindir_gitcommon/info";
- open GAO, "> $af.new" or confess $!;
- print GAO <<END, __ <<ENDT or confess $! unless defined $already;
+ open GAO, "> $af.new" or confess "$!";
+ print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
* dgit-defuse-attrs
$new
END
$_ = $new;
}
chomp;
- print GAO $_, "\n" or confess $!;
+ print GAO $_, "\n" or confess "$!";
}
- $gai->error and confess $!;
+ $gai->error and confess "$!";
}
- close GAO or confess $!;
+ close GAO or confess "$!";
rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
}
my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
debugcmd "|",@cmd;
my $gafl = new IO::File;
- open $gafl, "-|", @cmd or confess $!;
+ open $gafl, "-|", @cmd or confess "$!";
while (<$gafl>) {
chomp or die;
s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
# in child, sets things up, calls $fn->(), and returns undef
# in parent, returns canonical suite name for $tsuite
my $canonsuitefh = IO::File::new_tmpfile;
- my $pid = fork // confess $!;
+ my $pid = fork // confess "$!";
if (!$pid) {
forkcheck_setup();
$isuite = $tsuite;
$debugprefix .= " ";
progress f_ "fetching %s...", $tsuite;
canonicalise_suite();
- print $canonsuitefh $csuite, "\n" or confess $!;
- close $canonsuitefh or confess $!;
+ print $canonsuitefh $csuite, "\n" or confess "$!";
+ close $canonsuitefh or confess "$!";
$fn->();
return undef;
}
- waitpid $pid,0 == $pid or confess $!;
+ waitpid $pid,0 == $pid or confess "$!";
fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
if $? && $?!=256*4;
- seek $canonsuitefh,0,0 or confess $!;
+ seek $canonsuitefh,0,0 or confess "$!";
local $csuite = <$canonsuitefh>;
- confess $! unless defined $csuite && chomp $csuite;
+ confess "$!" unless defined $csuite && chomp $csuite;
if ($? == 256*4) {
printdebug "multisuite $tsuite missing\n";
return $csuite;
}
sub clone_set_head () {
- open H, "> .git/HEAD" or confess $!;
- print H "ref: ".lref()."\n" or confess $!;
- close H or confess $!;
+ open H, "> .git/HEAD" or confess "$!";
+ print H "ref: ".lref()."\n" or confess "$!";
+ close H or confess "$!";
}
sub clone_finish ($) {
my ($dstdir) = @_;
}
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();
}
sub check_not_dirty () {
- foreach my $f (qw(local-options local-patch-header)) {
- if (stat_exists "debian/source/$f") {
- fail f_ "git tree contains debian/source/%s", $f;
+ my @forbid = qw(local-options local-patch-header);
+ @forbid = map { "debian/source/$_" } @forbid;
+ foreach my $f (@forbid) {
+ if (stat_exists $f) {
+ fail f_ "git tree contains %s", $f;
}
}
+ 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();
$options{$_} = 1;
}
}
- F->error and confess $!;
+ F->error and confess "$!";
close F;
} else {
- confess $! unless $!==&ENOENT;
+ confess "$!" unless $!==&ENOENT;
}
if (!open F, "debian/source/format") {
- confess $! unless $!==&ENOENT;
+ confess "$!" unless $!==&ENOENT;
return '';
}
$_ = <F>;
- F->error and confess $!;
+ F->error and confess "$!";
chomp;
return ($_, \%options);
}
# git rev-list --first-parent DTRT.
my $pmf = dgit_privdir()."/pseudomerge";
open MC, ">", $pmf or die "$pmf $!";
- print MC <<END or confess $!;
+ print MC <<END or confess "$!";
tree $tree
parent $dgitview
parent $archive_hash
[$msg_cmd]
END
- close MC or confess $!;
+ close MC or confess "$!";
return make_commit($pmf);
}
$dsc->{$ourdscfield[0]} = join " ",
$tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
$reader_giturl;
- $dsc->save("$dscfn.tmp") or confess $!;
+ $dsc->save("$dscfn.tmp") or confess "$!";
my $changes = parsecontrol($changesfile,$changesfilewhat);
foreach my $field (qw(Source Distribution Version)) {
my $head = $tw->{Objid};
my $tag = $tw->{Tag};
- open TO, '>', $tfn->('.tmp') or confess $!;
- print TO <<END or confess $!;
+ open TO, '>', $tfn->('.tmp') or confess "$!";
+ print TO <<END or confess "$!";
object $head
type commit
tag $tag
print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
%s release %s for %s (%s) [dgit]
ENDT
- or confess $!;
- print TO <<END or confess $!;
+ or confess "$!";
+ print TO <<END or confess "$!";
[dgit distro=$declaredistro$delibs]
END
foreach my $ref (sort keys %previously) {
- print TO <<END or confess $!;
+ print TO <<END or confess "$!";
[dgit previously:$ref=$previously{$ref}]
END
}
(maintainer view tag generated by dgit --quilt=%s)
END
$quilt_mode
- or confess $!;
+ or confess "$!";
} else {
confess Dumper($tw)."?";
}
- close TO or confess $!;
+ close TO or confess "$!";
my $tagobjfn = $tfn->('.tmp');
if ($sign) {
if (!defined $keyid) {
$keyid = getfield $clogp, 'Maintainer';
}
- unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
+ unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
my @sign_cmd = (@gpg, qw(--detach-sign --armor));
push @sign_cmd, qw(-u),$keyid if defined $keyid;
push @sign_cmd, $tfn->('.tmp');
$we_are_responder = 1;
$us .= " (build host)";
- open PI, "<&STDIN" or confess $!;
- open STDIN, "/dev/null" or confess $!;
- open PO, ">&STDOUT" or confess $!;
+ open PI, "<&STDIN" or confess "$!";
+ open STDIN, "/dev/null" or confess "$!";
+ open PO, ">&STDOUT" or confess "$!";
autoflush PO 1;
- open STDOUT, ">&STDERR" or confess $!;
+ open STDOUT, ">&STDERR" or confess "$!";
autoflush STDOUT 1;
$vsnwant //= 1;
$i_child_pid = undef; # prevents killing some other process with same pid
printdebug "waiting for build host child $pid...\n";
my $got = waitpid $pid, 0;
- confess $! unless $got == $pid;
+ confess "$!" unless $got == $pid;
fail f_ "build host child failed: %s", waitstatusmsg() if $?;
i_cleanup();
foreach my $localpath (@localpaths) {
protocol_send_file \*RI, $localpath;
}
- print RI "files-end\n" or confess $!;
+ print RI "files-end\n" or confess "$!";
}
our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
my $descfn = ".git/dgit/quilt-description.tmp";
open O, '>', $descfn or confess "$descfn: $!";
$msg =~ s/\n+/\n\n/;
- print O <<END or confess $!;
+ print O <<END or confess "$!";
From: $author
${xinfo}Subject: $msg
---
END
- close O or confess $!;
+ close O or confess "$!";
{
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
close GIPATCH or die "$gipatch: $!";
runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
$unapplied, $headref, "--", sort keys %$editedignores;
- open SERIES, "+>>", "debian/patches/series" or confess $!;
- defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
+ open SERIES, "+>>", "debian/patches/series" or confess "$!";
+ defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
my $newline;
- defined read SERIES, $newline, 1 or confess $!;
- print SERIES "\n" or confess $! unless $newline eq "\n";
- print SERIES "auto-gitignore\n" or confess $!;
+ defined read SERIES, $newline, 1 or confess "$!";
+ print SERIES "\n" or confess "$!" unless $newline eq "\n";
+ print SERIES "auto-gitignore\n" or confess "$!";
close SERIES or die $!;
runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
commit_admin +(__ <<END).<<ENDU
printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
my @cmd= (@git, qw(diff-tree -r --name-only),
- $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
+ $p->{Commit},$c->{Commit},
+ qw(-- debian/patches .pc debian/source/format));
my $patchstackchange = cmdoutput @cmd;
if (length $patchstackchange) {
$patchstackchange =~ s/\n/,/g;
sub unpack_playtree_mkwork ($) {
my ($headref) = @_;
- mkdir "work" or confess $!;
+ mkdir "work" or confess "$!";
changedir "work";
mktree_in_ud_here();
runcmd @git, qw(reset -q --hard), $headref;
# 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;
changedir "..";
runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
rename srcfn("$upstreamversion", "/debian/patches"),
- "work/debian/patches";
+ "work/debian/patches"
+ or $!==ENOENT
+ or confess "install d/patches: $!";
changedir "work";
commit_quilty_patch();
my $fakeversion="$upstreamversion-~~DGITFAKE";
- my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
- print $fakedsc <<END or confess $!;
+ my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
+ print $fakedsc <<END or confess "$!";
Format: 3.0 (quilt)
Source: $package
Version: $fakeversion
END
my $dscaddfile=sub {
- my ($b) = @_;
+ my ($leaf) = @_;
my $md = new Digest::MD5;
- my $fh = new IO::File $b, '<' or die "$b $!";
- stat $fh or confess $!;
+ 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);
runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
$dscaddfile->($debtar);
- close $fakedsc or confess $!;
+ close $fakedsc or confess "$!";
}
sub quilt_fakedsc2unapplied ($$) {
progress __ "Tree already contains .pc - will use it then delete it.";
$mustdeletepc=1;
} else {
- rename '../fake/.pc','.pc' or confess $!;
+ rename '../fake/.pc','.pc' or confess "$!";
}
changedir '../fake';
};
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";
quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
if (!open P, '>>', ".pc/applied-patches") {
- $!==&ENOENT or confess $!;
+ $!==&ENOENT or confess "$!";
} else {
close P;
}
open I2, '<', $editing or confess "$editing: $!";
unlink $editing or confess "$editing: $!";
open O, '>', $editing or confess "$editing: $!";
- while (<I1>) { print O or confess $!; } I1->error and confess $!;
+ while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
my $copying = 0;
while (<I2>) {
$copying ||= m/^\-\-\- /;
next unless $copying;
- print O or confess $!;
+ print O or confess "$!";
}
- I2->error and confess $!;
+ I2->error and confess "$!";
close O or die $1;
finish 0;
}
sub maybe_apply_patches_dirtily () {
return unless $quilt_mode =~ m/gbp|unapplied/;
- print STDERR __ <<END or confess $!;
+ print STDERR __ <<END or confess "$!";
dgit: Building, or cleaning with rules target, in patches-unapplied tree.
dgit: Have to apply the patches - making the tree dirty.
#----- 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') {
+ # 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(-T clean);
- } elsif ($cleanmode eq 'dpkg-source-d') {
- 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;
"@changesfiles";
}
printdone f_ "build successful, results in %s\n", $result
- or confess $!;
+ or confess "$!";
}
sub midbuild_checkchanges () {
if ($gbp_make_orig) {
my $priv = dgit_privdir();
my $ok = "$priv/origs-gen-ok";
- unlink $ok or $!==&ENOENT or confess $!;
+ unlink $ok or $!==&ENOENT or confess "$!";
my @origs_cmd = @cmd;
push @origs_cmd, qw(--git-cleaner=true);
push @origs_cmd, "--git-prebuild=".
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) {
}
} else {
$leafdir = basename $maindir;
+
+ if ($buildproductsdir ne '..') {
+ # Well, we are going to run dpkg-source -b which consumes
+ # origs from .. and generates output there. To make this
+ # work when the bpd is not .. , we would have to (i) link
+ # origs from bpd to .. , (ii) check for files that
+ # dpkg-source -b would/might overwrite, and afterwards
+ # (iii) move all the outputs back to the bpd (iv) except
+ # for the origs which should be deleted from .. if they
+ # weren't there beforehand. And if there is an error and
+ # we don't run to completion we would necessarily leave a
+ # mess. This is too much. The real way to fix this
+ # is for dpkg-source to have bpd support.
+ confess unless $includedirty;
+ fail __
+ "--include-dirty not supported with --build-products-dir, sorry";
+ }
+
changedir '..';
}
runcmd_ordryrun_local @cmd, $leafdir;
my $mv = sub {
my ($why, $l) = @_;
printdebug " renaming ($why) $l\n";
- rename "$l", bpd_abs()."/$l"
- or fail f_ "put in place new built file (%s): %s", $l, $!;
+ rename_link_xf 0, "$l", bpd_abs()."/$l"
+ or fail f_ "put in place new built file (%s): %s", $l, $@;
};
foreach my $l (split /\n/, getfield $dsc, 'Files') {
$l =~ m/\S+$/ or next;
my $uv = upstreamversion $version;
quilt_make_fake_dsc($uv);
my $u = quilt_fakedsc2unapplied($headref, $uv);
- print $u, "\n" or confess $!;
+ print $u, "\n" or confess "$!";
}
sub import_dsc_result {
fail f_ <<END, $dsc_hash
.dsc contains Dgit field referring to object %s
Your git tree does not have that object. Try `git fetch' from a
-plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
+plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
END
}
if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
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;
+ printdebug "not in bpd, $f ...\n";
+ # $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
+ printdebug "not in bpd, $f, abs2rel, $there ...\n";
+ } else {
+ $there = (dirname $maindir)."/$there_from_parent";
+ # now $there is absoute
+ printdebug "not in bpd, $f, rel2rel, $there ...\n";
+ }
+ } elsif ($there =~ m#^/#) {
+ # $there is absolute already
+ printdebug "not in bpd, $f, abs, $there ...\n";
} 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;
"no arguments allowed to dgit print-dgit-repos-server-source-url"
if @ARGV;
my $url = repos_server_url();
- print $url, "\n" or confess $!;
+ print $url, "\n" or confess "$!";
}
sub pre_print_dpkg_source_ignores {
badusage __
"no arguments allowed to dgit print-dpkg-source-ignores"
if @ARGV;
- print "@dpkg_source_ignores\n" or confess $!;
+ print "@dpkg_source_ignores\n" or confess "$!";
}
sub cmd_setup_mergechangelogs {
#---------- argument parsing and main program ----------
sub cmd_version {
- print "dgit version $our_version\n" or confess $!;
+ print "dgit version $our_version\n" or confess "$!";
finish 0;
}
($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 ];
sub check_env_sanity () {
my $blocked = new POSIX::SigSet;
- sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
+ sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
eval {
foreach my $name (qw(PIPE CHLD)) {
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');
print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
if $dryrun_level == 1;
if (!@ARGV) {
- print STDERR __ $helpmsg or confess $!;
+ print STDERR __ $helpmsg or confess "$!";
finish 8;
}
$cmd = $subcommand = shift @ARGV;
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
-record_maindir if $invoked_in_git_tree;
+if ($invoked_in_git_tree) {
+ changedir_git_toplevel();
+ record_maindir();
+}
git_slurp_config();
my $fn = ${*::}{"cmd_$cmd"};
~ianmdlvl / dgit.git / blobdiff