1 2use strict; 3use Test::More; 4use File::Temp qw(tmpnam tempdir); 5use File::Spec; 6 7plan tests => 72; 8 9use_ok 'Path::Class'; 10 11 12my $file = file(scalar tmpnam()); 13ok $file, "Got a filename via tmpnam()"; 14 15{ 16 my $fh = $file->open('w'); 17 ok $fh, "Opened $file for writing"; 18 19 ok print( $fh "Foo\n"), "Printed to $file"; 20} 21 22ok -e $file, "$file should exist"; 23 24{ 25 my $fh = $file->open; 26 is scalar <$fh>, "Foo\n", "Read contents of $file correctly"; 27} 28 29{ 30 my $stat = $file->stat; 31 ok $stat; 32 cmp_ok $stat->mtime, '>', time() - 20; # Modified within last 20 seconds 33 34 $stat = $file->dir->stat; 35 ok $stat; 36} 37 381 while unlink $file; 39ok not -e $file; 40 41 42my $dir = dir(tempdir(CLEANUP => 1)); 43ok $dir; 44ok -d $dir; 45 46$file = $dir->file('foo.x'); 47$file->touch; 48ok -e $file; 49 50{ 51 my $dh = $dir->open; 52 ok $dh, "Opened $dir for reading"; 53 54 my @files = readdir $dh; 55 is scalar @files, 3; 56 ok scalar grep { $_ eq 'foo.x' } @files; 57} 58 59ok $dir->rmtree, "Removed $dir"; 60ok !-e $dir, "$dir no longer exists"; 61 62{ 63 $dir = dir('t', 'foo', 'bar'); 64 $dir->parent->rmtree if -e $dir->parent; 65 66 ok $dir->mkpath, "Created $dir"; 67 ok -d $dir, "$dir is a directory"; 68 69 # Use a Unix sample path to test cleaning it up 70 my $ugly = Path::Class::Dir->new_foreign(Unix => 't/foo/..//foo/bar'); 71 $ugly->resolve; 72 is $ugly->as_foreign('Unix'), 't/foo/bar'; 73 74 $dir = $dir->parent; 75 ok $dir->rmtree; 76 ok !-e $dir; 77} 78 79{ 80 $dir = dir('t', 'foo'); 81 ok $dir->mkpath; 82 ok $dir->subdir('dir')->mkpath; 83 ok -d $dir->subdir('dir'); 84 85 ok $dir->file('file.x')->touch; 86 ok $dir->file('0')->touch; 87 my @contents; 88 while (my $file = $dir->next) { 89 push @contents, $file; 90 } 91 is scalar @contents, 5; 92 93 my $joined = join ' ', sort map $_->basename, grep {-f $_} @contents; 94 is $joined, '0 file.x'; 95 96 my ($subdir) = grep {$_ eq $dir->subdir('dir')} @contents; 97 ok $subdir; 98 is -d $subdir, 1; 99 100 my ($file) = grep {$_ eq $dir->file('file.x')} @contents; 101 ok $file; 102 is -d $file, ''; 103 104 ok $dir->rmtree; 105 ok !-e $dir; 106 107 108 # Try again with directory called '0', in curdir 109 my $orig = dir()->absolute; 110 111 ok $dir->mkpath; 112 ok chdir($dir); 113 my $dir2 = dir(); 114 ok $dir2->subdir('0')->mkpath; 115 ok -d $dir2->subdir('0'); 116 117 @contents = (); 118 while (my $file = $dir2->next) { 119 push @contents, $file; 120 } 121 ok grep {$_ eq '0'} @contents; 122 123 ok chdir($orig); 124 ok $dir->rmtree; 125 ok !-e $dir; 126} 127 128{ 129 my $file = file('t', 'slurp'); 130 ok $file; 131 132 my $fh = $file->open('w') or die "Can't create $file: $!"; 133 print $fh "Line1\nLine2\n"; 134 close $fh; 135 ok -e $file; 136 137 my $content = $file->slurp; 138 is $content, "Line1\nLine2\n"; 139 140 my @content = $file->slurp; 141 is_deeply \@content, ["Line1\n", "Line2\n"]; 142 143 @content = $file->slurp(chomp => 1); 144 is_deeply \@content, ["Line1", "Line2"]; 145 146 $file->remove; 147 ok not -e $file; 148} 149 150{ 151 # Make sure we can make an absolute/relative roundtrip 152 my $cwd = dir(); 153 is $cwd, $cwd->absolute->relative, "from $cwd to ".$cwd->absolute." to ".$cwd->absolute->relative; 154} 155 156{ 157 my $t = dir('t'); 158 my $foo_bar = $t->subdir('foo','bar'); 159 $foo_bar->rmtree; # Make sure it doesn't exist 160 161 ok $t->subsumes($foo_bar), "t subsumes t/foo/bar"; 162 ok !$t->contains($foo_bar), "t doesn't contain t/foo/bar"; 163 164 $foo_bar->mkpath; 165 ok $t->subsumes($foo_bar), "t still subsumes t/foo/bar"; 166 ok $t->contains($foo_bar), "t now contains t/foo/bar"; 167 168 $t->subdir('foo')->rmtree; 169} 170 171{ 172 # Test recursive iteration through the following structure: 173 # a 174 # / \ 175 # b c 176 # / \ \ 177 # d e f 178 # / \ \ 179 # g h i 180 (my $abe = dir(qw(a b e)))->mkpath; 181 (my $acf = dir(qw(a c f)))->mkpath; 182 file($acf, 'i')->touch; 183 file($abe, 'h')->touch; 184 file($abe, 'g')->touch; 185 file('a', 'b', 'd')->touch; 186 187 my $a = dir('a'); 188 189 # Make sure the children() method works ok 190 my @children = sort map $_->as_foreign('Unix'), $a->children; 191 is_deeply \@children, ['a/b', 'a/c']; 192 193 { 194 recurse_test( $a, 195 preorder => 1, depthfirst => 0, # The default 196 precedence => [qw(a a/b 197 a a/c 198 a/b a/b/e/h 199 a/b a/c/f/i 200 a/c a/b/e/h 201 a/c a/c/f/i 202 )], 203 ); 204 } 205 206 { 207 my $files = 208 recurse_test( $a, 209 preorder => 1, depthfirst => 1, 210 precedence => [qw(a a/b 211 a a/c 212 a/b a/b/e/h 213 a/c a/c/f/i 214 )], 215 ); 216 is_depthfirst($files); 217 } 218 219 { 220 my $files = 221 recurse_test( $a, 222 preorder => 0, depthfirst => 1, 223 precedence => [qw(a/b a 224 a/c a 225 a/b/e/h a/b 226 a/c/f/i a/c 227 )], 228 ); 229 is_depthfirst($files); 230 } 231 232 233 $a->rmtree; 234 235 sub is_depthfirst { 236 my $files = shift; 237 if ($files->{'a/b'} < $files->{'a/c'}) { 238 cmp_ok $files->{'a/b/e'}, '<', $files->{'a/c'}, "Ensure depth-first search"; 239 } else { 240 cmp_ok $files->{'a/c/f'}, '<', $files->{'a/b'}, "Ensure depth-first search"; 241 } 242 } 243 244 sub recurse_test { 245 my ($dir, %args) = @_; 246 my $precedence = delete $args{precedence}; 247 my ($i, %files) = (0); 248 $a->recurse( callback => sub {$files{shift->as_foreign('Unix')->stringify} = ++$i}, 249 %args ); 250 while (my ($pre, $post) = splice @$precedence, 0, 2) { 251 cmp_ok $files{$pre}, '<', $files{$post}, "$pre should come before $post"; 252 } 253 return \%files; 254 } 255} 256