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
stat_exists link_ltarget
hashfile
- fail ensuredir executable_on_path
+ fail ensuredir must_getcwd 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
+ $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
+ playtree_setup);
# implicitly uses $main::us
- %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] );
- @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} };
+ %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)],
+ playground => [qw(record_maindir $maindir $local_git_cfg
+ fresh_playground $playground)]);
+ @EXPORT_OK = ( @{ $EXPORT_TAGS{policyflags} },
+ @{ $EXPORT_TAGS{playground} } );
}
our @EXPORT_OK;
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) {
die "mkdir $dir: $!";
}
+sub must_getcwd () {
+ my $d = getcwd();
+ defined $d or fail "getcwd failed: $!";
+ return $d;
+}
+
sub executable_on_path ($) {
my ($program) = @_;
return 1 if $program =~ m{/};
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;
+}
+
+# ========== playground handling ==========
+
+# terminology:
+#
+# $maindir user's git working tree
+# $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
+#
+# other globals
+#
+# $local_git_cfg hash of arrays of values: git config from $maindir
+#
+# expected calling pattern
+#
+# firstly
+#
+# [record_maindir]
+# must be run in directory containing .git
+# assigns to $maindir if not already set
+# also calls git_slurp_config_src to record git config
+# in $local_git_cfg, unless it's already set
+#
+# fresh_playground SUBDIR_PATH_COMPONENTS
+# e.g fresh_playground 'dgit/unpack' ('.git/' is implied)
+# 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
+# caller may call multiple times with different subdir paths
+# createing different playgrounds; but $playground global can
+# refer only to one, obv.
+#
+# then can use
+#
+# changedir $playground
+# changedir $maindir
+#
+# playtree_setup $local_git_cfg
+# # ^ call in some (perhaps trivial) subdir of $playground
+#
+# rmtree $playground
+
+# ----- maindir -----
+
+our $maindir;
+our $local_git_cfg;
+
+sub record_maindir () {
+ $maindir //= must_getcwd();
+ $local_git_cfg //= git_slurp_config_src 'local';
+}
+
+# ----- playgrounds -----
+
+our $playground;
+
+sub fresh_playground ($) {
+ my ($spc) = @_;
+ record_maindir();
+ $spc = ".git/$spc";
+ my $parent = dirname $spc;
+ mkdir $parent or $!==EEXIST or fail "failed to mkdir $parent: $!";
+ rmtree $spc;
+ mkdir $spc or die "$spc $!";
+ return $playground = "$maindir/$spc";
+}
+
+# ----- playtrees -----
+
+sub playtree_setup (;$) {
+ my ($t_local_git_cfg) = @_;
+ $t_local_git_cfg //= $local_git_cfg;
+ # for use in the playtree
+ # $maindir must be set, eg by calling record_maindir or fresh_playground
+ 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 "$maindir/.git/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 $!;
+}
+
1;