add lisp/gnus/gnus-sync.el

1 files changed, 215 insertions, 0 deletions

diff --git a/lisp/gnus/gnus-sync.el b/lisp/gnus/gnus-sync.el
new file mode 100644
index 00000000000..1bf07409648
--- /dev/null
+++ b/lisp/gnus/gnus-sync.el
@@ -0,0 +1,215 @@
+;;; gnus-sync.el --- synchronization facility for Gnus
+
+;;; Copyright (C) 2010
+;;; Free Software Foundation, Inc.
+
+;; Author: Ted Zlatanov <tzz@lifelogs.com>
+;; Keywords: news synchronization nntp nnrss
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is the gnus-sync.el package.
+
+;; Put this in your startup file (~/.gnus.el for instance)
+
+;; (setq gnus-sync-backend `("/remote:/path.gpg") ; will use Tramp+EPA if loaded
+;;       gnus-sync-global-vars `(gnus-newsrc-last-checked-date)
+;;       gnus-sync-newsrc-groups `("nntp" "nnrss")
+;;       gnus-sync-newsrc-vars `(read marks))
+
+;; TODO:
+
+;; - after gnus-sync-read, the message counts are wrong
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'gnus-util)
+
+(defgroup gnus-sync nil
+  "The Gnus synchronization facility."
+  :version "23.1"
+  :group 'gnus)
+
+(defcustom gnus-sync-newsrc-groups `("nntp" "nnrss")
+  "List of groups to be synchronized in the gnus-newsrc-alist.
+The group names are matched, they don't have to be fully
+qualified.  Typically you would choose all of these.  That's the
+default because there is no active sync backend by default, so
+this setting is harmless until the user chooses a sync backend."
+  :group 'gnus-sync
+  :type '(repeat regexp))
+
+(defcustom gnus-sync-newsrc-offsets '(2 3)
+  "List of per-group data to be synchronized."
+  :group 'gnus-sync
+  :type '(set (const :tag "Read ranges" 2)
+              (const :tag "Marks" 3)))
+
+(defcustom gnus-sync-global-vars nil
+  "List of global variables to be synchronized.
+You may want to sync `gnus-newsrc-last-checked-date' but pretty
+much any symbol is fair game.  You could additionally sync
+`gnus-newsrc-alist', `gnus-server-alist', `gnus-topic-topology',
+and `gnus-topic-alist' to cover all the variables in
+newsrc.eld (except for `gnus-format-specs' which should not be
+synchronized, I believe).  Also see `gnus-variable-list'."
+  :group 'gnus-sync
+  :type '(repeat (choice (variable :tag "A known variable")
+                         (symbol :tag "Any symbol"))))
+
+(defcustom gnus-sync-backend nil
+  "The synchronization backend."
+  :group 'gnus-sync
+  :type '(radio (const :format "None" nil)
+                (string :tag "Sync to a file")))
+
+(defvar gnus-sync-newsrc-loader nil
+  "Carrier for newsrc data")
+
+(defun gnus-sync-save ()
+"Save the Gnus sync data to the backend."
+  (interactive)
+  (gnus-message 6 "Saving the Gnus sync data")
+  (cond
+   ((stringp gnus-sync-backend)
+    (gnus-message 7 "gnus-sync: saving to backend %s" gnus-sync-backend)
+    ;; populate gnus-sync-newsrc-loader from all but the first dummy
+    ;; entry in gnus-newsrc-alist whose group matches any of the
+    ;; gnus-sync-newsrc-groups
+    (let ((gnus-sync-newsrc-loader
+           (loop for entry in (cdr gnus-newsrc-alist)
+                 when (gnus-grep-in-list
+                       (car entry)     ;the group name
+                       gnus-sync-newsrc-groups)
+                 collect (cons (car entry)
+                               (mapcar (lambda (offset)
+                                         (cons offset (nth offset entry)))
+                                       gnus-sync-newsrc-offsets)))))
+
+      (with-temp-file gnus-sync-backend
+        (progn
+          (let ((coding-system-for-write gnus-ding-file-coding-system)
+                (standard-output (current-buffer)))
+            (princ (format ";; -*- mode:emacs-lisp; coding: %s; -*-\n"
+                           gnus-ding-file-coding-system))
+            (princ ";; Gnus sync data v. 0.0.1\n")
+            (let* ((print-quoted t)
+                   (print-readably t)
+                   (print-escape-multibyte nil)
+                   (print-escape-nonascii t)
+                   (print-length nil)
+                   (print-level nil)
+                   (print-circle nil)
+                   (print-escape-newlines t)
+                   (variables (cons 'gnus-sync-newsrc-loader
+                                    gnus-sync-global-vars)))
+              (while variables
+                (when (and (boundp (setq variable (pop variables)))
+                           (symbol-value variable))
+                  (princ "\n(setq ")
+                  (princ (symbol-name variable))
+                  (princ " '")
+                  (prin1 (symbol-value variable))
+                  (princ ")\n"))))
+            (gnus-message
+             7
+             "gnus-sync: stored variables %s and %d groups in %s"
+             gnus-sync-global-vars
+             (length gnus-sync-newsrc-loader)
+             gnus-sync-backend)
+
+            ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
+            ;; Save the .eld file with extra line breaks.
+            (gnus-message 8 "gnus-sync: adding whitespace to %s"
+                          gnus-sync-backend)
+            (save-excursion
+              (goto-char (point-min))
+              (while (re-search-forward "^(\\|(\\\"" nil t)
+                (replace-match "\n\\&" t))
+              (goto-char (point-min))
+              (while (re-search-forward " $" nil t)
+                (replace-match "" t t))))))))
+    ;; the pass-through case: gnus-sync-backend is not a known choice
+    (nil)))
+
+(defun gnus-sync-read ()
+"Load the Gnus sync data from the backend."
+  (interactive)
+  (when gnus-sync-backend
+    (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend)
+    (cond ((stringp gnus-sync-backend)
+           ;; read data here...
+           (if (or debug-on-error debug-on-quit)
+               (load gnus-sync-backend nil t)
+             (condition-case var
+                 (load gnus-sync-backend nil t)
+               (error
+                (error "Error in %s: %s" gnus-sync-backend (cadr var)))))
+           (let ((valid-nodes
+                  (loop for node in gnus-sync-newsrc-loader
+                        if (gnus-gethash (car node) gnus-newsrc-hashtb)
+                        collect node)))
+             (dolist (node valid-nodes)
+               (loop for store in (cdr node)
+                     do (setf (nth (car store)
+                                   (assoc (car node) gnus-newsrc-alist))
+                              (cdr store))))
+            (gnus-message
+             7
+             "gnus-sync: loaded %d groups (out of %d) from %s"
+             (length valid-nodes)
+             (length gnus-sync-newsrc-loader)
+             gnus-sync-backend)
+           (setq gnus-sync-newsrc-loader nil)))
+          (nil))
+    ;; make the hashtable again because the newsrc-alist may have been modified
+    (when gnus-sync-newsrc-vars
+      (gnus-message 9 "gnus-sync: remaking the newsrc hashtable")
+      (gnus-make-hashtable-from-newsrc-alist))))
+
+;;;###autoload
+(defun gnus-sync-initialize ()
+"Initialize the Gnus sync facility."
+  (interactive)
+  (gnus-message 5 "Initializing the sync facility")
+  (gnus-sync-install-hooks))
+
+;;;###autoload
+(defun gnus-sync-install-hooks ()
+  "Install the sync hooks."
+  (interactive)
+  (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
+  (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
+  (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
+
+(defun gnus-sync-unload-hook ()
+  "Uninstall the sync hooks."
+  (interactive)
+  (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read)
+  (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
+  (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
+
+(add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
+
+;; this is harmless by default, until the gnus-sync-backend is set
+(gnus-sync-initialize)
+
+(provide 'gnus-sync)
+
+;;; gnus-sync.el ends here