+#+sbcl
+(defun unix-link (from to)
+ (sb-unix::int-syscall ("link" sb-alien:c-string sb-alien:c-string)
+ from to))
+
+(defun safe-copy (file tag)
+ "Make a copy of the FILE. Return the new name."
+
+ #+(or cmu sbcl)
+ ;; Use link(2) where available.
+ (generate-fresh-file-name file tag
+ (lambda (name)
+ (let ((from (native-namestring file
+ :as-file t))
+ (to (native-namestring name
+ :as-file t)))
+ (and from to
+ (unix-link from to)))))
+
+ #+clisp
+ (generate-fresh-file-name file tag
+ (lambda (name)
+ (posix:copy-file (namestring file)
+ (namestring name)
+ :method :hardlink
+ :if-exists nil)))
+
+ #-(or cmu sbcl clisp)
+ ;; Otherwise just copy the file contents and hope for the best.
+ (with-open-file (input file :element-type :default)
+ (multiple-value-bind
+ (copy output)
+ (generate-fresh-file-name file tag
+ (lambda (name)
+ (open name
+ :direction :output
+ :if-exists nil
+ :element-type :default)))
+ (unwind-protect
+ (progn
+ (let ((buffer (make-array 8192
+ :element-type (stream-element-type
+ input))))
+ (loop
+ (let ((read (read-sequence buffer input)))
+ (when (plusp read)
+ (write-sequence buffer output :end read))
+ (when (< read (length buffer))
+ (return copy))))))
+ (close output)))))
+