Merge from emacs-24; up to 2012-12-06T01:39:03Z!monnier@iro.umontreal.ca

[bpt/emacs.git] / lisp / mh-e / mh-letter.el

diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el
index eebc30a..b4d8b62 100644 (file)
--- a/lisp/mh-e/mh-letter.el
+++ b/lisp/mh-e/mh-letter.el
@@ -1,6 +1,7 @@
 ;;; mh-letter.el --- MH-Letter mode
 
 ;;; mh-letter.el --- MH-Letter mode
 

-;; Copyright (C) 1993, 1995, 1997, 2000-2011  Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 1997, 2000-2013 Free Software Foundation,
+;; Inc.

 
 ;; Author: Bill Wohler <wohler@newt.com>
 ;; Maintainer: Bill Wohler <wohler@newt.com>
 
 ;; Author: Bill Wohler <wohler@newt.com>
 ;; Maintainer: Bill Wohler <wohler@newt.com>


@@ -66,8 +67,9 @@ Each hook function can find the citation between point and mark.
 And each hook function should leave point and mark around the
 citation text as modified.
 
 And each hook function should leave point and mark around the
 citation text as modified.
 

-This is a normal hook, misnamed for historical reasons. It is
-semi-obsolete and is only used if `mail-citation-hook' is nil.")
+This is a normal hook, misnamed for historical reasons.
+It is obsolete and is only used if `mail-citation-hook' is nil.")
+(mh-make-obsolete-variable 'mh-yank-hooks 'mail-citation-hook "19.34")

 
 \f
 
 
 \f
 


