procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge changes made in Gnus trunk.

Browse source 
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.
This commit is contained in:
Gnus developers 2011-04-06 22:08:31 +00:00 • committed by Katsumi Yamaoka
parent e67a13abd8
commit 2237da9c04
3 changed files with 144 additions and 87 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
lisp/gnus/ChangeLog
View file

@ -1,10 +1,39 @@
2011-04-06 David Engster <dengste@eml.cc>
* 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 <dengste@eml.cc>
* registry.el (initialize-instance): Change :after to :AFTER to be
compatible with old EIEIO version in XEmacs.
2011-04-06 Teodor Zlatanov <tzz@lifelogs.com>
* gnus-registry.el: Don't use ERT if it's not available.
* 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 <dengste@eml.cc>
* 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 <tzz@lifelogs.com>
* 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

191
lisp/gnus/gnus-registry.el
View file

@ -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)))
(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 @@ 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)

7
lisp/gnus/registry.el
View file

@ -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)