source: branches/1.1.x/test/lisp/abcl/file-system-tests.lisp

Last change on this file was 14246, checked in by Mark Evenson, 12 years ago

abcl-test: Fix DIRECTORY.4.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 18.9 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 (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)
Note: See TracBrowser for help on using the repository browser.