source: trunk/source/tests/ansi-tests/ensure-directories-exist.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Jan  5 20:53:03 2004
4;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST
5
6(in-package :cl-test)
7
8(deftest ensure-directories-exist.1
9  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
10                            :defaults *default-pathname-defaults*))
11         (results nil)
12         (verbosity
13          (with-output-to-string
14            (*standard-output*)
15            (setq results (multiple-value-list (ensure-directories-exist pn))))))
16    (values
17     (length results)
18     (equalt (truename pn) (truename (first results)))
19     (second results)
20     verbosity))
21  2 t nil "")
22
23(deftest ensure-directories-exist.2
24  (with-open-file
25   (s "ensure-directories-exist.lsp" :direction :input)
26   (let* ((results (multiple-value-list (ensure-directories-exist s))))
27     (values
28      (length results)
29      (equalt (truename (first results)) (truename s))
30      (second results))))
31   2 t nil)
32
33(deftest ensure-directories-exist.3
34  (let ((s (open "ensure-directories-exist.lsp" :direction :input)))
35    (close s)
36    (let* ((results (multiple-value-list (ensure-directories-exist s))))
37      (values
38       (length results)
39       (equalt (truename (first results)) (truename s))
40       (second results))))
41   2 t nil)
42
43(deftest ensure-directories-exist.4
44  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
45                            :defaults *default-pathname-defaults*))
46         (results nil)
47         (verbosity
48          (with-output-to-string
49            (*standard-output*)
50            (setq results (multiple-value-list
51                           (ensure-directories-exist pn :verbose nil))))))
52    (values
53     (length results)
54     (equalt (truename pn) (truename (first results)))
55     (second results)
56     verbosity))
57  2 t nil "")
58
59(deftest ensure-directories-exist.5
60  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
61                            :defaults *default-pathname-defaults*))
62         (results nil)
63         (verbosity
64          (with-output-to-string
65            (*standard-output*)
66            (setq results (multiple-value-list
67                           (ensure-directories-exist pn :verbose t))))))
68    (values
69     (length results)
70     (equalt (truename pn) (truename (first results)))
71     (second results)
72     verbosity))
73  2 t nil "")
74
75(deftest ensure-directories-exist.6
76  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
77                            :defaults *default-pathname-defaults*))
78         (results nil)
79         (verbosity
80          (with-output-to-string
81            (*standard-output*)
82            (setq results (multiple-value-list
83                           (ensure-directories-exist
84                            pn :allow-other-keys nil))))))
85    (values
86     (length results)
87     (equalt (truename pn) (truename (first results)))
88     (second results)
89     verbosity))
90  2 t nil "")
91
92(deftest ensure-directories-exist.7
93  (let* ((pn (make-pathname :name "ensure-directories-exist.lsp"
94                            :defaults *default-pathname-defaults*))
95         (results nil)
96         (verbosity
97          (with-output-to-string
98            (*standard-output*)
99            (setq results (multiple-value-list
100                           (ensure-directories-exist
101                            pn :allow-other-keys t :nonsense t))))))
102    (values
103     (length results)
104     (equalt (truename pn) (truename (first results)))
105     (second results)
106     verbosity))
107  2 t nil "")
108
109;;; Case where directory shouldn't exist
110
111;; The directort ansi-tests/scratch must not exist before this
112;; test is run
113(deftest ensure-directories-exist.8
114  (let* ((subdir (make-pathname :directory '(:relative "scratch")
115                                :defaults *default-pathname-defaults*))
116         (pn (make-pathname :name "foo" :type "txt"
117                            :defaults subdir)))
118    (assert (not (probe-file pn)) ()
119            "Delete subdirectory scratch and its contents!")
120    (let* ((results nil)
121           (verbosity
122            (with-output-to-string
123              (*standard-output*)
124              (setq results (multiple-value-list (ensure-directories-exist pn)))))
125           (result-pn (first results))
126           (created (second results)))
127      ;; Create the file and write to it
128      (with-open-file (*standard-output*
129                       pn :direction :output :if-exists :error
130                       :if-does-not-exist :create)
131                      (print nil))                   
132      (values
133       (length results)
134       (notnot created)
135       (equalt pn result-pn)
136       (notnot (probe-file pn))
137       verbosity
138       )))
139  2 t t t "")
140
141;;; Specialized string tests
142
143(deftest ensure-directories-exist.9
144  (do-special-strings
145   (str "ensure-directories-exist.lsp" nil)
146   (let* ((results (multiple-value-list (ensure-directories-exist str))))
147     (assert (eql (length results) 2))
148     (assert (equalt (truename (first results)) (truename str)))
149     (assert (null (second results)))))
150  nil)
151
152;; FIXME
153;; Need to add a LPN test
154
155(deftest ensure-directories-exist.error.1
156  (signals-error-always
157   (ensure-directories-exist
158    (make-pathname :directory '(:relative :wild)
159                   :defaults *default-pathname-defaults*))
160   file-error)
161  t t)
162
163(deftest ensure-directories-exist.error.2
164  (signals-error (ensure-directories-exist) program-error)
165  t)
Note: See TracBrowser for help on using the repository browser.