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

Last change on this file since 15399 was 15399, checked in by Mark Evenson, 2 years ago

abcl/test/lisp: start towards correcting JAR-PATHNAME tests

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