From 6b2947e36526a0fe008839929d73a4accdfbdee6 Mon Sep 17 00:00:00 2001 From: "Rommel M. Martinez" <ebzzry@gmail.com> Date: Thu, 21 Jan 2010 23:29:20 +0800 Subject: [PATCH] Extended with-env; added placeholders --- test/test-source-registry.script | 91 ++++++++++++++++++++------------ 1 file changed, 58 insertions(+), 33 deletions(-) diff --git a/test/test-source-registry.script b/test/test-source-registry.script index 8edb6158..f82a69e8 100644 --- a/test/test-source-registry.script +++ b/test/test-source-registry.script @@ -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)) @@ -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))) - (unwind-protect - (progn - (setenv ,key ,value) - ,@rest) - (progn - (setenv ,key ,key-save)))))) +(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") :search t :output s)))) + (sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s)))) (concatenate 'string (string-trim '(#\newline) str) "/"))) @@ -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) @@ -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 merge-temp-under (path) - (namestring - (merge-pathnames - (let ((s (string-downcase - (prin1-to-string (gentemp))))) - (concatenate 'string s "/")) - path))) +(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 +;; (cl-user::quit-on-error +;; ...) \ No newline at end of file -- GitLab