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

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

Test for ticket #181 for failure somewhere in MERGE-PATHNAMES.

Probably related to underlying Pathname.truename() code from what I
could see in the JVM debugger.

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