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

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

Explicitly intialize *TMP-DIRECTORY* at compile and load time.

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