File Coverage

blib/lib/Test/TempDir/Tiny.pm

Criterion	Covered	Total	%
statement	73	96	76.0
branch	14	48	29.1
condition	5	32	15.6
subroutine	17	19	89.4
pod	2	2	100.0
total	111	197	56.3

use 5.006002;
use strict;
use warnings;

package Test::TempDir::Tiny;
# ABSTRACT: Temporary directories that stick around when tests fail

our $VERSION = '0.017';

use Exporter 5.57 qw/import/;
our @EXPORT = qw/tempdir in_tempdir/;

use Carp qw/confess/;
use Cwd qw/abs_path/;
use Errno qw/EEXIST ENOENT/;
{
    no warnings 'numeric'; # loading File::Path has non-numeric warnings on 5.8
    use File::Path 2.07 qw/remove_tree/;
}
use File::Spec::Functions qw/catdir/;
use File::Temp;

my ( $ROOT_DIR, $TEST_DIR, %COUNTER );
my ( $ORIGINAL_PID, $ORIGINAL_CWD, $TRIES, $DELAY, $SYSTEM_TEMP ) =
  ( $$, abs_path("."), 100, 50 / 1000, 0 );

sub _untaint {
    my $thing = shift;
    ($thing) = $thing =~ /^(.*)$/;
    return $thing;
}

#pod =func tempdir
#pod
#pod     $dir = tempdir();          # .../default_1/
#pod     $dir = tempdir("label");   # .../label_1/
#pod
#pod Creates a directory underneath a test-file-specific temporary directory and
#pod returns the absolute path to it in platform-native form (i.e. with backslashes
#pod on Windows).
#pod
#pod The function takes a single argument as a label for the directory or defaults
#pod to "default". An incremental counter value will be appended to allow a label to
#pod be used within a loop with distinct temporary directories:
#pod
#pod     # t/foo.t
#pod
#pod     for ( 1 .. 3 ) {
#pod         tempdir("in loop");
#pod     }
#pod
#pod     # creates:
#pod     #   ./tmp/t_foo_t/in_loop_1
#pod     #   ./tmp/t_foo_t/in_loop_2
#pod     #   ./tmp/t_foo_t/in_loop_3
#pod
#pod If the label contains any characters besides alphanumerics, underscore
#pod and dash, they will be collapsed and replaced with a single underscore.
#pod
#pod     $dir = tempdir("a space"); # .../a_space_1/
#pod     $dir = tempdir("a!bang");  # .../a_bang_1/
#pod
#pod The test-file-specific directory and all directories within it will be cleaned
#pod up with an END block if the current test file passes tests.
#pod
#pod =cut

sub tempdir {
    my $label = defined( $_[0] ) ? $_[0] : 'default';
    $label =~ tr{a-zA-Z0-9_-}{_}cs;

    _init() unless $ROOT_DIR && $TEST_DIR;
    my $suffix = ++$COUNTER{$label};
    my $subdir = catdir( $TEST_DIR, "${label}_${suffix}" );
    mkdir _untaint($subdir) or confess("Couldn't create $subdir: $!");
    return $subdir;
}

#pod =func in_tempdir
#pod
#pod     in_tempdir "label becomes name" => sub {
#pod         my $cwd = shift;
#pod         # this happens in tempdir
#pod     };
#pod
#pod Given a label and a code reference, creates a temporary directory based on the
#pod label (following the rules of L), changes to that directory, runs the
#pod code, then changes back to the original directory.
#pod
#pod The temporary directory path is given as an argument to the code reference.
#pod
#pod When the code finishes (even if it dies), C will change back to the
#pod original directory if it can, to the root if it can't, and will rethrow any
#pod fatal errors.
#pod
#pod =cut

sub in_tempdir {
    my ( $label, $code ) = @_;
    my $wantarray = wantarray;
    my $cwd       = abs_path(".");
    my $tempdir   = tempdir($label);

    chdir $tempdir or die "Can't chdir to '$tempdir'";
    my (@ret);
    my $ok = eval { $code->($tempdir); 1 };
    my $err = $@;
    chdir $cwd or chdir "/" or die "Can't chdir to either '$cwd' or '/'";
    confess( $err || "error from eval was lost" ) if !$ok;
    return;
}

