[bpt/emacs.git] / lisp / gnus / gnus-sync.el

;;; 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)

;; possibilities for gnus-sync-backend:
;; Tramp over SSH: /ssh:user@host:/path/to/filename
;; Tramp over IMAP: /imaps:user@yourhosthere.com:/INBOX.test/filename
;; ...or any other file Tramp and Emacs can handle...

;; (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-offsets `(2 3))

;; TODO:

;; - after gnus-sync-read, the message counts are wrong

;;; Code:

(eval-when-compile (require 'cl))
(require 'gnus)
(require 'gnus-start)
(require 'gnus-util)

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