The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use File::Basename;
use File::Path;
use File::System::Test;
use Test::More tests => 2774;

BEGIN { use_ok('File::System') }

-d 't/root' and rmtree('t/root', 1);
mkpath('t/root', 1, 0700);

-d 't/root2' and rmtree('t/root2', 1);
mkpath('t/root2', 1, 0700);

-d 't/root3' and rmtree('t/root3', 1);
mkpath('t/root3', 1, 0700);

-d 't/root4' and rmtree('t/root4', 1);
mkpath('t/root4', 1, 0700);

-d 't/root5' and rmtree('t/root5', 1);
mkpath('t/root5', 1, 0700);

my $root = File::System->new('Table', 
	'/'    => [ 'Real', root => 't/root' ],
);

# Checking initial file system root
is_root_sane($root);

my @mounts = (
	undef,
	[   mount => '/bar'         => 't/root2' => 't/root/bar'  ],
	[   mount => '/bar/baz'     => 't/root3' => 't/root2/baz' ],
	[   mount => '/bar/baz/qux' => 't/root4' => 't/root3/qux' ],
	[   mount => '/.bar'        => 't/root5' => 't/root/.bar' ],
	[ unmount => '/bar/baz/qux' => 't/root4' => 't/root3/qux' ],
	[ unmount => '/.bar'        => 't/root5' => 't/root/.bar' ],
	[ unmount => '/bar/baz'     => 't/root3' => 't/root2/baz' ],
	[ unmount => '/bar'         => 't/root2' => 't/root/bar'  ],
);

my %mounts = (
	'/'            => 't/root',
	'/bar'         => 't/root2',
	'/bar/baz'     => 't/root3',
	'/bar/baz/qux' => 't/root4',
	'/.bar'        => 't/root5',
);

my @dirs = qw(
	.bar .bar/.baz .bar/.baz/.qux .file2
	bar bar/baz bar/baz/qux file2
);

my @files = qw(
	.baz .file1 .file2/bar .file2/foo .file3 .file4 .foo .qux
	baz file1 file2/bar file2/foo file3 file4 foo qux
);

my @expected_mounts = ( '/' );
is_deeply([ sort $root->mounts ], [ sort @expected_mounts ]);

for my $cmd (@mounts) {

	if (defined $cmd && $cmd->[0] eq 'mount') {
		$root->mount($cmd->[1], [ 'Real', root => $cmd->[2] ]);

		push @expected_mounts, $cmd->[1];
		is_deeply([ sort $root->mounts ], [ sort @expected_mounts ]);
	} elsif (defined $cmd) {
		$root->unmount($cmd->[1]);

		@expected_mounts = grep { $cmd->[1] ne $_ } @expected_mounts;
		is_deeply([ sort $root->mounts ], [ sort @expected_mounts ]);
	}

	# create
	for my $path (@dirs) {
		ok(defined $root->create($path, 'd'));
	}

	for my $path (@files) {
		ok(defined $root->create($path, 'f'));
	}

	for my $path (@dirs, @files) {
		ok($root->exists($path));
		is_object_sane($root->lookup($path));
	}

	# Check to make sure child does essentially the same
	ok(defined $root->child('foo'));
	ok(!defined $root->child('foo2'));

	for my $path (@dirs, @files) {
		my $obj = $root->lookup($path);

		is_object_sane($obj);
	 
		# properties
		is_deeply([ $obj->properties ], [ qw/ basename dirname path object_type dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks / ]);
		is_deeply([ $obj->settable_properties ], [ qw/ mode uid gid atime mtime / ]);
	 
		$obj->set_property('mode', 0700);
		is($obj->get_property('mode') & 0777, 0700);
	 
		my $yesterday = time - 86400;
		$obj->set_property('atime', $yesterday);
		$obj->set_property('mtime', $yesterday);
		is($obj->get_property('atime'), $yesterday);
		is($obj->get_property('mtime'), $yesterday);
	}

	for my $path (@files) {
		my ($mp) = 
			sort { -(length($a) <=> length($b)) } 
			grep { $root->normalize_path($path) =~ /^$_/ } $root->mounts;
		my $real_path = $root->normalize_path($path);
		$real_path =~ s[$mp][$mounts{$mp}/];
		ok(-f $real_path);

		my $obj = $root->lookup($path);

		is_content_sane($obj);
		is_content_writable($obj);

		my $dir = $root->create("$mp/move_test", 'd');
		is_content_mobile($obj, $dir);
		$dir->remove('force');
	}

	for my $path (@dirs) {
		my ($mp) = 
			sort { -(length($a) <=> length($b)) } 
			grep { $root->normalize_path($path) =~ /$_/ } $root->mounts;
		my $real_path = $root->normalize_path($path);
		$real_path =~ s[$mp][$mounts{$mp}/];
		ok(-d $real_path);
		
		my $obj = $root->lookup($path);

		is_container_sane($obj);

		next if $mp = $obj->path;
		
		my $dir = $root->create("$mp/move_test", 'd');
		is_container_mobile($obj, $dir);
		$dir->remove('force');
	}

	is_glob_and_find_consistent($root);

	for my $path (@dirs) {
		my $obj = $root->lookup($path);

		is_glob_and_find_consistent($obj);
	}
}

rmtree([ qw( t/root t/root2 t/root3 t/root4 t/root5 ) ], 1);