Commit 542aea4a authored by Sergey Katrevich's avatar Sergey Katrevich
Browse files

temporary files creating get more robust, it also has resolved bug for sbcl...

temporary files creating get more robust, it also has resolved bug for sbcl for windows <= 1.3.15 (error 'File exists', see #1 )
parent 1b0a0fd9
......@@ -551,12 +551,64 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(setf *temporary-directory* (default-temporary-directory))
#+gcl (setf system::*tmp-dir* *temporary-directory*))
;;; Support for call-with-temporary-file
;;; (required for windows sbcl <= 1.3.15 where is problem: https://bugs.launchpad.net/sbcl/+bug/1674437 )
(defun random-mini ()
(let (v1 v2)
(setf v1 (get-internal-real-time))
(sleep (/ 1.0 internal-time-units-per-second 2.0))
(setf v2 (get-internal-real-time))
(1+ (- v2 v1))))
#|
;; For discovering quality mini-random numbers
(defun get-incf-variants-frequency (repeat)
(loop repeat repeat
for n = (random-mini)
if (= 1 n) count t into res-1
if (= 2 n) count t into res-2
if (= 3 n) count t into res-3
finally (return `((1 ,res-1) (2 ,res-2) (3 ,res-3)))))
|#
;; Results of checking quality "random-mini" numbers
;(get-incf-variants-frequency 100)
;((1 41) (2 59) (3 0))
;(get-incf-variants-frequency 1000)
;((1 426) (2 573) (3 1))
;(get-incf-variants-frequency 10000)
;((1 4246) (2 5744) (3 6))
(defun temp-name-extra-part ()
(format nil "-~36R-~36R" (get-universal-time) (+ (get-internal-real-time) (random-mini))))
#| Checking quality extra-suffix for temporary filenames
(let* ((res (loop repeat 10 collect (temp-name-extra-part)))
(res-cleaned (remove-duplicates res :test #'string=)))
(list res res-cleaned (length res-cleaned)))
=> (("-1P91IWH-5QRXF" "-1P91IWH-5QRXG" "-1P91IWH-5QRXH" "-1P91IWH-5QRXI"
"-1P91IWH-5QRXI" "-1P91IWH-5QRXJ" "-1P91IWH-5QRXK" "-1P91IWH-5QRXK"
"-1P91IWH-5QRXL" "-1P91IWH-5QRXL")
("-1P91IWH-5QRXF" "-1P91IWH-5QRXG" "-1P91IWH-5QRXH" "-1P91IWH-5QRXI"
"-1P91IWH-5QRXJ" "-1P91IWH-5QRXK" "-1P91IWH-5QRXL")
7)
|#
(defparameter *temp-filenames-extra-part-p* t)
(defparameter *max-attempts-create-temp-file* 1000)
;;; end Support for call-with-temporary-file
(defun call-with-temporary-file
(thunk &key
(want-stream-p t) (want-pathname-p t) (direction :io) keep after
directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
(element-type *default-stream-element-type*)
(external-format *utf-8-external-format*))
(external-format *utf-8-external-format*)
(temp-filenames-extra-part-p *temp-filenames-extra-part-p*))
"Call a THUNK with stream and/or pathname arguments identifying a temporary file.
The temporary file's pathname will be based on concatenating
......@@ -591,10 +643,20 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
:with prefix-nns = (native-namestring prefix-pn)
:with results = (progn (ensure-directories-exist prefix-pn)
())
:for attempts-count :from 0
:for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
:for pathname = (parse-native-namestring
(format nil "~A~36R~@[~A~]~@[.~A~]"
prefix-nns counter suffix (unless (eq type :unspecific) type)))
:for pathname = (loop
for pathname = (parse-native-namestring
(format nil "~A~36R~@[~A~]~@[~A~]~@[.~A~]"
prefix-nns
counter
(when temp-filenames-extra-part-p
(temp-name-extra-part))
suffix
(unless (eq type :unspecific) type)))
while (probe-file* pathname)
finally (return pathname))
:for okp = nil :do
;; TODO: on Unix, do something about umask
;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
......@@ -604,20 +666,25 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
(unwind-protect
(progn
(ensure-directories-exist pathname)
(with-open-file (stream pathname
:direction direction
:element-type element-type
:external-format external-format
:if-exists nil :if-does-not-exist :create)
(when stream
(setf okp pathname)
(when want-stream-p
;; Note: can't return directly from within with-open-file
;; or the non-local return causes the file creation to be undone.
(setf results (multiple-value-list
(if want-pathname-p
(funcall thunk stream pathname)
(funcall thunk stream)))))))
(handler-case
(with-open-file (stream pathname
:direction direction
:element-type element-type
:external-format external-format
:if-exists nil :if-does-not-exist :create)
(when stream
(setf okp pathname)
(when want-stream-p
;; Note: can't return directly from within with-open-file
;; or the non-local return causes the file creation to be undone.
(setf results (multiple-value-list
(if want-pathname-p
(funcall thunk stream pathname)
(funcall thunk stream)))))))
(file-error (err)
(when (> (incf attempts-count) *max-attempts-create-temp-file*)
(error err))))
(cond
((not okp) nil)
(after (return (call-function after okp)))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment