From 2b8ba00dc88398d44f606451980e5ceed56ddb3d Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Thu, 6 Jun 2019 20:43:27 -0700 Subject: [PATCH 2/2] Temporarily preserve encoded Gnus group names in Gnus files Non-ascii Gnus groups should be written to files in their encoded version until we're ready to bump Gnus' version and add an upgrade routine. * lisp/gnus/gnus-start.el (gnus-gnus-to-quick-newsrc-format): * lisp/gnus/gnus-agent.el (gnus-category-read): (gnus-category-write): Handle non-ascii group names appropriately. * lisp/gnus/gnus-registry.el (gnus-registry--munge-group-names): New function to encode/decode group names. (gnus-registry-fixup-registry): (gnus-registry-save): Use function. --- lisp/gnus/gnus-agent.el | 102 ++++++++++++++++++++++--------------- lisp/gnus/gnus-registry.el | 59 +++++++++++++++++++-- lisp/gnus/gnus-start.el | 39 +++++++++----- 3 files changed, 144 insertions(+), 56 deletions(-) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index d9c9e94070..dd30dda2a1 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -2693,52 +2693,74 @@ gnus-category-read "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." diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index e488858ebe..e949179b3c 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -264,6 +264,50 @@ gnus-registry-sort-by-creation-time (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))) @@ -281,7 +325,8 @@ gnus-registry-fixup-registry '(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) @@ -358,14 +403,20 @@ gnus-registry-read (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))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index cb585472af..9b620edbec 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -42,6 +42,7 @@ (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. @@ -2871,7 +2872,12 @@ gnus-gnus-to-quick-newsrc-format (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) @@ -2891,18 +2897,27 @@ gnus-gnus-to-quick-newsrc-format ;; 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))) -- 2.22.0