From a6e0188dffc394698d9ffbef50401f14a31c8722 Mon Sep 17 00:00:00 2001
From: Lars Ingebrigtsen <larsi@gnus.org>
Date: Thu, 13 Oct 2016 21:39:29 +0200
Subject: [PATCH] Fix problem with submitting binary data via HTTP forms

* lisp/gnus/mm-url.el (mm-url-encode-multipart-form-data):
Document the parameters, clean up the code, and make uploading
binary data really work (which it didn't if the binary bits
were in the last part of the data).
---
 lisp/gnus/mm-url.el | 75 +++++++++++++++++++++++++--------------------
 1 file changed, 42 insertions(+), 33 deletions(-)

diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el
index cbea134b544..d5debdb3704 100644
--- a/lisp/gnus/mm-url.el
+++ b/lisp/gnus/mm-url.el
@@ -402,43 +402,52 @@ spaces.  Die Die Die."
 
 (autoload 'mml-compute-boundary "mml")
 
-(defun mm-url-encode-multipart-form-data (pairs &optional boundary)
-  "Return PAIRS encoded in multipart/form-data."
+(defun mm-url-encode-multipart-form-data (data &optional boundary)
+  "Return DATA encoded in multipart/form-data.
+DATA is a list where the elements can have the following form:
+  (\"NAME\" . \"VALUE\")
+  (\"submit\")
+  (\"file\" . ((\"name\" . \"NAME\")
+             (\"filename\" . \"FILENAME\")
+             (\"content-type\" . \"CONTENT-TYPE\")
+             (\"filedata\" . \"FILEDATA\")))
+Lowercase names above are literals and uppercase can
+be various values."
   ;; RFC1867
   ;; Get a good boundary
   (unless boundary
     (setq boundary (mml-compute-boundary '())))
-  (concat
-   ;; Start with the boundary
-   "--" boundary "\r\n"
-   ;; Create name value pairs
-   (mapconcat
-    'identity
-    ;; Delete any returned items that are empty
-    (delq nil
-          (mapcar (lambda (data)
-                    (cond ((equal (car data) "file")
-                           ;; For each pair
-                           (format
-                            ;; Encode the name
-                            "Content-Disposition: form-data; name=%S; filename=%S\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Transfer-Encoding: binary\r\n\r\n%s"
-                            (cdr (assoc "name" (cdr data))) (cdr (assoc "filename" (cdr data)))
-                            (cond ((stringp (cdr (assoc "filedata" (cdr data))))
-                                   (cdr (assoc "filedata" (cdr data))))
-                                  ((integerp (cdr (assoc "filedata" (cdr data))))
-                                   (number-to-string (cdr (assoc "filedata" (cdr data))))))))
-                          ((equal (car data) "submit")
-                           "Content-Disposition: form-data; name=\"submit\"\r\n\r\nSubmit\r\n")
-                          (t
-                           (format
-                            "Content-Disposition: form-data;name=%S\r\n\r\n%s\r\n"
-                            (car data) (concat (mm-url-form-encode-xwfu (cdr data)))
-                            ))))
-                  pairs))
-    ;; use the boundary as a separator
-    (concat "\r\n--" boundary "\r\n"))
-   ;; put a boundary at the end.
-   "--" boundary "--\r\n"))
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (cl-loop for (name . value) in data
+	     do (insert "--" boundary "\r\n")
+	        (cond
+		 ((equal name "file")
+		  (insert (format "Content-Disposition: form-data; name=%S; filename=%S\r\n"
+				  (or (cdr (assoc "name" value)) name)
+				  (cdr (assoc "filename" value))))
+		  (insert "Content-Transfer-Encoding: binary\r\n")
+		  (insert (format "Content-Type: %s\r\n\r\n"
+				  (or (cdr (assoc "content-type" value))
+				      "text/plain")))
+		  (let ((filedata (cdr (assoc "filedata" value))))
+		    (cond
+		     ((stringp filedata)
+		      (insert filedata))
+		     ;; How can this possibly be useful?
+		     ((integerp filedata)
+		      (insert (number-to-string filedata))))))
+		 ((equal name "submit")
+		  (insert
+		   "Content-Disposition: form-data; name=\"submit\"\r\n\r\nSubmit\r\n"))
+		 (t
+		  (insert (format "Content-Disposition: form-data; name=%S\r\n\r\n"
+				  name))
+		  (insert value)))
+		(unless (bolp)
+		  (insert "\r\n")))
+    (insert "--" boundary "--\r\n")
+    (buffer-string)))
 
 (defun mm-url-remove-markup ()
   "Remove all HTML markup, leaving just plain text."