;;; -*- Lisp -*- (assert (every #'directory-pathname-p (list (make-pathname* :name nil :type "" :directory '(:absolute "tmp")) (make-pathname* :name "" :directory '(:absolute "tmp")) (make-pathname* :type "" :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")) (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))))) (assert (every (complement #'directory-pathname-p) (list (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 "." :type "" :directory '(:absolute "tmp")) (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) (error "version-satisfies must warn when given component without version"))) (assert (version<= "2.0" (asdf-version))) (assert (not (version-satisfies (asdf-version) "666"))) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar"))) '(#p"foo" #p"bar")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t) '(#p"foo/" #p"bar/")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t) '(#p"/foo" #p"/bar")) (assert-pathnames-equal (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t :ensure-directory t) '(#p"/foo/" #p"/bar/")) (assert-equal (mapcar 'location-function-p '((:function f) (:function (lambda (path absolute-source) (declare (ignore absolute-source)) path)) (function previous-isnt-keyword) (: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/operation:feature asdf/operation:original-initargs 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 <<<<<<< HEAD asdf/system:system-depends-on ======= >>>>>>> Fix for launchpad bug 1247662. asdf/system:system-weakly-depends-on asdf/system:entry-point asdf/system:homepage asdf/system:long-name asdf/system:mailto asdf/system:source-control ;; restarts 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 ;; types asdf/bundle:user-system #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition ;; on some implementations only asdf/bundle:bundle-system asdf/bundle:register-pre-built-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)) (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"))) (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 (assert (base-string-p (make-string 10 :element-type 'character))) (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)))) (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+)) (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))) (DBG :wtf-s) (with-temporary-file (:stream s :direction :io :prefix "LEP") (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)))