- (push `(:delete ,file ,(fresh-file-name file "del")) (safely-trail safe)))
-
-(defun fresh-file-name (base tag)
- "Return a fresh file name constructed from BASE and TAG in the current
- directory. Do not assume that this filename will be good by the time you
- try to create the file."
- (let ((name (format nil "~A.~A-~X"
- base tag (random most-positive-fixnum))))
- (if (probe-file name) (fresh-file-name base tag) name)))
+ (push `(:delete ,file) (safely-trail safe)))
+
+(defun generate-fresh-file-name (base tag &optional func)
+ "Return a fresh file name constructed from BASE (a filespec) and TAG (some
+ short descriptive string). The generated name has the same directory and
+ type as the BASE name, but a different name.
+
+ If FUNC is non-nil, then it is a function to call on the generated file
+ name: generate-fresh-file-name runs in a loop, calling FUNC with generated
+ file names until FUNC returns non-nil, at which point generate-fresh-
+ file-name returns two values: the generated name, and the result of FUNC.
+ generate-fresh-file-name catches errors of type file-error from FUNC, and
+ just tries again with a new name.
+
+ If FUNC is nil, it's treated the same as a function which always returns
+ t.
+
+ This is inspired by a similar facility in scsh."
+ (let ((base (pathname base)))
+ (dotimes (i 256
+ (error "Gave up trying to find a temporary ~A file for ~S."
+ tag base))
+ (let* ((new (merge-pathnames
+ (make-pathname
+ :name (format nil "~A-~A-~X"
+ (pathname-name base)
+ tag
+ (random most-positive-fixnum)))
+ base))
+ (ret (and (not (probe-file new))
+ (if func
+ (handler-case (funcall func new)
+ (file-error (cond)
+ (unless (pathname-match-p
+ (file-error-pathname cond)
+ new)
+ (error cond))
+ nil))
+ t))))
+ (when ret
+ (return (values new ret)))))))