@@ -273,7 +275,8 @@ searching for `mh-mail-header-separator' in the buffer."
 ;;; MH-Letter Mode
 
 ;; Shush compiler.
 ;;; MH-Letter Mode
 
 ;; Shush compiler.

-(defvar font-lock-defaults)             ; XEmacs
+(mh-do-in-xemacs
+  (defvar font-lock-defaults))

 
 ;; Ensure new buffers won't get this mode if default major-mode is nil.
 (put 'mh-letter-mode 'mode-class 'special)
 
 ;; Ensure new buffers won't get this mode if default major-mode is nil.
 (put 'mh-letter-mode 'mode-class 'special)


@@ -346,6 +349,8 @@ order).
   (define-key mh-letter-mode-map [menu-bar mail] 'undefined)
   (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
   (setq fill-column mh-letter-fill-column)
   (define-key mh-letter-mode-map [menu-bar mail] 'undefined)
   (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu))
   (setq fill-column mh-letter-fill-column)

+  (add-hook 'completion-at-point-functions
+            'mh-letter-completion-at-point nil 'local)

   ;; If text-mode-hook turned on auto-fill, tune it for messages
   (when auto-fill-function
     (make-local-variable 'auto-fill-function)
   ;; If text-mode-hook turned on auto-fill, tune it for messages
   (when auto-fill-function
     (make-local-variable 'auto-fill-function)


@@ -488,24 +493,41 @@ In a program, you can pass in a signature FILE."
             (message "No signature found")))))
   (force-mode-line-update))
 
             (message "No signature found")))))
   (force-mode-line-update))
 

-(defun mh-letter-complete (arg)
+(defun mh-letter-completion-at-point ()
+  "Return the completion data at point for MH letters.
+This provides alias and folder completion in header fields according to
+`mh-letter-complete-function-alist' and falls back on
+`mh-letter-complete-function-alist' elsewhere."
+  (let ((func (and (mh-in-header-p)
+                   (cdr (assoc (mh-letter-header-field-at-point)
+                               mh-letter-complete-function-alist)))))
+    (if func
+        (or (funcall func) #'ignore)
+      mh-letter-complete-function)))
+
+;; TODO Now that completion-at-point performs the task of
+;; mh-letter-complete, perhaps mh-letter-complete along with
+;; mh-complete-word should be rewritten as a more general function for
+;; XEmacs, renamed to mh-completion-at-point, and moved to
+;; mh-compat.el.
+(defun-mh mh-letter-complete completion-at-point ()

   "Perform completion on header field or word preceding point.
 
 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 or folders (for example, \"Fcc:\") then this command will provide
 alias completion. In the body of the message, this command runs
 `mh-letter-complete-function' instead, which is set to
   "Perform completion on header field or word preceding point.
 
 If the field contains addresses (for example, \"To:\" or \"Cc:\")
 or folders (for example, \"Fcc:\") then this command will provide
 alias completion. In the body of the message, this command runs
 `mh-letter-complete-function' instead, which is set to

-`ispell-complete-word' by default. This command takes a prefix
-argument ARG that is passed to the
-`mh-letter-complete-function'."
-  (interactive "P")
-  (let ((func nil))
-    (cond ((not (mh-in-header-p))
-           (funcall mh-letter-complete-function arg))
-          ((setq func (cdr (assoc (mh-letter-header-field-at-point)
-                                  mh-letter-complete-function-alist)))
-           (funcall func))
-          (t (funcall mh-letter-complete-function arg)))))
+`ispell-complete-word' by default."
+      (interactive)
+      (let ((data (mh-letter-completion-at-point)))
+        (cond
+         ((functionp data) (funcall data))
+         ((consp data)
+          (let ((start (nth 0 data))
+                (end (nth 1 data))
+                (table (nth 2 data)))
+            (mh-complete-word (buffer-substring-no-properties start end)
+                              table start end))))))

 
 (defun mh-letter-complete-or-space (arg)
   "Perform completion or insert space.
 
 (defun mh-letter-complete-or-space (arg)
   "Perform completion or insert space.


@@ -515,17 +537,17 @@ this command to perform completion in the header. Otherwise, a
 space is inserted; use a prefix argument ARG to specify more than
 one space."
   (interactive "p")
 space is inserted; use a prefix argument ARG to specify more than
 one space."
   (interactive "p")

-  (let ((func nil)
-        (end-of-prev (save-excursion
+  (let ((end-of-prev (save-excursion

                        (goto-char (mh-beginning-of-word))
                        (mh-beginning-of-word -1))))
     (cond ((not mh-compose-space-does-completion-flag)
            (self-insert-command arg))
                        (goto-char (mh-beginning-of-word))
                        (mh-beginning-of-word -1))))
     (cond ((not mh-compose-space-does-completion-flag)
            (self-insert-command arg))

-          ((not (mh-in-header-p)) (self-insert-command arg))
+          ;; FIXME: This > test is redundant now that all the completion
+          ;; functions do it anyway.

           ((> (point) end-of-prev) (self-insert-command arg))
           ((> (point) end-of-prev) (self-insert-command arg))

-          ((setq func (cdr (assoc (mh-letter-header-field-at-point)
-                                  mh-letter-complete-function-alist)))
-           (funcall func))
+          ((let ((mh-letter-complete-function nil))
+             (mh-letter-completion-at-point))
+           (mh-letter-complete))

           (t (self-insert-command arg)))))
 
 (defun mh-letter-confirm-address ()
           (t (self-insert-command arg)))))
 
 (defun mh-letter-confirm-address ()


@@ -703,69 +725,71 @@ not inserted. If the option `mh-yank-behavior' is set to one of
 the supercite flavors, the hook `mail-citation-hook' is ignored
 and `mh-ins-buf-prefix' is not inserted."
   (interactive)
 the supercite flavors, the hook `mail-citation-hook' is ignored
 and `mh-ins-buf-prefix' is not inserted."
   (interactive)

-  (if (and mh-sent-from-folder
-           (with-current-buffer mh-sent-from-folder mh-show-buffer)
-           (with-current-buffer mh-sent-from-folder
-             (get-buffer mh-show-buffer))
-           mh-sent-from-msg)
-      (let ((to-point (point))
-            (to-buffer (current-buffer)))
-        (set-buffer mh-sent-from-folder)
-        (if mh-delete-yanked-msg-window-flag
-            (delete-windows-on mh-show-buffer))
-        (set-buffer mh-show-buffer)     ; Find displayed message
-        (let* ((from-attr (mh-extract-from-attribution))
-               (yank-region (mh-mark-active-p nil))
-               (mh-ins-str
-                (cond ((and yank-region
-                            (or (eq 'supercite mh-yank-behavior)
-                                (eq 'autosupercite mh-yank-behavior)
-                                (eq t mh-yank-behavior)))
-                       ;; supercite needs the full header
-                       (concat
-                        (buffer-substring (point-min) (mh-mail-header-end))
-                        "\n"
-                        (buffer-substring (region-beginning) (region-end))))
-                      (yank-region
-                       (buffer-substring (region-beginning) (region-end)))
-                      ((or (eq 'body mh-yank-behavior)
-                           (eq 'attribution mh-yank-behavior)
-                           (eq 'autoattrib mh-yank-behavior))
-                       (buffer-substring
-                        (save-excursion
-                          (goto-char (point-min))
-                          (mh-goto-header-end 1)
-                          (point))
-                        (point-max)))
-                      ((or (eq 'supercite mh-yank-behavior)
-                           (eq 'autosupercite mh-yank-behavior)
-                           (eq t mh-yank-behavior))
-                       (buffer-substring (point-min) (point-max)))
-                      (t
-                       (buffer-substring (point) (point-max))))))
-          (set-buffer to-buffer)
-          (save-restriction
-            (narrow-to-region to-point to-point)
-            (insert (mh-filter-out-non-text mh-ins-str))
-            (goto-char (point-max))     ;Needed for sc-cite-original
-            (push-mark)                 ;Needed for sc-cite-original
-            (goto-char (point-min))     ;Needed for sc-cite-original
-            (mh-insert-prefix-string mh-ins-buf-prefix)
-            (when (or (eq 'attribution mh-yank-behavior)
-                      (eq 'autoattrib mh-yank-behavior))
-              (insert from-attr)
-              (mh-identity-insert-attribution-verb nil)
-              (insert "\n\n"))
-            ;; If the user has selected a region, he has already "edited" the
-            ;; text, so leave the cursor at the end of the yanked text. In
-            ;; either case, leave a mark at the opposite end of the included
-            ;; text to make it easy to jump or delete to the other end of the
-            ;; text.
-            (push-mark)
-            (goto-char (point-max))
-            (if (null yank-region)
-                (mh-exchange-point-and-mark-preserving-active-mark)))))
-    (error "There is no current message")))
+  (let ((show-buffer))
+    (if (and mh-sent-from-folder
+             (with-current-buffer mh-sent-from-folder mh-show-buffer)
+             (setq show-buffer (with-current-buffer mh-sent-from-folder
+                                 (get-buffer mh-show-buffer)))
+             mh-sent-from-msg)
+        (let ((to-point (point))
+              (to-buffer (current-buffer)))
+          (if mh-delete-yanked-msg-window-flag
+              (with-current-buffer mh-sent-from-folder
+                (delete-windows-on show-buffer)))
+          ;; Find displayed message
+          (with-current-buffer show-buffer
+            (let* ((from-attr (mh-extract-from-attribution))
+                   (yank-region (mh-mark-active-p nil))
+                   (mh-ins-str
+                    (cond ((and yank-region
+                                (or (eq 'supercite mh-yank-behavior)
+                                    (eq 'autosupercite mh-yank-behavior)
+                                    (eq t mh-yank-behavior)))
+                           ;; supercite needs the full header
+                           (concat
+                            (buffer-substring (point-min) (mh-mail-header-end))
+                            "\n"
+                            (buffer-substring (region-beginning) (region-end))))
+                          (yank-region
+                           (buffer-substring (region-beginning) (region-end)))
+                          ((or (eq 'body mh-yank-behavior)
+                               (eq 'attribution mh-yank-behavior)
+                               (eq 'autoattrib mh-yank-behavior))
+                           (buffer-substring
+                            (save-excursion
+                              (goto-char (point-min))
+                              (mh-goto-header-end 1)
+                              (point))
+                            (point-max)))
+                          ((or (eq 'supercite mh-yank-behavior)
+                               (eq 'autosupercite mh-yank-behavior)
+                               (eq t mh-yank-behavior))
+                           (buffer-substring (point-min) (point-max)))
+                          (t
+                           (buffer-substring (point) (point-max))))))
+              (with-current-buffer to-buffer
+                (save-restriction
+                  (narrow-to-region to-point to-point)
+                  (insert (mh-filter-out-non-text mh-ins-str))
+                  (goto-char (point-max))     ;Needed for sc-cite-original
+                  (push-mark)                 ;Needed for sc-cite-original
+                  (goto-char (point-min))     ;Needed for sc-cite-original
+                  (mh-insert-prefix-string mh-ins-buf-prefix)
+                  (when (or (eq 'attribution mh-yank-behavior)
+                            (eq 'autoattrib mh-yank-behavior))
+                    (insert from-attr)
+                    (mh-identity-insert-attribution-verb nil)
+                    (insert "\n\n"))
+                  ;; If the user has selected a region, he has already "edited" the
+                  ;; text, so leave the cursor at the end of the yanked text. In
+                  ;; either case, leave a mark at the opposite end of the included
+                  ;; text to make it easy to jump or delete to the other end of the
+                  ;; text.
+                  (push-mark)
+                  (goto-char (point-max))
+                  (if (null yank-region)
+                      (mh-exchange-point-and-mark-preserving-active-mark)))))))
+      (error "There is no current message"))))

 
 \f
 
 
 \f
 


@@ -862,15 +886,13 @@ downcasing the field name."
 
 (defun mh-folder-expand-at-point ()
   "Do folder name completion in Fcc header field."
 
 (defun mh-folder-expand-at-point ()
   "Do folder name completion in Fcc header field."

-  (let* ((end (point))
-         (beg (mh-beginning-of-word))
-         (folder (buffer-substring-no-properties beg end))
-         (leading-plus (and (> (length folder) 0) (equal (aref folder 0) ?+)))
-         (choices (mapcar (lambda (x) (list x))
-                          (mh-folder-completion-function folder nil t))))
-    (unless leading-plus
-      (setq folder (concat "+" folder)))
-    (mh-complete-word folder choices beg end)))
+  (let* ((beg (mh-beginning-of-word))
+         (end (save-excursion
+                (goto-char beg)
+                (mh-beginning-of-word -1))))
+    (when (>= end (point))
+      (list beg (if (fboundp 'completion-at-point) end (point))
+            #'mh-folder-completion-function))))

 
 ;;;###mh-autoload
 (defun mh-complete-word (word choices begin end)
 
 ;;;###mh-autoload
 (defun mh-complete-word (word choices begin end)


@@ -889,8 +911,16 @@ Any match found replaces the text from BEGIN to END."
           ((stringp completion)
            (if (equal word completion)
                (with-output-to-temp-buffer completions-buffer
           ((stringp completion)
            (if (equal word completion)
                (with-output-to-temp-buffer completions-buffer

-                 (mh-display-completion-list (all-completions word choices)
-                                             word))
+                 (mh-display-completion-list
+                  (all-completions word choices)
+                  ;; The `common-substring' arg only works if it's a prefix.
+                  (unless (and (functionp choices)
+                               (let ((bounds
+                                      (funcall choices
+                                               word nil '(boundaries . ""))))
+                                 (and (eq 'boundaries (car-safe bounds))
+                                      (< 0 (cadr bounds)))))
+                    word)))

              (ignore-errors
                (kill-buffer completions-buffer))
              (delete-region begin end)
              (ignore-errors
                (kill-buffer completions-buffer))
              (delete-region begin end)