Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnoo.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents e04119814345
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; nnoo.el --- OO Gnus Backends 1 ;;; nnoo.el --- OO Gnus Backends
2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
23 23
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'nnheader) 28 (eval-when-compile (require 'cl))
29 (require 'cl)
30 29
31 (defvar nnoo-definition-alist nil) 30 (defvar nnoo-definition-alist nil)
32 (defvar nnoo-state-alist nil) 31 (defvar nnoo-state-alist nil)
33 32
34 (defmacro defvoo (var init &optional doc &rest map) 33 (defmacro defvoo (var init &optional doc &rest map)
37 ,(if doc 36 ,(if doc
38 `(defvar ,var ,init ,doc) 37 `(defvar ,var ,init ,doc)
39 `(defvar ,var ,init)) 38 `(defvar ,var ,init))
40 (nnoo-define ',var ',map))) 39 (nnoo-define ',var ',map)))
41 (put 'defvoo 'lisp-indent-function 2) 40 (put 'defvoo 'lisp-indent-function 2)
41 (put 'defvoo 'lisp-indent-hook 2)
42 (put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map)) 42 (put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map))
43 43
44 (defmacro deffoo (func args &rest forms) 44 (defmacro deffoo (func args &rest forms)
45 "The same as `defun', only register FUNC." 45 "The same as `defun', only register FUNC."
46 `(prog1 46 `(prog1
47 (defun ,func ,args ,@forms) 47 (defun ,func ,args ,@forms)
48 (nnoo-register-function ',func))) 48 (nnoo-register-function ',func)))
49 (put 'deffoo 'lisp-indent-function 2) 49 (put 'deffoo 'lisp-indent-function 2)
50 (put 'deffoo 'lisp-indent-hook 2)
50 (put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body)) 51 (put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body))
51 52
52 (defun nnoo-register-function (func) 53 (defun nnoo-register-function (func)
53 (let ((funcs (nthcdr 3 (assoc (nnoo-backend func) 54 (let ((funcs (nthcdr 3 (assoc (nnoo-backend func)
54 nnoo-definition-alist)))) 55 nnoo-definition-alist))))
55 (unless funcs 56 (unless funcs
56 (error "%s belongs to a backend that hasn't been declared" func)) 57 (error "%s belongs to a backend that hasn't been declared" func))
57 (setcar funcs (cons func (car funcs))))) 58 (setcar funcs (cons func (car funcs)))))
58 59
59 (defmacro nnoo-declare (backend &rest parents) 60 (defmacro nnoo-declare (backend &rest parents)
60 `(eval-and-compile 61 `(eval-and-compile
61 (push (list ',backend 62 (push (list ',backend
62 (mapcar (lambda (p) (list p)) ',parents) 63 (mapcar (lambda (p) (list p)) ',parents)
63 nil nil) 64 nil nil)
64 nnoo-definition-alist) 65 nnoo-definition-alist)))
65 (push (list ',backend "*internal-non-initialized-backend*")
66 nnoo-state-alist)))
67 (put 'nnoo-declare 'lisp-indent-function 1) 66 (put 'nnoo-declare 'lisp-indent-function 1)
67 (put 'nnoo-declare 'lisp-indent-hook 1)
68 68
69 (defun nnoo-parents (backend) 69 (defun nnoo-parents (backend)
70 (nth 1 (assoc backend nnoo-definition-alist))) 70 (nth 1 (assoc backend nnoo-definition-alist)))
71 71
72 (defun nnoo-variables (backend) 72 (defun nnoo-variables (backend)
76 (nth 3 (assoc backend nnoo-definition-alist))) 76 (nth 3 (assoc backend nnoo-definition-alist)))
77 77
78 (defmacro nnoo-import (backend &rest imports) 78 (defmacro nnoo-import (backend &rest imports)
79 `(nnoo-import-1 ',backend ',imports)) 79 `(nnoo-import-1 ',backend ',imports))
80 (put 'nnoo-import 'lisp-indent-function 1) 80 (put 'nnoo-import 'lisp-indent-function 1)
81 (put 'nnoo-import 'lisp-indent-hook 1)
81 82
82 (defun nnoo-import-1 (backend imports) 83 (defun nnoo-import-1 (backend imports)
83 (let ((call-function 84 (let ((call-function
84 (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function)) 85 (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function))
85 imp functions function) 86 imp functions function)
88 (or (cdr imp) 89 (or (cdr imp)
89 (nnoo-functions (car imp)))) 90 (nnoo-functions (car imp))))
90 (while functions 91 (while functions
91 (unless (fboundp (setq function 92 (unless (fboundp (setq function
92 (nnoo-symbol backend (nnoo-rest-symbol 93 (nnoo-symbol backend (nnoo-rest-symbol
93 (car functions))))) 94 (car functions)))))
94 (eval `(deffoo ,function (&rest args) 95 (eval `(deffoo ,function (&rest args)
95 (,call-function ',backend ',(car functions) args)))) 96 (,call-function ',backend ',(car functions) args))))
96 (pop functions))))) 97 (pop functions)))))
97 98
98 (defun nnoo-parent-function (backend function args) 99 (defun nnoo-parent-function (backend function args)
109 (apply function args))) 110 (apply function args)))
110 111
111 (defmacro nnoo-map-functions (backend &rest maps) 112 (defmacro nnoo-map-functions (backend &rest maps)
112 `(nnoo-map-functions-1 ',backend ',maps)) 113 `(nnoo-map-functions-1 ',backend ',maps))
113 (put 'nnoo-map-functions 'lisp-indent-function 1) 114 (put 'nnoo-map-functions 'lisp-indent-function 1)
115 (put 'nnoo-map-functions 'lisp-indent-hook 1)
114 116
115 (defun nnoo-map-functions-1 (backend maps) 117 (defun nnoo-map-functions-1 (backend maps)
116 (let (m margs i) 118 (let (m margs i)
117 (while (setq m (pop maps)) 119 (while (setq m (pop maps))
118 (setq i 0 120 (setq i 0
122 (push `(nth ,i args) margs) 124 (push `(nth ,i args) margs)
123 (push (nth i (cdr m)) margs)) 125 (push (nth i (cdr m)) margs))
124 (incf i)) 126 (incf i))
125 (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) 127 (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
126 (&rest args) 128 (&rest args)
127 (nnoo-parent-function ',backend ',(car m) 129 (nnoo-parent-function ',backend ',(car m)
128 ,(cons 'list (nreverse margs)))))))) 130 ,(cons 'list (nreverse margs))))))))
129 131
130 (defun nnoo-backend (symbol) 132 (defun nnoo-backend (symbol)
131 (string-match "^[^-]+-" (symbol-name symbol)) 133 (string-match "^[^-]+-" (symbol-name symbol))
132 (intern (substring (symbol-name symbol) 0 (1- (match-end 0))))) 134 (intern (substring (symbol-name symbol) 0 (1- (match-end 0)))))
133 135
134 (defun nnoo-rest-symbol (symbol) 136 (defun nnoo-rest-symbol (symbol)
142 (let* ((backend (nnoo-backend var)) 144 (let* ((backend (nnoo-backend var))
143 (def (assq backend nnoo-definition-alist)) 145 (def (assq backend nnoo-definition-alist))
144 (parents (nth 1 def))) 146 (parents (nth 1 def)))
145 (unless def 147 (unless def
146 (error "%s belongs to a backend that hasn't been declared." var)) 148 (error "%s belongs to a backend that hasn't been declared." var))
147 (setcar (nthcdr 2 def) 149 (setcar (nthcdr 2 def)
148 (delq (assq var (nth 2 def)) (nth 2 def))) 150 (delq (assq var (nth 2 def)) (nth 2 def)))
149 (setcar (nthcdr 2 def) 151 (setcar (nthcdr 2 def)
150 (cons (cons var (symbol-value var)) 152 (cons (cons var (symbol-value var))
151 (nth 2 def))) 153 (nth 2 def)))
152 (while map 154 (while map
153 (nconc (assq (nnoo-backend (car map)) parents) 155 (nconc (assq (nnoo-backend (car map)) parents)
154 (list (list (pop map) var)))))) 156 (list (list (pop map) var))))))
155 157
156 (defun nnoo-change-server (backend server defs) 158 (defun nnoo-change-server (backend server defs)
157 (let* ((bstate (cdr (assq backend nnoo-state-alist))) 159 (let* ((bstate (cdr (assq backend nnoo-state-alist)))
160 (sdefs (assq backend nnoo-definition-alist))
158 (current (car bstate)) 161 (current (car bstate))
159 (parents (nnoo-parents backend)) 162 (parents (nnoo-parents backend))
160 (bvariables (nnoo-variables backend)) 163 state)
161 state def)
162 (unless bstate 164 (unless bstate
163 (push (setq bstate (list backend nil)) 165 (push (setq bstate (list backend nil))
164 nnoo-state-alist) 166 nnoo-state-alist)
165 (pop bstate)) 167 (pop bstate))
166 (if (equal server current) 168 (if (equal server current)
171 (while state 173 (while state
172 (set (caar state) (cdar state)) 174 (set (caar state) (cdar state))
173 (pop state)) 175 (pop state))
174 (setcar bstate server) 176 (setcar bstate server)
175 (unless (cdr (assoc server (cddr bstate))) 177 (unless (cdr (assoc server (cddr bstate)))
176 (while (setq def (pop defs)) 178 (while defs
177 (unless (assq (car def) bvariables) 179 (set (caar defs) (cadar defs))
178 (nconc bvariables 180 (pop defs)))
179 (list (cons (car def) (and (boundp (car def))
180 (symbol-value (car def)))))))
181 (set (car def) (cadr def))))
182 (while parents 181 (while parents
183 (nnoo-change-server 182 (nnoo-change-server
184 (caar parents) server 183 (caar parents) server
185 (mapcar (lambda (def) (list (car def) (symbol-value (cadr def)))) 184 (mapcar (lambda (def) (list (car def) (symbol-value (cadr def))))
186 (cdar parents))) 185 (cdar parents)))
187 (pop parents)))) 186 (pop parents))))
188 t) 187 t)
189 188
190 (defun nnoo-push-server (backend current) 189 (defun nnoo-push-server (backend current)
191 (let ((bstate (assq backend nnoo-state-alist)) 190 (let ((bstate (assq backend nnoo-state-alist))
192 (defs (nnoo-variables backend))) 191 (defs (nnoo-variables backend)))
193 ;; Remove the old definition. 192 ;; Remove the old definition.
194 (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate))) 193 (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate)))
195 ;; If this is the first time we push the server (i. e., this is
196 ;; the nil server), then we update the default values of
197 ;; all the variables to reflect the current values.
198 (when (equal current "*internal-non-initialized-backend*")
199 (let ((defaults (nnoo-variables backend))
200 def)
201 (while (setq def (pop defaults))
202 (setcdr def (symbol-value (car def))))))
203 (let (state) 194 (let (state)
204 (while defs 195 (while defs
205 (push (cons (caar defs) (symbol-value (caar defs))) 196 (push (cons (caar defs) (symbol-value (caar defs)))
206 state) 197 state)
207 (pop defs)) 198 (pop defs))
208 (nconc bstate (list (cons current state)))))) 199 (nconc bstate (list (cons current state))))))
209 200
210 (defsubst nnoo-current-server-p (backend server) 201 (defun nnoo-current-server-p (backend server)
211 (equal (nnoo-current-server backend) server)) 202 (equal (nnoo-current-server backend) server))
212 203
213 (defun nnoo-current-server (backend) 204 (defun nnoo-current-server (backend)
214 (nth 1 (assq backend nnoo-state-alist))) 205 (nth 1 (assq backend nnoo-state-alist)))
215 206
240 (and (nnoo-current-server-p backend server) 231 (and (nnoo-current-server-p backend server)
241 nntp-server-buffer 232 nntp-server-buffer
242 (buffer-name nntp-server-buffer))) 233 (buffer-name nntp-server-buffer)))
243 234
244 (defmacro nnoo-define-basics (backend) 235 (defmacro nnoo-define-basics (backend)
245 "Define `close-server', `server-opened' and `status-message'."
246 `(eval-and-compile 236 `(eval-and-compile
247 (nnoo-define-basics-1 ',backend))) 237 (nnoo-define-basics-1 ',backend)))
248 238
249 (defun nnoo-define-basics-1 (backend) 239 (defun nnoo-define-basics-1 (backend)
250 (let ((functions '(close-server server-opened status-message))) 240 (let ((functions '(close-server server-opened status-message)))
251 (while functions 241 (while functions
252 (eval `(deffoo ,(nnoo-symbol backend (car functions)) 242 (eval `(deffoo ,(nnoo-symbol backend (car functions))
253 (&optional server) 243 (&optional server)
254 (,(nnoo-symbol 'nnoo (pop functions)) ',backend server))))) 244 (,(nnoo-symbol 'nnoo (pop functions)) ',backend server)))))
255 (eval `(deffoo ,(nnoo-symbol backend 'open-server) 245 (eval `(deffoo ,(nnoo-symbol backend 'open-server)
256 (server &optional defs) 246 (server &optional defs)
257 (nnoo-change-server ',backend server defs)))) 247 (nnoo-change-server ',backend server defs))))
258 248
259 (defmacro nnoo-define-skeleton (backend)
260 "Define all required backend functions for BACKEND.
261 All functions will return nil and report an error."
262 `(eval-and-compile
263 (nnoo-define-skeleton-1 ',backend)))
264
265 (defun nnoo-define-skeleton-1 (backend)
266 (let ((functions '(retrieve-headers
267 request-close request-article
268 request-group close-group
269 request-list request-post request-list-newsgroups))
270 function fun)
271 (while (setq function (pop functions))
272 (when (not (fboundp (setq fun (nnoo-symbol backend function))))
273 (eval `(deffoo ,fun
274 (&rest args)
275 (nnheader-report ',backend ,(format "%s-%s not implemented"
276 backend function))))))))
277 (provide 'nnoo) 249 (provide 'nnoo)
278 250
279 ;;; nnoo.el ends here. 251 ;;; nnoo.el ends here.