Test-File

 view release on metacpan or  search on metacpan

lib/Test/File.pm  view on Meta::CPAN

# owner_is and owner_isn't should skip on OS where the question makes no
# sense.  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 }

	return 0 if $^O eq 'MSWin32';

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

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

	return 0;
	}

=item file_exists_ok( FILENAME [, NAME ] )

lib/Test/File.pm  view on Meta::CPAN

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

lib/Test/File.pm  view on Meta::CPAN

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

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

=item group_is( FILE , GROUP [, NAME ] )

Ok if FILE's group is the same as GROUP.  GROUP may be a text group name or
a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
systems that do not support getpwuid() and friends.  If the file does not
exist, the test fails.

Contributed by Dylan Martin

=cut

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

lib/Test/File.pm  view on Meta::CPAN

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

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

=item group_isnt( FILE , GROUP [, NAME ] )

Ok if FILE's group is not the same as GROUP.  GROUP may be a text group name or
a numeric group id.  Test skips on Dos, Mac OS <= 9 and any other operating
systems that do not support getpwuid() and friends.  If the file does not
exist, the test fails.

Contributed by Dylan Martin

=cut

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

lib/Test/File.pm  view on Meta::CPAN

	# to figure out which of several possibilities we have. And, 0 means
	# root, so we have to be very careful with the values.

	# maybe the argument is a UID. First, it has to be numeric. If it's
	# a UID, we'll get the same UID back. But, if we get back a value
	# that doesn't mean that we are done. There might be a name with
	# the same value.
	#
	# Don't use this value in comparisons! An undef could be turned
	# into zero!
	my $from_uid = (getpwuid($arg))[2] if $arg =~ /\A[0-9]+\z/;

	# Now try the argument as a name. If it's a name, then we'll get
	# back a UID. Maybe we get back nothing.
	my $from_nam = (getpwnam($arg))[2];

	return do {
		# first case, we got back nothing from getpwnam but did get
		# something from getpwuid. The arg is not a name and is a
		# UID.
		   if( defined $from_uid and not defined $from_nam ) { $arg }
		# second case, we got back nothing from getpwuid but did get
		# something from getpwnam. The arg is a name and is not a
		# UID.
		elsif( not defined $from_uid and defined $from_nam ) { $from_nam }
		# Now, what happens if neither are defined? The argument does
		# not correspond to a name or GID on the system. Since no such
		# user exists, we return undef.
		elsif( not defined $from_uid and not defined $from_nam ) { undef }
		# But what if they are both defined? The argument could represent
		# a UID and a name, and those could be different users! In this
		# case, we'll choose the original argument. That might be wrong,

lib/Test/File.pm  view on Meta::CPAN

	# Don't use this value in comparisons! An undef could be turned
	# into zero!
	my $from_gid = (getgrgid($arg))[2] if $arg =~ /\A[0-9]+\z/;

	# Now try the argument as a name. If it's a name, then we'll get
	# back a GID. Maybe we get back nothing.
	my $from_nam = (getgrnam($arg))[2];

	return do {
		# first case, we got back nothing from getgrnam but did get
		# something from getpwuid. The arg is not a name and is a
		# GID.
		   if( defined $from_gid and not defined $from_nam ) { $arg }
		# second case, we got back nothing from getgrgid but did get
		# something from getgrnam. The arg is a name and is not a
		# GID.
		elsif( not defined $from_gid and defined $from_nam ) { $from_nam }
		# Now, what happens if neither are defined? The argument does
		# not correspond to a name or GID on the system. Since no such
		# user exists, we return undef.
		elsif( not defined $from_gid and not defined $from_nam ) { undef }

t/obviously_non_multi_user.t  view on Meta::CPAN

use Test::More 1;

BEGIN {
	our $getpwuid_should_die = 0;
	our $getgrgid_should_die = 0;
	};

BEGIN{
	no warnings;

	*CORE::GLOBAL::getpwuid = sub ($) { die "Fred"   if $getpwuid_should_die };
	*CORE::GLOBAL::getgrgid = sub ($) { die "Barney" if $getgrgid_should_die };
	}

use_ok( 'Test::File' );

ok( defined &{ "Test::File::_obviously_non_multi_user" }, "_win32 defined" );

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The ones that we know aren't multi-user
subtest macos_single_user => sub {

t/obviously_non_multi_user.t  view on Meta::CPAN

	ok( Test::File::_obviously_non_multi_user(), "Returns false for MacOS" );
	};

subtest dos_single_user => sub {
	local $^O = 'dos';
	ok( Test::File::_obviously_non_multi_user(), "Returns true for Win32" );
	};

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The ones that use get*, but die
subtest getpwuid_should_die => sub {
	local $^O = 'Fooey';
	$getpwuid_should_die = 1;
	$getgrgid_should_die = 0;
	ok( Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' );
	};

subtest getgrgid_should_die => sub {
	local $^O = 'Fooey';
	$getpwuid_should_die = 0;
	$getgrgid_should_die = 1;
	ok( Test::File::_obviously_non_multi_user(), 'getgrgid dying returns true' );
	};

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# The ones that use get*, but don't die
subtest nothing_dies => sub {
	local $^O = 'Fooey';
	$getpwuid_should_die = 0;
	$getgrgid_should_die = 0;
	ok( ! Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' );
	};

done_testing();

t/owner.t  view on Meta::CPAN

	$filename = glob( "*" );

	die "Could not find a file" unless defined $filename;

	$owner_uid = ( stat $filename )[4];
	die "failed to find ${filename}'s owner\n" unless defined $owner_uid;

	$file_gid = ( stat $filename )[5];
	die "failed to find ${filename}'s owner\n" unless defined $file_gid;

	$owner_name = ( getpwuid $owner_uid )[0];
	die "failed to find ${filename}'s owner as name\n" unless defined $owner_name;

	$file_group_name = ( getgrgid $file_gid )[0];
	die "failed to find ${filename}'s group as name\n" unless defined $file_group_name;
	};
plan skip_all => "I can't find a file to test with: $@" if $@;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# find some name that isn't the one we found before
my( $other_name, $other_uid, $other_group_name, $other_gid );
eval
	{
	for( my $i = 0; $i < 65535; $i++ )
		{
		next if $i == $owner_uid;

		my @stats = getpwuid $i;
		next unless @stats;

		( $other_uid, $other_name )  = ( $i, $stats[0] );
		last;
		}

 	# XXX: why the for loop?
	for( my $i = 0; $i < 65535; $i++ )
		{
		next if $i == $file_gid;