Win32 stat() didn't handle AF_UNIX socket files

Unfortunately both symbolic links and sockets can only be
"statted" by opening with FILE_FLAG_OPEN_REPARSE_POINT which
obviously doesn't follow symbolic links.

So to find if a chain of symbolic links points to a socket,
is a broken chain, or loops, we need to follow the chain
ourselves.

1 files changed, 74 insertions, 0 deletions

diff --git a/t/win32/stat.t b/t/win32/stat.t
index c2fe60a326..7fa143750f 100644
--- a/t/win32/stat.t
+++ b/t/win32/stat.t
@@ -9,6 +9,8 @@ BEGIN {
 use strict;
 use Fcntl ":seek";
 use Config;
+use Errno;
+use Cwd "getcwd";
 
 Win32::FsType() eq 'NTFS'
     or skip_all("need NTFS");
@@ -18,6 +20,7 @@ my (undef, $maj, $min) = Win32::GetOSVersion();
 my $vista_or_later = $maj >= 6;
 
 my $tmpfile1 = tempfile();
+my $tmpfile2 = tempfile();
 
 # test some of the win32 specific stat code, since we
 # don't depend on the CRT for some of it
@@ -249,4 +252,75 @@ if (ok(mkdir($tmpfile1), "make a work directory")) {
     ok(!-e '"', qq(filename '"' shouldn't exist));
 }
 
+# https://github.com/Perl/perl5/issues/20204
+# Win32: stat/unlink fails on UNIX sockets
+SKIP:
+{
+    use IO::Socket;
+    unlink $tmpfile1;
+    my $listen = IO::Socket::UNIX->new(Local => $tmpfile1, Listen => 0)
+        or skip "Cannot create unix socket", 1;
+    ok(-S $tmpfile1, "can stat a socket");
+    ok(!-l $tmpfile1, "doesn't look like a symlink");
+    unlink $tmpfile2;
+    if (system("mklink $tmpfile2 $tmpfile1") == 0) {
+        ok(-l $tmpfile2, "symlink to socket is a symlink (via lstat)");
+        ok(-S $tmpfile2, "symlink to socket is also a socket (via stat)");
+        unlink $tmpfile2;
+    }
+    close $listen;
+    unlink $tmpfile1;
+}
+
+{
+    # if a symlink chain leads to a socket, or loops, or is broken,
+    # CreateFileA() fails, so we do our own link following.
+    # The link leading to a socket is checked above, here check loops
+    # fail, and that we get ELOOP (which isn't what MSVC returns, but
+    # try to be better).
+    if (system("mklink $tmpfile1 $tmpfile2") == 0
+        && system("mklink $tmpfile2 $tmpfile1") == 0) {
+        ok(!stat($tmpfile1), "looping symlink chain fails stat");
+        is($!+0, &Errno::ELOOP, "check error set");
+        ok(lstat($tmpfile1), "looping symlink chain passes lstat");
+
+        unlink $tmpfile2;
+        ok(!stat($tmpfile1), "broken symlink");
+        is($!+0, &Errno::ENOENT, "check error set");
+        ok(lstat($tmpfile1), "broken symlink chain passes lstat");
+    }
+    unlink $tmpfile1, $tmpfile2;
+}
+
+{
+    # $tmpfile4 -> $tmpfile1/file1 -> ../$tmpfile2 -> abspath($tmpfile3)
+    # $tmpfile3 either doesn't exist, is a file, or is a socket
+    my ($tmpfile3, $tmpfile4) = (tempfile(), tempfile());
+    ok(mkdir($tmpfile1), "make a directory");
+    my $cwd = getcwd();
+    if (system(qq(mklink $tmpfile4 $tmpfile1\\file1)) == 0
+        && system(qq(mklink $tmpfile1\\file1 ..\\$tmpfile2)) == 0
+        && system(qq(mklink $tmpfile2 "$cwd\\$tmpfile3")) == 0) {
+        ok(-l $tmpfile4, "yes, $tmpfile4 is a symlink");
+        ok(!-e $tmpfile4, "but we can't stat it");
+
+        open my $fh, ">", $tmpfile3 or die $!;
+        close $fh;
+        ok(-f $tmpfile4, "now $tmpfile4 leads to a file");
+        unlink $tmpfile3;
+
+      SKIP:
+        {
+            my $listen = IO::Socket::UNIX->new(Local => $tmpfile3, Listen => 0)
+                or skip "Cannot create unix socket", 1;
+            ok(!-f $tmpfile4, "$tmpfile4 no longer leads to a file");
+            ok(-S $tmpfile4, "now $tmpfile4 leads to a socket");
+            ok(-S "$tmpfile1/file1", "$tmpfile1/file1 should lead to a socket");
+            ok(-S $tmpfile2, "$tmpfile2 should lead to a socket");
+            unlink $tmpfile3;
+        }
+    }
+    unlink $tmpfile2, $tmpfile4, "$tmpfile1/file1";
+    rmdir $tmpfile1;
+}
 done_testing();