Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-mh-e.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; tm-mh-e.el --- MIME extension for mh-e
2
3 ;; Copyright (C) 1995,1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
7 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
8 ;; Created: 1993/11/21 (obsolete mh-e-mime.el)
9 ;; Version: $Revision: 1.1.1.1 $
10 ;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual
11
12 ;; This file is part of tm (Tools for MIME).
13
14 ;; This program is free software; you can redistribute it and/or
15 ;; modify it under the terms of the GNU General Public License as
16 ;; published by the Free Software Foundation; either version 2, or (at
17 ;; your option) any later version.
18
19 ;; This program is distributed in the hope that it will be useful, but
20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 ;; General Public License for more details.
23
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA.
28
29 ;;; Code:
30
31 (require 'tl-str)
32 (require 'tl-misc)
33 (require 'mh-e)
34 (or (featurep 'mh-utils)
35 (require 'tm-mh-e3)
36 )
37 (require 'tm-view)
38
39 (or (fboundp 'mh-get-header-field)
40 (defalias 'mh-get-header-field 'mh-get-field)
41 )
42 (or (boundp 'mh-temp-buffer)
43 (defconst mh-temp-buffer " *mh-temp*")
44 )
45
46
47 ;;; @ version
48 ;;;
49
50 (defconst tm-mh-e/RCS-ID
51 "$Id: tm-mh-e.el,v 1.1.1.1 1996/12/18 03:55:32 steve Exp $")
52
53 (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
54
55
56 ;;; @ variable
57 ;;;
58
59 (defvar tm-mh-e/automatic-mime-preview t
60 "*If non-nil, show MIME processed message.")
61
62 (defvar tm-mh-e/decode-encoded-word t
63 "*If non-nil, decode encoded-word when it is not MIME preview mode.")
64
65
66 ;;; @ functions
67 ;;;
68
69 (defun mh-display-msg (msg-num folder &optional show-buffer mode)
70 (or mode
71 (setq mode tm-mh-e/automatic-mime-preview)
72 )
73 ;; Display message NUMBER of FOLDER.
74 ;; Sets the current buffer to the show buffer.
75 (set-buffer folder)
76 (or show-buffer
77 (setq show-buffer mh-show-buffer))
78 ;; Bind variables in folder buffer in case they are local
79 (let ((msg-filename (mh-msg-filename msg-num)))
80 (if (not (file-exists-p msg-filename))
81 (error "Message %d does not exist" msg-num))
82 (set-buffer show-buffer)
83 (cond ((not (equal msg-filename buffer-file-name))
84 ;; Buffer does not yet contain message.
85 (clear-visited-file-modtime)
86 (unlock-buffer)
87 (setq buffer-file-name nil) ; no locking during setup
88 (setq buffer-read-only nil)
89 (erase-buffer)
90 (if mode
91 (let* ((aname (concat "article-" folder))
92 (abuf (get-buffer aname))
93 )
94 (if abuf
95 (progn
96 (set-buffer abuf)
97 (setq buffer-read-only nil)
98 (erase-buffer)
99 )
100 (setq abuf (get-buffer-create aname))
101 (set-buffer abuf)
102 )
103 (as-binary-input-file
104 (insert-file-contents msg-filename)
105 ;; (goto-char (point-min))
106 (while (re-search-forward "\r$" nil t)
107 (replace-match "")
108 )
109 )
110 (set-buffer-modified-p nil)
111 (setq buffer-read-only t)
112 (setq buffer-file-name msg-filename)
113 (mh-show-mode)
114 (mime/viewer-mode nil nil nil
115 aname (concat "show-" folder))
116 (goto-char (point-min))
117 )
118 (let ((clean-message-header mh-clean-message-header)
119 (invisible-headers mh-invisible-headers)
120 (visible-headers mh-visible-headers)
121 )
122 ;; 1995/9/21
123 ;; modified by ARIURA <ariura@cc.tuat.ac.jp>
124 ;; to support mhl.
125 (if mhl-formfile
126 (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
127 (if (stringp mhl-formfile)
128 (list "-form" mhl-formfile))
129 msg-filename)
130 (insert-file-contents msg-filename))
131 ;; end
132 (goto-char (point-min))
133 (cond (clean-message-header
134 (mh-clean-msg-header (point-min)
135 invisible-headers
136 visible-headers)
137 (goto-char (point-min)))
138 (t
139 (mh-start-of-uncleaned-message)))
140 (if tm-mh-e/decode-encoded-word
141 (mime/decode-message-header)
142 )
143 (set-buffer-modified-p nil)
144 (setq buffer-read-only t)
145 (setq buffer-file-name msg-filename)
146 (mh-show-mode)
147 ))
148 (or (eq buffer-undo-list t) ;don't save undo info for prev msgs
149 (setq buffer-undo-list nil))
150 ;;; Added by itokon (02/19/96)
151 (setq buffer-file-name msg-filename)
152 ;;;
153 (set-mark nil)
154 (setq mode-line-buffer-identification
155 (list (format mh-show-buffer-mode-line-buffer-id
156 folder msg-num)))
157 (set-buffer folder)
158 (setq mh-showing-with-headers nil)))))
159
160 (defun tm-mh-e/view-message (&optional msg)
161 "MIME decode and play this message."
162 (interactive)
163 (if (or (null tm-mh-e/automatic-mime-preview)
164 (null (get-buffer mh-show-buffer))
165 (save-excursion
166 (set-buffer mh-show-buffer)
167 (not (eq major-mode 'mime/viewer-mode))
168 ))
169 (let ((tm-mh-e/automatic-mime-preview t))
170 (mh-invalidate-show-buffer)
171 (mh-show-msg msg)
172 ))
173 (pop-to-buffer mh-show-buffer)
174 )
175
176 (defun tm-mh-e/toggle-decoding-mode (arg)
177 "Toggle MIME processing mode.
178 With arg, turn MIME processing on if arg is positive."
179 (interactive "P")
180 (setq tm-mh-e/automatic-mime-preview
181 (if (null arg)
182 (not tm-mh-e/automatic-mime-preview)
183 arg))
184 (save-excursion
185 (set-buffer mh-show-buffer)
186 (if (null tm-mh-e/automatic-mime-preview)
187 (if (and mime::preview/article-buffer
188 (get-buffer mime::preview/article-buffer))
189 (kill-buffer mime::preview/article-buffer)
190 )))
191 (mh-invalidate-show-buffer)
192 (mh-show (mh-get-msg-num t))
193 )
194
195 (defun tm-mh-e/show (&optional message)
196 (interactive)
197 (mh-invalidate-show-buffer)
198 (mh-show message)
199 )
200
201 (defun tm-mh-e/header-display ()
202 (interactive)
203 (mh-invalidate-show-buffer)
204 (let ((mime-viewer/ignored-field-regexp "^:$")
205 tm-mh-e/decode-encoded-word)
206 (mh-header-display)
207 ))
208
209 (defun tm-mh-e/raw-display ()
210 (interactive)
211 (mh-invalidate-show-buffer)
212 (let (tm-mh-e/automatic-mime-preview
213 tm-mh-e/decode-encoded-word)
214 (mh-header-display)
215 ))
216
217 (defun tm-mh-e/scroll-up-msg (&optional arg)
218 (interactive)
219 (mh-page-msg (or arg 1))
220 )
221
222 (defun tm-mh-e/scroll-down-msg (&optional arg)
223 (interactive)
224 (mh-page-msg (- (or arg 1)))
225 )
226
227 (defun tm-mh-e/burst-multipart/digest ()
228 "Burst apart the current message, which should be a multipart/digest.
229 The message is replaced by its table of contents and the letters from the
230 digest are inserted into the folder after that message."
231 (interactive)
232 (let ((digest (mh-get-msg-num t)))
233 (mh-process-or-undo-commands mh-current-folder)
234 (mh-set-folder-modified-p t) ; lock folder while bursting
235 (message "Bursting digest...")
236 (mh-exec-cmd "mhn" "-store" mh-current-folder digest)
237 (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
238 (message "Bursting digest...done")
239 ))
240
241
242 ;;; @ for tm-view
243 ;;;
244
245 (fset 'tm-mh-e/decode-charset-buffer
246 (symbol-function 'mime-charset/decode-buffer))
247
248 (set-alist 'mime-viewer/code-converter-alist
249 'mh-show-mode
250 (function tm-mh-e/decode-charset-buffer))
251
252 (defun tm-mh-e/content-header-filter ()
253 (goto-char (point-min))
254 (mime-preview/cut-header)
255 (tm-mh-e/decode-charset-buffer default-mime-charset)
256 (mime/decode-message-header)
257 )
258
259 (set-alist 'mime-viewer/content-header-filter-alist
260 'mh-show-mode
261 (function tm-mh-e/content-header-filter))
262
263 (defun tm-mh-e/quitting-method ()
264 (let ((win (get-buffer-window
265 mime/output-buffer-name))
266 (buf (current-buffer))
267 )
268 (if win
269 (delete-window win)
270 )
271 (pop-to-buffer
272 (let ((name (buffer-name buf)))
273 (substring name 5)
274 ))
275 (if (not tm-mh-e/automatic-mime-preview)
276 (mh-invalidate-show-buffer)
277 )
278 (mh-show (mh-get-msg-num t))
279 ))
280
281 (set-alist 'mime-viewer/quitting-method-alist
282 'mh-show-mode
283 (function tm-mh-e/quitting-method))
284 (set-alist 'mime-viewer/show-summary-method
285 'mh-show-mode
286 (function tm-mh-e/quitting-method))
287
288 (defun tm-mh-e/following-method (buf)
289 (save-excursion
290 (set-buffer buf)
291 (goto-char (point-max))
292 (setq mh-show-buffer buf)
293 (apply (function mh-send)
294 (std11-field-bodies '("To" "cc" "Subject") ""))
295 (setq mh-sent-from-folder buf)
296 (setq mh-sent-from-msg 1)
297 (let ((last (point)))
298 (mh-yank-cur-msg)
299 (goto-char last)
300 )))
301
302 (set-alist 'mime-viewer/following-method-alist
303 'mh-show-mode
304 (function tm-mh-e/following-method))
305
306
307 ;;; @@ for tm-partial
308 ;;;
309
310 (call-after-loaded
311 'tm-partial
312 (function
313 (lambda ()
314 (set-atype 'mime/content-decoding-condition
315 '((type . "message/partial")
316 (method . mime-article/grab-message/partials)
317 (major-mode . mh-show-mode)
318 (summary-buffer-exp
319 . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
320 (string-match "^show-\\(.+\\)$" article-buffer))
321 (substring article-buffer
322 (match-beginning 1) (match-end 1))
323 ))
324 ))
325 (set-alist 'tm-partial/preview-article-method-alist
326 'mh-show-mode
327 (function
328 (lambda ()
329 (let ((tm-mh-e/automatic-mime-preview t))
330 (tm-mh-e/show)
331 ))))
332 )))
333
334
335 ;;; @ set up
336 ;;;
337
338 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
339 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
340 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
341 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
342 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
343 (define-key mh-folder-mode-map "\r" (function tm-mh-e/scroll-up-msg))
344 (define-key mh-folder-mode-map "\e\r" (function tm-mh-e/scroll-down-msg))
345 (define-key mh-folder-mode-map "\C-c\C-b"
346 (function tm-mh-e/burst-multipart/digest))
347
348 (defun tm-mh-e/summary-before-quit ()
349 (let ((buf (get-buffer mh-show-buffer)))
350 (if buf
351 (let ((the-buf (current-buffer)))
352 (switch-to-buffer buf)
353 (if (and mime::article/preview-buffer
354 (setq buf (get-buffer mime::article/preview-buffer))
355 )
356 (progn
357 (switch-to-buffer the-buf)
358 (kill-buffer buf)
359 )
360 (switch-to-buffer the-buf)
361 )
362 ))))
363
364 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
365
366
367 ;;; @@ for tmh-comp.el
368 ;;;
369
370 (autoload 'tm-mh-e/edit-again "tmh-comp"
371 "Clean-up a draft or a message previously sent and make it resendable." t)
372 (autoload 'tm-mh-e/extract-rejected-mail "tmh-comp"
373 "Extract a letter returned by the mail system and make it re-editable." t)
374 (autoload 'tm-mh-e/forward "tmh-comp"
375 "Forward a message or message sequence by MIME style." t)
376
377 (call-after-loaded
378 'mime-setup
379 (function
380 (lambda ()
381 (substitute-key-definition
382 'mh-edit-again 'tm-mh-e/edit-again mh-folder-mode-map)
383 (substitute-key-definition
384 'mh-extract-rejected-mail 'tm-mh-e/extract-rejected-mail
385 mh-folder-mode-map)
386 (substitute-key-definition
387 'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
388
389 (call-after-loaded
390 'mh-comp
391 (function
392 (lambda ()
393 (require 'tmh-comp)
394 ))
395 'mh-letter-mode-hook)
396 )))
397
398
399 ;;; @ for BBDB
400 ;;;
401
402 (call-after-loaded
403 'bbdb
404 (function
405 (lambda ()
406 (require 'tm-bbdb)
407 )))
408
409
410 ;;; @ end
411 ;;;
412
413 (provide 'tm-mh-e)
414
415 (run-hooks 'tm-mh-e-load-hook)
416
417 ;;; tm-mh-e.el ends here