Loading test/test-source-registry.script +58 −33 Original line number Diff line number Diff line Loading @@ -3,6 +3,11 @@ ;; TODO: ;; - test for conditions ;; - use with-env for CL_SOURCE_REGISTRY ;; - write clean-up procedures, if needed (eval-when (:execute :compile-toplevel :load-toplevel) (require :sb-posix)) (defpackage :test-source-registry (:use #:cl #:asdf)) Loading @@ -16,25 +21,33 @@ (defun setenv (x v) #+sbcl (sb-posix:putenv (concatenate 'string x "=" v))) (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-var ((key value) &rest rest) (with-gensyms (key-save) `(let ((,key-save ,(getenv key))) (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 (setenv ,key ,value) ,@rest) (progn (setenv ,key ,key-save)))))) ,@(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") :search t :output s)))) (sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s)))) (concatenate 'string (string-trim '(#\newline) str) "/"))) Loading @@ -49,13 +62,20 @@ (merge-pathnames "tmp/" base)) (defun home-source-registry () (source-registry-under (merge-pathnames ".config/" (home-directory)))) (asdf::source-registry-under (merge-pathnames ".config/" (home-directory)))) (defun system-source-registry () (source-registry-under (system-directory))) (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 (tmp-directory)) (merge-temp-under (merge-temp-under (tmp-directory)))) (defvar *system-source-registry-config* `(:source-registry (:inherit-configuration) Loading @@ -67,30 +87,35 @@ (:inhert-configuration) (:directory ,(namestring (tmp-directory))))) (defun write-registry-file (file contents) (with-open-file (out file (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 () (write-registry-file (system-source-registry) *system-source-registry-config*)) (defun write-home-source-registry-config () (write-registry-file (home-source-registry) *home-source-registry-config*)) (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 (defun merge-temp-under (path) (namestring (merge-pathnames (let ((s (string-downcase (prin1-to-string (gentemp))))) (concatenate 'string s "/")) path))) ;; test environment variable (defun test-environment () (with-env-var (("CL_SOURCE_REGISTRY" (format nil "~A:~A" (home-directory) (system-directory)))) ...)) ;; test files (cl-user::quit-on-error (defun test-files () ...) ;; (cl-user::quit-on-error ;; ...) No newline at end of file Loading
test/test-source-registry.script +58 −33 Original line number Diff line number Diff line Loading @@ -3,6 +3,11 @@ ;; TODO: ;; - test for conditions ;; - use with-env for CL_SOURCE_REGISTRY ;; - write clean-up procedures, if needed (eval-when (:execute :compile-toplevel :load-toplevel) (require :sb-posix)) (defpackage :test-source-registry (:use #:cl #:asdf)) Loading @@ -16,25 +21,33 @@ (defun setenv (x v) #+sbcl (sb-posix:putenv (concatenate 'string x "=" v))) (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-var ((key value) &rest rest) (with-gensyms (key-save) `(let ((,key-save ,(getenv key))) (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 (setenv ,key ,value) ,@rest) (progn (setenv ,key ,key-save)))))) ,@(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") :search t :output s)))) (sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s)))) (concatenate 'string (string-trim '(#\newline) str) "/"))) Loading @@ -49,13 +62,20 @@ (merge-pathnames "tmp/" base)) (defun home-source-registry () (source-registry-under (merge-pathnames ".config/" (home-directory)))) (asdf::source-registry-under (merge-pathnames ".config/" (home-directory)))) (defun system-source-registry () (source-registry-under (system-directory))) (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 (tmp-directory)) (merge-temp-under (merge-temp-under (tmp-directory)))) (defvar *system-source-registry-config* `(:source-registry (:inherit-configuration) Loading @@ -67,30 +87,35 @@ (:inhert-configuration) (:directory ,(namestring (tmp-directory))))) (defun write-registry-file (file contents) (with-open-file (out file (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 () (write-registry-file (system-source-registry) *system-source-registry-config*)) (defun write-home-source-registry-config () (write-registry-file (home-source-registry) *home-source-registry-config*)) (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 (defun merge-temp-under (path) (namestring (merge-pathnames (let ((s (string-downcase (prin1-to-string (gentemp))))) (concatenate 'string s "/")) path))) ;; test environment variable (defun test-environment () (with-env-var (("CL_SOURCE_REGISTRY" (format nil "~A:~A" (home-directory) (system-directory)))) ...)) ;; test files (cl-user::quit-on-error (defun test-files () ...) ;; (cl-user::quit-on-error ;; ...) No newline at end of file