* lisp/gnus/gnus-win.el (gnus-configure-frame): Don't signal an error when

jumping to *Server* from a dedicated *Group* window.
(gnus-configure-frame): CSE.
* lisp/gnus/gnus-registry.el: Minor style cleanup.
(gnus-registry--set/remove-mark): New function, extracted from
gnus-registry-install-shortcuts.
(gnus-registry-install-shortcuts): Use it.

diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index c917e81a175957f0799ba8a1834ab6baca58926f..1c5984e96cdc626665f77bad2fb878a2f3c4b87d 100644 (file)
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,14 @@
+2012-05-25  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+       * gnus-win.el (gnus-configure-frame): Don't signal an error when
+       jumping to *Server* from a dedicated *Group* window.
+       (gnus-configure-frame): CSE.
+
+       * gnus-registry.el: Minor style cleanup.
+       (gnus-registry--set/remove-mark): New function, extracted from
+       gnus-registry-install-shortcuts.
+       (gnus-registry-install-shortcuts): Use it.
+
 2012-05-25  Katsumi Yamaoka  <yamaoka@jpl.org>
 
        * nnspool.el (news-path): Use eval-and-compile.

diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el
index f1618b376ef57da84407cd82c31fabf9616496b6..53690f041691eb3f27ee290bbe7294d29fe8db33 100644 (file)
--- a/lisp/gnus/gnus-registry.el
+++ b/lisp/gnus/gnus-registry.el
@@ -96,7 +96,7 @@
 (defvar gnus-adaptive-word-syntax-table)
 
 (defvar gnus-registry-dirty t
- "Boolean set to t when the registry is modified")
+ "Boolean set to t when the registry is modified.")
 
 (defgroup gnus-registry nil
   "The Gnus registry."
@@ -284,7 +284,7 @@ the Bit Bucket."
     :tracked nil)))
 
 (defvar gnus-registry-db (gnus-registry-make-db)
-  "*The article registry by Message ID.  See `registry-db'")
+  "The article registry by Message ID.  See `registry-db'.")
 
 ;; top-level registry data management
 (defun gnus-registry-remake-db (&optional forsure)
@@ -418,9 +418,9 @@ This is not required after changing `gnus-registry-cache-file'."
 ;; Function for nn{mail|imap}-split-fancy: look up all references in
 ;; the cache and if a match is found, return that group.
 (defun gnus-registry-split-fancy-with-parent ()
-  "Split this message into the same group as its parent.  The parent
-is obtained from the registry.  This function can be used as an entry
-in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
+  "Split this message into the same group as its parent.
+The parent is obtained from the registry.  This function can be used as an
+entry in `nnmail-split-fancy' or `nnimap-split-fancy', for example like
 this: (: gnus-registry-split-fancy-with-parent)
 
 This function tracks ALL backends, unlike
@@ -746,7 +746,7 @@ Overrides existing keywords with FORCE set non-nil."
   (registry-lookup-secondary-value gnus-registry-db 'keyword keyword))
 
 (defun gnus-registry-register-message-ids ()
-  "Register the Message-ID of every article in the group"
+  "Register the Message-ID of every article in the group."
   (unless (gnus-parameter-registry-ignore gnus-newsgroup-name)
     (dolist (article gnus-newsgroup-articles)
       (let* ((id (gnus-registry-fetch-message-id-fast article))
@@ -761,7 +761,7 @@ Overrides existing keywords with FORCE set non-nil."
 
 ;; message field fetchers
 (defun gnus-registry-fetch-message-id-fast (article)
-  "Fetch the Message-ID quickly, using the internal gnus-data-list function"
+  "Fetch the Message-ID quickly, using the internal gnus-data-list function."
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (mail-header-id (gnus-data-header (assoc article (gnus-data-list nil))))
@@ -793,7 +793,7 @@ Addresses without a name will say \"noname\"."
     nil))
 
 (defun gnus-registry-fetch-simplified-message-subject-fast (article)
-  "Fetch the Subject quickly, using the internal gnus-data-list function"
+  "Fetch the Subject quickly, using the internal gnus-data-list function."
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (gnus-string-remove-all-properties
@@ -811,7 +811,7 @@ Addresses without a name will say \"noname\"."
    (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) "")))
 
 (defun gnus-registry-fetch-header-fast (article header)
-  "Fetch the HEADER quickly, using the internal gnus-data-list function"
+  "Fetch the HEADER quickly, using the internal gnus-data-list function."
   (if (and (numberp article)
            (assoc article (gnus-data-list nil)))
       (gnus-string-remove-all-properties
@@ -831,7 +831,34 @@ FUNCTION should take two parameters, a mark symbol and the cell value."
       (when cell-data
         (funcall function mark cell-data)))))
 
-;;; this is ugly code, but I don't know how to do it better
+;; FIXME: Why not merge gnus-registry--set/remove-mark and
+;; gnus-registry-set-article-mark-internal?
+(defun gnus-registry--set/remove-mark (remove mark articles)
+  "Set/remove the MARK over process-marked ARTICLES."
+  ;; If this is called and the user doesn't want the
+  ;; registry enabled, we'll ask anyhow.
+  (unless gnus-registry-install
+    (let ((gnus-registry-install 'ask))
+      (gnus-registry-install-p)))
+
+  ;; Now the user is asked if gnus-registry-install is `ask'.
+  (when (gnus-registry-install-p)
+    (gnus-registry-set-article-mark-internal
+     ;; All this just to get the mark, I must be doing it wrong.
+     mark articles remove t)
+    ;; FIXME: Why do we do the above only here and not directly inside
+    ;; gnus-registry-set-article-mark-internal?  I.e. we wouldn't we want to do
+    ;; the things below when gnus-registry-set-article-mark-internal is called
+    ;; from gnus-registry-set-article-mark or
+    ;; gnus-registry-remove-article-mark?
+    (gnus-message 9 "Applying mark %s to %d articles"
+                  mark (length articles))
+    (dolist (article articles)
+      (gnus-summary-update-article
+       article
+       (assoc article (gnus-data-list nil))))))
+
+;; This is ugly code, but I don't know how to do it better.
 (defun gnus-registry-install-shortcuts ()
   "Install the keyboard shortcuts and menus for the registry.
 Uses `gnus-registry-marks' to find what shortcuts to install."
@@ -843,69 +870,41 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
        (let ((function-format
               (format "gnus-registry-%%s-article-%s-mark" mark)))
 
-;;; The following generates these functions:
-;;; (defun gnus-registry-set-article-Important-mark (&rest articles)
-;;;   "Apply the Important mark to process-marked ARTICLES."
-;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
-;;;   (gnus-registry-set-article-mark-internal 'Important articles nil t))
-;;; (defun gnus-registry-remove-article-Important-mark (&rest articles)
-;;;   "Apply the Important mark to process-marked ARTICLES."
-;;;   (interactive (gnus-summary-work-articles current-prefix-arg))
-;;;   (gnus-registry-set-article-mark-internal 'Important articles t t))
+;;;  The following generates these functions:
+;;;  (defun gnus-registry-set-article-Important-mark (&rest articles)
+;;;    "Apply the Important mark to process-marked ARTICLES."
+;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
+;;;    (gnus-registry-set-article-mark-internal 'Important articles nil t))
+;;;  (defun gnus-registry-remove-article-Important-mark (&rest articles)
+;;;    "Apply the Important mark to process-marked ARTICLES."
+;;;    (interactive (gnus-summary-work-articles current-prefix-arg))
+;;;    (gnus-registry-set-article-mark-internal 'Important articles t t))
 
          (dolist (remove '(t nil))
            (let* ((variant-name (if remove "remove" "set"))
-                  (function-name (format function-format variant-name))
-                  (shortcut (format "%c" data))
-                  (shortcut (if remove (upcase shortcut) shortcut)))
-             (unintern function-name obarray)
-             (eval
-              `(defun
-                 ;; function name
-                 ,(intern function-name)
-                 ;; parameter definition
-                 (&rest articles)
-                 ;; documentation
-                 ,(format
-                   "%s the %s mark over process-marked ARTICLES."
-                   (upcase-initials variant-name)
-                   mark)
-                 ;; interactive definition
-                 (interactive
-                  (gnus-summary-work-articles current-prefix-arg))
-                 ;; actual code
-
-                 ;; if this is called and the user doesn't want the
-                 ;; registry enabled, we'll ask anyhow
-                 (unless gnus-registry-install
-                   (let ((gnus-registry-install 'ask))
-                     (gnus-registry-install-p)))
-
-                 ;; now the user is asked if gnus-registry-install is 'ask
-                 (when (gnus-registry-install-p)
-                   (gnus-registry-set-article-mark-internal
-                    ;; all this just to get the mark, I must be doing it wrong
-                    (intern ,(symbol-name mark))
-                    articles ,remove t)
-                   (gnus-message
-                    9
-                    "Applying mark %s to %d articles"
-                    ,(symbol-name mark) (length articles))
-                   (dolist (article articles)
-                     (gnus-summary-update-article
-                      article
-                      (assoc article (gnus-data-list nil)))))))
-             (push (intern function-name) keys-plist)
+                  (function-name
+                   (intern (format function-format variant-name)))
+                  (shortcut (format "%c" (if remove (upcase data) data))))
+             (defalias function-name
+               ;; If it weren't for the function's docstring, we could
+               ;; use a closure, with lexical-let :-(
+               `(lambda (&rest articles)
+                  ,(format
+                    "%s the %s mark over process-marked ARTICLES."
+                    (upcase-initials variant-name)
+                    mark)
+                  (interactive
+                   (gnus-summary-work-articles current-prefix-arg))
+                  (gnus-registry--set/remove-mark ',mark ',remove articles)))
+             (push function-name keys-plist)
              (push shortcut keys-plist)
              (push (vector (format "%s %s"
                                    (upcase-initials variant-name)
                                    (symbol-name mark))
-                           (intern function-name) t)
+                           function-name t)
                    gnus-registry-misc-menus)
-             (gnus-message
-              9
-              "Defined mark handling function %s"
-              function-name))))))
+             (gnus-message 9 "Defined mark handling function %s"
+                           function-name))))))
     (gnus-define-keys-1
      '(gnus-registry-mark-map "M" gnus-summary-mark-map)
      keys-plist)
@@ -925,7 +924,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 ;; use like this:
 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars)
 (defun gnus-registry-article-marks-to-chars (headers)
-  "Show the marks for an article by the :char property"
+  "Show the marks for an article by the :char property."
   (let* ((id (mail-header-message-id headers))
          (marks (when id (gnus-registry-get-id-key id 'mark))))
     (mapconcat (lambda (mark)
@@ -938,7 +937,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install."
 ;; use like this:
 ;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names)
 (defun gnus-registry-article-marks-to-names (headers)
-  "Show the marks for an article by name"
+  "Show the marks for an article by name."
   (let* ((id (mail-header-message-id headers))
          (marks (when id (gnus-registry-get-id-key id 'mark))))
     (mapconcat (lambda (mark) (symbol-name mark)) marks ",")))
@@ -1153,13 +1152,14 @@ only the last one's marks are returned."
 
 ;;;###autoload
 (defun gnus-registry-initialize ()
-"Initialize the Gnus registry."
+  "Initialize the Gnus registry."
   (interactive)
   (gnus-message 5 "Initializing the registry")
   (gnus-registry-install-hooks)
   (gnus-registry-install-shortcuts)
   (gnus-registry-read))
 
+;; FIXME: Why autoload this function?
 ;;;###autoload
 (defun gnus-registry-install-hooks ()
   "Install the registry hooks."

diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index 579210c6138c2b6ceef7671580616b3256260fae..34c6c0ca1260954196c29e569e66476f83ff8a49 100644 (file)
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -239,7 +239,8 @@ See the Gnus manual for an explanation of the syntax used.")
 
 (defun gnus-configure-frame (split &optional window)
   "Split WINDOW according to SPLIT."
-  (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
+  (let* ((current-window (or (get-buffer-window (current-buffer))
+                             (selected-window)))
          (window (or window current-window)))
     (select-window window)
     ;; The SPLIT might be something that is to be evalled to
@@ -269,9 +270,21 @@ See the Gnus manual for an explanation of the syntax used.")
          (let ((buf (gnus-get-buffer-create
                      (gnus-window-to-buffer-helper buffer))))
            (when (buffer-name buf)
-             (if (eq buf (window-buffer (selected-window)))
-                 (set-buffer buf)
-               (switch-to-buffer buf))))
+             (cond
+               ((eq buf (window-buffer (selected-window)))
+                (set-buffer buf))
+               ((eq t (window-dedicated-p))
+                ;; If the window is hard-dedicated, we have a problem because
+                ;; we just can't do what we're asked.  But signalling an error,
+                ;; like `switch-to-buffer' would do, is not an option because
+                ;; it would prevent things like "^" (to jump to the *Servers*)
+                ;; in a dedicated *Group*.
+                ;; FIXME: Maybe a better/additional fix would be to change
+                ;; gnus-configure-windows so that when called
+                ;; from a hard-dedicated frame, it creates (and
+                ;; configures) a new frame, leaving the dedicated frame alone.
+                (pop-to-buffer buf))
+               (t (switch-to-buffer buf)))))
          (when (memq 'frame-focus split)
            (setq gnus-window-frame-focus window))
          ;; We return the window if it has the `point' spec.
@@ -340,9 +353,9 @@ See the Gnus manual for an explanation of the syntax used.")
          ;; fashion.
          (setq comp-subs (nreverse comp-subs))
          (while comp-subs
-           (if (null (cdr comp-subs))
-               (setq new-win window)
-             (setq new-win
+           (setq new-win
+                  (if (null (cdr comp-subs))
+                      window
                    (split-window window (cadar comp-subs)
                                  (eq type 'horizontal))))
            (setq result (or (gnus-configure-frame