playground: playtree: rename from workarea

[dgit.git] / Debian / Dgit.pm

diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm
index aef0112aebb975ce49cca55699808fbe6cf99922..524ae18a2d73b506c25320ea4a6476dd97f15ac0 100644 (file)
--- a/Debian/Dgit.pm
+++ b/Debian/Dgit.pm
@@ -30,6 +30,7 @@ use Digest::SHA;
 use Data::Dumper;
 use IPC::Open2;
 use File::Path;
+use File::Basename;
 
 BEGIN {
     use Exporter   ();
@@ -43,7 +44,7 @@ BEGIN {
                      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
                       runcmd cmdoutput cmdoutput_errok
@@ -58,10 +59,12 @@ BEGIN {
                       $debugprefix *debuglevel *DEBUG
                       shellquote printcmd messagequote
                       $negate_harmful_gitattrs
-                      workarea_setup);
+                     changedir git_slurp_config_src
+                     playtree_setup
+                     fresh_playtree in_playtree);
     # 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;
@@ -221,6 +224,12 @@ sub ensuredir ($) {
     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{/};
@@ -417,8 +426,38 @@ sub is_fast_fwd ($$) {
     }
 }
 
-sub workarea_setup ($) {
-    # for use in the workarea
+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);
@@ -439,4 +478,31 @@ sub workarea_setup ($) {
     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;