From: Stefan Monnier Date: Fri, 25 May 2012 14:58:17 +0000 (-0400) Subject: * lisp/gnus/gnus-win.el (gnus-configure-frame): Don't signal an error when X-Git-Tag: emacs-24.2.90~471^2~6^2~110^2~2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=245101e5da68860cf5c9d366f1858c374ba8c46f;p=emacs.git * 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 c917e81a175..1c5984e96cd 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,14 @@ +2012-05-25 Stefan Monnier + + * 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 * nnspool.el (news-path): Use eval-and-compile. diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index f1618b376ef..53690f04169 100644 --- 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 579210c6138..34c6c0ca126 100644 --- 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