File::System::Test - Module for testing file system drivers

File-System documentation Contained in the File-System distribution.

Index

Code Index:

NAME

Top

File::System::Test - Module for testing file system drivers

DESCRIPTION

Top

This suite of test subroutines will test if a file system object is internally consistent and can be used to test other features of the object.

The following tests are available:

is_root_sane($obj, $name)

Checks to make sure the root file object is generally sane. It tests the following:

  • Is the root object defined?
  • Does the root subroutine of the root object represent the same path?
  • Is the path '/'?
  • Does stringify work correctly?
  • Does basename return ''?
  • Does dirname return '/'?
  • Does a lookup of '' exist? Does it represent the same path?
  • Does a lookup of '.' exist? Does it represent the same path?
  • Does a lookup of '..' exist? Does it represent the same path?
  • Does a lookup of '/' exist? Does it represent the same path?
  • Does is_root return true?
  • Is parent path the same as root path?
  • Does properties return at least basename, dirname, and path?
  • Does is_container return true?

is_object_sane($obj, $name)

This test performs the following:

  • Is the object defined?
  • Does stringify work?
  • Does lookup of path result in object for same path?
  • Does basename return the basename of path?
  • Does dirname return the dirname of path?
  • Does is_root return false?
  • Does parent path match dirname?
  • Does properties return at least basename, dirname, and path?

is_container_sane($obj, $name)

Runs additional container specific tests. It tests the following:

  • Does is_container return true?
  • Can the container has_children?
  • Can the container children_paths?
  • Can the container children?
  • Can the container child?
  • If not has_children, does children_paths return '.' and '..' only? Does children return an empty list?
  • If the container has_children, does children_paths return '.' and '..' and more? Does children return a non-empty list?
  • If the container has_children, does each child return an object for the same path as lookup.

is_content_sane($obj, $name)

Runs additional content specific tests. It tests the following:

  • Does is_content return true?

is_content_writable($obj, $name)

Checks to see if the given file object is writable and confirms that writing works as expected.

  • Check to see if is_readable and is_writable.
  • Does open("w") work?
  • Can we write to the file handle returned by open("w")?
  • Does the file handle close properly?
  • Is the content of the file the same as written?
  • Check to see if is_appendable. If so, write one more line to the end, close and reopen to check that the file is as expected.
  • Check to see if is_seekable. If so, seek into the middle, overwrite part of the file, close andreopen to check that the file is as expected.

is_container_mobile($obj, $dest, $name)

Checks to see if the container $obj can be renamed (to 'renamed_container' and back), moved to the given container $dest (and moved back), and copied to the given container (and the copy removed).

Checks to make sure that after each of these operations that the entire subtree is preserved.

is_container_mobile($obj, $dest, $name)

Checks to see if the content $obj can be renamed (to 'renamed_content' and back), moved to the given container $dest (and moved back), and copied to the given container (and the copy removed).

is_glob_and_find_consistent($obj, $name)

Checks several different glob patterns on the object to see if the glob patterns find the same set of objects that a similar find operation returns. The object passed can be a root object or any other object in the tree.

This method also tests to see that the various different ways of calling glob and find are self-consistent. That is,

  $obj->find(\&test) === $root->find(\&test, $obj)
  $obj->glob($test)  === $root->glob("$obj/$test")

SEE ALSO

Top

File::System::Object

AUTHOR

Top

Andrew Sterling Hanenkamp, <hanenkamp@users.sourceforge.net>

COPYRIGHT AND LICENSE

Top

Copyright 2005 Andrew Sterling Hanenkamp. All Rights Reserved.

This library is licensed and distributed under the same terms as Perl itself.

File-System documentation Contained in the File-System distribution. 
package File::System::Test;

use strict;
use warnings;

our $VERSION = '1.16';

require Exporter;
use File::Basename ();
use Test::Builder;

my $test = Test::Builder->new;

our @ISA    = qw( Exporter );
our @EXPORT = qw(
	prepare
	is_root_sane
	is_object_sane
	is_container_sane
	is_content_sane
	is_content_writable
	is_container_mobile
	is_content_mobile
	is_glob_and_find_consistent
);

sub _check {
	my $true = shift;
	my $name = shift;

	unless ($true) {
		$test->ok(0, $name);
		$test->diag(join('', @_));
		return 0;
	} else {
		return 1;
	}
}


