test-utilities.script 14.3 KB
Newer Older
1
;;; -*- Lisp -*-
2

3
4
5
(assert
 (every #'directory-pathname-p
  (list
6
7
8
   (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.
9
10
   (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
11
12
13
(assert
 (every (complement #'directory-pathname-p)
  (list
14
15
   (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
   (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
16
;; These are funky and non portable, omit from tests:
17
18
;; (make-pathname* :name "" :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
19
20
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
21
22
23
24
25
26
27
28
29
30
31
32
(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"))
33
(assert (not (version-satisfies (find-system :test-asdf) "666")))
34
35
(handler-case (version-satisfies (find-system :test-asdf) "666")
  (simple-warning (c)
36
    (assert (search "Requested version ~S but ~S has no version" (simple-condition-format-control c))))
37
  (:no-error (x)
38
    (declare (ignore x))
39
    (error "version-satisfies must warn when given component without version")))
40
41
(assert (version<= "2.0" (asdf-version)))
(assert (not (version-satisfies (asdf-version) "666")))
42
(DBG "First pathname test.")
43
(assert-pathnames-equal
44
 (split-native-pathnames-string (join-namestrings '("foo" "bar")))
45
 '(#p"foo" #p"bar"))
46
(DBG "Second pathname test.")
47
(assert-pathnames-equal
48
 (split-native-pathnames-string (join-namestrings '("foo" "bar")) :ensure-directory t)
49
 '(#p"foo/" #p"bar/"))
50
(DBG "Third pathname test.")
51
(assert-pathnames-equal
52
 (split-native-pathnames-string (join-namestrings '("/foo" "/bar")) :want-absolute t)
53
 '(#p"/foo" #p"/bar"))
54
(DBG "Fourth pathname test.")
55
(assert-pathnames-equal
56
 (split-native-pathnames-string (join-namestrings '("/foo" "/bar"))
57
                                :want-absolute t :ensure-directory t)
58
 '(#p"/foo/" #p"/bar/"))
59
(DBG "Fifth pathname test.")
60
61
62
63
64
65
66
(assert-equal
 (mapcar 'location-function-p
         '((:function f)
           (:function (lambda (path absolute-source)
                        (declare (ignore absolute-source))
                        path))
           (function previous-isnt-keyword)
67
68
           (:function f too many arguments)))
 '(t t nil nil))
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84

(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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
    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
101
102
    ;; the following is here only for backward compatibility; should be in
    ;; asdf/system. [2014/02/20:rpg]
103
    asdf/component:defsystem-depends-on
104
105
106
107
108
109
110
111
112
113
114
115
116
    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
117
    asdf/component:sideway-dependencies
118
119
    asdf/component:version
    asdf/lisp-action:flags
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
120
    asdf/operation:feature
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
121
    asdf/operation:original-initargs
122
123
124
125
126
127
128
129
130
131
132
133
    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
134
135
    asdf/system:system-defsystem-depends-on
    asdf/system:system-weakly-depends-on
136
137
138
139
140
    asdf/system:entry-point
    asdf/system:homepage
    asdf/system:long-name
    asdf/system:mailto
    asdf/system:source-control
141
    ;; restarts
142
143
144
145
146
    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
147
    ;; types
148
    asdf/bundle:user-system
149
    #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
150
    ;; on some implementations only
151
152
    asdf/bundle:bundle-system
    asdf/bundle:static-library
153
154
155
156
    uiop/os:parse-file-location-info
    uiop/os:parse-windows-shortcut
    uiop/os:read-little-endian
    uiop/os:read-null-terminated-string
157
    ;; backward compatibility upgrade only
158
    asdf/backward-internals:make-sub-operation
159
160
    asdf/backward-interface:on-failure
    asdf/backward-interface:on-warnings
161
162
    asdf/find-system:contrib-sysdef-search
    asdf/find-system:sysdef-find-asdf
163
164
    ;; restart
    asdf/cache:reinitialize-source-registry-and-retry
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
    ))

(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))
190
191

(delete-package* :asdf-test-package-1)
192
193
194
195
196
197

(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*)
198
199
200
201
202
203
204
205
(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))
206
207
208
209
210
(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")))
211
(DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories")
212
213
(let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/")))
      (directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/"))))
214
215
216
  (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")
217
218
(let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/")))
      (directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/"))))
219
220
221
222
  (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/")
223
224
         (subpathname *build-directory* "deleteme/a/b/d/")
         (subpathname *build-directory* "deleteme/a/b/e/"))))
225
226
227
228
229
230
231
232
233
(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"))))
234
235
236
237
238

#+(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)))
239
240
(assert-equal "abcd" (strcat "a" nil "bc" "d"))
(assert-equal "abcd" (reduce/strcat '("a" nil "bc" "d")))
241

242
(defparameter *last-char-code* (1- (or #+allegro excl:real-char-code-limit char-code-limit)))
243
244
245
(defparameter *last-char* (code-char *last-char-code*))
(defparameter *last-char-string* (string *last-char*))

246
247
#-non-base-chars-exist-p
(progn
248
  (assert (base-string-p (make-string 10 :element-type 'character :initial-element *last-char*)))
249
  (assert (typep *last-char* 'base-char)))
250
251

(defun basify (s) (coerce s 'base-string))
252
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
253
254

#+non-base-chars-exist-p
255
256
(progn
  (assert (not (base-string-p *last-char-string*)))
257
  (assert (not (base-string-p (make-string 10 :element-type 'character))))
258
  (assert (not (base-string-p (unbasify "abc"))))
259
  (assert (base-string-p (basify "abc")))
260
  (assert (base-string-p (strcat "a" nil #\b (unbasify "cd"))))
261
  (assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
262
  (assert (base-string-p (strcat (basify "ab") (basify "cd"))))
263
  (assert (not (base-string-p (strcat (basify "ab") #\c *last-char* (unbasify "d")))))
264
  (assert (base-string-p (strcat (basify "ab") #\c #\d))))
265

266
267
(or #+os-windows ;; Avoid C:\Users vs C:\users on SBCL.
    (equalp (namestring *test-directory*) (namestring (getcwd)))
268
    (assert-pathname-equal *test-directory* (getcwd)))
269

270
271
272
273
274
275
(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+))
276
277
278
279
280
281
282
283
284
285
286
287
(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)))

288
(DBG :wtf-s)
289
(with-temporary-file (:stream s :direction :io :prefix "LEP")
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
  (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))
309

310
311
312
313
314
315
316
317
318
319
320
321
(assert
 (not (probe-file
       (let ((s 'outer-s))
         (with-temporary-file (:stream s :pathname p :direction :io :prefix "LEP")
           (assert (open-stream-p s))
           (DBG :wsp s p (probe-file p))
           (println "Same thing with :close-stream" s)
           :close-stream
           (assert-equal s 'outer-s) ;; the stream s (1) has been closed and (2) is no longer in scope.
           (assert-equal (read-file-lines p) '("Same thing with :close-stream"))
           p)))))

322
323
324
325
326
327
328
329
330
331
332
333
(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)))
334
335

(DBG :optimization-settings)
336
#-(or ecl-bytecmp gcl mkcl)
337
338
339
340
341
342
343
344
(loop :with settings = (get-optimization-settings)
      :for i :from 0 :to 3 :do
        (with-optimization-settings (`((speed ,i) (space ,i) (safety ,i) (debug ,i)))
          (let ((s (get-optimization-settings)))
            (loop :for q :in '(speed space safety debug) :do
                  #+mkcl (DBG :os i q s (assoc q s))
                         (assert-equal i (second (assoc q s))))))
        (assert-equal (get-optimization-settings) settings))