Test::File - test file attributes

	git://github.com/briandfoy/test-file.git

package Test::File;
use strict;

use base qw(Exporter);
use vars qw(@EXPORT $VERSION);

use File::Spec;
use Test::Builder;

@EXPORT = qw(
	file_exists_ok file_not_exists_ok
	file_empty_ok file_not_empty_ok file_size_ok file_max_size_ok
	file_min_size_ok file_readable_ok file_not_readable_ok file_writeable_ok
	file_not_writeable_ok file_executable_ok file_not_executable_ok
	file_mode_is file_mode_isnt
	file_is_symlink_ok
	symlink_target_exists_ok symlink_target_is
	symlink_target_dangles_ok
	link_count_is_ok link_count_gt_ok link_count_lt_ok
	owner_is owner_isnt
	group_is group_isnt
    file_line_count_is file_line_count_isnt file_line_count_between
	);

$VERSION = '1.29';

{
use warnings;
}

my $Test = Test::Builder->new();

sub _normalize
	{
	my $file = shift;
	return unless defined $file;

	return $file =~ m|/|
		? File::Spec->catfile( split m|/|, $file )
		: $file;
	}

sub _win32
	{
	return 0 if $^O eq 'darwin';
	return $^O =~ m/Win/;
	}

# returns true if symlinkscan't exist
sub _no_symlinks_here { ! eval { symlink("",""); 1 } }

# owner_is and owner_isn't should skip on OS where the question makes no
# sence.  I really don't know a good way to test for that, so I'm going
# to skip on the two OS's that I KNOW aren't multi-user.  I'd love to add
# more if anyone knows of any
#   Note:  I don't have a dos or mac os < 10 machine to test this on
sub _obviously_non_multi_user
	{
	foreach my $os ( qw(dos MacOS) ) { return 1 if $^O eq $os }

	eval { my $holder = getpwuid(0) };
	return 1 if $@;

	eval { my $holder = getgrgid(0) };
	return 1 if $@;

	return 0;
	}

sub file_exists_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename exists";

	my $ok = -e $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] does not exist");
		$Test->ok(0, $name);
		}
	}

sub file_not_exists_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename does not exist";

	my $ok = not -e $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] exists");
		$Test->ok(0, $name);
		}
	}

sub file_empty_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is empty";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = -z $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] exists with non-zero size!" );
		$Test->ok(0, $name);
		}
	}

sub file_not_empty_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not empty";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = not -z _;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] exists with zero size!" );
		$Test->ok(0, $name);
		}
	}

sub file_size_ok
	{
	my $filename = _normalize( shift );
	my $expected = int shift;
	my $name     = shift || "$filename has right size";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) == $expected;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size [$actual] not [$expected]!" );

		$Test->ok(0, $name);
		}
	}

sub file_max_size_ok
	{
	my $filename = _normalize( shift );
	my $max      = int shift;
	my $name     = shift || "$filename is under $max bytes";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) <= $max;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size [$actual] " .
			"greater than [$max]!"
			);

		$Test->ok(0, $name);
		}
	}

sub file_min_size_ok
	{
	my $filename = _normalize( shift );
	my $min      = int shift;
	my $name     = shift || "$filename is over $min bytes";

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok(0, $name);
		}

	my $ok = ( -s $filename ) >= $min;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		my $actual = -s $filename;
		$Test->diag(
			"File [$filename] has actual size ".
			"[$actual] less than [$min]!"
			);

		$Test->ok(0, $name);
		}
	}

sub _ENOFILE   () { -1 }
sub _ECANTOPEN () { -2 }

sub _file_line_counter
	{
	my $filename = shift;
	
	return _ENOFILE   unless -e $filename;  # does not exist
	
	return _ECANTOPEN unless open my( $fh ), "<", $filename; 
	
	my $count = 0;
	while( <$fh> ) { $count++ }

	return $count;
	}

