GameLib is a collection of libraries for creating applications in Cakelisp.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

371 lines
16 KiB

(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")))