From 07963cfc7b5bd985bf01ef22c90970501104352d Mon Sep 17 00:00:00 2001 From: Alexander Sulfrian Date: Thu, 19 Nov 2009 01:44:52 +0100 Subject: added rudel (obby and other colab framework for emacs) --- .../rudel/.svn/text-base/rudel-backend.el.svn-base | 305 +++++++++++++++++++++ 1 file changed, 305 insertions(+) create mode 100644 emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base (limited to 'emacs.d/lisp/rudel/.svn/text-base/rudel-backend.el.svn-base') 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 +;; 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 . + + +;;; 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 -- cgit v1.2.3