summaryrefslogtreecommitdiff
path: root/Debian/Dgit.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Debian/Dgit.pm')
-rw-r--r--Debian/Dgit.pm124
1 files changed, 99 insertions, 25 deletions
diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm
index c4a61af..57b79e8 100644
--- a/Debian/Dgit.pm
+++ b/Debian/Dgit.pm
@@ -44,28 +44,33 @@ BEGIN {
server_branch server_ref
stat_exists link_ltarget
hashfile
- fail ensuredir must_getcwd executable_on_path
+ fail failmsg ensuredir must_getcwd executable_on_path
waitstatusmsg failedcmd_waitstatus
failedcmd_report_cmd failedcmd
- runcmd cmdoutput cmdoutput_errok
+ runcmd shell_cmd cmdoutput cmdoutput_errok
git_rev_parse git_cat_file
- git_get_ref git_for_each_ref
+ git_get_ref git_get_symref git_for_each_ref
git_for_each_tag_referring is_fast_fwd
+ git_check_unmodified
$package_re $component_re $deliberately_re
$distro_re $versiontag_re $series_filename_re
+ $extra_orig_namepart_re
+ $git_null_obj
$branchprefix
+ $ffq_refprefix $gdrlast_refprefix
initdebug enabledebug enabledebuglevel
printdebug debugcmd
$debugprefix *debuglevel *DEBUG
shellquote printcmd messagequote
$negate_harmful_gitattrs
changedir git_slurp_config_src
+ gdr_ffq_prev_branchinfo
playtree_setup);
# implicitly uses $main::us
%EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)],
playground => [qw(record_maindir $maindir $local_git_cfg
$maindir_gitdir $maindir_gitcommon
- fresh_playground $playground
+ fresh_playground
ensure_a_playground)]);
@EXPORT_OK = ( @{ $EXPORT_TAGS{policyflags} },
@{ $EXPORT_TAGS{playground} } );
@@ -80,6 +85,10 @@ our $distro_re = $component_re;
our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+};
our $branchprefix = 'dgit';
our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s;
+our $extra_orig_namepart_re = qr{[-0-9a-z]+};
+our $git_null_obj = '0' x 40;
+our $ffq_refprefix = 'ffq-prev';
+our $gdrlast_refprefix = 'debrebase-last';
# policy hook exit status bits
# see dgit-repos-server head comment for documentation
@@ -92,7 +101,9 @@ sub NOCOMMITCHECK () { return 0x8; }
our $debugprefix;
our $debuglevel = 0;
-our $negate_harmful_gitattrs = "-text -eol -crlf -ident -filter";
+our $negate_harmful_gitattrs =
+ "-text -eol -crlf -ident -filter -working-tree-encoding";
+ # ^ when updating this, alter the regexp in dgit:is_gitattrs_setup
our $forkcheck_mainprocess;
@@ -108,7 +119,7 @@ sub forkcheck_mainprocess () {
sub setup_sigwarn () {
forkcheck_setup();
$SIG{__WARN__} = sub {
- die $_[0] if forkcheck_mainprocess;
+ confess $_[0] if forkcheck_mainprocess;
};
}
@@ -213,12 +224,16 @@ sub _us () {
$::us // ($0 =~ m#[^/]*$#, $&);
}
-sub fail {
- my $s = "@_\n";
+sub failmsg {
+ my $s = "error: @_\n";
$s =~ s/\n\n$/\n/;
my $prefix = _us().": ";
$s =~ s/^/$prefix/gm;
- die $s;
+ return "\n".$s;
+}
+
+sub fail {
+ die failmsg @_;
}
sub ensuredir ($) {
@@ -300,6 +315,11 @@ sub runcmd {
failedcmd @_ if system @_;
}
+sub shell_cmd {
+ my ($first_shell, @cmd) = @_;
+ return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
+}
+
sub cmdoutput_errok {
confess Dumper(\@_)." ?" if grep { !defined } @_;
debugcmd "|",@_;
@@ -348,11 +368,21 @@ sub git_rev_parse ($) {
return cmdoutput qw(git rev-parse), "$_[0]~0";
}
-sub git_cat_file ($) {
- my ($objname) = @_;
+sub git_cat_file ($;$) {
+ my ($objname, $etype) = @_;
# => ($type, $data) or ('missing', undef)
# in scalar context, just the data
+ # if $etype defined, dies unless type is $etype or in @$etype
our ($gcf_pid, $gcf_i, $gcf_o);
+ my $chk = sub {
+ my ($gtype, $data) = @_;
+ if ($etype) {
+ $etype = [$etype] unless ref $etype;
+ confess "$objname expected @$etype but is $gtype"
+ unless grep { $gtype eq $_ } @$etype;
+ }
+ return ($gtype, $data);
+ };
if (!$gcf_pid) {
my @cmd = qw(git cat-file --batch);
debugcmd "GCF|", @cmd;
@@ -362,13 +392,26 @@ sub git_cat_file ($) {
print $gcf_i $objname, "\n" or die $!;
my $x = <$gcf_o>;
printdebug "GCF<| ", $x;
- if ($x =~ m/ (missing)$/) { return ($1, undef); }
+ if ($x =~ m/ (missing)$/) { return $chk->($1, undef); }
my ($type, $size) = $x =~ m/^.* (\w+) (\d+)\n/ or die "$objname ?";
my $data;
(read $gcf_o, $data, $size) == $size or die "$objname $!";
$x = <$gcf_o>;
$x eq "\n" or die "$objname ($_) $!";
- return ($type, $data);
+ return $chk->($type, $data);
+}
+
+sub git_get_symref (;$) {
+ my ($symref) = @_; $symref //= 'HEAD';
+ # => undef if not a symref, otherwise refs/...
+ my @cmd = (qw(git symbolic-ref -q HEAD));
+ my $branch = cmdoutput_errok @cmd;
+ if (!defined $branch) {
+ $?==256 or failedcmd @cmd;
+ } else {
+ chomp $branch;
+ }
+ return $branch;
}
sub git_for_each_ref ($$;$) {
@@ -418,6 +461,25 @@ sub git_for_each_tag_referring ($$) {
});
}
+sub git_check_unmodified () {
+ foreach my $cached (qw(0 1)) {
+ my @cmd = qw(git diff --quiet);
+ push @cmd, qw(--cached) if $cached;
+ push @cmd, qw(HEAD);
+ debugcmd "+",@cmd;
+ $!=0; $?=-1; system @cmd;
+ return if !$?;
+ if ($?==256) {
+ fail
+ $cached
+ ? "git index contains changes (does not match HEAD)"
+ : "working tree is dirty (does not match HEAD)";
+ } else {
+ failedcmd @cmd;
+ }
+ }
+}
+
sub is_fast_fwd ($$) {
my ($ancestor,$child) = @_;
my @cmd = (qw(git merge-base), $ancestor, $child);
@@ -460,12 +522,28 @@ sub git_slurp_config_src ($) {
return $r;
}
+sub gdr_ffq_prev_branchinfo ($) {
+ my ($symref) = @_;
+ # => ('status', "message", [$symref, $ffq_prev, $gdrlast])
+ # 'status' may be
+ # branch message is undef
+ # weird-symref } no $symref,
+ # notbranch } no $ffq_prev
+ return ('detached', 'detached HEAD') unless defined $symref;
+ return ('weird-symref', 'HEAD symref is not to refs/')
+ unless $symref =~ m{^refs/};
+ my $ffq_prev = "refs/$ffq_refprefix/$'";
+ my $gdrlast = "refs/$gdrlast_refprefix/$'";
+ printdebug "ffq_prev_branchinfo branch current $symref\n";
+ return ('branch', undef, $symref, $ffq_prev, $gdrlast);
+}
+
# ========== playground handling ==========
# terminology:
#
# $maindir user's git working tree
-# $playground area in .git/ where we can make files, unpack, etc. etc.
+# playground area in .git/ where we can make files, unpack, etc. etc.
# playtree git working tree sharing object store with the user's
# inside playground, or identical to it
#
@@ -485,28 +563,26 @@ sub git_slurp_config_src ($) {
#
# fresh_playground SUBDIR_PATH_COMPONENTS
# e.g fresh_playground 'dgit/unpack' ('.git/' is implied)
-# default SUBDIR_PATH_COMPONENTS is $playground_subdir
+# default SUBDIR_PATH_COMPONENTS is playground_subdir
# calls record_maindir
# sets up a new playground (destroying any old one)
-# assigns to $playground and returns the same pathname
+# returns playground pathname
# caller may call multiple times with different subdir paths
-# createing different playgrounds; but $playground global can
-# refer only to one, obv.
+# createing different playgrounds
#
# ensure_a_playground SUBDIR_PATH_COMPONENTS
# like fresh_playground except:
# merely ensures the directory exists; does not delete an existing one
-# never sets global $playground
#
# then can use
#
-# changedir $playground
+# changedir playground
# changedir $maindir
#
# playtree_setup $local_git_cfg
-# # ^ call in some (perhaps trivial) subdir of $playground
+# # ^ call in some (perhaps trivial) subdir of playground
#
-# rmtree $playground
+# rmtree playground
# ----- maindir -----
@@ -538,8 +614,6 @@ sub record_maindir () {
# ----- playgrounds -----
-our $playground;
-
sub ensure_a_playground_parent ($) {
my ($spc) = @_;
record_maindir();
@@ -562,7 +636,7 @@ sub fresh_playground ($) {
$spc = ensure_a_playground_parent $spc;
rmtree $spc;
mkdir $spc or fail "failed to mkdir the playground $spc: $!";
- return $playground = $spc;
+ return $spc;
}
# ----- playtrees -----