close Warning: Failed to sync with repository "(default)": database is locked; repository information may be out of date. Look in the Trac log for more information including mitigation strategies.

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

Last change on this file since 12616 was 12616, checked in by Mark Evenson, 13 years ago

All URL/JAR tests now passing.

File size: 10.8 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* ((dir (merge-pathnames "tmp/" *abcl-test-directory*))
43           (sub (merge-pathnames "a/b/" dir)))
44      (when (probe-directory dir)
45        (delete-directory-and-files dir))
46      (ensure-directories-exist sub)
47      (sys:unzip (merge-pathnames "foo.abcl")
48                 dir)
49      (sys:unzip (merge-pathnames "foo.abcl")
50                 sub)
51      (cl-fad-copy-file (merge-pathnames "bar.abcl")
52                 (merge-pathnames "bar.abcl" dir))
53      (cl-fad-copy-file (merge-pathnames "bar.abcl")
54                 (merge-pathnames "bar.abcl" sub))
55      (cl-fad-copy-file (merge-pathnames "eek.lisp")
56                 (merge-pathnames "eek.lisp" dir))
57      (cl-fad-copy-file (merge-pathnames "eek.lisp")
58                 (merge-pathnames "eek.lisp" sub))
59      (sys:zip (merge-pathnames "baz.jar")
60               (append
61                (directory (merge-pathnames "*" dir))
62                (directory (merge-pathnames "*" sub)))
63               dir)
64      (delete-directory-and-files dir)))
65  (setf *jar-file-init* t))
66
67(defmacro with-jar-file-init (&rest body)
68  `(let ((*default-pathname-defaults* *abcl-test-directory*))
69     (progn
70       (unless *jar-file-init*
71         (jar-file-init))
72       ,@body)))
73
74(deftest jar-pathname.load.1
75    (with-jar-file-init
76      (load "jar:file:baz.jar!/foo"))
77  t)
78
79(deftest jar-pathname.load.2
80    (with-jar-file-init
81      (load "jar:file:baz.jar!/bar"))
82  t)
83
84(deftest jar-pathname.load.3
85    (with-jar-file-init
86      (load "jar:file:baz.jar!/bar.abcl"))
87  t)
88
89(deftest jar-pathname.load.4
90    (with-jar-file-init
91      (load "jar:file:baz.jar!/eek"))
92  t)
93
94(deftest jar-pathname.load.5
95    (with-jar-file-init
96      (load "jar:file:baz.jar!/eek.lisp"))
97  t)
98
99(deftest jar-pathname.load.6
100    (with-jar-file-init
101      (load "jar:file:baz.jar!/a/b/foo"))
102  t)
103
104(deftest jar-pathname.load.7
105    (with-jar-file-init
106      (load "jar:file:baz.jar!/a/b/bar"))
107  t)
108
109(deftest jar-pathname.load.8
110    (with-jar-file-init
111      (load "jar:file:baz.jar!/a/b/bar.abcl"))
112  t)
113
114(deftest jar-pathname.load.9
115    (with-jar-file-init
116      (load "jar:file:baz.jar!/a/b/eek"))
117  t)
118
119(deftest jar-pathname.load.10
120    (with-jar-file-init
121      (load "jar:file:baz.jar!/a/b/eek.lisp"))
122  t)
123
124;;; wrapped in PROGN for easy disabling without a network connection
125;;; XXX come up with a better abstraction
126
127(progn 
128  (deftest jar-pathname.load.11
129      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/foo")
130    t)
131
132  (deftest jar-pathname.load.12
133      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar")
134    t)
135
136  (deftest jar-pathname.load.13
137      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/bar.abcl")
138    t)
139
140  (deftest jar-pathname.load.14
141      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek")
142    t)
143
144  (deftest jar-pathname.load.15
145      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/eek.lisp")
146    t)
147
148  (deftest jar-pathname.load.16
149      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/foo")
150    t)
151
152  (deftest jar-pathname.load.17
153      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar")
154    t)
155
156  (deftest jar-pathname.load.18
157      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/bar.abcl")
158    t)
159
160  (deftest jar-pathname.load.19
161      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek")
162    t)
163
164  (deftest jar-pathname.load.20
165      (load "jar:http://abcl-dynamic-install.googlecode.com/files/baz.jar!/a/b/eek.lisp")
166    t))
167
168
169(deftest jar-pathname.probe-file.1
170    (with-jar-file-init
171        (probe-file "jar:file:baz.jar!/eek.lisp"))
172  #p#.(format nil "jar:file:~A/baz.jar!/eek.lisp" 
173              (namestring *abcl-test-directory*)))
174
175(deftest jar-pathname.probe-file.2
176    (with-jar-file-init
177        (probe-file "jar:file:baz.jar!/a/b/bar.abcl"))
178  #p#.(format nil "jar:file:~A/baz.jar!/a/b/bar.abcl"
179              (namestring *abcl-test-directory*)))
180
181(deftest jar-pathname.probe-file.3
182    (with-jar-file-init
183        (probe-file "jar:jar:file:baz.jar!/a/b/bar.abcl!/bar._"))
184   #p#.(format nil "jar:jar:file:~Abaz.jar!/a/b/bar.abcl!/bar._"
185                       (namestring *abcl-test-directory*)))
186
187(deftest jar-pathname.probe-file.4
188    (with-jar-file-init
189        (probe-file "jar:file:baz.jar!/a/b"))
190  nil)
191
192(deftest jar-pathname.probe-file.5
193    (with-jar-file-init
194        (probe-file "jar:file:baz.jar!/a/b/"))
195  #p#.(format nil "jar:file:~Abaz.jar!/a/b/"
196                       (namestring *abcl-test-directory*)))
197
198(deftest jar-pathname.merge-pathnames.1
199    (merge-pathnames 
200     "/bar.abcl" #p"jar:file:baz.jar!/foo")
201  #p"jar:file:baz.jar!/bar.abcl")
202
203(deftest jar-pathname.merge-pathnames.2
204    (merge-pathnames 
205     "bar.abcl" #p"jar:file:baz.jar!/foo/")
206  #p"jar:file:baz.jar!/foo/bar.abcl")
207
208(deftest jar-pathname.merge-pathnames.3
209    (merge-pathnames 
210     "jar:file:baz.jar!/foo" "bar")
211  #p"jar:file:baz.jar!/foo")
212
213(deftest jar-pathname.merge-pathnames.4
214    (merge-pathnames 
215     "jar:file:baz.jar!/foo" "/a/b/c")
216  #p"jar:file:/a/b/baz.jar!/foo")
217
218(deftest jar-pathname.merge-pathnames.5
219    (merge-pathnames "jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
220  #p"jar:file:/a/b/c/foo.jar!/bar/baz.lisp")
221
222(deftest jar-pathname.truename.1
223    (signals-error (truename "jar:file:baz.jar!/foo")
224                   'file-error)
225  t)
226
227(deftest jar-pathname.1
228    (let* ((p #p"jar:file:foo/baz.jar!/")
229           (d (first (pathname-device p))))
230      (values
231       (pathname-directory d) (pathname-name d) (pathname-type d)))
232  (:relative "foo") "baz" "jar")
233
234(deftest jar-pathname.2
235    (let* ((p #p"jar:file:baz.jar!/foo.abcl")
236           (d (first (pathname-device p))))
237      (values
238       (pathname-name d) (pathname-type d) 
239       (pathname-directory p) (pathname-name p) (pathname-type p)))
240  "baz" "jar"
241   (:absolute) "foo" "abcl")
242   
243(deftest jar-pathname.3
244    (let* ((p #p"jar:jar:file:baz.jar!/foo.abcl!/")
245           (d0 (first (pathname-device p)))
246           (d1 (second (pathname-device p))))
247      (values 
248       (pathname-name d0) (pathname-type d0)
249       (pathname-name d1) (pathname-type d1)))
250  "baz" "jar"
251  "foo" "abcl")
252
253(deftest jar-pathname.4
254    (let* ((p #p"jar:jar:file:a/baz.jar!/b/c/foo.abcl!/this/that/foo-20.cls")
255           (d0 (first (pathname-device p)))
256           (d1 (second (pathname-device p))))
257      (values 
258       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
259       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
260       (pathname-directory p) (pathname-name p) (pathname-type p)))
261  (:relative "a") "baz" "jar"
262  (:relative "b" "c") "foo" "abcl"
263  (:absolute "this" "that") "foo-20" "cls")
264
265(deftest jar-pathname.5
266    (let* ((p #p"jar:jar:file:a/foo/baz.jar!/b/c/foo.abcl!/armed/bear/bar-1.cls")
267           (d0 (first (pathname-device p)))
268           (d1 (second (pathname-device p))))
269      (values 
270       (pathname-directory d0) (pathname-name d0) (pathname-type d0)
271       (pathname-directory d1) (pathname-name d1) (pathname-type d1)
272       (pathname-directory p) (pathname-name p) (pathname-type p)))
273  (:relative "a" "foo" ) "baz" "jar"
274  (:relative "b" "c") "foo" "abcl"
275  (:absolute "armed" "bear") "bar-1" "cls")
276
277(deftest jar-pathname.6
278    (let* ((p #p"jar:http://example.org/abcl.jar!/org/armedbear/lisp/Version.class")
279           (d (first (pathname-device p))))
280      (values 
281       (system:pathname-url-p d)
282       (namestring d)
283       (pathname-directory p) (pathname-name p) (pathname-type p)))
284  t
285  "http://example.org/abcl.jar" 
286  (:absolute "org" "armedbear" "lisp") "Version" "class")
287
288(deftest jar-pathname.7
289    (let* ((p #p"jar:jar:http://example.org/abcl.jar!/foo.abcl!/foo-1.cls")
290           (d (pathname-device p))
291           (d0 (first d))
292           (d1 (second d)))
293      (values
294       (system:pathname-url-p d0)
295       (namestring d0)
296       (pathname-name d1) (pathname-type d1)
297       (pathname-name p) (pathname-type p)))
298  t
299  "http://example.org/abcl.jar"
300  "foo" "abcl"
301  "foo-1" "cls")
302
303(deftest jar-pathname.8
304    (let* ((p #p"jar:file:/a/b/foo.jar!/")
305           (d (first (pathname-device p))))
306      (values
307       (pathname-directory d) (pathname-name d) (pathname-type d)))
308  (:ABSOLUTE "a" "b") "foo" "jar")
309
310(deftest jar-pathname.9
311    (let* ((p #p"jar:file:a/b/foo.jar!/c/d/foo.lisp")
312           (d (first (pathname-device p))))
313      (values
314       (pathname-directory d) (pathname-name d) (pathname-type d)
315       (pathname-directory p) (pathname-name p) (pathname-type p)))
316  (:relative "a" "b") "foo" "jar"
317  (:absolute "c" "d") "foo" "lisp")
318
319(deftest jar-pathname.match-p.1
320    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
321                      "jar:file:/**/*.jar!/**/*.asd")
322  t)
323
324(deftest jar-pathname.match-p.2
325    (pathname-match-p "/a/system/def.asd"
326                      "jar:file:/**/*.jar!/**/*.asd")
327  nil)
328
329(deftest jar-pathname.match-p.3
330    (pathname-match-p "jar:file:/a/b/some.jar!/a/system/def.asd"
331                      "/**/*.asd")
332  nil)
333
334(deftest jar-pathname.translate.1
335    (namestring
336     (translate-pathname "jar:file:/a/b/c.jar!/d/e/f.lisp" 
337                         "jar:file:/**/*.jar!/**/*.*" 
338                         "/foo/**/*.*"))
339  "/foo/d/e/f.lisp")
340
341     
342
343       
344
345 
Note: See TracBrowser for help on using the repository browser.