Add a test from trac #2969

2 files changed, 107 insertions, 0 deletions

diff --git a/tests/all.T b/tests/all.T
index eb94d7d..b979a84 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -33,3 +33,9 @@ test('getUserEntryForName', compose(conf, expect_fail), compile_and_run,
 test('signals004', normal, compile_and_run, ['-package unix'])
 
 test('fdReadBuf001', only_ways(['threaded1','threaded2','ghci']), compile_and_run, ['-package unix'])
+
+test('fileStatus',
+     extra_clean(['dir', 'regular', 'link-dir', 'link-regular']),
+     compile_and_run,
+     ['-package unix'])
+
diff --git a/tests/fileStatus.hs b/tests/fileStatus.hs
new file mode 100644
index 0000000..a393d72
--- /dev/null
+++ b/tests/fileStatus.hs
@@ -0,0 +1,101 @@
+
+-- GHC trac #2969
+
+import System.Posix.Files
+import System.Posix.Directory
+import System.Posix.IO
+import Control.Exception as E
+import Control.Monad
+
+main = do
+  cleanup
+  fs <- testRegular
+  ds <- testDir
+  testSymlink fs ds
+  cleanup
+
+testRegular = do
+  createFile "regular" ownerReadMode
+  (fs, _) <- getStatus "regular"
+  let expected = (False,False,False,True,False,False,False)
+      actual   = snd (statusElements fs)
+  when (actual /= expected) $
+    fail "unexpected file status bits for regular file"
+  return fs
+
+testDir = do
+  createDirectory "dir" ownerReadMode
+  (ds, _) <- getStatus "dir"
+  let expected = (False,False,False,False,True,False,False)
+      actual   = snd (statusElements ds)
+  when (actual /= expected) $
+    fail "unexpected file status bits for directory"
+  return ds
+
+testSymlink fs ds = do
+  createSymbolicLink "regular" "link-regular"
+  createSymbolicLink "dir"     "link-dir"
+  (fs', ls)  <- getStatus "link-regular"
+  (ds', lds) <- getStatus "link-dir"
+
+  let expected = (False,False,False,False,False,True,False)
+      actualF  = snd (statusElements ls)
+      actualD  = snd (statusElements lds)
+
+  when (actualF /= expected) $
+    fail "unexpected file status bits for symlink to regular file"
+
+  when (actualD /= expected) $
+    fail "unexpected file status bits for symlink to directory"
+
+  when (statusElements fs /= statusElements fs') $
+    fail "status for a file does not match when it's accessed via a symlink"
+
+  when (statusElements ds /= statusElements ds') $
+    fail "status for a directory does not match when it's accessed via a symlink"
+
+cleanup = do
+  ignoreIOExceptions $ removeDirectory "dir"
+  mapM_ (ignoreIOExceptions . removeLink)
+        ["regular", "link-regular", "link-dir"]
+
+ignoreIOExceptions io = io `E.catch`
+                        ((\_ -> return ()) :: IOException -> IO ())
+
+getStatus f = do
+  fs  <- getFileStatus f
+  ls  <- getSymbolicLinkStatus f
+
+  fd  <- openFd f ReadOnly Nothing defaultFileFlags
+  fs' <- getFdStatus fd
+
+  when (statusElements fs /= statusElements fs') $
+    fail "getFileStatus and getFdStatus give inconsistent results"
+
+  when (not (isSymbolicLink ls) && statusElements fs /= statusElements fs') $
+    fail $ "getFileStatus and getSymbolicLinkStatus give inconsistent results "
+        ++ "on a file that is not a symbolic link"
+
+  return (fs, ls)
+
+-- Yay for 17-element tuples!
+statusElements fs = (,)
+  (deviceID fs
+  ,fileMode fs
+  ,linkCount fs
+  ,fileOwner fs
+  ,fileGroup fs
+  ,specialDeviceID fs
+  ,fileSize fs
+  ,accessTime fs
+  ,modificationTime fs
+  ,statusChangeTime fs
+  )
+  (isBlockDevice fs
+  ,isCharacterDevice fs
+  ,isNamedPipe fs
+  ,isRegularFile fs
+  ,isDirectory fs
+  ,isSymbolicLink fs
+  ,isSocket fs
+  )