0.8.13.72: MORE CHAPTERS
[sbcl.git] / tests / filesys.pure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
6 ;;;; from CMU CL.
7 ;;;; 
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
11
12 (in-package "CL-USER")
13
14 ;;; In sbcl-0.6.9 FOO-NAMESTRING functions  returned "" instead of NIL.
15 (let ((pathname0 (make-pathname :host nil 
16                                 :directory
17                                 (pathname-directory
18                                  *default-pathname-defaults*)
19                                 :name "getty"))
20       (pathname1 (make-pathname :host nil 
21                                 :directory nil
22                                 :name nil)))
23   (assert (equal (file-namestring pathname0) "getty"))
24   (assert (equal (directory-namestring pathname0)
25                  (directory-namestring *default-pathname-defaults*)))
26   (assert (equal (file-namestring pathname1) ""))
27   (assert (equal (directory-namestring pathname1) "")))
28
29 ;;; In sbcl-0.6.9 DIRECTORY failed on paths with :WILD or
30 ;;; :WILD-INFERIORS in their directory components.
31 (let ((dir (directory "../**/*.*")))
32   ;; We know a little bit about the structure of this result;
33   ;; let's test to make sure that this test file is in it.
34   (assert (find-if (lambda (pathname)
35                      (search "tests/filesys.pure.lisp"
36                              (namestring pathname)))
37                    dir)))
38
39 ;;; Set *default-pathname-defaults* to something other than the unix
40 ;;; cwd, to catch functions which access the filesystem without
41 ;;; merging properly.  We should test more functions than just OPEN
42 ;;; here, of course
43
44 (let ((*default-pathname-defaults*
45        (make-pathname :directory
46                       (butlast
47                        (pathname-directory *default-pathname-defaults*))
48                       :defaults *default-pathname-defaults*)))
49   ;; SBCL 0.7.1.2 failed to merge on OPEN
50   (with-open-file (i "tests/filesys.pure.lisp")
51       (assert i)))
52
53 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
54 ;;; if they are fed wild pathname designators; firstly, with wild
55 ;;; pathnames that don't correspond to any files:
56 (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp")))
57                'file-error))
58 (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp")))
59                'file-error))
60 ;;; then for pathnames that correspond to precisely one:
61 (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp")))
62                'file-error))
63 (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp")))
64                'file-error))
65 ;;; then for pathnames corresponding to many:
66 (assert (typep (nth-value 1 (ignore-errors (open "*.lisp")))
67                'file-error))
68 (assert (typep (nth-value 1 (ignore-errors (load "*.lisp")))
69                'file-error))
70
71 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
72 ;;; STREAM is not a stream associated with a file.
73 ;;;
74 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
75 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
76 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
77                'type-error))