Commit | Line | Data |
---|---|---|
9fc8d464 KY |
1 | ;;; gnus-sync.el --- synchronization facility for Gnus |
2 | ||
3 | ;;; Copyright (C) 2010 | |
4 | ;;; Free Software Foundation, Inc. | |
5 | ||
6 | ;; Author: Ted Zlatanov <tzz@lifelogs.com> | |
7 | ;; Keywords: news synchronization nntp nnrss | |
8 | ||
9 | ;; This file is part of GNU Emacs. | |
10 | ||
11 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
13 | ;; the Free Software Foundation, either version 3 of the License, or | |
14 | ;; (at your option) any later version. | |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
23 | ||
24 | ;;; Commentary: | |
25 | ||
26 | ;; This is the gnus-sync.el package. | |
27 | ||
28 | ;; Put this in your startup file (~/.gnus.el for instance) | |
29 | ||
30 | ;; (setq gnus-sync-backend `("/remote:/path.gpg") ; will use Tramp+EPA if loaded | |
31 | ;; gnus-sync-global-vars `(gnus-newsrc-last-checked-date) | |
32 | ;; gnus-sync-newsrc-groups `("nntp" "nnrss") | |
33 | ;; gnus-sync-newsrc-vars `(read marks)) | |
34 | ||
35 | ;; TODO: | |
36 | ||
37 | ;; - after gnus-sync-read, the message counts are wrong | |
38 | ||
39 | ;;; Code: | |
40 | ||
41 | (eval-when-compile (require 'cl)) | |
42 | (require 'gnus-util) | |
43 | ||
44 | (defgroup gnus-sync nil | |
45 | "The Gnus synchronization facility." | |
46 | :version "23.1" | |
47 | :group 'gnus) | |
48 | ||
49 | (defcustom gnus-sync-newsrc-groups `("nntp" "nnrss") | |
50 | "List of groups to be synchronized in the gnus-newsrc-alist. | |
51 | The group names are matched, they don't have to be fully | |
52 | qualified. Typically you would choose all of these. That's the | |
53 | default because there is no active sync backend by default, so | |
54 | this setting is harmless until the user chooses a sync backend." | |
55 | :group 'gnus-sync | |
56 | :type '(repeat regexp)) | |
57 | ||
58 | (defcustom gnus-sync-newsrc-offsets '(2 3) | |
59 | "List of per-group data to be synchronized." | |
60 | :group 'gnus-sync | |
61 | :type '(set (const :tag "Read ranges" 2) | |
62 | (const :tag "Marks" 3))) | |
63 | ||
64 | (defcustom gnus-sync-global-vars nil | |
65 | "List of global variables to be synchronized. | |
66 | You may want to sync `gnus-newsrc-last-checked-date' but pretty | |
67 | much any symbol is fair game. You could additionally sync | |
68 | `gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology', | |
69 | and `gnus-topic-alist' to cover all the variables in | |
70 | newsrc.eld (except for `gnus-format-specs' which should not be | |
71 | synchronized, I believe). Also see `gnus-variable-list'." | |
72 | :group 'gnus-sync | |
73 | :type '(repeat (choice (variable :tag "A known variable") | |
74 | (symbol :tag "Any symbol")))) | |
75 | ||
76 | (defcustom gnus-sync-backend nil | |
77 | "The synchronization backend." | |
78 | :group 'gnus-sync | |
79 | :type '(radio (const :format "None" nil) | |
80 | (string :tag "Sync to a file"))) | |
81 | ||
82 | (defvar gnus-sync-newsrc-loader nil | |
83 | "Carrier for newsrc data") | |
84 | ||
85 | (defun gnus-sync-save () | |
86 | "Save the Gnus sync data to the backend." | |
87 | (interactive) | |
88 | (gnus-message 6 "Saving the Gnus sync data") | |
89 | (cond | |
90 | ((stringp gnus-sync-backend) | |
91 | (gnus-message 7 "gnus-sync: saving to backend %s" gnus-sync-backend) | |
92 | ;; populate gnus-sync-newsrc-loader from all but the first dummy | |
93 | ;; entry in gnus-newsrc-alist whose group matches any of the | |
94 | ;; gnus-sync-newsrc-groups | |
95 | (let ((gnus-sync-newsrc-loader | |
96 | (loop for entry in (cdr gnus-newsrc-alist) | |
97 | when (gnus-grep-in-list | |
98 | (car entry) ;the group name | |
99 | gnus-sync-newsrc-groups) | |
100 | collect (cons (car entry) | |
101 | (mapcar (lambda (offset) | |
102 | (cons offset (nth offset entry))) | |
103 | gnus-sync-newsrc-offsets))))) | |
104 | ||
105 | (with-temp-file gnus-sync-backend | |
106 | (progn | |
107 | (let ((coding-system-for-write gnus-ding-file-coding-system) | |
108 | (standard-output (current-buffer))) | |
109 | (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n" | |
110 | gnus-ding-file-coding-system)) | |
111 | (princ ";; Gnus sync data v. 0.0.1\n") | |
112 | (let* ((print-quoted t) | |
113 | (print-readably t) | |
114 | (print-escape-multibyte nil) | |
115 | (print-escape-nonascii t) | |
116 | (print-length nil) | |
117 | (print-level nil) | |
118 | (print-circle nil) | |
119 | (print-escape-newlines t) | |
120 | (variables (cons 'gnus-sync-newsrc-loader | |
121 | gnus-sync-global-vars))) | |
122 | (while variables | |
123 | (when (and (boundp (setq variable (pop variables))) | |
124 | (symbol-value variable)) | |
125 | (princ "\n(setq ") | |
126 | (princ (symbol-name variable)) | |
127 | (princ " '") | |
128 | (prin1 (symbol-value variable)) | |
129 | (princ ")\n")))) | |
130 | (gnus-message | |
131 | 7 | |
132 | "gnus-sync: stored variables %s and %d groups in %s" | |
133 | gnus-sync-global-vars | |
134 | (length gnus-sync-newsrc-loader) | |
135 | gnus-sync-backend) | |
136 | ||
137 | ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu> | |
138 | ;; Save the .eld file with extra line breaks. | |
139 | (gnus-message 8 "gnus-sync: adding whitespace to %s" | |
140 | gnus-sync-backend) | |
141 | (save-excursion | |
142 | (goto-char (point-min)) | |
143 | (while (re-search-forward "^(\\|(\\\"" nil t) | |
144 | (replace-match "\n\\&" t)) | |
145 | (goto-char (point-min)) | |
146 | (while (re-search-forward " $" nil t) | |
147 | (replace-match "" t t)))))))) | |
148 | ;; the pass-through case: gnus-sync-backend is not a known choice | |
149 | (nil))) | |
150 | ||
151 | (defun gnus-sync-read () | |
152 | "Load the Gnus sync data from the backend." | |
153 | (interactive) | |
154 | (when gnus-sync-backend | |
155 | (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend) | |
156 | (cond ((stringp gnus-sync-backend) | |
157 | ;; read data here... | |
158 | (if (or debug-on-error debug-on-quit) | |
159 | (load gnus-sync-backend nil t) | |
160 | (condition-case var | |
161 | (load gnus-sync-backend nil t) | |
162 | (error | |
163 | (error "Error in %s: %s" gnus-sync-backend (cadr var))))) | |
164 | (let ((valid-nodes | |
165 | (loop for node in gnus-sync-newsrc-loader | |
166 | if (gnus-gethash (car node) gnus-newsrc-hashtb) | |
167 | collect node))) | |
168 | (dolist (node valid-nodes) | |
169 | (loop for store in (cdr node) | |
170 | do (setf (nth (car store) | |
171 | (assoc (car node) gnus-newsrc-alist)) | |
172 | (cdr store)))) | |
173 | (gnus-message | |
174 | 7 | |
175 | "gnus-sync: loaded %d groups (out of %d) from %s" | |
176 | (length valid-nodes) | |
177 | (length gnus-sync-newsrc-loader) | |
178 | gnus-sync-backend) | |
179 | (setq gnus-sync-newsrc-loader nil))) | |
180 | (nil)) | |
181 | ;; make the hashtable again because the newsrc-alist may have been modified | |
182 | (when gnus-sync-newsrc-vars | |
183 | (gnus-message 9 "gnus-sync: remaking the newsrc hashtable") | |
184 | (gnus-make-hashtable-from-newsrc-alist)))) | |
185 | ||
186 | ;;;###autoload | |
187 | (defun gnus-sync-initialize () | |
188 | "Initialize the Gnus sync facility." | |
189 | (interactive) | |
190 | (gnus-message 5 "Initializing the sync facility") | |
191 | (gnus-sync-install-hooks)) | |
192 | ||
193 | ;;;###autoload | |
194 | (defun gnus-sync-install-hooks () | |
195 | "Install the sync hooks." | |
196 | (interactive) | |
197 | (add-hook 'gnus-get-new-news-hook 'gnus-sync-read) | |
198 | (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save) | |
199 | (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) | |
200 | ||
201 | (defun gnus-sync-unload-hook () | |
202 | "Uninstall the sync hooks." | |
203 | (interactive) | |
204 | (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read) | |
205 | (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save) | |
206 | (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read)) | |
207 | ||
208 | (add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook) | |
209 | ||
210 | ;; this is harmless by default, until the gnus-sync-backend is set | |
211 | (gnus-sync-initialize) | |
212 | ||
213 | (provide 'gnus-sync) | |
214 | ||
215 | ;;; gnus-sync.el ends here |