Changeset 14712

Timestamp:

Apr 14, 2011, 3:53:47 PM (8 years ago)

Author:

rme

Message:

Merge r14662 from trunk.

Closes ticket:843.

Location:

release/1.6/source

Files:

• . (modified) (1 prop)
• level-0/l0-misc.lisp (modified) (1 prop)
• level-1/l1-files.lisp (modified) (1 diff)
• level-1/l1-sysio.lisp (modified) (2 diffs)

release/1.6/source/level-1/l1-files.lisp

@@ -213 +213 @@
   (when (directory-pathname-p path)
     (return-from %create-file (probe-file-x path)))
-  (assert (or (eql if-exists :overwrite)
-              (null if-exists)
-              (eq if-exists :error)
-              (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
-                                        (if (or (null if-exists)
-                                                (eq if-exists :error))
-                                          #$O_EXCL
-                                          0)))))
-    (if (< fd 0)
-      (if (and (null if-exists)
+         (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT
+                                        (if (eq if-exists :overwrite)
+                                          #$O_TRUNC
+                                          #$O_EXCL)))))
+    (when (and (neq if-exists :error)
                (or (eql fd (- #$EEXIST))
                    #+windows-target
                    (and (eql fd (- #$EPERM))
                         (probe-file path))))
-        (return-from %create-file nil)
-        (signal-file-error fd path))
+      (when (null if-exists)
+        (return-from %create-file nil))
+      (error "~s ~s not implemented yet" :if-exists if-exists))
+
+    (if (< fd 0)
+      (signal-file-error fd path)
       (fd-close fd))
     (%realpath unix-name)))

release/1.6/source/level-1/l1-sysio.lisp

@@ -776 +776 @@
       (check-pathname-not-wild filename) ;; probe-file-x misses wild versions....
       (multiple-value-bind (native-truename kind)(probe-file-x filename)
-        (if native-truename
+       (tagbody retry
+        (if native-truename
           (if (eq kind :directory)
             (if (eq direction :probe)
@@ -797 +798 @@
           (if (setq filename (if-does-not-exist if-does-not-exist filename))
             (progn
-              (unless (setq native-truename (%create-file filename :if-exists if-exists))
-                (return-from open nil))
+              (unless (setq native-truename (%create-file filename :if-exists (case if-exists
+                                                                                ;; Let %create file handle these cases
+                                                                                ((:error :overwrite) if-exists)
+                                                                                (t nil))))
+                ;; Somebody else created the file while we're trying to create it.
+                (when (null if-exists) (return-from open nil))
+                (multiple-value-setq (native-truename kind) (probe-file-x filename))
+                (unless native-truename ;; huh?  Perhaps it disappeared again?
+                  (error "Attempt to create ~s failed unexpectedly" filename))
+                (go retry))
               (setq created t))
-            (return-from open nil)))
+            (return-from open nil))))
         (let* ((fd (fd-open native-truename (case direction
                                               ((:probe :input) #$O_RDONLY)