diff options
| -rw-r--r-- | lisp/mh-e/ChangeLog | 14 | ||||
| -rw-r--r-- | lisp/mh-e/mh-alias.el | 32 | ||||
| -rw-r--r-- | lisp/mh-e/mh-e.el | 2 | ||||
| -rw-r--r-- | lisp/mh-e/mh-letter.el | 82 | ||||
| -rw-r--r-- | lisp/mh-e/mh-utils.el | 28 | ||||
| -rw-r--r-- | lisp/minibuffer.el | 8 |
6 files changed, 111 insertions, 55 deletions
diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog index f8e94412836..5228dc86fa2 100644 --- a/lisp/mh-e/ChangeLog +++ b/lisp/mh-e/ChangeLog @@ -1,3 +1,17 @@ +2011-04-28 Stefan Monnier <monnier@iro.umontreal.ca> + + * mh-utils.el (mh-folder-completion-function): Make it work like + file-name completion, so partial-completion can do its job. + + * mh-letter.el (mh-letter-completion-at-point): New function, extracted + from mh-letter-complete + (mh-letter-mode, mh-letter-complete, mh-letter-complete-or-space): + Use it. + (mh-complete-word): Only use the common-substring arg when it works. + (mh-folder-expand-at-point): + * mh-alias.el (mh-alias-letter-expand-alias): Return data suitable for + completion-at-point-functions. + 2011-04-06 Juanma Barranquero <lekktu@gmail.com> * mh-funcs.el (mh-undo-folder): Accept and ignore arguments, diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 061a5b3dc94..449a8782d0c 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -296,16 +296,28 @@ Blind aliases or users from /etc/passwd are not expanded." (defun mh-alias-letter-expand-alias () "Expand mail alias before point." (mh-alias-reload-maybe) - (let* ((end (point)) - (begin (mh-beginning-of-word)) - (input (buffer-substring-no-properties begin end))) - (mh-complete-word input mh-alias-alist begin end) - (when mh-alias-expand-aliases-flag - (let* ((end (point)) - (expansion (mh-alias-expand (buffer-substring begin end)))) - (delete-region begin end) - (insert expansion))))) - + (let* ((begin (mh-beginning-of-word)) + (end (save-excursion + (goto-char begin) + (mh-beginning-of-word -1)))) + (when (>= end (point)) + (list + begin (if (fboundp 'completion-at-point) end (point)) + (if (not mh-alias-expand-aliases-flag) + mh-alias-alist + (lambda (string pred action) + (case action + ((nil) + (let ((res (try-completion string mh-alias-alist pred))) + (if (or (eq res t) + (and (stringp res) + (eq t (try-completion res mh-alias-alist pred)))) + (or (mh-alias-expand (if (stringp res) res string)) + res) + res))) + ((t) (all-completions string mh-alias-alist pred)) + ((lambda) (if (fboundp 'test-completion) + (test-completion string mh-alias-alist pred)))))))))) ;;; Alias File Updating diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index e9896eb4b8c..ccae063827f 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -1179,7 +1179,7 @@ lowercase for mailing lists and uppercase for people." "*Non-nil means to expand aliases entered in the minibuffer. In other words, aliases entered in the minibuffer will be -expanded to the full address in the message draft. By default, +expanded to the full address in the message draft. By default, this expansion is not performed." :type 'boolean :group 'mh-alias diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index eebc30aa4ca..2ced886c05e 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -185,7 +185,7 @@ semi-obsolete and is only used if `mail-citation-hook' is nil.") "\C-c\C-w" mh-check-whom "\C-c\C-y" mh-yank-cur-msg "\C-c\M-d" mh-insert-auto-fields - "\M-\t" mh-letter-complete + "\M-\t" mh-letter-complete ;; FIXME: completion-at-point "\t" mh-letter-next-header-field-or-indent [backtab] mh-letter-previous-header-field) @@ -346,6 +346,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) + (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) @@ -488,24 +490,38 @@ In a program, you can pass in a signature FILE." (message "No signature found"))))) (force-mode-line-update)) -(defun mh-letter-complete (arg) - "Perform completion on header field or word preceding point. +(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))) + +(defalias 'mh-letter-complete + (if (fboundp 'completion-at-point) #'completion-at-point + (lambda () + "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. @@ -521,11 +537,12 @@ one space." (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)) - ((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 () @@ -862,18 +879,17 @@ downcasing the field name." (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) + ;; FIXME: Only needed when completion-at-point doesn't exist. "Complete WORD from CHOICES. Any match found replaces the text from BEGIN to END." (let ((completion (try-completion word choices)) @@ -889,8 +905,16 @@ Any match found replaces the text from BEGIN to END." ((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-subtring' 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) diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index d7d3107b908..4394e1b1b22 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -596,6 +596,7 @@ Expects FOLDER to have already been normalized with (setq name (substring name 0 (1- (length name))))) (push (cons name + ;; FIXME: what is this used for? --Stef (search-forward "(others)" (mh-line-end-position) t)) results)))) (forward-line 1)))) @@ -702,32 +703,33 @@ See Info node `(elisp) Programmed Completion' for details." (remainder (cond (last-complete (substring name (1+ last-slash))) (name (substring name 1)) (t "")))) - (cond ((eq flag nil) + (cond ((eq (car-safe flag) 'boundaries) + (list* 'boundaries + (let ((slash (mh-search-from-end ?/ orig-name))) + (if slash (1+ slash) + (if (string-match "\\`\\+" orig-name) 1 0))) + (if (cdr flag) (string-match "/" (cdr flag))))) + ((eq flag nil) (let ((try-res (try-completion - name - (mapcar (lambda (x) - (cons (concat (or last-complete "+") (car x)) - (cdr x))) - (mh-sub-folders last-complete t)) + remainder + (mh-sub-folders last-complete t) predicate))) (cond ((eq try-res nil) nil) ((and (eq try-res t) (equal name orig-name)) t) ((eq try-res t) name) - (t try-res)))) + (t (concat (or last-complete "+") try-res))))) ((eq flag t) - (mapcar (lambda (x) - (concat (or last-complete "+") x)) - (all-completions - remainder (mh-sub-folders last-complete t) predicate))) + (all-completions + remainder (mh-sub-folders last-complete t) predicate)) ((eq flag 'lambda) (let ((path (concat (unless (and (> (length name) 1) (eq (aref name 1) ?/)) mh-user-path) (substring name 1)))) - (cond (mh-allow-root-folder-flag (file-exists-p path)) + (cond (mh-allow-root-folder-flag (file-directory-p path)) ((equal path mh-user-path) nil) - (t (file-exists-p path)))))))) + (t (file-directory-p path)))))))) ;; Shush compiler. (defvar completion-root-regexp) ; XEmacs diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 4bf06a45238..7bd256afc79 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1377,6 +1377,10 @@ Currently supported properties are: "List of well-behaved functions found on `completion-at-point-functions'.") (defun completion--capf-wrapper (fun which) + ;; FIXME: The safe/misbehave handling assumes that a given function will + ;; always return the same kind of data, but this breaks down with functions + ;; like comint-completion-at-point or mh-letter-completion-at-point, which + ;; could be sometimes safe and sometimes misbehaving (and sometimes neither). (if (case which (all t) (safe (member fun completion--capf-safe-funs)) @@ -1408,7 +1412,7 @@ The completion method is determined by `completion-at-point-functions'." (completion-in-region-mode-predicate (lambda () ;; We're still in the same completion field. - (eq (car (funcall hookfun)) start)))) + (eq (car-safe (funcall hookfun)) start)))) (completion-in-region start end collection (plist-get plist :predicate)))) ;; Maybe completion already happened and the function returned t. @@ -1433,7 +1437,7 @@ The completion method is determined by `completion-at-point-functions'." (completion-in-region-mode-predicate (lambda () ;; We're still in the same completion field. - (eq (car (funcall hookfun)) start))) + (eq (car-safe (funcall hookfun)) start))) (ol (make-overlay start end nil nil t))) ;; FIXME: We should somehow (ab)use completion-in-region-function or ;; introduce a corresponding hook (plus another for word-completion, |