Path::Class Test Script

path_class_test.pl

#!perl

use 5.010;
use utf8;
use strict;
use warnings;

use Cwd qw/realpath/;
use Encode;
use File::Temp qw/tempdir/;
use FindBin;
use Path::Class;
use Test::Exception;
use Test::More;

use_ok 'Path::Class';

my $test_dir = dir(tempdir(DIR => '/tmp', CLEANUP => 1));
ok $test_dir , "create test dir => $test_dir";

# create test data
dir($test_dir, 'foo/bar/baz')->mkpath;
file($test_dir, 'foo/bar.txt')->touch;
file($test_dir, 'foo/bar/baz/zzz.txt')->touch;
ok file($test_dir, 'foo/bar.txt'), file($test_dir, 'foo/bar.txt');
ok file($test_dir, 'foo/bar/baz/zzz.txt'), file($test_dir, 'foo/bar/baz/zzz.txt');

# file dir
my $file = file('path', 'to', 'file.txt');
my $dir = dir('path', 'to', 'dir');
is $file, 'path/to/file.txt', 'file';
is $dir, 'path/to/dir', 'dir';

# foreign
$file = $file->as_foreign('Win32');
is $file, 'path\to\file.txt', 'as_foreign';
$file = Path::Class::File->new_foreign('Win32', 'path/to/file.txt');
is $file, 'path\to\file.txt', 'new_foreign';

# absolute
my $relative_file = file('foo/bar.txt');
is $relative_file->absolute, file($FindBin::Bin, $relative_file), 'absolute file';
my $relative_dir = dir('foo/bar');
is $relative_dir->absolute, file($FindBin::Bin, $relative_dir), 'absolute dir';
# relative
my $absolute_file = file($FindBin::Bin, 'foo/bar.txt');
is $absolute_file->relative, 'foo/bar.txt', 'relative file';
my $absolute_dir = dir($FindBin::Bin, 'foo/bar');
is $absolute_dir->relative, 'foo/bar', 'relative dir';

# cleanup resolve
$file = file('/foo/bar/baz////./././../path/file.txt');
$dir = dir('/foo/bar/baz////./././../path/dir');
is $file, '/foo/bar/baz/../path/file.txt', 'cleanup file';
is $dir, '/foo/bar/baz/../path/dir', 'cleanup dir';

# resolve
my $resolve_file = file($test_dir, 'foo/../././///./foo/bar/../../foo/bar.txt');
my $resolve_dir = dir($test_dir, 'foo/././////././../foo/../foo/bar/../bar/baz');
is $resolve_file->resolve, realpath($test_dir . '/foo/bar.txt'), 'resolve file';
is $resolve_dir->resolve, realpath($test_dir . '/foo/bar/baz'), 'resolve dir';
is file($test_dir, 'no/../foo/bar.txt')->resolve, '', 'resolve not exist file';

# parent
is file('foo/bar/baz.txt')->parent, 'foo/bar', 'parent file';
is dir('foo/bar/baz')->parent, 'foo/bar', 'parent dir';

# children
my $foo = dir($test_dir, 'foo');
my @children_list = $foo->children;
is scalar @children_list, 2, 'children';
is $children_list[0], dir($test_dir,'foo/bar' ), 'children element 1';
is $children_list[1], file($test_dir,'foo/bar.txt' ), 'children element 2';

# stat
isa_ok file(__FILE__)->stat, 'File::stat';
isa_ok file(__FILE__)->dir->stat, 'File::stat';
isa_ok file(__FILE__)->lstat, 'File::stat';
can_ok file(__FILE__)->stat, 'mtime';
like file(__FILE__)->stat->atime, qr/\d+/, 'stat';

# recurse
my @recurse_list = ();
$foo->recurse(
    callback => sub {
        push @recurse_list, shift;
    }
);
is scalar @recurse_list, 5, 'recurse';
is $recurse_list[0], $foo, 'recurse element 1';
is $recurse_list[1], dir($test_dir,'foo/bar' ), 'recurse element 2';
is $recurse_list[2], file($test_dir,'foo/bar.txt' ), 'recurse element 3';
is $recurse_list[3], dir($test_dir,'foo/bar/baz' ), 'recurse element 4';
is $recurse_list[4], file($test_dir,'foo/bar/baz/zzz.txt' ), 'recurse element 5';

