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


line stmt bran cond sub pod time code
1 2     2   149552 use 5.006002;
  2         27  
2 2     2   10 use strict;
  2         4  
  2         39  
3 2     2   9 use warnings;
  2         12  
  2         144  
4              
5             package Test::TempDir::Tiny;
6             # ABSTRACT: Temporary directories that stick around when tests fail
7              
8             our $VERSION = '0.018';
9              
10 2     2   13 use Exporter 5.57 qw/import/;
  2         29  
  2         104  
11             our @EXPORT = qw/tempdir in_tempdir/;
12              
13 2     2   12 use Carp qw/confess/;
  2         4  
  2         100  
14 2     2   20 use Cwd qw/abs_path/;
  2         3  
  2         100  
15 2     2   483 use Errno qw/EEXIST ENOENT/;
  2         1551  
  2         246  
16             {
17 2     2   17 no warnings 'numeric'; # loading File::Path has non-numeric warnings on 5.8
  2         3  
  2         94  
18 2     2   12 use File::Path 2.07 qw/remove_tree/;
  2         35  
  2         131  
19             }
20 2     2   857 use File::Spec::Functions qw/catdir/;
  2         1748  
  2         138  
21 2     2   854 use File::Temp 0.2308;
  2         15287  
  2         1995  
22              
23             my ( $ROOT_DIR, $TEST_DIR, %COUNTER );
24             my ( $ORIGINAL_PID, $ORIGINAL_CWD, $TRIES, $DELAY, $SYSTEM_TEMP ) =
25             ( $$, abs_path("."), 100, 50 / 1000, 0 );
26              
27             sub _untaint {
28 11     11   22 my $thing = shift;
29 11         61 ($thing) = $thing =~ /^(.*)$/;
30 11         577 return $thing;
31             }
32              
33             #pod =func tempdir
34             #pod
35             #pod $dir = tempdir(); # .../default_1/
36             #pod $dir = tempdir("label"); # .../label_1/
37             #pod
38             #pod Creates a directory underneath a test-file-specific temporary directory and
39             #pod returns the absolute path to it in platform-native form (i.e. with backslashes
40             #pod on Windows).
41             #pod
42             #pod The function takes a single argument as a label for the directory or defaults
43             #pod to "default". An incremental counter value will be appended to allow a label to
44             #pod be used within a loop with distinct temporary directories:
45             #pod
46             #pod # t/foo.t
47             #pod
48             #pod for ( 1 .. 3 ) {
49             #pod tempdir("in loop");
50             #pod }
51             #pod
52             #pod # creates:
53             #pod # ./tmp/t_foo_t/in_loop_1
54             #pod # ./tmp/t_foo_t/in_loop_2
55             #pod # ./tmp/t_foo_t/in_loop_3
56             #pod
57             #pod If the label contains any characters besides alphanumerics, underscore
58             #pod and dash, they will be collapsed and replaced with a single underscore.
59             #pod
60             #pod $dir = tempdir("a space"); # .../a_space_1/
61             #pod $dir = tempdir("a!bang"); # .../a_bang_1/
62             #pod
63             #pod The test-file-specific directory and all directories within it will be cleaned
64             #pod up with an END block if the current test file passes tests.
65             #pod
66             #pod =cut
67              
68             sub tempdir {
69 7 100   7 1 4545 my $label = defined( $_[0] ) ? $_[0] : 'default';
70 7         19 $label =~ tr{a-zA-Z0-9_-}{_}cs;
71              
72 7 100 66     42 _init() unless $ROOT_DIR && $TEST_DIR;
73 7         31 my $suffix = ++$COUNTER{$label};
74 7         43 my $subdir = catdir( $TEST_DIR, "${label}_${suffix}" );
75 7 50       24 mkdir _untaint($subdir) or confess("Couldn't create $subdir: $!");
76 7         42 return $subdir;
77             }
78              
79             #pod =func in_tempdir
80             #pod
81             #pod in_tempdir "label becomes name" => sub {
82             #pod my $cwd = shift;
83             #pod # this happens in tempdir
84             #pod };
85             #pod
86             #pod Given a label and a code reference, creates a temporary directory based on the
87             #pod label (following the rules of L), changes to that directory, runs the
88             #pod code, then changes back to the original directory.
89             #pod
90             #pod The temporary directory path is given as an argument to the code reference.
91             #pod
92             #pod When the code finishes (even if it dies), C will change back to the
93             #pod original directory if it can, to the root if it can't, and will rethrow any
94             #pod fatal errors.
95             #pod
96             #pod =cut
97              
98             sub in_tempdir {
99 1     1 1 1383238 my ( $label, $code ) = @_;
100 1         6 my $wantarray = wantarray;
101 1         29 my $cwd = abs_path(".");
102 1         17 my $tempdir = tempdir($label);
103              
104 1 50       22 chdir $tempdir or die "Can't chdir to '$tempdir'";
105 1         4 my (@ret);
106 1         7 my $ok = eval { $code->($tempdir); 1 };
  1         7  
  1         1594  
107 1         9 my $err = $@;
108 1 50 33     19 chdir $cwd or chdir "/" or die "Can't chdir to either '$cwd' or '/'";
109 1 50 0     5 confess( $err || "error from eval was lost" ) if !$ok;
110 1         5 return;
111             }
112              
113             sub _inside_t_dir {
114 0 0   0   0 -d "../t" && abs_path(".") eq abs_path("../t");
115             }
116              
117             sub _init {
118              
119 2     2   14 my $DEFAULT_ROOT = catdir( $ORIGINAL_CWD, "tmp" );
120              
121 2 50 33     133 if ( -d 't' && ( -w $DEFAULT_ROOT || -w '.' ) ) {
    0 33        
      0        
      0        
122 2         8 $ROOT_DIR = $DEFAULT_ROOT;
123             }
124             elsif ( _inside_t_dir() && ( -w '../$DEFAULT_ROOT' || -w '..' ) ) {
125 0         0 $ROOT_DIR = catdir( $ORIGINAL_CWD, "..", "tmp" );
126             }
127             else {
128 0         0 $ROOT_DIR = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
129 0         0 $SYSTEM_TEMP = 1;
130             }
131              
132             # TEST_DIR is based on .t path under ROOT_DIR
133 2         6 ( my $dirname = $0 ) =~ tr{:\\/.}{_};
134 2         13 $TEST_DIR = catdir( $ROOT_DIR, $dirname );
135              
136             # If it exists from a previous run, clear it out
137 2 50       19 if ( -d $TEST_DIR ) {
138 0         0 remove_tree( _untaint($TEST_DIR), { safe => 0, keep_root => 1 } );
139 0         0 return;
140             }
141              
142             # Need to create directory, but constructing nested directories can never
143             # be atomic, so we have to retry if the tempdir root gets deleted out from
144             # under us (perhaps by a parallel test)
145              
146 2         8 for my $n ( 1 .. $TRIES ) {
147             # Failing to mkdir is OK as long as error is EEXIST
148 2 50       7 if ( !mkdir( _untaint($ROOT_DIR) ) ) {
149 0 0       0 confess("Couldn't create $ROOT_DIR: $!")
150             unless $! == EEXIST;
151             }
152              
153             # Normalize after we know it exists, because abs_path might fail on
154             # some platforms if it doesn't exist
155 2         71 $ROOT_DIR = abs_path($ROOT_DIR);
156              
157             # If mkdir succeeds, we're done
158 2 50       6 if ( mkdir _untaint($TEST_DIR) ) {
159             # similarly normalize only after we're sure it exists
160 2         82 $TEST_DIR = abs_path($TEST_DIR);
161 2         8 return;
162             }
163              
164             # Anything other than ENOENT is a real error
165 0 0       0 if ( $! != ENOENT ) {
166 0         0 confess("Couldn't create $TEST_DIR: $!");
167             }
168              
169             # ENOENT means $ROOT_DIR was removed from under us or is not a
170             # directory. Only the latter case is a real error.
171 0 0 0     0 if ( -e $ROOT_DIR && !-d _ ) {
172 0         0 confess("$ROOT_DIR is not a directory");
173             }
174              
175 0 0       0 select( undef, undef, undef, $DELAY ) if $n < $TRIES;
176             }
177              
178 0         0 warn "Couldn't create $TEST_DIR in $TRIES tries.\n"
179             . "Using a regular tempdir instead.\n";
180              
181             # Because fallback isn't under root, we let File::Temp clean it up.
182 0         0 $TEST_DIR = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
183 0         0 return;
184             }
185              
186             # Relatively safe to untainted paths for these operations as they won't
187             # be evaluated or passed to the shell.
188             sub _cleanup {
189 0 0   0   0 return if $ENV{PERL_TEST_TEMPDIR_TINY_NOCLEANUP};
190 0 0 0     0 if ( $ROOT_DIR && -d $ROOT_DIR ) {
191             # always cleanup if root is in system temp directory, otherwise
192             # only clean up if exiting with non-zero value
193 0 0 0     0 if ( $SYSTEM_TEMP or not $? ) {
194 0 0 0     0 chdir _untaint($ORIGINAL_CWD)
195             or chdir "/"
196             or warn "Can't chdir to '$ORIGINAL_CWD' or '/'. Cleanup might fail.";
197 0 0       0 remove_tree( _untaint($TEST_DIR), { safe => 0 } )
198             if -d $TEST_DIR;
199             }
200              
201             # Remove root unless it's a symlink, which a user might create to
202             # force it to another drive. Removal will fail if there are any
203             # children, but we ignore errors as other tests might be running
204             # in parallel and have tempdirs there.
205 0 0       0 rmdir _untaint($ROOT_DIR) unless -l $ROOT_DIR;
206             }
207             }
208              
209             # for testing
210 1     1   5 sub _root_dir { return $ROOT_DIR }
211              
212             END {
213             # only clean up in original process, not children
214 2 50   2   1482 if ( $$ == $ORIGINAL_PID ) {
215             # our clean up must run after Test::More sets $? in its END block
216 2 50       17 if ( $] lt "5.008000" ) {
217 0         0 *Test::TempDir::Tiny::_CLEANER::DESTROY = \&_cleanup;
218 0         0 *blob = bless( {}, 'Test::TempDir::Tiny::_CLEANER' );
219             }
220             else {
221 2         19 require B;
222 2         6 push @{ B::end_av()->object_2svref }, \&_cleanup;
  2         142  
223             }
224             }
225             }
226              
227             1;
228              
229              
230             # vim: ts=4 sts=4 sw=4 et:
231              
232             __END__