Merge from mainline.

9 files changed, 127 insertions, 65 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,
diff --git a/src/ChangeLog b/src/ChangeLog
index 40fb601e061..f9ca67e703d 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -23,6 +23,16 @@
 
         * fns.c (Frandom): Let EMACS_UINT be wider than unsigned long.
 
+2011-04-28  Eli Zaretskii  <eliz@gnu.org>
+
+        * doprnt.c (doprnt): Don't return value smaller than the buffer
+        size if the message was truncated.  (Bug#8545).
+
+2011-04-28  Juanma Barranquero  <lekktu@gmail.com>
+
+        * w32fns.c (Fx_change_window_property, Fx_delete_window_property)
+        (Fx_window_property): #if-0 the whole functions, not just the bodies.
+
 2011-04-27  Paul Eggert  <eggert@cs.ucla.edu>
 
         * doprnt.c (doprnt): Support "ll" length modifier, for long long.
diff --git a/src/doprnt.c b/src/doprnt.c
index a6becc7454f..63dba9f5850 100644
--- a/src/doprnt.c
+++ b/src/doprnt.c
@@ -403,7 +403,9 @@ doprnt (char *buffer, register size_t bufsize, const char *format,
         while (fmt < format_end && --bufsize > 0 && !CHAR_HEAD_P (*fmt));
         if (!CHAR_HEAD_P (*fmt))
           {
-            bufptr = save_bufptr;
+            /* Truncate, but return value that will signal to caller
+               that the buffer was too small.  */
+            *save_bufptr = 0;
             break;
           }
       }
diff --git a/src/w32fns.c b/src/w32fns.c
index 821cc671646..bdf9dce9411 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -4865,6 +4865,8 @@ If TERMINAL is omitted or nil, that stands for the selected frame's display.  */
                            Window properties
  ***********************************************************************/
 
+#if 0 /* TODO : port window properties to W32 */
+
 DEFUN ("x-change-window-property", Fx_change_window_property,
        Sx_change_window_property, 2, 6, 0,
        doc: /* Change window property PROP to VALUE on the X window of FRAME.
@@ -4884,7 +4886,6 @@ If OUTER_P is non-nil, the property is changed for the outer X window of
 FRAME.  Default is to change on the edit X window.  */)
   (Lisp_Object prop, Lisp_Object value, Lisp_Object frame, Lisp_Object type, Lisp_Object format, Lisp_Object outer_p)
 {
-#if 0 /* TODO : port window properties to W32 */
   struct frame *f = check_x_frame (frame);
   Atom prop_atom;
 
@@ -4901,8 +4902,6 @@ FRAME.  Default is to change on the edit X window.  */)
   XFlush (FRAME_W32_DISPLAY (f));
   UNBLOCK_INPUT;
 
-#endif /* TODO */
-
   return value;
 }
 
@@ -4913,8 +4912,6 @@ DEFUN ("x-delete-window-property", Fx_delete_window_property,
 FRAME nil or omitted means use the selected frame.  Value is PROP.  */)
   (Lisp_Object prop, Lisp_Object frame)
 {
-#if 0 /* TODO : port window properties to W32 */
-
   struct frame *f = check_x_frame (frame);
   Atom prop_atom;
 
@@ -4926,7 +4923,6 @@ FRAME nil or omitted means use the selected frame.  Value is PROP.  */)
   /* Make sure the property is removed when we return.  */
   XFlush (FRAME_W32_DISPLAY (f));
   UNBLOCK_INPUT;
-#endif  /* TODO */
 
   return prop;
 }
@@ -4951,8 +4947,6 @@ Value is nil if FRAME hasn't a property with name PROP or if PROP has
 no value of TYPE (always string in the MS Windows case).  */)
   (Lisp_Object prop, Lisp_Object frame)
 {
-#if 0 /* TODO : port window properties to W32 */
-
   struct frame *f = check_x_frame (frame);
   Atom prop_atom;
   int rc;
@@ -4992,10 +4986,10 @@ no value of TYPE (always string in the MS Windows case).  */)
 
   return prop_value;
 
-#endif /* TODO */
   return Qnil;
 }
 
+#endif /* TODO */
 
 
 /***********************************************************************