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

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

Fix problems with whitespace in JAR-PATHNAME.

For dealing with URI Encoding (also known as [Percent Encoding]() we
implement the following rules which were implicitly.

[Percent Encoding]: http://en.wikipedia.org/wiki/Percent-encoding

  1. All pathname components are represented "as is" without escaping.
  1. Namestrings are suitably escaped if the Pathname is a URL-PATHNAME

or a JAR-PATHNAME.

  1. Namestrings should all "round-trip":

(when (typep p 'pathname)

(equal (namestring p)

(namestring (pathname p))))

Users may use EXT:URI-ENCODE and EXT:URI-DECODE to access the escaping
rules in circumstances where they wish to manipulate PATHNAME
namestrings more directly.

All tests in JAR-PATHNAMES now pass.

Constructors for PATHNAME now produce ERROR rather than FILE-ERROR as
CLHS says "The type file-error consists of error conditions that occur
during an attempt to open or close a file, or during some low-level
transactions with a file system," which doesn't apply here.

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