← Back to branch summary

~ubuntu-branches/ubuntu/trusty/cl-asdf/trusty

« back to all changes in this revision

Viewing changes to test/test-utilities.script

  • Committer: Package Import Robot
  • Author(s): Francois-Rene Rideau
  • Date: 2013-05-27 22:44:50 UTC
  • mfrom: (1.1.28)
  • Revision ID: package-import@ubuntu.com-20130527224450-4bddztgqi7q1uzn7
Tags: 2:3.0.1.2-1
ASDF 3.0.1.2 fixes issues with the debian package itself.
It also includes fixes to run-program and run-shell-command.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/test-utilities.script
1
1
;;; -*- Lisp -*-
2
 
(load "script-support.lisp")
3
 
(load-asdf)
4
 
 
5
 
(quit-on-error
6
2
 
7
3
(assert
8
4
 (every #'directory-pathname-p
9
5
  (list
10
 
   (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
11
 
   (make-pathname :name "" :directory '(:absolute "tmp"))
12
 
   (make-pathname :type "" :directory '(:absolute "tmp"))
 
6
   (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
 
7
   (make-pathname* :name "" :directory '(:absolute "tmp"))
 
8
   (make-pathname* :type "" :directory '(:absolute "tmp"))
13
9
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
14
10
;; and some implementations will enforce it.
15
 
;;   (make-pathname :type :unspecific :directory '(:absolute "tmp"))
16
 
;;   (make-pathname :name :unspecific :directory '(:absolute "tmp"))
17
 
;;   (make-pathname :name :unspecific :directory '(:absolute "tmp"))
18
 
   )))
 
11
   (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
 
12
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))
 
13
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
19
14
(assert
20
15
 (every (complement #'directory-pathname-p)
21
16
  (list
22
 
   (make-pathname :name "foo" :type nil :directory '(:absolute "tmp"))
23
 
   (make-pathname :name nil :type "bar" :directory '(:absolute "tmp")))))
24
 
;; These are funky and non portable. Omit from tests.
25
 
;; (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
26
 
;; (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
27
 
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t))
28
 
               '(:relative nil nil)))
29
 
(assert (equal (multiple-value-list (component-name-to-pathname-components ""  :force-directory nil))
30
 
               '(:relative nil nil)))
31
 
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory t))
32
 
               '(:absolute nil nil)))
33
 
(assert (equal (multiple-value-list (component-name-to-pathname-components "/" :force-directory nil))
34
 
               '(:absolute nil nil)))
35
 
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory t))
36
 
               '(:absolute ("aa" "ba") nil)))
37
 
(assert (equal (multiple-value-list (component-name-to-pathname-components "/aa/ba" :force-directory nil))
38
 
               '(:absolute ("aa") "ba")))
 
17
   (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
 
18
   (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
 
19
;; These are funky and non portable, omit from tests:
 
20
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
 
21
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
 
22
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :ensure-directory t))
 
23
               '(:relative nil nil nil)))
 
24
(assert (equal (multiple-value-list (split-unix-namestring-directory-components ""  :ensure-directory nil))
 
25
               '(:relative nil nil nil)))
 
26
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory t))
 
27
               '(:absolute nil nil nil)))
 
28
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory nil))
 
29
               '(:absolute nil nil nil)))
 
30
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory t))
 
31
               '(:absolute ("aa" "ba") nil nil)))
 
32
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory nil))
 
33
               '(:absolute ("aa") "ba" nil)))
39
34
(assert
40
35
 (version-satisfies (asdf-version) (asdf-version)))
41
36
(assert
42
 
 (version-satisfies (asdf-version) "2.000"))
 
37
 (version-satisfies (asdf-version) "3.0"))
 
38
(assert
 
39
 (version-satisfies (asdf-version) "2.0"))
 
40
(assert
 
41
 (version<= "2.0" (asdf-version)))
43
42
(assert
44
43
 (not (version-satisfies (asdf-version) "666")))
45
 
(assert
46
 
  (equal (asdf::split-pathnames* "foo:bar" nil nil "baz") '(#p"foo" #p"bar")))
47
 
(assert
48
 
  (equal (asdf::split-pathnames* "foo:bar" nil t "baz") '(#p"foo/" #p"bar/")))
49
 
(assert
50
 
  (equal (asdf::split-pathnames* "/foo:/bar" t nil "baz") '(#p"/foo" #p"/bar")))
51
 
(assert
52
 
  (equal (asdf::split-pathnames* "/foo:/bar" t t "baz") '(#p"/foo/" #p"/bar/")))
53
 
(assert (equal (mapcar 'asdf::location-function-p
54
 
                       '((:function f)
55
 
                         (:function (lambda (path absolute-source)
56
 
                                      (declare (ignore absolute-source))
57
 
                                      path))
58
 
                         (function previous-isnt-keyword)
59
 
                         (:function f too many arguments)
60
 
                         (:function (:lambda isnt lambda))
61
 
                         (:function (lambda (too many args) blah))))
62
 
               '(t t nil nil nil nil)))
63
 
)
 
44
(assert-pathnames-equal
 
45
 (split-native-pathnames-string "foo:bar")
 
46
 '(#p"foo" #p"bar"))
 
47
(assert-pathnames-equal
 
48
 (split-native-pathnames-string "foo:bar" :ensure-directory t)
 
49
 '(#p"foo/" #p"bar/"))
 
50
(assert-pathnames-equal
 
51
 (split-native-pathnames-string "/foo:/bar" :want-absolute t)
 
52
 '(#p"/foo" #p"/bar"))
 
53
(assert-pathnames-equal
 
54
 (split-native-pathnames-string "/foo:/bar" :want-absolute t :ensure-directory t)
 
55
 '(#p"/foo/" #p"/bar/"))
 
56
(assert-equal
 
57
 (mapcar 'location-function-p
 
58
         '((:function f)
 
59
           (:function (lambda (path absolute-source)
 
60
                        (declare (ignore absolute-source))
 
61
                        path))
 
62
           (function previous-isnt-keyword)
 
63
           (:function f too many arguments)
 
64
           (:function (:lambda isnt lambda))
 
65
           (:function (lambda (too many args) blah))))
 
66
 '(t t nil nil nil nil))
 
67
 
 
68
(initialize-source-registry '())
 
69
 
 
70
#|
 
71
(unless (find-system :swank nil)
 
72
  (leave-test "Cannot find SWANK" 0))
 
73
 
 
74
(load-system :swank)
 
75
;;(setq swank-loader::*fasl-directory* (resolve-output "slime/"))
 
76
;;(ensure-directories-exist swank-loader::*fasl-directory*)
 
77
;;(DBG :foo swank-loader::*fasl-directory*)
 
78
(swank-loader:init)
 
79
|#
 
80
 
 
81
(defparameter *ok-symbols*
 
82
  '(;; slots names
 
83
    asdf/action:accept
 
84
    asdf/action:action
 
85
    asdf/action:done-p
 
86
    asdf/action:stamp
 
87
    asdf/bundle:prologue-code
 
88
    asdf/bundle:build-args
 
89
    asdf/bundle:epilogue-code
 
90
    asdf/bundle:name-suffix
 
91
    asdf/component:absolute-pathname
 
92
    asdf/component:around-compile
 
93
    asdf/component:author
 
94
    asdf/component:children
 
95
    asdf/component:children-by-name
 
96
    asdf/component:components
 
97
    asdf/component:components-by-name
 
98
    asdf/component:default-component-class
 
99
    asdf/component:defsystem-depends-on
 
100
    asdf/component:description
 
101
    asdf/component:%encoding
 
102
    asdf/component:if-feature
 
103
    asdf/component:inline-methods
 
104
    asdf/component:in-order-to
 
105
    asdf/component:licence
 
106
    asdf/component:long-description
 
107
    asdf/component:maintainer
 
108
    asdf/component:name
 
109
    asdf/component:operation-times
 
110
    asdf/component:parent
 
111
    asdf/component:properties
 
112
    asdf/component:relative-pathname
 
113
    asdf/component:sideway-dependencies
 
114
    asdf/component:version
 
115
    asdf/lisp-action:flags
 
116
    asdf/operation:feature
 
117
    asdf/operation:original-initargs
 
118
    asdf/plan:index
 
119
    asdf/plan:forced
 
120
    asdf/plan:forced-not
 
121
    asdf/plan:planned-action-count
 
122
    asdf/plan:planned-output-action-count
 
123
    asdf/plan:planned-p
 
124
    asdf/plan:total-action-count
 
125
    asdf/plan:visited-actions
 
126
    asdf/plan:visiting-action-set
 
127
    asdf/plan:visiting-action-list
 
128
    asdf/system:bug-tracker
 
129
    asdf/system:build-pathname
 
130
    asdf/system:entry-point
 
131
    asdf/system:homepage
 
132
    asdf/system:long-name
 
133
    asdf/system:mailto
 
134
    asdf/system:source-control
 
135
    ;; restarts
 
136
    asdf/action:accept
 
137
    asdf/find-component:retry
 
138
    asdf/find-system:coerce-entry-to-directory
 
139
    asdf/find-system:remove-entry-from-registry
 
140
    asdf/lisp-action:try-recompiling
 
141
    ;; types
 
142
    asdf/bundle:user-system
 
143
    #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
 
144
    ;; on some implementations only
 
145
    asdf/bundle:bundle-system
 
146
    asdf/bundle:register-pre-built-system 
 
147
    asdf/bundle:static-library
 
148
    uiop/os:parse-file-location-info
 
149
    uiop/os:parse-windows-shortcut
 
150
    uiop/os:read-little-endian
 
151
    uiop/os:read-null-terminated-string
 
152
    ;; backward compatibility upgrade only
 
153
    asdf/backward-internals:make-sub-operation
 
154
    asdf/backward-interface:on-failure
 
155
    asdf/backward-interface:on-warnings
 
156
    asdf/find-system:contrib-sysdef-search
 
157
    asdf/find-system:sysdef-find-asdf
 
158
    ))
 
159
 
 
160
(defun defined-symbol-p (symbol)
 
161
  (or (boundp symbol)
 
162
      (fboundp symbol)
 
163
      (macro-function symbol)
 
164
      (find-class symbol nil)))
 
165
 
 
166
(defun fishy-exported-symbols (package &optional (ok-symbols *ok-symbols*))
 
167
  (loop :for symbol :being :the external-symbols :of package
 
168
        :unless (or
 
169
                 (defined-symbol-p symbol)
 
170
                 ;;(symbol-call :swank :classify-symbol symbol)
 
171
                 (member symbol ok-symbols))
 
172
          :collect symbol))
 
173
 
 
174
(defun fishy-asdf-exported-symbols ()
 
175
  (remove-duplicates
 
176
   (loop :for package :in (list-all-packages)
 
177
         :when (and (string-prefix-p "ASDF/" (package-name package))
 
178
                    (not (equal (package-name package) "ASDF/COMMON-LISP")))
 
179
           :nconc (fishy-exported-symbols package))
 
180
   :from-end t))
 
181
 
 
182
(assert-equal nil (fishy-asdf-exported-symbols))
 
183
 
 
184
(delete-package* :asdf-test-package-1)
 
185
 
 
186
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/c/"))
 
187
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/"))
 
188
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/"))
 
189
(register-directory *asdf-directory*)
 
190
(register-directory *uiop-directory*)
 
191
(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/1.x"))
 
192
(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/b/2"))
 
193
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))
 
194
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))
 
195
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
 
196
(assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))
 
197
(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
 
198
(delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/"))
 
199
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))))
 
200
(delete-directory-tree (subpathname *build-directory* "deleteme/")
 
201
                       :validate (lambda (x) (and (<= 5 (length (pathname-directory x)))
 
202
                                                  (subpathp x *build-directory*))))
 
203
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))))
 
204
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
 
205
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
 
206
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
 
207
 
 
208
#+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+)
 
209
#+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+))
 
210
 
 
211
(assert (base-string-p (make-string 10 :element-type 'base-char)))
 
212
(assert-equal "abcd" (strcat "a" nil "bc" "d"))
 
213
(assert-equal "abcd" (reduce/strcat '("a" nil "bc" "d")))
 
214
 
 
215
#-non-base-chars-exist-p
 
216
(progn
 
217
  (assert (base-string-p (make-string 10 :element-type 'character))))
 
218
 
 
219
(defun basify (s) (coerce s 'base-string))
 
220
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
 
221
 
 
222
#+non-base-chars-exist-p
 
223
(progn
 
224
  (assert (not (base-string-p (make-string 10 :element-type 'character))))
 
225
  (assert (not (base-string-p (unbasify "abc"))))
 
226
  (assert (base-string-p (basify "abc")))
 
227
  (assert (not (base-string-p (strcat "a" nil #\b (unbasify "cd")))))
 
228
  (assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
 
229
  (assert (base-string-p (strcat (basify "ab") (basify "cd"))))
 
230
  (assert (not (base-string-p (strcat (basify "ab") #\c (unbasify "d")))))
 
231
  (assert (base-string-p (strcat (basify "ab") #\c #\d))))