1 ;;; nnoo.el --- OO Gnus Backends
2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
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
,doc
)
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
)
63 (mapcar (lambda (p) (list p
)) ',parents
)
65 nnoo-definition-alist
)
66 (push (list ',backend
"*internal-non-initialized-backend*")
68 (put 'nnoo-declare
'lisp-indent-function
1)
70 (defun nnoo-parents (backend)
71 (nth 1 (assoc backend nnoo-definition-alist
)))
73 (defun nnoo-variables (backend)
74 (nth 2 (assoc backend nnoo-definition-alist
)))
76 (defun nnoo-functions (backend)
77 (nth 3 (assoc backend nnoo-definition-alist
)))
79 (defmacro nnoo-import
(backend &rest imports
)
80 `(nnoo-import-1 ',backend
',imports
))
81 (put 'nnoo-import
'lisp-indent-function
1)
83 (defun nnoo-import-1 (backend imports
)
85 (if (symbolp (car imports
)) (pop imports
) 'nnoo-parent-function
))
86 imp functions function
)
87 (while (setq imp
(pop imports
))
90 (nnoo-functions (car imp
))))
95 (nnoo-rest-symbol (car functions
)))))
96 (eval `(deffoo ,function
(&rest args
)
97 (,call-function
',backend
',(car functions
) args
))))
100 (defun nnoo-parent-function (backend function args
)
101 (let ((pbackend (nnoo-backend function
))
102 (nnoo-parent-backend backend
))
103 (nnoo-change-server pbackend
104 (nnoo-current-server backend
)
105 (cdr (assq pbackend
(nnoo-parents backend
))))
107 (apply function args
)
108 ;; Copy the changed variables back into the child.
109 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
111 (set (cadar vars
) (symbol-value (caar vars
)))
112 (setq vars
(cdr vars
)))))))
114 (defun nnoo-execute (backend function
&rest args
)
115 "Execute FUNCTION on behalf of BACKEND."
116 (let ((pbackend (nnoo-backend function
))
117 (nnoo-parent-backend backend
))
118 (nnoo-change-server pbackend
119 (nnoo-current-server backend
)
120 (cdr (assq pbackend
(nnoo-parents backend
))))
122 (apply function args
)
123 ;; Copy the changed variables back into the child.
124 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
126 (set (cadar vars
) (symbol-value (caar vars
)))
127 (setq vars
(cdr vars
)))))))
129 (defmacro nnoo-map-functions
(backend &rest maps
)
130 `(nnoo-map-functions-1 ',backend
',maps
))
131 (put 'nnoo-map-functions
'lisp-indent-function
1)
133 (defun nnoo-map-functions-1 (backend maps
)
135 (while (setq m
(pop maps
))
138 (while (< i
(length (cdr m
)))
139 (if (numberp (nth i
(cdr m
)))
140 (push `(nth ,i args
) margs
)
141 (push (nth i
(cdr m
)) margs
))
143 (eval `(deffoo ,(nnoo-symbol backend
(nnoo-rest-symbol (car m
)))
145 (nnoo-parent-function ',backend
',(car m
)
146 ,(cons 'list
(nreverse margs
))))))))
148 (defun nnoo-backend (symbol)
149 (string-match "^[^-]+-" (symbol-name symbol
))
150 (intern (substring (symbol-name symbol
) 0 (1- (match-end 0)))))
152 (defun nnoo-rest-symbol (symbol)
153 (string-match "^[^-]+-" (symbol-name symbol
))
154 (intern (substring (symbol-name symbol
) (match-end 0))))
156 (defun nnoo-symbol (backend symbol
)
157 (intern (format "%s-%s" backend symbol
)))
159 (defun nnoo-define (var map
)
160 (let* ((backend (nnoo-backend var
))
161 (def (assq backend nnoo-definition-alist
))
162 (parents (nth 1 def
)))
164 (error "%s belongs to a backend that hasn't been declared" var
))
165 (setcar (nthcdr 2 def
)
166 (delq (assq var
(nth 2 def
)) (nth 2 def
)))
167 (setcar (nthcdr 2 def
)
168 (cons (cons var
(symbol-value var
))
171 (nconc (assq (nnoo-backend (car map
)) parents
)
172 (list (list (pop map
) var
))))))
174 (defun nnoo-change-server (backend server defs
)
175 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
176 (current (car bstate
))
177 (parents (nnoo-parents backend
))
178 (server (if nnoo-parent-backend
179 (format "%s+%s" nnoo-parent-backend server
)
181 (bvariables (nnoo-variables backend
))
183 ;; If we don't have a current state, we push an empty state
186 (push (setq bstate
(list backend nil
))
189 (if (equal server current
)
191 (nnoo-push-server backend current
)
192 (setq state
(or (cdr (assoc server
(cddr bstate
)))
193 (nnoo-variables backend
)))
195 (set (caar state
) (cdar state
))
197 (setcar bstate server
)
198 (unless (cdr (assoc server
(cddr bstate
)))
199 (while (setq def
(pop defs
))
200 (unless (assq (car def
) bvariables
)
202 (list (cons (car def
) (and (boundp (car def
))
203 (symbol-value (car def
)))))))
204 (if (equal server
"*internal-non-initialized-backend*")
205 (set (car def
) (symbol-value (cadr def
)))
206 (set (car def
) (cadr def
)))))
209 (caar parents
) (format "%s+%s" backend server
)
210 (mapcar (lambda (def) (list (car def
) (symbol-value (cadr def
))))
215 (defun nnoo-push-server (backend current
)
216 (let ((bstate (assq backend nnoo-state-alist
))
217 (defs (nnoo-variables backend
)))
218 ;; Remove the old definition.
219 (setcdr (cdr bstate
) (delq (assoc current
(cddr bstate
)) (cddr bstate
)))
220 ;; If this is the first time we push the server (i. e., this is
221 ;; the nil server), then we update the default values of
222 ;; all the variables to reflect the current values.
223 (when (equal current
"*internal-non-initialized-backend*")
224 (let ((defaults (nnoo-variables backend
))
226 (while (setq def
(pop defaults
))
227 (setcdr def
(symbol-value (car def
))))))
230 (push (cons (caar defs
) (symbol-value (caar defs
)))
233 (nconc bstate
(list (cons current state
))))))
235 (defsubst nnoo-current-server-p
(backend server
)
236 (equal (nnoo-current-server backend
)
237 (if nnoo-parent-backend
238 (format "%s+%s" nnoo-parent-backend server
)
241 (defun nnoo-current-server (backend)
242 (nth 1 (assq backend nnoo-state-alist
)))
244 (defun nnoo-close-server (backend &optional server
)
246 (setq server
(nnoo-current-server backend
)))
248 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
249 (defs (assoc server
(cdr bstate
))))
252 (setcdr bstate
(delq defs
(cdr bstate
)))
255 (set (car (pop defs
)) nil
)))))
258 (defun nnoo-close (backend)
259 (setq nnoo-state-alist
260 (delq (assq backend nnoo-state-alist
)
264 (defun nnoo-status-message (backend server
)
265 (nnheader-get-report backend
))
267 (defun nnoo-server-opened (backend server
)
268 (and (nnoo-current-server-p backend server
)
270 (buffer-name nntp-server-buffer
)))
272 (defmacro nnoo-define-basics
(backend)
273 "Define `close-server', `server-opened' and `status-message'."
275 (nnoo-define-basics-1 ',backend
)))
277 (defun nnoo-define-basics-1 (backend)
278 (let ((functions '(close-server server-opened status-message
)))
280 (eval `(deffoo ,(nnoo-symbol backend
(car functions
))
282 (,(nnoo-symbol 'nnoo
(pop functions
)) ',backend server
)))))
283 (eval `(deffoo ,(nnoo-symbol backend
'open-server
)
284 (server &optional defs
)
285 (nnoo-change-server ',backend server defs
))))
287 (defmacro nnoo-define-skeleton
(backend)
288 "Define all required backend functions for BACKEND.
289 All functions will return nil and report an error."
291 (nnoo-define-skeleton-1 ',backend
)))
293 (defun nnoo-define-skeleton-1 (backend)
294 (let ((functions '(retrieve-headers
295 request-close request-article
296 request-group close-group
297 request-list request-post request-list-newsgroups
))
299 (while (setq function
(pop functions
))
300 (when (not (fboundp (setq fun
(nnoo-symbol backend function
))))
303 (nnheader-report ',backend
,(format "%s-%s not implemented"
304 backend function
))))))))
307 ;;; nnoo.el ends here.