From: Gnus developers Date: Wed, 6 Apr 2011 22:08:31 +0000 (+0000) Subject: Merge changes made in Gnus trunk. X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~380 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=2237da9c046e02caa87e3b3bd80fb207020a057a;p=emacs.git Merge changes made in Gnus trunk. registry.el, gnus-registry.el: Use `ignore-errors' instead of third argument NOERROR for `require', since XEmacs 21.4 does not support it. registry.el (initialize-instance): Change :after to :AFTER to be compatible with old EIEIO version in XEmacs. gnus-registry.el (gnus-registry-post-process-groups) (gnus-registry--split-fancy-with-parent-internal): Fix splitting bugs and provide better messaging. gnus-registry.el: Load ERT unconditionally anyway, discarding errors. registry.el: Load ERT unconditionally anyway, discarding errors. --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index b79a5de55e1..f6ce9f089ef 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,10 +1,39 @@ +2011-04-06 David Engster + + * registry.el, gnus-registry.el: Use `ignore-errors' instead of third + argument NOERROR for `require', since XEmacs 21.4 does not support it. + +2011-04-06 David Engster + + * registry.el (initialize-instance): Change :after to :AFTER to be + compatible with old EIEIO version in XEmacs. + +2011-04-06 Teodor Zlatanov + + * gnus-registry.el (gnus-registry-post-process-groups) + (gnus-registry--split-fancy-with-parent-internal): Fix splitting bugs + and provide better messaging. + +2011-04-06 David Engster + + * Makefile.in (fail-on-warning): New rule to compile with warnings as + errors. + + * dgnushack.el (dgnushack-compile-error-on-warn): New function to call + dgnushack-compile with error-on-warn enabled, and to signal an error if + clean compilation failed. + (dgnushack-compile): New argument 'error-on-warn'. If non-nil, compile + with `byte-compile-error-on-warn'. Return nil if errors occured. + 2011-04-06 Teodor Zlatanov - * gnus-registry.el: Don't use ERT if it's not available. + * gnus-registry.el: Don't use ERT if it's not available. Load it + unconditionally anyway, discarding errors. (gnus-registry-delete-entries): New convenience function. (gnus-registry-import-eld): Import from old .eld registry. - * registry.el: Don't use ERT if it's not available. + * registry.el: Don't use ERT if it's not available. Load it + unconditionally anyway, discarding errors. * proto-stream.el (gnutls-negotiate): Revert inadvertent commit of the version from the Claudio Bley GnuTLS patch (extra optional parameters diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 511012df577..5145f01d635 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -58,9 +58,11 @@ (eval-when-compile (require 'cl)) (eval-when-compile - (when (null (require 'ert nil t)) + (when (null (ignore-errors (require 'ert))) (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) +(ignore-errors + (require 'ert)) (require 'gnus) (require 'gnus-int) (require 'gnus-sum) @@ -394,85 +396,83 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." &allow-other-keys) (gnus-message 10 - "gnus-registry--split-fancy-with-parent-internal: %S" spec) + "gnus-registry--split-fancy-with-parent-internal %S" spec) (let ((db gnus-registry-db) found) - ;; this is a big if-else statement. it uses + ;; this is a big chain of statements. it uses ;; gnus-registry-post-process-groups to filter the results after ;; every step. - (cond - ;; the references string must be valid and parse to valid references - (references + ;; the references string must be valid and parse to valid references + (when references + (gnus-message + 9 + "%s is tracing references %s" + log-agent refstr) (dolist (reference (nreverse references)) - (gnus-message - 9 - "%s is looking for matches for reference %s from [%s]" - log-agent reference refstr) - (setq found - (loop for group in (gnus-registry-get-id-key reference 'group) - when (gnus-registry-follow-group-p group) - do (gnus-message - 7 - "%s traced the reference %s from [%s] to group %s" - log-agent reference refstr group) - collect group))) + (gnus-message 9 "%s is looking up %s" log-agent reference) + (loop for group in (gnus-registry-get-id-key reference 'group) + when (gnus-registry-follow-group-p group) + do (gnus-message 7 "%s traced %s to %s" log-agent reference group) + do (push group found))) ;; filter the found groups and return them ;; the found groups are the full groups (setq found (gnus-registry-post-process-groups "references" refstr found))) ;; else: there were no matches, try the extra tracking by sender - ((and (memq 'sender gnus-registry-track-extra) - sender - (gnus-grep-in-list - sender - gnus-registry-unfollowed-addresses)) - (let ((groups (apply - 'append - (mapcar - (lambda (reference) - (gnus-registry-get-id-key reference 'group)) - (registry-lookup-secondary-value db 'sender sender))))) - (setq found - (loop for group in groups - when (gnus-registry-follow-group-p group) - do (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 7 9) - "%s (extra tracking) traced sender '%s' to groups %s" - log-agent sender found) - collect group))) - - ;; filter the found groups and return them - ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups - "sender" sender found))) + (when (and (null found) + (memq 'sender gnus-registry-track-extra) + sender + (gnus-grep-in-list + sender + gnus-registry-unfollowed-addresses)) + (let ((groups (apply + 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value db 'sender sender))))) + (setq found + (loop for group in groups + when (gnus-registry-follow-group-p group) + do (gnus-message + ;; warn more if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced sender '%s' to %s" + log-agent sender group) + collect group))) + + ;; filter the found groups and return them + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "sender" sender found))) ;; else: there were no matches, now try the extra tracking by subject - ((and (memq 'subject gnus-registry-track-extra) - subject - (< gnus-registry-minimum-subject-length (length subject))) - (let ((groups (apply - 'append - (mapcar - (lambda (reference) - (gnus-registry-get-id-key reference 'group)) - (registry-lookup-secondary-value db 'subject subject))))) - (setq found - (loop for group in groups - when (gnus-registry-follow-group-p group) - do (gnus-message - ;; raise level of messaging if gnus-registry-track-extra - (if gnus-registry-track-extra 7 9) - "%s (extra tracking) traced subject '%s' to groups %s" - log-agent subject found) - collect group)) - ;; filter the found groups and return them - ;; the found groups are NOT the full groups - (setq found (gnus-registry-post-process-groups - "subject" subject found))))) - ;; after the (cond) we extract the actual value safely - (car-safe found))) + (when (and (null found) + (memq 'subject gnus-registry-track-extra) + subject + (< gnus-registry-minimum-subject-length (length subject))) + (let ((groups (apply + 'append + (mapcar + (lambda (reference) + (gnus-registry-get-id-key reference 'group)) + (registry-lookup-secondary-value db 'subject subject))))) + (setq found + (loop for group in groups + when (gnus-registry-follow-group-p group) + do (gnus-message + ;; warn more if gnus-registry-track-extra + (if gnus-registry-track-extra 7 9) + "%s (extra tracking) traced subject '%s' to %s" + log-agent subject group) + collect group)) + ;; filter the found groups and return them + ;; the found groups are NOT the full groups + (setq found (gnus-registry-post-process-groups + "subject" subject found)))) + ;; after the (cond) we extract the actual value safely + (car-safe found))) (defun gnus-registry-post-process-groups (mode key groups) "Inspects GROUPS found by MODE for KEY to determine which ones to follow. @@ -489,25 +489,48 @@ Foreign methods are not supported so they are rejected. Reduces the list to a single group, or complains if that's not possible. Uses `gnus-registry-split-strategy'." (let ((log-agent "gnus-registry-post-process-group") - out) - - ;; the strategy can be nil, in which case groups is nil - (setq groups + (desc (format "%d groups" (length groups))) + out chosen) + ;; the strategy can be nil, in which case chosen is nil + (setq chosen (case gnus-registry-split-strategy - ;; first strategy + ;; default, take only one-element lists into chosen + ((nil) + (and (= (length groups) 1) + (car-safe groups))) + ((first) - (and groups (list (car-safe groups)))) + (car-safe groups)) ((majority) (let ((freq (make-hash-table :size 256 :test 'equal))) - (mapc (lambda (x) (puthash x (1+ (gethash x freq 0)) freq)) + (mapc (lambda (x) (let ((x (gnus-group-short-name x))) + (puthash x (1+ (gethash x freq 0)) freq))) groups) - (list (car-safe - (sort groups (lambda (a b) - (> (gethash a freq 0) - (gethash b freq 0)))))))))) + (setq desc (format "%d groups, %d unique" + (length groups) + (hash-table-count freq))) + (car-safe + (sort groups + (lambda (a b) + (> (gethash (gnus-group-short-name a) freq 0) + (gethash (gnus-group-short-name b) freq 0))))))))) + + (if chosen + (gnus-message + 9 + "%s: strategy %s on %s produced %s" + log-agent gnus-registry-split-strategy desc chosen) + (gnus-message + 9 + "%s: strategy %s on %s did not produce an answer" + log-agent + (or gnus-registry-split-strategy "default") + desc)) + + (setq groups (and chosen (list chosen))) (dolist (group groups) (let ((m1 (gnus-find-method-for-group group)) @@ -517,18 +540,20 @@ possible. Uses `gnus-registry-split-strategy'." (if (gnus-methods-equal-p m1 m2) (progn ;; this is REALLY just for debugging - (gnus-message - 10 - "%s stripped group %s to %s" - log-agent group short-name) + (when (not (equal group short-name)) + (gnus-message + 10 + "%s: stripped group %s to %s" + log-agent group short-name)) (add-to-list 'out short-name)) ;; else... (gnus-message 7 - "%s ignored foreign group %s" + "%s: ignored foreign group %s" log-agent group)))) - ;; is there just one group? + (setq out (delq nil out)) + (cond ((= (length out) 1) out) ((null out) diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el index cc03b20662d..8fb7aab82fb 100644 --- a/lisp/gnus/registry.el +++ b/lisp/gnus/registry.el @@ -78,9 +78,12 @@ ;;; Code: (eval-when-compile - (when (null (require 'ert nil t)) + (when (null (ignore-errors (require 'ert))) (defmacro* ert-deftest (name () &body docstring-keys-and-body)))) +(ignore-errors + (require 'ert)) + (eval-when-compile (require 'cl)) (eval-and-compile (or (ignore-errors (progn @@ -128,7 +131,7 @@ :type hash-table :documentation "The data hashtable."))) -(defmethod initialize-instance :after ((this registry-db) slots) +(defmethod initialize-instance :AFTER ((this registry-db) slots) "Set value of data slot of THIS after initialization." (with-slots (data tracker) this (unless (member :data slots)