view release on metacpan or  search on metacpan

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

=encoding utf8

=head1 NAME

Test::File -- test file attributes

=head1 SYNOPSIS

  use Test::File;

=head1 DESCRIPTION

This modules provides a collection of test utilities for file
attributes.

Some file attributes depend on the owner of the process testing the
file in the same way the file test operators do.  For instance, root
(or super-user or Administrator) may always be able to read files no
matter the permissions.

Some attributes don't make sense outside of Unix, either, so some
tests automatically skip if they think they won't work on the
platform.  If you have a way to make these functions work on Windows,
for instance, please send me a patch. :) If you want to pretend to be
Windows on a non-Windows machine (for instance, to test C<skip()>),
you can set the C<PRETEND_TO_BE_WINDOWS> environment variable.

The optional NAME parameter for every function allows you to specify a
name for the test.  If not supplied, a reasonable default will be
generated.

=head2 Functions

=over 4

=cut

sub _is_plain_file {
	my $filename = _normalize( shift );

	my $message = do {
		   if( ! -e $filename ) { "does not exist" }
		elsif( ! -f _ )         { "is not a plain file" }
		elsif( -d _ )           { "is a directory"  }
		else { () }
		};

	if( $message ) {
		$Test->diag( "file [$filename] $message");
		return 0;
		}

	return 1;
	}

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 $ENV{PRETEND_TO_BE_WIN32} if defined $ENV{PRETEND_TO_BE_WIN32};
	return $^O =~ m/Win/ || $^O eq 'msys';
	}

# returns true if symlinks can't exist
BEGIN {
	my $cannot_symlink;

	sub _no_symlinks_here {
		return $cannot_symlink if defined $cannot_symlink;

		$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.