move pathname handling to new util package, and to testing package
This commit is contained in:
parent
8879a6ffa7
commit
d85453096e
6 changed files with 49 additions and 34 deletions
22
config.lisp
22
config.lisp
|
@ -4,30 +4,10 @@
|
||||||
|
|
||||||
(defpackage :scopes/config
|
(defpackage :scopes/config
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:export #:base #:make-system-path #:override-keys
|
(:export #:base #:make-system-path #:override-keys))
|
||||||
#:config-path #:file-path
|
|
||||||
#:relative-path #:runtime-path #:system-path #:test-path))
|
|
||||||
|
|
||||||
(in-package :scopes/config)
|
(in-package :scopes/config)
|
||||||
|
|
||||||
(defun relative-path (name &rest 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 &rest more-dirs)
|
|
||||||
(apply #'system-path sys name "test" more-dirs))
|
|
||||||
|
|
||||||
(defun runtime-path (name &rest dirs)
|
|
||||||
(merge-pathnames (apply #'relative-path name dirs)))
|
|
||||||
|
|
||||||
(defclass base ()
|
(defclass base ()
|
||||||
((override-keys :reader override-keys
|
((override-keys :reader override-keys
|
||||||
:initform nil
|
:initform nil
|
||||||
|
|
|
@ -7,9 +7,10 @@
|
||||||
:homepage "https://www.cyberconcepts.org"
|
:homepage "https://www.cyberconcepts.org"
|
||||||
:description "Core packages of the scopes project."
|
:description "Core packages of the scopes project."
|
||||||
:depends-on (:alexandria :com.inuoe.jzon :local-time :log4cl :str)
|
:depends-on (:alexandria :com.inuoe.jzon :local-time :log4cl :str)
|
||||||
:components ((:file "config")
|
:components ((:file "config" :depends-on ("util"))
|
||||||
(:file "forge/forge")
|
(:file "forge/forge")
|
||||||
(:file "testing")
|
(:file "util")
|
||||||
|
(:file "testing" :depends-on ("util"))
|
||||||
(:file "test/test-config" :depends-on ("testing" "config"))
|
(:file "test/test-config" :depends-on ("testing" "config"))
|
||||||
(:file "test/test-forge" :depends-on ("testing" "forge/forge")))
|
(:file "test/test-forge" :depends-on ("testing" "forge/forge")))
|
||||||
:long-description "scopes/core: The core packages of the scopes project."
|
:long-description "scopes/core: The core packages of the scopes project."
|
||||||
|
|
|
@ -8,11 +8,12 @@
|
||||||
:description "Generic data processing."
|
:description "Generic data processing."
|
||||||
:depends-on (:alexandria :chanl :cl-dotenv :com.inuoe.jzon :dbi
|
:depends-on (:alexandria :chanl :cl-dotenv :com.inuoe.jzon :dbi
|
||||||
:local-time :log4cl :str :sxql)
|
:local-time :log4cl :str :sxql)
|
||||||
:components ((:file "config")
|
:components ((:file "config" :depends-on ("util"))
|
||||||
(:file "forge/forge")
|
(:file "forge/forge")
|
||||||
(:file "storage/storage")
|
(:file "storage/storage")
|
||||||
(:file "storage/tracking" :depends-on ("storage/storage"))
|
(:file "storage/tracking" :depends-on ("storage/storage"))
|
||||||
(:file "testing")
|
(:file "util")
|
||||||
|
(:file "testing" :depends-on ("util"))
|
||||||
(:file "test/test-config" :depends-on ("testing" "config"))
|
(:file "test/test-config" :depends-on ("testing" "config"))
|
||||||
(:file "test/test-forge" :depends-on ("testing" "forge/forge"))
|
(:file "test/test-forge" :depends-on ("testing" "forge/forge"))
|
||||||
(:file "test/test-storage"
|
(:file "test/test-storage"
|
||||||
|
|
|
@ -5,6 +5,7 @@
|
||||||
(defpackage :scopes/test-config
|
(defpackage :scopes/test-config
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:local-nicknames (:config :scopes/config)
|
(:local-nicknames (:config :scopes/config)
|
||||||
|
(:util :scopes/util)
|
||||||
(:t :scopes/testing))
|
(:t :scopes/testing))
|
||||||
(:export #:run)
|
(:export #:run)
|
||||||
(:import-from :scopes/testing #:deftest #:==))
|
(:import-from :scopes/testing #:deftest #:==))
|
||||||
|
@ -24,12 +25,12 @@
|
||||||
(t:show-result)))
|
(t:show-result)))
|
||||||
|
|
||||||
(t:deftest test-make-path ()
|
(t:deftest test-make-path ()
|
||||||
(format t "~&relative-path: ~s" (config:relative-path "config" "app" "etc"))
|
(format t "~&relative-path: ~s" (util:relative-path "config" "app" "etc"))
|
||||||
(format t "~%system-path: ~s" (config:system-path :scopes "config" "test"))
|
(format t "~&system-path: ~s" (util:system-path :scopes "config" "test"))
|
||||||
(format t "~%test-path (config): ~s" (config:test-path :scopes "config"))
|
(format t "~&test-path (config): ~s" (t:test-path :scopes "config"))
|
||||||
(format t "~%test-path (data): ~s" (config:test-path :scopes "test.db" "data"))
|
(format t "~&test-path (data): ~s" (t:test-path :scopes "test.db" "data"))
|
||||||
(format t "~%runtime-path: ~s" (config:runtime-path "config" "app" "etc"))
|
(format t "~&runtime-path: ~s" (util:runtime-path "config" "app" "etc"))
|
||||||
(format t "~%runtime-path (.env): ~s" (config:runtime-path ".env" "app")))
|
(format t "~&runtime-path (.env): ~s" (util:runtime-path ".env" "app")))
|
||||||
|
|
||||||
(t:deftest test-env-override ()
|
(t:deftest test-env-override ()
|
||||||
(format t "~%override-keys: ~s" (config:override-keys *config*)))
|
(format t "~&override-keys: ~s~%" (config:override-keys *config*)))
|
||||||
|
|
10
testing.lisp
10
testing.lisp
|
@ -6,7 +6,8 @@
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:export #:*test-suite*
|
(:export #:*test-suite*
|
||||||
#:test-suite #:deftest #:show-result
|
#:test-suite #:deftest #:show-result
|
||||||
#:test #:==))
|
#:test #:==
|
||||||
|
#:test-path))
|
||||||
|
|
||||||
(in-package :scopes/testing)
|
(in-package :scopes/testing)
|
||||||
|
|
||||||
|
@ -41,3 +42,10 @@
|
||||||
`(defun ,name ,args
|
`(defun ,name ,args
|
||||||
(push '(,name) (result *test-suite*))
|
(push '(,name) (result *test-suite*))
|
||||||
,@body))
|
,@body))
|
||||||
|
|
||||||
|
;;;; utilities
|
||||||
|
|
||||||
|
(defun test-path (sys name &rest dirs)
|
||||||
|
(apply #'scopes/util:system-path sys name "test" dirs))
|
||||||
|
|
||||||
|
|
||||||
|
|
24
util.lisp
Normal file
24
util.lisp
Normal file
|
@ -0,0 +1,24 @@
|
||||||
|
;;;; clscopes/util
|
||||||
|
|
||||||
|
;;;; Common utilities for the scopes project.
|
||||||
|
|
||||||
|
(defpackage :scopes/util
|
||||||
|
(:use :common-lisp)
|
||||||
|
(:export #:relative-path #:runtime-path #:system-path))
|
||||||
|
|
||||||
|
(in-package :scopes/util)
|
||||||
|
|
||||||
|
(defun relative-path (name &rest 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 runtime-path (name &rest dirs)
|
||||||
|
(merge-pathnames (apply #'relative-path name dirs)))
|
||||||
|
|
||||||
|
(defun system-path (sys name &rest dirs)
|
||||||
|
(asdf:system-relative-pathname sys (apply #'relative-path name dirs)))
|
Loading…
Add table
Reference in a new issue