Commit 6b2947e3 authored by Rommel M. Martinez's avatar Rommel M. Martinez
Browse files

Extended with-env; added placeholders

parent bdf412cf
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment