- ;; Process if-exists argument if we are doing any output.
- (cond (output
- (unless if-exists-given
- (setf if-exists
- (if (eq (pathname-version pathname) :newest)
- :new-version
- :error)))
- (ensure-one-of if-exists
- '(:error :new-version :rename
- :rename-and-delete :overwrite
- :append :supersede nil)
- :if-exists)
- (case if-exists
- ((:new-version :error nil)
- (setf mask (logior mask sb!unix:o_excl)))
- ((:rename :rename-and-delete)
- (setf mask (logior mask sb!unix:o_creat)))
- ((:supersede)
- (setf mask (logior mask sb!unix:o_trunc)))
- (:append
- (setf mask (logior mask sb!unix:o_append)))))
- (t
- (setf if-exists :ignore-this-arg)))
-
- (unless if-does-not-exist-given
- (setf if-does-not-exist
- (cond ((eq direction :input) :error)
- ((and output
- (member if-exists '(:overwrite :append)))
- :error)
- ((eq direction :probe)
+ (flet ((open-error (format-control &rest format-arguments)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control format-control
+ :format-arguments format-arguments)))
+ ;; Process if-exists argument if we are doing any output.
+ (cond (output
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists)
+ (case if-exists
+ ((:new-version :error nil)
+ (setf mask (logior mask sb!unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((:supersede)
+ (setf mask (logior mask sb!unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb!unix:o_append)))))
+ (t
+ (setf if-exists :ignore-this-arg)))
+
+ (unless if-does-not-exist-given
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
+ (ensure-one-of if-does-not-exist
+ '(:error :create nil)
+ :if-does-not-exist)
+ (cond ((and if-exists-given
+ truename
+ (eq if-exists :new-version))
+ (open-error "OPEN :IF-EXISTS :NEW-VERSION is not supported ~
+ when a new version must be created."))
+ ((eq if-does-not-exist :create)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((not (member if-exists '(:error nil))))
+ ;; Both if-does-not-exist and if-exists now imply
+ ;; that there will be no opening of files, and either
+ ;; an error would be signalled, or NIL returned
+ ((and (not if-exists) (not if-does-not-exist))
+ (return-from open))
+ ((and if-exists if-does-not-exist)
+ (open-error "OPEN :IF-DOES-NOT-EXIST ~s ~
+ :IF-EXISTS ~s will always signal an error."
+ if-does-not-exist if-exists))
+ (truename
+ (if if-exists
+ (open-error "File exists ~s." pathname)
+ (return-from open)))
+ (if-does-not-exist
+ (open-error "File does not exist ~s." pathname))
+ (t
+ (return-from open)))
+ (let ((original (case if-exists
+ ((:rename :rename-and-delete)
+ (pick-backup-name namestring))
+ ((:append :overwrite)
+ ;; KLUDGE: Prevent CLOSE from deleting
+ ;; appending streams when called with :ABORT T
+ namestring)))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when (and original (not (eq original namestring)))
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
+ ;; whether the file already exists, make sure the original
+ ;; file is not a directory, and keep the mode.
+ (let ((exists
+ (and namestring
+ (multiple-value-bind (okay err/dev inode orig-mode)
+ (sb!unix:unix-stat namestring)
+ (declare (ignore inode)
+ (type (or index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control
+ "can't open ~S for output: is a directory"
+ :format-arguments (list namestring)))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb!unix:enoent)
+ nil)
+ (t
+ (simple-file-perror "can't find ~S"
+ namestring
+ err/dev)))))))
+ (unless (and exists
+ (rename-the-old-one namestring original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use :SUPERSEDE instead, we have to make
+ ;; sure SB!UNIX:O_CREAT corresponds to
+ ;; IF-DOES-NOT-EXIST. SB!UNIX:O_CREAT was set before
+ ;; because of IF-EXISTS being :RENAME.
+ (unless (eq if-does-not-exist :create)
+ (setf mask
+ (logior (logandc2 mask sb!unix:o_creat)
+ sb!unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Now we can try the actual Unix open(2).
+ (multiple-value-bind (fd errno)
+ (if namestring
+ (sb!unix:unix-open namestring mask mode)
+ (values nil sb!unix:enoent))
+ (flet ((vanilla-open-error ()
+ (simple-file-perror "error opening ~S" pathname errno)))
+ (cond ((numberp fd)
+ (case direction
+ ((:input :output :io)
+ ;; For O_APPEND opened files, lseek returns 0 until first write.
+ ;; So we jump ahead here.
+ (when (eq if-exists :append)
+ (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :external-format external-format
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :dual-channel-p nil
+ :serve-events nil
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream
+ (%make-fd-stream :name namestring
+ :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream))))
+ ((eql errno sb!unix:enoent)
+ (case if-does-not-exist
+ (:error (vanilla-open-error))
+ (:create
+ (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
+ pathname))
+ (t nil)))
+ ((and (eql errno sb!unix:eexist) (null if-exists))