Changeset 437

Timestamp:

Jan 30, 2004, 3:51:38 PM (21 years ago)

Author:

Gary Byers

Message:

IF-EXISTS: dialog nonsense. PROBE-FILE checks WILD-PATHNAME-P, which moved
here.

File:

• trunk/ccl/level-1/l1-files.lisp (modified) (3 diffs)

trunk/ccl/level-1/l1-files.lisp

@@ -62 +62 @@
   (case if-exists
     (:error (signal-file-error (- #$EEXIST) filename))
-    ((:dialog :new-version :rename) (overwrite-dialog filename prompt))
+    ((:dialog) (overwrite-dialog filename prompt))
     ((nil) nil)
-    ((:ignored :overwrite :append :supersede :rename-and-delete) filename)
+    ((:ignored :overwrite :append :supersede :rename-and-delete :new-version :rename) filename)
     (t (report-bad-arg if-exists '(member :error :dialog nil :ignored :overwrite :append :supersede :rename-and-delete)))))
 
@@ -130 +130 @@
 
 (defun probe-file (path)
+  (when (wild-pathname-p path)
+    (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
+           :pathname path))
   (let* ((native (native-translated-namestring path))
          (realpath (%realpath native))
@@ -1210 +1213 @@
             (return path))))))
 
+(defun wild-pathname-p (pathname &optional field-key)
+  (flet ((wild-p (name) (or (eq name :wild)
+                            (eq name :wild-inferiors)
+                            (and (stringp name) (%path-mem "*" name)))))
+    (case field-key
+      ((nil)
+       (or (some #'wild-p (pathname-directory pathname))
+           (wild-p (pathname-name pathname))
+           (wild-p (pathname-type pathname))
+           (wild-p (pathname-version pathname))))
+      (:host nil)
+      (:device nil)
+      (:directory (some #'wild-p (pathname-directory pathname)))
+      (:name (wild-p (pathname-name pathname)))
+      (:type (wild-p (pathname-type pathname)))
+      (:version (wild-p (pathname-version pathname)))
+      (t (wild-pathname-p pathname
+                          (require-type field-key 
+                                        '(member nil :host :device 
+                                          :directory :name :type :version)))))))