1 ;;; nnoo.el --- OO Gnus Backends
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000
4 ;; 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 2, or (at your option)
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; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
31 (eval-when-compile (require 'cl
))
33 (defvar nnoo-definition-alist nil
)
34 (defvar nnoo-state-alist nil
)
35 (defvar nnoo-parent-backend nil
)
37 (defmacro defvoo
(var init
&optional doc
&rest map
)
38 "The same as `defvar', only takes list of variables to MAP to."
41 `(defvar ,var
,init
,doc
)
43 (nnoo-define ',var
',map
)))
44 (put 'defvoo
'lisp-indent-function
2)
45 (put 'defvoo
'edebug-form-spec
'(var init
&optional doc
&rest map
))
47 (defmacro deffoo
(func args
&rest forms
)
48 "The same as `defun', only register FUNC."
50 (defun ,func
,args
,@forms
)
51 (nnoo-register-function ',func
)))
52 (put 'deffoo
'lisp-indent-function
2)
53 (put 'deffoo
'edebug-form-spec
'(&define name lambda-list def-body
))
55 (defun nnoo-register-function (func)
56 (let ((funcs (nthcdr 3 (assoc (nnoo-backend func
)
57 nnoo-definition-alist
))))
59 (error "%s belongs to a backend that hasn't been declared" func
))
60 (setcar funcs
(cons func
(car funcs
)))))
62 (defmacro nnoo-declare
(backend &rest parents
)
65 (mapcar (lambda (p) (list p
)) ',parents
)
67 nnoo-definition-alist
)
68 (push (list ',backend
"*internal-non-initialized-backend*")
70 (put 'nnoo-declare
'lisp-indent-function
1)
72 (defun nnoo-parents (backend)
73 (nth 1 (assoc backend nnoo-definition-alist
)))
75 (defun nnoo-variables (backend)
76 (nth 2 (assoc backend nnoo-definition-alist
)))
78 (defun nnoo-functions (backend)
79 (nth 3 (assoc backend nnoo-definition-alist
)))
81 (defmacro nnoo-import
(backend &rest imports
)
82 `(nnoo-import-1 ',backend
',imports
))
83 (put 'nnoo-import
'lisp-indent-function
1)
85 (defun nnoo-import-1 (backend imports
)
87 (if (symbolp (car imports
)) (pop imports
) 'nnoo-parent-function
))
88 imp functions function
)
89 (while (setq imp
(pop imports
))
92 (nnoo-functions (car imp
))))
97 (nnoo-rest-symbol (car functions
)))))
98 (eval `(deffoo ,function
(&rest args
)
99 (,call-function
',backend
',(car functions
) args
))))
102 (defun nnoo-parent-function (backend function args
)
103 (let ((pbackend (nnoo-backend function
))
104 (nnoo-parent-backend backend
))
105 (nnoo-change-server pbackend
106 (nnoo-current-server backend
)
107 (cdr (assq pbackend
(nnoo-parents backend
))))
109 (apply function args
)
110 ;; Copy the changed variables back into the child.
111 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
113 (set (cadar vars
) (symbol-value (caar vars
)))
114 (setq vars
(cdr vars
)))))))
116 (defun nnoo-execute (backend function
&rest args
)
117 "Execute FUNCTION on behalf of BACKEND."
118 (let ((pbackend (nnoo-backend function
))
119 (nnoo-parent-backend backend
))
120 (nnoo-change-server pbackend
121 (nnoo-current-server backend
)
122 (cdr (assq pbackend
(nnoo-parents backend
))))
124 (apply function args
)
125 ;; Copy the changed variables back into the child.
126 (let ((vars (cdr (assq pbackend
(nnoo-parents backend
)))))
128 (set (cadar vars
) (symbol-value (caar vars
)))
129 (setq vars
(cdr vars
)))))))
131 (defmacro nnoo-map-functions
(backend &rest maps
)
132 `(nnoo-map-functions-1 ',backend
',maps
))
133 (put 'nnoo-map-functions
'lisp-indent-function
1)
135 (defun nnoo-map-functions-1 (backend maps
)
137 (while (setq m
(pop maps
))
140 (while (< i
(length (cdr m
)))
141 (if (numberp (nth i
(cdr m
)))
142 (push `(nth ,i args
) margs
)
143 (push (nth i
(cdr m
)) margs
))
145 (eval `(deffoo ,(nnoo-symbol backend
(nnoo-rest-symbol (car m
)))
147 (nnoo-parent-function ',backend
',(car m
)
148 ,(cons 'list
(nreverse margs
))))))))
150 (defun nnoo-backend (symbol)
151 (string-match "^[^-]+-" (symbol-name symbol
))
152 (intern (substring (symbol-name symbol
) 0 (1- (match-end 0)))))
154 (defun nnoo-rest-symbol (symbol)
155 (string-match "^[^-]+-" (symbol-name symbol
))
156 (intern (substring (symbol-name symbol
) (match-end 0))))
158 (defun nnoo-symbol (backend symbol
)
159 (intern (format "%s-%s" backend symbol
)))
161 (defun nnoo-define (var map
)
162 (let* ((backend (nnoo-backend var
))
163 (def (assq backend nnoo-definition-alist
))
164 (parents (nth 1 def
)))
166 (error "%s belongs to a backend that hasn't been declared" var
))
167 (setcar (nthcdr 2 def
)
168 (delq (assq var
(nth 2 def
)) (nth 2 def
)))
169 (setcar (nthcdr 2 def
)
170 (cons (cons var
(symbol-value var
))
173 (nconc (assq (nnoo-backend (car map
)) parents
)
174 (list (list (pop map
) var
))))))
176 (defun nnoo-change-server (backend server defs
)
177 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
178 (current (car bstate
))
179 (parents (nnoo-parents backend
))
180 (server (if nnoo-parent-backend
181 (format "%s+%s" nnoo-parent-backend server
)
183 (bvariables (nnoo-variables backend
))
185 ;; If we don't have a current state, we push an empty state
188 (push (setq bstate
(list backend nil
))
191 (if (equal server current
)
193 (nnoo-push-server backend current
)
194 (setq state
(or (cdr (assoc server
(cddr bstate
)))
195 (nnoo-variables backend
)))
197 (set (caar state
) (cdar state
))
199 (setcar bstate server
)
200 (unless (cdr (assoc server
(cddr bstate
)))
201 (while (setq def
(pop defs
))
202 (unless (assq (car def
) bvariables
)
204 (list (cons (car def
) (and (boundp (car def
))
205 (symbol-value (car def
)))))))
206 (if (equal server
"*internal-non-initialized-backend*")
207 (set (car def
) (symbol-value (cadr def
)))
208 (set (car def
) (cadr def
)))))
211 (caar parents
) (format "%s+%s" backend server
)
212 (mapcar (lambda (def) (list (car def
) (symbol-value (cadr def
))))
217 (defun nnoo-push-server (backend current
)
218 (let ((bstate (assq backend nnoo-state-alist
))
219 (defs (nnoo-variables backend
)))
220 ;; Remove the old definition.
221 (setcdr (cdr bstate
) (delq (assoc current
(cddr bstate
)) (cddr bstate
)))
222 ;; If this is the first time we push the server (i. e., this is
223 ;; the nil server), then we update the default values of
224 ;; all the variables to reflect the current values.
225 (when (equal current
"*internal-non-initialized-backend*")
226 (let ((defaults (nnoo-variables backend
))
228 (while (setq def
(pop defaults
))
229 (setcdr def
(symbol-value (car def
))))))
232 (push (cons (caar defs
) (symbol-value (caar defs
)))
235 (nconc bstate
(list (cons current state
))))))
237 (defsubst nnoo-current-server-p
(backend server
)
238 (equal (nnoo-current-server backend
)
239 (if nnoo-parent-backend
240 (format "%s+%s" nnoo-parent-backend server
)
243 (defun nnoo-current-server (backend)
244 (nth 1 (assq backend nnoo-state-alist
)))
246 (defun nnoo-close-server (backend &optional server
)
248 (setq server
(nnoo-current-server backend
)))
250 (let* ((bstate (cdr (assq backend nnoo-state-alist
)))
251 (defs (assoc server
(cdr bstate
))))
254 (setcdr bstate
(delq defs
(cdr bstate
)))
257 (set (car (pop defs
)) nil
)))))
260 (defun nnoo-close (backend)
261 (setq nnoo-state-alist
262 (delq (assq backend nnoo-state-alist
)
266 (defun nnoo-status-message (backend server
)
267 (nnheader-get-report backend
))
269 (defun nnoo-server-opened (backend server
)
270 (and (nnoo-current-server-p backend server
)
272 (buffer-name nntp-server-buffer
)))
274 (defmacro nnoo-define-basics
(backend)
275 "Define `close-server', `server-opened' and `status-message'."
277 (nnoo-define-basics-1 ',backend
)))
279 (defun nnoo-define-basics-1 (backend)
280 (let ((functions '(close-server server-opened status-message
)))
282 (eval `(deffoo ,(nnoo-symbol backend
(car functions
))
284 (,(nnoo-symbol 'nnoo
(pop functions
)) ',backend server
)))))
285 (eval `(deffoo ,(nnoo-symbol backend
'open-server
)
286 (server &optional defs
)
287 (nnoo-change-server ',backend server defs
))))
289 (defmacro nnoo-define-skeleton
(backend)
290 "Define all required backend functions for BACKEND.
291 All functions will return nil and report an error."
293 (nnoo-define-skeleton-1 ',backend
)))
295 (defun nnoo-define-skeleton-1 (backend)
296 (let ((functions '(retrieve-headers
297 request-close request-article
298 request-group close-group
299 request-list request-post request-list-newsgroups
))
301 (while (setq function
(pop functions
))
302 (when (not (fboundp (setq fun
(nnoo-symbol backend function
))))
305 (nnheader-report ',backend
,(format "%s-%s not implemented"
306 backend function
))))))))
309 ;;; nnoo.el ends here.