my @depthfirst_list = ();
$foo->recurse(
    depthfirst => 1,
    preorder => 0,
    callback => sub {
        push @depthfirst_list, shift;
    }
);
is $depthfirst_list[0], file($test_dir,'foo/bar/baz/zzz.txt' ), 'recurse depthfirst element 1';
is $depthfirst_list[1], dir($test_dir,'foo/bar/baz' ), 'recurse depthfirst element 2';
is $depthfirst_list[2], dir($test_dir,'foo/bar' ), 'recurse depthfirst element 3';
is $depthfirst_list[3], file($test_dir,'foo/bar.txt' ), 'recurse depthfirst element 4';
is $depthfirst_list[4], $foo, 'recurse depthfirst element 5';

# touch
my $touch = file($test_dir, 'touch.txt');
ok !-e $touch, 'before touch';
$touch->touch;
my $touch_time = $touch->stat->mtime;
ok -e $touch, 'touch';
sleep 1;
$touch->touch;
cmp_ok $touch_time, ,'<', $touch->stat->mtime, 'touch mtime';
dies_ok { file('/nooooo/touch.txt')->touch } "Can't write";
ok ! -e file('/nooooo/touch.txt'), "Can't wrote";

# mkdir
my $test_mkdir = dir($test_dir, 'mkdir');
ok !-e $test_mkdir, 'before mkdir';
mkdir $test_mkdir or die $!;
ok -e $test_mkdir, 'mkdir';
ok !mkdir(dir($test_mkdir, 'foo/bar/baz/')), "Can't mkdir";
ok !-e dir($test_mkdir, 'foo/bar/baz/'), "Can't mkdir2";

# mkpath
my $test_mkpath = dir($test_mkdir, 'aaa/bbb/ccc');
ok !-e $test_mkpath, 'before mkpath';
$test_mkpath->mkpath;
ok -e $test_mkpath, 'mkpath';
dies_ok { dir('/home/path-class')->mkpath } "Can't mkpath";

# openw
my $test = file($test_dir, 'test.txt');
my $w = $test->openw;
binmode $w, ":utf8";
isa_ok $w, 'IO::File';
$w->print("1行\n");
$w->print("2行\n");
$w->close;
dies_ok { file($test_dir, 'test/test2/test.txt')->openw } "Can't openw";

# open('a')
my $a = $test->open('a') or die $!;
binmode $a, ":utf8";
isa_ok $a, 'IO::File';
$a->print("3行\n");
$a->print("4行\n");
$a->close;
ok !file($test_dir, 'test/test2/test.txt')->open('a'), "Can't open('a')";

# openr
my $r = $test->openr;
binmode $r, ":utf8";
isa_ok $r, 'IO::File';
is $r->getline, "1行\n", 'open 1';
is $r->getline, "2行\n", 'open 2';
is $r->getline, "3行\n", 'open 3';
is $r->getline, "4行\n", 'open 4';
dies_ok { file($test_dir, 'test/test2/test.txt')->openr } "Can't openr";

# slurp
is decode_utf8($test->slurp), "1行\n2行\n3行\n4行\n", "slurp";
is decode_utf8($test->slurp(chomp => 1)), "1行2行3行4行", "slurp chomp";
is $test->slurp(iomode => '<:encoding(UTF-8)'), "1行\n2行\n3行\n4行\n", "slurp iomode";
dies_ok { file($test_dir, 'test/test2/test.txt')->slurp } "Can't slurp";

# remove
$test->remove or die $!;
ok !-e $test, 'remove file';
ok !$test->remove, "Can't remove file";
my $remove_dir = dir($test_dir, 'remove');
mkdir $remove_dir or die $!;
$remove_dir->remove or die $!;
ok !-e $remove_dir, 'remove dir';
ok !$remove_dir->remove, "Can't remove dir";

# rmtree
my $rmtree_dir = dir($test_dir, 'aaa/bbb/ccc');
$rmtree_dir->mkpath or die $!;
ok -e $rmtree_dir, "before rmtree";
$rmtree_dir->rmtree or die $!;
ok !-e $rmtree_dir, 'rmtree';
ok !$rmtree_dir->rmtree, "Can't rmtee";

# parent
{
    package My::File;
    use parent qw(Path::Class::File);
    use Carp;
    sub dir_class { return "My::Dir" }
    sub opena { $_[0]->open('a') or croak "Can't append $_[0]: $!";  }
}
{
    package My::Dir;
    use parent qw(Path::Class::Dir);
    sub file_class { return "My::File" }
}

$file = My::File->new("test.txt");
$dir = $file->dir;
isa_ok $file, "My::File";
isa_ok $dir, "My::Dir";
isa_ok $dir->file('bar.txt'), "My::File";

my $writer = $file->openw;
$writer->print("test\n");
$writer->close;
my $appender = $file->opena;
$appender->print("test2\n");
$appender->close;

is $file->slurp, "test\ntest2\n", 'opena';
$file->remove;

done_testing;