sub is_root_sane {
	my $obj  = shift;
	my $name = shift;

	_check(defined $obj, $name, 'root object does not exist') || return;

	my $root = $obj->root;
	_check($obj->path eq $root->path, $name,
		"root object path [$obj] does not match ->root path [$root]") || return;

	_check($obj->path eq '/', $name, 
		"root object path is [$obj] instead of the desired [/]") || return;

	_check($obj->path eq "$obj", $name,
		"root object stringify was [$obj] instead of [",$obj->path,"]") || return;

	_check($obj->basename eq '/', $name,
		"root object basename was [",$obj->basename,"] instead of [/]") || return;

	_check($obj->dirname eq '/', $name,
		"root object dirname was [",$obj->dirname,"] instead of [/]") || return;

	_check($obj->is_root, $name, "root object [$obj] is not reporting is_root") || return;

	my $parent = $obj->parent;
	_check($obj->path eq $parent->path, $name,
		"root object path is [$obj] but parent is [$parent]") || return;

	_check(grep(/^basename$/, $obj->properties), $name,
		"root object [$obj] properties missing basename") || return;

	_check(grep(/^dirname$/, $obj->properties), $name,
		"root object [$obj] properties missing dirname") || return;

	_check(grep(/^path$/, $obj->properties), $name,
		"root object [$obj] properties missing path") || return;

	_check($obj->is_container, $name, "root object [$obj] is not a container") || return;

	for my $path ('', '.', '..', '/') {
		_check($obj->exists($path), $name, "root [$obj] cannot access file path [$path]") || return;

		my $lookup = $root->lookup($path);
		_check($obj->path eq $lookup->path, $name,
			"root object path [$obj] does not match ->lookup($path) path [$lookup]") || return;
	}

	$test->ok(1, $name);
}


sub is_object_sane {
	my $obj = shift;
	my $name = shift;

	_check(defined $obj, 'object does not exist') || return;

	_check($obj->path eq "$obj", $name,
		"object stringify was [$obj] instead of [",$obj->path,"]") || return;

	my $lookup = $obj->lookup($obj->path);
	_check($obj->path eq $lookup->path, $name,
		"object lookup($obj) results in [$lookup] instead of expected [$obj]") || return;

	_check($obj->basename eq $obj->basename_of_path($obj->path), $name,
		"object [$obj] basename was [",$obj->basename,"] instead of [",
		$obj->basename_of_path($obj->path),"]") || return;

	_check($obj->dirname eq $obj->dirname_of_path($obj->path), $name,
		"object [$obj] dirname was [",$obj->dirname,"] instead of [",
		$obj->dirname_of_path($obj->path),"]") || return;

	_check(!$obj->is_root, $name, "object [$obj] is incorrectly reporting is_root") || return;

	my $parent = $obj->parent;
	_check($obj->dirname eq $parent->path, $name,
		"object [$obj] dirname is [",$obj->dirname,"] but parent path is [$parent]") || return;

	_check(grep(/^basename$/, $obj->properties), $name,
		"object [$obj] properties missing basename") || return;

	_check(grep(/^dirname$/, $obj->properties), $name,
		"object [$obj] properties missing dirname") || return;

	_check(grep(/^path$/, $obj->properties), $name,
		"object [$obj] properties missing path") || return;
	
	$test->ok(1, $name);
}


sub is_container_sane {
	my $obj  = shift;
	my $name = shift;

	_check($obj->is_container, $name, "is_container [$obj] does not return true") || return;

	_check($obj->can("has_children"), $name, 
		"container [$obj] does not have a 'has_children' method.") || return;

	_check($obj->can("children_paths"), $name,
		"container [$obj] does not have a 'children_paths' method.") || return;

	_check($obj->can('children'), $name,
		"container [$obj] does not have a 'children' method.") || return;

	_check($obj->can('child'), $name,
		"container [$obj] does not have a 'child' method.") || return;

	my @children_paths = $obj->children_paths;
	my @children       = $obj->children;
	
	_check(grep(/^\.$/, @children_paths), $name,
		"container [$obj] does not contain a '.' child.") || return;

	_check(grep(/^\.\.$/, @children_paths), $name,
		"container [$obj] does not contain a '..' child.") || return;

	if ($obj->has_children) {
		_check(grep(!/^\.\.?$/, @children_paths), $name,
			"container [$obj] says it has children but children_paths returns none") || return;

		_check(scalar(@children) > 0, $name,
			"container [$obj] says it has children but children returns none") || return;

		for my $path (@children_paths) {
			my $lookup = $obj->lookup($path);
			my $child  = $obj->child($path);

            my $lookup_path = eval { $lookup->path } || '<undef>';
            my $child_path  = eval { $child->path }  || '<undef>';

			_check($lookup_path eq $child_path, $name,
				"container [$obj] doesn't find the same object via child() [$child_path] as it does for lookup() [$lookup_path] of $path") || return;
		}
	} else {
		_check(!grep(!/^\.\.?$/, @children_paths), $name,
			"container says it has no children but children_paths returns some") || return;

		_check(scalar(@children) == 0, $name,
			"container says it has no children but children returns some") || return;
	}

	$test->ok(1, $name);
}


sub is_content_sane {
	my $obj  = shift;
	my $name = shift;

	_check($obj->has_content, $name, "has_content [$obj] does not return true") || return;

	$test->ok(1, $name);
}


