/[emacs]/emacs/lisp/gnus/mml.el
ViewVC logotype

Diff of /emacs/lisp/gnus/mml.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14.4.2 by miles, Tue Oct 14 23:34:51 2003 UTC revision 1.14.4.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; mml.el --- package for parsing and validating MML documents  ;;; mml.el --- A package for parsing and validating MML documents
2  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.  ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
3    ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 27  Line 28 
28  (require 'mm-bodies)  (require 'mm-bodies)
29  (require 'mm-encode)  (require 'mm-encode)
30  (require 'mm-decode)  (require 'mm-decode)
31    (require 'mml-sec)
32  (eval-when-compile (require 'cl))  (eval-when-compile (require 'cl))
33    
34  (eval-and-compile  (eval-and-compile
35    (autoload 'message-make-message-id "message")    (autoload 'message-make-message-id "message")
36    (autoload 'gnus-setup-posting-charset "gnus-msg")    (autoload 'gnus-setup-posting-charset "gnus-msg")
37    (autoload 'gnus-add-minor-mode "gnus-ems")    (autoload 'gnus-add-minor-mode "gnus-ems")
38      (autoload 'gnus-make-local-hook "gnus-util")
39    (autoload 'message-fetch-field "message")    (autoload 'message-fetch-field "message")
40      (autoload 'fill-flowed-encode "flow-fill")
41    (autoload 'message-posting-charset "message"))    (autoload 'message-posting-charset "message"))
42    
43    (defcustom mml-content-type-parameters
44      '(name access-type expiration size permission format)
45      "*A list of acceptable parameters in MML tag.
46    These parameters are generated in Content-Type header if exists."
47      :type '(repeat (symbol :tag "Parameter"))
48      :group 'message)
49    
50    (defcustom mml-content-disposition-parameters
51      '(filename creation-date modification-date read-date)
52      "*A list of acceptable parameters in MML tag.
53    These parameters are generated in Content-Disposition header if exists."
54      :type '(repeat (symbol :tag "Parameter"))
55      :group 'message)
56    
57    (defcustom mml-insert-mime-headers-always nil
58      "If non-nil, always put Content-Type: text/plain at top of empty parts.
59    It is necessary to work against a bug in certain clients."
60      :type 'boolean
61      :group 'message)
62    
63    (defvar mml-tweak-type-alist nil
64      "A list of (TYPE . FUNCTION) for tweaking MML parts.
65    TYPE is a string containing a regexp to match the MIME type.  FUNCTION
66    is a Lisp function which is called with the MML handle to tweak the
67    part.  This variable is used only when no TWEAK parameter exists in
68    the MML handle.")
69    
70    (defvar mml-tweak-function-alist nil
71      "A list of (NAME . FUNCTION) for tweaking MML parts.
72    NAME is a string containing the name of the TWEAK parameter in the MML
73    handle.  FUNCTION is a Lisp function which is called with the MML
74    handle to tweak the part.")
75    
76    (defvar mml-tweak-sexp-alist
77      '((mml-externalize-attachments . mml-tweak-externalize-attachments))
78      "A list of (SEXP . FUNCTION) for tweaking MML parts.
79    SEXP is an s-expression.  If the evaluation of SEXP is non-nil, FUNCTION
80    is called.  FUNCTION is a Lisp function which is called with the MML
81    handle to tweak the part.")
82    
83    (defvar mml-externalize-attachments nil
84      "*If non-nil, local-file attachments are generated as external parts.")
85    
86  (defvar mml-generate-multipart-alist nil  (defvar mml-generate-multipart-alist nil
87    "*Alist of multipart generation functions.    "*Alist of multipart generation functions.
88  Each entry has the form (NAME . FUNCTION), where  Each entry has the form (NAME . FUNCTION), where
# Line 73  unknown encoding; `use-ascii': always us Line 120  unknown encoding; `use-ascii': always us
120  with unknown encoding; `multipart': always send messages with more than  with unknown encoding; `multipart': always send messages with more than
121  one charsets.")  one charsets.")
122    
 (defvar mml-generate-mime-preprocess-function nil  
   "A function called before generating a mime part.  
 The function is called with one parameter, which is the part to be  
 generated.")  
   
 (defvar mml-generate-mime-postprocess-function nil  
   "A function called after generating a mime part.  
 The function is called with one parameter, which is the generated part.")  
   
123  (defvar mml-generate-default-type "text/plain")  (defvar mml-generate-default-type "text/plain")
124    
125  (defvar mml-buffer-list nil)  (defvar mml-buffer-list nil)
# Line 98  The function is called with one paramete Line 136  The function is called with one paramete
136    
137  (defun mml-parse ()  (defun mml-parse ()
138    "Parse the current buffer as an MML document."    "Parse the current buffer as an MML document."
139    (goto-char (point-min))    (save-excursion
140    (let ((table (syntax-table)))      (goto-char (point-min))
141      (unwind-protect      (let ((table (syntax-table)))
142          (progn        (unwind-protect
143            (set-syntax-table mml-syntax-table)            (progn
144            (mml-parse-1))              (set-syntax-table mml-syntax-table)
145        (set-syntax-table table))))              (mml-parse-1))
146            (set-syntax-table table)))))
147    
148  (defun mml-parse-1 ()  (defun mml-parse-1 ()
149    "Parse the current buffer as an MML document."    "Parse the current buffer as an MML document."
# Line 112  The function is called with one paramete Line 151  The function is called with one paramete
151      (while (and (not (eobp))      (while (and (not (eobp))
152                  (not (looking-at "<#/multipart")))                  (not (looking-at "<#/multipart")))
153        (cond        (cond
154           ((looking-at "<#secure")
155            ;; The secure part is essentially a meta-meta tag, which
156            ;; expands to either a part tag if there are no other parts in
157            ;; the document or a multipart tag if there are other parts
158            ;; included in the message
159            (let* (secure-mode
160                   (taginfo (mml-read-tag))
161                   (recipients (cdr (assq 'recipients taginfo)))
162                   (sender (cdr (assq 'sender taginfo)))
163                   (location (cdr (assq 'tag-location taginfo)))
164                   (mode (cdr (assq 'mode taginfo)))
165                   (method (cdr (assq 'method taginfo)))
166                   tags)
167              (save-excursion
168                (if
169                    (re-search-forward
170                     "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
171                    (setq secure-mode "multipart")
172                  (setq secure-mode "part")))
173              (save-excursion
174                (goto-char location)
175                (re-search-forward "<#secure[^\n]*>\n"))
176              (delete-region (match-beginning 0) (match-end 0))
177              (cond ((string= mode "sign")
178                     (setq tags (list "sign" method)))
179                    ((string= mode "encrypt")
180                     (setq tags (list "encrypt" method)))
181                    ((string= mode "signencrypt")
182                     (setq tags (list "sign" method "encrypt" method))))
183              (eval `(mml-insert-tag ,secure-mode
184                                     ,@tags
185                                     ,(if recipients "recipients")
186                                     ,recipients
187                                     ,(if sender "sender")
188                                     ,sender))
189              ;; restart the parse
190              (goto-char location)))
191         ((looking-at "<#multipart")         ((looking-at "<#multipart")
192          (push (nconc (mml-read-tag) (mml-parse-1)) struct))          (push (nconc (mml-read-tag) (mml-parse-1)) struct))
193         ((looking-at "<#external")         ((looking-at "<#external")
# Line 128  The function is called with one paramete Line 204  The function is called with one paramete
204          (setq raw (cdr (assq 'raw tag))          (setq raw (cdr (assq 'raw tag))
205                point (point)                point (point)
206                contents (mml-read-part (eq 'mml (car tag)))                contents (mml-read-part (eq 'mml (car tag)))
207                charsets (if raw nil                charsets (cond
208                           (mm-find-mime-charset-region point (point))))                          (raw nil)
209                            ((assq 'charset tag)
210                             (list
211                              (intern (downcase (cdr (assq 'charset tag))))))
212                            (t
213                             (mm-find-mime-charset-region point (point)
214                                                          mm-hack-charsets))))
215          (when (and (not raw) (memq nil charsets))          (when (and (not raw) (memq nil charsets))
216            (if (or (memq 'unknown-encoding mml-confirmation-set)            (if (or (memq 'unknown-encoding mml-confirmation-set)
217                    (prog1 (y-or-n-p                    (message-options-get 'unknown-encoding)
218                            "\                    (and (y-or-n-p "\
219  Message contains characters with unknown encoding.  Really send?")  Message contains characters with unknown encoding.  Really send? ")
220                      (set (make-local-variable 'mml-confirmation-set)                         (message-options-set 'unknown-encoding t)))
                          (push 'unknown-encoding mml-confirmation-set))))  
221                (if (setq use-ascii                (if (setq use-ascii
222                          (or (memq 'use-ascii mml-confirmation-set)                          (or (memq 'use-ascii mml-confirmation-set)
223                              (y-or-n-p "Use ASCII as charset?")))                              (message-options-get 'use-ascii)
224                                (and (y-or-n-p "Use ASCII as charset? ")
225                                     (message-options-set 'use-ascii t))))
226                    (setq charsets (delq nil charsets))                    (setq charsets (delq nil charsets))
227                  (setq warn nil))                  (setq warn nil))
228              (error "Edit your message to remove those characters")))              (error "Edit your message to remove those characters")))
# Line 155  Message contains characters with unknown Line 238  Message contains characters with unknown
238                            tag point (point) use-ascii)))                            tag point (point) use-ascii)))
239              (when (and warn              (when (and warn
240                         (not (memq 'multipart mml-confirmation-set))                         (not (memq 'multipart mml-confirmation-set))
241                         (not                         (not (message-options-get 'multipart))
242                          (prog1 (y-or-n-p                         (not (and (y-or-n-p (format "\
                                 (format  
                                  "\  
243  A message part needs to be split into %d charset parts.  Really send? "  A message part needs to be split into %d charset parts.  Really send? "
244                                   (length nstruct)))                                                     (length nstruct)))
245                            (set (make-local-variable 'mml-confirmation-set)                                   (message-options-set 'multipart t))))
                                (push 'multipart mml-confirmation-set)))))  
246                (error "Edit your message to use only one charset"))                (error "Edit your message to use only one charset"))
247              (setq struct (nconc nstruct struct)))))))              (setq struct (nconc nstruct struct)))))))
248      (unless (eobp)      (unless (eobp)
# Line 229  A message part needs to be split into %d Line 309  A message part needs to be split into %d
309    
310  (defun mml-read-tag ()  (defun mml-read-tag ()
311    "Read a tag and return the contents."    "Read a tag and return the contents."
312    (let (contents name elem val)    (let ((orig-point (point))
313            contents name elem val)
314      (forward-char 2)      (forward-char 2)
315      (setq name (buffer-substring-no-properties      (setq name (buffer-substring-no-properties
316                  (point) (progn (forward-sexp 1) (point))))                  (point) (progn (forward-sexp 1) (point))))
317      (skip-chars-forward " \t\n")      (skip-chars-forward " \t\n")
318      (while (not (looking-at ">"))      (while (not (looking-at ">[ \t]*\n?"))
319        (setq elem (buffer-substring-no-properties        (setq elem (buffer-substring-no-properties
320                    (point) (progn (forward-sexp 1) (point))))                    (point) (progn (forward-sexp 1) (point))))
321        (skip-chars-forward "= \t\n")        (skip-chars-forward "= \t\n")
# Line 244  A message part needs to be split into %d Line 325  A message part needs to be split into %d
325          (setq val (match-string 1 val)))          (setq val (match-string 1 val)))
326        (push (cons (intern elem) val) contents)        (push (cons (intern elem) val) contents)
327        (skip-chars-forward " \t\n"))        (skip-chars-forward " \t\n"))
328      (forward-char 1)      (goto-char (match-end 0))
329      (skip-chars-forward " \t\n")      ;; Don't skip the leading space.
330        ;;(skip-chars-forward " \t\n")
331        ;; Put the tag location into the returned contents
332        (setq contents (append (list (cons 'tag-location orig-point)) contents))
333      (cons (intern name) (nreverse contents))))      (cons (intern name) (nreverse contents))))
334    
335    (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
336      (let ((str (buffer-substring-no-properties start end))
337            (bufstart start) tmp)
338        (while (setq tmp (text-property-any start end 'hard 't))
339          (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
340                               '(hard t) str)
341          (setq start (1+ tmp)))
342        str))
343    
344  (defun mml-read-part (&optional mml)  (defun mml-read-part (&optional mml)
345    "Return the buffer up till the next part, multipart or closing part or multipart.    "Return the buffer up till the next part, multipart or closing part or multipart.
346  If MML is non-nil, return the buffer up till the correspondent mml tag."  If MML is non-nil, return the buffer up till the correspondent mml tag."
347    (let ((beg (point)) (count 1))    (let ((beg (point)) (count 1))
348     ;; If the tag ended at the end of the line, we go to the next line.      ;; If the tag ended at the end of the line, we go to the next line.
349      (when (looking-at "[ \t]*\n")      (when (looking-at "[ \t]*\n")
350        (forward-line 1))        (forward-line 1))
351      (if mml      (if mml
# Line 261  If MML is non-nil, return the buffer up Line 354  If MML is non-nil, return the buffer up
354              (if (re-search-forward "<#\\(/\\)?mml." nil t)              (if (re-search-forward "<#\\(/\\)?mml." nil t)
355                  (setq count (+ count (if (match-beginning 1) -1 1)))                  (setq count (+ count (if (match-beginning 1) -1 1)))
356                (goto-char (point-max))))                (goto-char (point-max))))
357            (buffer-substring-no-properties beg (if (> count 0)            (mml-buffer-substring-no-properties-except-hard-newlines
358                                                    (point)             beg (if (> count 0)
359                                                  (match-beginning 0))))                     (point)
360                     (match-beginning 0))))
361        (if (re-search-forward        (if (re-search-forward
362             "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)             "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
363            (prog1            (prog1
364                (buffer-substring-no-properties beg (match-beginning 0))                (mml-buffer-substring-no-properties-except-hard-newlines
365                   beg (match-beginning 0))
366              (if (or (not (match-beginning 1))              (if (or (not (match-beginning 1))
367                      (equal (match-string 2) "multipart"))                      (equal (match-string 2) "multipart"))
368                  (goto-char (match-beginning 0))                  (goto-char (match-beginning 0))
369                (when (looking-at "[ \t]*\n")                (when (looking-at "[ \t]*\n")
370                  (forward-line 1))))                  (forward-line 1))))
371          (buffer-substring-no-properties beg (goto-char (point-max)))))))          (mml-buffer-substring-no-properties-except-hard-newlines
372             beg (goto-char (point-max)))))))
373    
374  (defvar mml-boundary nil)  (defvar mml-boundary nil)
375  (defvar mml-base-boundary "-=-=")  (defvar mml-base-boundary "-=-=")
# Line 294  If MML is non-nil, return the buffer up Line 390  If MML is non-nil, return the buffer up
390          (buffer-string)))))          (buffer-string)))))
391    
392  (defun mml-generate-mime-1 (cont)  (defun mml-generate-mime-1 (cont)
393    (save-restriction    (let ((mm-use-ultra-safe-encoding
394      (narrow-to-region (point) (point))           (or mm-use-ultra-safe-encoding (assq 'sign cont))))
395      (if mml-generate-mime-preprocess-function      (save-restriction
396          (funcall mml-generate-mime-preprocess-function cont))        (narrow-to-region (point) (point))
397      (cond        (mml-tweak-part cont)
398       ((or (eq (car cont) 'part) (eq (car cont) 'mml))        (cond
399        (let ((raw (cdr (assq 'raw cont)))         ((or (eq (car cont) 'part) (eq (car cont) 'mml))
400              coded encoding charset filename type)          (let ((raw (cdr (assq 'raw cont)))
401          (setq type (or (cdr (assq 'type cont)) "text/plain"))                coded encoding charset filename type flowed)
402          (if (and (not raw)            (setq type (or (cdr (assq 'type cont)) "text/plain"))
403                   (member (car (split-string type "/")) '("text" "message")))            (if (and (not raw)
404              (progn                     (member (car (split-string type "/")) '("text" "message")))
405                (with-temp-buffer                (progn
406                  (cond                  (with-temp-buffer
407                   ((cdr (assq 'buffer cont))                    (setq charset (mm-charset-to-coding-system
408                    (insert-buffer-substring (cdr (assq 'buffer cont))))                                   (cdr (assq 'charset cont))))
409                   ((and (setq filename (cdr (assq 'filename cont)))                    (when (eq charset 'ascii)
410                         (not (equal (cdr (assq 'nofile cont)) "yes")))                      (setq charset nil))
411                    (mm-insert-file-contents filename))                    (cond
412                   ((eq 'mml (car cont))                     ((cdr (assq 'buffer cont))
413                    (insert (cdr (assq 'contents cont))))                      (insert-buffer-substring (cdr (assq 'buffer cont))))
414                   (t                     ((and (setq filename (cdr (assq 'filename cont)))
415                    (save-restriction                           (not (equal (cdr (assq 'nofile cont)) "yes")))
416                      (narrow-to-region (point) (point))                      (let ((coding-system-for-read charset))
417                      (insert (cdr (assq 'contents cont)))                        (mm-insert-file-contents filename)))
418                      ;; Remove quotes from quoted tags.                     ((eq 'mml (car cont))
419                      (goto-char (point-min))                      (insert (cdr (assq 'contents cont))))
420                      (while (re-search-forward                     (t
421                              "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t)                      (save-restriction
422                        (delete-region (+ (match-beginning 0) 2)                        (narrow-to-region (point) (point))
423                                       (+ (match-beginning 0) 3))))))                        (insert (cdr (assq 'contents cont)))
424                  (cond                        ;; Remove quotes from quoted tags.
425                   ((eq (car cont) 'mml)                        (goto-char (point-min))
426                    (let ((mml-boundary (funcall mml-boundary-function                        (while (re-search-forward
427                                                 (incf mml-multipart-number)))                                "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
428                          (mml-generate-default-type "text/plain"))                                nil t)
429                      (mml-to-mime))                          (delete-region (+ (match-beginning 0) 2)
430                    (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))                                         (+ (match-beginning 0) 3))))))
431                      ;; ignore 0x1b, it is part of iso-2022-jp                    (cond
432                      (setq encoding (mm-body-7-or-8))))                     ((eq (car cont) 'mml)
433                   ((string= (car (split-string type "/")) "message")                      (let ((mml-boundary (mml-compute-boundary cont))
434                    (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))                            (mml-generate-default-type "text/plain"))
435                      ;; ignore 0x1b, it is part of iso-2022-jp                        (mml-to-mime))
436                      (setq encoding (mm-body-7-or-8))))                      (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
437                   (t                        ;; ignore 0x1b, it is part of iso-2022-jp
438                    (setq charset (mm-encode-body))                        (setq encoding (mm-body-7-or-8))))
439                    (setq encoding (mm-body-encoding                     ((string= (car (split-string type "/")) "message")
440                                    charset (cdr (assq 'encoding cont))))))                      (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
441                  (setq coded (buffer-string)))                        ;; ignore 0x1b, it is part of iso-2022-jp
442                (mml-insert-mime-headers cont type charset encoding)                        (setq encoding (mm-body-7-or-8))))
443                (insert "\n")                     (t
444                (insert coded))                      ;; Only perform format=flowed filling on text/plain
445            (mm-with-unibyte-buffer                      ;; parts where there either isn't a format parameter
446              (cond                      ;; in the mml tag or it says "flowed" and there
447               ((cdr (assq 'buffer cont))                      ;; actually are hard newlines in the text.
448                (insert-buffer-substring (cdr (assq 'buffer cont))))                      (let (use-hard-newlines)
449               ((and (setq filename (cdr (assq 'filename cont)))                        (when (and (string= type "text/plain")
450                     (not (equal (cdr (assq 'nofile cont)) "yes")))                                   (or (null (assq 'format cont))
451                (let ((coding-system-for-read mm-binary-coding-system))                                       (string= (cdr (assq 'format cont))
452                  (mm-insert-file-contents filename nil nil nil nil t)))                                                "flowed"))
453               (t                                   (setq use-hard-newlines
454                (insert (cdr (assq 'contents cont)))))                                         (text-property-any
455              (setq encoding (mm-encode-buffer type)                                          (point-min) (point-max) 'hard 't)))
456                    coded (buffer-string)))                          (fill-flowed-encode)
457            (mml-insert-mime-headers cont type charset encoding)                          ;; Indicate that `mml-insert-mime-headers' should
458            (insert "\n")                          ;; insert a "; format=flowed" string unless the
459            (mm-with-unibyte-current-buffer                          ;; user has already specified it.
460              (insert coded)))))                          (setq flowed (null (assq 'format cont)))))
461       ((eq (car cont) 'external)                      (setq charset (mm-encode-body charset))
462        (insert "Content-Type: message/external-body")                      (setq encoding (mm-body-encoding
463        (let ((parameters (mml-parameter-string                                      charset (cdr (assq 'encoding cont))))))
464                           cont '(expiration size permission)))                    (setq coded (buffer-string)))
465              (name (cdr (assq 'name cont))))                  (mml-insert-mime-headers cont type charset encoding flowed)
466          (when name                  (insert "\n")
467            (setq name (mml-parse-file-name name))                  (insert coded))
468            (if (stringp name)              (mm-with-unibyte-buffer
469                  (cond
470                   ((cdr (assq 'buffer cont))
471                    (insert-buffer-substring (cdr (assq 'buffer cont))))
472                   ((and (setq filename (cdr (assq 'filename cont)))
473                         (not (equal (cdr (assq 'nofile cont)) "yes")))
474                    (let ((coding-system-for-read mm-binary-coding-system))
475                      (mm-insert-file-contents filename nil nil nil nil t)))
476                   (t
477                    (insert (cdr (assq 'contents cont)))))
478                  (setq encoding (mm-encode-buffer type)
479                        coded (mm-string-as-multibyte (buffer-string))))
480                (mml-insert-mime-headers cont type charset encoding nil)
481                (insert "\n")
482                (mm-with-unibyte-current-buffer
483                  (insert coded)))))
484           ((eq (car cont) 'external)
485            (insert "Content-Type: message/external-body")
486            (let ((parameters (mml-parameter-string
487                               cont '(expiration size permission)))
488                  (name (cdr (assq 'name cont)))
489                  (url (cdr (assq 'url cont))))
490              (when name
491                (setq name (mml-parse-file-name name))
492                (if (stringp name)
493                    (mml-insert-parameter
494                     (mail-header-encode-parameter "name" name)
495                     "access-type=local-file")
496                (mml-insert-parameter                (mml-insert-parameter
497                 (mail-header-encode-parameter "name" name)                 (mail-header-encode-parameter
498                 "access-type=local-file")                  "name" (file-name-nondirectory (nth 2 name)))
499              (mml-insert-parameter                 (mail-header-encode-parameter "site" (nth 1 name))
500               (mail-header-encode-parameter                 (mail-header-encode-parameter
501                "name" (file-name-nondirectory (nth 2 name)))                  "directory" (file-name-directory (nth 2 name))))
502               (mail-header-encode-parameter "site" (nth 1 name))                (mml-insert-parameter
503               (mail-header-encode-parameter                 (concat "access-type="
504                "directory" (file-name-directory (nth 2 name))))                         (if (member (nth 0 name) '("ftp@" "anonymous@"))
505                               "anon-ftp"
506                             "ftp")))))
507              (when url
508              (mml-insert-parameter              (mml-insert-parameter
509               (concat "access-type="               (mail-header-encode-parameter "url" url)
510                       (if (member (nth 0 name) '("ftp@" "anonymous@"))               "access-type=url"))
511                           "anon-ftp"            (when parameters
512                         "ftp")))))              (mml-insert-parameter-string
513          (when parameters               cont '(expiration size permission))))
514            (mml-insert-parameter-string          (insert "\n\n")
515             cont '(expiration size permission))))          (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
516        (insert "\n\n")          (insert "Content-ID: " (message-make-message-id) "\n")
517        (insert "Content-Type: " (cdr (assq 'type cont)) "\n")          (insert "Content-Transfer-Encoding: "
518        (insert "Content-ID: " (message-make-message-id) "\n")                  (or (cdr (assq 'encoding cont)) "binary"))
519        (insert "Content-Transfer-Encoding: "          (insert "\n\n")
520                (or (cdr (assq 'encoding cont)) "binary"))          (insert (or (cdr (assq 'contents cont))))
521        (insert "\n\n")          (insert "\n"))
522        (insert (or (cdr (assq 'contents cont))))         ((eq (car cont) 'multipart)
523        (insert "\n"))          (let* ((type (or (cdr (assq 'type cont)) "mixed"))
524       ((eq (car cont) 'multipart)                 (mml-generate-default-type (if (equal type "digest")
525        (let* ((type (or (cdr (assq 'type cont)) "mixed"))                                                "message/rfc822"
526               (mml-generate-default-type (if (equal type "digest")                                              "text/plain"))
527                                              "message/rfc822"                 (handler (assoc type mml-generate-multipart-alist)))
528                                            "text/plain"))            (if handler
529               (handler (assoc type mml-generate-multipart-alist)))                (funcall (cdr handler) cont)
530          (if handler              ;; No specific handler.  Use default one.
531              (funcall (cdr handler) cont)              (let ((mml-boundary (mml-compute-boundary cont)))
532            ;; No specific handler.  Use default one.                (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
533            (let ((mml-boundary (mml-compute-boundary cont)))                                type mml-boundary)
534              (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"                        (if (cdr (assq 'start cont))
535                              type mml-boundary))                            (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
536              ;; Skip `multipart' and `type' elements.                          "\n"))
537              (setq cont (cddr cont))                (let ((cont cont) part)
538              (while cont                  (while (setq part (pop cont))
539                (insert "\n--" mml-boundary "\n")                    ;; Skip `multipart' and attributes.
540                (mml-generate-mime-1 (pop cont)))                    (when (and (consp part) (consp (cdr part)))
541              (insert "\n--" mml-boundary "--\n")))))                      (insert "\n--" mml-boundary "\n")
542       (t                      (mml-generate-mime-1 part))))
543        (error "Invalid element: %S" cont)))                (insert "\n--" mml-boundary "--\n")))))
544      (if mml-generate-mime-postprocess-function         (t
545          (funcall mml-generate-mime-postprocess-function cont))))          (error "Invalid element: %S" cont)))
546          ;; handle sign & encrypt tags in a semi-smart way.
547          (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
548                (encrypt-item (assoc (cdr (assq 'encrypt cont))
549                                     mml-encrypt-alist))
550                sender recipients)
551            (when (or sign-item encrypt-item)
552              (when (setq sender (cdr (assq 'sender cont)))
553                (message-options-set 'mml-sender sender)
554                (message-options-set 'message-sender sender))
555              (if (setq recipients (cdr (assq 'recipients cont)))
556                  (message-options-set 'message-recipients recipients))
557              (let ((style (mml-signencrypt-style (first (or sign-item encrypt-item)))))
558                ;; check if: we're both signing & encrypting, both methods
559                ;; are the same (why would they be different?!), and that
560                ;; the signencrypt style allows for combined operation.
561                (if (and sign-item encrypt-item (equal (first sign-item)
562                                                       (first encrypt-item))
563                         (equal style 'combined))
564                    (funcall (nth 1 encrypt-item) cont t)
565                  ;; otherwise, revert to the old behavior.
566                  (when sign-item
567                    (funcall (nth 1 sign-item) cont))
568                  (when encrypt-item
569                    (funcall (nth 1 encrypt-item) cont)))))))))
570    
571  (defun mml-compute-boundary (cont)  (defun mml-compute-boundary (cont)
572    "Return a unique boundary that does not exist in CONT."    "Return a unique boundary that does not exist in CONT."
# Line 458  If MML is non-nil, return the buffer up Line 608  If MML is non-nil, return the buffer up
608              "")              "")
609            mml-base-boundary))            mml-base-boundary))
610    
611  (defun mml-insert-mime-headers (cont type charset encoding)  (defun mml-insert-mime-headers (cont type charset encoding flowed)
612    (let (parameters disposition description)    (let (parameters id disposition description)
613      (setq parameters      (setq parameters
614            (mml-parameter-string            (mml-parameter-string
615             cont '(name access-type expiration size permission)))             cont mml-content-type-parameters))
616      (when (or charset      (when (or charset
617                parameters                parameters
618                (not (equal type mml-generate-default-type)))                flowed
619                  (not (equal type mml-generate-default-type))
620                  mml-insert-mime-headers-always)
621        (when (consp charset)        (when (consp charset)
622          (error          (error
623           "Can't encode a part with several charsets."))           "Can't encode a part with several charsets"))
624        (insert "Content-Type: " type)        (insert "Content-Type: " type)
625        (when charset        (when charset
626          (insert "; " (mail-header-encode-parameter          (insert "; " (mail-header-encode-parameter
627                        "charset" (symbol-name charset))))                        "charset" (symbol-name charset))))
628          (when flowed
629            (insert "; format=flowed"))
630        (when parameters        (when parameters
631          (mml-insert-parameter-string          (mml-insert-parameter-string
632           cont '(name access-type expiration size permission)))           cont mml-content-type-parameters))
633        (insert "\n"))        (insert "\n"))
634        (when (setq id (cdr (assq 'id cont)))
635          (insert "Content-ID: " id "\n"))
636      (setq parameters      (setq parameters
637            (mml-parameter-string            (mml-parameter-string
638             cont '(filename creation-date modification-date read-date)))             cont mml-content-disposition-parameters))
639      (when (or (setq disposition (cdr (assq 'disposition cont)))      (when (or (setq disposition (cdr (assq 'disposition cont)))
640                parameters)                parameters)
641        (insert "Content-Disposition: " (or disposition "inline"))        (insert "Content-Disposition: " (or disposition "inline"))
642        (when parameters        (when parameters
643          (mml-insert-parameter-string          (mml-insert-parameter-string
644           cont '(filename creation-date modification-date read-date)))           cont mml-content-disposition-parameters))
645        (insert "\n"))        (insert "\n"))
646      (unless (eq encoding '7bit)      (unless (eq encoding '7bit)
647        (insert (format "Content-Transfer-Encoding: %s\n" encoding)))        (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
# Line 542  If MML is non-nil, return the buffer up Line 698  If MML is non-nil, return the buffer up
698  ;;; Transforming MIME to MML  ;;; Transforming MIME to MML
699  ;;;  ;;;
700    
701  (defun mime-to-mml ()  (defun mime-to-mml (&optional handles)
702    "Translate the current buffer (which should be a message) into MML."    "Translate the current buffer (which should be a message) into MML.
703    If HANDLES is non-nil, use it instead reparsing the buffer."
704    ;; First decode the head.    ;; First decode the head.
705    (save-restriction    (save-restriction
706      (message-narrow-to-head)      (message-narrow-to-head)
707      (mail-decode-encoded-word-region (point-min) (point-max)))      (mail-decode-encoded-word-region (point-min) (point-max)))
708    (let ((handles (mm-dissect-buffer t)))    (unless handles
709      (goto-char (point-min))      (setq handles (mm-dissect-buffer t)))
710      (search-forward "\n\n" nil t)    (goto-char (point-min))
711      (delete-region (point) (point-max))    (search-forward "\n\n" nil t)
712      (if (stringp (car handles))    (delete-region (point) (point-max))
713          (mml-insert-mime handles)    (if (stringp (car handles))
714        (mml-insert-mime handles t))        (mml-insert-mime handles)
715      (mm-destroy-parts handles))      (mml-insert-mime handles t))
716      (mm-destroy-parts handles)
717    (save-restriction    (save-restriction
718      (message-narrow-to-head)      (message-narrow-to-head)
719      ;; Remove them, they are confusing.      ;; Remove them, they are confusing.
720      (message-remove-header "Content-Type")      (message-remove-header "Content-Type")
721      (message-remove-header "MIME-Version")      (message-remove-header "MIME-Version")
722        (message-remove-header "Content-Disposition")
723      (message-remove-header "Content-Transfer-Encoding")))      (message-remove-header "Content-Transfer-Encoding")))
724    
725  (defun mml-to-mime ()  (defun mml-to-mime ()
# Line 568  If MML is non-nil, return the buffer up Line 727  If MML is non-nil, return the buffer up
727    (message-encode-message-body)    (message-encode-message-body)
728    (save-restriction    (save-restriction
729      (message-narrow-to-headers-or-head)      (message-narrow-to-headers-or-head)
730        ;; Skip past any From_ headers.
731        (while (looking-at "From ")
732          (forward-line 1))
733      (let ((mail-parse-charset message-default-charset))      (let ((mail-parse-charset message-default-charset))
734        (mail-encode-encoded-word-buffer))))        (mail-encode-encoded-word-buffer))))
735    
# Line 589  If MML is non-nil, return the buffer up Line 751  If MML is non-nil, return the buffer up
751          (mml-insert-mml-markup handle buffer textp)))          (mml-insert-mml-markup handle buffer textp)))
752      (cond      (cond
753       (mmlp       (mmlp
754        (insert-buffer buffer)        (insert-buffer-substring buffer)
755        (goto-char (point-max))        (goto-char (point-max))
756        (insert "<#/mml>\n"))        (insert "<#/mml>\n"))
757       ((stringp (car handle))       ((stringp (car handle))
758        (mapcar 'mml-insert-mime (cdr handle))        (mapcar 'mml-insert-mime (cdr handle))
759        (insert "<#/multipart>\n"))        (insert "<#/multipart>\n"))
760       (textp       (textp
761        (let ((text (mm-get-part handle))        (let ((charset (mail-content-type-get
762              (charset (mail-content-type-get                        (mm-handle-type handle) 'charset))
763                        (mm-handle-type handle) 'charset)))              (start (point)))
764          (insert (mm-decode-string text charset)))          (if (eq charset 'gnus-decoded)
765                (mm-insert-part handle)
766              (insert (mm-decode-string (mm-get-part handle) charset)))
767            (mml-quote-region start (point)))
768        (goto-char (point-max)))        (goto-char (point-max)))
769       (t       (t
770        (insert "<#/part>\n")))))        (insert "<#/part>\n")))))
# Line 607  If MML is non-nil, return the buffer up Line 772  If MML is non-nil, return the buffer up
772  (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)  (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
773    "Take a MIME handle and insert an MML tag."    "Take a MIME handle and insert an MML tag."
774    (if (stringp (car handle))    (if (stringp (car handle))
775        (insert "<#multipart type=" (mm-handle-media-subtype handle)        (progn
776                ">\n")          (insert "<#multipart type=" (mm-handle-media-subtype handle))
777            (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
778              (when start
779                (insert " start=\"" start "\"")))
780            (insert ">\n"))
781      (if mmlp      (if mmlp
782          (insert "<#mml type=" (mm-handle-media-type handle))          (insert "<#mml type=" (mm-handle-media-type handle))
783        (insert "<#part type=" (mm-handle-media-type handle)))        (insert "<#part type=" (mm-handle-media-type handle)))
784      (dolist (elem (append (cdr (mm-handle-type handle))      (dolist (elem (append (cdr (mm-handle-type handle))
785                            (cdr (mm-handle-disposition handle))))                            (cdr (mm-handle-disposition handle))))
786        (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))        (unless (symbolp (cdr elem))
787            (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
788        (when (mm-handle-id handle)
789          (insert " id=\"" (mm-handle-id handle) "\""))
790      (when (mm-handle-disposition handle)      (when (mm-handle-disposition handle)
791        (insert " disposition=" (car (mm-handle-disposition handle))))        (insert " disposition=" (car (mm-handle-disposition handle))))
792      (when buffer      (when buffer
# Line 641  If MML is non-nil, return the buffer up Line 813  If MML is non-nil, return the buffer up
813  ;;;  ;;;
814    
815  (defvar mml-mode-map  (defvar mml-mode-map
816    (let ((map (make-sparse-keymap))    (let ((sign (make-sparse-keymap))
817            (encrypt (make-sparse-keymap))
818            (signpart (make-sparse-keymap))
819            (encryptpart (make-sparse-keymap))
820            (map (make-sparse-keymap))
821          (main (make-sparse-keymap)))          (main (make-sparse-keymap)))
822        (define-key sign "p" 'mml-secure-message-sign-pgpmime)
823        (define-key sign "o" 'mml-secure-message-sign-pgp)
824        (define-key sign "s" 'mml-secure-message-sign-smime)
825        (define-key signpart "p" 'mml-secure-sign-pgpmime)
826        (define-key signpart "o" 'mml-secure-sign-pgp)
827        (define-key signpart "s" 'mml-secure-sign-smime)
828        (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
829        (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
830        (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
831        (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
832        (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
833        (define-key encryptpart "s" 'mml-secure-encrypt-smime)
834        (define-key map "\C-n" 'mml-unsecure-message)
835      (define-key map "f" 'mml-attach-file)      (define-key map "f" 'mml-attach-file)
836      (define-key map "b" 'mml-attach-buffer)      (define-key map "b" 'mml-attach-buffer)
837      (define-key map "e" 'mml-attach-external)      (define-key map "e" 'mml-attach-external)
# Line 651  If MML is non-nil, return the buffer up Line 840  If MML is non-nil, return the buffer up
840      (define-key map "p" 'mml-insert-part)      (define-key map "p" 'mml-insert-part)
841      (define-key map "v" 'mml-validate)      (define-key map "v" 'mml-validate)
842      (define-key map "P" 'mml-preview)      (define-key map "P" 'mml-preview)
843        (define-key map "s" sign)
844        (define-key map "S" signpart)
845        (define-key map "c" encrypt)
846        (define-key map "C" encryptpart)
847      ;;(define-key map "n" 'mml-narrow-to-part)      ;;(define-key map "n" 'mml-narrow-to-part)
848      (define-key main "\M-m" map)      ;; `M-m' conflicts with `back-to-indentation'.
849        ;; (define-key main "\M-m" map)
850        (define-key main "\C-c\C-m" map)
851      main))      main))
852    
853  (easy-menu-define  (easy-menu-define
854    mml-menu mml-mode-map ""    mml-menu mml-mode-map ""
855    '("MML"    `("Attachments"
856      ("Attach"      ["Attach File..." mml-attach-file
857       ["File" mml-attach-file t]       ,@(if (featurep 'xemacs) '(t)
858       ["Buffer" mml-attach-buffer t]           '(:help "Attach a file at point"))]
859       ["External" mml-attach-external t])      ["Attach Buffer..." mml-attach-buffer t]
860      ("Insert"      ["Attach External..." mml-attach-external t]
861       ["Multipart" mml-insert-multipart t]      ["Insert Part..." mml-insert-part t]
862       ["Part" mml-insert-part t])      ["Insert Multipart..." mml-insert-multipart t]
863        ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t]
864        ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t]
865        ["PGP Sign" mml-secure-message-sign-pgp t]
866        ["PGP Encrypt" mml-secure-message-encrypt-pgp t]
867        ["S/MIME Sign" mml-secure-message-sign-smime t]
868        ["S/MIME Encrypt" mml-secure-message-encrypt-smime t]
869        ("Secure MIME part"
870         ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t]
871         ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t]
872         ["PGP Sign Part" mml-secure-sign-pgp t]
873         ["PGP Encrypt Part" mml-secure-encrypt-pgp t]
874         ["S/MIME Sign Part" mml-secure-sign-smime t]
875         ["S/MIME Encrypt Part" mml-secure-encrypt-smime t])
876        ["Encrypt/Sign off" mml-unsecure-message t]
877      ;;["Narrow" mml-narrow-to-part t]      ;;["Narrow" mml-narrow-to-part t]
878      ["Quote" mml-quote-region t]      ["Quote MML" mml-quote-region t]
879      ["Validate" mml-validate t]      ["Validate MML" mml-validate t]
880      ["Preview" mml-preview t]))      ["Preview" mml-preview t]))
881    
882  (defvar mml-mode nil  (defvar mml-mode nil
# Line 675  If MML is non-nil, return the buffer up Line 884  If MML is non-nil, return the buffer up
884    
885  (defun mml-mode (&optional arg)  (defun mml-mode (&optional arg)
886    "Minor mode for editing MML.    "Minor mode for editing MML.
887    MML is the MIME Meta Language, a minor mode for composing MIME articles.
888    See Info node `(emacs-mime)Composing'.
889    
890  \\{mml-mode-map}"  \\{mml-mode-map}"
891    (interactive "P")    (interactive "P")
892    (if (not (set (make-local-variable 'mml-mode)    (when (set (make-local-variable 'mml-mode)
893                  (if (null arg) (not mml-mode)               (if (null arg) (not mml-mode)
894                    (> (prefix-numeric-value arg) 0))))                 (> (prefix-numeric-value arg) 0)))
895        nil      (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map)
896      (set (make-local-variable 'mml-mode) t)      (easy-menu-add mml-menu mml-mode-map)
897      (unless (assq 'mml-mode minor-mode-alist)      (run-hooks 'mml-mode-hook)))
       (push `(mml-mode " MML") minor-mode-alist))  
     (unless (assq 'mml-mode minor-mode-map-alist)  
       (push (cons 'mml-mode mml-mode-map)  
             minor-mode-map-alist)))  
   (run-hooks 'mml-mode-hook))  
898    
899  ;;;  ;;;
900  ;;; Helper functions for reading MIME stuff from the minibuffer and  ;;; Helper functions for reading MIME stuff from the minibuffer and
# Line 696  If MML is non-nil, return the buffer up Line 902  If MML is non-nil, return the buffer up
902  ;;;  ;;;
903    
904  (defun mml-minibuffer-read-file (prompt)  (defun mml-minibuffer-read-file (prompt)
905    (let ((file (read-file-name prompt nil nil t)))    (let* ((completion-ignored-extensions nil)
906     ;; Prevent some common errors.  This is inspired by similar code in           (file (read-file-name prompt nil nil t)))
907        ;; Prevent some common errors.  This is inspired by similar code in
908      ;; VM.      ;; VM.
909      (when (file-directory-p file)      (when (file-directory-p file)
910        (error "%s is a directory, cannot attach" file))        (error "%s is a directory, cannot attach" file))
# Line 728  If MML is non-nil, return the buffer up Line 935  If MML is non-nil, return the buffer up
935        (setq description nil))        (setq description nil))
936      description))      description))
937    
938    (defun mml-minibuffer-read-disposition (type &optional default)
939      (let* ((default (or default
940                          (if (string-match "^text/.*" type)
941                              "inline"
942                            "attachment")))
943             (disposition (completing-read "Disposition: "
944                                           '(("attachment") ("inline") (""))
945                                           nil
946                                           nil)))
947        (if (not (equal disposition ""))
948            disposition
949          default)))
950    
951  (defun mml-quote-region (beg end)  (defun mml-quote-region (beg end)
952    "Quote the MML tags in the region."    "Quote the MML tags in the region."
953    (interactive "r")    (interactive "r")
# Line 755  If MML is non-nil, return the buffer up Line 975  If MML is non-nil, return the buffer up
975        (when value        (when value
976          ;; Quote VALUE if it contains suspicious characters.          ;; Quote VALUE if it contains suspicious characters.
977          (when (string-match "[\"'\\~/*;() \t\n]" value)          (when (string-match "[\"'\\~/*;() \t\n]" value)
978            (setq value (prin1-to-string value)))            (setq value (with-output-to-string
979                            (let (print-escape-nonascii)
980                              (prin1 value)))))
981          (insert (format " %s=%s" key value)))))          (insert (format " %s=%s" key value)))))
982    (insert ">\n"))    (insert ">\n"))
983    
# Line 768  If MML is non-nil, return the buffer up Line 990  If MML is non-nil, return the buffer up
990    
991  ;;; Attachment functions.  ;;; Attachment functions.
992    
993  (defun mml-attach-file (file &optional type description)  (defun mml-attach-file (file &optional type description disposition)
994    "Attach a file to the outgoing MIME message.    "Attach a file to the outgoing MIME message.
995  The file is not inserted or encoded until you send the message with  The file is not inserted or encoded until you send the message with
996  `\\[message-send-and-exit]' or `\\[message-send]'.  `\\[message-send-and-exit]' or `\\[message-send]'.
# Line 779  description of the attachment." Line 1001  description of the attachment."
1001    (interactive    (interactive
1002     (let* ((file (mml-minibuffer-read-file "Attach file: "))     (let* ((file (mml-minibuffer-read-file "Attach file: "))
1003            (type (mml-minibuffer-read-type file))            (type (mml-minibuffer-read-type file))
1004            (description (mml-minibuffer-read-description)))            (description (mml-minibuffer-read-description))
1005       (list file type description)))            (disposition (mml-minibuffer-read-disposition type)))
1006    (mml-insert-empty-tag 'part 'type type 'filename file       (list file type description disposition)))
1007                          'disposition "attachment" 'description description))    (mml-insert-empty-tag 'part
1008                            'type type
1009                            'filename file
1010                            'disposition (or disposition "attachment")
1011                            'description description))
1012    
1013  (defun mml-attach-buffer (buffer &optional type description)  (defun mml-attach-buffer (buffer &optional type description)
1014    "Attach a buffer to the outgoing MIME message.    "Attach a buffer to the outgoing MIME message.
# Line 823  TYPE is the MIME type to use." Line 1049  TYPE is the MIME type to use."
1049    (mml-insert-tag 'part 'type type 'disposition "inline")    (mml-insert-tag 'part 'type type 'disposition "inline")
1050    (forward-line -1))    (forward-line -1))
1051    
1052    (defun mml-preview-insert-mail-followup-to ()
1053      "Insert a Mail-Followup-To header before previewing an article.
1054    Should be adopted if code in `message-send-mail' is changed."
1055      (when (and (message-mail-p)
1056                 (message-subscribed-p)
1057                 (not (mail-fetch-field "mail-followup-to"))
1058                 (message-make-mail-followup-to))
1059        (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1060        (insert (message-make-mail-followup-to))))
1061    
1062  (defun mml-preview (&optional raw)  (defun mml-preview (&optional raw)
1063    "Display current buffer with Gnus, in a new buffer.    "Display current buffer with Gnus, in a new buffer.
1064  If RAW, don't highlight the article."  If RAW, don't highlight the article."
1065    (interactive "P")    (interactive "P")
1066    (let ((buf (current-buffer))    (save-excursion
1067          (message-posting-charset (or (gnus-setup-posting-charset      (let* ((buf (current-buffer))
1068                                        (save-restriction             (message-options message-options)
1069                                          (message-narrow-to-headers-or-head)             (message-this-is-mail (message-mail-p))
1070                                          (message-fetch-field "Newsgroups")))             (message-this-is-news (message-news-p))
1071                                       message-posting-charset)))             (message-posting-charset (or (gnus-setup-posting-charset
1072      (switch-to-buffer (get-buffer-create                                           (save-restriction
1073                         (concat (if raw "*Raw MIME preview of "                                             (message-narrow-to-headers-or-head)
1074                                   "*MIME preview of ") (buffer-name))))                                             (message-fetch-field "Newsgroups")))
1075      (erase-buffer)                                          message-posting-charset)))
1076      (insert-buffer buf)        (message-options-set-recipient)
1077      (if (re-search-forward        (switch-to-buffer (generate-new-buffer
1078           (concat "^" (regexp-quote mail-header-separator) "\n") nil t)                           (concat (if raw "*Raw MIME preview of "
1079          (replace-match "\n"))                                     "*MIME preview of ") (buffer-name))))
1080      (let ((mail-header-separator "")) ;; mail-header-separator is removed.        (when (boundp 'gnus-buffers)
1081        (mml-to-mime))          (push (current-buffer) gnus-buffers))
1082      (if raw        (erase-buffer)
1083          (when (fboundp 'set-buffer-multibyte)        (insert-buffer-substring buf)
1084            (let ((s (buffer-string)))        (mml-preview-insert-mail-followup-to)
1085              ;; Insert the content into unibyte buffer.        (let ((message-deletable-headers (if (message-news-p)
1086              (erase-buffer)                                             nil
1087              (mm-disable-multibyte)                                           message-deletable-headers)))
1088              (insert s)))          (message-generate-headers
1089        (let ((gnus-newsgroup-charset (car message-posting-charset)))           (copy-sequence (if (message-news-p)
1090          (run-hooks 'gnus-article-decode-hook)                              message-required-news-headers
1091          (let ((gnus-newsgroup-name "dummy"))                            message-required-mail-headers))))
1092            (gnus-article-prepare-display))))        (if (re-search-forward
1093      ;; Disable article-mode-map.             (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1094      (use-local-map nil)            (replace-match "\n"))
1095      (setq buffer-read-only t)        (let ((mail-header-separator ""));; mail-header-separator is removed.
1096      (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))          (mml-to-mime))
1097      (goto-char (point-min))))        (if raw
1098              (when (fboundp 'set-buffer-multibyte)
1099                (let ((s (buffer-string)))
1100                  ;; Insert the content into unibyte buffer.
1101                  (erase-buffer)
1102                  (mm-disable-multibyte)
1103                  (insert s)))
1104            (let ((gnus-newsgroup-charset (car message-posting-charset))
1105                  gnus-article-prepare-hook gnus-original-article-buffer)
1106              (run-hooks 'gnus-article-decode-hook)
1107              (let ((gnus-newsgroup-name "dummy")
1108                    (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1109                                            (gnus-make-hashtable 5))))
1110                (gnus-article-prepare-display))))
1111          ;; Disable article-mode-map.
1112          (use-local-map nil)
1113          (gnus-make-local-hook 'kill-buffer-hook)
1114          (add-hook 'kill-buffer-hook
1115                    (lambda ()
1116                      (mm-destroy-parts gnus-article-mime-handles)) nil t)
1117          (setq buffer-read-only t)
1118          (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1119          (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1120          (local-set-key "\r"
1121                         (lambda ()
1122                           (interactive)
1123                           (widget-button-press (point))))
1124          (local-set-key gnus-mouse-2
1125                         (lambda (event)
1126                           (interactive "@e")
1127                           (widget-button-press (widget-event-point event) event)))
1128          (goto-char (point-min)))))
1129    
1130  (defun mml-validate ()  (defun mml-validate ()
1131    "Validate the current MML document."    "Validate the current MML document."
1132    (interactive)    (interactive)
1133    (mml-parse))    (mml-parse))
1134    
1135    (defun mml-tweak-part (cont)
1136      "Tweak a MML part."
1137      (let ((tweak (cdr (assq 'tweak cont)))
1138            func)
1139        (cond
1140         (tweak
1141          (setq func
1142                (or (cdr (assoc tweak mml-tweak-function-alist))
1143                    (intern tweak))))
1144         (mml-tweak-type-alist
1145          (let ((alist mml-tweak-type-alist)
1146                (type (or (cdr (assq 'type cont)) "text/plain")))
1147            (while alist
1148              (if (string-match (caar alist) type)
1149                  (setq func (cdar alist)
1150                        alist nil)
1151                (setq alist (cdr alist)))))))
1152        (if func
1153            (funcall func cont)
1154          cont)
1155        (let ((alist mml-tweak-sexp-alist))
1156          (while alist
1157            (if (eval (caar alist))
1158                (funcall (cdar alist) cont))
1159            (setq alist (cdr alist)))))
1160      cont)
1161    
1162    (defun mml-tweak-externalize-attachments (cont)
1163      "Tweak attached files as external parts."
1164      (let (filename-cons)
1165        (when (and (eq (car cont) 'part)
1166                   (not (cdr (assq 'buffer cont)))
1167                   (and (setq filename-cons (assq 'filename cont))
1168                        (not (equal (cdr (assq 'nofile cont)) "yes"))))
1169          (setcar cont 'external)
1170          (setcar filename-cons 'name))))
1171    
1172  (provide 'mml)  (provide 'mml)
1173    
1174  ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12  ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12

Legend:
Removed from v.1.14.4.2  
changed lines
  Added in v.1.14.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26