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
- waitstatusmsg failedcmd
- cmdoutput cmdoutput_errok
- git_rev_parse git_get_ref git_for_each_ref
+ fail ensuredir must_getcwd executable_on_path
+ waitstatusmsg failedcmd_waitstatus
+ failedcmd_report_cmd failedcmd
+ 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);
# implicitly uses $main::us
- %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] );
- @EXPORT_OK = @{ $EXPORT_TAGS{policyflags} };
+ %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)],
+ playground => [qw(record_maindir $maindir $local_git_cfg
+ $maindir_gitdir $maindir_gitcommon
+ fresh_playground $playground
+ ensure_a_playground)]);
+ @EXPORT_OK = ( @{ $EXPORT_TAGS{policyflags} },
+ @{ $EXPORT_TAGS{playground} } );
}
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) {
printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0;
}
+sub dep14_version_mangle ($) {
+ my ($v) = @_;
+ # DEP-14 patch proposed 2016-11-09 "Version Mangling"
+ $v =~ y/~:/_%/;
+ $v =~ s/\.(?=\.|$|lock$)/.#/g;
+ return $v;
+}
+
sub debiantag_old ($$) {
my ($v,$distro) = @_;
- $v =~ y/~:/_%/;
- return "$distro/$v";
+ return "$distro/". dep14_version_mangle $v;
}
sub debiantag_new ($$) {
my ($v,$distro) = @_;
- $v =~ y/~:/_%/;
- return "archive/$distro/$v";
+ return "archive/$distro/".dep14_version_mangle $v;
}
sub debiantags ($$) {
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{/};
}
}
+sub failedcmd_report_cmd {
+ my $intro = shift @_;
+ $intro //= "failed command";
+ { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or die $!; };
+}
+
+sub failedcmd_waitstatus {
+ if ($? < 0) {
+ return "failed to fork/exec: $!";
+ } elsif ($?) {
+ return "subprocess ".waitstatusmsg();
+ } else {
+ return "subprocess produced invalid output";
+ }
+}
+
sub failedcmd {
# Expects $!,$? as set by close - see below.
# To use with system(), set $?=-1 first.
# success trashed $?==0 system
# program failed trashed $? >0 system
# syscall failure $! >0 unchanged system
- { local ($!); printcmd \*STDERR, _us().": failed command:", @_ or die $!; };
- if ($? < 0) {
- fail "failed to fork/exec: $!";
- } elsif ($?) {
- fail "subprocess ".waitstatusmsg();
- } else {
- fail "subprocess produced invalid output";
- }
+ failedcmd_report_cmd undef, @_;
+ fail failedcmd_waitstatus();
+}
+
+sub runcmd {
+ debugcmd "+",@_;
+ $!=0; $?=-1;
+ failedcmd @_ if system @_;
}
sub cmdoutput_errok {
if (-l _) {
$old = cmdoutput qw(realpath --), $old;
}
- link $old, $new or die "link $old $new: $!";
+ my $r = link $old, $new;
+ $r = symlink $old, $new if !$r && $!==EXDEV;
+ $r or die "(sym)link $old $new: $!";
}
sub hashfile ($) {
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;
+}
+
+# ========== 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.
+#
+# 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 $maindir
+#
+# playtree_setup $local_git_cfg
+# # ^ call in some (perhaps trivial) subdir of $playground
+#
+# rmtree $playground
+
+# ----- maindir -----
+
+# these three all go together
+our $maindir;
+our $maindir_gitdir;
+our $maindir_gitcommon;
+
+our $local_git_cfg;
+
+sub record_maindir () {
+ if (!defined $maindir) {
+ $maindir = must_getcwd();
+ if (!stat "$maindir/.git") {
+ fail "cannot stat $maindir/.git: $!";
+ }
+ if (-d _) {
+ # we fall back to this in case we have a pre-worktree
+ # git, which may not know git rev-parse --git-common-dir
+ $maindir_gitdir = "$maindir/.git";
+ $maindir_gitcommon = "$maindir/.git";
+ } else {
+ $maindir_gitdir = cmdoutput qw(git rev-parse --git-dir);
+ $maindir_gitcommon = cmdoutput qw(git rev-parse --git-common-dir);
+ }
+ }
+ $local_git_cfg //= git_slurp_config_src 'local';
+}
+
+# ----- playgrounds -----
+
+our $playground;
+
+sub ensure_a_playground_parent ($) {
+ my ($spc) = @_;
+ record_maindir();
+ $spc = "$maindir_gitdir/$spc";
+ my $parent = dirname $spc;
+ mkdir $parent or $!==EEXIST
+ or fail "failed to mkdir playground parent $parent: $!";
+ return $spc;
+}
+
+sub ensure_a_playground ($) {
+ my ($spc) = @_;
+ $spc = ensure_a_playground_parent $spc;
+ mkdir $spc or $!==EEXIST or fail "failed to mkdir a playground $spc: $!";
+ return $spc;
+}
+
+sub fresh_playground ($) {
+ my ($spc) = @_;
+ $spc = ensure_a_playground_parent $spc;
+ rmtree $spc;
+ mkdir $spc or fail "failed to mkdir the playground $spc: $!";
+ return $playground = $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;
+ }
+ # this is confusing: we have
+ # . playtree, not a worktree, has .git/, our cwd
+ # $maindir might be a worktree so
+ # $maindir_gitdir contains our main working "dgit", HEAD, etc.
+ # $maindir_gitcommon the shared stuff, including .objects
+ rmtree('.git/objects');
+ symlink "$maindir_gitcommon/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;