sub _inside_t_dir {
    -d "../t" && abs_path(".") eq abs_path("../t");
}

sub _init {

    my $DEFAULT_ROOT = catdir( $ORIGINAL_CWD, "tmp" );

    if ( -d 't' && ( -w $DEFAULT_ROOT || -w '.' ) ) {
        $ROOT_DIR = $DEFAULT_ROOT;
    }
    elsif ( _inside_t_dir() && ( -w '../$DEFAULT_ROOT' || -w '..' ) ) {
        $ROOT_DIR = catdir( $ORIGINAL_CWD, "..", "tmp" );
    }
    else {
        $ROOT_DIR = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
        $SYSTEM_TEMP = 1;
    }

    # TEST_DIR is based on .t path under ROOT_DIR
    ( my $dirname = $0 ) =~ tr{:\\/.}{_};
    $TEST_DIR = catdir( $ROOT_DIR, $dirname );

    # If it exists from a previous run, clear it out
    if ( -d $TEST_DIR ) {
        remove_tree( _untaint($TEST_DIR), { safe => 0, keep_root => 1 } );
        return;
    }

    # Need to create directory, but constructing nested directories can never
    # be atomic, so we have to retry if the tempdir root gets deleted out from
    # under us (perhaps by a parallel test)

    for my $n ( 1 .. $TRIES ) {
        # Failing to mkdir is OK as long as error is EEXIST
        if ( !mkdir( _untaint($ROOT_DIR) ) ) {
            confess("Couldn't create $ROOT_DIR: $!")
              unless $! == EEXIST;
        }

        # Normalize after we know it exists, because abs_path might fail on
        # some platforms if it doesn't exist
        $ROOT_DIR = abs_path($ROOT_DIR);

        # If mkdir succeeds, we're done
        if ( mkdir _untaint($TEST_DIR) ) {
            # similarly normalize only after we're sure it exists
            $TEST_DIR = abs_path($TEST_DIR);
            return;
        }

        # Anything other than ENOENT is a real error
        if ( $! != ENOENT ) {
            confess("Couldn't create $TEST_DIR: $!");
        }

        # ENOENT means $ROOT_DIR was removed from under us or is not a
        # directory.  Only the latter case is a real error.
        if ( -e $ROOT_DIR && !-d _ ) {
            confess("$ROOT_DIR is not a directory");
        }

        select( undef, undef, undef, $DELAY ) if $n < $TRIES;
    }

    warn "Couldn't create $TEST_DIR in $TRIES tries.\n"
      . "Using a regular tempdir instead.\n";

    # Because fallback isn't under root, we let File::Temp clean it up.
    $TEST_DIR = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
    return;
}

# Relatively safe to untainted paths for these operations as they won't
# be evaluated or passed to the shell.
sub _cleanup {
    return if $ENV{PERL_TEST_TEMPDIR_TINY_NOCLEANUP};
    if ( $ROOT_DIR && -d $ROOT_DIR ) {
        # always cleanup if root is in system temp directory, otherwise
        # only clean up if exiting with non-zero value
        if ( $SYSTEM_TEMP or not $? ) {
            chdir _untaint($ORIGINAL_CWD)
              or chdir "/"
              or warn "Can't chdir to '$ORIGINAL_CWD' or '/'. Cleanup might fail.";
            remove_tree( _untaint($TEST_DIR), { safe => 0 } )
              if -d $TEST_DIR;
        }

        # Remove root unless it's a symlink, which a user might create to
        # force it to another drive.  Removal will fail if there are any
        # children, but we ignore errors as other tests might be running
        # in parallel and have tempdirs there.
        rmdir _untaint($ROOT_DIR) unless -l $ROOT_DIR;
    }
}

# for testing
sub _root_dir { return $ROOT_DIR }

END {
    # only clean up in original process, not children
    if ( $$ == $ORIGINAL_PID ) {
        # our clean up must run after Test::More sets $? in its END block
        if ( $] lt "5.008000" ) {
            *Test::TempDir::Tiny::_CLEANER::DESTROY = \&_cleanup;
            *blob = bless( {}, 'Test::TempDir::Tiny::_CLEANER' );
        }
        else {
            require B;
            push @{ B::end_av()->object_2svref }, \&_cleanup;
        }
    }
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__