1 |
;;; mh-comp.el --- MH-E functions for composing messages |
;;; mh-comp.el --- MH-E functions for composing messages |
2 |
|
|
3 |
;; Copyright (C) 1993, 95, 1997, |
;; Copyright (C) 1993, 95, 1997, |
4 |
;; 2000, 01, 02, 2003 Free Software Foundation, Inc. |
;; 2000, 01, 02, 03, 2004 Free Software Foundation, Inc. |
5 |
|
|
6 |
;; Author: Bill Wohler <wohler@newt.com> |
;; Author: Bill Wohler <wohler@newt.com> |
7 |
;; Maintainer: Bill Wohler <wohler@newt.com> |
;; Maintainer: Bill Wohler <wohler@newt.com> |
36 |
(require 'mh-e) |
(require 'mh-e) |
37 |
(require 'gnus-util) |
(require 'gnus-util) |
38 |
(require 'easymenu) |
(require 'easymenu) |
39 |
(require 'cl) |
(require 'mh-utils) |
40 |
|
(mh-require-cl) |
41 |
(eval-when (compile load eval) |
(eval-when (compile load eval) |
42 |
(ignore-errors (require 'mailabbrev))) |
(ignore-errors (require 'mailabbrev))) |
43 |
|
|
200 |
(defvar mh-annotate-field nil |
(defvar mh-annotate-field nil |
201 |
"Field name for message annotation.") |
"Field name for message annotation.") |
202 |
|
|
203 |
|
(defvar mh-insert-auto-fields-done-local nil |
204 |
|
"Buffer-local variable set when `mh-insert-auto-fields' successfully called.") |
205 |
|
(make-variable-buffer-local 'mh-insert-auto-fields-done-local) |
206 |
|
|
207 |
;;;###autoload |
;;;###autoload |
208 |
(defun mh-smail () |
(defun mh-smail () |
209 |
"Compose and send mail with the MH mail system. |
"Compose and send mail with the MH mail system. |
284 |
(save-buffer) |
(save-buffer) |
285 |
(mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil |
(mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil |
286 |
config) |
config) |
287 |
(mh-letter-mode-message))) |
(mh-letter-mode-message) |
288 |
|
(mh-letter-adjust-point))) |
289 |
|
|
290 |
;;;###mh-autoload |
;;;###mh-autoload |
291 |
(defun mh-extract-rejected-mail (msg) |
(defun mh-extract-rejected-mail (msg) |
315 |
(mh-letter-mode-message))) |
(mh-letter-mode-message))) |
316 |
|
|
317 |
;;;###mh-autoload |
;;;###mh-autoload |
318 |
(defun mh-forward (to cc &optional msg-or-seq) |
(defun mh-forward (to cc &optional range) |
319 |
"Forward messages to the recipients TO and CC. |
"Forward messages to the recipients TO and CC. |
320 |
Use optional MSG-OR-SEQ argument to specify a message or sequence to forward. |
Use optional RANGE argument to specify a message or sequence to forward. |
321 |
Default is the displayed message. |
Default is the displayed message. |
322 |
If optional prefix argument is provided, then prompt for the message sequence. |
|
323 |
If variable `transient-mark-mode' is non-nil and the mark is active, then the |
Check the documentation of `mh-interactive-range' to see how RANGE is read in |
324 |
selected region is forwarded. |
interactive use. |
|
In a program, MSG-OR-SEQ can be a message number, a list of message numbers, a |
|
|
region in a cons cell, or a sequence. |
|
325 |
|
|
326 |
See also documentation for `\\[mh-send]' function." |
See also documentation for `\\[mh-send]' function." |
327 |
(interactive (list (mh-read-address "To: ") |
(interactive (list (mh-interactive-read-address "To: ") |
328 |
(mh-read-address "Cc: ") |
(mh-interactive-read-address "Cc: ") |
329 |
(mh-interactive-msg-or-seq "Forward"))) |
(mh-interactive-range "Forward"))) |
330 |
(let* ((folder mh-current-folder) |
(let* ((folder mh-current-folder) |
331 |
(msgs (mh-msg-or-seq-to-msg-list msg-or-seq)) |
(msgs (mh-range-to-msg-list range)) |
332 |
(config (current-window-configuration)) |
(config (current-window-configuration)) |
333 |
(fwd-msg-file (mh-msg-filename (car msgs) folder)) |
(fwd-msg-file (mh-msg-filename (car msgs) folder)) |
334 |
;; forw always leaves file in "draft" since it doesn't have -draft |
;; forw always leaves file in "draft" since it doesn't have -draft |
359 |
;; If using MML, translate mhn |
;; If using MML, translate mhn |
360 |
(if (equal mh-compose-insertion 'gnus) |
(if (equal mh-compose-insertion 'gnus) |
361 |
(save-excursion |
(save-excursion |
362 |
(re-search-forward (format "^\\(%s\\)?$" |
(goto-char (mh-mail-header-end)) |
|
mh-mail-header-separator)) |
|
363 |
(while |
(while |
364 |
(re-search-forward |
(re-search-forward |
365 |
"^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" |
"^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" |
379 |
;; Postition just before forwarded message |
;; Postition just before forwarded message |
380 |
(if (re-search-forward "^------- Forwarded Message" nil t) |
(if (re-search-forward "^------- Forwarded Message" nil t) |
381 |
(forward-line -1) |
(forward-line -1) |
382 |
(re-search-forward (format "^\\(%s\\)?$" mh-mail-header-separator)) |
(goto-char (mh-mail-header-end)) |
383 |
(forward-line 1)) |
(forward-line 1)) |
384 |
(delete-other-windows) |
(delete-other-windows) |
385 |
(mh-add-msgs-to-seq msgs 'forwarded t) |
(mh-add-msgs-to-seq msgs 'forwarded t) |
387 |
to forw-subject cc |
to forw-subject cc |
388 |
mh-note-forw "Forwarded:" |
mh-note-forw "Forwarded:" |
389 |
config) |
config) |
390 |
(mh-letter-mode-message))))) |
(mh-letter-mode-message) |
391 |
|
(mh-letter-adjust-point))))) |
392 |
|
|
393 |
(defun mh-forwarded-letter-subject (from subject) |
(defun mh-forwarded-letter-subject (from subject) |
394 |
"Return a Subject suitable for a forwarded message. |
"Return a Subject suitable for a forwarded message. |
571 |
If `mh-compose-letter-function' is defined, it is called on the draft and |
If `mh-compose-letter-function' is defined, it is called on the draft and |
572 |
passed three arguments: TO, CC, and SUBJECT." |
passed three arguments: TO, CC, and SUBJECT." |
573 |
(interactive (list |
(interactive (list |
574 |
(mh-read-address "To: ") |
(mh-interactive-read-address "To: ") |
575 |
(mh-read-address "Cc: ") |
(mh-interactive-read-address "Cc: ") |
576 |
(read-string "Subject: "))) |
(mh-interactive-read-string "Subject: "))) |
577 |
(let ((config (current-window-configuration))) |
(let ((config (current-window-configuration))) |
578 |
(delete-other-windows) |
(delete-other-windows) |
579 |
(mh-send-sub to cc subject config))) |
(mh-send-sub to cc subject config))) |
591 |
If `mh-compose-letter-function' is defined, it is called on the draft and |
If `mh-compose-letter-function' is defined, it is called on the draft and |
592 |
passed three arguments: TO, CC, and SUBJECT." |
passed three arguments: TO, CC, and SUBJECT." |
593 |
(interactive (list |
(interactive (list |
594 |
(mh-read-address "To: ") |
(mh-interactive-read-address "To: ") |
595 |
(mh-read-address "Cc: ") |
(mh-interactive-read-address "Cc: ") |
596 |
(read-string "Subject: "))) |
(mh-interactive-read-string "Subject: "))) |
597 |
(let ((pop-up-windows t)) |
(let ((pop-up-windows t)) |
598 |
(mh-send-sub to cc subject (current-window-configuration)))) |
(mh-send-sub to cc subject (current-window-configuration)))) |
599 |
|
|
634 |
(mh-compose-and-send-mail draft "" folder msg-num |
(mh-compose-and-send-mail draft "" folder msg-num |
635 |
to subject cc |
to subject cc |
636 |
nil nil config) |
nil nil config) |
637 |
(mh-letter-mode-message)))) |
(mh-letter-mode-message) |
638 |
|
(mh-letter-adjust-point)))) |
639 |
|
|
640 |
(defun mh-read-draft (use initial-contents delete-contents-file) |
(defun mh-read-draft (use initial-contents delete-contents-file) |
641 |
"Read draft file into a draft buffer and make that buffer the current one. |
"Read draft file into a draft buffer and make that buffer the current one. |
700 |
(save-excursion |
(save-excursion |
701 |
(cond ((get-buffer buffer) ; Buffer may be deleted |
(cond ((get-buffer buffer) ; Buffer may be deleted |
702 |
(set-buffer buffer) |
(set-buffer buffer) |
703 |
(mh-iterate-on-msg-or-seq nil msg |
(mh-iterate-on-range nil msg |
704 |
(mh-notate nil note (1+ mh-cmd-note))))))) |
(mh-notate nil note (1+ mh-cmd-note))))))) |
705 |
|
|
706 |
(defun mh-insert-fields (&rest name-values) |
(defun mh-insert-fields (&rest name-values) |
872 |
`mh-letter-mode-hook' are run. |
`mh-letter-mode-hook' are run. |
873 |
|
|
874 |
\\{mh-letter-mode-map}" |
\\{mh-letter-mode-map}" |
|
|
|
875 |
(or mh-user-path (mh-find-path)) |
(or mh-user-path (mh-find-path)) |
876 |
(make-local-variable 'mh-send-args) |
(make-local-variable 'mh-send-args) |
877 |
(make-local-variable 'mh-annotate-char) |
(make-local-variable 'mh-annotate-char) |
883 |
(setq mail-header-separator mh-mail-header-separator) ;override sendmail.el |
(setq mail-header-separator mh-mail-header-separator) ;override sendmail.el |
884 |
(make-local-variable 'mh-help-messages) |
(make-local-variable 'mh-help-messages) |
885 |
(setq mh-help-messages mh-letter-mode-help-messages) |
(setq mh-help-messages mh-letter-mode-help-messages) |
886 |
|
(setq buffer-invisibility-spec '((vanish . t) t)) |
887 |
|
(set (make-local-variable 'line-move-ignore-invisible) t) |
888 |
|
|
889 |
|
;; Set mh-mail-header-end-marker to remember end of message header. |
890 |
|
(set (make-local-variable 'mh-letter-mail-header-end-marker) |
891 |
|
(set-marker (make-marker) (save-excursion |
892 |
|
(goto-char (mh-mail-header-end)) |
893 |
|
(line-beginning-position 2)))) |
894 |
|
|
895 |
;; From sendmail.el for proper paragraph fill |
;; From sendmail.el for proper paragraph fill |
896 |
;; sendmail.el also sets a normal-auto-fill-function (not done here) |
;; sendmail.el also sets a normal-auto-fill-function (not done here) |
920 |
|
|
921 |
;; Enable undo since a show-mode buffer might have been reused. |
;; Enable undo since a show-mode buffer might have been reused. |
922 |
(buffer-enable-undo) |
(buffer-enable-undo) |
923 |
(if (and (boundp 'tool-bar-mode) tool-bar-mode) |
(set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map) |
|
(set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)) |
|
924 |
(mh-funcall-if-exists mh-toolbar-init :letter) |
(mh-funcall-if-exists mh-toolbar-init :letter) |
925 |
(make-local-variable 'font-lock-defaults) |
(make-local-variable 'font-lock-defaults) |
926 |
(cond |
(cond |
930 |
;; is that gnus uses static text properties which are not appropriate |
;; is that gnus uses static text properties which are not appropriate |
931 |
;; for a buffer that will be edited. So the choice here is either fontify |
;; for a buffer that will be edited. So the choice here is either fontify |
932 |
;; the citations and header... |
;; the citations and header... |
933 |
(setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) |
(setq font-lock-defaults '(mh-letter-font-lock-keywords t))) |
934 |
(t |
(t |
935 |
;; ...or the header only |
;; ...or the header only |
936 |
(setq font-lock-defaults '(mh-show-font-lock-keywords t)))) |
(setq font-lock-defaults '(mh-show-font-lock-keywords t)))) |
941 |
(make-local-variable 'auto-fill-function) |
(make-local-variable 'auto-fill-function) |
942 |
(setq auto-fill-function 'mh-auto-fill-for-letter))) |
(setq auto-fill-function 'mh-auto-fill-for-letter))) |
943 |
|
|
944 |
|
(defun mh-font-lock-field-data (limit) |
945 |
|
"Find header field region between point and LIMIT." |
946 |
|
(and (< (point) (mh-letter-header-end)) |
947 |
|
(< (point) limit) |
948 |
|
(let ((end (min limit (mh-letter-header-end))) |
949 |
|
(point (point)) |
950 |
|
data-end data-begin field) |
951 |
|
(end-of-line) |
952 |
|
(setq data-end (if (re-search-forward "^[^ \t]" end t) |
953 |
|
(match-beginning 0) |
954 |
|
end)) |
955 |
|
(goto-char (1- data-end)) |
956 |
|
(if (not (re-search-backward "\\(^[^ \t][^:]*\\):[ \t]*" nil t)) |
957 |
|
(setq data-begin (point-min)) |
958 |
|
(setq data-begin (match-end 0)) |
959 |
|
(setq field (match-string 1))) |
960 |
|
(setq data-begin (max point data-begin)) |
961 |
|
(if (and field (mh-letter-skipped-header-field-p field)) |
962 |
|
(set-match-data nil) |
963 |
|
(set-match-data (list data-begin data-end data-begin data-end))) |
964 |
|
(goto-char (if (equal point data-end) (1+ data-end) data-end)) |
965 |
|
t))) |
966 |
|
|
967 |
|
(defun mh-letter-header-end () |
968 |
|
"Find the end of header from `mh-letter-mail-header-end-marker'." |
969 |
|
(save-excursion |
970 |
|
(goto-char (marker-position mh-letter-mail-header-end-marker)) |
971 |
|
(forward-line -1) |
972 |
|
(point))) |
973 |
|
|
974 |
(defun mh-auto-fill-for-letter () |
(defun mh-auto-fill-for-letter () |
975 |
"Perform auto-fill for message. |
"Perform auto-fill for message. |
976 |
Header is treated specially by inserting a tab before continuation lines." |
Header is treated specially by inserting a tab before continuation lines." |
1102 |
The versions of MH-E, Emacs, and MH are shown." |
The versions of MH-E, Emacs, and MH are shown." |
1103 |
|
|
1104 |
;; Lazily initialize mh-x-mailer-string. |
;; Lazily initialize mh-x-mailer-string. |
1105 |
(when (null mh-x-mailer-string) |
(when (and mh-insert-x-mailer-flag (null mh-x-mailer-string)) |
1106 |
(save-window-excursion |
(save-window-excursion |
1107 |
;; User would be confused if version info buffer disappeared magically, |
;; User would be confused if version info buffer disappeared magically, |
1108 |
;; so don't delete buffer if it already existed. |
;; so don't delete buffer if it already existed. |
1129 |
(kill-buffer mh-info-buffer))))) |
(kill-buffer mh-info-buffer))))) |
1130 |
;; Insert X-Mailer, but only if it doesn't already exist. |
;; Insert X-Mailer, but only if it doesn't already exist. |
1131 |
(save-excursion |
(save-excursion |
1132 |
(when (null (mh-goto-header-field "X-Mailer")) |
(when (and mh-insert-x-mailer-flag |
1133 |
|
(null (mh-goto-header-field "X-Mailer"))) |
1134 |
(mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) |
(mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) |
1135 |
|
|
1136 |
(defun mh-regexp-in-field-p (regexp &rest fields) |
(defun mh-regexp-in-field-p (regexp &rest fields) |
1148 |
(setq fields (cdr fields)))) |
(setq fields (cdr fields)))) |
1149 |
search-result))) |
search-result))) |
1150 |
|
|
1151 |
(defun mh-insert-auto-fields () |
;;;###mh-autoload |
1152 |
"Insert custom fields if To or Cc match `mh-auto-fields-list'." |
(defun mh-insert-auto-fields (&optional non-interactive) |
1153 |
(save-excursion |
"Insert custom fields if To or Cc match `mh-auto-fields-list'. |
1154 |
(when (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:"))) |
Sets buffer-local `mh-insert-auto-fields-done-local' when done and inserted |
1155 |
(let ((list mh-auto-fields-list)) |
something. If NON-INTERACTIVE is non-nil, do not be verbose and only |
1156 |
(while list |
attempt matches if `mh-insert-auto-fields-done-local' is nil. |
1157 |
(let ((regexp (nth 0 (car list))) |
|
1158 |
(entries (nth 1 (car list)))) |
An `identity' entry is skipped if one was already entered manually." |
1159 |
(when (mh-regexp-in-field-p regexp "To:" "cc:") |
(interactive) |
1160 |
(let ((entry-list entries)) |
(when (or (not non-interactive) (not mh-insert-auto-fields-done-local)) |
1161 |
(while entry-list |
(save-excursion |
1162 |
(let ((field (caar entry-list)) |
(when (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:"))) |
1163 |
(value (cdar entry-list))) |
(let ((list mh-auto-fields-list)) |
1164 |
(cond |
(while list |
1165 |
((equal "identity" field) |
(let ((regexp (nth 0 (car list))) |
1166 |
(when (assoc value mh-identity-list) |
(entries (nth 1 (car list)))) |
1167 |
(mh-insert-identity value))) |
(when (mh-regexp-in-field-p regexp "To:" "cc:") |
1168 |
(t |
(setq mh-insert-auto-fields-done-local t) |
1169 |
(mh-modify-header-field field value |
(if (not non-interactive) |
1170 |
(equal field "From"))))) |
(message "Matched for regexp %s" regexp)) |
1171 |
(setq entry-list (cdr entry-list)))))) |
(let ((entry-list entries)) |
1172 |
(setq list (cdr list))))))) |
(while entry-list |
1173 |
|
(let ((field (caar entry-list)) |
1174 |
|
(value (cdar entry-list))) |
1175 |
|
(cond |
1176 |
|
((equal "identity" field) |
1177 |
|
(when (and (not mh-identity-local) |
1178 |
|
(assoc value mh-identity-list)) |
1179 |
|
(mh-insert-identity value))) |
1180 |
|
(t |
1181 |
|
(mh-modify-header-field field value |
1182 |
|
(equal field "From"))))) |
1183 |
|
(setq entry-list (cdr entry-list)))))) |
1184 |
|
(setq list (cdr list)))))))) |
1185 |
|
|
1186 |
(defun mh-modify-header-field (field value &optional overwrite-flag) |
(defun mh-modify-header-field (field value &optional overwrite-flag) |
1187 |
"To header FIELD add VALUE. |
"To header FIELD add VALUE. |
1188 |
If OVERWRITE-FLAG is non-nil then the old value, if present, is discarded." |
If OVERWRITE-FLAG is non-nil then the old value, if present, is discarded." |
1189 |
(cond ((mh-goto-header-field (concat field ":")) |
(cond ((and overwrite-flag |
1190 |
(insert value) |
(mh-goto-header-field (concat field ":"))) |
1191 |
(if overwrite-flag |
(insert " " value) |
1192 |
(delete-region (point) (line-end-position)) |
(delete-region (point) (line-end-position))) |
1193 |
(insert ", "))) |
((and (not overwrite-flag) |
1194 |
(t (mh-goto-header-end 0) |
(mh-regexp-in-field-p (concat "\\b" value "\\b") field)) |
1195 |
(insert field ": " value "\n")))) |
;; Already there, do nothing. |
1196 |
|
) |
1197 |
|
((and (not overwrite-flag) |
1198 |
|
(mh-goto-header-field (concat field ":"))) |
1199 |
|
(insert " " value ",")) |
1200 |
|
(t |
1201 |
|
(mh-goto-header-end 0) |
1202 |
|
(insert field ": " value "\n")))) |
1203 |
|
|
1204 |
|
(defvar mh-letter-mail-header-end-marker nil) |
1205 |
|
|
1206 |
(defun mh-compose-and-send-mail (draft send-args |
(defun mh-compose-and-send-mail (draft send-args |
1207 |
sent-from-folder sent-from-msg |
sent-from-folder sent-from-msg |
1220 |
for `mh-annotate-msg'. |
for `mh-annotate-msg'. |
1221 |
CONFIG is the window configuration to restore after sending the letter." |
CONFIG is the window configuration to restore after sending the letter." |
1222 |
(pop-to-buffer draft) |
(pop-to-buffer draft) |
|
(mh-insert-auto-fields) |
|
1223 |
(mh-letter-mode) |
(mh-letter-mode) |
1224 |
|
(mh-insert-auto-fields t) |
1225 |
|
|
1226 |
;; mh-identity support |
;; mh-identity support |
1227 |
(if (and (boundp 'mh-identity-default) |
(if (and (boundp 'mh-identity-default) |
1233 |
(mh-identity-make-menu) |
(mh-identity-make-menu) |
1234 |
(easy-menu-add mh-identity-menu)) |
(easy-menu-add mh-identity-menu)) |
1235 |
|
|
1236 |
|
;; Extra fields |
1237 |
|
(mh-insert-x-mailer) |
1238 |
|
(mh-insert-x-face) |
1239 |
|
;; Hide skipped fields |
1240 |
|
(mh-letter-hide-all-skipped-fields) |
1241 |
|
|
1242 |
(setq mh-sent-from-folder sent-from-folder) |
(setq mh-sent-from-folder sent-from-folder) |
1243 |
(setq mh-sent-from-msg sent-from-msg) |
(setq mh-sent-from-msg sent-from-msg) |
1244 |
(setq mh-send-args send-args) |
(setq mh-send-args send-args) |
1278 |
Insert X-Face field if the file specified by `mh-x-face-file' exists." |
Insert X-Face field if the file specified by `mh-x-face-file' exists." |
1279 |
(interactive "P") |
(interactive "P") |
1280 |
(run-hooks 'mh-before-send-letter-hook) |
(run-hooks 'mh-before-send-letter-hook) |
1281 |
|
(mh-insert-auto-fields t) |
1282 |
(cond ((mh-mhn-directive-present-p) |
(cond ((mh-mhn-directive-present-p) |
1283 |
(mh-edit-mhn)) |
(mh-edit-mhn)) |
1284 |
((mh-mml-directive-present-p) |
((mh-mml-directive-present-p) |
1285 |
(mh-mml-to-mime))) |
(mh-mml-to-mime))) |
|
(if mh-insert-x-mailer-flag (mh-insert-x-mailer)) |
|
|
(mh-insert-x-face) |
|
1286 |
(save-buffer) |
(save-buffer) |
1287 |
(message "Sending...") |
(message "Sending...") |
1288 |
(let ((draft-buffer (current-buffer)) |
(let ((draft-buffer (current-buffer)) |
1549 |
|
|
1550 |
(mh-do-in-xemacs (defvar mail-abbrevs)) |
(mh-do-in-xemacs (defvar mail-abbrevs)) |
1551 |
|
|
1552 |
|
;;;###mh-autoload |
1553 |
|
(defun mh-complete-word (word choices begin end) |
1554 |
|
"Complete WORD at from CHOICES. |
1555 |
|
Any match found replaces the text from BEGIN to END." |
1556 |
|
(let ((completion (try-completion word choices))) |
1557 |
|
(cond ((eq completion t) |
1558 |
|
(message "Completed: %s" word)) |
1559 |
|
((null completion) |
1560 |
|
(message "No completion for `%s'" word)) |
1561 |
|
((stringp completion) |
1562 |
|
(if (equal word completion) |
1563 |
|
(with-output-to-temp-buffer "*Completions*" |
1564 |
|
(display-completion-list (all-completions word choices))) |
1565 |
|
(delete-region begin end) |
1566 |
|
(insert completion)))))) |
1567 |
|
|
1568 |
|
;;;###mh-autoload |
1569 |
|
(defun mh-beginning-of-word (&optional n) |
1570 |
|
"Return position of the N th word backwards." |
1571 |
|
(unless n (setq n 1)) |
1572 |
|
(let ((syntax-table (syntax-table))) |
1573 |
|
(unwind-protect |
1574 |
|
(save-excursion |
1575 |
|
(mh-funcall-if-exists mail-abbrev-make-syntax-table) |
1576 |
|
(set-syntax-table mail-abbrev-syntax-table) |
1577 |
|
(backward-word n) |
1578 |
|
(point)) |
1579 |
|
(set-syntax-table syntax-table)))) |
1580 |
|
|
1581 |
(defun mh-folder-expand-at-point () |
(defun mh-folder-expand-at-point () |
1582 |
"Do folder name completion in Fcc header field." |
"Do folder name completion in Fcc header field." |
1583 |
(let* ((end (point)) |
(let* ((end (point)) |
1584 |
(syntax-table (syntax-table)) |
(beg (mh-beginning-of-word)) |
|
(beg (unwind-protect |
|
|
(save-excursion |
|
|
(mh-funcall-if-exists mail-abbrev-make-syntax-table) |
|
|
(set-syntax-table mail-abbrev-syntax-table) |
|
|
(backward-word 1) |
|
|
(point)) |
|
|
(set-syntax-table syntax-table))) |
|
1585 |
(folder (buffer-substring beg end)) |
(folder (buffer-substring beg end)) |
1586 |
(leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+))) |
(leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+))) |
1587 |
(last-slash (mh-search-from-end ?/ folder)) |
(last-slash (mh-search-from-end ?/ folder)) |
1588 |
(prefix (and last-slash (substring folder 0 last-slash))) |
(prefix (and last-slash (substring folder 0 last-slash))) |
1589 |
(mail-abbrevs |
(choices (mapcar #'(lambda (x) |
1590 |
(mapcar #'(lambda (x) |
(list (cond (prefix (format "%s/%s" prefix x)) |
1591 |
(list (cond (prefix (format "%s/%s" prefix x)) |
(leading-plus (format "+%s" x)) |
1592 |
(leading-plus (format "+%s" x)) |
(t x)))) |
1593 |
(t x)))) |
(mh-folder-completion-function folder nil t)))) |
1594 |
(mh-folder-completion-function folder nil t)))) |
(mh-complete-word folder choices beg end))) |
1595 |
(if (fboundp 'mail-abbrev-complete-alias) |
|
1596 |
(mh-funcall-if-exists mail-abbrev-complete-alias) |
;; XXX: This should probably be customizable |
1597 |
(error "Fcc completion not supported in your version of Emacs")))) |
(defvar mh-letter-complete-function-alist |
1598 |
|
'((cc . mh-alias-letter-expand-alias) |
1599 |
|
(bcc . mh-alias-letter-expand-alias) |
1600 |
|
(dcc . mh-alias-letter-expand-alias) |
1601 |
|
(fcc . mh-folder-expand-at-point) |
1602 |
|
(from . mh-alias-letter-expand-alias) |
1603 |
|
(mail-followup-to . mh-alias-letter-expand-alias) |
1604 |
|
(reply-to . mh-alias-letter-expand-alias) |
1605 |
|
(to . mh-alias-letter-expand-alias)) |
1606 |
|
"Alist of header fields and completion functions to use.") |
1607 |
|
|
|
;;;###mh-autoload |
|
1608 |
(defun mh-letter-complete (arg) |
(defun mh-letter-complete (arg) |
1609 |
"Perform completion on header field or word preceding point. |
"Perform completion on header field or word preceding point. |
1610 |
Alias completion is done within the mail header on selected fields and |
Alias completion is done within the mail header on selected fields based on |
1611 |
by the function designated by `mh-letter-complete-function' elsewhere, |
the matches in `mh-letter-complete-function-alist'. Elsewhere the function |
1612 |
passing the prefix ARG if any." |
designated by `mh-letter-complete-function' is used and given the prefix ARG, |
1613 |
|
if present." |
1614 |
(interactive "P") |
(interactive "P") |
1615 |
(let ((case-fold-search t)) |
(let ((func nil)) |
1616 |
(cond |
(cond ((not (mh-in-header-p)) |
1617 |
((and (mh-in-header-p) |
(funcall mh-letter-complete-function arg)) |
1618 |
(save-excursion |
((setq func (cdr (assoc (mh-letter-header-field-at-point) |
1619 |
(mh-header-field-beginning) |
mh-letter-complete-function-alist))) |
1620 |
(looking-at "^fcc:"))) |
(funcall func)) |
1621 |
(mh-folder-expand-at-point)) |
(t (funcall mh-letter-complete-function arg))))) |
1622 |
((and (mh-in-header-p) |
|
1623 |
(save-excursion |
(defun mh-letter-complete-or-space (arg) |
1624 |
(mh-header-field-beginning) |
"Perform completion or insert space. |
1625 |
(looking-at "^.*\\(to\\|cc\\|from\\):"))) |
If `mh-compose-space-does-completion-flag' is nil (the default) a space is |
1626 |
(mh-alias-letter-expand-alias)) |
inserted. |
1627 |
(t |
|
1628 |
(funcall mh-letter-complete-function arg))))) |
Otherwise, if point is in the message header and the preceding character is |
1629 |
|
not whitespace then do completion. Otherwise insert a space character. |
1630 |
|
|
1631 |
|
ARG is the number of spaces inserted." |
1632 |
|
(interactive "p") |
1633 |
|
(let ((func nil) |
1634 |
|
(end-of-prev (save-excursion |
1635 |
|
(goto-char (mh-beginning-of-word)) |
1636 |
|
(mh-beginning-of-word -1)))) |
1637 |
|
(cond ((not mh-compose-space-does-completion-flag) |
1638 |
|
(self-insert-command arg)) |
1639 |
|
((not (mh-in-header-p)) (self-insert-command arg)) |
1640 |
|
((> (point) end-of-prev) (self-insert-command arg)) |
1641 |
|
((setq func (cdr (assoc (mh-letter-header-field-at-point) |
1642 |
|
mh-letter-complete-function-alist))) |
1643 |
|
(funcall func)) |
1644 |
|
(t (self-insert-command arg))))) |
1645 |
|
|
1646 |
|
(defun mh-letter-confirm-address () |
1647 |
|
"Flash alias expansion if `mh-alias-flash-on-comma' is non-nil." |
1648 |
|
(interactive) |
1649 |
|
(cond ((not (mh-in-header-p)) (self-insert-command 1)) |
1650 |
|
((eq (cdr (assoc (mh-letter-header-field-at-point) |
1651 |
|
mh-letter-complete-function-alist)) |
1652 |
|
'mh-alias-letter-expand-alias) |
1653 |
|
(mh-alias-reload-maybe) |
1654 |
|
(mh-alias-minibuffer-confirm-address)) |
1655 |
|
(t (self-insert-command 1)))) |
1656 |
|
|
1657 |
|
(defvar mh-letter-header-field-regexp "^\\([A-Za-z][A-Za-z0-9-]*\\):") |
1658 |
|
|
1659 |
|
(defun mh-letter-header-field-at-point () |
1660 |
|
"Return the header field name at point. |
1661 |
|
A symbol is returned whose name is the string obtained by downcasing the field |
1662 |
|
name." |
1663 |
|
(save-excursion |
1664 |
|
(end-of-line) |
1665 |
|
(and (re-search-backward mh-letter-header-field-regexp nil t) |
1666 |
|
(intern (downcase (match-string 1)))))) |
1667 |
|
|
1668 |
|
;;;###mh-autoload |
1669 |
|
(defun mh-letter-next-header-field-or-indent (arg) |
1670 |
|
"Move to next field or indent depending on point. |
1671 |
|
In the message header, go to the next field. Elsewhere call |
1672 |
|
`indent-relative' as usual with optional prefix ARG." |
1673 |
|
(interactive "P") |
1674 |
|
(let ((header-end (save-excursion |
1675 |
|
(goto-char (mh-mail-header-end)) |
1676 |
|
(forward-line) |
1677 |
|
(point)))) |
1678 |
|
(if (> (point) header-end) |
1679 |
|
(indent-relative arg) |
1680 |
|
(mh-letter-next-header-field)))) |
1681 |
|
|
1682 |
|
(defun mh-letter-next-header-field () |
1683 |
|
"Cycle to the next header field. |
1684 |
|
If we are at the last header field go to the start of the message body." |
1685 |
|
(let ((header-end (mh-mail-header-end))) |
1686 |
|
(cond ((>= (point) header-end) (goto-char (point-min))) |
1687 |
|
((< (point) (progn |
1688 |
|
(beginning-of-line) |
1689 |
|
(re-search-forward mh-letter-header-field-regexp |
1690 |
|
(line-end-position) t) |
1691 |
|
(point))) |
1692 |
|
(beginning-of-line)) |
1693 |
|
(t (end-of-line))) |
1694 |
|
(cond ((re-search-forward mh-letter-header-field-regexp header-end t) |
1695 |
|
(if (mh-letter-skipped-header-field-p (match-string 1)) |
1696 |
|
(mh-letter-next-header-field) |
1697 |
|
(mh-letter-skip-leading-whitespace-in-header-field))) |
1698 |
|
(t (goto-char header-end) |
1699 |
|
(forward-line))))) |
1700 |
|
|
1701 |
|
;;;###mh-autoload |
1702 |
|
(defun mh-letter-previous-header-field () |
1703 |
|
"Cycle to the previous header field. |
1704 |
|
If we are at the first header field go to the start of the message body." |
1705 |
|
(interactive) |
1706 |
|
(let ((header-end (mh-mail-header-end))) |
1707 |
|
(if (>= (point) header-end) |
1708 |
|
(goto-char header-end) |
1709 |
|
(mh-header-field-beginning)) |
1710 |
|
(cond ((re-search-backward mh-letter-header-field-regexp nil t) |
1711 |
|
(if (mh-letter-skipped-header-field-p (match-string 1)) |
1712 |
|
(mh-letter-previous-header-field) |
1713 |
|
(goto-char (match-end 0)) |
1714 |
|
(mh-letter-skip-leading-whitespace-in-header-field))) |
1715 |
|
(t (goto-char header-end) |
1716 |
|
(forward-line))))) |
1717 |
|
|
1718 |
|
(defun mh-letter-skipped-header-field-p (field) |
1719 |
|
"Check if FIELD is to be skipped." |
1720 |
|
(let ((field (downcase field))) |
1721 |
|
(loop for x in mh-compose-skipped-header-fields |
1722 |
|
when (equal (downcase x) field) return t |
1723 |
|
finally return nil))) |
1724 |
|
|
1725 |
|
(defun mh-letter-skip-leading-whitespace-in-header-field () |
1726 |
|
"Skip leading whitespace in a header field. |
1727 |
|
If the header field doesn't have at least one space after the colon then a |
1728 |
|
space character is added." |
1729 |
|
(let ((need-space t)) |
1730 |
|
(while (memq (char-after) '(?\t ?\ )) |
1731 |
|
(forward-char) |
1732 |
|
(setq need-space nil)) |
1733 |
|
(when need-space (insert " ")))) |
1734 |
|
|
1735 |
|
(defvar mh-hidden-header-keymap |
1736 |
|
(let ((map (make-sparse-keymap))) |
1737 |
|
(mh-do-in-gnu-emacs |
1738 |
|
(define-key map [mouse-2] 'mh-letter-toggle-header-field-display-button)) |
1739 |
|
(mh-do-in-xemacs |
1740 |
|
(define-key map '(button2) |
1741 |
|
'mh-letter-toggle-header-field-display-button)) |
1742 |
|
map)) |
1743 |
|
|
1744 |
|
(defun mh-letter-toggle-header-field-display-button (event) |
1745 |
|
"Toggle header field display at location of EVENT. |
1746 |
|
This function does the same thing as `mh-letter-toggle-header-field-display' |
1747 |
|
except that it is callable from a mouse button." |
1748 |
|
(interactive "e") |
1749 |
|
(mh-do-at-event-location event |
1750 |
|
(mh-letter-toggle-header-field-display nil))) |
1751 |
|
|
1752 |
|
(defun mh-letter-toggle-header-field-display (arg) |
1753 |
|
"Toggle display of header field at point. |
1754 |
|
If the header is long or spread over multiple lines then hiding it will show |
1755 |
|
the first few characters and replace the rest with an ellipsis. |
1756 |
|
|
1757 |
|
If ARG is negative then header is hidden, if positive it is displayed. If ARG |
1758 |
|
is the symbol `long' then keep at most the first 4 lines." |
1759 |
|
(interactive (list nil)) |
1760 |
|
(when (and (mh-in-header-p) |
1761 |
|
(progn |
1762 |
|
(end-of-line) |
1763 |
|
(re-search-backward mh-letter-header-field-regexp nil t))) |
1764 |
|
(let ((buffer-read-only nil) |
1765 |
|
(modified-flag (buffer-modified-p)) |
1766 |
|
(begin (point)) |
1767 |
|
end) |
1768 |
|
(end-of-line) |
1769 |
|
(setq end (1- (if (re-search-forward "^[^ \t]" nil t) |
1770 |
|
(match-beginning 0) |
1771 |
|
(point-max)))) |
1772 |
|
(goto-char begin) |
1773 |
|
;; Make it clickable... |
1774 |
|
(add-text-properties begin end `(keymap ,mh-hidden-header-keymap |
1775 |
|
mouse-face highlight)) |
1776 |
|
(unwind-protect |
1777 |
|
(cond ((or (and (not arg) |
1778 |
|
(text-property-any begin end 'invisible 'vanish)) |
1779 |
|
(and (numberp arg) (>= arg 0)) |
1780 |
|
(and (eq arg 'long) (> (line-beginning-position 5) end))) |
1781 |
|
(remove-text-properties begin end '(invisible nil)) |
1782 |
|
(search-forward ":" (line-end-position) t) |
1783 |
|
(mh-letter-skip-leading-whitespace-in-header-field)) |
1784 |
|
((eq arg 'long) |
1785 |
|
(end-of-line 4) |
1786 |
|
(mh-letter-truncate-header-field end) |
1787 |
|
(beginning-of-line)) |
1788 |
|
(t (end-of-line) |
1789 |
|
(mh-letter-truncate-header-field end) |
1790 |
|
(beginning-of-line))) |
1791 |
|
(set-buffer-modified-p modified-flag))))) |
1792 |
|
|
1793 |
|
(defun mh-letter-truncate-header-field (end) |
1794 |
|
"Replace text from current line till END with an ellipsis. |
1795 |
|
If the current line is too long truncate a part of it as well." |
1796 |
|
(let ((max-len (min (window-width) 62))) |
1797 |
|
(when (> (+ (current-column) 4) max-len) |
1798 |
|
(backward-char (- (+ (current-column) 5) max-len))) |
1799 |
|
(when (> end (point)) |
1800 |
|
(add-text-properties (point) end '(invisible vanish))))) |
1801 |
|
|
1802 |
|
(defun mh-letter-hide-all-skipped-fields () |
1803 |
|
"Hide all skipped fields." |
1804 |
|
(save-excursion |
1805 |
|
(goto-char (point-min)) |
1806 |
|
(save-restriction |
1807 |
|
(narrow-to-region (point) (mh-mail-header-end)) |
1808 |
|
(while (re-search-forward mh-letter-header-field-regexp nil t) |
1809 |
|
(if (mh-letter-skipped-header-field-p (match-string 1)) |
1810 |
|
(mh-letter-toggle-header-field-display -1) |
1811 |
|
(mh-letter-toggle-header-field-display 'long)) |
1812 |
|
(beginning-of-line 2))))) |
1813 |
|
|
1814 |
|
(defun mh-interactive-read-address (prompt) |
1815 |
|
"Read an address. |
1816 |
|
If `mh-compose-prompt-flag' is non-nil, then read an address with PROMPT. |
1817 |
|
Otherwise return the empty string." |
1818 |
|
(if mh-compose-prompt-flag (mh-read-address prompt) "")) |
1819 |
|
|
1820 |
|
(defun mh-interactive-read-string (prompt) |
1821 |
|
"Read a string. |
1822 |
|
If `mh-compose-prompt-flag' is non-nil, then read a string with PROMPT. |
1823 |
|
Otherwise return the empty string." |
1824 |
|
(if mh-compose-prompt-flag (read-string prompt) "")) |
1825 |
|
|
1826 |
|
(defun mh-letter-adjust-point () |
1827 |
|
"Move cursor to first header field if are using the no prompt mode." |
1828 |
|
(unless mh-compose-prompt-flag |
1829 |
|
(goto-char (point-max)) |
1830 |
|
(mh-letter-next-header-field))) |
1831 |
|
|
1832 |
;;; Build the letter-mode keymap: |
;;; Build the letter-mode keymap: |
1833 |
;;; If this changes, modify mh-letter-mode-help-messages accordingly, above. |
;;; If this changes, modify mh-letter-mode-help-messages accordingly, above. |
1835 |
"\C-c?" mh-help |
"\C-c?" mh-help |
1836 |
"\C-c\C-c" mh-send-letter |
"\C-c\C-c" mh-send-letter |
1837 |
"\C-c\C-d" mh-insert-identity |
"\C-c\C-d" mh-insert-identity |
1838 |
|
"\C-c\M-d" mh-insert-auto-fields |
1839 |
"\C-c\C-e" mh-edit-mhn |
"\C-c\C-e" mh-edit-mhn |
1840 |
"\C-c\C-f\C-b" mh-to-field |
"\C-c\C-f\C-b" mh-to-field |
1841 |
"\C-c\C-f\C-c" mh-to-field |
"\C-c\C-f\C-c" mh-to-field |
1871 |
"\C-c\C-^" mh-insert-signature ;if no C-s |
"\C-c\C-^" mh-insert-signature ;if no C-s |
1872 |
"\C-c\C-w" mh-check-whom |
"\C-c\C-w" mh-check-whom |
1873 |
"\C-c\C-y" mh-yank-cur-msg |
"\C-c\C-y" mh-yank-cur-msg |
1874 |
"\M-\t" mh-letter-complete) |
"\C-c\C-t" mh-letter-toggle-header-field-display |
1875 |
|
" " mh-letter-complete-or-space |
1876 |
|
"\M-\t" mh-letter-complete |
1877 |
|
"\t" mh-letter-next-header-field-or-indent |
1878 |
|
[backtab] mh-letter-previous-header-field |
1879 |
|
"," mh-letter-confirm-address) |
1880 |
|
|
1881 |
;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. |
;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. |
1882 |
|
|