X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-encode.el;h=770d1063a2708aafa571899c53357fdb5d6336ce;hb=refs%2Ftags%2Ft-gnus-6_15_24-00;hp=875d12ffe5a0ad9935949fc61dbe53e9d68ef918;hpb=a3fbfe62d8a31ca9b3c0d18a4895e3a8924fc176;p=elisp%2Fgnus.git-

diff --git a/lisp/mm-encode.el b/lisp/mm-encode.el
index 875d12f..770d106 100644
--- a/lisp/mm-encode.el
+++ b/lisp/mm-encode.el
@@ -1,9 +1,10 @@
 ;;; mm-encode.el --- Functions for encoding MIME things
-;; Copyright (C) 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; This file is not yet part of GNU Emacs.
+;; This file is part of GNU Emacs.
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -24,178 +25,164 @@
 
 ;;; Code:
 
-(defvar mm-header-encoding-alist
-  '(("X-Nsubject" . iso-2022-jp-2)
-    ("Newsgroups" . nil)
-    ("Message-ID" . nil)
-    (t . mime))
-  "*Header/encoding method alist.
-The list is traversed sequentially.  The keys can either be a
-header regexp or `t'.
-
-The values can be:
-
-1) nil, in which case no encoding is done;
-2) `mime', in which case the header will be encoded according to RFC1522;
-3) a charset, in which case it will be encoded as that charse;
-4) `default', in which case the field will be encoded as the rest
-   of the article.")
-
-(defvar mm-mime-mule-charset-alist
-  '((us-ascii ascii)
-    (iso-8859-1 latin-iso8859-1)
-    (iso-8859-2 latin-iso8859-2)
-    (iso-8859-3 latin-iso8859-3)
-    (iso-8859-4 latin-iso8859-4)
-    (iso-8859-5 cyrillic-iso8859-5)
-    (koi8-r cyrillic-iso8859-5)
-    (iso-8859-6 arabic-iso8859-6)
-    (iso-8859-7 greek-iso8859-7)
-    (iso-8859-8 hebrew-iso8859-8)
-    (iso-8859-9 latin-iso8859-9)
-    (iso-2022-jp latin-jisx0201
-		 japanese-jisx0208-1978 japanese-jisx0208)
-    (euc-kr korean-ksc5601)
-    (cn-gb-2312 chinese-gb2312)
-    (cn-big5 chinese-big5-1 chinese-big5-2)
-    (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7
-		   latin-jisx0201 japanese-jisx0208-1978
-		   chinese-gb2312 japanese-jisx0208
-		   korean-ksc5601 japanese-jisx0212)
-    (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7
-		    latin-jisx0201 japanese-jisx0208-1978
-		    chinese-gb2312 japanese-jisx0208
-		    korean-ksc5601 japanese-jisx0212
-		    chinese-cns11643-1 chinese-cns11643-2)
-    (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2
-		    cyrillic-iso8859-5 greek-iso8859-7
-		    latin-jisx0201 japanese-jisx0208-1978
-		    chinese-gb2312 japanese-jisx0208
-		    korean-ksc5601 japanese-jisx0212
-		    chinese-cns11643-1 chinese-cns11643-2
-		    chinese-cns11643-3 chinese-cns11643-4
-		    chinese-cns11643-5 chinese-cns11643-6
-		    chinese-cns11643-7))
-  "Alist of MIME-charset/MULE-charsets.")
-
-(defvar mm-mime-charset-encoding-alist
-  '((us-ascii . nil)
-    (iso-8859-1 . Q)
-    (iso-8859-2 . Q)
-    (iso-8859-3 . Q)
-    (iso-8859-4 . Q)
-    (iso-8859-5 . Q)
-    (koi8-r . Q)
-    (iso-8859-7 . Q)
-    (iso-8859-8 . Q)
-    (iso-8859-9 . Q)
-    (iso-2022-jp . B)
-    (iso-2022-kr . B)
-    (gb2312 . B)
-    (cn-gb . B)
-    (cn-gb-2312 . B)
-    (euc-kr . B)
-    (iso-2022-jp-2 . B)
-    (iso-2022-int-1 . B))
-  "Alist of MIME charsets to MIME encodings.
-Valid encodings are nil, `Q' and `B'.")
-
-(defvar mm-mime-encoding-function-alist
-  '((Q . quoted-printable-encode-region)
-    (B . base64-encode-region)
-    (nil . ignore))
-  "Alist of MIME encodings to encoding functions.")
-
-(defun mm-encode-message-header ()
-  "Encode the message header according to `mm-header-encoding-alist'."
-  (when (featurep 'mule)
-    (save-excursion
-      (save-restriction
-	(message-narrow-to-headers)
-	(let ((alist mm-header-encoding-alist)
-	      elem method)
-	  (while (not (eobp))
-	    (save-restriction
-	      (message-narrow-to-field)
-	      (when (find-non-ascii-charset-region (point-min) (point-max))
-		;; We found something that may perhaps be encoded.
-		(while (setq elem (pop alist))
-		  (when (or (and (stringp (car elem))
-				 (looking-at (car elem)))
-			    (eq (car elem) t))
-		    (setq alist nil
-			  method (cdr elem))))
-		(when method
-		  (cond
-		   ((eq method 'mime)
-		    (mm-encode-words-region (point-min) (point-max)))
-		   ;; Hm.
-		   (t))))
-	      (goto-char (point-max)))))))))
-
-(defun mm-encode-words-region (b e)
-  "Encode all encodable words in REGION."
-  (let (prev c start qstart qprev qend)
-    (save-excursion
-      (goto-char b)
-      (while (re-search-forward "[^ \t\n]+" nil t)
-	(save-restriction
-	  (narrow-to-region (match-beginning 0) (match-end 0))
-	  (goto-char (setq start (point-min)))
-	  (setq prev nil)
-	  (while (not (eobp))
-	    (unless (eq (setq c (char-charset (following-char))) 'ascii)
-	      (cond
-	       ((eq c prev)
-		)
-	       ((null prev)
-		(setq qstart (or qstart start)
-		      qend (point-max)
-		      qprev c)
-		(setq prev c))
-	       (t
-		;(mm-encode-word-region start (setq start (point)) prev)
-		(setq prev c)
-		)))
-	    (forward-char 1)))
-	(when (and (not prev) qstart)
-	  (mm-encode-word-region qstart qend qprev)
-	  (setq qstart nil)))
-      (when qstart
-	(mm-encode-word-region qstart qend qprev)
-	(setq qstart nil)))))
-
-(defun mm-encode-words-string (string)
-  "Encode words in STRING."
-  (with-temp-buffer
-    (insert string)
-    (mm-encode-words-region (point-min) (point-max))
-    (buffer-string)))
-
-(defun mm-mule-charset-to-mime-charset (charset)
-  "Return the MIME charset corresponding to MULE CHARSET."
-  (let ((alist mm-mime-mule-charset-alist)
-	out)
-    (while alist
-      (when (memq charset (cdar alist))
-	(setq out (caar alist)
-	      alist nil))
-      (pop alist))
-    out))
-
-(defun mm-encode-word-region (b e charset)
-  "Encode the word in the region with CHARSET."
-  (let* ((mime-charset (mm-mule-charset-to-mime-charset charset))
-	 (encoding (cdr (assq mime-charset mm-mime-charset-encoding-alist))))
-    (save-restriction
-      (narrow-to-region b e)
-      (funcall (cdr (assq encoding mm-mime-encoding-function-alist))
-	       b e)
+(eval-when-compile (require 'cl))
+(require 'mail-parse)
+(require 'gnus-mailcap)
+(eval-and-compile
+  (autoload 'mm-body-7-or-8 "mm-bodies"))
+
+(defcustom mm-content-transfer-encoding-defaults
+  '(("text/x-patch" 8bit)
+    ("text/.*" qp-or-base64)
+    ("message/rfc822" 8bit)
+    ("application/emacs-lisp" 8bit)
+    ("application/x-emacs-lisp" 8bit)
+    ("application/x-patch" 8bit)
+    (".*" base64))
+  "Alist of regexps that match MIME types and their encodings.
+If the encoding is `qp-or-base64', then either quoted-printable
+or base64 will be used, depending on what is more efficient."
+  :type '(repeat (list (regexp :tag "MIME type")
+		       (choice :tag "encoding"
+			       (const 7bit)
+			       (const 8bit)
+			       (const qp-or-base64)
+			       (const quoted-printable)
+			       (const base64))))
+  :group 'mime)
+
+(defvar mm-use-ultra-safe-encoding nil
+  "If non-nil, use encodings aimed at Procrustean bed survival.
+
+This means that textual parts are encoded as quoted-printable if they
+contain lines longer than 76 characters or starting with \"From \" in
+the body.  Non-7bit encodings (8bit, binary) are generally disallowed.
+This is to reduce the probability that a broken MTA or MDA changes the
+message.
+
+This variable should never be set directly, but bound before a call to
+`mml-generate-mime' or similar functions.")
+
+(defun mm-insert-rfc822-headers (charset encoding)
+  "Insert text/plain headers with CHARSET and ENCODING."
+  (insert "MIME-Version: 1.0\n")
+  (insert "Content-Type: text/plain; charset="
+	  (mail-quote-string (downcase (symbol-name charset))) "\n")
+  (insert "Content-Transfer-Encoding: "
+	  (downcase (symbol-name encoding)) "\n"))
+
+(defun mm-insert-multipart-headers ()
+  "Insert multipart/mixed headers."
+  (let ((boundary "=-=-="))
+    (insert "MIME-Version: 1.0\n")
+    (insert "Content-Type: multipart/mixed; boundary=\"" boundary "\"\n")
+    boundary))
+
+(defun mm-default-file-encoding (file)
+  "Return a default encoding for FILE."
+  (if (not (string-match "\\.[^.]+$" file))
+      "application/octet-stream"
+    (mailcap-extension-to-mime (match-string 0 file))))
+
+(defun mm-safer-encoding (encoding)
+  "Return a safer but similar encoding."
+  (cond
+   ((memq encoding '(7bit 8bit quoted-printable)) 'quoted-printable)
+   ;; The remaining encodings are binary and base64 (and perhaps some
+   ;; non-standard ones), which are both turned into base64.
+   (t 'base64)))
+
+(defun mm-encode-content-transfer-encoding (encoding &optional type)
+  (cond
+   ((eq encoding 'quoted-printable)
+    (mm-with-unibyte-current-buffer-mule4
+      (quoted-printable-encode-region (point-min) (point-max) t)))
+   ((eq encoding 'base64)
+    (when (equal type "text/plain")
       (goto-char (point-min))
-      (insert "=?" (upcase (symbol-name mime-charset)) "?"
-	      (symbol-name encoding) "?")
-      (goto-char (point-max))
-      (insert "?="))))
+      (while (search-forward "\n" nil t)
+	(replace-match "\r\n" t t)))
+    (condition-case error
+	(base64-encode-region (point-min) (point-max))
+      (error
+       (message "Error while decoding: %s" error)
+       nil)))
+   ((memq encoding '(7bit 8bit binary))
+    ;; Do nothing.
+    )
+   ((null encoding)
+    ;; Do nothing.
+    )
+   ((functionp encoding)
+    (ignore-errors (funcall encoding (point-min) (point-max))))
+   (t
+    (message "Unknown encoding %s; treating it as 8bit" encoding))))
+
+(defun mm-encode-buffer (type)
+  "Encode the buffer which contains data of TYPE.
+The encoding used is returned."
+  (let* ((mime-type (if (stringp type) type (car type)))
+	 (encoding
+	  (or (and (listp type)
+		   (cadr (assq 'encoding type)))
+	      (mm-content-transfer-encoding mime-type)))
+	 (bits (mm-body-7-or-8)))
+    ;; We force buffers that are 7bit to be unencoded, no matter
+    ;; what the preferred encoding is.
+    ;; Only if the buffers don't contain lone lines.
+    (when (and (eq bits '7bit) (not (mm-long-lines-p 76)))
+      (setq encoding bits))
+    (mm-encode-content-transfer-encoding encoding mime-type)
+    encoding))
+
+(defun mm-insert-headers (type encoding &optional file)
+  "Insert headers for TYPE."
+  (insert "Content-Type: " type)
+  (when file
+    (insert ";\n\tname=\"" (file-name-nondirectory file) "\""))
+  (insert "\n")
+  (insert (format "Content-Transfer-Encoding: %s\n" encoding))
+  (insert "Content-Disposition: inline")
+  (when file
+    (insert ";\n\tfilename=\"" (file-name-nondirectory file) "\""))
+  (insert "\n")
+  (insert "\n"))
+
+(defun mm-content-transfer-encoding (type)
+  "Return a CTE suitable for TYPE to encode the current buffer."
+  (let ((rules mm-content-transfer-encoding-defaults))
+    (catch 'found
+      (while rules
+	(when (string-match (caar rules) type)
+	  (throw 'found
+		 (let ((encoding
+			(if (eq (cadr (car rules)) 'qp-or-base64)
+			    (mm-qp-or-base64)
+			  (cadr (car rules)))))
+		   (if mm-use-ultra-safe-encoding
+		       (mm-safer-encoding encoding)
+		     encoding))))
+	(pop rules)))))
+
+(defun mm-qp-or-base64 ()
+  (if (equal mm-use-ultra-safe-encoding '(sign . "pgp"))
+      ;; perhaps not always accurate?
+      'quoted-printable
+    (save-excursion
+      (let ((limit (min (point-max) (+ 2000 (point-min))))
+	    (n8bit 0))
+	(goto-char (point-min))
+	(skip-chars-forward "\x20-\x7f\r\n\t" limit)
+	(while (< (point) limit)
+	  (incf n8bit)
+	  (forward-char 1)
+	  (skip-chars-forward "\x20-\x7f\r\n\t" limit))
+	(if (or (< (* 6 n8bit) (- limit (point-min)))
+		;; Don't base64, say, a short line with a single
+		;; non-ASCII char when splitting parts by charset.
+		(= n8bit 1))
+	    'quoted-printable
+	  'base64)))))
 
 (provide 'mm-encode)