lisp/gnus/gnus-sync.el

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