implement IsSymlinkCreationAllowed()

Author: xenu

Makefile.PL

@@ -33,5 +33,6 @@ my $test_requires = $ExtUtils::MakeMaker::VERSION >= 6.64
     : 'PREREQ_PM';
 
 $param{$test_requires}{'Test'} = 0;
+$param{$test_requires}{'File::Temp'} = 0;
 
 WriteMakefile(%param);

Win32.pm

@@ -713,6 +713,27 @@ sub _GetOSName {
     return ("Win$os", $desc);
 }
 
+sub IsSymlinkCreationAllowed {
+    my(undef, $major, $minor, $build) = 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 IsDeveloperModeEnabled();
+    }
+
+    my $privs = 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};
+}
+
 # "no warnings 'redefine';" doesn't work for 5.8.7 and earlier
 local $^W = 0;
 bootstrap Win32;
@@ -1309,6 +1330,12 @@ returns 1 on Win9X.
 Returns true if the developer mode is currently enabled. It always returns
 false on Windows versions older than Windows 10.
 
+=item Win32::IsSymlinkCreationAllowed()
+
+Returns true if the current process is allowed to create symbolic links. This
+function is a convenience wrapper around Win32::GetProcessPrivileges() and
+Win32::IsDeveloperModeEnabled().
+
 =item Win32::IsWinNT()
 
 [CORE] Returns non zero if the Win32 subsystem is Windows NT.

t/Privileges.t

@@ -3,10 +3,12 @@ use warnings;
 
 use Test;
 use Win32;
+use Config;
+use File::Temp;
 
-plan tests => 5;
+plan tests => 7;
 
-ok(ref(Win32::GetProcessPrivileges) eq 'HASH');
+ok(ref(Win32::GetProcessPrivileges()) eq 'HASH');
 ok(ref(Win32::GetProcessPrivileges(Win32::GetCurrentProcessId())) eq 'HASH');
 
 # All Windows PIDs are divisible by 4. It's an undocumented implementation
@@ -30,3 +32,24 @@ skip($skip, sub{
 # function doesn't segfault
 Win32::IsDeveloperModeEnabled();
 ok(1);
+
+Win32::IsSymlinkCreationAllowed();
+ok(1);
+
+$skip = $^O ne 'MSWin32' ? 'MSWin32-only test' : 0;
+$skip ||= !$Config{d_symlink} ? 'this perl doesn\'t have symlink()' : 0;
+
+skip($skip, sub {
+    my $tmpdir = File::Temp->newdir;
+    my $dirname = $tmpdir->dirname;
+
+    if (Win32::IsSymlinkCreationAllowed()) {
+        # we expect success
+        return symlink("foo", $tmpdir->dirname . "/new_symlink") == 1;
+    }
+    else {
+        # we expect failure
+        return symlink("foo", $tmpdir->dirname . "/new_symlink") == 0;
+    }
+});
+