1 | ;;; file-system-tests.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2005 Peter Graves |
---|
4 | ;;; |
---|
5 | ;;; This program is free software; you can redistribute it and/or |
---|
6 | ;;; modify it under the terms of the GNU General Public License |
---|
7 | ;;; as published by the Free Software Foundation; either version 2 |
---|
8 | ;;; of the License, or (at your option) any later version. |
---|
9 | ;;; |
---|
10 | ;;; This program is distributed in the hope that it will be useful, |
---|
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
13 | ;;; GNU General Public License for more details. |
---|
14 | ;;; |
---|
15 | ;;; You should have received a copy of the GNU General Public License |
---|
16 | ;;; along with this program; if not, write to the Free Software |
---|
17 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
18 | |
---|
19 | #+sbcl |
---|
20 | (require '#:sb-posix) |
---|
21 | |
---|
22 | (in-package #:abcl.test.lisp) |
---|
23 | |
---|
24 | (defparameter *this-file* |
---|
25 | (merge-pathnames (make-pathname :type "lisp") |
---|
26 | (if (find :asdf2 *features*) |
---|
27 | (merge-pathnames |
---|
28 | (make-pathname :name (pathname-name *load-truename*)) |
---|
29 | (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/")) |
---|
30 | *load-truename*))) |
---|
31 | |
---|
32 | (defparameter *this-directory* |
---|
33 | (if (find :asdf2 *features*) |
---|
34 | (asdf:system-relative-pathname :abcl-test-lisp "test/lisp/abcl/") |
---|
35 | (make-pathname :host (pathname-host *load-truename*) |
---|
36 | :device (pathname-device *load-truename*) |
---|
37 | :directory (pathname-directory *load-truename*)))) |
---|
38 | |
---|
39 | (defun pathnames-equal-p (pathname1 pathname2) |
---|
40 | #-(or allegro clisp cmu lispworks) |
---|
41 | (equal pathname1 pathname2) |
---|
42 | #+(or allegro clisp cmu) |
---|
43 | (and (pathnamep pathname1) |
---|
44 | (pathnamep pathname2) |
---|
45 | (equal (pathname-host pathname1) (pathname-host pathname2)) |
---|
46 | (equal (pathname-device pathname1) (pathname-device pathname2)) |
---|
47 | (equal (pathname-directory pathname1) (pathname-directory pathname2)) |
---|
48 | (equal (pathname-name pathname1) (pathname-name pathname2)) |
---|
49 | (equal (pathname-type pathname1) (pathname-type pathname2)) |
---|
50 | (or (equal (pathname-version pathname1) (pathname-version pathname2)) |
---|
51 | (and (member (pathname-version pathname1) '(:newest nil)) |
---|
52 | (member (pathname-version pathname2) '(:newest nil)) |
---|
53 | t))) |
---|
54 | #+lispworks |
---|
55 | (string= (namestring pathname1) (namestring pathname2))) |
---|
56 | |
---|
57 | #+abcl |
---|
58 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
59 | (ext:run-shell-command command :directory directory :output output)) |
---|
60 | |
---|
61 | #+allegro |
---|
62 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
63 | (excl:run-shell-command command :directory directory :input nil :output output)) |
---|
64 | |
---|
65 | #+clisp |
---|
66 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
67 | (declare (ignore output)) ;; FIXME |
---|
68 | (let (status old-directory) |
---|
69 | (when directory |
---|
70 | (setf old-directory (ext:cd)) |
---|
71 | (ext:cd directory)) |
---|
72 | (unwind-protect |
---|
73 | (setf status (ext:run-shell-command command)) |
---|
74 | (when old-directory |
---|
75 | (ext:cd old-directory))) |
---|
76 | (cond ((numberp status) |
---|
77 | status) |
---|
78 | ((eq status t) |
---|
79 | 0) |
---|
80 | (t |
---|
81 | -1)))) |
---|
82 | |
---|
83 | #+cmu |
---|
84 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
85 | (when directory |
---|
86 | (setf command (concatenate 'string |
---|
87 | "\\cd \"" |
---|
88 | (namestring (pathname directory)) |
---|
89 | "\" && " |
---|
90 | command))) |
---|
91 | (ext:process-exit-code |
---|
92 | (ext:run-program |
---|
93 | "/bin/sh" |
---|
94 | (list "-c" command) |
---|
95 | :input nil :output output))) |
---|
96 | |
---|
97 | #+sbcl |
---|
98 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
99 | (when directory |
---|
100 | (setf command (concatenate 'string |
---|
101 | "\\cd \"" |
---|
102 | (namestring (pathname directory)) |
---|
103 | "\" && " |
---|
104 | command))) |
---|
105 | (sb-ext:process-exit-code |
---|
106 | (sb-ext:run-program |
---|
107 | "/bin/sh" |
---|
108 | (list "-c" command) |
---|
109 | :input nil :output output))) |
---|
110 | |
---|
111 | #+lispworks |
---|
112 | (defun run-shell-command (command &key directory (output *standard-output*)) |
---|
113 | (when directory |
---|
114 | #+unix |
---|
115 | (setf command (concatenate 'string |
---|
116 | "\\cd \"" |
---|
117 | (namestring (pathname directory)) |
---|
118 | "\" && " |
---|
119 | command))) |
---|
120 | (system:call-system-showing-output |
---|
121 | command |
---|
122 | :shell-type "/bin/sh" |
---|
123 | :output-stream output)) |
---|
124 | |
---|
125 | (defun copy-file (from to) |
---|
126 | (let* ((from-namestring (namestring (pathname from))) |
---|
127 | (to-namestring (namestring (pathname to))) |
---|
128 | (command (concatenate 'string "cp " from-namestring " " to-namestring))) |
---|
129 | (zerop (run-shell-command command)))) |
---|
130 | |
---|
131 | (defun make-symbolic-link (from to) |
---|
132 | (let* ((from-namestring (namestring (pathname from))) |
---|
133 | (to-namestring (namestring (pathname to))) |
---|
134 | (command (concatenate 'string "ln -s " from-namestring " " to-namestring))) |
---|
135 | (zerop (run-shell-command command)))) |
---|
136 | |
---|
137 | (defun probe-directory (pathname) |
---|
138 | #+abcl (ext:probe-directory pathname) |
---|
139 | #+allegro (excl:probe-directory pathname) |
---|
140 | #+clisp (ignore-errors (ext:probe-directory pathname)) |
---|
141 | #+cmu (probe-file pathname) ; FIXME |
---|
142 | #+sbcl (probe-file pathname) ; FIXME |
---|
143 | #+lispworks (probe-file pathname) |
---|
144 | ) |
---|
145 | |
---|
146 | (defun file-directory-p (pathname) |
---|
147 | #+abcl (ext:file-directory-p pathname) |
---|
148 | #+allegro (excl:file-directory-p pathname) |
---|
149 | #-(or abcl allegro) |
---|
150 | (let* ((namestring (namestring pathname)) |
---|
151 | (len (length namestring)) |
---|
152 | (last-char (and (> len 0) (char namestring (1- len))))) |
---|
153 | (eql last-char #+windows #\\ #-windows #\/))) |
---|
154 | |
---|
155 | (defun make-directory (pathname) |
---|
156 | #+allegro |
---|
157 | (excl:make-directory pathname) |
---|
158 | #-allegro |
---|
159 | (and (ensure-directories-exist pathname) t)) |
---|
160 | |
---|
161 | (defun delete-directory (pathname) |
---|
162 | #+abcl (delete-file pathname) |
---|
163 | #+allegro (excl:delete-directory pathname) |
---|
164 | #+clisp (ext:delete-dir (namestring pathname)) |
---|
165 | #+cmu (unix:unix-rmdir (namestring pathname)) |
---|
166 | #+sbcl (zerop (sb-posix:rmdir (namestring pathname))) |
---|
167 | #+lispworks (lw:delete-directory pathname) |
---|
168 | ) |
---|
169 | |
---|
170 | ;; This approach is race-prone, but it should be adequate for our limited |
---|
171 | ;; purposes here. |
---|
172 | (defun make-temporary-filename (directory) |
---|
173 | (unless (probe-directory directory) |
---|
174 | (error "The directory ~S does not exist." directory)) |
---|
175 | (dotimes (i 10) |
---|
176 | (let ((pathname (merge-pathnames (make-pathname :name (symbol-name (gensym)) |
---|
177 | :type nil) |
---|
178 | directory))) |
---|
179 | (unless (probe-file pathname) |
---|
180 | (return-from make-temporary-filename pathname)))) |
---|
181 | (error "Unable to create a temporary filename in ~S" directory)) |
---|
182 | |
---|
183 | (defun touch (filespec) |
---|
184 | (with-open-file (stream filespec :direction :output :if-exists :error))) |
---|
185 | |
---|
186 | (defun make-temporary-directory (parent-directory) |
---|
187 | (let* ((tmp (make-temporary-filename parent-directory)) |
---|
188 | (directory-namestring (concatenate 'string (namestring tmp) "/")) |
---|
189 | (directory-pathname (pathname directory-namestring))) |
---|
190 | (make-directory directory-pathname) |
---|
191 | directory-pathname)) |
---|
192 | |
---|
193 | (defun delete-directory-and-files (pathspec &key (quiet t) (dry-run nil)) |
---|
194 | (let* ((namestring (namestring pathspec)) |
---|
195 | (len (length namestring)) |
---|
196 | (last-char (and (> len 0) (char namestring (1- len))))) |
---|
197 | (unless (eql last-char #+windows #\\ #-windows #\/) |
---|
198 | (setf namestring (concatenate 'string namestring #+windows "\\" #-windows "/"))) |
---|
199 | (let ((pathname (pathname namestring))) |
---|
200 | (unless (probe-directory pathname) |
---|
201 | (error "Directory does not exist: ~S" pathname)) |
---|
202 | (unless quiet |
---|
203 | (format t "~&processing directory ~S~%" pathname)) |
---|
204 | (let ((list (directory (make-pathname :name :wild |
---|
205 | :type #-clisp :wild #+clisp nil |
---|
206 | :defaults pathname)))) |
---|
207 | (dolist (x list) |
---|
208 | (cond ((file-directory-p x) |
---|
209 | (delete-directory-and-files x :quiet quiet)) |
---|
210 | (t |
---|
211 | (unless quiet |
---|
212 | (format t "~&deleting file ~S~%" x)) |
---|
213 | (unless dry-run |
---|
214 | (delete-file x))))) |
---|
215 | (unless quiet |
---|
216 | (format t "~&deleting directory ~S~%" pathname)) |
---|
217 | (unless dry-run |
---|
218 | (delete-directory pathname)))))) |
---|
219 | |
---|
220 | #-(or allegro clisp lispworks windows) |
---|
221 | (deftest run-shell-command.1 |
---|
222 | (let* ((raw-string |
---|
223 | (with-output-to-string (s) (run-shell-command "pwd" |
---|
224 | :directory *this-directory* |
---|
225 | :output s))) |
---|
226 | (string |
---|
227 | (string-right-trim '(#\newline #\return) raw-string)) |
---|
228 | (length (length string))) |
---|
229 | (when (> length 0) |
---|
230 | (unless (eql (char string (1- length)) #\/) |
---|
231 | (setf string (concatenate 'string string (string #\/))))) |
---|
232 | (string= string (directory-namestring *this-directory*))) |
---|
233 | t) |
---|
234 | |
---|
235 | #-(or allegro clisp lispworks windows) |
---|
236 | (deftest run-shell-command.2 |
---|
237 | (let* ((directory |
---|
238 | (probe-file (merge-pathnames "../" *this-directory*))) |
---|
239 | (raw-string |
---|
240 | (with-output-to-string (s) (run-shell-command "pwd" |
---|
241 | :directory directory |
---|
242 | :output s))) |
---|
243 | (string |
---|
244 | (string-right-trim '(#\newline #\return) raw-string)) |
---|
245 | (length (length string))) |
---|
246 | (when (> length 0) |
---|
247 | (unless (eql (char string (1- length)) #\/) |
---|
248 | (setf string (concatenate 'string string (string #\/))))) |
---|
249 | (string= string (directory-namestring directory))) |
---|
250 | t) |
---|
251 | |
---|
252 | (deftest probe-file.1 |
---|
253 | (pathnames-equal-p (probe-file *this-file*) *this-file*) |
---|
254 | t) |
---|
255 | |
---|
256 | (deftest probe-file.2 |
---|
257 | (let ((pathname #p".")) |
---|
258 | #-clisp |
---|
259 | (pathnames-equal-p (probe-file pathname) (truename pathname)) |
---|
260 | #+clisp |
---|
261 | ;; "." names a directory, not a file. |
---|
262 | (signals-error (probe-file pathname) 'file-error)) |
---|
263 | t) |
---|
264 | #+(and clisp windows) |
---|
265 | (pushnew 'probe-file.2 *expected-failures*) |
---|
266 | |
---|
267 | (deftest probe-file.3 |
---|
268 | (let ((pathname #p"./")) |
---|
269 | #-clisp |
---|
270 | (pathnames-equal-p (probe-file pathname) *this-directory*) |
---|
271 | #+clisp |
---|
272 | ;; "no file name given" |
---|
273 | (signals-error (probe-file pathname) 'file-error)) |
---|
274 | t) |
---|
275 | |
---|
276 | (deftest probe-file.4 |
---|
277 | (let ((pathname #p"..")) |
---|
278 | #-clisp |
---|
279 | (pathnames-equal-p (probe-file pathname) (truename pathname)) |
---|
280 | #+clisp |
---|
281 | ;; ".." names a directory, not a file. |
---|
282 | (signals-error (probe-file pathname) 'file-error)) |
---|
283 | t) |
---|
284 | #+(and clisp windows) |
---|
285 | (pushnew 'probe-file.4 *expected-failures*) |
---|
286 | |
---|
287 | (deftest probe-file.5 |
---|
288 | (or |
---|
289 | ;; It might not exist. That's OK. |
---|
290 | (null (probe-directory #p"/home/")) |
---|
291 | (pathnames-equal-p (probe-file #p"/home") (probe-file #p"/home/"))) |
---|
292 | t) |
---|
293 | #+(or allegro cmu clisp) |
---|
294 | (pushnew 'probe-file.5 *expected-failures*) |
---|
295 | |
---|
296 | (deftest truename.1 |
---|
297 | (pathnames-equal-p (truename *this-file*) *this-file*) |
---|
298 | t) |
---|
299 | |
---|
300 | (deftest truename.2 |
---|
301 | (pathnames-equal-p (truename #p"./") *this-directory*) |
---|
302 | t) |
---|
303 | |
---|
304 | (deftest directory.1 |
---|
305 | (let ((list (directory *this-file*))) |
---|
306 | (and |
---|
307 | (= (length list) 1) |
---|
308 | (pathnames-equal-p (car list) *this-file*))) |
---|
309 | t) |
---|
310 | |
---|
311 | ;; Verify that DIRECTORY returns nil if the directory is empty. |
---|
312 | (deftest directory.2 |
---|
313 | (let ((directory-pathname (make-temporary-directory *this-directory*))) |
---|
314 | (unwind-protect |
---|
315 | (directory (make-pathname :name :wild :defaults directory-pathname)) |
---|
316 | (delete-directory-and-files directory-pathname))) |
---|
317 | nil) |
---|
318 | |
---|
319 | ;; A directory with a one file named "foo". |
---|
320 | (deftest directory.3 |
---|
321 | (let ((directory-pathname (make-temporary-directory *this-directory*))) |
---|
322 | (unwind-protect |
---|
323 | (let ((file-pathname (make-pathname :name "foo" :defaults directory-pathname))) |
---|
324 | (touch file-pathname) |
---|
325 | (let ((directory (directory (make-pathname :name :wild |
---|
326 | :defaults directory-pathname)))) |
---|
327 | (and (listp directory) |
---|
328 | (= (length directory) 1) |
---|
329 | (pathnames-equal-p (car directory) file-pathname)))) |
---|
330 | (delete-directory-and-files directory-pathname))) |
---|
331 | t) |
---|
332 | |
---|
333 | ;; Same as DIRECTORY.3, but use :type :wild for the wildcard. |
---|
334 | (deftest directory.4 |
---|
335 | (let ((directory-pathname (make-temporary-directory *this-directory*))) |
---|
336 | (unwind-protect |
---|
337 | (let ((file-pathname (make-pathname :name "foo" :defaults directory-pathname))) |
---|
338 | (touch file-pathname) |
---|
339 | (let ((directory (directory (make-pathname :name :wild |
---|
340 | :type :wild |
---|
341 | :defaults directory-pathname)))) |
---|
342 | (and (listp directory) |
---|
343 | (= (length directory) 1) |
---|
344 | (pathnames-equal-p (truename (car directory)) |
---|
345 | (truename file-pathname))))) |
---|
346 | (delete-directory-and-files directory-pathname))) |
---|
347 | t) |
---|
348 | #+clisp |
---|
349 | ;; A pathname with type nil does not match a wildcard with type :WILD. |
---|
350 | (pushnew 'directory.4 *expected-failures*) |
---|
351 | |
---|
352 | #-windows |
---|
353 | (deftest symlink.1 |
---|
354 | (let* ((tmp1 (make-temporary-filename *this-directory*)) |
---|
355 | (tmp2 (make-temporary-filename *this-directory*))) |
---|
356 | (unwind-protect |
---|
357 | (values |
---|
358 | (unwind-protect |
---|
359 | (and |
---|
360 | ;; Copy this file to tmp1. |
---|
361 | (copy-file *this-file* tmp1) |
---|
362 | (pathnames-equal-p (probe-file tmp1) tmp1) |
---|
363 | ;; Create tmp2 as a symlink to tmp1. |
---|
364 | (make-symbolic-link tmp1 tmp2) |
---|
365 | ;; Verify that the symlink exists and points to the copy. |
---|
366 | (pathnames-equal-p (probe-file tmp2) tmp1) |
---|
367 | (pathnames-equal-p (truename tmp2) tmp1)) |
---|
368 | ;; Delete the symlink. |
---|
369 | (when (probe-file tmp2) |
---|
370 | (delete-file tmp2))) |
---|
371 | ;; Copy should still exist after symlink is deleted. |
---|
372 | (pathnames-equal-p (probe-file tmp1) tmp1)) |
---|
373 | (when (probe-file tmp1) |
---|
374 | (delete-file tmp1)))) |
---|
375 | t t) |
---|
376 | #+allegro |
---|
377 | ;; Allegro's PROBE-FILE doesn't follow the symlink. |
---|
378 | (pushnew 'symlink.1 *expected-failures*) |
---|
379 | |
---|
380 | #-windows |
---|
381 | (deftest symlink.2 |
---|
382 | (let* ((copy (make-temporary-filename *this-directory*)) |
---|
383 | (link (make-temporary-filename *this-directory*)) |
---|
384 | directory) |
---|
385 | (unwind-protect |
---|
386 | (and |
---|
387 | ;; Copy this file to copy. |
---|
388 | (copy-file *this-file* copy) |
---|
389 | ;; Verify that copy exists. |
---|
390 | (pathnames-equal-p (probe-file copy) copy) |
---|
391 | ;; Create link as a symlink to copy. |
---|
392 | (make-symbolic-link copy link) |
---|
393 | ;; Verify that the symlink appears in the directory listing. |
---|
394 | (setf directory (directory link)) |
---|
395 | (= (length directory) 1) |
---|
396 | ;; The directory listing should contain the truename of the symlink. |
---|
397 | (pathnames-equal-p (car directory) (truename link))) |
---|
398 | (progn |
---|
399 | ;; Clean up. |
---|
400 | (when (probe-file link) |
---|
401 | (delete-file link)) |
---|
402 | (when (probe-file copy) |
---|
403 | (delete-file copy))))) |
---|
404 | t) |
---|
405 | #+allegro |
---|
406 | (pushnew 'symlink.2 *expected-failures*) |
---|
407 | |
---|
408 | ;; user-homedir-pathname &optional host => pathname |
---|
409 | |
---|
410 | ;; "USER-HOMEDIR-PATHNAME returns a pathname without any name, type, or version |
---|
411 | ;; component (those components are all nil) for the user's home directory on |
---|
412 | ;; HOST. If it is impossible to determine the user's home directory on HOST, |
---|
413 | ;; then nil is returned. USER-HOMEDIR-PATHNAME never returns nil if HOST is not |
---|
414 | ;; supplied." |
---|
415 | (deftest user-homedir-pathname.1 |
---|
416 | (let ((pathname (user-homedir-pathname))) |
---|
417 | (values (pathnamep pathname) |
---|
418 | (pathname-name pathname) |
---|
419 | (pathname-type pathname) |
---|
420 | (pathname-version pathname))) |
---|
421 | t nil nil nil) |
---|
422 | #+allegro |
---|
423 | ;; Allegro's version component is :UNSPECIFIC. |
---|
424 | (pushnew 'user-homedir-pathname.1 *expected-failures*) |
---|
425 | |
---|
426 | (deftest file-system.directory-namestring.1 |
---|
427 | (let ((pathname (user-homedir-pathname))) |
---|
428 | (equal (namestring pathname) (directory-namestring pathname))) |
---|
429 | #-windows |
---|
430 | t |
---|
431 | #+windows |
---|
432 | ;; The drive prefix ("C:\\") is not part of the directory namestring. |
---|
433 | nil) |
---|
434 | #+clisp |
---|
435 | (pushnew 'file-system.directory-namestring.1 *expected-failures*) |
---|
436 | |
---|
437 | (deftest file.system.directory-namestring.2 |
---|
438 | (let ((pathname (user-homedir-pathname))) |
---|
439 | (equal (directory-namestring pathname) |
---|
440 | (namestring (make-pathname :directory (pathname-directory pathname))))) |
---|
441 | t) |
---|
442 | #+clisp |
---|
443 | (pushnew 'file-system.directory-namestring.2 *expected-failures*) |
---|
444 | |
---|
445 | (deftest ensure-directories-exist.1 |
---|
446 | (let* ((tmp (make-temporary-filename *this-directory*)) |
---|
447 | (directory-namestring (concatenate 'string (namestring tmp) "/")) |
---|
448 | (file-namestring (concatenate 'string directory-namestring "foo.bar"))) |
---|
449 | (multiple-value-bind (path created) |
---|
450 | (ensure-directories-exist file-namestring) |
---|
451 | (values |
---|
452 | ;; 1. "The primary value is the given pathspec..." |
---|
453 | #+(or allegro clisp) |
---|
454 | (eq path file-namestring) |
---|
455 | #-(or allegro clisp) |
---|
456 | (pathnames-equal-p (pathname path) (pathname file-namestring)) |
---|
457 | ;; 2. Verify that the directory was created. |
---|
458 | created |
---|
459 | ;; 3. Verify that the directory exists. |
---|
460 | #+clisp |
---|
461 | ;; CLISP's PROBE-DIRECTORY just returns T. |
---|
462 | (ext:probe-directory directory-namestring) |
---|
463 | ;; ABCL fills in DEVICE as :UNSPECIFIC when resolving |
---|
464 | ;; filesystem paths on non-M$DOG |
---|
465 | #+abcl |
---|
466 | (not (null (truename directory-namestring))) |
---|
467 | #-(or clisp abcl) |
---|
468 | (pathnames-equal-p (probe-file directory-namestring) |
---|
469 | (pathname directory-namestring)) |
---|
470 | ;; 4. Delete the directory. |
---|
471 | (when (probe-directory directory-namestring) |
---|
472 | (delete-directory directory-namestring)) |
---|
473 | ;; 5. Verify that the directory is no longer there. |
---|
474 | (probe-directory directory-namestring)) |
---|
475 | )) |
---|
476 | t t t t nil) |
---|
477 | |
---|
478 | ;; What happens if you call ENSURE-DIRECTORIES-EXIST with a pathname that has |
---|
479 | ;; no name, type, or version component? |
---|
480 | |
---|
481 | ;; Case 1: the directory in question already exists. |
---|
482 | (deftest ensure-directories-exist.2 |
---|
483 | (let ((pathname |
---|
484 | (make-pathname :host (pathname-host *this-directory*) |
---|
485 | :device (pathname-device *this-directory*) |
---|
486 | :directory (pathname-directory *this-directory*) |
---|
487 | :name nil :type nil :version nil))) |
---|
488 | (multiple-value-bind (path created) |
---|
489 | (ensure-directories-exist pathname) |
---|
490 | (values |
---|
491 | #+(or allegro clisp) |
---|
492 | (eq path pathname) |
---|
493 | #-(or allegro clisp) |
---|
494 | (pathnames-equal-p (pathname path) (pathname pathname)) |
---|
495 | created))) |
---|
496 | t nil) |
---|
497 | |
---|
498 | ;; Case 2: the directory in question does not exist. |
---|
499 | (deftest ensure-directories-exist.3 |
---|
500 | (let* ((tmp (make-temporary-filename *this-directory*)) |
---|
501 | (directory-namestring (concatenate 'string (namestring tmp) "/")) |
---|
502 | (pathname (pathname directory-namestring))) |
---|
503 | (multiple-value-bind (path created) |
---|
504 | (ensure-directories-exist pathname) |
---|
505 | (values |
---|
506 | #+(or allegro clisp) |
---|
507 | (eq path pathname) |
---|
508 | #-(or allegro clisp) |
---|
509 | (pathnames-equal-p (pathname path) (pathname pathname)) |
---|
510 | created |
---|
511 | (not (null (probe-directory directory-namestring))) |
---|
512 | (when (probe-directory directory-namestring) |
---|
513 | (delete-directory directory-namestring)) |
---|
514 | ))) |
---|
515 | t t t t) |
---|