Mercurial > emacs
comparison lisp/gnus/mml.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 695cf19ef79e |
children | 497f0d2ca551 cce1c0ee76ee |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; mml.el --- package for parsing and validating MML documents | 1 ;;; mml.el --- A package for parsing and validating MML documents |
2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. | 2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 |
3 ;; Free Software Foundation, Inc. | |
3 | 4 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
5 ;; This file is part of GNU Emacs. | 6 ;; This file is part of GNU Emacs. |
6 | 7 |
7 ;; GNU Emacs is free software; you can redistribute it and/or modify | 8 ;; GNU Emacs is free software; you can redistribute it and/or modify |
25 | 26 |
26 (require 'mm-util) | 27 (require 'mm-util) |
27 (require 'mm-bodies) | 28 (require 'mm-bodies) |
28 (require 'mm-encode) | 29 (require 'mm-encode) |
29 (require 'mm-decode) | 30 (require 'mm-decode) |
31 (require 'mml-sec) | |
30 (eval-when-compile (require 'cl)) | 32 (eval-when-compile (require 'cl)) |
31 | 33 |
32 (eval-and-compile | 34 (eval-and-compile |
33 (autoload 'message-make-message-id "message") | 35 (autoload 'message-make-message-id "message") |
34 (autoload 'gnus-setup-posting-charset "gnus-msg") | 36 (autoload 'gnus-setup-posting-charset "gnus-msg") |
35 (autoload 'gnus-add-minor-mode "gnus-ems") | 37 (autoload 'gnus-add-minor-mode "gnus-ems") |
38 (autoload 'gnus-make-local-hook "gnus-util") | |
36 (autoload 'message-fetch-field "message") | 39 (autoload 'message-fetch-field "message") |
40 (autoload 'fill-flowed-encode "flow-fill") | |
37 (autoload 'message-posting-charset "message")) | 41 (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.") | |
38 | 85 |
39 (defvar mml-generate-multipart-alist nil | 86 (defvar mml-generate-multipart-alist nil |
40 "*Alist of multipart generation functions. | 87 "*Alist of multipart generation functions. |
41 Each entry has the form (NAME . FUNCTION), where | 88 Each entry has the form (NAME . FUNCTION), where |
42 NAME is a string containing the name of the part (without the | 89 NAME is a string containing the name of the part (without the |
71 `unknown-encoding': always send messages contain characters with | 118 `unknown-encoding': always send messages contain characters with |
72 unknown encoding; `use-ascii': always use ASCII for those characters | 119 unknown encoding; `use-ascii': always use ASCII for those characters |
73 with unknown encoding; `multipart': always send messages with more than | 120 with unknown encoding; `multipart': always send messages with more than |
74 one charsets.") | 121 one charsets.") |
75 | 122 |
76 (defvar mml-generate-mime-preprocess-function nil | |
77 "A function called before generating a mime part. | |
78 The function is called with one parameter, which is the part to be | |
79 generated.") | |
80 | |
81 (defvar mml-generate-mime-postprocess-function nil | |
82 "A function called after generating a mime part. | |
83 The function is called with one parameter, which is the generated part.") | |
84 | |
85 (defvar mml-generate-default-type "text/plain") | 123 (defvar mml-generate-default-type "text/plain") |
86 | 124 |
87 (defvar mml-buffer-list nil) | 125 (defvar mml-buffer-list nil) |
88 | 126 |
89 (defun mml-generate-new-buffer (name) | 127 (defun mml-generate-new-buffer (name) |
96 (mapcar 'kill-buffer mml-buffer-list) | 134 (mapcar 'kill-buffer mml-buffer-list) |
97 (setq mml-buffer-list nil))) | 135 (setq mml-buffer-list nil))) |
98 | 136 |
99 (defun mml-parse () | 137 (defun mml-parse () |
100 "Parse the current buffer as an MML document." | 138 "Parse the current buffer as an MML document." |
101 (goto-char (point-min)) | 139 (save-excursion |
102 (let ((table (syntax-table))) | 140 (goto-char (point-min)) |
103 (unwind-protect | 141 (let ((table (syntax-table))) |
104 (progn | 142 (unwind-protect |
105 (set-syntax-table mml-syntax-table) | 143 (progn |
106 (mml-parse-1)) | 144 (set-syntax-table mml-syntax-table) |
107 (set-syntax-table table)))) | 145 (mml-parse-1)) |
146 (set-syntax-table table))))) | |
108 | 147 |
109 (defun mml-parse-1 () | 148 (defun mml-parse-1 () |
110 "Parse the current buffer as an MML document." | 149 "Parse the current buffer as an MML document." |
111 (let (struct tag point contents charsets warn use-ascii no-markup-p raw) | 150 (let (struct tag point contents charsets warn use-ascii no-markup-p raw) |
112 (while (and (not (eobp)) | 151 (while (and (not (eobp)) |
113 (not (looking-at "<#/multipart"))) | 152 (not (looking-at "<#/multipart"))) |
114 (cond | 153 (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))) | |
115 ((looking-at "<#multipart") | 191 ((looking-at "<#multipart") |
116 (push (nconc (mml-read-tag) (mml-parse-1)) struct)) | 192 (push (nconc (mml-read-tag) (mml-parse-1)) struct)) |
117 ((looking-at "<#external") | 193 ((looking-at "<#external") |
118 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part)))) | 194 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part)))) |
119 struct)) | 195 struct)) |
126 no-markup-p t | 202 no-markup-p t |
127 warn t)) | 203 warn t)) |
128 (setq raw (cdr (assq 'raw tag)) | 204 (setq raw (cdr (assq 'raw tag)) |
129 point (point) | 205 point (point) |
130 contents (mml-read-part (eq 'mml (car tag))) | 206 contents (mml-read-part (eq 'mml (car tag))) |
131 charsets (if raw nil | 207 charsets (cond |
132 (mm-find-mime-charset-region point (point)))) | 208 (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)))) | |
133 (when (and (not raw) (memq nil charsets)) | 215 (when (and (not raw) (memq nil charsets)) |
134 (if (or (memq 'unknown-encoding mml-confirmation-set) | 216 (if (or (memq 'unknown-encoding mml-confirmation-set) |
135 (prog1 (y-or-n-p | 217 (message-options-get 'unknown-encoding) |
136 "\ | 218 (and (y-or-n-p "\ |
137 Message contains characters with unknown encoding. Really send?") | 219 Message contains characters with unknown encoding. Really send? ") |
138 (set (make-local-variable 'mml-confirmation-set) | 220 (message-options-set 'unknown-encoding t))) |
139 (push 'unknown-encoding mml-confirmation-set)))) | |
140 (if (setq use-ascii | 221 (if (setq use-ascii |
141 (or (memq 'use-ascii mml-confirmation-set) | 222 (or (memq 'use-ascii mml-confirmation-set) |
142 (y-or-n-p "Use ASCII as charset?"))) | 223 (message-options-get 'use-ascii) |
224 (and (y-or-n-p "Use ASCII as charset? ") | |
225 (message-options-set 'use-ascii t)))) | |
143 (setq charsets (delq nil charsets)) | 226 (setq charsets (delq nil charsets)) |
144 (setq warn nil)) | 227 (setq warn nil)) |
145 (error "Edit your message to remove those characters"))) | 228 (error "Edit your message to remove those characters"))) |
146 (if (or raw | 229 (if (or raw |
147 (eq 'mml (car tag)) | 230 (eq 'mml (car tag)) |
153 struct)) | 236 struct)) |
154 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets | 237 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets |
155 tag point (point) use-ascii))) | 238 tag point (point) use-ascii))) |
156 (when (and warn | 239 (when (and warn |
157 (not (memq 'multipart mml-confirmation-set)) | 240 (not (memq 'multipart mml-confirmation-set)) |
158 (not | 241 (not (message-options-get 'multipart)) |
159 (prog1 (y-or-n-p | 242 (not (and (y-or-n-p (format "\ |
160 (format | |
161 "\ | |
162 A message part needs to be split into %d charset parts. Really send? " | 243 A message part needs to be split into %d charset parts. Really send? " |
163 (length nstruct))) | 244 (length nstruct))) |
164 (set (make-local-variable 'mml-confirmation-set) | 245 (message-options-set 'multipart t)))) |
165 (push 'multipart mml-confirmation-set))))) | |
166 (error "Edit your message to use only one charset")) | 246 (error "Edit your message to use only one charset")) |
167 (setq struct (nconc nstruct struct))))))) | 247 (setq struct (nconc nstruct struct))))))) |
168 (unless (eobp) | 248 (unless (eobp) |
169 (forward-line 1)) | 249 (forward-line 1)) |
170 (nreverse struct))) | 250 (nreverse struct))) |
227 struct)) | 307 struct)) |
228 struct)))) | 308 struct)))) |
229 | 309 |
230 (defun mml-read-tag () | 310 (defun mml-read-tag () |
231 "Read a tag and return the contents." | 311 "Read a tag and return the contents." |
232 (let (contents name elem val) | 312 (let ((orig-point (point)) |
313 contents name elem val) | |
233 (forward-char 2) | 314 (forward-char 2) |
234 (setq name (buffer-substring-no-properties | 315 (setq name (buffer-substring-no-properties |
235 (point) (progn (forward-sexp 1) (point)))) | 316 (point) (progn (forward-sexp 1) (point)))) |
236 (skip-chars-forward " \t\n") | 317 (skip-chars-forward " \t\n") |
237 (while (not (looking-at ">")) | 318 (while (not (looking-at ">[ \t]*\n?")) |
238 (setq elem (buffer-substring-no-properties | 319 (setq elem (buffer-substring-no-properties |
239 (point) (progn (forward-sexp 1) (point)))) | 320 (point) (progn (forward-sexp 1) (point)))) |
240 (skip-chars-forward "= \t\n") | 321 (skip-chars-forward "= \t\n") |
241 (setq val (buffer-substring-no-properties | 322 (setq val (buffer-substring-no-properties |
242 (point) (progn (forward-sexp 1) (point)))) | 323 (point) (progn (forward-sexp 1) (point)))) |
243 (when (string-match "^\"\\(.*\\)\"$" val) | 324 (when (string-match "^\"\\(.*\\)\"$" val) |
244 (setq val (match-string 1 val))) | 325 (setq val (match-string 1 val))) |
245 (push (cons (intern elem) val) contents) | 326 (push (cons (intern elem) val) contents) |
246 (skip-chars-forward " \t\n")) | 327 (skip-chars-forward " \t\n")) |
247 (forward-char 1) | 328 (goto-char (match-end 0)) |
248 (skip-chars-forward " \t\n") | 329 ;; 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)) | |
249 (cons (intern name) (nreverse contents)))) | 333 (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)) | |
250 | 343 |
251 (defun mml-read-part (&optional mml) | 344 (defun mml-read-part (&optional mml) |
252 "Return the buffer up till the next part, multipart or closing part or multipart. | 345 "Return the buffer up till the next part, multipart or closing part or multipart. |
253 If MML is non-nil, return the buffer up till the correspondent mml tag." | 346 If MML is non-nil, return the buffer up till the correspondent mml tag." |
254 (let ((beg (point)) (count 1)) | 347 (let ((beg (point)) (count 1)) |
255 ;; If the tag ended at the end of the line, we go to the next line. | 348 ;; If the tag ended at the end of the line, we go to the next line. |
256 (when (looking-at "[ \t]*\n") | 349 (when (looking-at "[ \t]*\n") |
257 (forward-line 1)) | 350 (forward-line 1)) |
258 (if mml | 351 (if mml |
259 (progn | 352 (progn |
260 (while (and (> count 0) (not (eobp))) | 353 (while (and (> count 0) (not (eobp))) |
261 (if (re-search-forward "<#\\(/\\)?mml." nil t) | 354 (if (re-search-forward "<#\\(/\\)?mml." nil t) |
262 (setq count (+ count (if (match-beginning 1) -1 1))) | 355 (setq count (+ count (if (match-beginning 1) -1 1))) |
263 (goto-char (point-max)))) | 356 (goto-char (point-max)))) |
264 (buffer-substring-no-properties beg (if (> count 0) | 357 (mml-buffer-substring-no-properties-except-hard-newlines |
265 (point) | 358 beg (if (> count 0) |
266 (match-beginning 0)))) | 359 (point) |
360 (match-beginning 0)))) | |
267 (if (re-search-forward | 361 (if (re-search-forward |
268 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) | 362 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) |
269 (prog1 | 363 (prog1 |
270 (buffer-substring-no-properties beg (match-beginning 0)) | 364 (mml-buffer-substring-no-properties-except-hard-newlines |
365 beg (match-beginning 0)) | |
271 (if (or (not (match-beginning 1)) | 366 (if (or (not (match-beginning 1)) |
272 (equal (match-string 2) "multipart")) | 367 (equal (match-string 2) "multipart")) |
273 (goto-char (match-beginning 0)) | 368 (goto-char (match-beginning 0)) |
274 (when (looking-at "[ \t]*\n") | 369 (when (looking-at "[ \t]*\n") |
275 (forward-line 1)))) | 370 (forward-line 1)))) |
276 (buffer-substring-no-properties beg (goto-char (point-max))))))) | 371 (mml-buffer-substring-no-properties-except-hard-newlines |
372 beg (goto-char (point-max))))))) | |
277 | 373 |
278 (defvar mml-boundary nil) | 374 (defvar mml-boundary nil) |
279 (defvar mml-base-boundary "-=-=") | 375 (defvar mml-base-boundary "-=-=") |
280 (defvar mml-multipart-number 0) | 376 (defvar mml-multipart-number 0) |
281 | 377 |
292 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) | 388 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed")) |
293 cont))) | 389 cont))) |
294 (buffer-string))))) | 390 (buffer-string))))) |
295 | 391 |
296 (defun mml-generate-mime-1 (cont) | 392 (defun mml-generate-mime-1 (cont) |
297 (save-restriction | 393 (let ((mm-use-ultra-safe-encoding |
298 (narrow-to-region (point) (point)) | 394 (or mm-use-ultra-safe-encoding (assq 'sign cont)))) |
299 (if mml-generate-mime-preprocess-function | 395 (save-restriction |
300 (funcall mml-generate-mime-preprocess-function cont)) | 396 (narrow-to-region (point) (point)) |
301 (cond | 397 (mml-tweak-part cont) |
302 ((or (eq (car cont) 'part) (eq (car cont) 'mml)) | 398 (cond |
303 (let ((raw (cdr (assq 'raw cont))) | 399 ((or (eq (car cont) 'part) (eq (car cont) 'mml)) |
304 coded encoding charset filename type) | 400 (let ((raw (cdr (assq 'raw cont))) |
305 (setq type (or (cdr (assq 'type cont)) "text/plain")) | 401 coded encoding charset filename type flowed) |
306 (if (and (not raw) | 402 (setq type (or (cdr (assq 'type cont)) "text/plain")) |
307 (member (car (split-string type "/")) '("text" "message"))) | 403 (if (and (not raw) |
308 (progn | 404 (member (car (split-string type "/")) '("text" "message"))) |
309 (with-temp-buffer | 405 (progn |
310 (cond | 406 (with-temp-buffer |
311 ((cdr (assq 'buffer cont)) | 407 (setq charset (mm-charset-to-coding-system |
312 (insert-buffer-substring (cdr (assq 'buffer cont)))) | 408 (cdr (assq 'charset cont)))) |
313 ((and (setq filename (cdr (assq 'filename cont))) | 409 (when (eq charset 'ascii) |
314 (not (equal (cdr (assq 'nofile cont)) "yes"))) | 410 (setq charset nil)) |
315 (mm-insert-file-contents filename)) | 411 (cond |
316 ((eq 'mml (car cont)) | 412 ((cdr (assq 'buffer cont)) |
317 (insert (cdr (assq 'contents cont)))) | 413 (insert-buffer-substring (cdr (assq 'buffer cont)))) |
318 (t | 414 ((and (setq filename (cdr (assq 'filename cont))) |
319 (save-restriction | 415 (not (equal (cdr (assq 'nofile cont)) "yes"))) |
320 (narrow-to-region (point) (point)) | 416 (let ((coding-system-for-read charset)) |
321 (insert (cdr (assq 'contents cont))) | 417 (mm-insert-file-contents filename))) |
322 ;; Remove quotes from quoted tags. | 418 ((eq 'mml (car cont)) |
323 (goto-char (point-min)) | 419 (insert (cdr (assq 'contents cont)))) |
324 (while (re-search-forward | 420 (t |
325 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t) | 421 (save-restriction |
326 (delete-region (+ (match-beginning 0) 2) | 422 (narrow-to-region (point) (point)) |
327 (+ (match-beginning 0) 3)))))) | 423 (insert (cdr (assq 'contents cont))) |
328 (cond | 424 ;; Remove quotes from quoted tags. |
329 ((eq (car cont) 'mml) | 425 (goto-char (point-min)) |
330 (let ((mml-boundary (funcall mml-boundary-function | 426 (while (re-search-forward |
331 (incf mml-multipart-number))) | 427 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" |
332 (mml-generate-default-type "text/plain")) | 428 nil t) |
333 (mml-to-mime)) | 429 (delete-region (+ (match-beginning 0) 2) |
334 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) | 430 (+ (match-beginning 0) 3)))))) |
335 ;; ignore 0x1b, it is part of iso-2022-jp | 431 (cond |
336 (setq encoding (mm-body-7-or-8)))) | 432 ((eq (car cont) 'mml) |
337 ((string= (car (split-string type "/")) "message") | 433 (let ((mml-boundary (mml-compute-boundary cont)) |
338 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) | 434 (mml-generate-default-type "text/plain")) |
339 ;; ignore 0x1b, it is part of iso-2022-jp | 435 (mml-to-mime)) |
340 (setq encoding (mm-body-7-or-8)))) | 436 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) |
341 (t | 437 ;; ignore 0x1b, it is part of iso-2022-jp |
342 (setq charset (mm-encode-body)) | 438 (setq encoding (mm-body-7-or-8)))) |
343 (setq encoding (mm-body-encoding | 439 ((string= (car (split-string type "/")) "message") |
344 charset (cdr (assq 'encoding cont)))))) | 440 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) |
345 (setq coded (buffer-string))) | 441 ;; ignore 0x1b, it is part of iso-2022-jp |
346 (mml-insert-mime-headers cont type charset encoding) | 442 (setq encoding (mm-body-7-or-8)))) |
347 (insert "\n") | 443 (t |
348 (insert coded)) | 444 ;; Only perform format=flowed filling on text/plain |
349 (mm-with-unibyte-buffer | 445 ;; parts where there either isn't a format parameter |
350 (cond | 446 ;; in the mml tag or it says "flowed" and there |
351 ((cdr (assq 'buffer cont)) | 447 ;; actually are hard newlines in the text. |
352 (insert-buffer-substring (cdr (assq 'buffer cont)))) | 448 (let (use-hard-newlines) |
353 ((and (setq filename (cdr (assq 'filename cont))) | 449 (when (and (string= type "text/plain") |
354 (not (equal (cdr (assq 'nofile cont)) "yes"))) | 450 (or (null (assq 'format cont)) |
355 (let ((coding-system-for-read mm-binary-coding-system)) | 451 (string= (cdr (assq 'format cont)) |
356 (mm-insert-file-contents filename nil nil nil nil t))) | 452 "flowed")) |
357 (t | 453 (setq use-hard-newlines |
358 (insert (cdr (assq 'contents cont))))) | 454 (text-property-any |
359 (setq encoding (mm-encode-buffer type) | 455 (point-min) (point-max) 'hard 't))) |
360 coded (buffer-string))) | 456 (fill-flowed-encode) |
361 (mml-insert-mime-headers cont type charset encoding) | 457 ;; Indicate that `mml-insert-mime-headers' should |
362 (insert "\n") | 458 ;; insert a "; format=flowed" string unless the |
363 (mm-with-unibyte-current-buffer | 459 ;; user has already specified it. |
364 (insert coded))))) | 460 (setq flowed (null (assq 'format cont))))) |
365 ((eq (car cont) 'external) | 461 (setq charset (mm-encode-body charset)) |
366 (insert "Content-Type: message/external-body") | 462 (setq encoding (mm-body-encoding |
367 (let ((parameters (mml-parameter-string | 463 charset (cdr (assq 'encoding cont)))))) |
368 cont '(expiration size permission))) | 464 (setq coded (buffer-string))) |
369 (name (cdr (assq 'name cont)))) | 465 (mml-insert-mime-headers cont type charset encoding flowed) |
370 (when name | 466 (insert "\n") |
371 (setq name (mml-parse-file-name name)) | 467 (insert coded)) |
372 (if (stringp name) | 468 (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") | |
373 (mml-insert-parameter | 496 (mml-insert-parameter |
374 (mail-header-encode-parameter "name" name) | 497 (mail-header-encode-parameter |
375 "access-type=local-file") | 498 "name" (file-name-nondirectory (nth 2 name))) |
499 (mail-header-encode-parameter "site" (nth 1 name)) | |
500 (mail-header-encode-parameter | |
501 "directory" (file-name-directory (nth 2 name)))) | |
502 (mml-insert-parameter | |
503 (concat "access-type=" | |
504 (if (member (nth 0 name) '("ftp@" "anonymous@")) | |
505 "anon-ftp" | |
506 "ftp"))))) | |
507 (when url | |
376 (mml-insert-parameter | 508 (mml-insert-parameter |
377 (mail-header-encode-parameter | 509 (mail-header-encode-parameter "url" url) |
378 "name" (file-name-nondirectory (nth 2 name))) | 510 "access-type=url")) |
379 (mail-header-encode-parameter "site" (nth 1 name)) | 511 (when parameters |
380 (mail-header-encode-parameter | 512 (mml-insert-parameter-string |
381 "directory" (file-name-directory (nth 2 name)))) | 513 cont '(expiration size permission)))) |
382 (mml-insert-parameter | 514 (insert "\n\n") |
383 (concat "access-type=" | 515 (insert "Content-Type: " (cdr (assq 'type cont)) "\n") |
384 (if (member (nth 0 name) '("ftp@" "anonymous@")) | 516 (insert "Content-ID: " (message-make-message-id) "\n") |
385 "anon-ftp" | 517 (insert "Content-Transfer-Encoding: " |
386 "ftp"))))) | 518 (or (cdr (assq 'encoding cont)) "binary")) |
387 (when parameters | 519 (insert "\n\n") |
388 (mml-insert-parameter-string | 520 (insert (or (cdr (assq 'contents cont)))) |
389 cont '(expiration size permission)))) | 521 (insert "\n")) |
390 (insert "\n\n") | 522 ((eq (car cont) 'multipart) |
391 (insert "Content-Type: " (cdr (assq 'type cont)) "\n") | 523 (let* ((type (or (cdr (assq 'type cont)) "mixed")) |
392 (insert "Content-ID: " (message-make-message-id) "\n") | 524 (mml-generate-default-type (if (equal type "digest") |
393 (insert "Content-Transfer-Encoding: " | 525 "message/rfc822" |
394 (or (cdr (assq 'encoding cont)) "binary")) | 526 "text/plain")) |
395 (insert "\n\n") | 527 (handler (assoc type mml-generate-multipart-alist))) |
396 (insert (or (cdr (assq 'contents cont)))) | 528 (if handler |
397 (insert "\n")) | 529 (funcall (cdr handler) cont) |
398 ((eq (car cont) 'multipart) | 530 ;; No specific handler. Use default one. |
399 (let* ((type (or (cdr (assq 'type cont)) "mixed")) | 531 (let ((mml-boundary (mml-compute-boundary cont))) |
400 (mml-generate-default-type (if (equal type "digest") | 532 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"" |
401 "message/rfc822" | 533 type mml-boundary) |
402 "text/plain")) | 534 (if (cdr (assq 'start cont)) |
403 (handler (assoc type mml-generate-multipart-alist))) | 535 (format "; start=\"%s\"\n" (cdr (assq 'start cont))) |
404 (if handler | 536 "\n")) |
405 (funcall (cdr handler) cont) | 537 (let ((cont cont) part) |
406 ;; No specific handler. Use default one. | 538 (while (setq part (pop cont)) |
407 (let ((mml-boundary (mml-compute-boundary cont))) | 539 ;; Skip `multipart' and attributes. |
408 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" | 540 (when (and (consp part) (consp (cdr part))) |
409 type mml-boundary)) | 541 (insert "\n--" mml-boundary "\n") |
410 ;; Skip `multipart' and `type' elements. | 542 (mml-generate-mime-1 part)))) |
411 (setq cont (cddr cont)) | 543 (insert "\n--" mml-boundary "--\n"))))) |
412 (while cont | 544 (t |
413 (insert "\n--" mml-boundary "\n") | 545 (error "Invalid element: %S" cont))) |
414 (mml-generate-mime-1 (pop cont))) | 546 ;; handle sign & encrypt tags in a semi-smart way. |
415 (insert "\n--" mml-boundary "--\n"))))) | 547 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) |
416 (t | 548 (encrypt-item (assoc (cdr (assq 'encrypt cont)) |
417 (error "Invalid element: %S" cont))) | 549 mml-encrypt-alist)) |
418 (if mml-generate-mime-postprocess-function | 550 sender recipients) |
419 (funcall mml-generate-mime-postprocess-function cont)))) | 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))))))))) | |
420 | 570 |
421 (defun mml-compute-boundary (cont) | 571 (defun mml-compute-boundary (cont) |
422 "Return a unique boundary that does not exist in CONT." | 572 "Return a unique boundary that does not exist in CONT." |
423 (let ((mml-boundary (funcall mml-boundary-function | 573 (let ((mml-boundary (funcall mml-boundary-function |
424 (incf mml-multipart-number)))) | 574 (incf mml-multipart-number)))) |
456 (if (> number 17) | 606 (if (> number 17) |
457 (format "%x" number) | 607 (format "%x" number) |
458 "") | 608 "") |
459 mml-base-boundary)) | 609 mml-base-boundary)) |
460 | 610 |
461 (defun mml-insert-mime-headers (cont type charset encoding) | 611 (defun mml-insert-mime-headers (cont type charset encoding flowed) |
462 (let (parameters disposition description) | 612 (let (parameters id disposition description) |
463 (setq parameters | 613 (setq parameters |
464 (mml-parameter-string | 614 (mml-parameter-string |
465 cont '(name access-type expiration size permission))) | 615 cont mml-content-type-parameters)) |
466 (when (or charset | 616 (when (or charset |
467 parameters | 617 parameters |
468 (not (equal type mml-generate-default-type))) | 618 flowed |
619 (not (equal type mml-generate-default-type)) | |
620 mml-insert-mime-headers-always) | |
469 (when (consp charset) | 621 (when (consp charset) |
470 (error | 622 (error |
471 "Can't encode a part with several charsets.")) | 623 "Can't encode a part with several charsets")) |
472 (insert "Content-Type: " type) | 624 (insert "Content-Type: " type) |
473 (when charset | 625 (when charset |
474 (insert "; " (mail-header-encode-parameter | 626 (insert "; " (mail-header-encode-parameter |
475 "charset" (symbol-name charset)))) | 627 "charset" (symbol-name charset)))) |
628 (when flowed | |
629 (insert "; format=flowed")) | |
476 (when parameters | 630 (when parameters |
477 (mml-insert-parameter-string | 631 (mml-insert-parameter-string |
478 cont '(name access-type expiration size permission))) | 632 cont mml-content-type-parameters)) |
479 (insert "\n")) | 633 (insert "\n")) |
634 (when (setq id (cdr (assq 'id cont))) | |
635 (insert "Content-ID: " id "\n")) | |
480 (setq parameters | 636 (setq parameters |
481 (mml-parameter-string | 637 (mml-parameter-string |
482 cont '(filename creation-date modification-date read-date))) | 638 cont mml-content-disposition-parameters)) |
483 (when (or (setq disposition (cdr (assq 'disposition cont))) | 639 (when (or (setq disposition (cdr (assq 'disposition cont))) |
484 parameters) | 640 parameters) |
485 (insert "Content-Disposition: " (or disposition "inline")) | 641 (insert "Content-Disposition: " (or disposition "inline")) |
486 (when parameters | 642 (when parameters |
487 (mml-insert-parameter-string | 643 (mml-insert-parameter-string |
488 cont '(filename creation-date modification-date read-date))) | 644 cont mml-content-disposition-parameters)) |
489 (insert "\n")) | 645 (insert "\n")) |
490 (unless (eq encoding '7bit) | 646 (unless (eq encoding '7bit) |
491 (insert (format "Content-Transfer-Encoding: %s\n" encoding))) | 647 (insert (format "Content-Transfer-Encoding: %s\n" encoding))) |
492 (when (setq description (cdr (assq 'description cont))) | 648 (when (setq description (cdr (assq 'description cont))) |
493 (insert "Content-Description: " | 649 (insert "Content-Description: " |
540 | 696 |
541 ;;; | 697 ;;; |
542 ;;; Transforming MIME to MML | 698 ;;; Transforming MIME to MML |
543 ;;; | 699 ;;; |
544 | 700 |
545 (defun mime-to-mml () | 701 (defun mime-to-mml (&optional handles) |
546 "Translate the current buffer (which should be a message) into MML." | 702 "Translate the current buffer (which should be a message) into MML. |
703 If HANDLES is non-nil, use it instead reparsing the buffer." | |
547 ;; First decode the head. | 704 ;; First decode the head. |
548 (save-restriction | 705 (save-restriction |
549 (message-narrow-to-head) | 706 (message-narrow-to-head) |
550 (mail-decode-encoded-word-region (point-min) (point-max))) | 707 (mail-decode-encoded-word-region (point-min) (point-max))) |
551 (let ((handles (mm-dissect-buffer t))) | 708 (unless handles |
552 (goto-char (point-min)) | 709 (setq handles (mm-dissect-buffer t))) |
553 (search-forward "\n\n" nil t) | 710 (goto-char (point-min)) |
554 (delete-region (point) (point-max)) | 711 (search-forward "\n\n" nil t) |
555 (if (stringp (car handles)) | 712 (delete-region (point) (point-max)) |
556 (mml-insert-mime handles) | 713 (if (stringp (car handles)) |
557 (mml-insert-mime handles t)) | 714 (mml-insert-mime handles) |
558 (mm-destroy-parts handles)) | 715 (mml-insert-mime handles t)) |
716 (mm-destroy-parts handles) | |
559 (save-restriction | 717 (save-restriction |
560 (message-narrow-to-head) | 718 (message-narrow-to-head) |
561 ;; Remove them, they are confusing. | 719 ;; Remove them, they are confusing. |
562 (message-remove-header "Content-Type") | 720 (message-remove-header "Content-Type") |
563 (message-remove-header "MIME-Version") | 721 (message-remove-header "MIME-Version") |
722 (message-remove-header "Content-Disposition") | |
564 (message-remove-header "Content-Transfer-Encoding"))) | 723 (message-remove-header "Content-Transfer-Encoding"))) |
565 | 724 |
566 (defun mml-to-mime () | 725 (defun mml-to-mime () |
567 "Translate the current buffer from MML to MIME." | 726 "Translate the current buffer from MML to MIME." |
568 (message-encode-message-body) | 727 (message-encode-message-body) |
569 (save-restriction | 728 (save-restriction |
570 (message-narrow-to-headers-or-head) | 729 (message-narrow-to-headers-or-head) |
730 ;; Skip past any From_ headers. | |
731 (while (looking-at "From ") | |
732 (forward-line 1)) | |
571 (let ((mail-parse-charset message-default-charset)) | 733 (let ((mail-parse-charset message-default-charset)) |
572 (mail-encode-encoded-word-buffer)))) | 734 (mail-encode-encoded-word-buffer)))) |
573 | 735 |
574 (defun mml-insert-mime (handle &optional no-markup) | 736 (defun mml-insert-mime (handle &optional no-markup) |
575 (let (textp buffer mmlp) | 737 (let (textp buffer mmlp) |
587 (unless (and no-markup | 749 (unless (and no-markup |
588 (equal (mm-handle-media-type handle) "text/plain")) | 750 (equal (mm-handle-media-type handle) "text/plain")) |
589 (mml-insert-mml-markup handle buffer textp))) | 751 (mml-insert-mml-markup handle buffer textp))) |
590 (cond | 752 (cond |
591 (mmlp | 753 (mmlp |
592 (insert-buffer buffer) | 754 (insert-buffer-substring buffer) |
593 (goto-char (point-max)) | 755 (goto-char (point-max)) |
594 (insert "<#/mml>\n")) | 756 (insert "<#/mml>\n")) |
595 ((stringp (car handle)) | 757 ((stringp (car handle)) |
596 (mapcar 'mml-insert-mime (cdr handle)) | 758 (mapcar 'mml-insert-mime (cdr handle)) |
597 (insert "<#/multipart>\n")) | 759 (insert "<#/multipart>\n")) |
598 (textp | 760 (textp |
599 (let ((text (mm-get-part handle)) | 761 (let ((charset (mail-content-type-get |
600 (charset (mail-content-type-get | 762 (mm-handle-type handle) 'charset)) |
601 (mm-handle-type handle) 'charset))) | 763 (start (point))) |
602 (insert (mm-decode-string text charset))) | 764 (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))) | |
603 (goto-char (point-max))) | 768 (goto-char (point-max))) |
604 (t | 769 (t |
605 (insert "<#/part>\n"))))) | 770 (insert "<#/part>\n"))))) |
606 | 771 |
607 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp) | 772 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp) |
608 "Take a MIME handle and insert an MML tag." | 773 "Take a MIME handle and insert an MML tag." |
609 (if (stringp (car handle)) | 774 (if (stringp (car handle)) |
610 (insert "<#multipart type=" (mm-handle-media-subtype handle) | 775 (progn |
611 ">\n") | 776 (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")) | |
612 (if mmlp | 781 (if mmlp |
613 (insert "<#mml type=" (mm-handle-media-type handle)) | 782 (insert "<#mml type=" (mm-handle-media-type handle)) |
614 (insert "<#part type=" (mm-handle-media-type handle))) | 783 (insert "<#part type=" (mm-handle-media-type handle))) |
615 (dolist (elem (append (cdr (mm-handle-type handle)) | 784 (dolist (elem (append (cdr (mm-handle-type handle)) |
616 (cdr (mm-handle-disposition handle)))) | 785 (cdr (mm-handle-disposition handle)))) |
617 (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")) | 786 (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) "\"")) | |
618 (when (mm-handle-disposition handle) | 790 (when (mm-handle-disposition handle) |
619 (insert " disposition=" (car (mm-handle-disposition handle)))) | 791 (insert " disposition=" (car (mm-handle-disposition handle)))) |
620 (when buffer | 792 (when buffer |
621 (insert " buffer=\"" (buffer-name buffer) "\"")) | 793 (insert " buffer=\"" (buffer-name buffer) "\"")) |
622 (when nofile | 794 (when nofile |
639 ;;; | 811 ;;; |
640 ;;; Mode for inserting and editing MML forms | 812 ;;; Mode for inserting and editing MML forms |
641 ;;; | 813 ;;; |
642 | 814 |
643 (defvar mml-mode-map | 815 (defvar mml-mode-map |
644 (let ((map (make-sparse-keymap)) | 816 (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)) | |
645 (main (make-sparse-keymap))) | 821 (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) | |
646 (define-key map "f" 'mml-attach-file) | 835 (define-key map "f" 'mml-attach-file) |
647 (define-key map "b" 'mml-attach-buffer) | 836 (define-key map "b" 'mml-attach-buffer) |
648 (define-key map "e" 'mml-attach-external) | 837 (define-key map "e" 'mml-attach-external) |
649 (define-key map "q" 'mml-quote-region) | 838 (define-key map "q" 'mml-quote-region) |
650 (define-key map "m" 'mml-insert-multipart) | 839 (define-key map "m" 'mml-insert-multipart) |
651 (define-key map "p" 'mml-insert-part) | 840 (define-key map "p" 'mml-insert-part) |
652 (define-key map "v" 'mml-validate) | 841 (define-key map "v" 'mml-validate) |
653 (define-key map "P" 'mml-preview) | 842 (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) | |
654 ;;(define-key map "n" 'mml-narrow-to-part) | 847 ;;(define-key map "n" 'mml-narrow-to-part) |
655 (define-key main "\M-m" map) | 848 ;; `M-m' conflicts with `back-to-indentation'. |
849 ;; (define-key main "\M-m" map) | |
850 (define-key main "\C-c\C-m" map) | |
656 main)) | 851 main)) |
657 | 852 |
658 (easy-menu-define | 853 (easy-menu-define |
659 mml-menu mml-mode-map "" | 854 mml-menu mml-mode-map "" |
660 '("MML" | 855 `("Attachments" |
661 ("Attach" | 856 ["Attach File..." mml-attach-file |
662 ["File" mml-attach-file t] | 857 ,@(if (featurep 'xemacs) '(t) |
663 ["Buffer" mml-attach-buffer t] | 858 '(:help "Attach a file at point"))] |
664 ["External" mml-attach-external t]) | 859 ["Attach Buffer..." mml-attach-buffer t] |
665 ("Insert" | 860 ["Attach External..." mml-attach-external t] |
666 ["Multipart" mml-insert-multipart t] | 861 ["Insert Part..." mml-insert-part t] |
667 ["Part" mml-insert-part t]) | 862 ["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] | |
668 ;;["Narrow" mml-narrow-to-part t] | 877 ;;["Narrow" mml-narrow-to-part t] |
669 ["Quote" mml-quote-region t] | 878 ["Quote MML" mml-quote-region t] |
670 ["Validate" mml-validate t] | 879 ["Validate MML" mml-validate t] |
671 ["Preview" mml-preview t])) | 880 ["Preview" mml-preview t])) |
672 | 881 |
673 (defvar mml-mode nil | 882 (defvar mml-mode nil |
674 "Minor mode for editing MML.") | 883 "Minor mode for editing MML.") |
675 | 884 |
676 (defun mml-mode (&optional arg) | 885 (defun mml-mode (&optional arg) |
677 "Minor mode for editing MML. | 886 "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'. | |
678 | 889 |
679 \\{mml-mode-map}" | 890 \\{mml-mode-map}" |
680 (interactive "P") | 891 (interactive "P") |
681 (if (not (set (make-local-variable 'mml-mode) | 892 (when (set (make-local-variable 'mml-mode) |
682 (if (null arg) (not mml-mode) | 893 (if (null arg) (not mml-mode) |
683 (> (prefix-numeric-value arg) 0)))) | 894 (> (prefix-numeric-value arg) 0))) |
684 nil | 895 (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map) |
685 (set (make-local-variable 'mml-mode) t) | 896 (easy-menu-add mml-menu mml-mode-map) |
686 (unless (assq 'mml-mode minor-mode-alist) | 897 (run-hooks 'mml-mode-hook))) |
687 (push `(mml-mode " MML") minor-mode-alist)) | |
688 (unless (assq 'mml-mode minor-mode-map-alist) | |
689 (push (cons 'mml-mode mml-mode-map) | |
690 minor-mode-map-alist))) | |
691 (run-hooks 'mml-mode-hook)) | |
692 | 898 |
693 ;;; | 899 ;;; |
694 ;;; Helper functions for reading MIME stuff from the minibuffer and | 900 ;;; Helper functions for reading MIME stuff from the minibuffer and |
695 ;;; inserting stuff to the buffer. | 901 ;;; inserting stuff to the buffer. |
696 ;;; | 902 ;;; |
697 | 903 |
698 (defun mml-minibuffer-read-file (prompt) | 904 (defun mml-minibuffer-read-file (prompt) |
699 (let ((file (read-file-name prompt nil nil t))) | 905 (let* ((completion-ignored-extensions nil) |
700 ;; Prevent some common errors. This is inspired by similar code in | 906 (file (read-file-name prompt nil nil t))) |
907 ;; Prevent some common errors. This is inspired by similar code in | |
701 ;; VM. | 908 ;; VM. |
702 (when (file-directory-p file) | 909 (when (file-directory-p file) |
703 (error "%s is a directory, cannot attach" file)) | 910 (error "%s is a directory, cannot attach" file)) |
704 (unless (file-exists-p file) | 911 (unless (file-exists-p file) |
705 (error "No such file: %s" file)) | 912 (error "No such file: %s" file)) |
725 (defun mml-minibuffer-read-description () | 932 (defun mml-minibuffer-read-description () |
726 (let ((description (read-string "One line description: "))) | 933 (let ((description (read-string "One line description: "))) |
727 (when (string-match "\\`[ \t]*\\'" description) | 934 (when (string-match "\\`[ \t]*\\'" description) |
728 (setq description nil)) | 935 (setq description nil)) |
729 description)) | 936 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))) | |
730 | 950 |
731 (defun mml-quote-region (beg end) | 951 (defun mml-quote-region (beg end) |
732 "Quote the MML tags in the region." | 952 "Quote the MML tags in the region." |
733 (interactive "r") | 953 (interactive "r") |
734 (save-excursion | 954 (save-excursion |
753 (let ((key (pop plist)) | 973 (let ((key (pop plist)) |
754 (value (pop plist))) | 974 (value (pop plist))) |
755 (when value | 975 (when value |
756 ;; Quote VALUE if it contains suspicious characters. | 976 ;; Quote VALUE if it contains suspicious characters. |
757 (when (string-match "[\"'\\~/*;() \t\n]" value) | 977 (when (string-match "[\"'\\~/*;() \t\n]" value) |
758 (setq value (prin1-to-string value))) | 978 (setq value (with-output-to-string |
979 (let (print-escape-nonascii) | |
980 (prin1 value))))) | |
759 (insert (format " %s=%s" key value))))) | 981 (insert (format " %s=%s" key value))))) |
760 (insert ">\n")) | 982 (insert ">\n")) |
761 | 983 |
762 (defun mml-insert-empty-tag (name &rest plist) | 984 (defun mml-insert-empty-tag (name &rest plist) |
763 "Insert an empty MML tag described by NAME and PLIST." | 985 "Insert an empty MML tag described by NAME and PLIST." |
766 (apply #'mml-insert-tag name plist) | 988 (apply #'mml-insert-tag name plist) |
767 (insert "<#/" name ">\n")) | 989 (insert "<#/" name ">\n")) |
768 | 990 |
769 ;;; Attachment functions. | 991 ;;; Attachment functions. |
770 | 992 |
771 (defun mml-attach-file (file &optional type description) | 993 (defun mml-attach-file (file &optional type description disposition) |
772 "Attach a file to the outgoing MIME message. | 994 "Attach a file to the outgoing MIME message. |
773 The file is not inserted or encoded until you send the message with | 995 The file is not inserted or encoded until you send the message with |
774 `\\[message-send-and-exit]' or `\\[message-send]'. | 996 `\\[message-send-and-exit]' or `\\[message-send]'. |
775 | 997 |
776 FILE is the name of the file to attach. TYPE is its content-type, a | 998 FILE is the name of the file to attach. TYPE is its content-type, a |
777 string of the form \"type/subtype\". DESCRIPTION is a one-line | 999 string of the form \"type/subtype\". DESCRIPTION is a one-line |
778 description of the attachment." | 1000 description of the attachment." |
779 (interactive | 1001 (interactive |
780 (let* ((file (mml-minibuffer-read-file "Attach file: ")) | 1002 (let* ((file (mml-minibuffer-read-file "Attach file: ")) |
781 (type (mml-minibuffer-read-type file)) | 1003 (type (mml-minibuffer-read-type file)) |
782 (description (mml-minibuffer-read-description))) | 1004 (description (mml-minibuffer-read-description)) |
783 (list file type description))) | 1005 (disposition (mml-minibuffer-read-disposition type))) |
784 (mml-insert-empty-tag 'part 'type type 'filename file | 1006 (list file type description disposition))) |
785 'disposition "attachment" 'description description)) | 1007 (mml-insert-empty-tag 'part |
1008 'type type | |
1009 'filename file | |
1010 'disposition (or disposition "attachment") | |
1011 'description description)) | |
786 | 1012 |
787 (defun mml-attach-buffer (buffer &optional type description) | 1013 (defun mml-attach-buffer (buffer &optional type description) |
788 "Attach a buffer to the outgoing MIME message. | 1014 "Attach a buffer to the outgoing MIME message. |
789 See `mml-attach-file' for details of operation." | 1015 See `mml-attach-file' for details of operation." |
790 (interactive | 1016 (interactive |
821 (interactive | 1047 (interactive |
822 (list (mml-minibuffer-read-type ""))) | 1048 (list (mml-minibuffer-read-type ""))) |
823 (mml-insert-tag 'part 'type type 'disposition "inline") | 1049 (mml-insert-tag 'part 'type type 'disposition "inline") |
824 (forward-line -1)) | 1050 (forward-line -1)) |
825 | 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 | |
826 (defun mml-preview (&optional raw) | 1062 (defun mml-preview (&optional raw) |
827 "Display current buffer with Gnus, in a new buffer. | 1063 "Display current buffer with Gnus, in a new buffer. |
828 If RAW, don't highlight the article." | 1064 If RAW, don't highlight the article." |
829 (interactive "P") | 1065 (interactive "P") |
830 (let ((buf (current-buffer)) | 1066 (save-excursion |
831 (message-posting-charset (or (gnus-setup-posting-charset | 1067 (let* ((buf (current-buffer)) |
832 (save-restriction | 1068 (message-options message-options) |
833 (message-narrow-to-headers-or-head) | 1069 (message-this-is-mail (message-mail-p)) |
834 (message-fetch-field "Newsgroups"))) | 1070 (message-this-is-news (message-news-p)) |
835 message-posting-charset))) | 1071 (message-posting-charset (or (gnus-setup-posting-charset |
836 (switch-to-buffer (get-buffer-create | 1072 (save-restriction |
837 (concat (if raw "*Raw MIME preview of " | 1073 (message-narrow-to-headers-or-head) |
838 "*MIME preview of ") (buffer-name)))) | 1074 (message-fetch-field "Newsgroups"))) |
839 (erase-buffer) | 1075 message-posting-charset))) |
840 (insert-buffer buf) | 1076 (message-options-set-recipient) |
841 (if (re-search-forward | 1077 (switch-to-buffer (generate-new-buffer |
842 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) | 1078 (concat (if raw "*Raw MIME preview of " |
843 (replace-match "\n")) | 1079 "*MIME preview of ") (buffer-name)))) |
844 (let ((mail-header-separator "")) ;; mail-header-separator is removed. | 1080 (when (boundp 'gnus-buffers) |
845 (mml-to-mime)) | 1081 (push (current-buffer) gnus-buffers)) |
846 (if raw | 1082 (erase-buffer) |
847 (when (fboundp 'set-buffer-multibyte) | 1083 (insert-buffer-substring buf) |
848 (let ((s (buffer-string))) | 1084 (mml-preview-insert-mail-followup-to) |
849 ;; Insert the content into unibyte buffer. | 1085 (let ((message-deletable-headers (if (message-news-p) |
850 (erase-buffer) | 1086 nil |
851 (mm-disable-multibyte) | 1087 message-deletable-headers))) |
852 (insert s))) | 1088 (message-generate-headers |
853 (let ((gnus-newsgroup-charset (car message-posting-charset))) | 1089 (copy-sequence (if (message-news-p) |
854 (run-hooks 'gnus-article-decode-hook) | 1090 message-required-news-headers |
855 (let ((gnus-newsgroup-name "dummy")) | 1091 message-required-mail-headers)))) |
856 (gnus-article-prepare-display)))) | 1092 (if (re-search-forward |
857 ;; Disable article-mode-map. | 1093 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) |
858 (use-local-map nil) | 1094 (replace-match "\n")) |
859 (setq buffer-read-only t) | 1095 (let ((mail-header-separator ""));; mail-header-separator is removed. |
860 (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) | 1096 (mml-to-mime)) |
861 (goto-char (point-min)))) | 1097 (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))))) | |
862 | 1129 |
863 (defun mml-validate () | 1130 (defun mml-validate () |
864 "Validate the current MML document." | 1131 "Validate the current MML document." |
865 (interactive) | 1132 (interactive) |
866 (mml-parse)) | 1133 (mml-parse)) |
867 | 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 | |
868 (provide 'mml) | 1172 (provide 'mml) |
869 | 1173 |
870 ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 | 1174 ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 |
871 ;;; mml.el ends here | 1175 ;;; mml.el ends here |