tm 7.41.3.
[elisp/tm.git] / mh-e / tm-mh-e.el
1 ;;;
2 ;;; tm-mh-e.el --- MIME extender for mh-e
3 ;;;
4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
5 ;;; Copyright (C) 1993,1994,1995 MORIOKA Tomohiko
6 ;;;
7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
8 ;;;         OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
9 ;;; modified by YAMAOKA Katsumi <yamaoka@ga.sony.co.jp>
10 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
11 ;;; Created: 1993/11/21 (obsolete mh-e-mime.el)
12 ;;; Version: $Revision: 7.47 $
13 ;;; Keywords: mail, MH, MIME, multimedia, encoded-word, multilingual
14 ;;;
15 ;;; This file is part of tm (Tools for MIME).
16 ;;;
17 ;;; This program is free software; you can redistribute it and/or
18 ;;; modify it under the terms of the GNU General Public License as
19 ;;; published by the Free Software Foundation; either version 2, or
20 ;;; (at your option) any later version.
21 ;;;
22 ;;; This program is distributed in the hope that it will be useful,
23 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
24 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
25 ;;; General Public License for more details.
26 ;;;
27 ;;; You should have received a copy of the GNU General Public License
28 ;;; along with This program.  If not, write to the Free Software
29 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
30 ;;;
31 ;;; Code:
32
33 (require 'tl-str)
34 (require 'tl-misc)
35 (require 'mh-e)
36 (if (not (boundp 'mh-e-version))
37     (require 'tm-mh-e3)
38   )
39 (require 'tm-view)
40
41 (or (fboundp 'mh-get-header-field)
42     (defalias 'mh-get-header-field 'mh-get-field)
43     )
44
45
46 ;;; @ version
47 ;;;
48
49 (defconst tm-mh-e/RCS-ID
50   "$Id: tm-mh-e.el,v 7.47 1996/01/25 15:14:27 morioka Exp $")
51
52 (defconst tm-mh-e/version (get-version-string tm-mh-e/RCS-ID))
53
54
55 ;;; @ variable
56 ;;;
57
58 (defvar tm-mh-e/automatic-mime-preview t
59   "*If non-nil, show MIME processed message.")
60
61 (defvar tm-mh-e/decode-encoded-word t
62   "*If non-nil, decode encoded-word when it is not MIME preview mode.")
63
64 (defvar tm-mh-e/forwcomps "forwcomps"
65   "Name of file to be used as a skeleton for forwarding messages.
66 Default is \"forwcomps\".  If not a complete path name, the file
67 is searched for first in the user's MH directory, then in the
68 system MH lib directory.")
69
70
71 ;;; @ functions
72 ;;;
73
74 (if (not (fboundp 'tm-mh-e/original-mh-display-msg))
75     (fset 'tm-mh-e/original-mh-display-msg
76           (symbol-function 'mh-display-msg))
77   )
78
79 (defun mh-display-msg (msg-num folder &optional show-buffer mode)
80   (or mode
81       (setq mode tm-mh-e/automatic-mime-preview)
82       )
83   ;; Display message NUMBER of FOLDER.
84   ;; Sets the current buffer to the show buffer.
85   (set-buffer folder)
86   (or show-buffer
87       (setq show-buffer mh-show-buffer))
88   ;; Bind variables in folder buffer in case they are local
89   (let ((msg-filename (mh-msg-filename msg-num)))
90     (if (not (file-exists-p msg-filename))
91         (error "Message %d does not exist" msg-num))
92     (set-buffer show-buffer)
93     (cond ((not (equal msg-filename buffer-file-name))
94            ;; Buffer does not yet contain message.
95            (clear-visited-file-modtime)
96            (unlock-buffer)
97            (setq buffer-file-name nil)  ; no locking during setup
98            (setq buffer-read-only nil)
99            (erase-buffer)
100            (if mode
101                (let* ((aname (concat "article-" folder))
102                       (abuf (get-buffer aname))
103                       )
104                  (if abuf
105                      (progn
106                        (set-buffer abuf)
107                        (setq buffer-read-only nil)
108                        (erase-buffer)
109                        )
110                    (setq abuf (get-buffer-create aname))
111                    (set-buffer abuf)
112                    )
113                  (let ((file-coding-system-for-read
114                         (if (boundp 'MULE) *noconv*))
115                        kanji-fileio-code)
116                    (insert-file-contents msg-filename)
117                    ;; (goto-char (point-min))
118                    (while (re-search-forward "\r$" nil t)
119                      (replace-match "")
120                      )
121                    )
122                  (set-buffer-modified-p nil)
123                  (setq buffer-read-only t)
124                  (setq buffer-file-name msg-filename)
125                  (mh-show-mode)
126                  (mime/viewer-mode nil nil nil
127                                    aname (concat "show-" folder))
128                  (goto-char (point-min))
129                  )
130              (let ((clean-message-header mh-clean-message-header)
131                    (invisible-headers mh-invisible-headers)
132                    (visible-headers mh-visible-headers)
133                    )
134                ;; 1995/9/21
135                ;;   modified by ARIURA <ariura@cc.tuat.ac.jp>
136                ;;   to support mhl.
137                (if mhl-formfile
138                    (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
139                                            (if (stringp mhl-formfile)
140                                                (list "-form" mhl-formfile))
141                                            msg-filename)
142                  (insert-file-contents msg-filename))
143                ;; end
144                (goto-char (point-min))
145                (cond (clean-message-header
146                       (mh-clean-msg-header (point-min)
147                                            invisible-headers
148                                            visible-headers)
149                       (goto-char (point-min)))
150                      (t
151                       (mh-start-of-uncleaned-message)))
152                (if tm-mh-e/decode-encoded-word
153                    (mime/decode-message-header)
154                  )
155                (set-buffer-modified-p nil)
156                (setq buffer-read-only t)
157                (setq buffer-file-name msg-filename)
158                (mh-show-mode)
159                ))
160            (or (eq buffer-undo-list t)  ;don't save undo info for prev msgs
161                (setq buffer-undo-list nil))
162            (set-mark nil)
163            (setq mode-line-buffer-identification
164                  (list (format mh-show-buffer-mode-line-buffer-id
165                                folder msg-num)))
166            (set-buffer folder)
167            (setq mh-showing-with-headers nil)))))
168
169 (defun tm-mh-e/view-message (&optional msg)
170   "MIME decode and play this message."
171   (interactive)
172   (if (or (null tm-mh-e/automatic-mime-preview)
173           (null (get-buffer mh-show-buffer))
174           (save-excursion
175             (set-buffer mh-show-buffer)
176             (not (eq major-mode 'mime/viewer-mode))
177             ))
178       (let ((tm-mh-e/automatic-mime-preview t))
179         (mh-invalidate-show-buffer)
180         (mh-show-msg msg)
181         ))
182   (pop-to-buffer mh-show-buffer)
183   )
184
185 (defun tm-mh-e/toggle-decoding-mode (arg)
186   "Toggle MIME processing mode.
187 With arg, turn MIME processing on if arg is positive."
188   (interactive "P")
189   (setq tm-mh-e/automatic-mime-preview
190         (if (null arg)
191             (not tm-mh-e/automatic-mime-preview)
192           arg))
193   (save-excursion
194     (set-buffer mh-show-buffer)
195     (if (null tm-mh-e/automatic-mime-preview)
196         (if (and mime::preview/article-buffer
197                  (get-buffer mime::preview/article-buffer))
198             (kill-buffer mime::preview/article-buffer)
199           )))
200   (mh-invalidate-show-buffer)
201   (mh-show (mh-get-msg-num t))
202   )
203
204 (defun tm-mh-e/show (&optional message)
205   (interactive)
206   (mh-invalidate-show-buffer)
207   (mh-show message)
208   )
209
210 (defun tm-mh-e/header-display ()
211   (interactive)
212   (mh-invalidate-show-buffer)
213   (let ((mime-viewer/ignored-field-regexp "^:$")
214         tm-mh-e/decode-encoded-word)
215     (mh-header-display)
216     ))
217
218 (defun tm-mh-e/raw-display ()
219   (interactive)
220   (mh-invalidate-show-buffer)
221   (let (tm-mh-e/automatic-mime-preview
222         tm-mh-e/decode-encoded-word)
223     (mh-header-display)
224     ))
225
226
227 ;;; @ for tm-view
228 ;;;
229
230 (fset 'tm-mh-e/code-convert-region-to-emacs
231       (symbol-function 'mime/code-convert-region-to-emacs))
232
233 (defun tm-mh-e/content-header-filter ()
234   (goto-char (point-min))
235   (mime-preview/cut-header)
236   (tm-mh-e/code-convert-region-to-emacs (point-min)(point-max)
237                                         mime/default-coding-system)
238   (mime/decode-message-header)
239   (if (featurep 'hilit19)
240       (hilit-rehighlight-buffer-quietly)
241     )
242   )
243
244 (defun tm-mh-e/quitting-method ()
245   (let ((win (get-buffer-window
246               mime/output-buffer-name))
247         (buf (current-buffer))
248         )
249     (if win
250         (delete-window win)
251       )
252     (pop-to-buffer
253      (let ((name (buffer-name buf)))
254        (substring name 5)
255        ))
256     (if (not tm-mh-e/automatic-mime-preview)
257         (mh-invalidate-show-buffer)
258       )
259     (mh-show (mh-get-msg-num t))
260     ))
261
262 (defun tm-mh-e/set-window-configuration ()
263   (save-excursion
264     (set-buffer mh-show-buffer)
265     (setq mime::preview/original-window-configuration
266           (current-window-configuration))
267     ))
268
269 (add-hook 'mh-show-hook 'tm-mh-e/set-window-configuration)
270
271
272 ;;; @ for tm-partial
273 ;;;
274
275 (call-after-loaded
276  'tm-partial
277  (function
278   (lambda ()
279     (set-atype 'mime/content-decoding-condition
280                '((type . "message/partial")
281                  (method . mime-article/grab-message/partials)
282                  (major-mode . mh-show-mode)
283                  (summary-buffer-exp
284                   . (and (or (string-match "^article-\\(.+\\)$" article-buffer)
285                              (string-match "^show-\\(.+\\)$" article-buffer))
286                          (substring article-buffer
287                                     (match-beginning 1) (match-end 1))
288                          ))
289                  ))
290     (set-alist 'tm-partial/preview-article-method-alist
291                'mh-show-mode
292                (function
293                 (lambda ()
294                   (let ((tm-mh-e/automatic-mime-preview t))
295                     (tm-mh-e/show)
296                     ))))
297     )))
298
299
300 ;;; @ for tm-edit
301 ;;;
302
303 (defun tm-mh-e::make-message (folder number)
304   (vector folder number)
305   )
306
307 (defun tm-mh-e::message/folder (message)
308   (elt message 0)
309   )
310
311 (defun tm-mh-e::message/number (message)
312   (elt message 1)
313   )
314
315 (defun tm-mh-e::message/file-name (message)
316   (expand-file-name
317    (tm-mh-e::message/number message)
318    (mh-expand-file-name (tm-mh-e::message/folder message))
319    ))
320
321 ;;; modified by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
322 ;;;     1995/11/14 (cf. [tm-ja:1096])
323 (defun tm-mh-e/prompt-for-message (prompt folder &optional default)
324   (let* ((files
325           (directory-files (mh-expand-file-name folder) nil "^[0-9]+$")
326           )
327          (folder-buf (get-buffer folder))
328          (default
329            (if folder-buf
330                (save-excursion
331                  (set-buffer folder-buf)
332                  (let* ((show-buffer (get-buffer mh-show-buffer))
333                         (show-buffer-file-name
334                          (buffer-file-name show-buffer)))
335                    (if show-buffer-file-name
336                        (file-name-nondirectory show-buffer-file-name)))))))
337     (if (or (null default)
338             (not (string-match "^[0-9]+$" default)))
339         (setq default
340               (if (and (string= folder mh-sent-from-folder)
341                        mh-sent-from-msg)
342                   (int-to-string mh-sent-from-msg)
343                 (save-excursion
344                   (let (cur-msg)
345                     (if (and
346                          (= 0 (mh-exec-cmd-quiet nil "pick" folder "cur"))
347                          (set-buffer mh-temp-buffer)
348                          (setq cur-msg (buffer-string))
349                          (string-match "^[0-9]+$" cur-msg))
350                         (substring cur-msg 0 (match-end 0))
351                       (car files)))))))
352     (completing-read prompt
353                      (let ((i 0))
354                        (mapcar (function
355                                 (lambda (file)
356                                   (setq i (+ i 1))
357                                   (list file i)
358                                   ))
359                                files)
360                        ) nil nil default)
361     ))
362
363 (defun tm-mh-e/query-message (&optional message)
364   (let (folder number)
365     (if message
366         (progn
367           (setq folder (tm-mh-e::message/folder message))
368           (setq number (tm-mh-e::message/number message))
369           ))
370     (or (stringp folder)
371         (setq folder (mh-prompt-for-folder
372                       "Message from"
373                       (if (and (stringp mh-sent-from-folder)
374                                (string-match "^\\+" mh-sent-from-folder))
375                           mh-sent-from-folder "+inbox")
376                       nil)))
377     (setq number
378           (if (numberp number)
379               (number-to-string number)
380             (tm-mh-e/prompt-for-message "Message number: " folder)
381             ))
382     (tm-mh-e::make-message folder number)
383     ))
384 ;;; end
385
386 ;;; by OKABE Yasuo <okabe@kudpc.kyoto-u.ac.jp>
387 ;;;     1995/11/14 (cf. [tm-ja:1099])
388 (defun tm-mh-e/forward (to cc &optional msg-or-seq)
389   "Forward a message or message sequence as MIME message/rfc822.
390 Defaults to displayed message. If optional prefix argument provided,
391 then prompt for the message sequence. See also documentation for
392 `\\[mh-send]' function."
393   (interactive (progn
394                  (require 'mh-comp)
395                  (list (mh-read-address "To: ")
396                        (mh-read-address "Cc: ")
397                        (if current-prefix-arg
398                            (mh-read-seq-default "Forward" t)
399                          (mh-get-msg-num t)
400                          ))))
401   (or msg-or-seq
402       (setq msg-or-seq (mh-get-msg-num t)))
403   (let* ((folder mh-current-folder)
404          (config (current-window-configuration))
405          ;; uses "draft" for compatibility with forw.
406          ;; forw always leaves file in "draft" since it doesn't have -draft
407          (draft-name (expand-file-name "draft" mh-user-path))
408          (draft (cond ((or (not (file-exists-p draft-name))
409                            (y-or-n-p "The file `draft' exists.  Discard it? "))
410                        (mh-exec-cmd "comp"
411                                     "-noedit" "-nowhatnowproc"
412                                     "-form" tm-mh-e/forwcomps
413                                     "-nodraftfolder")
414                        (prog1
415                            (mh-read-draft "" draft-name t)
416                          (mh-insert-fields "To:" to "Cc:" cc)
417                          (set-buffer-modified-p nil)))
418                       (t
419                        (mh-read-draft "" draft-name nil)))))
420     (require 'tm-edit)
421     (let ((msubtype "digest")
422           orig-from orig-subject multipart-flag
423           (tag-regexp
424            (concat "^"
425                    (regexp-quote (mime-make-tag "message" "rfc822"))))
426           )
427       (goto-char (point-min))
428       (save-excursion
429         (save-restriction
430           (goto-char (point-max))
431           (if (not (bolp)) (insert "\n"))
432           (let ((beg (point)))
433             (narrow-to-region beg beg)
434             (mh-exec-cmd-output "pick" nil folder msg-or-seq)
435             (if (> (count-lines (point) (point-max)) 1)
436                 (setq multipart-flag t)
437               )
438             (while (re-search-forward "^\\([0-9]+\\)\n" nil t)
439               (let ((forw-msg
440                      (buffer-substring (match-beginning 1) (match-end 1)))
441                     (beg (match-beginning 0))
442                     (end (match-end 0))
443                     )
444                 (save-restriction
445                   (narrow-to-region beg end)
446                   ;; modified for Emacs 18
447                   (delete-region beg end)
448                   (insert-file-contents
449                    (mh-expand-file-name forw-msg
450                                         (mh-expand-file-name folder))
451                    )
452                   (save-excursion
453                     (push-mark (point-max))
454                     (mime-editor/inserted-message-filter))
455                   (goto-char (point-max))
456                   )
457                 (save-excursion
458                   (goto-char beg)
459                   (mime-editor/insert-tag "message" "rfc822")
460                   )))
461             (delete-region (point) (point-max))
462             (if multipart-flag
463                 (mime-editor/enclose-region "digest" beg (point))
464               ))))
465       (re-search-forward tag-regexp)
466       (forward-line 1)
467       (save-restriction
468         (narrow-to-region (point) (point-max))
469         (setq orig-from (mh-get-header-field "From:"))
470         (setq orig-subject (mh-get-header-field "Subject:")))
471       (let ((forw-subject
472              (mh-forwarded-letter-subject orig-from orig-subject)))
473         (mh-insert-fields "Subject:" forw-subject)
474         (goto-char (point-min))
475         (re-search-forward tag-regexp)
476         (forward-line -1)
477         (delete-other-windows)
478         (if (numberp msg-or-seq)
479             (mh-add-msgs-to-seq msg-or-seq 'forwarded t)
480           (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t))
481         (mh-compose-and-send-mail draft "" folder msg-or-seq
482                                   to forw-subject cc
483                                   mh-note-forw "Forwarded:"
484                                   config)))))
485 ;;; end
486
487 (defun tm-mh-e/insert-message (&optional message)
488   ;; always ignores message
489   (let ((article-buffer
490          (if (not (and (stringp mh-sent-from-folder)
491                        (numberp mh-sent-from-msg)
492                        ))
493              (cond ((and (boundp 'gnus-original-article-buffer)
494                          (bufferp mh-sent-from-folder)
495                          (get-buffer gnus-original-article-buffer)
496                          )
497                     gnus-original-article-buffer)
498                    ((and (boundp 'gnus-article-buffer)
499                          (get-buffer gnus-article-buffer)
500                          (bufferp mh-sent-from-folder)
501                          )
502                     (save-excursion
503                       (set-buffer gnus-article-buffer)
504                       (if (eq major-mode 'mime/viewer-mode)
505                           mime::preview/article-buffer
506                         (current-buffer)
507                         )))
508                    ))))
509     (if (null article-buffer)
510         (tm-mh-e/insert-mail
511          (tm-mh-e::make-message mh-sent-from-folder mh-sent-from-msg)
512          )
513       (insert-buffer article-buffer)
514       (mime-editor/inserted-message-filter)
515       )
516     ))
517
518 (defun tm-mh-e/insert-mail (&optional message)
519   (save-excursion
520     (save-restriction
521       (let ((message-file
522              (tm-mh-e::message/file-name (tm-mh-e/query-message message))))
523         (narrow-to-region (point) (point))
524         (insert-file-contents message-file)
525         (push-mark (point-max))
526         (mime-editor/inserted-message-filter)
527     ))))
528
529 (call-after-loaded
530  'tm-edit
531  (function
532   (lambda ()
533     (set-alist
534      'mime-editor/message-inserter-alist
535      'mh-letter-mode (function tm-mh-e/insert-message))
536     (set-alist
537      'mime-editor/mail-inserter-alist
538      'mh-letter-mode (function tm-mh-e/insert-mail))
539     (set-alist
540      'mime-editor/mail-inserter-alist
541      'news-reply-mode (function tm-mh-e/insert-mail))
542     )))
543
544 (defun tm-mh-e/insert-letter (verbatim)
545   "Interface to mh-insert-letter."
546   (interactive "P")
547   (let*
548       ((folder (mh-prompt-for-folder
549                 "Message from"
550                 (if (and (stringp mh-sent-from-folder)
551                          (string-match "^\\+" mh-sent-from-folder))
552                     mh-sent-from-folder "+inbox")
553                 nil))
554        (number (tm-mh-e/prompt-for-message "Message number: " folder)))
555     (mh-insert-letter folder number verbatim)))
556
557 (defun tm-mh-e/yank-cur-msg ()
558   "Interface to mh-yank-cur-msg."
559   (interactive)
560   (let ((mh-sent-from-folder mh-sent-from-folder)
561         (mh-sent-from-msg mh-sent-from-msg))
562     (if (not (stringp mh-sent-from-folder))
563         (cond ((and (boundp 'gnus-article-buffer)
564                     (get-buffer gnus-article-buffer)
565                     (bufferp mh-sent-from-folder)
566                     ) ; might be called from GNUS
567                (if (boundp 'gnus-article-copy) ; might be sgnus
568                    (save-excursion
569                      (gnus-copy-article-buffer)
570                      (setq mh-sent-from-folder gnus-article-copy)
571                      (set-buffer mh-sent-from-folder)
572                      (setq mh-show-buffer gnus-article-copy))
573                  (save-excursion
574                    (setq mh-sent-from-folder gnus-article-buffer)
575                    (set-buffer gnus-article-buffer)
576                    (setq mh-show-buffer (current-buffer)))))
577               (t
578                (error "There is no current message"))))
579     (mh-yank-cur-msg)))
580
581 (call-after-loaded
582  'mime-setup
583  (function
584   (lambda ()
585     (substitute-key-definition
586      'mh-forward 'tm-mh-e/forward mh-folder-mode-map)
587     (call-after-loaded
588      'mh-comp
589      (function
590       (lambda ()
591         (substitute-key-definition
592          'mh-yank-cur-msg 'tm-mh-e/yank-cur-msg mh-letter-mode-map)
593         )))
594     )))
595
596
597 ;;; @ for BBDB
598 ;;;
599
600 (call-after-loaded
601  'bbdb
602  (function
603   (lambda ()
604     (require 'tm-bbdb)
605     )))
606
607
608 ;;; @ set up
609 ;;;
610
611 (define-key mh-folder-mode-map "v" (function tm-mh-e/view-message))
612 (define-key mh-folder-mode-map "\et" (function tm-mh-e/toggle-decoding-mode))
613 (define-key mh-folder-mode-map "." (function tm-mh-e/show))
614 (define-key mh-folder-mode-map "," (function tm-mh-e/header-display))
615 (define-key mh-folder-mode-map "\e," (function tm-mh-e/raw-display))
616 (define-key mh-folder-mode-map "\r"
617   (function (lambda ()
618               (interactive)
619               (scroll-other-window 1)
620               )))
621 (define-key mh-folder-mode-map "\e\r"
622   (function (lambda ()
623               (interactive)
624               (scroll-other-window -1)
625               )))
626
627 (defun tm-mh-e/summary-before-quit ()
628   (let ((buf (get-buffer mh-show-buffer)))
629     (if buf
630         (let ((the-buf (current-buffer)))
631           (switch-to-buffer buf)
632           (if (and mime::article/preview-buffer
633                    (setq buf (get-buffer mime::article/preview-buffer))
634                    )
635               (progn
636                 (switch-to-buffer the-buf)
637                 (kill-buffer buf)
638                 )
639             (switch-to-buffer the-buf)
640             )
641           ))))
642
643 (add-hook 'mh-before-quit-hook (function tm-mh-e/summary-before-quit))
644              
645 (set-alist 'mime-viewer/quitting-method-alist
646            'mh-show-mode
647            (function tm-mh-e/quitting-method))
648
649 (set-alist 'mime-viewer/content-header-filter-alist
650            'mh-show-mode
651            (function tm-mh-e/content-header-filter))
652
653 (set-alist 'mime-viewer/code-converter-alist
654            'mh-show-mode
655            (function tm-mh-e/code-convert-region-to-emacs))
656
657
658 ;;; @ end
659 ;;;
660
661 (provide 'tm-mh-e)
662
663 (run-hooks 'tm-mh-e-load-hook)
664
665 ;;; tm-mh-e.el ends here