Add FileSystem.cake from File Helper

ReadMe.org

@@ -97,6 +97,7 @@ Here are the known compatibility results, where blank means untested/unknown:
 | Dependencies.cake           | Yes          | Yes          | Yes         |       |
 | Dictionary.cake             | Yes          | Yes          | Yes         | Yes   |
 | DynamicArray.cake           | Yes          | Yes          | Yes         | Yes   |
+| FileSystem.cake             | Yes          | Yes          | Yes         |       |
 | FreeType.cake               | Yes          |              |             |       |
 | Image.cake                  | Yes          | Yes          | Yes         |       |
 | ImGui.cake                  | Yes          | No[1]        | Yes         |       |

src/FileSystem.cake

@@ -0,0 +1,371 @@
+(import "DynamicArray.cake"
+        "FileUtilities.cake"
+        "CHelpers.cake" "ComptimeHelpers.cake"
+        &with-decls "DynamicArray.cake")
+
+(c-import "<stdio.h>"
+          &with-decls "<stddef.h>") ;; for size_t
+
+(var filesystem-verbose-logging bool false)
+;; (var filesystem-verbose-logging bool true)
+
+(def-type-alias-global file-size (long long))
+
+(defmacro fsdebugf (format-string string &optional &rest format-args any)
+  (if format-args
+      (tokenize-push output
+        (when filesystem-verbose-logging
+          (fprintf stderr (token-splice format-string)
+                   (token-splice-rest format-args tokens))))
+      (tokenize-push output
+        (when filesystem-verbose-logging
+          (fprintf stderr (token-splice format-string)))))
+  (return true))
+
+(defstruct directory-entry
+  name (* (const char))
+  is-directory bool
+  size size_t)
+
+(defstruct entry-details
+  path (* char)
+  size size_t
+  is-directory bool ;; TODO: Use flags to save space
+  can-read bool)
+
+(defun directory-entries-destroy (directory-entries (* directory-entry))
+  (each-item-addr-in-dynarray directory-entries i entry (* directory-entry)
+    (free (type-cast (path entry > name) (* void)))))
+
+(defun file-names-destroy (file-names (* (* (const char))))
+  (each-item-in-dynarray file-names i str (* (const char))
+    (free (type-cast str (* void)))))
+
+(defun full-path-for-entry (current-dir (* (const char))
+                            entry (* directory-entry)
+                            &return dynstring)
+  (dynstring-create-f full-path "%s%s%s" current-dir
+                      (? (is-root-path current-dir) "" "/")
+                      (path entry > name))
+  (return full-path))
+
+(defun is-root-path (path (* (const char)) &return bool)
+  (return (and (= 1 (strlen path))
+               (= '/' (at 0 path)))))
+
+(defun get-parent-of-path (current-dir (* (const char))
+                           out-str (* dynstring))
+  (var dir-name ([] 2048 char) (array 0))
+  (get-directory-from-path current-dir dir-name (array-size dir-name))
+  (dynarray-clear (deref out-str))
+  (dynstring-append out-str dir-name))
+
+(defstruct divided-path-dir
+  full-path ([] 1024 char)
+  innermost-dir-offset size_t)
+(defun divide-path (current-dir (* (const char))
+                    divided-path (* (* divided-path-dir))) ;; dynarray
+  (var next-path dynstring null)
+  (var previous-path dynstring null)
+  (var temp-path dynstring null)
+  (dynstring-append (addr previous-path) current-dir)
+  (get-parent-of-path previous-path (addr next-path))
+
+  (while (!= (dynstring-strlen previous-path) (dynstring-strlen next-path))
+    (var new-divided-path-dir divided-path-dir (array 0))
+    (strcpy (field new-divided-path-dir full-path) previous-path)
+    (set (field new-divided-path-dir innermost-dir-offset) (dynstring-strlen next-path))
+    (dynarray-push (deref divided-path) new-divided-path-dir)
+    (dynarray-clear temp-path)
+    (dynstring-append (addr temp-path) next-path)
+    (get-parent-of-path next-path (addr next-path))
+    (dynarray-clear previous-path)
+    (dynstring-append (addr previous-path) temp-path))
+
+  (var root-path-dir divided-path-dir (array 0))
+  (strcpy (field root-path-dir full-path) next-path)
+  (set (field root-path-dir innermost-dir-offset) 0)
+  (dynarray-push (deref divided-path) root-path-dir)
+
+  (dynarray-free temp-path)
+  (dynarray-free previous-path)
+  (dynarray-free next-path))
+
+;;
+;; Platform implementations
+;;
+
+(comptime-cond
+ ('Unix
+  (c-import "<dirent.h>" "<errno.h>" "<sys/stat.h>" "<assert.h>")
+
+  ;; This is gross hidden behavior
+  (defun-local is-special-skippable-dir (path (* (const char))
+                                         &return bool)
+    (return (or (= 0 (strcmp "/proc" path))
+                (= 0 (strcmp "/sys" path)))))
+
+  (defun-local set-error-string (error-string-buffer (* char) error-string-buffer-length size_t)
+    ;; See man strerror(3)
+    (if (and (>= _POSIX_C_SOURCE 200112L) (not _GNU_SOURCE))
+        ;; XSI-complient version always writes error string to buffer
+        (scope (var return-str (* (const char))
+                 (strerror_r errno error-string-buffer error-string-buffer-length)))
+        ;; GNU version only writes to buffer sometimes; we need to copy to our buffer in that case
+        (scope
+         (var return-str (* (const char))
+           (strerror_r errno error-string-buffer error-string-buffer-length))
+         (unless (at 0 error-string-buffer)
+           (safe-strncpy error-string-buffer return-str error-string-buffer-length)))))
+
+  (defun read-directory-details (directory-name (* (const char))
+                                 directories-dynarray (* (* directory-entry))
+                                 entry-details-dynarray (* (* entry-details)) ;; null slots for directories
+                                 ;; If read-directory returns false, this holds a user-facing string with
+                                 ;; a description of the error
+                                 error-string-buffer (* char) error-string-buffer-length size_t
+                                 &return bool)
+    (assert (and directory-name directories-dynarray))
+
+    (when (is-special-skippable-dir directory-name)
+      (return true))
+
+    ;; Clear any previous entries
+    (directory-entries-destroy (deref directories-dynarray))
+    (dynarray-set-length (deref directories-dynarray) 0)
+    (dynarray-set-length (deref entry-details-dynarray) 0)
+
+    (var directory (* DIR) (opendir directory-name))
+    (unless directory
+      (set-error-string error-string-buffer error-string-buffer-length)
+      (perror "read-directory")
+      (return false))
+    (c-for (var entry (* dirent) (readdir directory))
+        entry
+        (set entry (readdir directory))
+      (fsdebugf "%s" (path entry > d_name))
+
+      ;; Filter current dir and parent dir
+      (when (or (= 0 (strcmp (path entry > d_name) ".."))
+                (= 0 (strcmp (path entry > d_name) ".")))
+        (continue))
+
+      (var new-entry directory-entry (array 0))
+
+      ;; TODO String interning?
+      (set (field new-entry name) (strdup (path entry > d_name)))
+
+      (scope
+       ;; TODO: Better to have this be stack allocated
+       (dynstring-create-f entry-filename
+                           "%s/%s" directory-name (path entry > d_name))
+       (var details (struct stat))
+       ;; Use lstat to treat symlinks as files
+	   (when (and (= -1 (lstat entry-filename (addr details)))
+                  (!= errno ENOENT))
+         (dynarray-free entry-filename)
+		 (set-error-string error-string-buffer error-string-buffer-length)
+         (perror "read-directory")
+         (return false))
+       ;; TODO Pool this or something instead
+       (var new-details entry-details (array 0))
+       (set (field new-details path) (strdup entry-filename))
+       (dynarray-free entry-filename)
+       (cond
+         ((S_ISDIR (field details st_mode))
+          (set (field new-details is-directory) true)
+          (set (field new-entry is-directory) true)
+          (fsdebugf "\t\tdirectory"))
+         ((S_ISREG (field details st_mode)) ;; File; populate details
+          (set (field new-details is-directory) false)
+          (set (field new-details size) (field details st_size))
+          (set (field new-entry size) (field details st_size))))
+
+       (set (field new-details can-read) (bit-and (field details st_mode) S_IROTH))
+
+       (dynarray-push (deref entry-details-dynarray) new-details))
+
+      (dynarray-push (deref directories-dynarray) new-entry)
+      (fsdebugf "\n"))
+    (closedir directory)
+    (return true))
+
+  (defun read-directory (directory-name (* (const char))
+                         directories-dynarray (* (* directory-entry))
+                         ;; If read-directory returns false, this holds a user-facing string with
+                         ;; a description of the error
+                         error-string-buffer (* char) error-string-buffer-length size_t
+                         &return bool)
+    (assert (and directory-name directories-dynarray))
+
+    ;; Clear any previous entries
+    (directory-entries-destroy (deref directories-dynarray))
+    (dynarray-set-length (deref directories-dynarray) 0)
+
+    (var directory (* DIR) (opendir directory-name))
+    (unless directory
+      (set-error-string error-string-buffer error-string-buffer-length)
+      (perror "read-directory")
+      (return false))
+    (c-for (var entry (* dirent) (readdir directory))
+        entry
+        (set entry (readdir directory))
+      (fsdebugf "%s" (path entry > d_name))
+
+      ;; Filter current dir and parent dir
+      (when (or (= 0 (strcmp (path entry > d_name) ".."))
+                (= 0 (strcmp (path entry > d_name) ".")))
+        (continue))
+
+      (var new-entry directory-entry (array 0))
+
+      ;; TODO String interning?
+      (set (field new-entry name) (strdup (path entry > d_name)))
+
+      ;; See man 3 readdir. This is a nice speed-up but we aren't guaranteed to have it
+      ;; No longer used because I need to get the size from stat anyways (which would have been the
+      ;; else block when _DIRENT_HAVE_D_TYPE is undefined
+      ;; (if-c-preprocessor-defined _DIRENT_HAVE_D_TYPE
+      ;;   (scope
+      ;;    (when (= DT_DIR (path entry > d_type))
+      ;;      (set (field new-entry is-directory) true)
+      ;;      (fsdebugf "\t\tdirectory"))))
+      (scope
+       ;; TODO: Better to have this be stack allocated
+       (dynstring-create-f entry-filename
+                           "%s/%s" directory-name (path entry > d_name))
+       (var details (struct stat))
+       ;; Use lstat to treat symlinks as files
+	   (when (and (= -1 (lstat entry-filename (addr details)))
+                  (!= errno ENOENT))
+         (dynarray-free entry-filename)
+		 (set-error-string error-string-buffer error-string-buffer-length)
+         (perror "read-directory")
+         (return false))
+       (dynarray-free entry-filename)
+       (set (field new-entry size) (field details st_size))
+       (when (S_ISDIR (field details st_mode))
+         (set (field new-entry is-directory) true)
+         (fsdebugf "\t\tdirectory")))
+
+      (dynarray-push (deref directories-dynarray) new-entry)
+      (fsdebugf "\n"))
+    (closedir directory)
+    (return true))
+
+  ;; For testing only. This is normally a Windows-only function
+  (defun get-file-drives (drives-out ([] 26 char))
+    (var current-drive (* char) drives-out)
+    (each-in-range 26 i
+        (set (deref current-drive) (+ i 'A'))
+        (incr current-drive))))
+
+ ('Windows
+  (c-preprocessor-define WIN32_LEAN_AND_MEAN)
+  (c-import "windows.h")
+  (defun read-directory-details (directory-name (* (const char))
+                                 directories-dynarray (* (* directory-entry))
+                                 entry-details-dynarray (* (* entry-details)) ;; null slots for directories
+                                 ;; If read-directory returns false, this holds a user-facing string with
+                                 ;; a description of the error
+                                 error-string-buffer (* char) error-string-buffer-length size_t
+                                 &return bool)
+    ;; Clear any previous entries
+    (directory-entries-destroy (deref directories-dynarray))
+    (dynarray-set-length (deref directories-dynarray) 0)
+    (dynarray-set-length (deref entry-details-dynarray) 0)
+
+    (var search-directory-path ([] 1024 char) (array 0))
+    ;; Required by FindFirstFile; see https://docs.microsoft.com/en-us/windows/win32/fileio/listing-the-files-in-a-directory
+    (snprintf search-directory-path (sizeof search-directory-path) "%s/*" directory-name)
+	(var directory-name-length size_t (strlen directory-name))
+	(var has-slash bool (= (at (- directory-name-length 1) directory-name) '/'))
+    (set (at (- 1024 1) search-directory-path) 0)
+
+    (var find-data WIN32_FIND_DATA)
+    (var find-handle HANDLE INVALID_HANDLE_VALUE)
+    (set find-handle (FindFirstFile search-directory-path (addr find-data)))
+    (when (= find-handle INVALID_HANDLE_VALUE)
+	  ;; This would be great except that FindFirstFile appears to return ERROR_ACCESS_DENIED when
+	  ;; directories are empty. This means I cannot detect whether access was actually denied, or
+	  ;; the folder is legitimately empty. So, no error on invalid handle seems to be the only option
+      ;; (snprintf error-string-buffer error-string-buffer-length
+      ;;           "Failed to find first file in directory (%d)" (GetLastError))
+      ;; (set (at (- error-string-buffer-length 1) error-string-buffer) 0)
+      ;; (return false)
+	  (return true))
+
+    (while true
+      ;; Filter current dir and parent dir
+      ;; Ignore links? Doesn't appear to be necessary, at least not on my system
+      (unless (or ;; (bit-and (field find-data dwFileAttributes) FILE_ATTRIBUTE_REPARSE_POINT)
+               (= 0 (strcmp (field find-data cFileName) ".."))
+               (= 0 (strcmp (field find-data cFileName) ".")))
+        (var is-directory bool (bit-and (field find-data dwFileAttributes)
+                                        FILE_ATTRIBUTE_DIRECTORY))
+        (var new-entry directory-entry (array 0))
+        ;; TODO String interning?
+        (set (field new-entry name) (strdup (field find-data cFileName)))
+        (set (field new-entry is-directory) is-directory)
+        (var new-entry-details entry-details (array 0))
+        (scope
+         (var full-path ([] 1024 char) (array 0))
+         (snprintf full-path (sizeof full-path) "%s%s%s" directory-name
+				   (? has-slash "" "/")
+				   (field find-data cFileName))
+		 (path-convert-to-forward-slashes full-path)
+         ;; TODO String interning?
+         (set (field new-entry-details path) (strdup full-path)))
+        (set (field new-entry-details can-read) true)
+        (scope
+         (var file-size LARGE_INTEGER)
+         (set (field file-size LowPart) (field find-data nFileSizeLow))
+         (set (field file-size HighPart) (field find-data nFileSizeHigh))
+         ;; TODO This is probably not correct!
+         (set (field new-entry-details size) (type-cast (field file-size QuadPart) size_t))
+         (set (field new-entry size) (field new-entry-details size)))
+        (set (field new-entry-details is-directory) is-directory)
+        ;; (fprintf stderr "%s    %s %d\n" (field find-data cFileName)
+        ;;          (? is-directory "dir" "file")
+        ;;          ;; Wrong!
+        ;;          (type-cast (field new-entry-details size) int))
+        (dynarray-push (deref entry-details-dynarray) new-entry-details)
+        (dynarray-push (deref directories-dynarray) new-entry))
+
+      (unless (FindNextFile find-handle (addr find-data))
+        (break)))
+
+    (var error DWORD (GetLastError))
+    (unless (= error ERROR_NO_MORE_FILES)
+      (snprintf error-string-buffer error-string-buffer-length
+                "Failed to read entire directory with code %d"
+                (type-cast error int))
+      (set (at (- error-string-buffer-length 1) error-string-buffer) 0)
+      (FindClose find-handle)
+      (return false))
+
+    (FindClose find-handle)
+    (return true))
+
+  (defun read-directory (directory-name (* (const char))
+                         directories-dynarray (* (* directory-entry))
+                         ;; If read-directory returns false, this holds a user-facing string with
+                         ;; a description of the error
+                         error-string-buffer (* char) error-string-buffer-length size_t
+                         &return bool)
+    (var entry-details-dynarray (* entry-details) null)
+    (var result bool (read-directory-details directory-name directories-dynarray
+                                             (addr entry-details-dynarray) error-string-buffer
+                                             error-string-buffer-length))
+    (dynarray-free entry-details-dynarray)
+    (return result))
+
+  (defun get-file-drives (drives-out ([] 26 char))
+    (var drives DWORD (GetLogicalDrives))
+    (var current-drive (* char) drives-out)
+    (each-in-range 26 i
+      (when (bit-and (bit->> drives i) 1)
+        (set (deref current-drive) (+ i 'A'))
+        (incr current-drive)))))
+ (true
+  (comptime-error "Need to define a supported platform or add FileSystem support to this platform")))