upstream

8 files changed, 181 insertions, 62 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index e86bc7f0a96..00a105b5142 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,25 @@
+2013-03-27  Eli Zaretskii  <eliz@gnu.org>
+
+        * facemenu.el (list-colors-callback): New defvar.
+        (list-colors-redisplay): New function.
+        (list-colors-display): Install list-colors-redisplay as the
+        revert-buffer-function.  (Bug#14063)
+
+2013-03-27  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * minibuffer.el (completion-pcm--merge-completions): Make sure prefixes
+        and suffixes don't overlap (bug#14061).
+
+        * case-table.el: Use lexical-binding.
+        (case-table-get-table): New function.
+        (get-upcase-table): Use it.  Mark as obsolete.  Adjust callers.
+
+2013-03-27  Teodor Zlatanov  <tzz@lifelogs.com>
+
+        * progmodes/subword.el: Add `superword-mode' to do word motion
+        over symbol_words (parallels and leverages `subword-mode' which
+        does word motion inside MixedCaseWords).
+
 2013-03-26  Stefan Monnier  <monnier@iro.umontreal.ca>
 
         * desktop.el (desktop--v2s): Rename from desktop-internal-v2s.
diff --git a/lisp/case-table.el b/lisp/case-table.el
index 711d4e4ec8c..7d4aa27de1c 100644
--- a/lisp/case-table.el
+++ b/lisp/case-table.el
@@ -1,4 +1,4 @@
-;;; case-table.el --- code to extend the character set and support case tables
+;;; case-table.el --- code to extend the character set and support case tables  -*- lexical-binding: t -*-
 
 ;; Copyright (C) 1988, 1994, 2001-2013 Free Software Foundation, Inc.
 
@@ -65,18 +65,26 @@
        (describe-vector description)
        (help-mode)))))
 
