view release on metacpan or  search on metacpan

lib/Test/TempDir/Tiny.pm  view on Meta::CPAN

        # 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__

=pod

=encoding UTF-8

=head1 NAME

Test::TempDir::Tiny - Temporary directories that stick around when tests fail

=head1 VERSION

version 0.018

=head1 SYNOPSIS

    # t/foo.t
    use Test::More;
    use Test::TempDir::Tiny;

    # default tempdirs
    $dir = tempdir();          # ./tmp/t_foo_t/default_1/
    $dir = tempdir();          # ./tmp/t_foo_t/default_2/

    # labeled tempdirs
    $dir = tempdir("label");   # ./tmp/t_foo_t/label_1/
    $dir = tempdir("label");   # ./tmp/t_foo_t/label_2/

    # labels with spaces and non-word characters
    $dir = tempdir("bar baz")  # ./tmp/t_foo_t/bar_baz_1/
    $dir = tempdir("!!!bang")  # ./tmp/t_foo_t/_bang_1/

    # run code in a temporary directory
    in_tempdir "label becomes name" => sub {
        my $cwd = shift;
        # do stuff in a tempdir
    };

=head1 DESCRIPTION

This module works with L<Test::More> to create temporary directories that stick
around if tests fail.

It is loosely based on L<Test::TempDir>, but with less complexity, greater
portability and zero non-core dependencies.  (L<Capture::Tiny> is recommended