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 ;;; In sbcl-0.9.7 DIRECTORY failed on pathnames with character-set
  39 ;;; components.
  40 (let ((dir (directory "[f]*.*")))
  41   ;; We know a little bit about the structure of this result;
  42   ;; let's test to make sure that this test file is in it.
  43   (assert (find-if (lambda (pathname)
  44                      (search "filesys.pure.lisp"
  45                              (namestring pathname)))
  46                    dir)))
  47
  48 ;;; Set *default-pathname-defaults* to something other than the unix
  49 ;;; cwd, to catch functions which access the filesystem without
  50 ;;; merging properly.  We should test more functions than just OPEN
  51 ;;; here, of course
  52
  53 (let ((*default-pathname-defaults*
  54        (make-pathname :directory
  55                       (butlast
  56                        (pathname-directory *default-pathname-defaults*))
  57                       :defaults *default-pathname-defaults*)))
  58   ;; SBCL 0.7.1.2 failed to merge on OPEN
  59   (with-open-file (i "tests/filesys.pure.lisp")
  60       (assert i)))
  61
  62 ;;; OPEN, LOAD and friends should signal an error of type FILE-ERROR
  63 ;;; if they are fed wild pathname designators; firstly, with wild
  64 ;;; pathnames that don't correspond to any files:
  65 (assert (typep (nth-value 1 (ignore-errors (open "non-existent*.lisp")))
  66                'file-error))
  67 (assert (typep (nth-value 1 (ignore-errors (load "non-existent*.lisp")))
  68                'file-error))
  69 ;;; then for pathnames that correspond to precisely one:
  70 (assert (typep (nth-value 1 (ignore-errors (open "filesys.pur*.lisp")))
  71                'file-error))
  72 (assert (typep (nth-value 1 (ignore-errors (load "filesys.pur*.lisp")))
  73                'file-error))
  74 ;;; then for pathnames corresponding to many:
  75 (assert (typep (nth-value 1 (ignore-errors (open "*.lisp")))
  76                'file-error))
  77 (assert (typep (nth-value 1 (ignore-errors (load "*.lisp")))
  78                'file-error))
  79
  80 ;;; ANSI: FILE-LENGTH should signal an error of type TYPE-ERROR if
  81 ;;; STREAM is not a stream associated with a file.
  82 ;;;
  83 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
  84 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
  85 (assert (typep (nth-value 1 (ignore-errors (file-length *terminal-io*)))
  86                'type-error))