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. |
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 |
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) |
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." |
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") |
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"))) |
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) |
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") |
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 |
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 "-=-=") |
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." |
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))) |
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 () |
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 |
|
|
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"))))) |
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 |
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) |
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 |
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 |
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)) |
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") |
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 |
|
|
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]'. |
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. |
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 |