source: branches/1.1.x/test/lisp/abcl/jar-pathname.lisp

Last change on this file was 13934, checked in by Mark Evenson, 13 years ago

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