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

Last change on this file since 14612 was 14612, checked in by Mark Evenson, 8 years ago

Set a timeout on retrieval of JAR-PATHNAME objects from ZipCache?.

JDK 7(?) changed the default timeout for sockets to 0, which means
infinity, which is probably a bad idea when dealing with I/O on the
Inner-tubes.

Restore the failing tests in ABCL-TEST-LISP: the test suite bombs, but
not as catastrophically.

File size: 15.7 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.org/fasl/42/baz-20140105a-fasl-42.jar!/")
206;; fasl 41  "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20130403a.jar!/")
207
208(defmacro load-url-relative (path) 
209  `(load (probe-file (format nil "~A~A" *url-jar-pathname-base* ,path))))
210
211;;; wrapped in PROGN for easy disabling without a network connection
212;;; XXX come up with a better abstraction
213
214;; disable until fix loading fasls via HTTP
215(progn 
216  (deftest jar-pathname.load.http.1
217      (load-url-relative "foo")
218    t)
219
220  (deftest jar-pathname.load.http.2
221      (load-url-relative "bar")
222    t)
223
224  (deftest jar-pathname.load.http.3
225      (load-url-relative "bar.abcl")
226    t)
227
228  (deftest jar-pathname.load.http.4
229      (load-url-relative "eek")
230    t)
231
232  (deftest jar-pathname.load.http.5
233      (load-url-relative "eek.lisp")
234    t)
235
236  (deftest jar-pathname.load.http.6
237      (load-url-relative "a/b/foo")
238    t)
239
240  (deftest jar-pathname.load.http.7
241      (load-url-relative "a/b/bar")
242    t)
243
244  (deftest jar-pathname.load.http.8
245      (load-url-relative "a/b/bar.abcl")
246    t)
247
248  (deftest jar-pathname.load.http.9
249      (load-url-relative "a/b/eek")
250    t)
251
252  (deftest jar-pathname.load.http.10
253      (load-url-relative "a/b/eek.lisp")
254    t))
255
256(deftest jar-pathname.probe-file.1
257    (let ((result 
258           (with-jar-file-init
259               (probe-file "jar:file:baz.jar!/eek.lisp"))))
260      (string=
261       (if result (namestring result) "")
262       (format nil "jar:file:~Abaz.jar!/eek.lisp" 
263               (namestring *tmp-directory*))))
264  t)
265
266(deftest jar-pathname.probe-file.2
267    (let ((result 
268          (with-jar-file-init
269              (probe-file "jar:file:baz.jar!/a/b/bar.abcl"))))
270      (string=
271       (if result (namestring result) "")
272       (format nil "jar:file:~Abaz.jar!/a/b/bar.abcl" 
273               (namestring *tmp-directory*))))
274  t)
275
276(deftest jar-pathname.probe-file.3
277    (let ((result 
278          (with-jar-file-init
279              (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._"))))
280      (string=
281       (if result (namestring result) "")
282       (format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._" 
283               (namestring *tmp-directory*))))
284  t)
285
286
287(push 'jar-pathname.probe-file.4 *expected-failures*)
288(deftest jar-pathname.probe-file.4
289    (let ((result 
290          (with-jar-file-init
291              (probe-file "jar:file:baz.jar!/a/b"))))
292      (string=
293       (if result (namestring result) "")
294       (format nil "jar:file:~Abaz.jar!/a/b/"
295               (namestring *tmp-directory*))))
296  t)
297
298(push 'jar-pathname.probe-file.5 *expected-failures*)
299(deftest jar-pathname.probe-file.5
300    (let ((result 
301          (with-jar-file-init
302              (probe-file "jar:file:baz.jar!/a/b/"))))
303      (string=
304       (if result (namestring result) "")
305       (format nil "jar:file:~Abaz.jar!/a/b/"
306               (namestring *tmp-directory*))))
307  t)
308
309
310(deftest jar-pathname.probe-file.6
311    (let ((result 
312          (with-jar-file-init
313              (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl"))))
314      (string=
315       (if result (namestring result) "")
316       (format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl"
317               (namestring *tmp-directory*))))
318  t)
319
320(deftest jar-pathname.merge-pathnames.1
321    (merge-pathnames 
322     "/bar.abcl" #p"jar:file:baz.jar!/foo")
323  #p"jar:file:baz.jar!/bar.abcl")
324
325(deftest jar-pathname.merge-pathnames.2
326    (merge-pathnames 
327     "bar.abcl" #p"jar:file:baz.jar!/foo/baz")
328  #p"jar:file:baz.jar!/foo/bar.abcl")
329
330(deftest jar-pathname.merge-pathnames.3
331    (merge-pathnames 
332     "jar:file:baz.jar!/foo" "bar")
333  #p"jar:file:baz.jar!/foo")
334
335(deftest jar-pathname.merge-pathnames.4
336    (merge-pathnames 
337     "jar:file:baz.jar!/foo" "/a/b/c")
338  #p"jar:file:/a/b/baz.jar!/foo")
339
340
341;;; Under win32, we get the device in the merged path
342#+windows 
343(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
344
345(deftest jar-pathname.merge-pathnames.5
346    (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
347  #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
348
349(deftest jar-pathname.truename.1
350    (signals-error (truename "jar:file:baz.jar!/foo")
351                   'file-error)
352  t)
353
354(deftest jar-pathname.1
355    (let* ((p #p"jar:file:foo/baz.jar!/")
356           (d (first (pathname-device p))))
357      (values
358       (pathname-directory d) (pathname-name d) (pathname-type d)))
359  (:relative "foo") "baz" "jar")
360
361(deftest jar-pathname.2
362    (let* ((p #p"jar:file:baz.jar!/foo.abcl")
363           (d (first (pathname-device p))))
364      (values
365       (pathname-name d) (pathname-type d) 
366       (pathname-directory p) (pathname-name p) (pathname-type p)))
367  "baz" "jar"
368   (:absolute) "foo" "abcl")
369   
370(deftest jar-pathname.3
371    (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/")
372           (d0 (first (pathname-device p)))
373           (d1 (second (pathname-device p))))
374      (values 
375       (pathname-name d0) (pathname-type d0)
376       (pathname-name d1) (pathname-type d1)))
377  "baz" "jar"
378  "foo" "abcl")
379
380(deftest jar-pathname.4
381    (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls")
382           (d0 (first (pathname-device p)))
383           (d1 (second (pathname-device p))))
384      (values 
385       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
386       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
387       (pathname-directory p) (pathname-name p) (pathname-type p)))
388  (:relative "a") "baz" "jar"
389  (:relative "b" "c") "foo" "abcl"
390  (:absolute "this" "that") "foo-20" "cls")
391
392(deftest jar-pathname.5
393    (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls")
394           (d0 (first (pathname-device p)))
395           (d1 (second (pathname-device p))))
396      (values 
397       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
398       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
399       (pathname-directory p) (pathname-name p) (pathname-type p)))
400  (:relative "a" "foo" ) "baz" "jar"
401  (:relative "b" "c") "foo" "abcl"
402  (:absolute "armed" "bear") "bar-1" "cls")
403
404(deftest jar-pathname.6
405    (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
406           (d (first (pathname-device p))))
407      (values 
408       (ext:pathname-url-p d)
409       (namestring d)
410       (pathname-directory p) (pathname-name p) (pathname-type p)))
411  t
412  "http://example.org/abcl.jar" 
413  (:absolute "org" "armedbear" "lisp") "Version" "class")
414
415(deftest jar-pathname.7
416    (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls")
417           (d (pathname-device p))
418           (d0 (first d))
419           (d1 (second d)))
420      (values
421       (ext:pathname-url-p d0)
422       (namestring d0)
423       (pathname-name d1) (pathname-type d1)
424       (pathname-name p) (pathname-type p)))
425  t
426  "http://example.org/abcl.jar"
427  "foo" "abcl"
428  "foo-1" "cls")
429
430(deftest jar-pathname.8
431    (let* ((p #p"jar:file:/a/b/foo.jar!/")
432           (d (first (pathname-device p))))
433      (values
434       (pathname-directory d) (pathname-name d) (pathname-type d)))
435  (:ABSOLUTE "a" "b") "foo" "jar")
436
437(deftest jar-pathname.9
438    (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp")
439           (d (first (pathname-device p))))
440      (values
441       (pathname-directory d) (pathname-name d) (pathname-type d)
442       (pathname-directory p) (pathname-name p) (pathname-type p)))
443  (:relative "a" "b") "foo" "jar"
444  (:absolute "c" "d") "foo" "lisp")
445
446;;; 'jar:file:' forms must be URI encoded, meaning whitespace is not allowed
447(deftest jar-pathname.10
448    (signals-error 
449     (let ((s "jar:file:/foo/bar/a space/that!/this"))
450       (equal s
451              (namestring (pathname s))))
452     'error)
453  t)
454
455(deftest jar-pathname.11
456    (let ((s (string-downcase "jar:file:/foo/bar/a%20space%3f/that!/this")))
457      (string= s
458               (string-downcase (namestring (pathname s)))))
459  t)
460
461;;; We allow jar-pathname to be contructed without a device to allow
462;;; MERGE-PATHNAMES to work, even though #p"file:" is illegal.
463(deftest jar-pathname.12
464    (string= (namestring (first (pathname-device #p"jar:file:!/foo.bar")))
465             "")
466  t)
467
468(deftest jar-pathname.match-p.1
469    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
470                      "jar:file:/**/*.jar!/**/*.asd")
471  t)
472
473(deftest jar-pathname.match-p.2
474    (pathname-match-p "/a/system/def.asd"
475                      "jar:file:/**/*.jar!/**/*.asd")
476  nil)
477
478(deftest jar-pathname.match-p.3
479    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
480                      "/**/*.asd")
481  nil)
482
483(deftest jar-pathname.translate.1
484    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
485      "jar:file:/**/*.jar!/**/*.*" 
486      "/foo/**/*.*")
487  #p"/foo/d/e/f.lisp")
488
489;;; ticket #181
490;;; TODO Make reasons for failure more clear
491(deftest jar-pathname.truename.1
492    (let* ((abcl 
493            (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname))
494           (jar-entry 
495            (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl))))
496           (jar-entry-dir 
497            (make-pathname :defaults jar-entry :name nil :type nil))
498           (defaults 
499            *default-pathname-defaults*))
500      (let ((*default-pathname-defaults* jar-entry-dir))
501        (not (probe-file (merge-pathnames jar-entry)))))
502  nil)
503 
Note: See TracBrowser for help on using the repository browser.