[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
    (let* ((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))))
           (gnus-sync-newsrc-loader
            (nunion loader
                    (set-difference gnus-sync-newsrc-loader loader :key 'car)
                    :key 'car)))

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