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

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