From f7c047cafd84b556398014c4932c90dba55a5c0d Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Thu, 22 Aug 2013 02:05:02 +0400 Subject: [PATCH] Fix OPEN when :if-exists/:if-does-not-exist are both NIL or :ERROR. Such combination results in OPEN never actually opening a file, only either signalling an error or returning NIL. Reported by Jan Moringen. --- NEWS | 2 + src/code/fd-stream.lisp | 309 +++++++++++++++++++++++++---------------------- tests/filesys.pure.lisp | 31 +++++ 3 files changed, 196 insertions(+), 146 deletions(-) diff --git a/NEWS b/NEWS index c377988..793d4a0 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,8 @@ changes relative to sbcl-1.1.10 * bug fix: ROOM works again on Windows. * bug fix: Streams were flushed even when there was one byte still left in the buffer. (lp#910213) + * bug fix: OPEN handles correctly when :if-exists and :if-does-not-exist are + either NIL or :ERROR. changes in sbcl-1.1.10 relative to sbcl-1.1.9: * enhancement: ASDF has been updated to 3.0.2. diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 8c0ca30..c583f17 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -2289,12 +2289,12 @@ (defun open (filename &key - (direction :input) - (element-type 'base-char) - (if-exists nil if-exists-given) - (if-does-not-exist nil if-does-not-exist-given) - (external-format :default) - &aux ; Squelch assignment warning. + (direction :input) + (element-type 'base-char) + (if-exists nil if-exists-given) + (if-does-not-exist nil if-does-not-exist-given) + (external-format :default) + &aux ; Squelch assignment warning. (direction direction) (if-does-not-exist if-does-not-exist) (if-exists if-exists)) @@ -2316,7 +2316,7 @@ (:io (values t t sb!unix:o_rdwr)) (:probe (values t nil sb!unix:o_rdonly))) (declare (type index mask)) - (let* (;; PATHNAME is the pathname we associate with the stream. + (let* ( ;; PATHNAME is the pathname we associate with the stream. (pathname (merge-pathnames filename)) (physical (physicalize-pathname pathname)) (truename (probe-file physical)) @@ -2327,147 +2327,164 @@ (and input (eq if-does-not-exist :create)) (and (eq direction :io) (not if-does-not-exist-given))) (native-namestring physical :as-file t))))) - ;; 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 ((eq if-does-not-exist :create) + (setf mask (logior mask sb!unix:o_creat))) + ((not (member if-exists '(:new-version :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)) + ((sb!unix:unix-stat namestring) + (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 "~@" + pathname)) + (t nil))) + ((and (eql errno sb!unix:eexist) (null if-exists)) nil) (t - :create)))) - (ensure-one-of if-does-not-exist - '(:error :create nil) - :if-does-not-exist) - (if (eq if-does-not-exist :create) - (setf mask (logior mask sb!unix:o_creat))) - - (let ((original (case if-exists - ((:rename :rename-and-delete) - (pick-backup-name namestring)) - ((:append :overwrite) - ;; KLUDGE: Provent 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)) - (labels ((open-error (format-control &rest format-arguments) - (error 'simple-file-error - :pathname pathname - :format-control format-control - :format-arguments format-arguments)) - (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 "~@" - pathname)) - (t nil))) - ((and (eql errno sb!unix:eexist) (null if-exists)) - nil) - (t - (vanilla-open-error))))))))) + (vanilla-open-error)))))))))) ;;;; initialization diff --git a/tests/filesys.pure.lisp b/tests/filesys.pure.lisp index a08e134..554fa07 100644 --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp @@ -191,3 +191,34 @@ (directory (make-pathname :name :unspecific :type :unspecific))))) + +;;; Generated with +;;; (loop for exist in '(nil t) +;;; append +;;; (loop for (if-exists if-does-not-exist) in '((nil :error) +;;; (:error nil) +;;; (nil nil) +;;; (:error :error)) +;;; collect (list 'do-open exist if-exists if-does-not-exist))) +(with-test (:name :open-never-openning) + (flet ((do-open (existing if-exists if-does-not-exist) + (open (if existing + #.(or *compile-file-truename* *load-truename*) + "a-really-non-existing-file") + :direction :output + :if-exists if-exists :if-does-not-exist if-does-not-exist))) + (assert (raises-error? + (do-open nil nil :error))) + (assert (not + (do-open nil :error nil))) + (assert (not + (do-open t nil :error))) + (assert (raises-error? + (do-open t :error nil))) + (assert (not + (do-open nil nil nil))) + (assert (raises-error? + (do-open nil :error :error))) + (assert (not + (do-open t nil nil))) + (assert (raises-error? (do-open t :error :error))))) -- 1.7.10.4