Skip to content
Snippets Groups Projects
test-source-registry.script 2.61 KiB
Newer Older
(load "script-support")
(load "../asdf")

;; TODO:
;; - test for conditions

(defpackage :test-source-registry
  (:use #:cl #:asdf))

(in-package :test-source-registry)

(defun getenv (x)
  #+sbcl
  (sb-posix:getenv x))

(defun setenv (x v)
  #+sbcl
  (sb-posix:putenv
   (concatenate 'string x "=" 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))))))

(defun make-temporary-directory ()
  (let ((str (with-output-to-string (s)
               (sb-ext:run-program "mktemp" '("-d") :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 ()
  (source-registry-under (merge-pathnames ".config/" (home-directory))))
(defun system-source-registry ()
  (source-registry-under (system-directory)))


(defvar *asd-temp-path-1*
  (merge-temp-under (tmp-directory))
(defvar *system-source-registry-config*
  `(: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 (file contents)
  (with-open-file (out file
                       :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)))

;; test environment variable

;; test files

(cl-user::quit-on-error
 ...)