source: branches/0.23.x/abcl/test/lisp/abcl/jar-pathname.lisp @ 13033

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

[ticket #110][backport r13024,r13026] Fix #\+ in JAR pathnames.

File size: 11.6 KB
Line 
1(in-package #:abcl.test.lisp)
2
3(defvar *jar-file-init* nil)
4
5;;; From CL-FAD
6(defvar *stream-buffer-size* 8192)
7(defun cl-fad-copy-stream (from to &optional (checkp t))
8  "Copies into TO \(a stream) from FROM \(also a stream) until the end
9of FROM is reached, in blocks of *stream-buffer-size*.  The streams
10should have the same element type.  If CHECKP is true, the streams are
11checked for compatibility of their types."
12  (when checkp
13    (unless (subtypep (stream-element-type to) (stream-element-type from))
14      (error "Incompatible streams ~A and ~A." from to)))
15  (let ((buf (make-array *stream-buffer-size*
16                         :element-type (stream-element-type from))))
17    (loop
18     (let ((pos (read-sequence buf from)))
19       (when (zerop pos) (return))
20       (write-sequence buf to :end pos))))
21  (values))
22
23(defun cl-fad-copy-file (from to &key overwrite)
24  "Copies the file designated by the non-wild pathname designator FROM
25to the file designated by the non-wild pathname designator TO.  If
26OVERWRITE is true overwrites the file designtated by TO if it exists."
27  (let ((element-type '(unsigned-byte 8)))
28    (with-open-file (in from :element-type element-type)
29      (with-open-file (out to :element-type element-type
30                              :direction :output
31                              :if-exists (if overwrite
32                                           :supersede :error))
33        (cl-fad-copy-stream in out))))
34  (values))
35
36(defun jar-file-init ()
37  (let* ((*default-pathname-defaults*  *abcl-test-directory*)
38         (asdf::*verbose-out* *standard-output*))
39    (compile-file "foo.lisp")
40    (compile-file "bar.lisp")
41    (compile-file "eek.lisp")
42    (let* ((tmpdir (merge-pathnames "tmp/" *abcl-test-directory*))
43           (subdirs 
44            (mapcar (lambda (p) (merge-pathnames p tmpdir))
45                    '("a/b/" "d/e+f/")))
46           (sub1 (first subdirs))
47           (sub2 (second subdirs)))
48      (when (probe-directory tmpdir)
49        (delete-directory-and-files tmpdir))
50      (mapcar (lambda (p) (ensure-directories-exist p)) subdirs)
51      (sys:unzip (merge-pathnames "foo.abcl") tmpdir)
52      (sys:unzip (merge-pathnames "foo.abcl") sub1)
53      (cl-fad-copy-file (merge-pathnames "bar.abcl")
54                        (merge-pathnames "bar.abcl" tmpdir))
55      (cl-fad-copy-file (merge-pathnames "bar.abcl")
56                        (merge-pathnames "bar.abcl" sub1))
57      (cl-fad-copy-file (merge-pathnames "bar.abcl")
58                        (merge-pathnames "bar.abcl" sub2))
59      (cl-fad-copy-file (merge-pathnames "eek.lisp")
60                        (merge-pathnames "eek.lisp" tmpdir))
61      (cl-fad-copy-file (merge-pathnames "eek.lisp")
62                        (merge-pathnames "eek.lisp" sub1))
63      (sys:zip (merge-pathnames "baz.jar")
64               (loop :for p :in (list tmpdir sub1 sub2)
65                  :appending (directory (merge-pathnames "*" p)))
66               tmpdir)
67      #+nil (delete-directory-and-files dir)))
68  (setf *jar-file-init* t))
69
70(defmacro with-jar-file-init (&rest body)
71  `(let ((*default-pathname-defaults* *abcl-test-directory*))
72     (progn
73       (unless *jar-file-init*
74         (jar-file-init))
75       ,@body)))
76
77(deftest jar-pathname.load.1
78    (with-jar-file-init
79      (load "jar:file:baz.jar!/foo"))
80  t)
81
82(deftest jar-pathname.load.2
83    (with-jar-file-init
84      (load "jar:file:baz.jar!/bar"))
85  t)
86
87(deftest jar-pathname.load.3
88    (with-jar-file-init
89      (load "jar:file:baz.jar!/bar.abcl"))
90  t)
91
92(deftest jar-pathname.load.4
93    (with-jar-file-init
94      (load "jar:file:baz.jar!/eek"))
95  t)
96
97(deftest jar-pathname.load.5
98    (with-jar-file-init
99      (load "jar:file:baz.jar!/eek.lisp"))
100  t)
101
102(deftest jar-pathname.load.6
103    (with-jar-file-init
104      (load "jar:file:baz.jar!/a/b/foo"))
105  t)
106
107(deftest jar-pathname.load.7
108    (with-jar-file-init
109      (load "jar:file:baz.jar!/a/b/bar"))
110  t)
111
112(deftest jar-pathname.load.8
113    (with-jar-file-init
114      (load "jar:file:baz.jar!/a/b/bar.abcl"))
115  t)
116
117(deftest jar-pathname.load.9
118    (with-jar-file-init
119      (load "jar:file:baz.jar!/a/b/eek"))
120  t)
121
122(deftest jar-pathname.load.10
123    (with-jar-file-init
124      (load "jar:file:baz.jar!/a/b/eek.lisp"))
125  t)
126
127(deftest jar-pathname.load.11
128    (with-jar-file-init
129        (load "jar:file:baz.jar!/d/e+f/bar.abcl"))
130  t)
131
132;;; wrapped in PROGN for easy disabling without a network connection
133;;; XXX come up with a better abstraction
134
135(defvar *url-jar-pathname-base*
136  "jar:http://abcl-dynamic-install.googlecode.com/files/baz-20100505a.jar!/")
137
138(defmacro load-url-relative (path) 
139  `(load (format nil "~A~A" *url-jar-pathname-base* ,path)))
140
141(progn 
142  (deftest jar-pathname.load.http.1
143      (load-url-relative "foo")
144    t)
145
146  (deftest jar-pathname.load.http.2
147      (load-url-relative "bar")
148    t)
149
150  (deftest jar-pathname.load.http.3
151      (load-url-relative "bar.abcl")
152    t)
153
154  (deftest jar-pathname.load.http.4
155      (load-url-relative "eek")
156    t)
157
158  (deftest jar-pathname.load.http.5
159      (load-url-relative "eek.lisp")
160    t)
161
162  (deftest jar-pathname.load.http.6
163      (load-url-relative "a/b/foo")
164    t)
165
166  (deftest jar-pathname.load.http.7
167      (load-url-relative "a/b/bar")
168    t)
169
170  (deftest jar-pathname.load.http.8
171      (load-url-relative "a/b/bar.abcl")
172    t)
173
174  (deftest jar-pathname.load.http.9
175      (load-url-relative "a/b/eek")
176    t)
177
178  (deftest jar-pathname.load.http.10
179      (load-url-relative "a/b/eek.lisp")
180    t))
181
182(deftest jar-pathname.probe-file.1
183    (with-jar-file-init
184        (probe-file "jar:file:baz.jar!/eek.lisp"))
185  #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" 
186              (namestring *abcl-test-directory*)))
187
188(deftest jar-pathname.probe-file.2
189    (with-jar-file-init
190        (probe-file "jar:file:baz.jar!/a/b/bar.abcl"))
191  #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl"
192              (namestring *abcl-test-directory*)))
193
194(deftest jar-pathname.probe-file.3
195    (with-jar-file-init
196        (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._"))
197   #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._"
198                       (namestring *abcl-test-directory*)))
199
200(deftest jar-pathname.probe-file.4
201    (with-jar-file-init
202        (probe-file "jar:file:baz.jar!/a/b"))
203  #p#.(format nil "jar:file:~Abaz.jar!/a/b/"
204                       (namestring *abcl-test-directory*)))
205
206(deftest jar-pathname.probe-file.5
207    (with-jar-file-init
208        (probe-file "jar:file:baz.jar!/a/b/"))
209  #p#.(format nil "jar:file:~Abaz.jar!/a/b/"
210                       (namestring *abcl-test-directory*)))
211
212(deftest jar-pathname.probe-file.6
213    (with-jar-file-init
214        (probe-file "jar:file:baz.jar!/d/e+f/bar.abcl"))
215  #p#.(format nil "jar:file:~Abaz.jar!/d/e+f/bar.abcl"
216                       (namestring *abcl-test-directory*)))
217
218(deftest jar-pathname.merge-pathnames.1
219    (merge-pathnames 
220     "/bar.abcl" #p"jar:file:baz.jar!/foo")
221  #p"jar:file:baz.jar!/bar.abcl")
222
223(deftest jar-pathname.merge-pathnames.2
224    (merge-pathnames 
225     "bar.abcl" #p"jar:file:baz.jar!/foo/")
226  #p"jar:file:baz.jar!/foo/bar.abcl")
227
228(deftest jar-pathname.merge-pathnames.3
229    (merge-pathnames 
230     "jar:file:baz.jar!/foo" "bar")
231  #p"jar:file:baz.jar!/foo")
232
233(deftest jar-pathname.merge-pathnames.4
234    (merge-pathnames 
235     "jar:file:baz.jar!/foo" "/a/b/c")
236  #p"jar:file:/a/b/baz.jar!/foo")
237
238
239;;; Under win32, we get the device in the merged path
240#+windows 
241(push 'jar-pathname.merge-pathnames.5 *expected-failures*)
242
243(deftest jar-pathname.merge-pathnames.5
244    (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
245  #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
246
247(deftest jar-pathname.truename.1
248    (signals-error (truename "jar:file:baz.jar!/foo")
249                   'file-error)
250  t)
251
252(deftest jar-pathname.1
253    (let* ((p #p"jar:file:foo/baz.jar!/")
254           (d (first (pathname-device p))))
255      (values
256       (pathname-directory d) (pathname-name d) (pathname-type d)))
257  (:relative "foo") "baz" "jar")
258
259(deftest jar-pathname.2
260    (let* ((p #p"jar:file:baz.jar!/foo.abcl")
261           (d (first (pathname-device p))))
262      (values
263       (pathname-name d) (pathname-type d) 
264       (pathname-directory p) (pathname-name p) (pathname-type p)))
265  "baz" "jar"
266   (:absolute) "foo" "abcl")
267   
268(deftest jar-pathname.3
269    (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/")
270           (d0 (first (pathname-device p)))
271           (d1 (second (pathname-device p))))
272      (values 
273       (pathname-name d0) (pathname-type d0)
274       (pathname-name d1) (pathname-type d1)))
275  "baz" "jar"
276  "foo" "abcl")
277
278(deftest jar-pathname.4
279    (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls")
280           (d0 (first (pathname-device p)))
281           (d1 (second (pathname-device p))))
282      (values 
283       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
284       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
285       (pathname-directory p) (pathname-name p) (pathname-type p)))
286  (:relative "a") "baz" "jar"
287  (:relative "b" "c") "foo" "abcl"
288  (:absolute "this" "that") "foo-20" "cls")
289
290(deftest jar-pathname.5
291    (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls")
292           (d0 (first (pathname-device p)))
293           (d1 (second (pathname-device p))))
294      (values 
295       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
296       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
297       (pathname-directory p) (pathname-name p) (pathname-type p)))
298  (:relative "a" "foo" ) "baz" "jar"
299  (:relative "b" "c") "foo" "abcl"
300  (:absolute "armed" "bear") "bar-1" "cls")
301
302(deftest jar-pathname.6
303    (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
304           (d (first (pathname-device p))))
305      (values 
306       (ext:pathname-url-p d)
307       (namestring d)
308       (pathname-directory p) (pathname-name p) (pathname-type p)))
309  t
310  "http://example.org/abcl.jar" 
311  (:absolute "org" "armedbear" "lisp") "Version" "class")
312
313(deftest jar-pathname.7
314    (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls")
315           (d (pathname-device p))
316           (d0 (first d))
317           (d1 (second d)))
318      (values
319       (ext:pathname-url-p d0)
320       (namestring d0)
321       (pathname-name d1) (pathname-type d1)
322       (pathname-name p) (pathname-type p)))
323  t
324  "http://example.org/abcl.jar"
325  "foo" "abcl"
326  "foo-1" "cls")
327
328(deftest jar-pathname.8
329    (let* ((p #p"jar:file:/a/b/foo.jar!/")
330           (d (first (pathname-device p))))
331      (values
332       (pathname-directory d) (pathname-name d) (pathname-type d)))
333  (:ABSOLUTE "a" "b") "foo" "jar")
334
335(deftest jar-pathname.9
336    (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp")
337           (d (first (pathname-device p))))
338      (values
339       (pathname-directory d) (pathname-name d) (pathname-type d)
340       (pathname-directory p) (pathname-name p) (pathname-type p)))
341  (:relative "a" "b") "foo" "jar"
342  (:absolute "c" "d") "foo" "lisp")
343
344(deftest jar-pathname.10
345    (let ((s "jar:file:/foo/bar/a space/that!/this"))
346      (equal s
347             (namestring (pathname s))))
348  t)
349
350(deftest jar-pathname.11
351    (let ((s "jar:file:/foo/bar/a+space/that!/this"))
352      (equal s
353             (namestring (pathname s))))
354  t)
355
356
357(deftest jar-pathname.match-p.1
358    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
359                      "jar:file:/**/*.jar!/**/*.asd")
360  t)
361
362(deftest jar-pathname.match-p.2
363    (pathname-match-p "/a/system/def.asd"
364                      "jar:file:/**/*.jar!/**/*.asd")
365  nil)
366
367(deftest jar-pathname.match-p.3
368    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
369                      "/**/*.asd")
370  nil)
371
372(deftest jar-pathname.translate.1
373    (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
374      "jar:file:/**/*.jar!/**/*.*" 
375      "/foo/**/*.*")
376  #p"/foo/d/e/f.lisp")
377
378     
379
380       
381
382 
Note: See TracBrowser for help on using the repository browser.