"Read the category alist."
(setq gnus-category-alist
(or
- (with-temp-buffer
- (ignore-errors
- (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories"))
- (goto-char (point-min))
- ;; This code isn't temp, it will be needed so long as
- ;; anyone may be migrating from an older version.
-
- ;; Once we're certain that people will not revert to an
- ;; earlier version, we can take out the old-list code in
- ;; gnus-category-write.
- (let* ((old-list (read (current-buffer)))
- (new-list (ignore-errors (read (current-buffer)))))
- (if new-list
- new-list
- ;; Convert from a positional list to an alist.
- (mapcar
- (lambda (c)
- (setcdr c
- (delq nil
- (gnus-mapcar
- (lambda (valu symb)
- (if valu
- (cons symb valu)))
- (cdr c)
- '(agent-predicate agent-score-file agent-groups))))
- c)
- old-list)))))
+ (let ((list
+ (with-temp-buffer
+ (ignore-errors
+ (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories"))
+ (goto-char (point-min))
+ ;; This code isn't temp, it will be needed so long as
+ ;; anyone may be migrating from an older version.
+
+ ;; Once we're certain that people will not revert to an
+ ;; earlier version, we can take out the old-list code in
+ ;; gnus-category-write.
+ (let* ((old-list (read (current-buffer)))
+ (new-list (ignore-errors (read (current-buffer)))))
+ (if new-list
+ new-list
+ ;; Convert from a positional list to an alist.
+ (mapcar
+ (lambda (c)
+ (setcdr c
+ (delq nil
+ (gnus-mapcar
+ (lambda (valu symb)
+ (if valu
+ (cons symb valu)))
+ (cdr c)
+ '(agent-predicate agent-score-file agent-groups))))
+ c)
+ old-list)))))))
+ ;; Possibly decode group names.
+ (dolist (cat list)
+ (setf (alist-get 'agent-groups cat)
+ (mapcar (lambda (g)
+ (if (string-match-p "[^[:ascii:]]" g)
+ (decode-coding-string g 'utf-8-emacs)
+ g))
+ (alist-get 'agent-groups cat))))
+ list)
(list (gnus-agent-cat-make 'default 'short)))))
(defun gnus-category-write ()
"Write the category alist."
(setq gnus-category-predicate-cache nil
gnus-category-group-cache nil)
- (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
- (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
- ;; This prin1 is temporary. It exists so that people can revert
- ;; to an earlier version of gnus-agent.
- (prin1 (mapcar (lambda (c)
- (list (car c)
- (cdr (assoc 'agent-predicate c))
- (cdr (assoc 'agent-score-file c))
- (cdr (assoc 'agent-groups c))))
- gnus-category-alist)
- (current-buffer))
- (newline)
- (prin1 gnus-category-alist (current-buffer))))
+ ;; Temporarily encode non-ascii group names when saving to file,
+ ;; pending an upgrade of Gnus' file formats.
+ (let ((gnus-category-alist
+ (mapcar (lambda (cat)
+ (setf (alist-get 'agent-groups cat)
+ (mapcar (lambda (g)
+ (if (multibyte-string-p g)
+ (encode-coding-string g 'utf-8-emacs)
+ g))
+ (alist-get 'agent-groups cat)))
+ cat)
+ (copy-tree gnus-category-alist))))
+ (gnus-make-directory (nnheader-concat gnus-agent-directory "lib"))
+ (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories")
+ ;; This prin1 is temporary. It exists so that people can revert
+ ;; to an earlier version of gnus-agent.
+ (prin1 (mapcar (lambda (c)
+ (list (car c)
+ (cdr (assoc 'agent-predicate c))
+ (cdr (assoc 'agent-score-file c))
+ (cdr (assoc 'agent-groups c))))
+ gnus-category-alist)
+ (current-buffer))
+ (newline)
+ (prin1 gnus-category-alist (current-buffer)))))
(defun gnus-category-edit-predicate (category)
"Edit the predicate for CATEGORY."
(cadr (assq 'creation-time r))
(cadr (assq 'creation-time l))))
+;; Remove this from the save routine (and fix it to only decode) at
+;; next Gnus version bump.
+(defun gnus-registry--munge-group-names (db &optional encode)
+ "Encode/decode group names in DB, before saving or after loading.
+Encode names if ENCODE is non-nil, otherwise decode."
+ (let ((datahash (slot-value db 'data))
+ (grouphash (registry-lookup-secondary db 'group))
+ reset-pairs)
+ (when (hash-table-p grouphash)
+ (maphash
+ (lambda (group-name val)
+ (if encode
+ (when (multibyte-string-p group-name)
+ (remhash group-name grouphash)
+ (puthash (encode-coding-string group-name 'utf-8-emacs)
+ val grouphash))
+ (when (string-match-p "[^[:ascii:]]" group-name)
+ (remhash group-name grouphash)
+ (puthash (decode-coding-string group-name 'utf-8-emacs) val grouphash))))
+ grouphash))
+ (maphash
+ (lambda (id data)
+ (let ((groups (cdr-safe (assq 'group data))))
+ (when (seq-some (lambda (g)
+ (if encode
+ (multibyte-string-p g)
+ (string-match-p "[^[:ascii:]]" g)))
+ groups)
+ ;; Create a replacement DATA.
+ (push (list id (cons (cons 'group (mapcar
+ (lambda (g)
+ (funcall
+ (if encode
+ #'encode-coding-string
+ #'decode-coding-string)
+ g 'utf-8-emacs))
+ groups))
+ (assq-delete-all 'group data)))
+ reset-pairs))))
+ datahash)
+ (pcase-dolist (`(,id ,data) reset-pairs)
+ (remhash id datahash)
+ (puthash id data datahash))))
+
(defun gnus-registry-fixup-registry (db)
(when db
(let ((old (oref db tracked)))
'(mark group keyword)))
(when (not (equal old (oref db tracked)))
(gnus-message 9 "Reindexing the Gnus registry (tracked change)")
- (registry-reindex db))))
+ (registry-reindex db))
+ (gnus-registry--munge-group-names db)))
db)
(defun gnus-registry-make-db (&optional file)
(defun gnus-registry-save (&optional file db)
"Save the registry cache file."
(interactive)
- (let ((file (or file gnus-registry-cache-file))
- (db (or db gnus-registry-db)))
+ (let* ((file (or file gnus-registry-cache-file))
+ (db (or db gnus-registry-db))
+ (clone (clone db)))
(gnus-message 5 "Saving Gnus registry (%d entries) to %s..."
(registry-size db) file)
(registry-prune
db gnus-registry-default-sort-function)
+ ;; Write a clone of the database with non-ascii group names
+ ;; encoded as 'utf-8. Let-bind `gnus-registry-db' so that
+ ;; functions in the munging process work on our clone.
+ (let ((gnus-registry-db clone))
+ (gnus-registry--munge-group-names clone 'encode))
;; TODO: call (gnus-string-remove-all-properties v) on all elements?
- (eieio-persistent-save db file)
+ (eieio-persistent-save clone file)
(gnus-message 5 "Saving Gnus registry (size %d) to %s...done"
(registry-size db) file)))
(defvar gnus-agent-covered-methods)
(defvar gnus-agent-file-loading-local)
(defvar gnus-agent-file-loading-cache)
+(defvar gnus-topic-alist)
(defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc")
"Your `.newsrc' file.
(princ "(setq gnus-newsrc-file-version ")
(princ (gnus-prin1-to-string gnus-version))
(princ ")\n"))
-
+ ;; Sort `gnus-newsrc-alist' according to order in
+ ;; `gnus-group-list'.
+ (setq gnus-newsrc-alist
+ (mapcar (lambda (g)
+ (nth 1 (gethash g gnus-newsrc-hashtb)))
+ (delete "dummy.group" gnus-group-list)))
(let* ((print-quoted t)
(print-readably t)
(print-escape-multibyte nil)
;; Remove the `gnus-killed-list' from the list of variables
;; to be saved, if required.
(delq 'gnus-killed-list (copy-sequence gnus-variable-list)))))
+ ;; Encode group names in `gnus-newsrc-alist' and
+ ;; `gnus-topic-alist' in order to keep newsrc.eld files
+ ;; compatible with older versions of Gnus. At some point,
+ ;; if/when a new version of Gnus is released, stop doing
+ ;; this and move the corresponding decode in
+ ;; `gnus-read-newsrc-el-file' into a conversion routine.
+ (gnus-newsrc-alist
+ (mapcar (lambda (info)
+ (cons (encode-coding-string (car info) 'utf-8-emacs)
+ (cdr info)))
+ gnus-newsrc-alist))
+ (gnus-topic-alist
+ (when (memq 'gnus-topic-alist variables)
+ (mapcar (lambda (elt)
+ (cons (car elt) ; Topic name
+ (mapcar (lambda (g)
+ (encode-coding-string
+ g 'utf-8-emacs))
+ (cdr elt))))
+ gnus-topic-alist)))
variable)
- ;; A bit of a fake-out here: the original value of
- ;; `gnus-newsrc-alist' isn't written to file, instead it is
- ;; constructed at the last minute by combining the group
- ;; ordering in `gnus-group-list' with the group infos from
- ;; `gnus-newsrc-hashtb'.
- (set (nth (seq-position gnus-variable-list 'gnus-newsrc-alist)
- gnus-variable-list)
- (mapcar (lambda (g)
- (nth 1 (gethash g gnus-newsrc-hashtb)))
- (delete "dummy.group" gnus-group-list)))
-
;; Insert the variables into the file.
(while variables
(when (and (boundp (setq variable (pop variables)))
projects / emacs.git / commitdiff