diff options
Diffstat (limited to 'jabber-fallback-lib/fsm.el')
| -rw-r--r-- | jabber-fallback-lib/fsm.el | 421 |
1 files changed, 421 insertions, 0 deletions
diff --git a/jabber-fallback-lib/fsm.el b/jabber-fallback-lib/fsm.el new file mode 100644 index 0000000..e97dc09 --- /dev/null +++ b/jabber-fallback-lib/fsm.el @@ -0,0 +1,421 @@ +;;; fsm.el --- state machine library + +;; Copyright (C) 2006, 2007, 2008 Magnus Henoch + +;; Author: Magnus Henoch <mange@freemail.hu> +;; Version: 0.1ttn4 + +;; This file 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 2, or (at your option) +;; any later version. + +;; This file 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of +;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp +;; easy and fun. By "asynchronous" I mean that long-lasting tasks +;; don't interfer with normal editing. + +;; Some people say that it would be nice if Emacs Lisp had threads +;; and/or continuations. They are probably right, but there are few +;; things that can't be made to run in the background using facilities +;; already available: timers, filters and sentinels. As the code can +;; become a bit messy when using such means, with callbacks everywhere +;; and such things, it can be useful to structure the program as a +;; state machine. + +;; In this model, a state machine passes between different "states", +;; which are actually only different event handler functions. The +;; state machine receives "events" (from timers, filters, user +;; requests, etc) and reacts to them, possibly entering another state, +;; possibly returning a value. + +;; The essential macros/functions are: +;; +;; define-state-machine - create start-FOO function +;; define-state - event handler for each state (required) +;; define-enter-state - called when entering a state (optional) +;; define-fsm - encapsulates the above three (more sugar!) +;; fsm-send - send an event to a state machine +;; fsm-call - send an event and wait for reply + +;; fsm.el is similar to but different from Distel: +;; <URL:http://fresh.homeunix.net/~luke/distel/> +;; Emacs' tq library is a similar idea. + +;; Here is a simple (not using all the features of fsm.el) example: +;; +;; (require 'cl) +;; (labels ((hey (n ev) +;; (message "%d (%s)\tp%sn%s!" n ev +;; (if (zerop (% n 4)) "o" "i") +;; (make-string (max 1 (abs n)) ?g)))) +;; (macrolet ((zow (next timeout) +;; `(progn (hey (incf count) event) +;; (list ,next count ,timeout)))) +;; (define-fsm pingpong +;; :start ((init) "Start a pingpong fsm." +;; (interactive "nInit (number, negative to auto-terminate): ") +;; (list :ping (ash (ash init -2) 2) ; 4 is death +;; (when (interactive-p) 0))) +;; :state-data-name count +;; :states +;; ((:ping +;; (:event (zow :pingg 0.1))) +;; (:pingg +;; (:event (zow :pinggg 0.1))) +;; (:pinggg +;; (:event (zow :pong 1))) +;; (:pong +;; (:event (zow :ping (if (= 0 count) +;; (fsm-goodbye-cruel-world 'pingpong) +;; 3)))))))) +;; +;; (fsm-send (start-pingpong -16) t) +;; +;; Copy into a buffer, uncomment, and type M-x eval-buffer RET. +;; Alternatively, you can replace the `fsm-goodbye-cruel-world' +;; form with `nil', eval just the `labels' form and then type +;; M-x start-pingpong RET -16 RET. + +;; NOTE: This is version 0.1ttn4 of fsm.el, with the following +;; mods (an exercise in meta-meta-programming ;-) by ttn: +;; -- Refill for easy (traditional 80-column) perusal. +;; -- New var `fsm-debug-timestamp-format'. +;; -- Make variables satisfy `user-variable-p'. +;; -- Use `format' instead of `concat'. +;; -- New func `fsm-goodbye-cruel-world'. +;; -- Make start-function respect `interactive' spec. +;; -- Make enter-/event-functions anonymous. +;; -- New macro `define-fsm'. +;; -- Example usage in Commentary. + +;;; Code: + +;; We require cl at runtime, since we insert `destructuring-bind' into +;; modules that use fsm.el. +(require 'cl) + +(defvar fsm-debug "*fsm-debug*" + "*Name of buffer for fsm debug messages. +If nil, don't output debug messages.") + +(defvar fsm-debug-timestamp-format nil + "*Timestamp format (a string) for `fsm-debug-output'. +Default format is whatever `current-time-string' returns +followed by a colon and a space.") + +(defun fsm-debug-output (format &rest args) + "Append debug output to buffer named by the variable `fsm-debug'. +FORMAT and ARGS are passed to `format'." + (when fsm-debug + (with-current-buffer (get-buffer-create fsm-debug) + (save-excursion + (goto-char (point-max)) + (insert (if fsm-debug-timestamp-format + (format-time-string fsm-debug-timestamp-format) + (concat (current-time-string) ": ")) + (apply 'format format args) "\n"))))) + +(defmacro* define-state-machine (name &key start sleep) + "Define a state machine class called NAME. +A function called start-NAME is created, which uses the argument +list and body specified in the :start argument. BODY should +return a list of the form (STATE STATE-DATA [TIMEOUT]), where +STATE is the initial state (defined by `define-state'), +STATE-DATA is any object, and TIMEOUT is the number of seconds +before a :timeout event will be sent to the state machine. BODY +may refer to the instance being created through the dynamically +bound variable `fsm'. + +SLEEP-FUNCTION, if provided, takes one argument, the number of +seconds to sleep while allowing events concerning this state +machine to happen. There is probably no reason to change the +default, which is accept-process-output with rearranged +arguments. + +\(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])" + (declare (debug (&define name :name start + &rest + &or [":start" + (lambda-list + [&optional ("interactive" interactive)] + stringp def-body)] + [":sleep" function-form]))) + (let ((start-name (intern (format "start-%s" name))) + interactive-spec) + (destructuring-bind (arglist docstring &body body) start + (when (and (consp (car body)) (eq 'interactive (caar body))) + (setq interactive-spec (list (pop body)))) + (unless (stringp docstring) + (error "Docstring is not a string")) + `(progn + (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) + (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) + (defun ,start-name ,arglist + ,docstring + ,@interactive-spec + (fsm-debug-output "Starting %s" ',name) + (let ((fsm (gensym (concat "fsm-" ,(symbol-name name) "-")))) + (destructuring-bind (state state-data &optional timeout) + (progn ,@body) + (put fsm :name ',name) + (put fsm :state nil) + (put fsm :state-data nil) + (put fsm :sleep ,(or sleep (lambda (secs) + (accept-process-output + nil secs)))) + (put fsm :deferred nil) + (fsm-update fsm state state-data timeout) + fsm))))))) + +(defmacro* define-state (fsm-name state-name arglist &body body) + "Define a state called STATE-NAME in the state machine FSM-NAME. +ARGLIST and BODY make a function that gets called when the state +machine receives an event in this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object +EVENT The occurred event, an object. +CALLBACK A function of one argument that expects the response + to this event, if any (often `ignore' is used) + +If the event should return a response, the state machine should +arrange to call CALLBACK at some point in the future (not necessarily +in this handler). + +The function should return a list of the form (NEW-STATE +NEW-STATE-DATA TIMEOUT): + +NEW-STATE The next state, a symbol +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue + +Alternatively, the function may return the keyword :defer, in +which case the event will be resent when the state machine enters +another state." + (declare (debug (&define name name :name handler lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-event)) + (lambda ,arglist ,@body))) + +(defmacro* define-enter-state (fsm-name state-name arglist &body body) + "Define a function to call when FSM-NAME enters the state STATE-NAME. +ARGLIST and BODY make a function that gets called when the state +machine enters this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object + +The function should return a list of the form (NEW-STATE-DATA +TIMEOUT): + +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue" + (declare (debug (&define name name :name enter lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-enter)) + (lambda ,arglist ,@body))) + +(defmacro* define-fsm (name &key + start sleep states + (fsm-name 'fsm) + (state-data-name 'state-data) + (callback-name 'callback) + (event-name 'event)) + "Define a state machine class called NAME, along with its STATES. +This macro is (further) syntatic sugar for `define-state-machine', +`define-state' and `define-enter-state' macros, q.v. + +NAME is a symbol. Everything else is specified with a keyword arg. + +START and SLEEP are the same as for `define-state-machine'. + +STATES is a list, each element having the form (STATE-NAME . STATE-SPEC). +STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or +`:enter', and values a series of expressions representing the BODY of +a `define-state' or `define-enter-state' call, respectively. + +FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols, +used to construct the state functions' arglists." + `(progn + (define-state-machine ,name :start ,start :sleep ,sleep) + ,@(loop for (state-name . spec) in states + if (assq :enter spec) collect + `(define-enter-state ,name ,state-name + (,fsm-name ,state-data-name) + ,@(cdr it)) + end + if (assq :event spec) collect + `(define-state ,name ,state-name + (,fsm-name ,state-data-name + ,event-name + ,callback-name) + ,@(cdr it)) + end))) + +(defun fsm-goodbye-cruel-world (name) + "Unbind functions related to fsm NAME (a symbol). +Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE. +Functions are `fmakunbound', which will probably give (fatal) pause to +any state machines using them. Return nil." + (interactive "SUnbind function definitions for fsm named: ") + (fmakunbound (intern (format "start-%s" name))) + (let (ht) + (when (hash-table-p (setq ht (get name :fsm-event))) + (clrhash ht) + (remprop name :fsm-event)) + (when (hash-table-p (setq ht (get name :fsm-enter))) + (clrhash ht) + (remprop name :fsm-enter))) + nil) + +(defun fsm-start-timer (fsm secs) + "Send a timeout event to FSM after SECS seconds. +The timer is canceled if another event occurs before, unless the +event handler explicitly asks to keep the timer." + (fsm-stop-timer fsm) + (put fsm + :timeout (run-with-timer + secs nil + #'fsm-send-sync fsm :timeout))) + +(defun fsm-stop-timer (fsm) + "Stop the timeout timer of FSM." + (let ((timer (get fsm :timeout))) + (when (timerp timer) + (cancel-timer timer) + (put fsm :timeout nil)))) + +(defun fsm-maybe-change-timer (fsm timeout) + "Change the timer of FSM according to TIMEOUT." + (cond + ((numberp timeout) + (fsm-start-timer fsm timeout)) + ((null timeout) + (fsm-stop-timer fsm)) + ;; :keep needs no timer change + )) + +(defun fsm-send (fsm event &optional callback) + "Send EVENT to FSM asynchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (run-with-timer 0 nil #'fsm-send-sync fsm event callback)) + +(defun fsm-update (fsm new-state new-state-data timeout) + (let ((fsm-name (get fsm :name)) + (old-state (get fsm :state))) + (put fsm :state new-state) + (put fsm :state-data new-state-data) + (fsm-maybe-change-timer fsm timeout) + + ;; On state change, call enter function and send deferred events + ;; again. + (unless (eq old-state new-state) + (fsm-debug-output "%s enters %s" fsm-name new-state) + (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter)))) + (when (functionp enter-fn) + (fsm-debug-output "Found enter function for %S" new-state) + (condition-case e + (destructuring-bind (newer-state-data newer-timeout) + (funcall enter-fn fsm new-state-data) + (fsm-debug-output "Using data from enter function") + (put fsm :state-data newer-state-data) + (fsm-maybe-change-timer fsm newer-timeout)) + ((debug error) + (fsm-debug-output "Didn't work: %S" e))))) + + (let ((deferred (nreverse (get fsm :deferred)))) + (put fsm :deferred nil) + (dolist (event deferred) + (apply 'fsm-send-sync fsm event)))))) + +(defun fsm-send-sync (fsm event &optional callback) + "Send EVENT to FSM synchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (save-match-data + (let* ((fsm-name (get fsm :name)) + (state (get fsm :state)) + (state-data (get fsm :state-data)) + (state-fn (gethash state (get fsm-name :fsm-event)))) + ;; If the event is a list, output only the car, to avoid an + ;; overflowing debug buffer. + (fsm-debug-output "Sent %S to %s in state %s" + (or (car-safe event) event) fsm-name state) + (let ((result (condition-case e + (funcall state-fn fsm state-data event + (or callback 'ignore)) + ((debug error) (cons :error-signaled e))))) + ;; Special case for deferring an event until next state change. + (cond + ((eq result :defer) + (let ((deferred (get fsm :deferred))) + (put fsm :deferred (cons (list event callback) deferred)))) + ((null result) + (fsm-debug-output "Warning: event %S ignored in state %s/%s" event fsm-name state)) + ((eq (car-safe result) :error-signaled) + (fsm-debug-output "Error in %s/%s: %s" + fsm-name state + (error-message-string (cdr result)))) + ((and (listp result) + (<= 2 (length result)) + (<= (length result) 3)) + (destructuring-bind (new-state new-state-data &optional timeout) result + (fsm-update fsm new-state new-state-data timeout))) + (t + (fsm-debug-output "Incorrect return value in %s/%s: %S" + fsm-name state + result))))))) + +(defun fsm-call (fsm event) + "Send EVENT to FSM synchronously, and wait for a reply. +Return the reply. +`with-timeout' might be useful." + (lexical-let (reply) + (fsm-send-sync fsm event (lambda (r) (setq reply (list r)))) + (while (null reply) + (fsm-sleep fsm 1)) + (car reply))) + +(defun fsm-make-filter (fsm) + "Return a filter function that sends events to FSM. +Events sent are of the form (:filter PROCESS STRING)." + (lexical-let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :filter process string))))) + +(defun fsm-make-sentinel (fsm) + "Return a sentinel function that sends events to FSM. +Events sent are of the form (:sentinel PROCESS STRING)." + (lexical-let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :sentinel process string))))) + +(defun fsm-sleep (fsm secs) + "Sleep up to SECS seconds in a way that lets FSM receive events." + (funcall (get fsm :sleep) secs)) + +(defun fsm-get-state-data (fsm) + "Return the state data of FSM. +Note the absence of a set function. The fsm should manage its +state data itself; other code should just send messages to it." + (get fsm :state-data)) + +(provide 'fsm) + +;;; fsm.el ends here |