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 @@
;; unless (pathname-match-p pn pattern-pathname)
;; 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
(classify-error (directory))
......
......@@ -134,7 +134,8 @@
)))
2 t t t "")
;; FIXME
;; Need to add a LPN test
(deftest ensure-directories-exist.error.1
(classify-error
......
......@@ -52,6 +52,9 @@
author))
nil)
;;; FIXME
;;; Add LPN test
;;; Error tests
(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 @@
(length (multiple-value-list (file-write-date "file-write-date.lsp")))
1)
;;; FIXME
;;; Add LPN test
;;;
(deftest file-write-date.error.1
......@@ -71,5 +74,3 @@
(file-write-date (make-pathname :name "file-write-date" :type :wild
:defaults *default-pathname-defaults*)))
file-error)
......@@ -12,4 +12,5 @@
(load "file-author.lsp")
(load "file-write-date.lsp")
(load "rename-file.lsp")
(load "delete-file.lsp")
(load "file-error.lsp")
......@@ -14,3 +14,12 @@
(symbol-value
(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 @@
(deftest probe-file.2
(let ((s (open #p"probe-file.lsp" :direction :input)))
(prog1
(equalp (truename #p"probe-file.lsp")
(probe-file s))
(equalpt (truename #p"probe-file.lsp")
(probe-file s))
(close s)))
t)
(deftest probe-file.3
(let ((s (open #p"probe-file.lsp" :direction :input)))
(close s)
(equalp (truename #p"probe-file.lsp")
(probe-file s)))
(equalpt (truename #p"probe-file.lsp")
(probe-file s)))
t)
(deftest probe-file.4
(equalpt (truename #p"probe-file.lsp")
(probe-file "CLTEST:probe-file.lsp"))
t)
(deftest probe-file.error.1
......@@ -36,6 +41,6 @@
(classify-error (probe-file (make-pathname :name :wild)))
file-error)
(deftest probe-file.error.4
(classify-error (probe-file "CLTEST:*.FOO"))
file-error)
......@@ -83,3 +83,13 @@
10
(return '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 @@
(loop for i from 1 to n
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*))
nconc (let ((result (test-random-integer-form size nvars)))
(when result
......@@ -391,7 +392,7 @@
(1 `(/ ,(make-random-integer-form (1- size)) -1))
;; tagbody
(5 (make-random-tagbody size))
(5 (make-random-tagbody-and-progn size))
;; conditionals
(20
......@@ -467,19 +468,20 @@
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
`(catch ,tag ,(make-random-integer-form (1- size)))))
(4 ;; setq
(4 ;; setq and similar
(if *vars*
(let* ((vdesc (random-from-seq *vars*))
(var (var-desc-name vdesc))
(type (var-desc-type vdesc)))
(type (var-desc-type vdesc))
(op (random-from-seq #(setq setf))))
(cond
((equal type '(integer * *))
`(setq ,var ,(make-random-integer-form (1- size))))
`(,op ,var ,(make-random-integer-form (1- size))))
((and (consp type)
(eq (car type) 'integer)
(integerp (second 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
(t (make-random-integer-form size))))
(make-random-integer-form size)))
......@@ -589,25 +591,32 @@
(let* ((num-forms (random 6))
(tags nil))
(loop for i below num-forms
do (loop for tag = (rcase (1 (random 8))
(1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8))))
do (loop for tag = (rcase
#-acl (1 (random 8))
(1 (random-from-seq #(tag1 tag2 tag3 tag4
tag5 tag6 tag7 tag8))))
while (member tag tags)
finally (push tag tags)))
(assert (= (length (remove-duplicates tags)) (length 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
(loop for tag-list on tags
for i below num-forms
for size in sizes
collect (let ((*go-tags* (append tag-list *go-tags*)))
(make-random-integer-form size))))
(final-form (make-random-integer-form (car (last sizes)))))
`(progn (tagbody ,@(loop for tag in tags
for form in forms
when (atom form) do (setq form `(progn ,form))
append `(,form ,tag)))
,final-form))))
(make-random-integer-form size)))))
`(tagbody ,@(loop for tag in tags
for form in forms
when (atom form) do (setq form `(progn ,form))
append `(,form ,tag))))))
(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)
"Make a random form whose value is to be used as a generalized boolean."
......@@ -1065,7 +1074,7 @@
(try (eval form)))
(prune-fn form try-fn)))
((setq)
((setq setf)
(try 0)
;; Assumes only one assignment
(assert (= (length form) 3))
......
......@@ -20,10 +20,15 @@
(=t (length results) 3)
(probe-file pn1)
(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))
(probe-file old-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
(let ((pn1 "file-to-be-renamed.txt")
......@@ -40,10 +45,15 @@
(=t (length results) 3)
(probe-file pn1)
(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))
(probe-file old-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
(let* ((pn1 (make-pathname :name "file-to-be-renamed"
......@@ -67,10 +77,15 @@
(=t (length results) 3)
(probe-file pn1)
(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))
(probe-file old-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
(let ((pn1 "file-to-be-renamed.txt")
......@@ -89,10 +104,15 @@
(=t (length results) 3)
(probe-file pn1)
(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))
(probe-file old-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
(let ((pn1 "CLTEST:file-to-be-renamed.txt")
......@@ -109,10 +129,17 @@
(=t (length results) 3)
(probe-file pn1)
(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))
(probe-file old-truename)
(notnot (probe-file new-truename))))))
t nil t t nil t)
(notnot (probe-file new-truename))
(notnot (typep defaulted-new-name 'logical-pathname))
))))
t nil t (t t t nil nil) t nil t t)
;;;
......
......@@ -54,6 +54,21 @@
))))
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
......
......@@ -337,10 +337,18 @@
))
(eval-when (load eval compile)
(setf (logical-pathname-translations "CLTESTROOT")
`(("**;*.*.*" ,(make-pathname :directory '(:absolute)))))
(setf (logical-pathname-translations "CLTEST")
`(("**;*.*.*" ,(make-pathname))))
(ignore-errors
(setf (logical-pathname-translations "CLTESTROOT")
`(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors)
: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*
......
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