use Config;
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
- git_rev_parse git_get_ref git_for_each_ref
+ 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
+ playtree_setup
+ fresh_playtree in_playtree);
# implicitly uses $main::us
- %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] );
- @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} };
+ %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] );
+ @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
# dynamic loader, runtime, etc., failures, which report 127 or 255
sub NOFFCHECK () { return 0x2; }
sub FRESHREPO () { return 0x4; }
+sub NOCOMMITCHECK () { return 0x8; }
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 "|",@_;
return cmdoutput qw(git rev-parse), "$_[0]~0";
}
+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);
+ debugcmd "GCF|", @cmd;
+ $gcf_pid = open2 $gcf_o, $gcf_i, @cmd or die $!;
+ }
+ printdebug "GCF>| ", $objname, "\n";
+ print $gcf_i $objname, "\n" or die $!;
+ my $x = <$gcf_o>;
+ printdebug "GCF<| ", $x;
+ if ($x =~ m/ (missing)$/) { return ($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);
+}
+
sub git_for_each_ref ($$;$) {
my ($pattern,$func,$gitdir) = @_;
# calls $func->($objid,$objtype,$fullrefname,$reftail);
}
}
+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 playtree_setup ($) {
+ # for use in the playtree
+ 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_playtree ($;$) {
+ my $sub = pop @_; # in_playtree [$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_playtree (;$) {
+ 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_playtree sub { playtree_setup $local_git_cfg; };
+}
+
1;
~ianmdlvl / dgit.git / blobdiff