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

;;; gnus-sync.el --- synchronization facility for Gnus

;; Copyright (C) 2010-2011  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.

;; It's due for a rewrite using gnus-after-set-mark-hook and
;; gnus-before-update-mark-hook.  Until then please consider it
;; experimental.

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

;; - use gnus-after-set-mark-hook and gnus-before-update-mark-hook to
;;   catch the mark updates

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