cgit.sxemacs.org Git - gnus/blob - lisp/gnus-sync.el

   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                    variable)
 123               (while variables
 124                 (when (and (boundp (setq variable (pop variables)))
 125                            (symbol-value variable))
 126                   (princ "\n(setq ")
 127                   (princ (symbol-name variable))
 128                   (princ " '")
 129                   (prin1 (symbol-value variable))
 130                   (princ ")\n"))))
 131             (gnus-message
 132              7
 133              "gnus-sync: stored variables %s and %d groups in %s"
 134              gnus-sync-global-vars
 135              (length gnus-sync-newsrc-loader)
 136              gnus-sync-backend)
 137
 138             ;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
 139             ;; Save the .eld file with extra line breaks.
 140             (gnus-message 8 "gnus-sync: adding whitespace to %s"
 141                           gnus-sync-backend)
 142             (save-excursion
 143               (goto-char (point-min))
 144               (while (re-search-forward "^(\\|(\\\"" nil t)
 145                 (replace-match "\n\\&" t))
 146               (goto-char (point-min))
 147               (while (re-search-forward " $" nil t)
 148                 (replace-match "" t t))))))))
 149     ;; the pass-through case: gnus-sync-backend is not a known choice
 150     (nil)))
 151
 152 (defun gnus-sync-read ()
 153 "Load the Gnus sync data from the backend."
 154   (interactive)
 155   (when gnus-sync-backend
 156     (gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend)
 157     (cond ((stringp gnus-sync-backend)
 158            ;; read data here...
 159            (if (or debug-on-error debug-on-quit)
 160                (load gnus-sync-backend nil t)
 161              (condition-case var
 162                  (load gnus-sync-backend nil t)
 163                (error
 164                 (error "Error in %s: %s" gnus-sync-backend (cadr var)))))
 165            (let ((valid-nodes
 166                   (loop for node in gnus-sync-newsrc-loader
 167                         if (gnus-gethash (car node) gnus-newsrc-hashtb)
 168                         collect node)))
 169              (dolist (node valid-nodes)
 170                (loop for store in (cdr node)
 171                      do (setf (nth (car store)
 172                                    (assoc (car node) gnus-newsrc-alist))
 173                               (cdr store))))
 174             (gnus-message
 175              7
 176              "gnus-sync: loaded %d groups (out of %d) from %s"
 177              (length valid-nodes)
 178              (length gnus-sync-newsrc-loader)
 179              gnus-sync-backend)
 180            (setq gnus-sync-newsrc-loader nil)))
 181           (nil))
 182     ;; make the hashtable again because the newsrc-alist may have been modified
 183     (when gnus-sync-newsrc-offsets
 184       (gnus-message 9 "gnus-sync: remaking the newsrc hashtable")
 185       (gnus-make-hashtable-from-newsrc-alist))))
 186
 187 ;;;###autoload
 188 (defun gnus-sync-initialize ()
 189 "Initialize the Gnus sync facility."
 190   (interactive)
 191   (gnus-message 5 "Initializing the sync facility")
 192   (gnus-sync-install-hooks))
 193
 194 ;;;###autoload
 195 (defun gnus-sync-install-hooks ()
 196   "Install the sync hooks."
 197   (interactive)
 198   (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
 199   (add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
 200   (add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
 201
 202 (defun gnus-sync-unload-hook ()
 203   "Uninstall the sync hooks."
 204   (interactive)
 205   (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read)
 206   (remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
 207   (remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
 208
 209 (add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
 210
 211 ;; this is harmless by default, until the gnus-sync-backend is set
 212 (gnus-sync-initialize)
 213
 214 (provide 'gnus-sync)
 215
 216 ;;; gnus-sync.el ends here