Commit 08149c40 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files
parents 31c47c52 7c184ec6
Loading
Loading
Loading
Loading
+1 −0
Original line number Diff line number Diff line
@@ -7,6 +7,7 @@ website/changelog.xml

# Test stuff
test/results/
test/tmp/

# We build these at various stages in the make process
LICENSE
+11 −1
Original line number Diff line number Diff line
@@ -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]"
@@ -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"
+39 −112
Original line number Diff line number Diff line
@@ -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