/[emacs]/emacs/lisp/mh-e/mh-comp.el
ViewVC logotype

Diff of /emacs/lisp/mh-e/mh-comp.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3.4.2 by miles, Tue Oct 14 23:39:25 2003 UTC revision 1.3.4.3 by miles, Sat Jul 17 02:51:48 2004 UTC
# Line 1  Line 1 
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>
# Line 36  Line 36 
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    
# Line 199  Used by the \\<mh-folder-mode-map>`\\[mh Line 200  Used by the \\<mh-folder-mode-map>`\\[mh
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.
# Line 279  See also documentation for `\\[mh-send]' Line 284  See also documentation for `\\[mh-send]'
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)
# Line 309  See also documentation for `\\[mh-send]' Line 315  See also documentation for `\\[mh-send]'
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
# Line 355  See also documentation for `\\[mh-send]' Line 359  See also documentation for `\\[mh-send]'
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-+\\) \\(.*\\)$"
# Line 376  See also documentation for `\\[mh-send]' Line 379  See also documentation for `\\[mh-send]'
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)
# Line 384  See also documentation for `\\[mh-send]' Line 387  See also documentation for `\\[mh-send]'
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.
# Line 567  details. Line 571  details.
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)))
# Line 587  details. Line 591  details.
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    
# Line 630  CONFIG is the window configuration befor Line 634  CONFIG is the window configuration befor
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.
# Line 695  MSG can be a message number, a list of m Line 700  MSG can be a message number, a list of m
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)
# Line 867  When a message is composed, the hooks `t Line 872  When a message is composed, the hooks `t
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)
# Line 879  When a message is composed, the hooks `t Line 883  When a message is composed, the hooks `t
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)
# Line 908  When a message is composed, the hooks `t Line 920  When a message is composed, the hooks `t
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
# Line 919  When a message is composed, the hooks `t Line 930  When a message is composed, the hooks `t
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))))
# Line 930  When a message is composed, the hooks `t Line 941  When a message is composed, the hooks `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."
# Line 1061  MH the first time a message is composed. Line 1102  MH the first time a message is composed.
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.
# Line 1088  The versions of MH-E, Emacs, and MH are Line 1129  The versions of MH-E, Emacs, and MH are
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)
# Line 1106  The versions of MH-E, Emacs, and MH are Line 1148  The versions of MH-E, Emacs, and MH are
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
# Line 1157  message.  In that case, the ANNOTATE-FIE Line 1220  message.  In that case, the ANNOTATE-FIE
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)
# Line 1170  CONFIG is the window configuration to re Line 1233  CONFIG is the window configuration to re
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)
# Line 1209  Insert X-Mailer field if variable `mh-in Line 1278  Insert X-Mailer field if variable `mh-in
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))
# Line 1481  This is useful in breaking up paragraphs Line 1549  This is useful in breaking up paragraphs
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.
# Line 1534  passing the prefix ARG if any." Line 1835  passing the prefix ARG if any."
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
# Line 1569  passing the prefix ARG if any." Line 1871  passing the prefix ARG if any."
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    

Legend:
Removed from v.1.3.4.2  
changed lines
  Added in v.1.3.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26