1 ;;; nnoo.el --- OO Gnus Backends
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
29 (eval-when-compile (require 'cl
))
31 (defvar nnoo-definition-alist nil
)
32 (defvar nnoo-state-alist nil
)
33 (defvar nnoo-parent-backend nil
)
35 (defmacro defvoo
(var init
&optional doc
&rest map
)
36 "The same as `defvar', only takes list of variables to MAP to."
39 `(defvar ,var
,init
,(concat doc
"\n\nThis is a Gnus server variable. See Info node `(gnus)Select Methods'."))
41 (nnoo-define ',var
',map
)))
42 (put 'defvoo
'lisp-indent-function
2)
43 (put 'defvoo
'edebug-form-spec
'(var init
&optional doc
&rest map
))
45 (defmacro deffoo
(func args
&rest forms
)
46 "The same as `defun', only register FUNC."
48 (defun ,func
,args
,@forms
)
49 (nnoo-register-function ',func
)))
50 (put 'deffoo
'lisp-indent-function
2)
51 (put 'deffoo
'edebug-form-spec
'(&define name lambda-list def-body
))
53 (defun nnoo-register-function (func)
54 (let ((funcs (nthcdr 3 (assoc (nnoo-backend func
)
55 nnoo-definition-alist
))))
57 (error "%s belongs to a backend that hasn't been declared" func
))
58 (setcar funcs
(cons func
(car funcs
)))))
60 (defmacro nnoo-declare
(backend &rest parents
)
62 (if (assq ',backend nnoo-definition-alist
)
63 (setcar (cdr (assq ',backend nnoo-definition-alist
))
64 (mapcar 'list
',parents
))
66 (mapcar 'list
',parents
)
68 nnoo-definition-alist
))
69 (unless (assq ',backend nnoo-state-alist
)
70 (push (list ',backend
"*internal-non-initialized-backend*")
72 (put 'nnoo-declare
'lisp-indent-function
1)
74 (defun nnoo-parents (backend)
75 (nth 1 (assoc backend nnoo-definition-alist
)))
77 (defun nnoo-variables (backend)
78 (nth 2 (assoc backend nnoo-definition-alist
)))
80 (defun nnoo-functions (backend)
81 (nth 3 (assoc backend nnoo-definition-alist
)))
83 (defmacro nnoo-import
(backend &rest imports
)
84 `(nnoo-import-1 ',backend
',imports
))
85 (put 'nnoo-import
'lisp-indent-function
1)
87 (defun nnoo-import-1 (backend imports
)
89 (if (symbolp (car imports
)) (pop imports
) 'nnoo-parent-function
))
90 imp functions function
)
91 (while (setq imp
(pop imports
))
94 (nnoo-functions (car imp
))))
99 (nnoo-rest-symbol (car functions
)))))
100 (eval `(deffoo ,function
(&rest args
)
101 (,call-function
',backend
',(car functions
) args
))))
104 (defun nnoo-parent-function (backend function args
)
105 (let ((pbackend (nnoo-backend function
))
106 (nnoo-parent-backend backend
))
107 (nnoo-change-server pbackend
108 (nnoo-current-server backend
)
109 (cdr (assq pbackend
(nnoo-parents backend
))))
111 (apply function args
)
112 ;; Copy the changed variables back into the child.
113 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
115 (set (cadar vars
) (symbol-value (caar vars
)))
116 (setq vars
(cdr vars
)))))))
118 (defun nnoo-execute (backend function
&rest args
)
119 "Execute FUNCTION on behalf of BACKEND."
120 (let ((pbackend (nnoo-backend function
))
121 (nnoo-parent-backend backend
))
122 (nnoo-change-server pbackend
123 (nnoo-current-server backend
)
124 (cdr (assq pbackend
(nnoo-parents backend
))))
126 (apply function args
)
127 ;; Copy the changed variables back into the child.
128 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
130 (set (cadar vars
) (symbol-value (caar vars
)))
131 (setq vars
(cdr vars
)))))))
133 (defmacro nnoo-map-functions
(backend &rest maps
)
134 `(nnoo-map-functions-1 ',backend
',maps
))
135 (put 'nnoo-map-functions
'lisp-indent-function
1)
137 (defun nnoo-map-functions-1 (backend maps
)
139 (while (setq m
(pop maps
))
142 (while (< i
(length (cdr m
)))
143 (if (numberp (nth i
(cdr m
)))
144 (push `(nth ,i args
) margs
)
145 (push (nth i
(cdr m
)) margs
))
147 (eval `(deffoo ,(nnoo-symbol backend
(nnoo-rest-symbol (car m
)))
149 (nnoo-parent-function ',backend
',(car m
)
150 ,(cons 'list
(nreverse margs
))))))))
152 (defun nnoo-backend (symbol)
153 (string-match "^[^-]+-" (symbol-name symbol
))
154 (intern (substring (symbol-name symbol
) 0 (1- (match-end 0)))))
156 (defun nnoo-rest-symbol (symbol)
157 (string-match "^[^-]+-" (symbol-name symbol
))
158 (intern (substring (symbol-name symbol
) (match-end 0))))
160 (defun nnoo-symbol (backend symbol
)
161 (intern (format "%s-%s" backend symbol
)))
163 (defun nnoo-define (var map
)
164 (let* ((backend (nnoo-backend var
))
165 (def (assq backend nnoo-definition-alist
))
166 (parents (nth 1 def
)))
168 (error "%s belongs to a backend that hasn't been declared" var
))
169 (setcar (nthcdr 2 def
)
170 (delq (assq var
(nth 2 def
)) (nth 2 def
)))
171 (setcar (nthcdr 2 def
)
172 (cons (cons var
(symbol-value var
))
175 (nconc (assq (nnoo-backend (car map
)) parents
)
176 (list (list (pop map
) var
))))))
178 (defun nnoo-change-server (backend server defs
)
179 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
180 (current (car bstate
))
181 (parents (nnoo-parents backend
))
182 (server (if nnoo-parent-backend
183 (format "%s+%s" nnoo-parent-backend server
)
185 (bvariables (nnoo-variables backend
))
187 ;; If we don't have a current state, we push an empty state
190 (push (setq bstate
(list backend nil
))
193 (if (equal server current
)
195 (nnoo-push-server backend current
)
196 (setq state
(or (cdr (assoc server
(cddr bstate
)))
197 (nnoo-variables backend
)))
199 (set (caar state
) (cdar state
))
201 (setcar bstate server
)
202 (unless (cdr (assoc server
(cddr bstate
)))
203 (while (setq def
(pop defs
))
204 (unless (assq (car def
) bvariables
)
206 (list (cons (car def
) (and (boundp (car def
))
207 (symbol-value (car def
)))))))
208 (if (equal server
"*internal-non-initialized-backend*")
209 (set (car def
) (symbol-value (cadr def
)))
210 (set (car def
) (cadr def
)))))
213 (caar parents
) (format "%s+%s" backend server
)
214 (mapcar (lambda (def) (list (car def
) (symbol-value (cadr def
))))
219 (defun nnoo-push-server (backend current
)
220 (let ((bstate (assq backend nnoo-state-alist
))
221 (defs (nnoo-variables backend
)))
222 ;; Remove the old definition.
223 (setcdr (cdr bstate
) (delq (assoc current
(cddr bstate
)) (cddr bstate
)))
224 ;; If this is the first time we push the server (i. e., this is
225 ;; the nil server), then we update the default values of
226 ;; all the variables to reflect the current values.
227 (when (equal current
"*internal-non-initialized-backend*")
228 (let ((defaults (nnoo-variables backend
))
230 (while (setq def
(pop defaults
))
231 (setcdr def
(symbol-value (car def
))))))
234 (push (cons (caar defs
) (symbol-value (caar defs
)))
237 (nconc bstate
(list (cons current state
))))))
239 (defsubst nnoo-current-server-p
(backend server
)
240 (equal (nnoo-current-server backend
)
241 (if nnoo-parent-backend
242 (format "%s+%s" nnoo-parent-backend server
)
245 (defun nnoo-current-server (backend)
246 (nth 1 (assq backend nnoo-state-alist
)))
248 (defun nnoo-close-server (backend &optional server
)
250 (setq server
(nnoo-current-server backend
)))
252 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
253 (defs (assoc server
(cdr bstate
))))
256 (setcdr bstate
(delq defs
(cdr bstate
)))
259 (set (car (pop defs
)) nil
)))))
262 (defun nnoo-close (backend)
263 (setq nnoo-state-alist
264 (delq (assq backend nnoo-state-alist
)
268 (defun nnoo-status-message (backend server
)
269 (nnheader-get-report backend
))
271 (defun nnoo-server-opened (backend server
)
272 (and (nnoo-current-server-p backend server
)
274 (buffer-name nntp-server-buffer
)))
276 (defmacro nnoo-define-basics
(backend)
277 "Define `close-server', `server-opened' and `status-message'."
279 (nnoo-define-basics-1 ',backend
)))
281 (defun nnoo-define-basics-1 (backend)
282 (let ((functions '(close-server server-opened status-message
)))
284 (eval `(deffoo ,(nnoo-symbol backend
(car functions
))
286 (,(nnoo-symbol 'nnoo
(pop functions
)) ',backend server
)))))
287 (eval `(deffoo ,(nnoo-symbol backend
'open-server
)
288 (server &optional defs
)
289 (nnoo-change-server ',backend server defs
))))
291 (defmacro nnoo-define-skeleton
(backend)
292 "Define all required backend functions for BACKEND.
293 All functions will return nil and report an error."
295 (nnoo-define-skeleton-1 ',backend
)))
297 (defun nnoo-define-skeleton-1 (backend)
298 (let ((functions '(retrieve-headers
299 request-close request-article
300 request-group close-group
301 request-list request-post request-list-newsgroups
))
303 (while (setq function
(pop functions
))
304 (when (not (fboundp (setq fun
(nnoo-symbol backend function
))))
307 (nnheader-report ',backend
,(format "%s-%s not implemented"
308 backend function
))))))))
310 (defun nnoo-set (server &rest args
)
311 (let ((parents (nnoo-parents (car server
)))
312 (nnoo-parent-backend (car server
)))
314 (nnoo-change-server (caar parents
)
318 (nnoo-change-server (car server
)
319 (cadr server
) (cddr server
))
321 (set (pop args
) (pop args
))))
325 ;; arch-tag: 0196b5ed-6f34-4778-a455-73a971f837e7
326 ;;; nnoo.el ends here