view release on metacpan or  search on metacpan

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

		$cannot_symlink = ! do {
			eval {
				symlink("","");                 # symlink exist in perl
				_IsSymlinkCreationAllowed()		# symlink is ok in current session
				}
		};
	}

	sub _IsSymlinkCreationAllowed {
		if ($^O eq 'MSWin32') {
			#
			# Bare copy of Perl's Win32::IsSymlinkCreationAllowed but with Test::File::Win32 namespace instead of Win32
			#
			my(undef, $major, $minor, $build) = Test::File::Win32::GetOSVersion();

			# Vista was the first Windows version with symlink support
			return !!0 if $major < 6;

			# Since Windows 10 1703, enabling the developer mode allows to create
			# symlinks regardless of process privileges
			if ($major > 10 || ($major == 10 && ($minor > 0 || $build > 15063))) {
				return !!1 if Test::File::Win32::IsDeveloperModeEnabled();
			}

			my $privs = Test::File::Win32::GetProcessPrivileges();

			return !!0 unless $privs;

			# It doesn't matter if the permission is enabled or not, it just has to
			# exist. CreateSymbolicLink() will automatically enable it when needed.
			return exists $privs->{SeCreateSymbolicLinkPrivilege};
		}

		1;
	}

=item has_symlinks

Returns true is this module thinks that the current system supports
symlinks.

This is not a test function. It's something that tests can use to
determine what it should expect or skip.

=cut

	sub has_symlinks { ! _no_symlinks_here() }
}

# 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 ] )

Ok if the file exists, and not ok otherwise.

=cut

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

=item file_not_exists_ok( FILENAME [, NAME ] )

Ok if the file does not exist, and not okay if it does exist.

=cut

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

=item file_empty_ok( FILENAME [, NAME ] )

Ok if the file exists and has empty size, not ok if the file does not
exist or exists with non-zero size.

Previously this tried to test any sort of file. Sometime in the future
this will fail if the argument is not a plain file or is a directory.

=cut

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

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

=item owner_is( FILE , OWNER [, NAME ] )

Ok if FILE's owner is the same as OWNER.  OWNER may be a text user name
or a numeric userid.  Test skips on Dos, and Mac OS <= 9.
If the file does not exist, the test fails.

Contributed by Dylan Martin

=cut

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

=item owner_isnt( FILE, OWNER [, NAME ] )

Ok if FILE's owner is not the same as OWNER.  OWNER may be a text user name
or a numeric userid.  Test skips on Dos and Mac OS <= 9.  If the file
does not exist, the test fails.

Contributed by Dylan Martin

=cut

sub owner_isnt {
	my $filename      = shift;
	my $owner         = shift;
	my $name          = shift || "$filename doesn't belong 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 );
	}

=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" );

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

=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";

	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 $arg = shift;

	# the name might be numeric (why would you do that?), so we need
	# 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,
		# so the best we can do is a warning.
		else {
			carp( "Found both a UID or name for <$arg>. Guessing the UID is <$arg>." );
			$arg
			}
		};
	}

sub _get_gid {
	my $arg = shift;

	# the name might be numeric (why would you do that?), so we need
	# 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 GID. First, it has to be numeric. If it's
	# a GID, we'll get the same GID 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_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 }
		# But what if they are both defined? The argument could represent
		# a GID and a name, and those could be different users! In this
		# case, we'll choose the original argument. That might be wrong,
		# so the best we can do is a warning.
		else {
			carp( "Found both a GID or name for <$arg>. Guessing the GID is <$arg>." );
			$arg;
			}
		};
	}

=item file_mtime_age_ok( FILE [, WITHIN_SECONDS ] [, NAME ] )

Ok if FILE's modified time is WITHIN_SECONDS inclusive of the system's current time.
This test uses stat() to obtain the mtime. If the file does not exist the test
returns failure. If stat() fails, the test is skipped.

=cut

sub file_mtime_age_ok {
	my $filename    = shift;
	my $within_secs = shift || 0;
	my $name        = shift || "$filename mtime within $within_secs seconds of current time";

	my $time        = time();

	my $filetime = _stat_file($filename, 9);

	return if ( $filetime == -1 ); #skip

	return $Test->ok(1, $name) if ( $filetime + $within_secs > $time-1  );

	$Test->diag( "file [$filename] mtime [$filetime] is not $within_secs seconds within current system time [$time].");
	return $Test->ok(0, $name);
	}

=item file_mtime_gt_ok( FILE, UNIXTIME [, NAME ] )

Ok if FILE's mtime is > UNIXTIME. This test uses stat() to get the mtime. If stat() fails
this test is skipped. If FILE does not exist, this test fails.

=cut

sub file_mtime_gt_ok {
	my $filename    = shift;
	my $time        = int shift;
	my $name        = shift || "$filename mtime is greater than unix timestamp $time";

	my $filetime = _stat_file($filename, 9);