Loading .gitignore +1 −0 Original line number Diff line number Diff line Loading @@ -7,6 +7,7 @@ website/changelog.xml # Test stuff test/results/ test/tmp/ # We build these at various stages in the make process LICENSE Loading test/run-tests.sh +11 −1 Original line number Diff line number Diff line Loading @@ -5,7 +5,8 @@ # - quit with exit status 0 on getting eof # - quit with exit status >0 if an unhandled error occurs export CL_SOURCE_REGISTRY=$PWD export TEST_DIR="$PWD/tmp/" export CL_SOURCE_REGISTRY="$TEST_DIR/dir1/:$TEST_DIR/dir2//" if [ x"$1" = "xhelp" ]; then echo "$0 [lisp invocation] [scripts-regex]" Loading Loading @@ -105,6 +106,15 @@ fi # do_tests "/usr/bin/lisp -batch -noinit" x86f #fi create_asds () { mkdir -p tmp/{dir1,dir2/{dir3,dir4}} for i in `find tmp | sed -e '1d'`; do touch "$i"/test.asd; done } clean_up () { rm -rf tmp } if [ -z "$command" ] ; then echo "Error: cannot find or do not know how to run Lisp named $lisp" Loading test/test-source-registry.s +39 −112 Original line number Diff line number Diff line Loading @@ -2,120 +2,47 @@ (load "../asdf") ;; TODO: ;; - test for conditions ;; - use with-env for CL_SOURCE_REGISTRY ;; - write clean-up procedures, if needed ;; - test for directories ;; - test for correct chaining of inheritance (eval-when (:execute :compile-toplevel :load-toplevel) (require :sb-posix)) (defun pathname->directory (pathname) (make-pathname :directory (append (pathname-directory pathname) (list (file-namestring pathname))) :name nil :type nil :defaults (pathname pathname))) (defpackage :test-source-registry (:use #:cl #:asdf)) (defvar *test-directory* (pathname->directory (getenv "TEST_DIR"))) (in-package :test-source-registry) (defun under-test-directory (path &optional (defaults *test-directory*)) (merge-pathnames path defaults)) (defun getenv (x) #+sbcl (sb-posix:getenv x)) (defun setenv (x v) #+sbcl (sb-posix:putenv (concatenate 'string x "=" v)) v) (defmacro with-gensyms ((&rest names) &body body) `(let ,(loop for n in names collect `(,n (gensym))) ,@body)) (defmacro with-env ((&rest kv) &body body) (let ((temps (loop :for i :upto (length kv) :collect (gensym))) (keys (mapcar #'(lambda (x) (first x)) kv))) (flet ((gen-getenvs () (mapcar #'(lambda (x y) `(,y (getenv ,x))) keys temps)) (gen-setenvs () (mapcar #'(lambda (x y) `(setenv ,y ,x)) temps keys))) `(let ,(gen-getenvs) (unwind-protect (progn ,@(loop :for (k v) :in kv :collect `(setenv ,k ,v)) ,@body) (progn ,@(gen-setenvs))))))) (defun make-temporary-directory () (let ((str (with-output-to-string (s) (sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s)))) (concatenate 'string (string-trim '(#\newline) str) "/"))) (defvar *base-directory* (make-temporary-directory)) (defun home-directory (&optional (base *base-directory*)) (let ((s (namestring (user-homedir-pathname)))) (merge-pathnames (subseq s 1 (length s)) base))) (defun system-directory (&optional (base *base-directory*)) (merge-pathnames "etc/" base)) (defun tmp-directory (&optional (base *base-directory*)) (merge-pathnames "tmp/" base)) (defun home-source-registry () (asdf::source-registry-under (merge-pathnames ".config/" (home-directory)))) (defun system-source-registry () (asdf::source-registry-under (system-directory))) (defun merge-temp-under (path) (namestring (merge-pathnames (let ((s (string-downcase (prin1-to-string (gentemp))))) (concatenate 'string s "/")) path))) (defvar *asd-temp-path-1* (merge-temp-under (merge-temp-under (tmp-directory)))) (defvar *system-source-registry-config* (defvar *test-config-1* `(:source-registry (:inherit-configuration) (:tree ,*asd-temp-path-1*))) (defvar *asd-temp-path-2* (namestring (tmp-directory))) (defvar *home-source-registry-config* `(:source-registry (:inhert-configuration) (:directory ,(namestring (tmp-directory))))) (defun write-registry-file (path contents) (ensure-directories-exist path) (with-open-file (out path :direction :output :if-exists :supersede) (with-standard-io-syntax (format out "~S" contents)))) (defun write-system-source-registry-config (&key (path (system-source-registry)) (contents *system-source-registry-config*)) (write-registry-file path contents)) (defun write-home-source-registry-config (&key (path (home-source-registry)) (contents *home-source-registry-config*)) (write-registry-file path contents)) ;; use *asd-temp-path-X*? (defun create-asd-file (&optional (directory *default-pathname-defaults*)) (let ((*default-pathname-defaults* directory)) (with-open-file (out ;; test environment variable (defun test-environment () (with-env-var (("CL_SOURCE_REGISTRY" (format nil "~A:~A" (home-directory) (system-directory)))) ...)) ;; test files (defun test-files () ...) ;; (cl-user::quit-on-error ;; ...) No newline at end of file (:directory ,(namestring (under-test-directory "dir1/"))) (:tree ,(namestring (under-test-directory "dir2/"))) (:ignore-inherited-configuration))) (defvar *test-expect-1* (loop :for dir :in '("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/") :collect (merge-pathnames dir *test-directory*))) (defvar *test-source-registries* '(test-environment-source-registry test-something-2 test-something-3)) (cl-user::quit-on-error (assert (equal (process-source-registry (getenv "CL_SOURCE_REGISTRY")) *test-expect-1*)) (assert (equal (process-source-registry *test-config-1*) *test-expect-1*)) ;; FIXME: add more tests ;; (assert (equal ...)) ) No newline at end of file Loading
.gitignore +1 −0 Original line number Diff line number Diff line Loading @@ -7,6 +7,7 @@ website/changelog.xml # Test stuff test/results/ test/tmp/ # We build these at various stages in the make process LICENSE Loading
test/run-tests.sh +11 −1 Original line number Diff line number Diff line Loading @@ -5,7 +5,8 @@ # - quit with exit status 0 on getting eof # - quit with exit status >0 if an unhandled error occurs export CL_SOURCE_REGISTRY=$PWD export TEST_DIR="$PWD/tmp/" export CL_SOURCE_REGISTRY="$TEST_DIR/dir1/:$TEST_DIR/dir2//" if [ x"$1" = "xhelp" ]; then echo "$0 [lisp invocation] [scripts-regex]" Loading Loading @@ -105,6 +106,15 @@ fi # do_tests "/usr/bin/lisp -batch -noinit" x86f #fi create_asds () { mkdir -p tmp/{dir1,dir2/{dir3,dir4}} for i in `find tmp | sed -e '1d'`; do touch "$i"/test.asd; done } clean_up () { rm -rf tmp } if [ -z "$command" ] ; then echo "Error: cannot find or do not know how to run Lisp named $lisp" Loading
test/test-source-registry.s +39 −112 Original line number Diff line number Diff line Loading @@ -2,120 +2,47 @@ (load "../asdf") ;; TODO: ;; - test for conditions ;; - use with-env for CL_SOURCE_REGISTRY ;; - write clean-up procedures, if needed ;; - test for directories ;; - test for correct chaining of inheritance (eval-when (:execute :compile-toplevel :load-toplevel) (require :sb-posix)) (defun pathname->directory (pathname) (make-pathname :directory (append (pathname-directory pathname) (list (file-namestring pathname))) :name nil :type nil :defaults (pathname pathname))) (defpackage :test-source-registry (:use #:cl #:asdf)) (defvar *test-directory* (pathname->directory (getenv "TEST_DIR"))) (in-package :test-source-registry) (defun under-test-directory (path &optional (defaults *test-directory*)) (merge-pathnames path defaults)) (defun getenv (x) #+sbcl (sb-posix:getenv x)) (defun setenv (x v) #+sbcl (sb-posix:putenv (concatenate 'string x "=" v)) v) (defmacro with-gensyms ((&rest names) &body body) `(let ,(loop for n in names collect `(,n (gensym))) ,@body)) (defmacro with-env ((&rest kv) &body body) (let ((temps (loop :for i :upto (length kv) :collect (gensym))) (keys (mapcar #'(lambda (x) (first x)) kv))) (flet ((gen-getenvs () (mapcar #'(lambda (x y) `(,y (getenv ,x))) keys temps)) (gen-setenvs () (mapcar #'(lambda (x y) `(setenv ,y ,x)) temps keys))) `(let ,(gen-getenvs) (unwind-protect (progn ,@(loop :for (k v) :in kv :collect `(setenv ,k ,v)) ,@body) (progn ,@(gen-setenvs))))))) (defun make-temporary-directory () (let ((str (with-output-to-string (s) (sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s)))) (concatenate 'string (string-trim '(#\newline) str) "/"))) (defvar *base-directory* (make-temporary-directory)) (defun home-directory (&optional (base *base-directory*)) (let ((s (namestring (user-homedir-pathname)))) (merge-pathnames (subseq s 1 (length s)) base))) (defun system-directory (&optional (base *base-directory*)) (merge-pathnames "etc/" base)) (defun tmp-directory (&optional (base *base-directory*)) (merge-pathnames "tmp/" base)) (defun home-source-registry () (asdf::source-registry-under (merge-pathnames ".config/" (home-directory)))) (defun system-source-registry () (asdf::source-registry-under (system-directory))) (defun merge-temp-under (path) (namestring (merge-pathnames (let ((s (string-downcase (prin1-to-string (gentemp))))) (concatenate 'string s "/")) path))) (defvar *asd-temp-path-1* (merge-temp-under (merge-temp-under (tmp-directory)))) (defvar *system-source-registry-config* (defvar *test-config-1* `(:source-registry (:inherit-configuration) (:tree ,*asd-temp-path-1*))) (defvar *asd-temp-path-2* (namestring (tmp-directory))) (defvar *home-source-registry-config* `(:source-registry (:inhert-configuration) (:directory ,(namestring (tmp-directory))))) (defun write-registry-file (path contents) (ensure-directories-exist path) (with-open-file (out path :direction :output :if-exists :supersede) (with-standard-io-syntax (format out "~S" contents)))) (defun write-system-source-registry-config (&key (path (system-source-registry)) (contents *system-source-registry-config*)) (write-registry-file path contents)) (defun write-home-source-registry-config (&key (path (home-source-registry)) (contents *home-source-registry-config*)) (write-registry-file path contents)) ;; use *asd-temp-path-X*? (defun create-asd-file (&optional (directory *default-pathname-defaults*)) (let ((*default-pathname-defaults* directory)) (with-open-file (out ;; test environment variable (defun test-environment () (with-env-var (("CL_SOURCE_REGISTRY" (format nil "~A:~A" (home-directory) (system-directory)))) ...)) ;; test files (defun test-files () ...) ;; (cl-user::quit-on-error ;; ...) No newline at end of file (:directory ,(namestring (under-test-directory "dir1/"))) (:tree ,(namestring (under-test-directory "dir2/"))) (:ignore-inherited-configuration))) (defvar *test-expect-1* (loop :for dir :in '("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/") :collect (merge-pathnames dir *test-directory*))) (defvar *test-source-registries* '(test-environment-source-registry test-something-2 test-something-3)) (cl-user::quit-on-error (assert (equal (process-source-registry (getenv "CL_SOURCE_REGISTRY")) *test-expect-1*)) (assert (equal (process-source-registry *test-config-1*) *test-expect-1*)) ;; FIXME: add more tests ;; (assert (equal ...)) ) No newline at end of file