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

Last change on this file was 15441, checked in by Mark Evenson, 3 years ago

Able to load from directories with whitespace
File size: 15.1 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* :overwrite t)))
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  (load (merge-jar-entry jar entry)))
126
127(defun merge-jar-entry (jar entry)
128  (let ((jar-pathname (if (ext:pathname-jar-p jar)
129                          jar
130                          (make-pathname :device (list jar)))))
131    (merge-pathnames entry jar-pathname)))
132
133
134(deftest jar-pathname.load.2
135  (with-jar-file-init
136      (load-from-jar *tmp-jar-path* "bar"))
137  t)
138
139(deftest jar-pathname.load.3
140  (with-jar-file-init
141      (load-from-jar *tmp-jar-path* "bar.abcl"))
142  t)
143
144(deftest jar-pathname.load.4
145  (with-jar-file-init
146      (load-from-jar *tmp-jar-path* "eek"))
147  t)
148
149(deftest jar-pathname.load.5
150  (with-jar-file-init
151      (load-from-jar *tmp-jar-path* "eek.lisp"))
152  t)
153
154(deftest jar-pathname.load.6
155  (signals-error 
156   (load-from-jar *tmp-jar-path* "this doesn't exist")
157   'file-error)
158  t)
159
160(deftest jar-pathname.load.7
161  (with-jar-file-init
162      (load-from-jar *tmp-jar-path* "a/b/bar"))
163  t)
164
165(deftest jar-pathname.load.8
166  (with-jar-file-init
167      (load-from-jar *tmp-jar-path* "a/b/bar.abcl"))
168  t)
169
170(deftest jar-pathname.load.9
171  (with-jar-file-init
172      (load-from-jar *tmp-jar-path* "a/b/eek"))
173  t)
174
175(deftest jar-pathname.load.10
176  (with-jar-file-init
177      (load-from-jar *tmp-jar-path* "a/b/eek.lisp"))
178  t)
179
180(deftest jar-pathname.load.11
181  (with-jar-file-init
182      (load-from-jar *tmp-jar-path* "d/e+f/bar.abcl"))
183  t)
184
185 
186  #+(or) ;; URI encodings in namestring are not currently interpolated
187(deftest jar-pathname.load.12
188    (with-jar-file-init
189        (load-from-jar *tmp-jar-path* "a/b/foo%20bar.abcl"))
190  t)
191
192(deftest jar-pathname.load.13
193    (with-jar-file-init 
194        (load-from-jar *tmp-jar-path* "a/b/foo bar.abcl"))
195  t)
196
197#+(or) ;; URI encodings in namestring are not currently interpolated
198(deftest jar-pathname.load.14
199    (with-jar-file-init
200  (load-from-jar *tmp-jar-path-whitespace* "a/b/bar.abcl")) 
201  t)
202#+(or) ;; URI encodings in namestring are not currently interpolated
203(deftest jar-pathname.load.15
204    (load-from-jar *tmp-jar-path-whitespace* "a/b/foo bar.abcl") 
205  t)
206
207  #+(or) ;; URI encodings in namestring are not currently interpolated
208(deftest jar-pathname.load.16
209    (load-from-jar *tmp-jar-path-whitespace* "a/b/foo%20bar.abcl")
210  t)
211
212(defparameter *url-jar-pathname-base*
213  #p"jar:https://abcl.org/releases/1.7.1/abcl-contrib.jar!/")
214
215(deftest jar-pathname.url.https.1
216    (equalp
217     *url-jar-pathname-base*
218     (probe-file *url-jar-pathname-base*))
219  t)
220
221(deftest jar-pathname.url.https.2
222     (namestring (merge-pathnames "**" "jar:https://abcl.org/releases/1.7.1/abcl-contrib.jar!/"))
223  "jar:https://abcl.org/releases/1.7.1/abcl-contrib.jar!/**")
224
225(deftest jar-pathname.url.https.3
226    (not (null (probe-file #p"jar:https://abcl.org/releases/1.7.1/abcl-contrib.jar!/README.markdown")))
227  t)
228
229(deftest jar-pathname.url.https.4
230    (< 1 (length (directory #p"jar:https://abcl.org/releases/1.7.1/abcl-contrib.jar!/**/")))
231  t)
232   
233(deftest jar-pathname.probe-file.1
234    (with-jar-file-init
235        (let ((p (merge-jar-entry  *tmp-jar-path* "eek.lisp")))
236          (not (null (probe-file p)))))
237  t)
238
239(deftest jar-pathname.probe-file.2
240  (with-jar-file-init
241      (let ((p (merge-jar-entry *tmp-jar-path* "a/b/bar.abcl")))
242        (not (null (probe-file p)))))
243  t)
244
245(deftest jar-pathname.probe-file.3
246    (with-jar-file-init
247        (let ((p (make-pathname :device (list (pathname *tmp-jar-path*) #p"a/b/bar.abcl")
248                                :directory '(:absolute)
249                                :name "bar_1"
250                                :type "cls")))
251          (not (null (probe-file p)))))
252  t)
253
254(deftest jar-pathname.probe-file.4
255    (with-jar-file-init
256        (let ((p (merge-jar-entry *tmp-jar-path* "a/b/bar.abcl")))
257          (not (null (probe-file p)))))
258  t)
259
260(deftest jar-pathname.probe-file.5
261  (with-jar-file-init
262      (let ((p (merge-jar-entry *tmp-jar-path* "a/b/" )))
263        (not (null (probe-file p)))))
264  t)
265
266(deftest jar-pathname.probe-file.6
267  (with-jar-file-init
268      (let ((p (merge-jar-entry *tmp-jar-path* "d/e+f/bar.abcl")))
269        (not (null (probe-file p)))))
270  t)
271
272(deftest jar-pathname.probe-file.7
273  (with-jar-file-init 
274      (not (null (probe-file (merge-jar-entry *tmp-jar-path* "__loader__._")))))
275  t)
276
277
278#+(or) ;; abcl-1.8.0 behavior is not to merge absolute pathname with JAR-PATHNAME defaults
279(deftest jar-pathname.merge-pathnames.1
280  (merge-pathnames "/bar.abcl" #p"jar:file:/baz.jar!/foo")
281  #p"jar:file:/baz.jar!/bar.abcl")
282
283(deftest jar-pathname.merge-pathnames.2
284  (namestring (merge-pathnames "bar.abcl" #p"jar:file:///baz.jar!/foo/baz"))
285  "jar:file:///baz.jar!/foo/bar.abcl")
286
287(deftest jar-pathname.merge-pathnames.3
288  (namestring (merge-pathnames "jar:file:///baz.jar!/foo" "bar"))
289  "jar:file:///baz.jar!/foo")
290
291(deftest jar-pathname.merge-pathnames.4
292    (namestring (merge-pathnames "jar:file:///baz.jar!/foo" "/a/b/c"))
293  "jar:file:///baz.jar!/foo")
294
295;;; Under win32, we get the device in the merged path
296#+windows 
297(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
298(deftest jar-pathname.merge-pathnames.5
299  (namestring (merge-pathnames "jar:file:///a/b/c/foo.jar!/bar/baz.lisp"))
300  "jar:file:///a/b/c/foo.jar!/bar/baz.lisp")
301
302(deftest jar-pathname.truename.1
303  (signals-error (truename "jar:file:baz.jar!/foo")
304                 'file-error)
305  t)
306
307(deftest jar-pathname.1
308    (let* ((p #p"jar:file:/foo/baz.jar!/")
309           (d (first (pathname-device p))))
310      (values
311       (pathname-directory d) (pathname-name d) (pathname-type d)))
312  (:absolute "foo") "baz" "jar")
313
314(deftest jar-pathname.2
315    (let* ((p #p"jar:file:baz.jar!/foo.abcl")
316           (d (first (pathname-device p))))
317      (values
318       (pathname-name d) (pathname-type d) 
319       (pathname-directory p) (pathname-name p) (pathname-type p)))
320  "baz" "jar"
321   (:absolute) "foo" "abcl")
322
323(deftest jar-pathname.3
324    (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/")
325           (d0 (first (pathname-device p)))
326           (d1 (second (pathname-device p))))
327      (values 
328       (pathname-name d0) (pathname-type d0)
329       (pathname-name d1) (pathname-type d1)))
330  "baz" "jar"
331  "foo" "abcl")
332
333(deftest jar-pathname.4
334    (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls")
335           (d0 (first (pathname-device p)))
336           (d1 (second (pathname-device p))))
337      (values 
338       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
339       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
340       (pathname-directory p) (pathname-name p) (pathname-type p)))
341  (:relative "a") "baz" "jar"
342  (:relative "b" "c") "foo" "abcl"
343  (:absolute "this" "that") "foo-20" "cls")
344
345(deftest jar-pathname.5
346    (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls")
347           (d0 (first (pathname-device p)))
348           (d1 (second (pathname-device p))))
349      (values 
350       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
351       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
352       (pathname-directory p) (pathname-name p) (pathname-type p)))
353  (:relative "a" "foo" ) "baz" "jar"
354  (:relative "b" "c") "foo" "abcl"
355  (:absolute "armed" "bear") "bar-1" "cls")
356
357(deftest jar-pathname.6
358    (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
359           (d (first (pathname-device p))))
360      (values 
361       (ext:pathname-url-p d)
362       (namestring d)
363       (pathname-directory p) (pathname-name p) (pathname-type p)))
364  t
365  "http://example.org/abcl.jar" 
366  (:absolute "org" "armedbear" "lisp") "Version" "class")
367
368(deftest jar-pathname.7
369    (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls")
370           (d (pathname-device p))
371           (d0 (first d))
372           (d1 (second d)))
373      (values
374       (ext:pathname-url-p d0)
375       (namestring d0)
376       (pathname-name d1) (pathname-type d1)
377       (pathname-name p) (pathname-type p)))
378  t
379  "http://example.org/abcl.jar"
380  "foo" "abcl"
381  "foo-1" "cls")
382
383(deftest jar-pathname.8
384    (let* ((p #p"jar:file:/a/b/foo.jar!/")
385           (d (first (pathname-device p))))
386      (values
387       (pathname-directory d) (pathname-name d) (pathname-type d)))
388  (:ABSOLUTE "a" "b") "foo" "jar")
389
390(deftest jar-pathname.9
391    (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp")
392           (d (first (pathname-device p))))
393      (values
394       (pathname-directory d) (pathname-name d) (pathname-type d)
395       (pathname-directory p) (pathname-name p) (pathname-type p)))
396  (:relative "a" "b") "foo" "jar"
397  (:absolute "c" "d") "foo" "lisp")
398
399;;; 'jar:file:' forms currently (abcl-1.8.0) can't be URI encoded, meaning whitespace is not allowed
400(deftest jar-pathname.10
401    (signals-error 
402     (let ((s "jar:file:/foo/bar/a space/that!/this"))
403       (equal s
404              (namestring (pathname s))))
405     'error)
406  t)
407
408#+(or) ;; URI escaping not returned
409(deftest jar-pathname.11
410    (let ((s (string-downcase "jar:file:///foo/bar/a%20space%3f/that!/this")))
411      (string= s
412               (string-downcase (namestring (pathname s)))))
413  t)
414
415;;; We allow jar-pathname to be contructed without a device to allow
416;;; MERGE-PATHNAMES to work, even though #p"file:" is illegal.
417#+(or)
418(deftest jar-pathname.12
419    (string= (namestring (first (pathname-device #p"jar:file:!/foo.bar")))
420             "")
421  t)
422
423(deftest jar-pathname.match-p.1
424    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
425                      "jar:file:/**/*.jar!/**/*.asd")
426  t)
427
428(deftest jar-pathname.match-p.2
429    (pathname-match-p "/a/system/def.asd"
430                      "jar:file:/**/*.jar!/**/*.asd")
431  nil)
432
433(deftest jar-pathname.match-p.3
434    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
435                      "/**/*.asd")
436  nil)
437
438(deftest jar-pathname.translate.1
439    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
440      "jar:file:/**/*.jar!/**/*.*" 
441      "/foo/**/*.*")
442  #p"/foo/d/e/f.lisp")
443
444;;; ticket #181
445;;; TODO Make reasons for failure more clear
446(deftest jar-pathname.truename.1
447    (let* ((abcl 
448            (slot-value (asdf:find-system 'abcl) 'asdf::absolute-pathname))
449           (jar-entry 
450            (pathname (format nil "jar:file:~A/dist/abcl-contrib.jar!/jss/jss.asd" (namestring abcl))))
451           (jar-entry-dir 
452            (make-pathname :defaults jar-entry :name nil :type nil))
453           (defaults 
454            *default-pathname-defaults*))
455      (let ((*default-pathname-defaults* jar-entry-dir))
456        (not (probe-file (merge-pathnames jar-entry)))))
457  nil)
458 
Note: See TracBrowser for help on using the repository browser.