Changeset 8237

Timestamp:

Jan 22, 2008, 9:50:07 PM (17 years ago)

Author:

Gary Byers

Message:

Handle and use (%CREATE-FILE ... :IF-EXISTS NIL).

Location:

trunk/source/level-1

Files:

• l1-files.lisp (modified) (1 diff)
• l1-streams.lisp (modified) (1 diff)
• l1-sysio.lisp (modified) (1 diff)

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

@@ -193 +193 @@
   (when (directory-pathname-p path)
     (return-from %create-file (probe-file-x path)))
-  (assert (or (eql if-exists :overwrite) (not (probe-file path))) ()
+  (assert (or (eql if-exists :overwrite)
+              (null if-exists)
+              (not (probe-file path))) ()
           "~s ~s not implemented yet" :if-exists if-exists)
   (let* ((unix-name (native-translated-namestring path))
-         (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC))))
+         (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC
+                                        (if (null if-exists)
+                                          #$O_EXCL
+                                          0)))))
     (if (< fd 0)
-      (signal-file-error fd path)
+      (if (eql fd (- #$EEXIST))         ; #$O_EXCL was set and file exists
+        (return-from %create-file nil)
+        (signal-file-error fd path))
       (fd-close fd))
     (%realpath unix-name)))

trunk/source/level-1/l1-streams.lisp

@@ -5577 +5577 @@
          (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path)))
     (loop
-      (when (not (probe-file tem-path)) (return tem-path))
+      (when (%create-file tem-path :if-exists nil) (return tem-path))
       (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date)))))))
 

trunk/source/level-1/l1-sysio.lisp

@@ -773 +773 @@
               (return-from open nil)))
           (if (setq filename (if-does-not-exist if-does-not-exist filename))
-            (setq native-truename (%create-file filename))
+            (unless (setq native-truename (%create-file filename :if-exists if-exists))
+              (return-from open nil))
             (return-from open nil)))
         (let* ((fd (fd-open native-truename (case direction