# XXX: lots of cut and pasting here, needs refactoring
# looks like the refactoring might be worse than this though
sub file_line_count_is
	{
	my $filename = _normalize( shift );
	my $expected = shift;
	my $name     = do {
		no warnings 'uninitialized';
		shift || "$filename line count is $expected lines";
		};
	
	unless( defined $expected && int( $expected ) == $expected )
		{
		no warnings 'uninitialized';
		$Test->diag( "file_line_count_is expects a positive whole number for " .
			"the second argument. Got [$expected]!" );
		return $Test->ok( 0, $name );
		}

	my $got = _file_line_counter( $filename );
	
	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN ) 
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}		
	elsif( $got == $expected )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected [$expected] lines in [$filename], " .
			"got [$got] lines!" );
		$Test->ok( 0, $name );
		}

	}

sub file_line_count_isnt
	{
	my $filename = _normalize( shift );
	my $expected = shift;
	my $name     = do {
		no warnings 'uninitialized';
		shift || "$filename line count is not $expected lines";
		};
	
	unless( defined $expected && int( $expected ) == $expected )
		{
		no warnings 'uninitialized';
		$Test->diag( "file_line_count_is expects a positive whole number for " .
			"the second argument. Got [$expected]!" );
		return $Test->ok( 0, $name );
		}

	my $got = _file_line_counter( $filename );
	
	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN ) 
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}		
	elsif( $got != $expected )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected something other than [$expected] lines in [$filename], " .
			"but got [$got] lines!" );
		$Test->ok( 0, $name );
		}

	}

sub file_line_count_between
	{
	my $filename = _normalize( shift );
	my $min      = shift;
	my $max      = shift;

	my $name = do {
		no warnings 'uninitialized';
		shift || "$filename line count is between [$min] and [$max] lines";
		};
	
	foreach my $ref ( \$min, \$max )
		{
		unless( defined $$ref && int( $$ref ) == $$ref )
			{
			no warnings 'uninitialized';
			$Test->diag( "file_line_count_between expects positive whole numbers for " .
				"the second and third arguments. Got [$min] and [$max]!" );
			return $Test->ok( 0, $name );
			}
		}
		

	my $got = _file_line_counter( $filename );
	
	if( $got eq _ENOFILE )
		{
		$Test->diag( "File [$filename] does not exist!" );
		$Test->ok( 0, $name );
		}
	elsif( $got == _ECANTOPEN ) 
		{
		$Test->diag( "Could not open [$filename]: \$! is [$!]!" );
		$Test->ok( 0, $name );
		}		
	elsif( $min <= $got and $got <= $max )
		{
		$Test->ok( 1, $name );
		}
	else
		{
		$Test->diag( "Expected a line count between [$min] and [$max] " .
			"in [$filename], but got [$got] lines!" 
			);
		$Test->ok( 0, $name );
		}

	}
	

sub file_readable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is readable";

	my $ok = -r $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is not readable!" );
		$Test->ok(0, $name);
		}
	}

sub file_not_readable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not readable";

	my $ok = not -r $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is readable!" );
		$Test->ok(0, $name);
		}
	}

sub file_writeable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is writeable";

	my $ok = -w $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag( "File [$filename] is not writeable!" );
		$Test->ok(0, $name);
		}
	}

sub file_not_writeable_ok
	{
	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not writeable";

	my $ok = not -w $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is writeable!");
		$Test->ok(0, $name);
		}
	}

sub file_executable_ok
	{
	if( _win32() )
		{
		$Test->skip( "file_executable_ok doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $name     = shift || "$filename is executable";

	my $ok = -x $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is not executable!");
		$Test->ok(0, $name);
		}
	}

sub file_not_executable_ok
	{
	if( _win32() )
		{
		$Test->skip( "file_not_executable_ok doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $name     = shift || "$filename is not executable";

	my $ok = not -x $filename;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag("File [$filename] is executable!");
		$Test->ok(0, $name);
		}
	}

sub file_mode_is
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_is doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode is %04o", $filename, $mode);

	my $ok = -e $filename && ((stat($filename))[2] & 07777) == $mode;

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag(sprintf("File [%s] mode is not %04o!", $filename, $mode) );
		$Test->ok(0, $name);
		}
	}

