diff --git a/doc/index.xml b/doc/index.xml index 261bbb3..549b29d 100644 --- a/doc/index.xml +++ b/doc/index.xml @@ -1751,12 +1751,12 @@ - A filename designator for the uploaded file being written - to disk. It defaults to NIL in which case the internal - filename generator will be used. It also can be a STRING - of the filename, a PATHNAME, or a SYMBOL - which should be a function without arguments that returns the - filename STRING. + This is used to control how filename generation for the files being uploaded. + It defaults to NIL in which case the internal filename + generator will be used. It can also be a SYMBOL (designating + a function) or a Function, in both cases the function should + have signature of (&key file-name field-name content-type), and should + return a filename to be used by the server to which uploaded content is written. diff --git a/request.lisp b/request.lisp index 7e1007a..8e3037f 100644 --- a/request.lisp +++ b/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 :write-content-to-file (make-upload-filename)) + (loop for part in (rfc2388:parse-mime stream boundary :write-content-to-file (make-upload-filename-generator)) for headers = (rfc2388:mime-part-headers part) for content-disposition-header = (rfc2388:find-content-disposition-header headers) for name = (cdr (rfc2388:find-parameter diff --git a/specials.lisp b/specials.lisp index ebdc4dd..3accfb7 100644 --- a/specials.lisp +++ b/specials.lisp @@ -254,11 +254,13 @@ the debugger).") "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") + "This is used to control how filename generation for the files +being uploaded. It defaults to NIL in which case the internal +filename generator will be used. It can also be a SYMBOL (designating +a function) or a Function, in both cases the function should have +signature of (&key file-name field-name content-type), and should +return a filename to be used by the server to which uploaded content +is written.") (defconstant +latin-1+ (make-external-format :latin1 :eol-style :lf) diff --git a/util.lisp b/util.lisp index 5606b55..61d2e4e 100644 --- a/util.lisp +++ b/util.lisp @@ -128,9 +128,8 @@ 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. When - *upload-filename-generator* is NIL, then this is the default - function supplied to RFC2388 library when a file is uploaded." + "Generates a unique name for a temporary file. This function is +called from the RFC2388 library when a file is uploaded." (let ((tmp-file-name #+:allegro (pathname (system:make-temp-file-name prefix *tmp-directory*)) @@ -142,23 +141,27 @@ according to HTTP/1.1 \(RFC 2068)." 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 make-upload-filename-generator () + "Based on the value of *upload-filename-generator*, arrange +for a suitable filename generator to be used by RFC2388 library +when a file is being uploaded." + (etypecase *upload-filename-generator* + ;; the old behaviour. + (null (lambda (&rest args) + (declare (ignore args)) + (funcall #'make-tmp-file-name))) + ;; the new additional behaviour. + ((or symbol function) + (lambda (&rest args) + (let ((filename (apply *upload-filename-generator* args :allow-other-keys t))) + (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'."