source: trunk/abcl/test/lisp/abcl/file-system-tests.lisp @ 14244

Last change on this file since 14244 was 14244, checked in by Mark Evenson, 8 years ago

Correct ENSURE-DIRECTORIES-EXIST.1 test logic.

ABCL fills in DEVICE as :UNSPECIFIC when resolving filesystem paths on
non-M$DOG meaning that an unresolved pathname is not always equivalent
to its resolved version.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 18.8 KB
Line 
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 (car directory) file-pathname))))
345      (delete-directory-and-files directory-pathname)))
346  t)
347#+clisp
348;; A pathname with type nil does not match a wildcard with type :WILD.
349(pushnew 'directory.4 *expected-failures*)
350
351#-windows
352(deftest symlink.1
353  (let* ((tmp1 (make-temporary-filename *this-directory*))
354         (tmp2 (make-temporary-filename *this-directory*)))
355    (unwind-protect
356        (values
357         (unwind-protect
358             (and
359              ;; Copy this file to tmp1.
360              (copy-file *this-file* tmp1)
361              (pathnames-equal-p (probe-file tmp1) tmp1)
362              ;; Create tmp2 as a symlink to tmp1.
363              (make-symbolic-link tmp1 tmp2)
364              ;; Verify that the symlink exists and points to the copy.
365              (pathnames-equal-p (probe-file tmp2) tmp1)
366              (pathnames-equal-p (truename tmp2) tmp1))
367           ;; Delete the symlink.
368           (when (probe-file tmp2)
369             (delete-file tmp2)))
370         ;; Copy should still exist after symlink is deleted.
371         (pathnames-equal-p (probe-file tmp1) tmp1))
372      (when (probe-file tmp1)
373        (delete-file tmp1))))
374  t t)
375#+allegro
376;; Allegro's PROBE-FILE doesn't follow the symlink.
377(pushnew 'symlink.1 *expected-failures*)
378
379#-windows
380(deftest symlink.2
381  (let* ((copy (make-temporary-filename *this-directory*))
382         (link (make-temporary-filename *this-directory*))
383         directory)
384    (unwind-protect
385        (and
386         ;; Copy this file to copy.
387         (copy-file *this-file* copy)
388         ;; Verify that copy exists.
389         (pathnames-equal-p (probe-file copy) copy)
390         ;; Create link as a symlink to copy.
391         (make-symbolic-link copy link)
392         ;; Verify that the symlink appears in the directory listing.
393         (setf directory (directory link))
394         (= (length directory) 1)
395         ;; The directory listing should contain the truename of the symlink.
396         (pathnames-equal-p (car directory) (truename link)))
397      (progn
398        ;; Clean up.
399        (when (probe-file link)
400          (delete-file link))
401        (when (probe-file copy)
402          (delete-file copy)))))
403  t)
404#+allegro
405(pushnew 'symlink.2 *expected-failures*)
406
407;; user-homedir-pathname &optional host => pathname
408
409;; "USER-HOMEDIR-PATHNAME returns a pathname without any name, type, or version
410;; component (those components are all nil) for the user's home directory on
411;; HOST. If it is impossible to determine the user's home directory on HOST,
412;; then nil is returned. USER-HOMEDIR-PATHNAME never returns nil if HOST is not
413;; supplied."
414(deftest user-homedir-pathname.1
415  (let ((pathname (user-homedir-pathname)))
416    (values (pathnamep pathname)
417            (pathname-name pathname)
418            (pathname-type pathname)
419            (pathname-version pathname)))
420  t nil nil nil)
421#+allegro
422;; Allegro's version component is :UNSPECIFIC.
423(pushnew 'user-homedir-pathname.1 *expected-failures*)
424
425(deftest file-system.directory-namestring.1
426  (let ((pathname (user-homedir-pathname)))
427    (equal (namestring pathname) (directory-namestring pathname)))
428  #-windows
429  t
430  #+windows
431  ;; The drive prefix ("C:\\") is not part of the directory namestring.
432  nil)
433#+clisp
434(pushnew 'file-system.directory-namestring.1 *expected-failures*)
435
436(deftest file.system.directory-namestring.2
437  (let ((pathname (user-homedir-pathname)))
438    (equal (directory-namestring pathname)
439           (namestring (make-pathname :directory (pathname-directory pathname)))))
440  t)
441#+clisp
442(pushnew 'file-system.directory-namestring.2 *expected-failures*)
443
444(deftest ensure-directories-exist.1
445  (let* ((tmp (make-temporary-filename *this-directory*))
446         (directory-namestring (concatenate 'string (namestring tmp) "/"))
447         (file-namestring (concatenate 'string directory-namestring "foo.bar")))
448    (multiple-value-bind (path created)
449        (ensure-directories-exist file-namestring)
450      (values
451       ;; 1. "The primary value is the given pathspec..."
452       #+(or allegro clisp)
453       (eq path file-namestring)
454       #-(or allegro clisp)
455       (pathnames-equal-p (pathname path) (pathname file-namestring))
456       ;; 2. Verify that the directory was created.
457       created
458       ;; 3. Verify that the directory exists.
459       #+clisp
460       ;; CLISP's PROBE-DIRECTORY just returns T.
461       (ext:probe-directory directory-namestring)
462       ;; ABCL fills in DEVICE as :UNSPECIFIC when resolving
463       ;; filesystem paths on non-M$DOG
464       #+abcl
465       (not (null (truename directory-namestring)))
466       #-(or clisp abcl)
467       (pathnames-equal-p (probe-file directory-namestring)
468                          (pathname directory-namestring))
469       ;; 4. Delete the directory.
470       (when (probe-directory directory-namestring)
471         (delete-directory directory-namestring))
472       ;; 5. Verify that the directory is no longer there.
473       (probe-directory directory-namestring))
474       ))
475  t t t t nil)
476
477;; What happens if you call ENSURE-DIRECTORIES-EXIST with a pathname that has
478;; no name, type, or version component?
479
480;; Case 1: the directory in question already exists.
481(deftest ensure-directories-exist.2
482  (let ((pathname
483         (make-pathname :host (pathname-host *this-directory*)
484                        :device (pathname-device *this-directory*)
485                        :directory (pathname-directory *this-directory*)
486                        :name nil :type nil :version nil)))
487    (multiple-value-bind (path created)
488        (ensure-directories-exist pathname)
489      (values
490       #+(or allegro clisp)
491       (eq path pathname)
492       #-(or allegro clisp)
493       (pathnames-equal-p (pathname path) (pathname pathname))
494       created)))
495  t nil)
496
497;; Case 2: the directory in question does not exist.
498(deftest ensure-directories-exist.3
499  (let* ((tmp (make-temporary-filename *this-directory*))
500         (directory-namestring (concatenate 'string (namestring tmp) "/"))
501         (pathname (pathname directory-namestring)))
502    (multiple-value-bind (path created)
503        (ensure-directories-exist pathname)
504      (values
505       #+(or allegro clisp)
506       (eq path pathname)
507       #-(or allegro clisp)
508       (pathnames-equal-p (pathname path) (pathname pathname))
509       created
510       (not (null (probe-directory directory-namestring)))
511       (when (probe-directory directory-namestring)
512         (delete-directory directory-namestring))
513       )))
514  t t t t)
Note: See TracBrowser for help on using the repository browser.