sub is_content_writable {
	my $obj  = shift;
	my $name = shift;

	_check($obj->is_readable, $name, "is_readable [$obj] returns false") || return;

	_check($obj->is_writable, $name, "is_writable [$obj] returns false") || return;

	my $fh = $obj->open("w");
	_check(defined $fh, $name, "open('w') [$obj] returns undef") || return;

	my @expected = (
		"Hello World\n",
		"foo\n",
		"bar\n",
		"baz\n",
		"qux\n",
	);

	for my $line (@expected) {
		_check(print($fh $line), $name, "print [$obj] failed on file handle") || return;
	}

	_check(close($fh), $name, "[$obj] failed to close file handle") || return;

	my $content = $obj->content;
	_check($content eq join('', @expected), $name,
		"[$obj] content read from file '$content' doesn't match expected") || return;

	my @content = $obj->content;
	for (my $n = 0; $n < @content; ++$n) {
		_check($content[$n] eq $expected[$n], $name,
			"[$obj] content read from line $n of file, '$content[$n]', doesn't match expected") || return;
	}

	if ($obj->is_appendable) {
		my $fh = $obj->open("a");
		_check(defined $fh, $name, "open('a') [$obj] returns undef") || return;

		_check(print($fh "quux\n"), $name, "print [$obj] failed on appendable file handle") || return;

		_check(close($fh), $name, "[$obj] failed to close appendable file handle") || return;

		push @expected, "quux\n";
		my $content = $obj->content;
		_check($content eq join('', @expected), $name,
			"[$obj] content read from appended file '$content' doesn't match expected") || return;
	}

	if ($obj->is_seekable) {
		my $fh = $obj->open("r+");
		_check(defined $fh, $name, "open('w') [$obj] returns undef") || return;

		_check(seek($fh, 16, 0), $name, "seek [$obj] returned a failure") || return;

		_check(print($fh "huh\n"), $name, "print [$obj] failed on seeked file handle") || return;

		_check(close($fh), $name, "[$obj] failed to close seeked file handle") || return;

		splice @expected, 2, 1, "huh\n";
		my $content = $obj->content;
		_check($content eq join('', @expected), $name,
			"[$obj] content read from seeked file '$content' doesn't match expected") || return;
	}

	$test->ok(1, $name);
}


sub is_container_mobile {
	my $obj  = shift;
	my $dest = shift;
	my $name = shift;

	# RENAME
	my $basename = $obj->basename;
	my $path = $obj->path;
	my $renamed_path = $obj->normalize_path($obj->dirname.'/renamed_container');

	my @files = $obj->find(sub { shift->path ne $obj->path });
	my @renamed_files = 
		map { my $p = $_->path; $p =~ s/^$obj/$renamed_path/; $p } @files;

	_check($obj->rename('renamed_container')->path eq $renamed_path, $name,
		"renamed container path is '$obj' rather than '$renamed_path'") || return;

	for my $path (@files) {
		_check(!$path->exists, $name,
			"renamed container '$obj' failed to rename child from '$path'") || return;
	}

	for my $path (@renamed_files) {
		_check($obj->exists($path), $name,
			"renamed container '$obj' failed to rename child to '$path'") || return;
	}

	_check($obj->rename($basename)->path eq $path, $name,
		"originally renamed container path is '$obj' rather than '$path'") || return;

	for my $path (@files) {
		_check($path->exists, $name,
			"originally renamed container '$obj' failed to rename child to '$path'") || return;
	}

	for my $path (@renamed_files) {
		_check(!$obj->exists($path), $name,
			"originally renamed container '$obj' failed to rename child from '$path'") || return;
	}

	# MOVE
	my $parent = $obj->parent;
	my $new_path = $obj->normalize_path($dest->path."/$basename");

	my @new_files = 
		map { my $p = $_->path; $p =~ s/^$obj/$new_path/; $p } @files;

	_check($obj->move($dest, 'force')->path eq $new_path, $name,
		"moved container path is '$obj' rather than '$new_path'") || return;

	for my $path (@files) {
		_check(!$obj->exists($path), $name,
			"moved container '$obj' failed to move child from '$path'") || return;
	}
	
	for my $path (@new_files) {
		_check($obj->exists($path), $name,
			"moved container '$obj' failed to move child to '$path'") || return;
	}

	_check($obj->move($parent, 'force')->path eq $path, $name,
		"originally moved container path is '$obj' rather than '$path'") || return;

	for my $path (@files) {
		_check($path->exists, $name,
			"originally moved container '$obj' failed to move child to '$path'") || return;
	}
	
	for my $path (@new_files) {
		_check(!$obj->exists($path), $name,
			"originally moved container '$obj' failed to move child from '$path'") || return;
	}

	# COPY
	my $copy = $obj->copy($dest, 'force');
	_check($copy->path eq $new_path, $name,
		"copied container path is '$obj' rather than '$new_path'") || return;

	for my $path (@files) {
		_check($obj->exists($path), $name,
			"original container '$obj' lost child from '$path' after copy") || return;
	}
	
	for my $path (@new_files) {
		_check($obj->exists($path), $name,
			"copied container '$copy' failed to copy child to '$path'") || return;
	}

	# REMOVE
	$copy->remove('force');
	_check(!$copy->is_valid, $name,
		"removed container '$copy' is still valid") || return;

	for my $path (@files) {
		_check($path->exists, $name,
			"pre-copy container '$obj' lost child to '$path' when copy container '$copy' was removed") || return;
	}
	
	for my $path (@new_files) {
		_check(!$obj->exists($path), $name,
			"removed container '$copy' failed to remove child from '$path'") || return;
	}

	$test->ok(1, $name);
}


