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

Last change on this file since 12618 was 12618, checked in by Mark Evenson, 11 years ago

Incorporate an ASDF2 snapshot as the base ASDF.

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