[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-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))
	46	(require 'gnus-util)
	47
	48	(defgroup gnus-sync nil
	49	"The Gnus synchronization facility."
810717b6	50	:version "24.1"
9fc8d464 KY	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)
9fc8d464 KY	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
ab731e1c KY	98	;; TODO: keep the old contents for groups we don't have!
	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)))))
9fc8d464 KY	108	(with-temp-file gnus-sync-backend
	109	(progn
	110	(let ((coding-system-for-write gnus-ding-file-coding-system)
	111	(standard-output (current-buffer)))
	112	(princ (format ";; -- mode:emacs-lisp; coding: %s; --\n"
	113	gnus-ding-file-coding-system))
	114	(princ ";; Gnus sync data v. 0.0.1\n")
	115	(let* ((print-quoted t)
	116	(print-readably t)
	117	(print-escape-multibyte nil)
	118	(print-escape-nonascii t)
	119	(print-length nil)
	120	(print-level nil)
	121	(print-circle nil)
	122	(print-escape-newlines t)
	123	(variables (cons 'gnus-sync-newsrc-loader
bbe276f2 KY	124	gnus-sync-global-vars))
bbe276f2 KY	125	variable)
9fc8d464	126	(while variables
f5a62bb4	127	(if (and (boundp (setq variable (pop variables)))
9fc8d464	128	(symbol-value variable))
f5a62bb4 KY	129	(progn
	130	(princ "\n(setq ")
	131	(princ (symbol-name variable))
	132	(princ " '")
	133	(prin1 (symbol-value variable))
	134	(princ ")\n"))
	135	(princ "\n;;; skipping empty variable ")
	136	(princ (symbol-name variable)))))
9fc8d464 KY	137	(gnus-message
	138	7
	139	"gnus-sync: stored variables %s and %d groups in %s"
	140	gnus-sync-global-vars
	141	(length gnus-sync-newsrc-loader)
	142	gnus-sync-backend)
	143
	144	;; Idea from Dan Christensen <jdc@chow.mat.jhu.edu>
	145	;; Save the .eld file with extra line breaks.
	146	(gnus-message 8 "gnus-sync: adding whitespace to %s"
	147	gnus-sync-backend)
	148	(save-excursion
	149	(goto-char (point-min))
	150	(while (re-search-forward "^(\\\|(\\\"" nil t)
	151	(replace-match "\n\\&" t))
	152	(goto-char (point-min))
	153	(while (re-search-forward " $" nil t)
	154	(replace-match "" t t))))))))
	155	;; the pass-through case: gnus-sync-backend is not a known choice
	156	(nil)))
	157
	158	(defun gnus-sync-read ()
	159	"Load the Gnus sync data from the backend."
	160	(interactive)
	161	(when gnus-sync-backend
	162	(gnus-message 7 "gnus-sync: loading from backend %s" gnus-sync-backend)
	163	(cond ((stringp gnus-sync-backend)
	164	;; read data here...
	165	(if (or debug-on-error debug-on-quit)
	166	(load gnus-sync-backend nil t)
	167	(condition-case var
	168	(load gnus-sync-backend nil t)
	169	(error
	170	(error "Error in %s: %s" gnus-sync-backend (cadr var)))))
186a9cbb KY	171	(let ((valid-count 0)
	172	invalid-groups)
	173	(dolist (node gnus-sync-newsrc-loader)
	174	(if (gnus-gethash (car node) gnus-newsrc-hashtb)
	175	(progn
	176	(incf valid-count)
	177	(loop for store in (cdr node)
	178	do (setf (nth (car store)
	179	(assoc (car node) gnus-newsrc-alist))
9fc8d464	180	(cdr store))))
186a9cbb	181	(push (car node) invalid-groups)))
9fc8d464 KY	182	(gnus-message
	183	7
	184	"gnus-sync: loaded %d groups (out of %d) from %s"
186a9cbb	185	valid-count (length gnus-sync-newsrc-loader)
9fc8d464	186	gnus-sync-backend)
186a9cbb KY	187	(when invalid-groups
	188	(gnus-message
	189	7
	190	"gnus-sync: skipped %d groups (out of %d) from %s"
	191	(length invalid-groups)
	192	(length gnus-sync-newsrc-loader)
	193	gnus-sync-backend)
	194	(gnus-message 9 "gnus-sync: skipped groups: %s"
8c330707	195	(mapconcat 'identity invalid-groups ", ")))))
9fc8d464 KY	196	(nil))
9fc8d464 KY	197	;; make the hashtable again because the newsrc-alist may have been modified
bbe276f2	198	(when gnus-sync-newsrc-offsets
9fc8d464 KY	199	(gnus-message 9 "gnus-sync: remaking the newsrc hashtable")
	200	(gnus-make-hashtable-from-newsrc-alist))))
	201
	202	;;;###autoload
	203	(defun gnus-sync-initialize ()
	204	"Initialize the Gnus sync facility."
	205	(interactive)
	206	(gnus-message 5 "Initializing the sync facility")
	207	(gnus-sync-install-hooks))
	208
	209	;;;###autoload
	210	(defun gnus-sync-install-hooks ()
	211	"Install the sync hooks."
	212	(interactive)
79993b19	213	;; (add-hook 'gnus-get-new-news-hook 'gnus-sync-read)
9fc8d464	214	(add-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
ab731e1c	215	(add-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
9fc8d464 KY	216
	217	(defun gnus-sync-unload-hook ()
	218	"Uninstall the sync hooks."
	219	(interactive)
79993b19	220	;; (remove-hook 'gnus-get-new-news-hook 'gnus-sync-read)
9fc8d464 KY	221	(remove-hook 'gnus-save-newsrc-hook 'gnus-sync-save)
	222	(remove-hook 'gnus-read-newsrc-el-hook 'gnus-sync-read))
	223
	224	(add-hook 'gnus-sync-unload-hook 'gnus-sync-unload-hook)
	225
	226	;; this is harmless by default, until the gnus-sync-backend is set
	227	(gnus-sync-initialize)
	228
	229	(provide 'gnus-sync)
	230
	231	;;; gnus-sync.el ends here