summaryrefslogtreecommitdiffstats
path: root/emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base
diff options
context:
space:
mode:
authorAlexander Sulfrian <alexander@sulfrian.net>2009-11-19 01:44:52 +0100
committerAlexander Sulfrian <alexander@sulfrian.net>2009-11-19 01:44:52 +0100
commit07963cfc7b5bd985bf01ef22c90970501104352d (patch)
tree8166a4c5ff56dfb5a2c8860cd34cb2c04d601fd3 /emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base
parent91d3e89c924fb8a932599ccfcf18bc364878ac17 (diff)
downloaddotfiles-07963cfc7b5bd985bf01ef22c90970501104352d.tar.gz
dotfiles-07963cfc7b5bd985bf01ef22c90970501104352d.tar.xz
dotfiles-07963cfc7b5bd985bf01ef22c90970501104352d.zip
added rudel (obby and other colab framework for emacs)
Diffstat (limited to '')
-rw-r--r--emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base305
1 files changed, 305 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base b/emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base
new file mode 100644
index 0000000..79cfef6
--- /dev/null
+++ b/emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base
@@ -0,0 +1,305 @@
+;;; rudel-backend.el --- A generic backend management mechanism for Rudel
+;;
+;; Copyright (C) 2009 Jan Moringen
+;;
+;; Author: Jan Moringen <scymtym@users.sourceforge.net>
+;; Keywords: Rudel, backend, factory
+;; X-RCS: $Id:$
+;;
+;; This file is part of Rudel.
+;;
+;; Rudel is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; Rudel is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with Rudel. If not, see <http://www.gnu.org/licenses>.
+
+
+;;; Commentary:
+;;
+;; This file contains a generic mechanism that handles registration,
+;; query and instantiation of Rudel backends for any number of
+;; functional categories.
+;;
+;; The class and collaboration design is as follows: for each
+;; category, which is identified by a symbol, there is a factory
+;; object (an instance of `rudel-backend-factory') that is responsible
+;; for creating backend objects of the category. Examples of
+;; categories are 'transport', 'protocol' and 'session-initiation'.
+;; In addition to creating backend object, factories also allow
+;; querying backends based on desired capabilities and load backend
+;; implementations only when required.
+
+
+;;; History:
+;;
+;; 0.1 - Initial revision
+
+
+;;; Code:
+;;
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'eieio)
+
+
+;;; Class rudel-backend
+;;
+
+(defclass rudel-backend ()
+ ((version :initarg :version
+ :type list
+ :documentation
+ "A list of the form (MAJOR MINOR [MICRO
+WHATEVER*]) describing the version of the backend.")
+ (capabilities :initarg :capabilities
+ :type list
+ :initform nil
+ :documentation
+ "A list of symbols, or lists whose car is a
+symbol, that each describe one capability of the backend."))
+ "Base class for backend classes."
+ :abstract t)
+
+(defmethod rudel-capable-of-p ((this rudel-backend) capability)
+ "Return t if the backend THIS is capable of CAPABILITY."
+ (with-slots (capabilities) this
+ (member capability capabilities)))
+
+
+;;; Class rudel-backend-factory
+;;
+
+(defclass rudel-backend-factory ()
+ ((backends :initarg :backends
+ :type hash-table
+ :documentation
+ "Mapping of symbolic names to classes (prior to
+instantiation) or objects (after instantiation) for all backends
+known to the factory object.")
+ (factories :type hash-table
+ :allocation :class
+ :documentation
+ "Mapping of backend categories to responsible
+factory objects."))
+ "Factory class that holds an object for each known backend
+category. Objects manage backend implementation for one backend
+category each.")
+(oset-default rudel-backend-factory factories
+ (make-hash-table :test #'eq))
+
+(defmethod initialize-instance ((this rudel-backend-factory) &rest slots)
+ "Initialize slots of THIS with SLOTS."
+ (when (next-method-p)
+ (call-next-method))
+ (oset this :backends (make-hash-table :test #'eq)))
+
+;;;###autoload
+(defmethod rudel-get-factory :static ((this rudel-backend-factory)
+ category)
+ "Return the factory responsible for CATEGORY.
+If there is no responsible factory, create one and return it."
+ (with-slots (factories) this
+ (or (gethash category factories)
+ (puthash category (rudel-backend-factory category) factories)))
+ )
+
+;;;###autoload
+(defmethod rudel-add-backend ((this rudel-backend-factory)
+ name class &optional replace)
+ "Add factory class CLASS with name NAME to THIS.
+if REPLACE is non-nil, replace a registered implementation of the
+same name."
+ (with-slots (backends) this
+ (when (or (not (gethash name backends))
+ replace)
+ (puthash name class backends))))
+
+(defmethod rudel-get-backend ((this rudel-backend-factory) name)
+ "Return backend object for name NAME or nil if there is none.
+The returned backend is of the form (NAME . OBJECT).
+
+Backends are loaded, if necessary."
+ ;; Load all available backends
+ (rudel-load-backends this)
+
+ ;; Find the backend and return it.
+ (with-slots (backends) this
+ (let ((backend (gethash name backends)))
+ (when backend
+ (cons name backend))))
+ )
+
+(defmethod rudel-all-backends ((this rudel-backend-factory))
+ "Return a list of all backends registered with THIS.
+Each list element is of the form (NAME . CLASS-OR-OBJECT)."
+ (let ((backend-list))
+ (with-slots (backends) this
+ (maphash (lambda (name class)
+ (push (cons name class) backend-list))
+ backends))
+ backend-list)
+ )
+
+(defmethod rudel-suitable-backends ((this rudel-backend-factory) predicate)
+ "Return a list of backends which satisfy PREDICATE.
+Each list element is of the form (NAME . OBJECT).
+Backends are loaded, if necessary."
+ ;; Load all available backends
+ (rudel-load-backends this)
+
+ ;; Retrieve and return all backends, possibly filtering the list
+ ;; using PREDICATE.
+ (if predicate
+ (remove-if-not
+ (lambda (cell)
+ (and (object-p (cdr cell))
+ (funcall predicate (cdr cell))))
+ (rudel-all-backends this))
+ (rudel-all-backends this))
+ )
+
+(defmethod rudel-load-backends ((this rudel-backend-factory))
+ "Load backends in THIS factory if necessary.
+Loading errors are not reported explicitly, but can be detected
+by checking for backends that still are classes rather than
+objects."
+ ;; Map lambda that loads unloaded backends over all backends. Store
+ ;; objects back after loading.
+ (with-slots (backends) this
+ (maphash
+ (lambda (name class)
+ (unless (object-p class)
+ (condition-case error
+ (puthash name (make-instance
+ class (symbol-name name)) backends)
+ (error (display-warning
+ '(rudel backend)
+ (format "Could not load backend `%s': %s"
+ name
+ (error-message-string error))
+ :warning)))))
+ backends))
+ )
+
+
+;;; High-level frontend functions
+;;
+
+(defsubst rudel-backend-cons-p (cell)
+ "Check whether CELL is a cons of a backend name and object."
+ (and (consp cell)
+ (symbolp (car cell))
+ (object-p (cdr cell))))
+
+;;;###autoload
+(defun rudel-backend-get (category name)
+ "A shortcut for getting backend NAME of category CATEGORY.
+The returned backend is of the form (NAME . OBJECT)."
+ (rudel-get-backend (rudel-backend-get-factory category) name))
+
+;;;###autoload
+(defun rudel-backend-get-factory (category)
+ "A shortcut for getting the factory object for CATEGORY."
+ (rudel-get-factory rudel-backend-factory category))
+
+(defun rudel-backend-suitable-backends (category predicate)
+ "Return backends from category CATEGORY that satisfy PREDICATE.
+Each list element is of the form (NAME . OBJECT)."
+ (rudel-suitable-backends
+ (rudel-backend-get-factory category)
+ predicate))
+
+(defun rudel-backend-choose (category &optional predicate)
+ "Choose a backend from CATEGORY satisfying PREDICATE automatically or by asking the user.
+The returned backend is of the form (NAME . CLASS-OR-OBJECT)."
+ (let ((backends (rudel-backend-suitable-backends
+ category predicate)))
+ (unless backends
+ (error "No backends available"))
+
+ (if (= (length backends) 1)
+ ;; If there is only one backend, we can choose that one right
+ ;; away displaying a message to avoid confusing the user.
+ (let ((backend (nth 0 backends)))
+ (message "Using backend `%s'" (symbol-name (car backend)))
+ (sit-for 0.5)
+ backend)
+
+ ;; When we have more than one backend, we have to ask the user,
+ ;; which one she wants.
+ (require 'rudel-interactive)
+ (rudel-read-backend backends nil 'object)))
+ )
+
+
+;;; User interaction functions
+;;
+
+(defun rudel-backend-dump (&optional load)
+ "Create display information about backends in a buffer.
+If LOAD is non-nil, load all backends before display. This makes
+available information available for the backends"
+ (interactive "p")
+ (save-excursion
+ ;; Setup a new buffer.
+ (set-buffer (get-buffer-create "*Rudel Backends*"))
+ (erase-buffer)
+ (set-window-buffer nil (current-buffer))
+ (maphash
+ (lambda (category factory)
+ ;; Load backends if requested.
+ (unless (zerop load)
+ (rudel-load-backends factory))
+
+ ;; Insert header for this category.
+ (insert (propertize
+ (format "Category %s\n" category)
+ 'face 'bold))
+ (insert (apply #'format
+ " %-20s %-6s %-7s %s\n"
+ (mapcar
+ (lambda (header)
+ (propertize header 'face 'italic))
+ '("name" "loaded" "version" "capabilities"))))
+
+ ;; Insert all backends provided by this factory.
+ (dolist (backend (rudel-all-backends factory))
+ (insert (format " %-20s %-6s %-7s (%s)\n"
+ (propertize
+ (symbol-name (car backend))
+ 'face 'font-lock-type-face)
+ (propertize
+ (prin1-to-string (object-p (cdr backend)))
+ 'face 'font-lock-variable-name-face)
+ (propertize
+ (if (object-p (cdr backend))
+ (mapconcat #'prin1-to-string
+ (oref (cdr backend) :version)
+ ".")
+ "?")
+ 'face 'font-lock-constant-face)
+ (propertize
+ (if (object-p (cdr backend))
+ (mapconcat #'prin1-to-string
+ (oref (cdr backend) :capabilities)
+ " ")
+ "?")
+ 'face 'font-lock-constant-face))))
+
+ ;; One empty line between backend categories.
+ (insert "\n"))
+ (oref rudel-backend-factory factories)))
+ )
+
+(provide 'rudel-backend)
+;;; rudel-backend.el ends here