sub file_mode_isnt
	{
	if( _win32() )
		{
		$Test->skip( "file_mode_isnt doesn't work on Windows!" );
		return;
		}

	my $filename = _normalize( shift );
	my $mode     = shift;

	my $name     = shift || sprintf("%s mode is not %04o",$filename,$mode);

	my $ok = not (-e $filename && ((stat($filename))[2] & 07777) == $mode);

	if( $ok )
		{
		$Test->ok(1, $name);
		}
	else
		{
		$Test->diag(sprintf("File [%s] mode is %04o!",$filename,$mode));
		$Test->ok(0, $name);
		}
	}

sub file_is_symlink_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"file_is_symlink_ok doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $name = shift || "$file is a symlink";

	if( -l $file )
		{
		$Test->ok(1, $name)
		}
	else
		{
		$Test->diag( "File [$file] is not a symlink!" );
		$Test->ok(0, $name);
		}
	}

sub symlink_target_exists_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_exists_ok doesn't work on systems without symlinks!"
			);
		return;
		}

	my $file = shift;
	my $dest = shift || readlink( $file );
	my $name = shift || "$file is a symlink";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	unless( -e $dest )
		{
		$Test->diag( "Symlink [$file] points to non-existent target [$dest]!" );
		return $Test->ok( 0, $name );
		}

	my $actual = readlink( $file );
	unless( $dest eq $actual )
		{
		$Test->diag(
			"Symlink [$file] points to\n" . 
			"         got: $actual\n" . 
			"    expected: $dest\n"
			);
		return $Test->ok( 0, $name );
		}

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

sub symlink_target_dangles_ok
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_dangles_ok doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $dest = readlink( $file );
	my $name = shift || "$file is a symlink";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	if( -e $dest )
		{
		$Test->diag(
			"Symlink [$file] points to existing file [$dest] but shouldn't!" );
		return $Test->ok( 0, $name );
		}

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

sub symlink_target_is 
	{
	if( _no_symlinks_here() )
		{
		$Test->skip(
			"symlink_target_is doesn't work on systems without symlinks!" );
		return;
		}

	my $file = shift;
	my $dest = shift;
	my $name = shift || "symlink $file points to $dest";

	unless( -l $file )
		{
		$Test->diag( "File [$file] is not a symlink!" );
		return $Test->ok( 0, $name );
		}

	my $actual_dest = readlink( $file );
	my $link_error  = $!;

	unless( defined $actual_dest )
		{
		$Test->diag( "Symlink [$file] does not have a defined target!" );
		$Test->diag( "readlink error: $link_error" ) if defined $link_error;
		return $Test->ok( 0, $name );
		}
	
	if( $dest eq $actual_dest ) 
		{
		$Test->ok( 1, $name );
		} 
	else 
		{
		$Test->ok( 0, $name );
		$Test->diag("       got: $actual_dest" );
		$Test->diag("  expected: $dest" );
		}
	}

sub link_count_is_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = ( stat $file )[3];

	unless( $actual == $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: expected [$count]!" );
		return $Test->ok( 0, $name );
		}

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

sub link_count_gt_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = (stat $file )[3];

	unless( $actual > $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: ".
			"expected more than [$count]!" );
		return $Test->ok( 0, $name );
		}

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