sub is_content_mobile {
	my $obj  = shift;
	my $dest = shift;
	my $name = shift;

	# RENAME
	my $basename = $obj->basename;
	my $path = $obj->path;
	my $renamed_path = $obj->normalize_path($obj->dirname.'/renamed_content');

	_check($obj->rename('renamed_content')->path eq $renamed_path, $name,
		"renamed content path is '$obj' rather than '$renamed_path'") || return;

	_check($obj->rename($basename)->path eq $path, $name,
		"originally renamed content path is '$obj' rather than '$path'") || return;

	# MOVE
	my $parent = $obj->parent;
	my $new_path = $obj->normalize_path($dest->path."/$basename");

	_check($obj->move($dest)->path eq $new_path, $name,
		"moved content path is '$obj' rather than '$new_path'") || return;

	_check($obj->move($parent)->path eq $path, $name,
		"originally moved content path is '$obj' rather than '$path'") || return;

	# COPY
	my $copy = $obj->copy($dest);
	_check($copy->path eq $new_path, $name,
		"copied content path is '$obj' rather than '$new_path'") || return;

	# REMOVE
	$copy->remove;
	_check(!$copy->is_valid, $name,
		"removed content '$copy' is still valid") || return;

	$test->ok(1, $name);
}


sub is_glob_and_find_consistent {
	my $obj  = shift;
	my $name = shift;

	my @tests = (
		[ '*{ar,az}', sub { $_[0]->path !~ /\/\.[^\/]+$/ 
								&& $_[0]->parent eq $obj
								&& $_[0]->path =~ /ar$|az$/ } ],
		[ '*',        sub { $_[0]->parent eq $obj
								&& $_[0]->path !~ /\/\.[^\/]+$/
								&& $_[0]->path ne $obj->path } ],
		[ '.??*',     sub { $_[0]->parent eq $obj
								&& $_[0]->path =~ /\/\.[^\/]+$/ } ],
		[ '*/*',      sub { $_[0]->path =~ /^$obj\/?[^\/]+\//
								&& $_[0]->path !~ /^$obj\/?[^\/]+\/[^\/]+\//
								&& $_[0]->path !~ /\/\.[^\/]+$/
						   		&& $_[0]->path !~ /\/\.[^\/]+\/[^\/]+$/ } ],
	);

	my $root = $obj->root;
	for my $test (@tests) {
		my @glob = $obj->glob($test->[0]);
		my @find = $obj->find($test->[1]);

		my @root_glob = $root->glob("$obj/$test->[0]");
		my @root_find = $root->find($test->[1], $obj);

		my $glob_err = join ', ', @glob;
		my $find_err = join ', ', @find;

		my $root_glob_err = join ', ', @root_glob;
		my $root_find_err = join ', ', @root_find;

		_check(@glob eq @find, $name, "in '$obj' for '$test->[0]', glob returned [ $glob_err ] but find returned [ $find_err ]") || return;

		_check(@glob eq @root_glob, $name, "in '$obj' for '$test->[0]', obj glob returned [ $glob_err ] but root glob returned [ $root_glob_err ]") || return;

		_check(@find eq @root_find, $name, "in '$obj' for '$test->[0]', obj find returned [ $find_err ] but root find returned [ $root_find_err ]") || return;

		for (my $i = 0; $i < @glob; ++$i) {
			_check($glob[$i] eq $find[$i], $name, "in '$obj' element $i of glob was '$glob[$i]', but element $i of find was '$find[$i]'") || return;

			_check($glob[$i] eq $root_glob[$i], $name, "in '$obj' element $i of obj glob was '$glob[$i]', but element $i of root glob was '$root_glob[$i]'") || return;

			_check($find[$i] eq $root_find[$i], $name, "in '$obj' element $i of obj find was '$find[$i]', but element $i of root find was '$root_find[$i]'") || return;
		}
	}

	$test->ok(1, $name);
}


1