The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use 5.008001;
use strict;
use warnings;
use Test::More 0.96;
use Test::Fatal;
use File::Temp qw(tmpnam tempdir);
use File::Spec;

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!";
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";
}

{
    my $stat = $file->stat;
    ok $stat;
    cmp_ok $stat->mtime, '>', time() - 20;           # Modified within last 20 seconds

    $stat = $file->parent->stat;
    ok $stat;
}

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;
utime time - 10, time - 10, $file;
$file->touch;
ok( $file->stat->mtime > ( time - 10 ), "touch sets utime" );

{
    my @files = $dir->children;
    is scalar @files, 1 or diag explain \@files;
    ok scalar grep { /foo\.x/ } @files;
}

ok $dir->remove, "Removed $dir";
ok !-e $dir, "$dir no longer exists";
ok $dir->remove, "Removing non-existent dir returns true";

my $tmpdir = Path::Tiny->tempdir;

{
    $dir = path( $tmpdir, 'foo', 'bar' );
    $dir->parent->remove if -e $dir->parent;

    ok $dir->mkpath, "Created $dir";
    ok -d $dir, "$dir is a directory";

    $dir = $dir->parent;
    ok $dir->remove( { 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;
    my @contents;
    my $iter = $dir->iterator;
    while ( my $file = $iter->() ) {
        push @contents, $file;
    }
    is scalar @contents, 3
      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, '';

    ok $dir->remove;
    ok !-e $dir;

    # Try again with directory called '0', in curdir
    my $orig = path()->absolute;

    ok $dir->mkpath;
    ok chdir($dir);
    my $dir2 = path();
    ok $dir2->child('0')->mkpath;
    ok -d $dir2->child('0');

    @contents = ();
    $iter     = $dir2->iterator;
    while ( my $file = $iter->() ) {
        push @contents, $file;
    }
    ok grep { $_ eq '0' } @contents;

    ok chdir($orig);
    ok $dir->remove;
    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 true";
}

{
    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";

    my $line3 = "\302\261\n";
    utf8::decode($line3);
    my @content = $file->lines( { binmode => ':crlf:utf8' } );
    is_deeply \@content, [ "Line1\n", "Line2\n", $line3 ];

    chop($line3);
    @content = $file->lines( { chomp => 1, binmode => ':crlf:utf8' } );
    is_deeply \@content, [ "Line1", "Line2", $line3 ];

    $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;
}

{
    my $file = $tmpdir->child("foo.txt");
    $file->spew("Hello World\n");
    my $copy = $tmpdir->child("bar.txt");
    $file->copy($copy);
    is( $copy->slurp, "Hello World\n", "file copied" );
    chmod 0400, $copy; # read only
    ok( exception { $file->copy($copy) }, "copy throws error if permission denied" );
}

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" );
}

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