use Digest::SHA;
use Data::Dumper;
use IPC::Open2;
+use File::Path;
+use File::Basename;
BEGIN {
use Exporter ();
$VERSION = 1.00;
@ISA = qw(Exporter);
- @EXPORT = qw(setup_sigwarn
+ @EXPORT = qw(setup_sigwarn forkcheck_setup forkcheck_mainprocess
dep14_version_mangle
debiantags debiantag_old debiantag_new
server_branch server_ref
fail ensuredir executable_on_path
waitstatusmsg failedcmd_waitstatus
failedcmd_report_cmd failedcmd
- cmdoutput cmdoutput_errok
+ runcmd cmdoutput cmdoutput_errok
git_rev_parse git_cat_file
git_get_ref git_for_each_ref
git_for_each_tag_referring is_fast_fwd
$package_re $component_re $deliberately_re
+ $distro_re $versiontag_re $series_filename_re
$branchprefix
initdebug enabledebug enabledebuglevel
printdebug debugcmd
$debugprefix *debuglevel *DEBUG
- shellquote printcmd messagequote);
+ shellquote printcmd messagequote
+ $negate_harmful_gitattrs
+ changedir git_slurp_config_src
+ workarea_setup
+ fresh_workarea in_workarea);
# implicitly uses $main::us
%EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] );
- @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} };
+ @EXPORT_OK = ( qw($wa), @{ $EXPORT_TAGS{policyflags} } );
}
our @EXPORT_OK;
our $package_re = '[0-9a-z][-+.0-9a-z]*';
our $component_re = '[0-9a-zA-Z][-+.0-9a-zA-Z]*';
our $deliberately_re = "(?:TEST-)?$package_re";
+our $distro_re = $component_re;
+our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+};
our $branchprefix = 'dgit';
+our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s;
# policy hook exit status bits
# see dgit-repos-server head comment for documentation
our $debugprefix;
our $debuglevel = 0;
+our $negate_harmful_gitattrs = "-text -eol -crlf -ident -filter";
+
+our $forkcheck_mainprocess;
+
+sub forkcheck_setup () {
+ $forkcheck_mainprocess = $$;
+}
+
+sub forkcheck_mainprocess () {
+ # You must have called forkcheck_setup or setup_sigwarn already
+ getppid != $forkcheck_mainprocess;
+}
+
sub setup_sigwarn () {
- our $sigwarn_mainprocess = $$;
+ forkcheck_setup();
$SIG{__WARN__} = sub {
- die $_[0] unless getppid == $sigwarn_mainprocess;
+ die $_[0] if forkcheck_mainprocess;
};
}
sub shellquote {
my @out;
local $_;
+ defined or confess 'internal error' foreach @_;
foreach my $a (@_) {
$_ = $a;
if (!length || m{[^-=_./:0-9a-z]}i) {
fail failedcmd_waitstatus();
}
+sub runcmd {
+ debugcmd "+",@_;
+ $!=0; $?=-1;
+ failedcmd @_ if system @_;
+}
+
sub cmdoutput_errok {
confess Dumper(\@_)." ?" if grep { !defined } @_;
debugcmd "|",@_;
sub git_cat_file ($) {
my ($objname) = @_;
# => ($type, $data) or ('missing', undef)
+ # in scalar context, just the data
our ($gcf_pid, $gcf_i, $gcf_o);
if (!$gcf_pid) {
my @cmd = qw(git cat-file --batch);
}
}
+sub changedir ($) {
+ my ($newdir) = @_;
+ printdebug "CD $newdir\n";
+ chdir $newdir or confess "chdir: $newdir: $!";
+}
+
+sub git_slurp_config_src ($) {
+ my ($src) = @_;
+ # returns $r such that $r->{KEY}[] = VALUE
+ my @cmd = (qw(git config -z --get-regexp), "--$src", qw(.*));
+ debugcmd "|",@cmd;
+
+ local ($debuglevel) = $debuglevel-2;
+ local $/="\0";
+
+ my $r = { };
+ open GITS, "-|", @cmd or die $!;
+ while (<GITS>) {
+ chomp or die;
+ printdebug "=> ", (messagequote $_), "\n";
+ m/\n/ or die "$_ ?";
+ push @{ $r->{$`} }, $'; #';
+ }
+ $!=0; $?=0;
+ close GITS
+ or ($!==0 && $?==256)
+ or failedcmd @cmd;
+ return $r;
+}
+
+sub workarea_setup ($) {
+ # for use in the workarea
+ my ($t_local_git_cfg) = @_;
+ # should be run in a directory .git/FOO/BAR of a working tree
+ runcmd qw(git init -q);
+ runcmd qw(git config gc.auto 0);
+ foreach my $copy (qw(user.email user.name user.useConfigOnly
+ core.sharedRepository
+ core.compression core.looseCompression
+ core.bigFileThreshold core.fsyncObjectFiles)) {
+ my $v = $t_local_git_cfg->{$copy};
+ next unless $v;
+ runcmd qw(git config), $copy, $_ foreach @$v;
+ }
+ rmtree('.git/objects');
+ symlink '../../../../objects','.git/objects' or die $!;
+ ensuredir '.git/info';
+ open GA, "> .git/info/attributes" or die $!;
+ print GA "* $negate_harmful_gitattrs\n" or die $!;
+ close GA or die $!;
+}
+
+our $wa;
+our $local_git_cfg;
+
+sub in_workarea ($;$) {
+ my $sub = pop @_; # in_workarea [$twa, sub { ... };]
+ # default $twa is global $wa (which caller must, in that case, set)
+ # $twa should be relative paths of the form .git/FOO/BAR
+ my ($twa) = @_;
+ $twa //= $wa;
+ changedir $twa or die "$twa $!";
+ my $r = eval { $sub->($twa); };
+ changedir '../../..' or die "$@; $!";
+ die $@ if length $@;
+ return $r;
+}
+
+sub fresh_workarea (;$) {
+ my ($twa) = @_;
+ $twa //= $wa;
+ $local_git_cfg //= git_slurp_config_src 'local';
+ my $parent = dirname $twa;
+ mkdir $parent or $!==EEXIST or fail "failed to mkdir $parent: $!";
+ rmtree $twa;
+ mkdir $twa or die "$twa $!";
+ in_workarea sub { workarea_setup $local_git_cfg; };
+}
+
1;