sub link_count_lt_ok
	{
	my $file   = shift;
	my $count  = int( 0 + shift );

	my $name   = shift || "$file has a link count of [$count]";

	my $actual = (stat $file )[3];

	unless( $actual < $count )
		{
		$Test->diag(
			"File [$file] points has [$actual] links: ".
			"expected less than [$count]!" );
		return $Test->ok( 0, $name );
		}

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


# owner_is, owner_isnt, group_is and group_isnt are almost
# identical in the beginning, so I'm writing a skeleton they can all use.
# I can't think of a better name...
sub _dm_skeleton
	{
	no warnings 'uninitialized';
	
	if( _obviously_non_multi_user() )
		{
		my $calling_sub = (caller(1))[3];
		$Test->skip( $calling_sub . " only works on a multi-user OS!" );
		return 'skip';
		}

	my $filename      = _normalize( shift );
	my $testing_for   = shift;
	my $name          = shift;

	unless( defined $filename )
		{
		$Test->diag( "File name not specified!" );
		return $Test->ok( 0, $name );
		}

	unless( -e $filename )
		{
		$Test->diag( "File [$filename] does not exist!" );
		return $Test->ok( 0, $name );
		}

	return;
	}

sub owner_is
	{
	my $filename      = shift;
	my $owner         = shift;
	my $name          = shift || "$filename belongs to $owner";

	my $err = _dm_skeleton( $filename, $owner, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $owner_uid = _get_uid( $owner );
	unless( defined $owner_uid )
		{
		$Test->diag("User [$owner] does not exist on this system!");
		return $Test->ok( 0, $name );
		}
		
	my $file_uid = ( stat $filename )[4];

	unless( defined $file_uid )
		{
		$Test->skip("stat failed to return owner uid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_uid == $owner_uid;

	my $real_owner = ( getpwuid $file_uid )[0];
	unless( defined $real_owner )
		{
		$Test->diag("File does not belong to $owner!");
		return $Test->ok( 0, $name );
		}

	$Test->diag( "File [$filename] belongs to $real_owner ($file_uid), ".
			"not $owner ($owner_uid)!" );
	return $Test->ok( 0, $name );
	}

sub owner_isnt
	{
	my $filename      = shift;
	my $owner         = shift;
	my $name          = shift || "$filename belongs to $owner";

	my $err = _dm_skeleton( $filename, $owner, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $owner_uid = _get_uid( $owner );
	unless( defined $owner_uid )
		{
		return $Test->ok( 1, $name );
		}

	my $file_uid  = ( stat $filename )[4];

	#$Test->diag( "owner_isnt: $owner_uid $file_uid" );
	return $Test->ok( 1, $name ) if $file_uid != $owner_uid;

	$Test->diag( "File [$filename] belongs to $owner ($owner_uid)!" );
	return $Test->ok( 0, $name );
	}

sub group_is
 	{
	my $filename      = shift;
	my $group         = shift;
	my $name          = ( shift || "$filename belongs to group $group" );

	my $err = _dm_skeleton( $filename, $group, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $group_gid = _get_gid( $group );
	unless( defined $group_gid )
		{
		$Test->diag("Group [$group] does not exist on this system!");
		return $Test->ok( 0, $name );
		}

	my $file_gid  = ( stat $filename )[5];

	unless( defined $file_gid )
 		{
		$Test->skip("stat failed to return group gid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_gid == $group_gid;

	my $real_group = ( getgrgid $file_gid )[0];
	unless( defined $real_group )
		{
		$Test->diag("File does not belong to $group!");
 		return $Test->ok( 0, $name );
 		}

	$Test->diag( "File [$filename] belongs to $real_group ($file_gid), ".
			"not $group ($group_gid)!" );

	return $Test->ok( 0, $name );
	}

sub group_isnt
	{
	my $filename      = shift;
	my $group         = shift;
	my $name          = shift || "$filename does not belong to group $group";

	my $err = _dm_skeleton( $filename, $group, $name );
	return if( defined( $err ) && $err eq 'skip' );
	return $err if defined($err);

	my $group_gid = _get_gid( $group );
	my $file_gid  = ( stat $filename )[5];

	unless( defined $file_gid )
		{
		$Test->skip("stat failed to return group gid for $filename!");
		return;
		}

	return $Test->ok( 1, $name ) if $file_gid != $group_gid;

	$Test->diag( "File [$filename] belongs to $group ($group_gid)!" );
 		return $Test->ok( 0, $name );
	}

sub _get_uid
	{
	my $owner = shift;
	my $owner_uid;

	if ($owner =~ /^\d+/)
		{
		$owner_uid = $owner;
		$owner = ( getpwuid $owner )[0];
		}
	else
		{
		$owner_uid = (getpwnam($owner))[2];
		}

	$owner_uid;
	}

sub _get_gid
	{
	my $group = shift;
	my $group_uid;

	if ($group =~ /^\d+/)
		{
		$group_uid = $group;
		$group = ( getgrgid $group )[0];
		}
	else
		{
		$group_uid = (getgrnam($group))[2];
		}

	$group_uid;
	}

"The quick brown fox jumped over the lazy dog";