cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

improve pathname handling: correctly handle file types and leading dots

Browse source
This commit is contained in:
Helmut Merz 2024-06-03 16:48:04 +02:00
parent 476234f6c1
commit 8879a6ffa7
2 changed files with 16 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
config.lisp
View file

@ -11,13 +11,19 @@
(in-package :scopes/config)
(defun relative-path (name &rest dirs)
(make-pathname :name name :directory (cons :relative dirs)))
(let* ((parts (str:rsplit "." name :limit 2))
(n (pop parts))
(type (car parts)))
(when (string= n "")
(setf n name)
(setf type nil))
(make-pathname :name n :type type :directory (cons :relative dirs))))
(defun system-path (sys name &rest dirs)
(asdf:system-relative-pathname sys (apply #'relative-path name dirs)))
(defun test-path (sys name)
(system-path sys name "test"))
(defun test-path (sys name &rest more-dirs)
(apply #'system-path sys name "test" more-dirs))
(defun runtime-path (name &rest dirs)
(merge-pathnames (apply #'relative-path name dirs)))

12
test/test-config.lisp
View file

@ -24,10 +24,12 @@
(t:show-result)))
(t:deftest test-make-path ()
(format t "~%relative-path: ~a" (config:relative-path "config" "app" "etc"))
(format t "~%system-path: ~a" (config:system-path :scopes "config" "test"))
(format t "~%test-path: ~a" (config:test-path :scopes "config"))
(format t "~%runtime-path: ~a" (config:runtime-path "config" "app" "etc")))
(format t "~&relative-path: ~s" (config:relative-path "config" "app" "etc"))
(format t "~%system-path: ~s" (config:system-path :scopes "config" "test"))
(format t "~%test-path (config): ~s" (config:test-path :scopes "config"))
(format t "~%test-path (data): ~s" (config:test-path :scopes "test.db" "data"))
(format t "~%runtime-path: ~s" (config:runtime-path "config" "app" "etc"))
(format t "~%runtime-path (.env): ~s" (config:runtime-path ".env" "app")))
(t:deftest test-env-override ()
(format t "~%override-keys: ~a" (config:override-keys *config*)))
(format t "~%override-keys: ~s" (config:override-keys *config*)))