[Emacs-diffs] /srv/bzr/emacs/trunk r103856: Merge changes made in Gnus trunk.

[Katsumi Yamaoka]

------------------------------------------------------------
revno: 103856
author: Gnus developers <address@hidden>
committer: Katsumi Yamaoka <address@hidden>
branch nick: trunk
timestamp: Wed 2011-04-06 22:08:31 +0000
message:
  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.
modified:
  lisp/gnus/ChangeLog
  lisp/gnus/gnus-registry.el
  lisp/gnus/registry.el

=== modified file 'lisp/gnus/ChangeLog'
--- a/lisp/gnus/ChangeLog       2011-04-06 12:55:49 +0000
+++ b/lisp/gnus/ChangeLog       2011-04-06 22:08:31 +0000
@@ -1,10 +1,39 @@
-2011-04-06  Teodor Zlatanov  <address@hidden>
-
-       * gnus-registry.el: Don't use ERT if it's not available.
+2011-04-06  David Engster  <address@hidden>
+
+       * 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  <address@hidden>
+
+       * registry.el (initialize-instance): Change :after to :AFTER to be
+       compatible with old EIEIO version in XEmacs.
+
+2011-04-06  Teodor Zlatanov  <address@hidden>
+
+       * 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  <address@hidden>
+
+       * 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  <address@hidden>
+
+       * 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

=== modified file 'lisp/gnus/gnus-registry.el'
--- a/lisp/gnus/gnus-registry.el        2011-04-06 12:55:49 +0000
+++ b/lisp/gnus/gnus-registry.el        2011-04-06 22:08:31 +0000
@@ -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 @@
            &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)))
+     (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)))
+       ;; 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 @@
 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 @@
         (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)

=== modified file 'lisp/gnus/registry.el'
--- a/lisp/gnus/registry.el     2011-04-06 12:55:49 +0000
+++ b/lisp/gnus/registry.el     2011-04-06 22:08:31 +0000
@@ -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)