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

Last change on this file was 14627, checked in by Evenson Not Org, 5 years ago

(partially) restore CL:LOAD from jar files.

There is apparently a fair amount of "breakage" of cases that used to
load no longer working which seems due to the changes in the semantics
for finding the FASL init loader. The following tests are now broken
but no longer cause the JVM to crash: JAR-PATHNAME.LOAD.HTTP.1,
JAR-PATHNAME.LOAD.HTTP.2, JAR-PATHNAME.LOAD.HTTP.4,
JAR-PATHNAME.LOAD.HTTP.6, JAR-PATHNAME.LOAD.HTTP.7,
and JAR-PATHNAME.LOAD.HTTP.9. Need to follow this up in subsequent work.

Fixed the underlying HttpHead?.get() interface used to determine
whether to used a cache version. The custom HTTP HEAD code that was
working under Java 6 no longer worked on Java 7.

Added to HttpHead?.get() asynchronous java.lang.Throwable on a socket
timeout of 5000 ms.

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