| 1 | ;;; nnoo.el --- OO Gnus Backends |
| 2 | |
| 3 | ;; Copyright (C) 1996-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 6 | ;; Keywords: news |
| 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 | ;;; Code: |
| 26 | |
| 27 | (require 'nnheader) |
| 28 | (eval-when-compile (require 'cl)) |
| 29 | |
| 30 | (defvar nnoo-definition-alist nil) |
| 31 | (defvar nnoo-state-alist nil) |
| 32 | (defvar nnoo-parent-backend nil) |
| 33 | |
| 34 | (defmacro defvoo (var init &optional doc &rest map) |
| 35 | "The same as `defvar', only takes list of variables to MAP to." |
| 36 | `(prog1 |
| 37 | ,(if doc |
| 38 | `(defvar ,var ,init ,(concat doc "\n\nThis is a Gnus server variable. See Info node `(gnus)Select Methods'.")) |
| 39 | `(defvar ,var ,init)) |
| 40 | (nnoo-define ',var ',map))) |
| 41 | (put 'defvoo 'lisp-indent-function 2) |
| 42 | (put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map)) |
| 43 | |
| 44 | (defmacro deffoo (func args &rest forms) |
| 45 | "The same as `defun', only register FUNC." |
| 46 | `(prog1 |
| 47 | (defun ,func ,args ,@forms) |
| 48 | (nnoo-register-function ',func))) |
| 49 | (put 'deffoo 'lisp-indent-function 2) |
| 50 | (put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body)) |
| 51 | |
| 52 | (defun nnoo-register-function (func) |
| 53 | (let ((funcs (nthcdr 3 (assoc (nnoo-backend func) |
| 54 | nnoo-definition-alist)))) |
| 55 | (unless funcs |
| 56 | (error "%s belongs to a backend that hasn't been declared" func)) |
| 57 | (setcar funcs (cons func (car funcs))))) |
| 58 | |
| 59 | (defmacro nnoo-declare (backend &rest parents) |
| 60 | `(eval-and-compile |
| 61 | (if (assq ',backend nnoo-definition-alist) |
| 62 | (setcar (cdr (assq ',backend nnoo-definition-alist)) |
| 63 | (mapcar 'list ',parents)) |
| 64 | (push (list ',backend |
| 65 | (mapcar 'list ',parents) |
| 66 | nil nil) |
| 67 | nnoo-definition-alist)) |
| 68 | (unless (assq ',backend nnoo-state-alist) |
| 69 | (push (list ',backend "*internal-non-initialized-backend*") |
| 70 | nnoo-state-alist)))) |
| 71 | (put 'nnoo-declare 'lisp-indent-function 1) |
| 72 | |
| 73 | (defun nnoo-parents (backend) |
| 74 | (nth 1 (assoc backend nnoo-definition-alist))) |
| 75 | |
| 76 | (defun nnoo-variables (backend) |
| 77 | (nth 2 (assoc backend nnoo-definition-alist))) |
| 78 | |
| 79 | (defun nnoo-functions (backend) |
| 80 | (nth 3 (assoc backend nnoo-definition-alist))) |
| 81 | |
| 82 | (defmacro nnoo-import (backend &rest imports) |
| 83 | `(nnoo-import-1 ',backend ',imports)) |
| 84 | (put 'nnoo-import 'lisp-indent-function 1) |
| 85 | |
| 86 | (defun nnoo-import-1 (backend imports) |
| 87 | (let ((call-function |
| 88 | (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function)) |
| 89 | imp functions function) |
| 90 | (while (setq imp (pop imports)) |
| 91 | (setq functions |
| 92 | (or (cdr imp) |
| 93 | (nnoo-functions (car imp)))) |
| 94 | (while functions |
| 95 | (unless (fboundp |
| 96 | (setq function |
| 97 | (nnoo-symbol backend |
| 98 | (nnoo-rest-symbol (car functions))))) |
| 99 | (eval `(deffoo ,function (&rest args) |
| 100 | (,call-function ',backend ',(car functions) args)))) |
| 101 | (pop functions))))) |
| 102 | |
| 103 | (defun nnoo-parent-function (backend function args) |
| 104 | (let ((pbackend (nnoo-backend function)) |
| 105 | (nnoo-parent-backend backend)) |
| 106 | (nnoo-change-server pbackend |
| 107 | (nnoo-current-server backend) |
| 108 | (cdr (assq pbackend (nnoo-parents backend)))) |
| 109 | (prog1 |
| 110 | (apply function args) |
| 111 | ;; Copy the changed variables back into the child. |
| 112 | (let ((vars (cdr (assq pbackend (nnoo-parents backend))))) |
| 113 | (while vars |
| 114 | (set (cadar vars) (symbol-value (caar vars))) |
| 115 | (setq vars (cdr vars))))))) |
| 116 | |
| 117 | (defun nnoo-execute (backend function &rest args) |
| 118 | "Execute FUNCTION on behalf of BACKEND." |
| 119 | (let ((pbackend (nnoo-backend function)) |
| 120 | (nnoo-parent-backend backend)) |
| 121 | (nnoo-change-server pbackend |
| 122 | (nnoo-current-server backend) |
| 123 | (cdr (assq pbackend (nnoo-parents backend)))) |
| 124 | (prog1 |
| 125 | (apply function args) |
| 126 | ;; Copy the changed variables back into the child. |
| 127 | (let ((vars (cdr (assq pbackend (nnoo-parents backend))))) |
| 128 | (while vars |
| 129 | (set (cadar vars) (symbol-value (caar vars))) |
| 130 | (setq vars (cdr vars))))))) |
| 131 | |
| 132 | (defmacro nnoo-map-functions (backend &rest maps) |
| 133 | `(nnoo-map-functions-1 ',backend ',maps)) |
| 134 | (put 'nnoo-map-functions 'lisp-indent-function 1) |
| 135 | |
| 136 | (defun nnoo-map-functions-1 (backend maps) |
| 137 | (let (m margs i) |
| 138 | (while (setq m (pop maps)) |
| 139 | (setq i 0 |
| 140 | margs nil) |
| 141 | (while (< i (length (cdr m))) |
| 142 | (if (numberp (nth i (cdr m))) |
| 143 | (push `(nth ,i args) margs) |
| 144 | (push (nth i (cdr m)) margs)) |
| 145 | (incf i)) |
| 146 | (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m))) |
| 147 | (&rest args) |
| 148 | (nnoo-parent-function ',backend ',(car m) |
| 149 | ,(cons 'list (nreverse margs)))))))) |
| 150 | |
| 151 | (defun nnoo-backend (symbol) |
| 152 | (string-match "^[^-]+-" (symbol-name symbol)) |
| 153 | (intern (substring (symbol-name symbol) 0 (1- (match-end 0))))) |
| 154 | |
| 155 | (defun nnoo-rest-symbol (symbol) |
| 156 | (string-match "^[^-]+-" (symbol-name symbol)) |
| 157 | (intern (substring (symbol-name symbol) (match-end 0)))) |
| 158 | |
| 159 | (defun nnoo-symbol (backend symbol) |
| 160 | (intern (format "%s-%s" backend symbol))) |
| 161 | |
| 162 | (defun nnoo-define (var map) |
| 163 | (let* ((backend (nnoo-backend var)) |
| 164 | (def (assq backend nnoo-definition-alist)) |
| 165 | (parents (nth 1 def))) |
| 166 | (unless def |
| 167 | (error "%s belongs to a backend that hasn't been declared" var)) |
| 168 | (setcar (nthcdr 2 def) |
| 169 | (delq (assq var (nth 2 def)) (nth 2 def))) |
| 170 | (setcar (nthcdr 2 def) |
| 171 | (cons (cons var (symbol-value var)) |
| 172 | (nth 2 def))) |
| 173 | (while map |
| 174 | (nconc (assq (nnoo-backend (car map)) parents) |
| 175 | (list (list (pop map) var)))))) |
| 176 | |
| 177 | (defun nnoo-change-server (backend server defs) |
| 178 | (let* ((bstate (cdr (assq backend nnoo-state-alist))) |
| 179 | (current (car bstate)) |
| 180 | (parents (nnoo-parents backend)) |
| 181 | (server (if nnoo-parent-backend |
| 182 | (format "%s+%s" nnoo-parent-backend server) |
| 183 | server)) |
| 184 | (bvariables (nnoo-variables backend)) |
| 185 | state def) |
| 186 | ;; If we don't have a current state, we push an empty state |
| 187 | ;; onto the alist. |
| 188 | (unless bstate |
| 189 | (push (setq bstate (list backend nil)) |
| 190 | nnoo-state-alist) |
| 191 | (pop bstate)) |
| 192 | (if (equal server current) |
| 193 | t |
| 194 | (nnoo-push-server backend current) |
| 195 | (setq state (or (cdr (assoc server (cddr bstate))) |
| 196 | (nnoo-variables backend))) |
| 197 | (while state |
| 198 | (set (caar state) (cdar state)) |
| 199 | (pop state)) |
| 200 | (setcar bstate server) |
| 201 | (unless (cdr (assoc server (cddr bstate))) |
| 202 | (while (setq def (pop defs)) |
| 203 | (unless (assq (car def) bvariables) |
| 204 | (nconc bvariables |
| 205 | (list (cons (car def) (and (boundp (car def)) |
| 206 | (symbol-value (car def))))))) |
| 207 | (if (equal server "*internal-non-initialized-backend*") |
| 208 | (set (car def) (symbol-value (cadr def))) |
| 209 | (set (car def) (cadr def))))) |
| 210 | (while parents |
| 211 | (nnoo-change-server |
| 212 | (caar parents) (format "%s+%s" backend server) |
| 213 | (mapcar (lambda (def) (list (car def) (symbol-value (cadr def)))) |
| 214 | (cdar parents))) |
| 215 | (pop parents)))) |
| 216 | t) |
| 217 | |
| 218 | (defun nnoo-push-server (backend current) |
| 219 | (let ((bstate (assq backend nnoo-state-alist)) |
| 220 | (defs (nnoo-variables backend))) |
| 221 | ;; Remove the old definition. |
| 222 | (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate))) |
| 223 | ;; If this is the first time we push the server (i. e., this is |
| 224 | ;; the nil server), then we update the default values of |
| 225 | ;; all the variables to reflect the current values. |
| 226 | (when (equal current "*internal-non-initialized-backend*") |
| 227 | (let ((defaults (nnoo-variables backend)) |
| 228 | def) |
| 229 | (while (setq def (pop defaults)) |
| 230 | (setcdr def (symbol-value (car def)))))) |
| 231 | (let (state) |
| 232 | (while defs |
| 233 | (push (cons (caar defs) (symbol-value (caar defs))) |
| 234 | state) |
| 235 | (pop defs)) |
| 236 | (nconc bstate (list (cons current state)))))) |
| 237 | |
| 238 | (defsubst nnoo-current-server-p (backend server) |
| 239 | (equal (nnoo-current-server backend) |
| 240 | (if nnoo-parent-backend |
| 241 | (format "%s+%s" nnoo-parent-backend server) |
| 242 | server))) |
| 243 | |
| 244 | (defun nnoo-current-server (backend) |
| 245 | (nth 1 (assq backend nnoo-state-alist))) |
| 246 | |
| 247 | (defun nnoo-close-server (backend &optional server) |
| 248 | (unless server |
| 249 | (setq server (nnoo-current-server backend))) |
| 250 | (when server |
| 251 | (let* ((bstate (cdr (assq backend nnoo-state-alist))) |
| 252 | (defs (assoc server (cdr bstate)))) |
| 253 | (when bstate |
| 254 | (setcar bstate nil) |
| 255 | (setcdr bstate (delq defs (cdr bstate))) |
| 256 | (pop defs) |
| 257 | (while defs |
| 258 | (set (car (pop defs)) nil))))) |
| 259 | t) |
| 260 | |
| 261 | (defun nnoo-close (backend) |
| 262 | (setq nnoo-state-alist |
| 263 | (delq (assq backend nnoo-state-alist) |
| 264 | nnoo-state-alist)) |
| 265 | t) |
| 266 | |
| 267 | (defun nnoo-status-message (backend server) |
| 268 | (nnheader-get-report backend)) |
| 269 | |
| 270 | (defun nnoo-server-opened (backend server) |
| 271 | (and (nnoo-current-server-p backend server) |
| 272 | nntp-server-buffer |
| 273 | (buffer-name nntp-server-buffer))) |
| 274 | |
| 275 | (defmacro nnoo-define-basics (backend) |
| 276 | "Define `close-server', `server-opened' and `status-message'." |
| 277 | `(eval-and-compile |
| 278 | (nnoo-define-basics-1 ',backend))) |
| 279 | |
| 280 | (defun nnoo-define-basics-1 (backend) |
| 281 | (let ((functions '(close-server server-opened status-message))) |
| 282 | (while functions |
| 283 | (eval `(deffoo ,(nnoo-symbol backend (car functions)) |
| 284 | (&optional server) |
| 285 | (,(nnoo-symbol 'nnoo (pop functions)) ',backend server))))) |
| 286 | (eval `(deffoo ,(nnoo-symbol backend 'open-server) |
| 287 | (server &optional defs) |
| 288 | (nnoo-change-server ',backend server defs)))) |
| 289 | |
| 290 | (defmacro nnoo-define-skeleton (backend) |
| 291 | "Define all required backend functions for BACKEND. |
| 292 | All functions will return nil and report an error." |
| 293 | `(eval-and-compile |
| 294 | (nnoo-define-skeleton-1 ',backend))) |
| 295 | |
| 296 | (defun nnoo-define-skeleton-1 (backend) |
| 297 | (let ((functions '(retrieve-headers |
| 298 | request-close request-article |
| 299 | request-group close-group |
| 300 | request-list request-post request-list-newsgroups)) |
| 301 | function fun) |
| 302 | (while (setq function (pop functions)) |
| 303 | (when (not (fboundp (setq fun (nnoo-symbol backend function)))) |
| 304 | (eval `(deffoo ,fun |
| 305 | (&rest args) |
| 306 | (nnheader-report ',backend ,(format "%s-%s not implemented" |
| 307 | backend function)))))))) |
| 308 | |
| 309 | (defun nnoo-set (server &rest args) |
| 310 | (let ((parents (nnoo-parents (car server))) |
| 311 | (nnoo-parent-backend (car server))) |
| 312 | (while parents |
| 313 | (nnoo-change-server (caar parents) |
| 314 | (cadr server) |
| 315 | (cdar parents)) |
| 316 | (pop parents))) |
| 317 | (nnoo-change-server (car server) |
| 318 | (cadr server) (cddr server)) |
| 319 | (while args |
| 320 | (set (pop args) (pop args)))) |
| 321 | |
| 322 | (provide 'nnoo) |
| 323 | |
| 324 | ;;; nnoo.el ends here |