summaryrefslogtreecommitdiff
path: root/t/filesystem.t
diff options
context:
space:
mode:
Diffstat (limited to 't/filesystem.t')
-rw-r--r--t/filesystem.t415
1 files changed, 415 insertions, 0 deletions
diff --git a/t/filesystem.t b/t/filesystem.t
new file mode 100644
index 0000000..ec5146c
--- /dev/null
+++ b/t/filesystem.t
@@ -0,0 +1,415 @@
+use 5.008001;
+use strict;
+use warnings;
+use Test::More 0.96;
+use File::Temp qw(tmpnam tempdir);
+use File::Spec;
+use Cwd;
+
+use lib 't/lib';
+use TestUtils qw/exception/;
+
+use Path::Tiny;
+
+# Tests adapted from Path::Class t/basic.t
+
+my $file = path( scalar tmpnam() );
+ok $file, "Got a filename via tmpnam()";
+
+{
+ my $fh = $file->openw;
+ ok $fh, "Opened $file for writing";
+
+ ok print( $fh "Foo\n" ), "Printed to $file";
+}
+
+ok -e $file, "$file should exist";
+ok $file->is_file, "it's a file!";
+
+if ( -e "/dev/null" ) {
+ ok( path("/dev/null")->is_file, "/dev/null is_file, too" );
+}
+
+my ( $volume, $dirname, $basename ) =
+ map { s{\\}{/}; $_ } File::Spec->splitpath($file);
+is( $file->volume, $volume, "volume correct" );
+is( $file->volume, $volume, "volume cached " ); # for coverage
+is( $file->dirname, $dirname, "dirname correct" );
+is( $file->basename, $basename, "basename correct" );
+
+{
+ my $fh = $file->openr;
+ is scalar <$fh>, "Foo\n", "Read contents of $file correctly";
+}
+
+note "stat";
+{
+ my $stat = $file->stat;
+ ok $stat;
+ cmp_ok $stat->mtime, '>', time() - 20; # Modified within last 20 seconds
+
+ $stat = $file->parent->stat;
+ ok $stat;
+}
+
+note "stat/lstat with no file";
+{
+ my $file = "i/do/not/exist";
+ ok exception { path($file)->stat };
+ ok exception { path($file)->lstat };
+}
+
+1 while unlink $file;
+ok not -e $file;
+
+my $dir = path( tempdir( TMPDIR => 1, CLEANUP => 1 ) );
+ok $dir;
+ok -d $dir;
+ok $dir->is_dir, "It's a directory!";
+
+$file = $dir->child('foo.x');
+$file->touch;
+ok -e $file;
+my $epoch = time - 10;
+utime $epoch, $epoch, $file;
+$file->touch;
+ok( $file->stat->mtime > $epoch, "touch sets utime as current time" );
+$file->touch($epoch);
+ok( $file->stat->mtime == $epoch, "touch sets utime as 10 secs before" );
+
+{
+ my @files = $dir->children;
+ is scalar @files, 1 or diag explain \@files;
+ ok scalar grep { /foo\.x/ } @files;
+}
+
+ok $dir->remove_tree, "Removed $dir";
+ok !-e $dir, "$dir no longer exists";
+ok !$dir->remove_tree, "Removing non-existent dir returns false";
+
+my $tmpdir = Path::Tiny->tempdir;
+
+{
+ $dir = path( $tmpdir, 'foo', 'bar' );
+ $dir->parent->remove_tree if -e $dir->parent;
+
+ ok $dir->mkpath, "Created $dir";
+ ok -d $dir, "$dir is a directory";
+
+ $dir = $dir->parent;
+ ok $dir->remove_tree( { safe => 1 } ); # check that we pass through args
+ ok !-e $dir;
+}
+
+{
+ $dir = path( $tmpdir, 'foo' );
+ ok $dir->mkpath;
+ ok $dir->child('dir')->mkpath;
+ ok -d $dir->child('dir');
+
+ ok $dir->child('file.x')->touch;
+ ok $dir->child('0')->touch;
+ ok $dir->child('foo/bar/baz.txt')->touchpath;
+
+ subtest 'iterator' => sub {
+ my @contents;
+ my $iter = $dir->iterator;
+ while ( my $file = $iter->() ) {
+ push @contents, $file;
+ }
+ is scalar @contents, 4
+ or diag explain \@contents;
+ is( $iter->(), undef, "exhausted iterator is undef" );
+
+ my $joined = join ' ', sort map $_->basename, grep { -f $_ } @contents;
+ is $joined, '0 file.x'
+ or diag explain \@contents;
+
+ my ($subdir) = grep { $_ eq $dir->child('dir') } @contents;
+ ok $subdir;
+ is -d $subdir, 1;
+
+ my ($file) = grep { $_ eq $dir->child('file.x') } @contents;
+ ok $file;
+ is -d $file, '';
+ };
+
+ subtest 'visit' => sub {
+ my @contents;
+ $dir->visit( sub { push @contents, $_[0] } );
+ is scalar @contents, 4
+ or diag explain \@contents;
+
+ my $joined = join ' ', sort map $_->basename, grep { -f $_ } @contents;
+ is $joined, '0 file.x'
+ or diag explain \@contents;
+
+ my ($subdir) = grep { $_ eq $dir->child('dir') } @contents;
+ ok $subdir;
+ is -d $subdir, 1;
+
+ my ($file) = grep { $_ eq $dir->child('file.x') } @contents;
+ ok $file;
+ is -d $file, '';
+ };
+
+ ok $dir->remove_tree;
+ ok !-e $dir;
+
+ # Try again with directory called '0', in curdir
+ my $orig = Path::Tiny->cwd;
+
+ ok $dir->mkpath;
+ ok chdir($dir);
+ my $dir2 = path(".");
+ ok $dir2->child('0')->mkpath;
+ ok -d $dir2->child('0');
+
+ subtest 'iterator' => sub {
+ my @contents;
+ my $iter = $dir2->iterator;
+ while ( my $file = $iter->() ) {
+ push @contents, $file;
+ }
+ ok grep { $_ eq '0' } @contents;
+ };
+ subtest 'visit' => sub {
+ my @contents;
+ $dir2->visit( sub { push @contents, $_[0] } );
+ ok grep { $_ eq '0' } @contents;
+ };
+
+ ok chdir($orig);
+ ok $dir->remove_tree;
+ ok !-e $dir;
+}
+
+{
+ my $file = path( $tmpdir, 'slurp' );
+ ok $file;
+
+ my $fh = $file->openw or die "Can't create $file: $!";
+ print $fh "Line1\nLine2\n";
+ close $fh;
+ ok -e $file;
+
+ my $content = $file->slurp;
+ is $content, "Line1\nLine2\n";
+
+ my @content = $file->lines;
+ is_deeply \@content, [ "Line1\n", "Line2\n" ];
+
+ @content = $file->lines( { chomp => 1 } );
+ is_deeply \@content, [ "Line1", "Line2" ];
+
+ ok( $file->remove, "removing file" );
+ ok !-e $file, "file is gone";
+ ok !$file->remove, "removing file again returns false";
+
+ my $subdir = $tmpdir->child('subdir');
+ ok $subdir->mkpath;
+ ok exception { $subdir->remove }, "calling 'remove' on a directory throws";
+ ok rmdir $subdir;
+
+ my $orig = Path::Tiny->cwd;
+ ok chdir $tmpdir;
+ my $zero_file = path '0';
+ ok $zero_file->openw;
+ ok $zero_file->remove, "removing file called '0'";
+ ok chdir $orig;
+}
+
+{
+ my $file = path( $tmpdir, 'slurp' );
+ ok $file;
+
+ my $fh = $file->openw(':raw') or die "Can't create $file: $!";
+ print $fh "Line1\r\nLine2\r\n\302\261\r\n";
+ close $fh;
+ ok -e $file;
+
+ my $content = $file->slurp( { binmode => ':raw' } );
+ is $content, "Line1\r\nLine2\r\n\302\261\r\n", "slurp raw";
+
+ my $line3 = "\302\261\n";
+ utf8::decode($line3);
+
+ $content = $file->slurp( { binmode => ':crlf:utf8' } );
+ is $content, "Line1\nLine2\n" . $line3, "slurp+crlf+utf8";
+
+ my @content = $file->lines( { binmode => ':crlf:utf8' } );
+ is_deeply \@content, [ "Line1\n", "Line2\n", $line3 ], "lines+crlf+utf8";
+
+ chop($line3);
+ @content = $file->lines( { chomp => 1, binmode => ':crlf:utf8' } );
+ is_deeply \@content, [ "Line1", "Line2", $line3 ], "lines+chomp+crlf+utf8";
+
+ $file->remove;
+ ok not -e $file;
+}
+
+{
+ my $file = path( $tmpdir, 'spew' );
+ $file->remove() if $file->exists;
+ $file->spew( { binmode => ':raw' }, "Line1\r\n" );
+ $file->append( { binmode => ':raw' }, "Line2" );
+
+ my $content = $file->slurp( { binmode => ':raw' } );
+
+ is( $content, "Line1\r\nLine2" );
+}
+
+{
+ # Make sure we can make an absolute/relative roundtrip
+ my $cwd = path(".");
+ is $cwd, $cwd->absolute->relative,
+ "from $cwd to " . $cwd->absolute . " to " . $cwd->absolute->relative;
+}
+
+{
+ # realpath should resolve ..
+ my $lib = path("t/../lib");
+ my $real = $lib->realpath;
+ unlike $real, qr/\.\./, "updir gone from realpath";
+ my $abs_lib = $lib->absolute;
+ my $abs_t = path("t")->absolute;
+ my $case = $abs_t->child("../lib");
+ is( $case->realpath, $lib->realpath, "realpath on absolute" );
+
+ # non-existent directory in realpath should throw error
+ eval { path("lkajdfak/djslakdj")->realpath };
+ like(
+ $@,
+ qr/Error resolving realpath/,
+ "caught error from realpath on non-existent dir"
+ );
+
+ # but non-existent basename in realpath should throw error
+ eval { path("./djslakdj")->realpath };
+ is( $@, '', "no error from realpath on non-existent last component" );
+}
+
+subtest "copy()" => sub {
+ my $file = $tmpdir->child("foo.txt");
+ $file->spew("Hello World\n");
+
+ my $copy;
+ subtest "dest is a file" => sub {
+ $copy = $tmpdir->child("bar.txt");
+ my $result = $file->copy($copy);
+ is "$result" => "$copy", "returned the right file";
+
+ is( $copy->slurp, "Hello World\n", "file copied" );
+ };
+
+ subtest "dest is a dir" => sub {
+ # new tempdir nto to clobber the original foo.txt
+ my $tmpdir = Path::Tiny->tempdir;
+ my $result = $file->copy($tmpdir);
+
+ is "$result" => "$tmpdir/foo.txt", "returned the right file";
+
+ is $result->slurp, "Hello World\n", "file copied";
+ };
+
+ subtest "try some different chmods" => sub {
+ ok( $copy->chmod(0000), "chmod(0000)" );
+ ok( $copy->chmod("0400"), "chmod('0400')" );
+ SKIP: {
+ skip "No exception if run as root", 1 if $> == 0;
+ skip "No exception writing to read-only file", 1
+ unless
+ exception { open my $fh, ">", "$copy" or die }; # probe if actually read-only
+ my $error = exception { $file->copy($copy) };
+ ok( $error, "copy throws error if permission denied" );
+ like( $error, qr/\Q$file/, "error messages includes the source file name" );
+ like( $error, qr/\Q$copy/, "error messages includes the destination file name" );
+ }
+ ok( $copy->chmod("u+w"), "chmod('u+w')" );
+ };
+};
+
+{
+ $tmpdir->child( "subdir", "touched.txt" )->touchpath->spew("Hello World\n");
+ is(
+ $tmpdir->child( "subdir", "touched.txt" )->slurp,
+ "Hello World\n",
+ "touch can chain"
+ );
+}
+
+SKIP: {
+ my $newtmp = Path::Tiny->tempdir;
+ my $file = $newtmp->child("foo.txt");
+ my $link = $newtmp->child("bar.txt");
+ $file->spew("Hello World\n");
+ eval { symlink $file => $link };
+ skip "symlink unavailable", 1 if $@;
+ ok( $link->lstat->size, "lstat" );
+
+ ok $link->remove, 'remove symbolic link';
+ ok $file->remove;
+
+ $file = $newtmp->child("foo.txt");
+ $link = $newtmp->child("bar.txt");
+ $file->spew("Hello World\n");
+ ok symlink $file => $link;
+
+ ok $file->remove;
+ ok $link->remove, 'remove broken symbolic link';
+
+ my $dir = $newtmp->child('foo');
+ $link = $newtmp->child("bar");
+ ok $dir->mkpath;
+ ok -d $dir;
+ $file = $dir->child("baz.txt");
+ $file->spew("Hello World\n");
+ ok symlink $dir => $link;
+
+ ok $link->remove_tree, 'remove_tree symbolic link';
+ ok $dir->remove_tree;
+
+ $dir = $newtmp->child('foo');
+ $link = $newtmp->child("bar");
+ ok $dir->mkpath;
+ ok -d $dir;
+ $file = $dir->child("baz.txt");
+ $file->spew("Hello World\n");
+ ok symlink $dir => $link;
+
+ ok $dir->remove_tree;
+ ok $link->remove_tree, 'remove_tree broken symbolic link';
+
+ $file = $newtmp->child("foo.txt");
+ $link = $newtmp->child("bar.txt");
+ my $link2 = $newtmp->child("baz.txt");
+ $file->spew("Hello World\n");
+ ok symlink $file => $link;
+ ok symlink $link => $link2;
+ $link2->spew("Hello Perl\n");
+ ok -l $link2, 'path is still symbolic link after spewing';
+ is readlink($link2), $link, 'symbolic link is available after spewing';
+ is readlink($link), $file, 'symbolic link is available after spewing';
+ is $file->slurp, "Hello Perl\n",
+ 'spewing follows the link and replace the destination instead';
+}
+
+# We don't have subsume so comment these out. Keep in case we
+# implement it later
+
+##{
+## my $t = path( 't');
+## my $foo_bar = $t->child('foo','bar');
+## $foo_bar->remove; # Make sure it doesn't exist
+##
+## ok $t->subsumes($foo_bar), "t subsumes t/foo/bar";
+## ok !$t->contains($foo_bar), "t doesn't contain t/foo/bar";
+##
+## $foo_bar->mkpath;
+## ok $t->subsumes($foo_bar), "t still subsumes t/foo/bar";
+## ok $t->contains($foo_bar), "t now contains t/foo/bar";
+##
+## $t->child('foo')->remove;
+##}
+
+done_testing;
View Lorry Controller Status