Commit 9c47a7a8 authored by pfdietz's avatar pfdietz

More files tests, and added more logical pathname tests. We make an...

More files tests, and added more logical pathname tests.  We make an assumption that the CLTEST logical host can be defined to be the directory containing this test suite.  More progv tests inspired by random test failures.
parent 8ebfcfbd
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 13 18:42:29 2004
;;;; Contains: Tests for DELETE-FILE
(in-package :cl-test)
(deftest delete-file.1
(let ((pn "scratchfile.txt"))
(unless (probe-file pn)
(with-open-file (s pn :direction :output)
(format s "Contents~%")))
(values
(notnot (probe-file pn))
(multiple-value-list (delete-file pn))
(probe-file pn)))
t (t) nil)
(deftest delete-file.2
(let ((pn #p"scratchfile.txt"))
(unless (probe-file pn)
(with-open-file (s pn :direction :output)
(format s "Contents~%")))
(values
(notnot (probe-file pn))
(multiple-value-list (delete-file pn))
(probe-file pn)))
t (t) nil)
(deftest delete-file.3
(let ((pn "CLTEST:scratchfile.txt"))
(unless (probe-file pn)
(with-open-file (s pn :direction :output)
(format s "Contents~%")))
(values
(notnot (probe-file pn))
(multiple-value-list (delete-file pn))
(probe-file pn)))
t (t) nil)
(deftest delete-file.4
(let ((pn "CLTEST:scratchfile.txt"))
(unless (probe-file pn)
(with-open-file (s pn :direction :output)
(format s "Contents~%")))
(let ((s (open pn :direction :input)))
(close s)
(values
(notnot (probe-file pn))
(multiple-value-list (delete-file s))
(probe-file pn))))
t (t) nil)
;;;
(deftest delete-file.error.1
(classify-error (delete-file))
program-error)
(deftest delete-file.error.2
(let ((pn "scratch.txt"))
(unless (probe-file pn)
(with-open-file (s pn :direction :output)
(format s "Contents~%")))
(values
(notnot (probe-file pn))
(classify-error (delete-file "scratch.txt" nil))
(notnot (probe-file pn))
(delete-file pn)
(probe-file pn)))
t program-error t t nil)
(deftest delete-file.error.3
(let ((pn "nonexistent.txt"))
(when (probe-file pn) (delete-file pn))
(let ((result (classify-error (delete-file "nonexistent.txt"))))
(if (member result '(file-error t))
t
result)))
t)
...@@ -38,7 +38,23 @@ ...@@ -38,7 +38,23 @@
;; unless (pathname-match-p pn pattern-pathname) ;; unless (pathname-match-p pn pattern-pathname)
;; collect pn)) ;; collect pn))
)) ))
nil nil nil) nil nil ;; nil
)
(deftest directory.7
(let* ((pattern-pathname (make-pathname :name :wild :type :wild
:defaults *default-pathname-defaults*))
(pathnames (directory pattern-pathname)))
(loop for pn in pathnames
unless (equal pn (probe-file pn))
collect pn))
nil)
(deftest directory.8
(let* ((pathname-pattern "CLTEST:*.*")
(len (length (directory pathname-pattern))))
(if (< len 500) len nil))
nil)
(deftest directory.error.1 (deftest directory.error.1
(classify-error (directory)) (classify-error (directory))
......
...@@ -134,7 +134,8 @@ ...@@ -134,7 +134,8 @@
))) )))
2 t t t "") 2 t t t "")
;; FIXME
;; Need to add a LPN test
(deftest ensure-directories-exist.error.1 (deftest ensure-directories-exist.error.1
(classify-error (classify-error
......
...@@ -52,6 +52,9 @@ ...@@ -52,6 +52,9 @@
author)) author))
nil) nil)
;;; FIXME
;;; Add LPN test
;;; Error tests ;;; Error tests
(deftest file-author.error.1 (deftest file-author.error.1
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 13 19:10:02 2004
;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function
(in-package :cl-test)
(deftest file-error.1
(let ((pn (make-pathname :name :wild
:type "txt"
:version :newest
:defaults *default-pathname-defaults*)))
(handler-case
(probe-file pn)
(error (c)
(values
(notnot (typep c 'file-error))
(if (equalp (file-error-pathname c) pn)
t
(list (file-error-pathname c) pn))))))
t t)
(deftest file-error-pathname.1
(let ((c (make-condition 'file-error :pathname "foo.txt")))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(file-error-pathname c)))
t t "foo.txt")
(deftest file-error-pathname.2
(let ((c (make-condition 'file-error :pathname #p"foo.txt")))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(equalt #p"foo.txt" (file-error-pathname c))))
t t t)
(deftest file-error-pathname.3
(let ((c (make-condition 'file-error :pathname "CLTEST:foo.txt")))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(equalpt "CLTEST:foo.txt"
(file-error-pathname c))))
t t t)
(deftest file-error-pathname.4
(let ((c (make-condition 'file-error :pathname (logical-pathname "CLTEST:foo.txt"))))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(equalpt (logical-pathname "CLTEST:foo.txt")
(file-error-pathname c))))
t t t)
(deftest file-error-pathname.5
(with-open-file (s "file-error.lsp" :direction :input)
(let ((c (make-condition 'file-error :pathname s)))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(equalpt s (file-error-pathname c)))))
t t t)
(deftest file-error-pathname.6
(let ((s (open "file-error.lsp" :direction :input)))
(close s)
(let ((c (make-condition 'file-error :pathname s)))
(values
(notnot (typep c 'file-error))
(eqlt (class-of c) (find-class 'file-error))
(equalpt s (file-error-pathname c)))))
t t t)
(deftest file-error-pathname.error.1
(classify-error (file-error-pathname))
program-error)
(deftest file-error-pathname.error.2
(classify-error (file-error-pathname (make-condition 'file-error :pathname "foo.txt") nil))
program-error)
...@@ -50,6 +50,9 @@ ...@@ -50,6 +50,9 @@
(length (multiple-value-list (file-write-date "file-write-date.lsp"))) (length (multiple-value-list (file-write-date "file-write-date.lsp")))
1) 1)
;;; FIXME
;;; Add LPN test
;;; ;;;
(deftest file-write-date.error.1 (deftest file-write-date.error.1
...@@ -71,5 +74,3 @@ ...@@ -71,5 +74,3 @@
(file-write-date (make-pathname :name "file-write-date" :type :wild (file-write-date (make-pathname :name "file-write-date" :type :wild
:defaults *default-pathname-defaults*))) :defaults *default-pathname-defaults*)))
file-error) file-error)
...@@ -12,4 +12,5 @@ ...@@ -12,4 +12,5 @@
(load "file-author.lsp") (load "file-author.lsp")
(load "file-write-date.lsp") (load "file-write-date.lsp")
(load "rename-file.lsp") (load "rename-file.lsp")
(load "delete-file.lsp")
(load "file-error.lsp")
...@@ -14,3 +14,12 @@ ...@@ -14,3 +14,12 @@
(symbol-value (symbol-value
(synonym-stream-symbol x)))))) (synonym-stream-symbol x))))))
(defun explode-pathname (pn)
(list
:host (pathname-host pn)
:device (pathname-device pn)
:directory (pathname-directory pn)
:name (pathname-name pn)
:type (pathname-type pn)
:version (pathname-version pn)))
...@@ -12,16 +12,21 @@ ...@@ -12,16 +12,21 @@
(deftest probe-file.2 (deftest probe-file.2
(let ((s (open #p"probe-file.lsp" :direction :input))) (let ((s (open #p"probe-file.lsp" :direction :input)))
(prog1 (prog1
(equalp (truename #p"probe-file.lsp") (equalpt (truename #p"probe-file.lsp")
(probe-file s)) (probe-file s))
(close s))) (close s)))
t) t)
(deftest probe-file.3 (deftest probe-file.3
(let ((s (open #p"probe-file.lsp" :direction :input))) (let ((s (open #p"probe-file.lsp" :direction :input)))
(close s) (close s)
(equalp (truename #p"probe-file.lsp") (equalpt (truename #p"probe-file.lsp")
(probe-file s))) (probe-file s)))
t)
(deftest probe-file.4
(equalpt (truename #p"probe-file.lsp")
(probe-file "CLTEST:probe-file.lsp"))
t) t)
(deftest probe-file.error.1 (deftest probe-file.error.1
...@@ -36,6 +41,6 @@ ...@@ -36,6 +41,6 @@
(classify-error (probe-file (make-pathname :name :wild))) (classify-error (probe-file (make-pathname :name :wild)))
file-error) file-error)
(deftest probe-file.error.4
(classify-error (probe-file "CLTEST:*.FOO"))
file-error)
...@@ -83,3 +83,13 @@ ...@@ -83,3 +83,13 @@
10 10
(return 'good))) (return 'good)))
good) good)
;;; Variables that are not bound don't have any type constraints
(deftest progv.12
(progv '(x y) '(1)
(locally (declare (special x y) (type nil y))
(values
x
(boundp 'y))))
1 nil)
...@@ -107,7 +107,8 @@ ...@@ -107,7 +107,8 @@
(loop for i from 1 to n (loop for i from 1 to n
do (when (= (mod i 100) 0) do (when (= (mod i 100) 0)
#+sbcl (sb-ext::gc :full t) ;; #+sbcl (print "Do gc...")
;; #+sbcl (sb-ext::gc :full t)
(prin1 i) (princ " ") (finish-output *standard-output*)) (prin1 i) (princ " ") (finish-output *standard-output*))
nconc (let ((result (test-random-integer-form size nvars))) nconc (let ((result (test-random-integer-form size nvars)))
(when result (when result
...@@ -391,7 +392,7 @@ ...@@ -391,7 +392,7 @@
(1 `(/ ,(make-random-integer-form (1- size)) -1)) (1 `(/ ,(make-random-integer-form (1- size)) -1))
;; tagbody ;; tagbody
(5 (make-random-tagbody size)) (5 (make-random-tagbody-and-progn size))
;; conditionals ;; conditionals
(20 (20
...@@ -467,19 +468,20 @@ ...@@ -467,19 +468,20 @@
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
`(catch ,tag ,(make-random-integer-form (1- size))))) `(catch ,tag ,(make-random-integer-form (1- size)))))
(4 ;; setq (4 ;; setq and similar
(if *vars* (if *vars*
(let* ((vdesc (random-from-seq *vars*)) (let* ((vdesc (random-from-seq *vars*))
(var (var-desc-name vdesc)) (var (var-desc-name vdesc))
(type (var-desc-type vdesc))) (type (var-desc-type vdesc))
(op (random-from-seq #(setq setf))))
(cond (cond
((equal type '(integer * *)) ((equal type '(integer * *))
`(setq ,var ,(make-random-integer-form (1- size)))) `(,op ,var ,(make-random-integer-form (1- size))))
((and (consp type) ((and (consp type)
(eq (car type) 'integer) (eq (car type) 'integer)
(integerp (second type)) (integerp (second type))
(integerp (third type))) (integerp (third type)))
`(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
;; Abort -- can't assign ;; Abort -- can't assign
(t (make-random-integer-form size)))) (t (make-random-integer-form size))))
(make-random-integer-form size))) (make-random-integer-form size)))
...@@ -589,25 +591,32 @@ ...@@ -589,25 +591,32 @@
(let* ((num-forms (random 6)) (let* ((num-forms (random 6))
(tags nil)) (tags nil))
(loop for i below num-forms (loop for i below num-forms
do (loop for tag = (rcase (1 (random 8)) do (loop for tag = (rcase
(1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8)))) #-acl (1 (random 8))
(1 (random-from-seq #(tag1 tag2 tag3 tag4
tag5 tag6 tag7 tag8))))
while (member tag tags) while (member tag tags)
finally (push tag tags))) finally (push tag tags)))
(assert (= (length (remove-duplicates tags)) (length tags))) (assert (= (length (remove-duplicates tags)) (length tags)))
(let* ((*go-tags* (set-difference *go-tags* tags)) (let* ((*go-tags* (set-difference *go-tags* tags))
(sizes (random-partition (1- size) (1+ num-forms))) (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil))
(forms (forms
(loop for tag-list on tags (loop for tag-list on tags
for i below num-forms for i below num-forms
for size in sizes for size in sizes
collect (let ((*go-tags* (append tag-list *go-tags*))) collect (let ((*go-tags* (append tag-list *go-tags*)))
(make-random-integer-form size)))) (make-random-integer-form size)))))
(final-form (make-random-integer-form (car (last sizes))))) `(tagbody ,@(loop for tag in tags
`(progn (tagbody ,@(loop for tag in tags for form in forms
for form in forms when (atom form) do (setq form `(progn ,form))
when (atom form) do (setq form `(progn ,form)) append `(,form ,tag))))))
append `(,form ,tag)))
,final-form)))) (defun make-random-tagbody-and-progn (size)
(let* ((final-size (random (max 1 (floor size 5))))
(tagbody-size (- size final-size)))
(let ((final-form (make-random-integer-form final-size))
(tagbody-form (make-random-tagbody tagbody-size)))
`(progn ,tagbody-form ,final-form))))
(defun make-random-pred-form (size) (defun make-random-pred-form (size)
"Make a random form whose value is to be used as a generalized boolean." "Make a random form whose value is to be used as a generalized boolean."
...@@ -1065,7 +1074,7 @@ ...@@ -1065,7 +1074,7 @@
(try (eval form))) (try (eval form)))
(prune-fn form try-fn))) (prune-fn form try-fn)))
((setq) ((setq setf)
(try 0) (try 0)
;; Assumes only one assignment ;; Assumes only one assignment
(assert (= (length form) 3)) (assert (= (length form) 3))
......
...@@ -20,10 +20,15 @@ ...@@ -20,10 +20,15 @@
(=t (length results) 3) (=t (length results) 3)
(probe-file pn1) (probe-file pn1)
(notnot (probe-file pn2)) (notnot (probe-file pn2))
(list (notnot (pathnamep defaulted-new-name))
(notnot (pathnamep old-truename))
(notnot (pathnamep new-truename))
(typep old-truename 'logical-pathname)
(typep new-truename 'logical-pathname))
(notnot (probe-file defaulted-new-name)) (notnot (probe-file defaulted-new-name))
(probe-file old-truename) (probe-file old-truename)
(notnot (probe-file new-truename)))))) (notnot (probe-file new-truename))))))
t nil t t nil t) t nil t (t t t nil nil) t nil t)
(deftest rename-file.2 (deftest rename-file.2
(let ((pn1 "file-to-be-renamed.txt") (let ((pn1 "file-to-be-renamed.txt")
...@@ -40,10 +45,15 @@ ...@@ -40,10 +45,15 @@
(=t (length results) 3) (=t (length results) 3)
(probe-file pn1) (probe-file pn1)
(notnot (probe-file pn2)) (notnot (probe-file pn2))
(list (notnot (pathnamep defaulted-new-name))
(notnot (pathnamep old-truename))
(notnot (pathnamep new-truename))
(typep old-truename 'logical-pathname)
(typep new-truename 'logical-pathname))
(notnot (probe-file defaulted-new-name)) (notnot (probe-file defaulted-new-name))
(probe-file old-truename) (probe-file old-truename)
(notnot (probe-file new-truename)))))) (notnot (probe-file new-truename))))))
t nil t t nil t) t nil t (t t t nil nil) t nil t)
(deftest rename-file.3 (deftest rename-file.3
(let* ((pn1 (make-pathname :name "file-to-be-renamed" (let* ((pn1 (make-pathname :name "file-to-be-renamed"
...@@ -67,10 +77,15 @@ ...@@ -67,10 +77,15 @@
(=t (length results) 3) (=t (length results) 3)
(probe-file pn1) (probe-file pn1)
(notnot (probe-file pn3)) (notnot (probe-file pn3))
(list (notnot (pathnamep defaulted-new-name))
(notnot (pathnamep old-truename))
(notnot (pathnamep new-truename))
(typep old-truename 'logical-pathname)
(typep new-truename 'logical-pathname))
(notnot (probe-file defaulted-new-name)) (notnot (probe-file defaulted-new-name))
(probe-file old-truename) (probe-file old-truename)
(notnot (probe-file new-truename)))))) (notnot (probe-file new-truename))))))
t t nil t t nil t) t t nil t (t t t nil nil) t nil t)
(deftest rename-file.4 (deftest rename-file.4
(let ((pn1 "file-to-be-renamed.txt") (let ((pn1 "file-to-be-renamed.txt")
...@@ -89,10 +104,15 @@ ...@@ -89,10 +104,15 @@
(=t (length results) 3) (=t (length results) 3)
(probe-file pn1) (probe-file pn1)
(notnot (probe-file pn2)) (notnot (probe-file pn2))
(list (notnot (pathnamep defaulted-new-name))
(notnot (pathnamep old-truename))
(notnot (pathnamep new-truename))
(typep old-truename 'logical-pathname)
(typep new-truename 'logical-pathname))
(notnot (probe-file defaulted-new-name)) (notnot (probe-file defaulted-new-name))
(probe-file old-truename) (probe-file old-truename)
(notnot (probe-file new-truename))))))) (notnot (probe-file new-truename)))))))
t nil t t nil t) t nil t (t t t nil nil) t nil t)
(deftest rename-file.5 (deftest rename-file.5
(let ((pn1 "CLTEST:file-to-be-renamed.txt") (let ((pn1 "CLTEST:file-to-be-renamed.txt")
...@@ -109,10 +129,17 @@ ...@@ -109,10 +129,17 @@
(=t (length results) 3) (=t (length results) 3)
(probe-file pn1) (probe-file pn1)
(notnot (probe-file pn2)) (notnot (probe-file pn2))
(list (notnot (pathnamep defaulted-new-name))
(notnot (pathnamep old-truename))
(notnot (pathnamep new-truename))
(typep old-truename 'logical-pathname)
(typep new-truename 'logical-pathname))
(notnot (probe-file defaulted-new-name)) (notnot (probe-file defaulted-new-name))
(probe-file old-truename) (probe-file old-truename)
(notnot (probe-file new-truename)))))) (notnot (probe-file new-truename))
t nil t t nil t) (notnot (typep defaulted-new-name 'logical-pathname))
))))
t nil t (t t t nil nil) t nil t t)
;;; ;;;
......
...@@ -54,6 +54,21 @@ ...@@ -54,6 +54,21 @@
)))) ))))
t nil t t) t nil t t)
(deftest truename.5
(let* ((lpn "CLTEST:foo.txt")
(pn (translate-logical-pathname lpn)))
(unless (probe-file lpn)
(with-open-file (s lpn :direction :output) (format s "Stuff~%")))
(let ((tn (truename lpn)))
(values
(notnot (pathnamep pn))
(if (equalt (pathname-name pn) (pathname-name tn))
t (list (pathname-name pn) (pathname-name tn)))
(if (equalt (pathname-type pn) (pathname-type tn))
t (list (pathname-type pn) (pathname-type tn)))
)))
t t t)
;;; ;;;
(deftest truename.error.1 (deftest truename.error.1
......
...@@ -337,10 +337,18 @@ ...@@ -337,10 +337,18 @@
)) ))
(eval-when (load eval compile) (eval-when (load eval compile)
(setf (logical-pathname-translations "CLTESTROOT") (ignore-errors
`(("**;*.*.*" ,(make-pathname :directory '(:absolute))))) (setf (logical-pathname-translations "CLTESTROOT")
(setf (logical-pathname-translations "CLTEST") `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors)
`(("**;*.*.*" ,(make-pathname)))) :name :wild :type :wild)))))
(ignore-errors
(setf (logical-pathname-translations "CLTEST")
`(("**;*.*.*" ,(make-pathname
:directory (append
(pathname-directory
(truename (make-pathname)))
'(:wild-inferiors))
:name :wild :type :wild)))))
) )
(defparameter *logical-pathnames* (defparameter *logical-pathnames*
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment