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

Last change on this file since 13326 was 13326, checked in by Mark Evenson, 11 years ago

Add tests for whitespace in pathname.

Refactor jar-pathname tests via LOAD-JAR-RELATIVE macro.

Use DEFPARAMETER rather than DEFVAR.

Add paths containing whitespace to local jar in preparation for
expanding the test suite to more failing cases.

*TMP-JAR_PATH* now contains the path to jar used for testing.

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