Skip to content
Snippets Groups Projects
Commit 5a8eaccd authored by Robert Goldman's avatar Robert Goldman
Browse files

Tests for loop check in ASD search.

Note that this loop check is problematic: if the bug appears and is not
fixed by the patch, this test will go away forever.
parent 7647ca49
No related branches found
No related tags found
No related merge requests found
(defsystem :loop
:components ((:file "loop")))
;;; -*- Lisp -*-
;;;---------------------------------------------------------------------------
;;; This checks a fix to bug 1533766 where a search of the
;;; registry can be caused to loop forever if symlinks introduce a circularity
;;; into the file tree.
;;; ---------------------------------------------------------------------------
(in-package :asdf-test)
;; since symlinks only somewhat exist on Windows, we don't test there.
(when (uiop:os-windows-p)
(exit-lisp 0))
(let ((scratch-dir (namestring (make-sub-pathname :directory '(:relative "looping-scratch")
:defaults *test-directory*))))
(unwind-protect
(progn
;; set up pathological directory structure
(uiop:run-program (format nil "mkdir ~a" scratch-dir))
(uiop:run-program (format nil "mkdir ~a/subdirs" scratch-dir))
(uiop:run-program (format nil "mkdir ~a/subdirs/subdir" scratch-dir))
(uiop:run-program (format nil "mkdir ~a/subdirs/subdir2" scratch-dir))
(uiop:run-program (format nil "cd ~a/subdirs/subdir ; ln -s .. ln-subdir"
scratch-dir))
(uiop:run-program (format nil "cd ~a/subdirs/subdir2 ; ln -s .. ln-subdir"
scratch-dir))
(uiop:copy-file (format nil "~a" (namestring (make-sub-pathname :name "loop"
:type "asd"
:defaults *test-directory*)))
(format nil "~a" (namestring (make-sub-pathname :name "loop"
:type "asd"
:defaults scratch-dir))))
(assert-equal (list "loop")
(let ((asds nil))
(declare (special asds))
(asdf/source-registry:collect-sub*directories-asd-files
"/Users/rpg/Downloads/asdf-loop\ 2/"
:collect
#'(lambda (asd)
(let* ((name (pathname-name asd))
(name (if (typep asd 'logical-pathname)
;; logical pathnames are upper-case,
;; at least in the CLHS and on SBCL,
;; yet (coerce-name :foo) is lower-case.
;; won't work well with (load-system "Foo")
;; instead of (load-system 'foo)
(string-downcase name)
name)))
(push name asds))))
asds))
(initialize-source-registry
`(:source-registry (:tree ,scratch-dir) :ignore-inherited-configuration))
(assert (asdf:find-system :loop)))
;; clean up
(uiop:run-program (format nil "rm -r ~a" scratch-dir))))
(exit-lisp 0)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment