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