make-pathname.lsp 4.75 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Nov 29 05:54:30 2003
;;;; Contains: Tests of MAKE-PATHNAME

(in-package :cl-test)

8 9 10
(defvar *null-pathname*
    (make-pathname))

11 12
(defun make-pathname-test
  (&rest args &key (defaults nil)
sds's avatar
sds committed
13 14 15 16 17 18 19 20 21 22 23 24 25
         (host (if defaults (pathname-host defaults)
                 (pathname-host *default-pathname-defaults*)))
         (device (if defaults (pathname-device defaults)
                   (pathname-device *null-pathname*)))
         (directory (if defaults (pathname-directory defaults)
                      (pathname-directory *null-pathname*)))
         (name (if defaults (pathname-name defaults)
                 (pathname-name  *null-pathname*)))
         (type (if defaults (pathname-type defaults)
                 (pathname-type *null-pathname*)))
         (version (if defaults (pathname-version defaults)
                    (pathname-version *null-pathname*)))
         case)
26 27
  (declare (ignorable case))
  (let* ((vals (multiple-value-list (apply #'make-pathname args)))
sds's avatar
sds committed
28
         (pn (first vals)))
29
    (and (= (length vals) 1)
sds's avatar
sds committed
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
         (typep pn 'pathname)
         (equalp (pathname-host pn) host)
         (equalp (pathname-device pn) device)
         ;; (equalp (pathname-directory pn) directory)
         (let ((pnd (pathname-directory pn)))
           (if (eq directory :wild)
               (member pnd '((:absolute :wild-inferiors)
                             (:absolute :wild))
                       :test #'equal)
             (equalp pnd directory)))
         (equalp (pathname-name pn) name)
         (equalp (pathname-type pn) type)
         (equalp (pathname-version pn) version)
         t)))


46 47 48 49 50 51 52 53 54

(deftest make-pathname.1
  (make-pathname-test)
  t)

(deftest make-pathname.2
  (make-pathname-test :name "foo")
  t)

pfdietz's avatar
pfdietz committed
55 56 57 58 59 60
(deftest make-pathname.2a
  (do-special-strings
   (s "foo")
   (assert (make-pathname-test :name s)))
  nil)

61 62 63 64
(deftest make-pathname.3
  (make-pathname-test :name "foo" :type "txt")
  t)

pfdietz's avatar
pfdietz committed
65 66 67 68 69 70
(deftest make-pathname.3a
  (do-special-strings
   (s "txt")
   (assert (make-pathname-test :name "foo" :type s)))
  nil)

71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
(deftest make-pathname.4
  (make-pathname-test :type "lsp")
  t)

(deftest make-pathname.5
  (make-pathname-test :directory :wild)
  t)

(deftest make-pathname.6
  (make-pathname-test :name :wild)
  t)

(deftest make-pathname.7
  (make-pathname-test :type :wild)
  t)

(deftest make-pathname.8
  (make-pathname-test :version :wild)
  t)
pfdietz's avatar
pfdietz committed
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110

(deftest make-pathname.9
  (make-pathname-test :defaults *default-pathname-defaults*)
  t)

(deftest make-pathname.10
  (make-pathname-test :defaults (make-pathname :name "foo" :type "bar"))
  t)

(deftest make-pathname.11
  (make-pathname-test :version :newest)
  t)

(deftest make-pathname.12
  (make-pathname-test :case :local)
  t)

(deftest make-pathname.13
  (make-pathname-test :case :common)
  t)

111 112
(deftest make-pathname.14
  (let ((*default-pathname-defaults*
sds's avatar
sds committed
113
         (make-pathname :name "foo" :type "lsp" :version :newest)))
114 115 116
    (make-pathname-test))
  t)

117 118 119
;;; Works on the components of actual pathnames
(deftest make-pathname.rebuild
  (loop for p in *pathnames*
sds's avatar
sds committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
        for host = (pathname-host p)
        for device = (pathname-device p)
        for directory = (pathname-directory p)
        for name = (pathname-name p)
        for type = (pathname-type p)
        for version = (pathname-version p)
        for p2 = (make-pathname
                  :host host
                  :device device
                  :directory directory
                  :name name
                  :type type
                  :version version)
        unless (equal p p2)
        collect (list p p2))
135 136
  nil)

pfdietz's avatar
pfdietz committed
137 138 139
;;; Various constraints on :directory

(deftest make-pathname-error-absolute-up
140
  (signals-error (directory (make-pathname :directory '(:absolute :up)))
sds's avatar
sds committed
141
                 file-error)
142
  t)
pfdietz's avatar
pfdietz committed
143 144

(deftest make-pathname-error-absolute-back
145
  (signals-error (directory (make-pathname :directory '(:absolute :back)))
sds's avatar
sds committed
146
                 file-error)
147
  t)
pfdietz's avatar
pfdietz committed
148 149 150 151 152

;; The next test is correct, but was causing very large amounts of time to be spent
;; in buggy implementations
#|
(deftest make-pathname-error-absolute-wild-inferiors-up
153
  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up)))
sds's avatar
sds committed
154
                 file-error)
155
  t)
pfdietz's avatar
pfdietz committed
156 157 158
|#

(deftest make-pathname-error-relative-wild-inferiors-up
159
  (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up))))
sds's avatar
sds committed
160
                 file-error)
161
  t)
pfdietz's avatar
pfdietz committed
162 163

(deftest make-pathname-error-absolute-wild-inferiors-back
164
  (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back)))
sds's avatar
sds committed
165
                 file-error)
166
  t)
pfdietz's avatar
pfdietz committed
167 168

(deftest make-pathname-error-relative-wild-inferiors-back
169
  (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back)))
sds's avatar
sds committed
170
                 file-error)
171
  t)