+(defun case-table-get-table (case-table table)
+  "Return the TABLE of CASE-TABLE.
+TABLE can be `down', `up', `eqv' or `canon'."
+  (let ((slot-nb (cdr (assq table '((up . 0) (canon . 1) (eqv . 2))))))
+    (or (if (eq table 'down) case-table)
+        (char-table-extra-slot case-table slot-nb)
+        ;; Setup all extra slots of CASE-TABLE by temporarily selecting
+        ;; it as the standard case table.
+        (let ((old (standard-case-table)))
+          (unwind-protect
+              (progn
+                (set-standard-case-table case-table)
+                (char-table-extra-slot case-table slot-nb))
+            (or (eq case-table old)
+                (set-standard-case-table old)))))))
+
 (defun get-upcase-table (case-table)
   "Return the upcase table of CASE-TABLE."
-  (or (char-table-extra-slot case-table 0)
-      ;; Setup all extra slots of CASE-TABLE by temporarily selecting
-      ;; it as the standard case table.
-      (let ((old (standard-case-table)))
-        (unwind-protect
-            (progn
-              (set-standard-case-table case-table)
-              (char-table-extra-slot case-table 0))
-          (or (eq case-table old)
-              (set-standard-case-table old))))))
+  (case-table-get-table case-table 'up))
+(make-obsolete 'get-upcase-table 'case-table-get-table "24.4")
 
 (defun copy-case-table (case-table)
   (let ((copy (copy-sequence case-table))
@@ -97,7 +105,7 @@ It also modifies `standard-syntax-table' to
 indicate left and right delimiters."
   (aset table l l)
   (aset table r r)
-  (let ((up (get-upcase-table table)))
+  (let ((up (case-table-get-table table 'up)))
     (aset up l l)
     (aset up r r))
   ;; Clear out the extra slots so that they will be
@@ -117,7 +125,7 @@ It also modifies `standard-syntax-table' to give them the syntax of
 word constituents."
   (aset table uc lc)
   (aset table lc lc)
-  (let ((up (get-upcase-table table)))
+  (let ((up (case-table-get-table table 'up)))
     (aset up uc uc)
     (aset up lc uc))
   ;; Clear out the extra slots so that they will be
@@ -132,7 +140,7 @@ word constituents."
 It also modifies `standard-syntax-table' to give them the syntax of
 word constituents."
   (aset table lc lc)
-  (let ((up (get-upcase-table table)))
+  (let ((up (case-table-get-table table 'up)))
     (aset up uc uc)
     (aset up lc uc))
   ;; Clear out the extra slots so that they will be
@@ -148,7 +156,7 @@ It also modifies `standard-syntax-table' to give them the syntax of
 word constituents."
   (aset table uc lc)
   (aset table lc lc)
-  (let ((up (get-upcase-table table)))
+  (let ((up (case-table-get-table table 'up)))
     (aset up uc uc))
   ;; Clear out the extra slots so that they will be
   ;; recomputed from the main (downcase) table and upcase table.
@@ -164,7 +172,7 @@ that will be used as the downcase part of a case table.
 It also modifies `standard-syntax-table'.
 SYNTAX should be \" \", \"w\", \".\" or \"_\"."
   (aset table c c)
-  (let ((up (get-upcase-table table)))
+  (let ((up (case-table-get-table table 'up)))
     (aset up c c))
   ;; Clear out the extra slots so that they will be
   ;; recomputed from the main (downcase) table and upcase table.
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index e86c1c23d66..9a66edd28fc 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -513,12 +513,23 @@ filter out the color from the output."
          (* (nth 1 c-rgb) 0.7151522)
          (* (nth 2 c-rgb) 0.0721750))))))
 
+(defvar list-colors-callback nil
+  "Value of CALLBACK arg passed to `list-colors-display'; internal use.")
+
+(defun list-colors-redisplay (_ignore-auto _noconfirm)
+  "Redisplay the colors using `list-colors-sort'.
+
+This is installed as a `revert-buffer-function' in the *Colors* buffer."
+  (list-colors-display nil (buffer-name) list-colors-callback))
+
 (defun list-colors-display (&optional list buffer-name callback)
   "Display names of defined colors, and show what they look like.
 If the optional argument LIST is non-nil, it should be a list of
 colors to display.  Otherwise, this command computes a list of
 colors that the current display can handle.  Customize
 `list-colors-sort' to change the order in which colors are shown.
+Type `g' or \\[revert-buffer] after customizing `list-colors-sort'
+to redisplay colors in the new order.
 
 If the optional argument BUFFER-NAME is nil, it defaults to *Colors*.
 
@@ -566,7 +577,9 @@ color.  The function should accept a single argument, the color name."
       (erase-buffer)
       (list-colors-print list callback)
       (set-buffer-modified-p nil)
-      (setq truncate-lines t)))
+      (setq truncate-lines t)
+      (setq-local list-colors-callback callback)
+      (setq revert-buffer-function 'list-colors-redisplay)))
   (when callback
     (pop-to-buffer buffer-name)
     (message "Click on a color to select it.")))
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index 9fffc4f1a45..cbfb0109aec 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,12 @@
+2013-03-27  Andrew Cohen  <cohen@bu.edu>
+
+        * gnus-msg.el (gnus-setup-message): When replying from an nnir summary
+        buffer use the posting-style and gcc of the original article group.
+        (gnus-inews-insert-gcc): Don't set gcc-self for virtual groups.
+
+        * nnir.el: Fix byte-compile warning. nnoo-define-skeleton should come
+        after other deffoos.
+
 2013-03-26  Andrew Cohen  <cohen@bu.edu>
 
         * nnir.el: Major rewrite. Cleaner separation between searches and group
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index f7b2d8b99d9..067465b0e6f 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -426,15 +426,24 @@ Thank you for your help in stamping out bugs.
     `(let ((,winconf (current-window-configuration))
            (,winconf-name gnus-current-window-configuration)
            (,buffer (buffer-name (current-buffer)))
-           (,article gnus-article-reply)
+           (,article (or  (when (and
+                                 (string-match "^nnir:" gnus-newsgroup-name)
+                                 gnus-article-reply)
+                            (nnir-article-number gnus-article-reply))
+                           gnus-article-reply))
            (,yanked gnus-article-yanked-articles)
-           (,group gnus-newsgroup-name)
+           (,group (or (when (and
+                              (string-match "^nnir:" gnus-newsgroup-name)
+                              gnus-article-reply)
+                         (nnir-article-group gnus-article-reply))
+                       gnus-newsgroup-name))
            (message-header-setup-hook
             (copy-sequence message-header-setup-hook))
            (mbl mml-buffer-list)
            (message-mode-hook (copy-sequence message-mode-hook)))
        (setq mml-buffer-list nil)
-       (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
+       (add-hook 'message-header-setup-hook (lambda ()
+                                              (gnus-inews-insert-gcc ,group)))
        ;; message-newsreader and message-mailer were formerly set in
        ;; gnus-inews-add-send-actions, but this is too late when
        ;; message-generate-headers-first is used. --ansel
@@ -1706,7 +1715,8 @@ this is a reply."
          (group (when group (gnus-group-decoded-name group)))
          (var (or gnus-outgoing-message-group gnus-message-archive-group))
          (gcc-self-val
-          (and group (gnus-group-find-parameter group 'gcc-self)))
+          (and group (gnus-group-find-parameter group 'gcc-self)
+               (not (gnus-virtual-group-p group))))
          result
          (groups
           (cond
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el
index cabd08b0653..a48c6043e82 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -886,7 +886,7 @@ skips all prompting."
 ;;  (car (assoc  '(nnir "nnir-ephemeral" (nnir-address "nnir"))
 ;;              gnus-opened-servers))))
 
-(nnoo-define-skeleton nnir)
+
 
 
 (defmacro nnir-add-result (dirnam artno score prefix server artlist)
@@ -1880,6 +1880,11 @@ article came from is also searched."
         (nnir-request-update-info pgroup (gnus-get-info pgroup)))
     t))
 
+(deffoo nnir-request-close ()
+  t)
+
+
+(nnoo-define-skeleton nnir)
 
 ;; The end.
 (provide 'nnir)
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index ec237f0f664..016b16d0740 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -2997,12 +2997,21 @@ the same set of elements."
                 ;; here any more.
                 (unless unique
                   (push elem res)
-                  (when (memq elem '(star point prefix))
-                    ;; Extract common suffix additionally to common prefix.
-                    ;; Only do it for `point', `star', and `prefix' since for
-                    ;; `any' it could lead to a merged completion that
-                    ;; doesn't itself match the candidates.
-                    (let ((suffix (completion--common-suffix comps)))
+                  ;; Extract common suffix additionally to common prefix.
+                  ;; Don't do it for `any' since it could lead to a merged
+                  ;; completion that doesn't itself match the candidates.
+                  (when (and (memq elem '(star point prefix))
+                             ;; If prefix is one of the completions, there's no
+                             ;; suffix left to find.
+                             (not (assoc-string prefix comps t)))
+                    (let ((suffix
+                           (completion--common-suffix
+                            (if (zerop (length prefix)) comps
+                              ;; Ignore the chars in the common prefix, so we
+                              ;; don't merge '("abc" "abbc") as "ab*bc".
+                              (let ((skip (length prefix)))
+                                (mapcar (lambda (str) (substring str skip))
+                                        comps))))))
                       (cl-assert (stringp suffix))
                       (unless (equal suffix "")
                         (push suffix res)))))
diff --git a/lisp/progmodes/subword.el b/lisp/progmodes/subword.el
index 80e632c6ef6..24abfa8a053 100644
--- a/lisp/progmodes/subword.el
+++ b/lisp/progmodes/subword.el
@@ -26,7 +26,8 @@
 
 ;; This package provides `subword' oriented commands and a minor mode
 ;; (`subword-mode') that substitutes the common word handling
-;; functions with them.
+;; functions with them.  It also provides the `superword-mode' minor
+;; mode that treats symbols as words, the opposite of `subword-mode'.
 
 ;; In spite of GNU Coding Standards, it is popular to name a symbol by
 ;; mixing uppercase and lowercase letters, e.g. "GtkWidget",
@@ -43,12 +44,13 @@
 
 ;; The subword oriented commands defined in this package recognize
 ;; subwords in a nomenclature to move between them and to edit them as
-;; words.
+;; words.  You also get a mode to treat symbols as words instead,
+;; called `superword-mode' (the opposite of `subword-mode').
 
 ;; In the minor mode, all common key bindings for word oriented
 ;; commands are overridden by the subword oriented commands:
 
-;; Key     Word oriented command      Subword oriented command
+;; Key     Word oriented command      Subword oriented command (also superword)
 ;; ============================================================
 ;; M-f     `forward-word'             `subword-forward'
 ;; M-b     `backward-word'            `subword-backward'
@@ -67,8 +69,13 @@
 ;; To make the mode turn on automatically, put the following code in
 ;; your .emacs:
 ;;
-;; (add-hook 'c-mode-common-hook
-;;        (lambda () (subword-mode 1)))
+;; (add-hook 'c-mode-common-hook 'subword-mode)
+;;
+
+;; To make the mode turn `superword-mode' on automatically for
+;; only some modes, put the following code in your .emacs:
+;;
+;; (add-hook 'c-mode-common-hook 'superword-mode)
 ;;
 
 ;; Acknowledgment:
@@ -98,7 +105,8 @@
   (let ((map (make-sparse-keymap)))
     (dolist (cmd '(forward-word backward-word mark-word kill-word
                                 backward-kill-word transpose-words
-                                capitalize-word upcase-word downcase-word))
+                                capitalize-word upcase-word downcase-word
+                                left-word right-word))
       (let ((othercmd (let ((name (symbol-name cmd)))
                         (string-match "\\([[:alpha:]-]+\\)-word[s]?" name)
                         (intern (concat "subword-" (match-string 1 name))))))
@@ -133,9 +141,8 @@ subwords in a nomenclature to move between subwords and to edit them
 as words.
 
 \\{subword-mode-map}"
-    nil
-    nil
-    subword-mode-map)
+    :lighter " ,"
+    (when subword-mode (superword-mode -1)))
 
 (define-obsolete-function-alias 'c-subword-mode 'subword-mode "23.2")
 
@@ -161,6 +168,8 @@ Optional argument ARG is the same as for `forward-word'."
 
 (put 'subword-forward 'CUA 'move)
 
+(defalias 'subword-right 'subword-forward)
+
 (defun subword-backward (&optional arg)
   "Do the same as `backward-word' but on subwords.
 See the command `subword-mode' for a description of subwords.
@@ -168,6 +177,8 @@ Optional argument ARG is the same as for `backward-word'."
   (interactive "p")
   (subword-forward (- (or arg 1))))
 
+(defalias 'subword-left 'subword-backward)
+
 (defun subword-mark (arg)
   "Do the same as `mark-word' but on subwords.
 See the command `subword-mode' for a description of subwords.
@@ -254,41 +265,73 @@ Optional argument ARG is the same as for `capitalize-word'."
     (unless advance
       (goto-char start))))
 
+
+
+(defvar superword-mode-map subword-mode-map
+  "Keymap used in `superword-mode' minor mode.")
+
+;;;###autoload
+(define-minor-mode superword-mode
+  "Toggle superword movement and editing (Superword mode).
+With a prefix argument ARG, enable Superword mode if ARG is
+positive, and disable it otherwise.  If called from Lisp, enable
+the mode if ARG is omitted or nil.
+
+Superword mode is a buffer-local minor mode.  Enabling it remaps
+word-based editing commands to superword-based commands that
+treat symbols as words, e.g. \"this_is_a_symbol\".
+
+The superword oriented commands activated in this minor mode
+recognize symbols as superwords to move between superwords and to
+edit them as words.
+
+\\{superword-mode-map}"
+    :lighter " ²"
+    (when superword-mode (subword-mode -1)))
+
+;;;###autoload
+(define-global-minor-mode global-superword-mode superword-mode
+  (lambda () (superword-mode 1)))
 
 
 ;;
 ;; Internal functions
 ;;
 (defun subword-forward-internal ()
-  (if (and
-       (save-excursion
-         (let ((case-fold-search nil))
-           (re-search-forward subword-forward-regexp nil t)))
-       (> (match-end 0) (point)))
-      (goto-char
-       (cond
-        ((< 1 (- (match-end 2) (match-beginning 2)))
-         (1- (match-end 2)))
-        (t
-         (match-end 0))))
-    (forward-word 1)))
-
+  (if superword-mode
+      (forward-symbol 1)
+    (if (and
+         (save-excursion
+           (let ((case-fold-search nil))
+             (re-search-forward subword-forward-regexp nil t)))
+         (> (match-end 0) (point)))
+        (goto-char
+         (cond
+          ((< 1 (- (match-end 2) (match-beginning 2)))
+           (1- (match-end 2)))
+          (t
+           (match-end 0))))
+      (forward-word 1))))
 
 (defun subword-backward-internal ()
-  (if (save-excursion
-        (let ((case-fold-search nil))
-          (re-search-backward subword-backward-regexp nil t)))
-      (goto-char
-       (cond
-        ((and (match-end 3)
-              (< 1 (- (match-end 3) (match-beginning 3)))
-              (not (eq (point) (match-end 3))))
-         (1- (match-end 3)))
-        (t
-         (1+ (match-beginning 0)))))
-    (backward-word 1)))
+  (if superword-mode
+      (forward-symbol -1)
+    (if (save-excursion
+          (let ((case-fold-search nil))
+            (re-search-backward subword-backward-regexp nil t)))
+        (goto-char
+         (cond
+          ((and (match-end 3)
+                (< 1 (- (match-end 3) (match-beginning 3)))
+                (not (eq (point) (match-end 3))))
+           (1- (match-end 3)))
+          (t
+           (1+ (match-beginning 0)))))
+      (backward-word 1))))
 
 
+
 (provide 'subword)
+(provide 'superword)
 
 ;;; subword.el ends here