Add a special parameter allowing the developer to control the filenam…

…e of the uploaded file before being written to disk.

doc/index.xml

@@ -1749,6 +1749,17 @@
         </clix:description>
       </clix:special-variable>
 
+      <clix:special-variable name='*upload-filename-generator*'>
+        <clix:description>
+         A filename designator for the uploaded file being written
+         to disk. It defaults to <code>NIL</code> in which case the internal
+         filename generator will be used. It also can be a <code>STRING</code> 
+         of the filename, a <code>PATHNAME</code>, or a <code>SYMBOL</code> 
+         which should be a function without arguments that returns the
+         filename <code>STRING</code>.
+        </clix:description>
+      </clix:special-variable>
+
       <clix:function name="raw-post-data">
         <clix:lambda-list>
           <clix:lkw>key</clix:lkw>

request.lisp

@@ -124,7 +124,7 @@ supposed to be of content type 'multipart/form-data'."
                              "BOUNDARY"
                              (rfc2388:header-parameters parsed-content-type-header)))
 		       (return-from parse-rfc2388-form-data))))
-    (loop for part in (rfc2388:parse-mime stream boundary)
+    (loop for part in (rfc2388:parse-mime stream boundary :write-content-to-file (make-upload-filename))
           for headers = (rfc2388:mime-part-headers part)
           for content-disposition-header = (rfc2388:find-content-disposition-header headers)
           for name = (cdr (rfc2388:find-parameter

specials.lisp

@@ -253,6 +253,13 @@ the debugger).")
 (defvar *tmp-files* nil
   "A list of temporary files created while a request was handled.")
 
+(defparameter *upload-filename-generator* nil
+  "A filename designator to be used by RFC2388 when uploaded file
+   is being written to disk. It defaults to NIL in which case the
+   internal generator is used. It also can be a STRING of the filename,
+   a PATHNAME, or a SYMBOL which should be a function that takes no
+   arguments and return the filename")
+
 (defconstant +latin-1+
   (make-external-format :latin1 :eol-style :lf)
   "A FLEXI-STREAMS external format used for `faithful' input and

util.lisp

@@ -128,8 +128,9 @@ according to HTTP/1.1 \(RFC 2068)."
 (let ((counter 0))
   (declare (ignorable counter))
   (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
-    "Generates a unique name for a temporary file.  This function is
-called from the RFC2388 library when a file is uploaded."
+    "Generates a unique name for a temporary file.  When
+    *upload-filename-generator* is NIL, then this is the default
+     function supplied to RFC2388 library when a file is uploaded."
     (let ((tmp-file-name
            #+:allegro
            (pathname (system:make-temp-file-name prefix *tmp-directory*))
@@ -141,11 +142,24 @@ called from the RFC2388 library when a file is uploaded."
                  unless (probe-file pathname)
                  return pathname)))
       (push tmp-file-name *tmp-files*)
-      ;; maybe call hook for file uploads
-      (when *file-upload-hook*
-        (funcall *file-upload-hook* tmp-file-name))
       tmp-file-name)))
 
+(defun make-upload-filename ()
+  "This function is used to generate the filename to
+   be passed to RFC2388 library. There it will be used
+   for the content being written to the disk."
+  (let ((filename (cond
+                   ((null *upload-filename-generator*)
+                     (funcall 'make-tmp-file-name))
+                   (otherwise
+                    (etypecase *upload-filename-generator*
+                      (string *upload-filename-generator*)
+                      (pathname (namestring *upload-filename-generator*))
+                      (symbol (funcall *upload-filename-generator*))))))) ;
+    (when *file-upload-hook*
+      (funcall *file-upload-hook* filename))
+    filename))
+
 (defun quote-string (string)
   "Quotes string according to RFC 2616's definition of `quoted-string'."
   (with-output-to-string (out)