source: trunk/abcl/test/lisp/abcl/jar-pathname.lisp @ 13313

Last change on this file since 13313 was 13313, checked in by Mark Evenson, 10 years ago

Use directory derived from java.io.File.createTempFile() to write tests.

*TMP-DIRECTORY* now names the location used by the JAR-PATHNAME tests
to create and load tests.

Move the forms to compile into special variables.

File size: 12.2 KB
Line 
1(in-package #:abcl.test.lisp)
2
3(defvar *jar-file-init* nil)
4
5(defparameter *tmp-directory*
6  (make-pathname 
7   :directory (append 
8               (pathname-directory (pathname
9                                    (java:jcall "getAbsolutePath" 
10                                                (java:jstatic "createTempFile" "java.io.File" 
11                                                              "jar" "tmp"))))
12               '("jar-pathname-tests"))))
13
14
15(defvar *foo.lisp*
16  `((defun foo ()
17      (labels ((output ()
18                 (format t "FOO here.")))
19        (output)))))
20
21(defvar *bar.lisp*
22  `((defvar *pathname* *load-pathname*)
23    (defvar *truename* *load-truename*)
24
25    (defun bar () 
26      (labels 
27          ((output () 
28             (format t "Some BAR~%*load-pathname* ~S~%*load-truename* ~S~%"
29                     *pathname* *truename*)))
30        (output)))
31    (defvar *bar* t)
32
33    (defun baz ()
34      (format t "Some BAZ"))))
35
36(defvar *eek.lisp* 
37  `((defun eek ()
38      (format t "Another EEK."))
39    (defun ook ()
40      (let ((*load-verbose* t))
41        (load (merge-pathnames #p"bar" *load-truename*))))
42    (defun aak ()
43      (format t "*LOAD-TRUENAME* is '~A'" *load-truename*))))
44
45(defun write-forms (forms path)
46  (with-open-file (s path :direction :output :if-exists :supersede)
47    (with-standard-io-syntax
48      (dolist (form forms)
49        (print form s)))))
50
51(defun jar-file-init ()
52  (format t "~&Using ~A to create files for testing jar-pathnames.~%" *tmp-directory*)
53  (ensure-directories-exist *tmp-directory*)
54  (let* ((*default-pathname-defaults*  *tmp-directory*)
55         (asdf::*verbose-out* *standard-output*))
56    (write-forms *foo.lisp* "foo.lisp")
57    (compile-file "foo.lisp")
58    (write-forms *bar.lisp* "bar.lisp")
59    (compile-file "bar.lisp")
60    (write-forms *eek.lisp* "eek.lisp")
61    (compile-file "eek.lisp")
62    (let* ((tmpdir (merge-pathnames "tmp/" *tmp-directory*))
63           (subdirs 
64            (mapcar (lambda (p) (merge-pathnames p tmpdir))
65                    '("a/b/" "d/e+f/")))
66           (sub1 (first subdirs))
67           (sub2 (second subdirs)))
68      (when (probe-directory tmpdir)
69        (delete-directory-and-files tmpdir))
70      (mapcar (lambda (p) (ensure-directories-exist p)) subdirs)
71      (sys:unzip (merge-pathnames "foo.abcl") tmpdir)
72      (sys:unzip (merge-pathnames "foo.abcl") sub1)
73      (cl-fad-copy-file (merge-pathnames "bar.abcl")
74                        (merge-pathnames "bar.abcl" tmpdir))
75      (cl-fad-copy-file (merge-pathnames "bar.abcl")
76                        (merge-pathnames "bar.abcl" sub1))
77      (cl-fad-copy-file (merge-pathnames "bar.abcl")
78                        (merge-pathnames "bar.abcl" sub2))
79      (cl-fad-copy-file (merge-pathnames "eek.lisp")
80                        (merge-pathnames "eek.lisp" tmpdir))
81      (cl-fad-copy-file (merge-pathnames "eek.lisp")
82                        (merge-pathnames "eek.lisp" sub1))
83      (sys:zip (merge-pathnames "baz.jar")
84               (loop :for p :in (list tmpdir sub1 sub2)
85                  :appending (directory (merge-pathnames "*" p)))
86               tmpdir)
87      #+nil (delete-directory-and-files dir)))
88  (setf *jar-file-init* t))
89
90(defmacro with-jar-file-init (&rest body)
91  `(let ((*default-pathname-defaults* *tmp-directory*))
92     (progn
93       (unless *jar-file-init*
94         (jar-file-init))
95       ,@body)))
96
97(deftest jar-pathname.load.1
98    (with-jar-file-init
99      (load "jar:file:baz.jar!/foo"))
100  t)
101
102(deftest jar-pathname.load.2
103    (with-jar-file-init
104      (load "jar:file:baz.jar!/bar"))
105  t)
106
107(deftest jar-pathname.load.3
108    (with-jar-file-init
109      (load "jar:file:baz.jar!/bar.abcl"))
110  t)
111
112(deftest jar-pathname.load.4
113    (with-jar-file-init
114      (load "jar:file:baz.jar!/eek"))
115  t)
116
117(deftest jar-pathname.load.5
118    (with-jar-file-init
119      (load "jar:file:baz.jar!/eek.lisp"))
120  t)
121
122(deftest jar-pathname.load.6
123    (with-jar-file-init
124      (load "jar:file:baz.jar!/a/b/foo"))
125  t)
126
127(deftest jar-pathname.load.7
128    (with-jar-file-init
129      (load "jar:file:baz.jar!/a/b/bar"))
130  t)
131
132(deftest jar-pathname.load.8
133    (with-jar-file-init
134      (load "jar:file:baz.jar!/a/b/bar.abcl"))
135  t)
136
137(deftest jar-pathname.load.9
138    (with-jar-file-init
139      (load "jar:file:baz.jar!/a/b/eek"))
140  t)
141
142(deftest jar-pathname.load.10
143    (with-jar-file-init
144      (load "jar:file:baz.jar!/a/b/eek.lisp"))
145  t)
146
147(deftest jar-pathname.load.11
148    (with-jar-file-init
149        (load "jar:file:baz.jar!/d/e+f/bar.abcl"))
150  t)
151
152;;; wrapped in PROGN for easy disabling without a network connection
153;;; XXX come up with a better abstraction
154
155(defvar *url-jar-pathname-base*
156  "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20101103a.jar!/")
157
158(defmacro load-url-relative (path) 
159  `(load (format nil "~A~A" *url-jar-pathname-base* ,path)))
160
161(progn 
162  (deftest jar-pathname.load.http.1
163      (load-url-relative "foo")
164    t)
165
166  (deftest jar-pathname.load.http.2
167      (load-url-relative "bar")
168    t)
169
170  (deftest jar-pathname.load.http.3
171      (load-url-relative "bar.abcl")
172    t)
173
174  (deftest jar-pathname.load.http.4
175      (load-url-relative "eek")
176    t)
177
178  (deftest jar-pathname.load.http.5
179      (load-url-relative "eek.lisp")
180    t)
181
182  (deftest jar-pathname.load.http.6
183      (load-url-relative "a/b/foo")
184    t)
185
186  (deftest jar-pathname.load.http.7
187      (load-url-relative "a/b/bar")
188    t)
189
190  (deftest jar-pathname.load.http.8
191      (load-url-relative "a/b/bar.abcl")
192    t)
193
194  (deftest jar-pathname.load.http.9
195      (load-url-relative "a/b/eek")
196    t)
197
198  (deftest jar-pathname.load.http.10
199      (load-url-relative "a/b/eek.lisp")
200    t))
201
202(deftest jar-pathname.probe-file.1
203    (with-jar-file-init
204        (probe-file "jar:file:baz.jar!/eek.lisp"))
205  #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" 
206              (namestring *abcl-test-directory*)))
207
208(deftest jar-pathname.probe-file.2
209    (with-jar-file-init
210        (probe-file "jar:file:baz.jar!/a/b/bar.abcl"))
211  #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl"
212              (namestring *tmp-directory*)))
213
214(deftest jar-pathname.probe-file.3
215    (with-jar-file-init
216        (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._"))
217   #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._"
218                       (namestring *tmp-directory*)))
219
220(push 'jar-pathname.probe-file.4 *expected-failures*)
221(deftest jar-pathname.probe-file.4
222    (with-jar-file-init
223        (probe-file "jar:file:baz.jar!/a/b"))
224  #p#.(format nil "jar:file:~Abaz.jar!/a/b/"
225                       (namestring *tmp-directory*)))
226
227(push 'jar-pathname.probe-file.5 *expected-failures*)
228(deftest jar-pathname.probe-file.5
229    (with-jar-file-init
230        (probe-file "jar:file:baz.jar!/a/b/"))
231  #p#.(format nil "jar:file:~Abaz.jar!/a/b/"
232                       (namestring *tmp-directory*)))
233
234(deftest jar-pathname.probe-file.6
235    (with-jar-file-init
236        (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl"))
237  #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl"
238                       (namestring *tmp-directory*)))
239
240(deftest jar-pathname.merge-pathnames.1
241    (merge-pathnames 
242     "/bar.abcl" #p"jar:file:baz.jar!/foo")
243  #p"jar:file:baz.jar!/bar.abcl")
244
245(deftest jar-pathname.merge-pathnames.2
246    (merge-pathnames 
247     "bar.abcl" #p"jar:file:baz.jar!/foo/")
248  #p"jar:file:baz.jar!/foo/bar.abcl")
249
250(deftest jar-pathname.merge-pathnames.3
251    (merge-pathnames 
252     "jar:file:baz.jar!/foo" "bar")
253  #p"jar:file:baz.jar!/foo")
254
255(deftest jar-pathname.merge-pathnames.4
256    (merge-pathnames 
257     "jar:file:baz.jar!/foo" "/a/b/c")
258  #p"jar:file:/a/b/baz.jar!/foo")
259
260
261;;; Under win32, we get the device in the merged path
262#+windows 
263(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
264
265(deftest jar-pathname.merge-pathnames.5
266    (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
267  #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
268
269(deftest jar-pathname.truename.1
270    (signals-error (truename "jar:file:baz.jar!/foo")
271                   'file-error)
272  t)
273
274(deftest jar-pathname.1
275    (let* ((p #p"jar:file:foo/baz.jar!/")
276           (d (first (pathname-device p))))
277      (values
278       (pathname-directory d) (pathname-name d) (pathname-type d)))
279  (:relative "foo") "baz" "jar")
280
281(deftest jar-pathname.2
282    (let* ((p #p"jar:file:baz.jar!/foo.abcl")
283           (d (first (pathname-device p))))
284      (values
285       (pathname-name d) (pathname-type d) 
286       (pathname-directory p) (pathname-name p) (pathname-type p)))
287  "baz" "jar"
288   (:absolute) "foo" "abcl")
289   
290(deftest jar-pathname.3
291    (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/")
292           (d0 (first (pathname-device p)))
293           (d1 (second (pathname-device p))))
294      (values 
295       (pathname-name d0) (pathname-type d0)
296       (pathname-name d1) (pathname-type d1)))
297  "baz" "jar"
298  "foo" "abcl")
299
300(deftest jar-pathname.4
301    (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls")
302           (d0 (first (pathname-device p)))
303           (d1 (second (pathname-device p))))
304      (values 
305       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
306       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
307       (pathname-directory p) (pathname-name p) (pathname-type p)))
308  (:relative "a") "baz" "jar"
309  (:relative "b" "c") "foo" "abcl"
310  (:absolute "this" "that") "foo-20" "cls")
311
312(deftest jar-pathname.5
313    (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls")
314           (d0 (first (pathname-device p)))
315           (d1 (second (pathname-device p))))
316      (values 
317       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
318       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
319       (pathname-directory p) (pathname-name p) (pathname-type p)))
320  (:relative "a" "foo" ) "baz" "jar"
321  (:relative "b" "c") "foo" "abcl"
322  (:absolute "armed" "bear") "bar-1" "cls")
323
324(deftest jar-pathname.6
325    (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
326           (d (first (pathname-device p))))
327      (values 
328       (ext:pathname-url-p d)
329       (namestring d)
330       (pathname-directory p) (pathname-name p) (pathname-type p)))
331  t
332  "http://example.org/abcl.jar" 
333  (:absolute "org" "armedbear" "lisp") "Version" "class")
334
335(deftest jar-pathname.7
336    (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls")
337           (d (pathname-device p))
338           (d0 (first d))
339           (d1 (second d)))
340      (values
341       (ext:pathname-url-p d0)
342       (namestring d0)
343       (pathname-name d1) (pathname-type d1)
344       (pathname-name p) (pathname-type p)))
345  t
346  "http://example.org/abcl.jar"
347  "foo" "abcl"
348  "foo-1" "cls")
349
350(deftest jar-pathname.8
351    (let* ((p #p"jar:file:/a/b/foo.jar!/")
352           (d (first (pathname-device p))))
353      (values
354       (pathname-directory d) (pathname-name d) (pathname-type d)))
355  (:ABSOLUTE "a" "b") "foo" "jar")
356
357(deftest jar-pathname.9
358    (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp")
359           (d (first (pathname-device p))))
360      (values
361       (pathname-directory d) (pathname-name d) (pathname-type d)
362       (pathname-directory p) (pathname-name p) (pathname-type p)))
363  (:relative "a" "b") "foo" "jar"
364  (:absolute "c" "d") "foo" "lisp")
365
366;;; 'jar:file:' forms must be URI encoded, meaning whitespace is not allowed
367(deftest jar-pathname.10
368    (signals-error 
369     (let ((s "jar:file:/foo/bar/a space/that!/this"))
370       (equal s
371              (namestring (pathname s))))
372     'file-error)
373  t)
374
375(deftest jar-pathname.11
376    (let ((s "jar:file:/foo/bar/a%20space%3f/that!/this"))
377      (string= s
378             (namestring (pathname s))))
379  t)
380
381;;; We allow jar-pathname to be contructed without a device to allow
382;;; MERGE-PATHNAMES to work, even though #p"file:" is illegal.
383(deftest jar-pathname.12
384    (string= (namestring (first (pathname-device #p"jar:file:!/foo.bar")))
385             "")
386  t)
387
388(deftest jar-pathname.match-p.1
389    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
390                      "jar:file:/**/*.jar!/**/*.asd")
391  t)
392
393(deftest jar-pathname.match-p.2
394    (pathname-match-p "/a/system/def.asd"
395                      "jar:file:/**/*.jar!/**/*.asd")
396  nil)
397
398(deftest jar-pathname.match-p.3
399    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
400                      "/**/*.asd")
401  nil)
402
403(deftest jar-pathname.translate.1
404    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
405      "jar:file:/**/*.jar!/**/*.*" 
406      "/foo/**/*.*")
407  #p"/foo/d/e/f.lisp")
408
409     
410
411       
412
413 
Note: See TracBrowser for help on using the repository browser.