Newer
Older
;;; -*- Lisp -*-
(assert
(every #'directory-pathname-p
(list
(make-pathname* :name nil :type nil :directory '(:absolute "tmp"))
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
;; and some implementations will enforce it.
(make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
(make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
(assert
(every (complement #'directory-pathname-p)
(list
Francois-Rene Rideau
committed
(make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
(make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
;; These are funky and non portable, omit from tests:
;; (make-pathname* :name "" :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
Francois-Rene Rideau
committed
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
Francois-Rene Rideau
committed
(macrolet ((ts (x y)
`(assert-equal (multiple-value-list (split-unix-namestring-directory-components ,@x))
',y)))
(ts ("" :ensure-directory t) (:relative nil nil nil))
(ts ("" :ensure-directory nil) (:relative nil nil nil))
(ts ("/" :ensure-directory t) (:absolute nil nil nil))
(ts ("/" :ensure-directory nil) (:absolute nil nil nil))
(ts ("/aa/ba" :ensure-directory t) (:absolute ("aa" "ba") nil nil))
(ts ("/aa/ba" :ensure-directory nil) (:absolute ("aa") "ba" nil)))
(assert (version-satisfies (asdf-version) (asdf-version)))
(assert (version-satisfies (asdf-version) "3.0"))
(assert (version-satisfies (asdf-version) "2.0"))
(assert (version-satisfies (find-system :test-asdf) "666"))
(handler-case (version-satisfies (find-system :test-asdf) "666")
(simple-warning (c)
(assert (search "Requested version ~S but ~S has no version" (simple-condition-format-control c))))
(:no-error (x)
Francois-Rene Rideau
committed
(declare (ignore x))
(error "version-satisfies must warn when given component without version")))
Francois-Rene Rideau
committed
(assert (version<= "2.0" (asdf-version)))
(assert (not (version-satisfies (asdf-version) "666")))
Francois-Rene Rideau
committed
(assert-pathnames-equal
(split-native-pathnames-string (join-namestrings '("foo" "bar")))
Francois-Rene Rideau
committed
(assert-pathnames-equal
(split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t)
Francois-Rene Rideau
committed
(assert-pathnames-equal
(split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t)
Francois-Rene Rideau
committed
(assert-pathnames-equal
(split-native-pathnames-string (join-namestrings '("/foo" "/bar"))
:want-absolute t :ensure-directory t)
(assert-equal
(mapcar 'location-function-p
'((:function f)
(:function (lambda (path absolute-source)
(declare (ignore absolute-source))
path))
(function previous-isnt-keyword)
Francois-Rene Rideau
committed
(:function f too many arguments)))
'(t t nil nil))
(initialize-source-registry '())
#|
(unless (find-system :swank nil)
(leave-test "Cannot find SWANK" 0))
(load-system :swank)
;;(setq swank-loader::*fasl-directory* (resolve-output "slime/"))
;;(ensure-directories-exist swank-loader::*fasl-directory*)
;;(DBG :foo swank-loader::*fasl-directory*)
(swank-loader:init)
|#
(defparameter *ok-symbols*
'(;; slots names
asdf/action:accept
asdf/action:action
asdf/action:done-p
asdf/action:stamp
asdf/bundle:prologue-code
asdf/bundle:build-args
asdf/bundle:epilogue-code
asdf/bundle:name-suffix
asdf/component:absolute-pathname
asdf/component:around-compile
asdf/component:author
asdf/component:children
asdf/component:children-by-name
asdf/component:components
asdf/component:components-by-name
asdf/component:default-component-class
;; the following is here only for backward compatibility; should be in
;; asdf/system. [2014/02/20:rpg]
asdf/component:defsystem-depends-on
asdf/component:description
asdf/component:%encoding
asdf/component:if-feature
asdf/component:inline-methods
asdf/component:in-order-to
asdf/component:licence
asdf/component:long-description
asdf/component:maintainer
asdf/component:name
asdf/component:operation-times
asdf/component:parent
asdf/component:properties
asdf/component:relative-pathname
asdf/component:sideway-dependencies
asdf/component:version
asdf/lisp-action:flags
asdf/plan:index
asdf/plan:forced
asdf/plan:forced-not
asdf/plan:planned-action-count
asdf/plan:planned-output-action-count
asdf/plan:planned-p
asdf/plan:total-action-count
asdf/plan:visited-actions
asdf/plan:visiting-action-set
asdf/plan:visiting-action-list
asdf/system:bug-tracker
asdf/system:build-pathname
asdf/system:system-defsystem-depends-on
asdf/system:system-weakly-depends-on
asdf/system:entry-point
asdf/system:homepage
asdf/system:long-name
asdf/system:mailto
asdf/system:source-control
asdf/action:accept
asdf/find-component:retry
asdf/find-system:coerce-entry-to-directory
asdf/find-system:remove-entry-from-registry
asdf/lisp-action:try-recompiling
#+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
;; on some implementations only
asdf/bundle:bundle-system
asdf/bundle:static-library
uiop/os:parse-file-location-info
uiop/os:parse-windows-shortcut
uiop/os:read-little-endian
uiop/os:read-null-terminated-string
;; backward compatibility upgrade only
asdf/backward-internals:make-sub-operation
asdf/backward-interface:on-failure
asdf/backward-interface:on-warnings
asdf/find-system:contrib-sysdef-search
asdf/find-system:sysdef-find-asdf
))
(defun defined-symbol-p (symbol)
(or (boundp symbol)
(fboundp symbol)
(macro-function symbol)
(find-class symbol nil)))
(defun fishy-exported-symbols (package &optional (ok-symbols *ok-symbols*))
(loop :for symbol :being :the external-symbols :of package
:unless (or
(defined-symbol-p symbol)
;;(symbol-call :swank :classify-symbol symbol)
(member symbol ok-symbols))
:collect symbol))
(defun fishy-asdf-exported-symbols ()
(remove-duplicates
(loop :for package :in (list-all-packages)
:when (and (string-prefix-p "ASDF/" (package-name package))
(not (equal (package-name package) "ASDF/COMMON-LISP")))
:nconc (fishy-exported-symbols package))
:from-end t))
(assert-equal nil (fishy-asdf-exported-symbols))
Francois-Rene Rideau
committed
(delete-package* :asdf-test-package-1)
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/c/"))
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/"))
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/"))
(register-directory *asdf-directory*)
(register-directory *uiop-directory*)
(let ((new-file (subpathname *build-directory* "deleteme/a/1.x")))
(when (probe-file new-file)
(delete-file new-file))
(copy-file (system-source-file :uiop) new-file))
(let ((new-file (subpathname *build-directory* "deleteme/a/b/2")))
(when (probe-file new-file)
(delete-file new-file))
(copy-file (system-source-file :uiop) new-file))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
(DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories")
(let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/")))
(directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/"))))
(assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x")))
(assert-pathnames-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2"))))
(DBG "check to make sure SUBDIRECTORIES does list subdirectories")
(let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/")))
(directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/"))))
(assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/b/")))
(assert-pathnames-equal
(sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x)))))
(list (subpathname *build-directory* "deleteme/a/b/c/")
(subpathname *build-directory* "deleteme/a/b/d/")
(subpathname *build-directory* "deleteme/a/b/e/"))))
(delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/"))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))))
(delete-directory-tree (subpathname *build-directory* "deleteme/")
:validate (lambda (x) (and (<= 5 (length (pathname-directory x)))
(subpathp x *build-directory*))))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
#+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+)
#+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+))
(assert (base-string-p (make-string 10 :element-type 'base-char)))
(assert-equal "abcd" (strcat "a" nil "bc" "d"))
(assert-equal "abcd" (reduce/strcat '("a" nil "bc" "d")))
Francois-Rene Rideau
committed
(defparameter *last-char-code* (1- (or #+allegro excl:real-char-code-limit char-code-limit)))
(defparameter *last-char* (code-char *last-char-code*))
(defparameter *last-char-string* (string *last-char*))
#-non-base-chars-exist-p
(progn
Francois-Rene Rideau
committed
(assert (base-string-p (make-string 10 :element-type 'character :initial-element *last-char*)))
(assert (typep *last-char* 'base-char)))
(defun basify (s) (coerce s 'base-string))
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
#+non-base-chars-exist-p
(progn
(assert (not (base-string-p *last-char-string*)))
(assert (not (base-string-p (make-string 10 :element-type 'character))))
(assert (not (base-string-p (unbasify "abc"))))
(assert (base-string-p (basify "abc")))
(assert (base-string-p (strcat "a" nil #\b (unbasify "cd"))))
(assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
(assert (base-string-p (strcat (basify "ab") (basify "cd"))))
(assert (not (base-string-p (strcat (basify "ab") #\c *last-char* (unbasify "d")))))
(assert (base-string-p (strcat (basify "ab") #\c #\d))))
Francois-Rene Rideau
committed
(or #+os-windows ;; Avoid C:\Users vs C:\users on SBCL.
(equalp (namestring *test-directory*) (namestring (getcwd)))
(assert-pathname-equal *test-directory* (getcwd)))
(assert-equal +crlf+ (map 'string 'code-char '(13 10)))
(assert-equal +lf+ (map 'string 'code-char '(10)))
(assert-equal +cr+ (map 'string 'code-char '(13)))
(defparameter acrlf (strcat "a" +crlf+))
(defparameter blf (strcat "b" +lf+))
(defparameter ccr (strcat "c" +cr+))
Francois-Rene Rideau
committed
(macrolet ((ts (x y z)
`(progn
(assert-equal (list ,x ,y) (multiple-value-list (stripln ,z)))
(assert-equal (strcat ,x ,y) ,z))))
(ts "a" +crlf+ acrlf)
(ts "b" +lf+ blf)
(ts "c" +cr+ ccr)
(ts acrlf +crlf+ (strcat acrlf +crlf+))
(ts blf +cr+ (strcat blf +cr+))
(ts "c" +crlf+ (strcat ccr +lf+))
(ts (strcat acrlf "b") +lf+ (strcat acrlf blf)))
Francois-Rene Rideau
committed
(DBG :wtf-s)
(with-temporary-file (:stream s :direction :io :prefix "LEP")
Francois-Rene Rideau
committed
(println "Hello, World" s)
(file-position s 0)
(assert-equal (read-line s) "Hello, World"))
(DBG :wtf-p)
(let ((pn
(with-temporary-file (:pathname pn :direction :output :prefix "LEP")
(assert-equal (read-file-lines pn) ())
pn)))
(assert (not (probe-file pn))))
(DBG :wtf-s-p)
(let ((pn
(with-temporary-file (:stream s :pathname p :keep t :direction :io :prefix "LEP")
(println "Hello, World" s)
(DBG :wsp s p (probe-file p))
p)))
(assert-equal (read-file-lines pn) '("Hello, World"))
(delete-file pn))
(DBG :ensure-gethash)
(let ((h (make-hash-table :test 'equal)))
(assert-equal (multiple-value-list (gethash 1 h 2)) '(2 nil))
(assert-equal (multiple-value-list (ensure-gethash 1 h 2)) '(2 nil))
(assert-equal (multiple-value-list (gethash 1 h 2)) '(2 t))
(assert-equal (multiple-value-list (ensure-gethash 1 h 3)) '(2 t))
(assert-equal (multiple-value-list (ensure-gethash 1 h '(error "foo"))) '(2 t))
(signals parse-error (ensure-gethash 2 h '(error parse-error)))
(assert-equal (multiple-value-list (gethash 3 h nil)) '(nil nil))
(assert-equal (multiple-value-list (ensure-gethash 3 h nil)) '(nil nil))
(assert-equal (multiple-value-list (gethash 3 h 4)) '(nil t))
(assert-equal (multiple-value-list (ensure-gethash 3 h 5)) '(nil t)))