summaryrefslogtreecommitdiffstats
path: root/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base
diff options
context:
space:
mode:
Diffstat (limited to 'emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base')
-rw-r--r--emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base314
1 files changed, 314 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base
new file mode 100644
index 0000000..faefe70
--- /dev/null
+++ b/emacs.d/lisp/rudel/obby/.svn/text-base/rudel-obby-util.el.svn-base
@@ -0,0 +1,314 @@
+;;; rudel-obby-util.el --- Miscellaneous functions for the Rudel obby backend
+;;
+;; Copyright (C) 2008, 2009 Jan Moringen
+;;
+;; Author: Jan Moringen <scymtym@users.sourceforge.net>
+;; Keywords: Rudel, obby, backend, miscellaneous
+;; 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:
+;;
+;;
+
+
+;;; History:
+;;
+;; 0.1 - Initial revision.
+
+
+;;; Code:
+;;
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'eieio)
+
+(require 'rudel)
+(require 'rudel-util)
+
+(require 'jupiter)
+
+
+;;; Class rudel-obby-socket-owner
+;;
+
+(defclass rudel-obby-socket-owner (rudel-socket-owner)
+ ((buffer :initarg :buffer
+ :type (or null string)
+ :initform nil
+ :documentation
+ "Stores message fragments until complete messages can
+be assembled."))
+ "This class adds functions for sending and receiving obby
+messages to the base class rudel-socket-owner.")
+
+(defmethod rudel-send ((this rudel-obby-socket-owner)
+ name &rest arguments)
+ "Send obby message NAME with arguments ARGUMENTS through the socket associated to THIS."
+ (with-slots (socket) this
+ (rudel-obby-send socket name arguments)))
+
+(defmethod rudel-receive ((this rudel-obby-socket-owner) data)
+ "Reassemble lines in DATA received on the socket associated with THIS and call message handler."
+ ;; Assemble fragmented lines.
+ (with-slots (buffer) this
+ (rudel-assemble-line-fragments data buffer))
+
+ ;; Process all available lines.
+ (rudel-loop-lines data line
+ ;; `rudel-message' has to dispatch message to an appropriate
+ ;; handler.
+ (let ((message (rudel-obby-parse-message line)))
+ (rudel-message this message)))
+ )
+
+(defgeneric rudel-message ((this rudel-obby-socket-owner) message)
+ "Called when a message arrives.
+Should be implemented in derived classes.")
+
+
+;;; Message serialization
+;;
+
+(defgeneric rudel-operation->message ((this jupiter-operation))
+ "Generate a list obby message components from THIS operation.")
+
+(defmethod rudel-operation->message ((this jupiter-insert))
+ "Serialize THIS insert operation."
+ (with-slots (from data) this
+ (list "ins" (format "%x" from) data)))
+
+(defmethod rudel-operation->message ((this jupiter-delete))
+ "Serialize THIS delete operation."
+ (with-slots (from length) this
+ (list "del" (format "%x" from) (format "%x" length))))
+
+(defmethod rudel-operation->message ((this jupiter-compound))
+ "Serialize THIS compound operation."
+ (with-slots (children) this
+ (apply #'append
+ (list "split" )
+ (mapcar #'rudel-operation->message children))))
+
+(defmethod rudel-operation->message ((this jupiter-nop))
+ "Serialize THIS nop operation."
+ (list "nop"))
+
+(defun rudel-message->operation (message local-revision remote-revision)
+ "Construct an operation object from MESSAGE and LOCAL-REVISION and REMOTE-REVISION.
+LOCAL-REVISION and REMOTE-REVISION are only used in the
+construction of the name of the new operation. "
+ (let ((type (car message)))
+ (cond
+
+ ;; Insert operation
+ ((string= type "ins")
+ (let ((position-numeric (string-to-number (nth 1 message) 16))
+ (data (nth 2 message)))
+ (jupiter-insert
+ (format "insert-%d-%d"
+ remote-revision local-revision)
+ :from position-numeric
+ :data data)))
+
+ ;; Delete operation
+ ((string= type "del")
+ (let ((position-numeric (string-to-number (nth 1 message) 16))
+ (length-numeric (string-to-number (nth 2 message) 16)))
+ (jupiter-delete
+ (format "delete-%d-%d"
+ remote-revision local-revision)
+ :from position-numeric
+ :to (+ position-numeric length-numeric))))
+
+ ;; Compound operation
+ ((string= type "split")
+ (let* ((rest (cdr message))
+ (offset (position-if
+ (lambda (item)
+ (member* item '("ins" "del" "nop")
+ :test #'string=))
+ rest
+ :start 1))
+ (first (subseq rest 0 offset))
+ (second (subseq rest offset)))
+ (jupiter-compound
+ (format "compound-%d-%d"
+ remote-revision local-revision)
+ :children
+ (list (rudel-message->operation
+ first local-revision remote-revision)
+ (rudel-message->operation
+ second local-revision remote-revision)))))
+
+ ;; No operation
+ ((string= type "nop")
+ (jupiter-nop
+ (format "nop-%d-%d"
+ remote-revision local-revision)))
+
+ ;; Unknown operation type
+ (t (error "Unknown document record type: `%s'" type))))
+ )
+
+
+;;; Character <-> byte position conversion
+;;
+
+(defgeneric rudel-obby-char->byte ((this jupiter-operation) buffer)
+ "Convert character positions and lengths in THIS to bytes.")
+
+(defmethod rudel-obby-char->byte ((this jupiter-insert) buffer)
+ "Convert character positions and lengths in THIS insert to bytes."
+ (with-slots (from) this
+ (with-current-buffer buffer
+ (setq from (- (position-bytes (+ from 1)) 1)))))
+
+(defmethod rudel-obby-char->byte ((this jupiter-delete) buffer)
+ "Convert character positions and lengths in THIS delete to bytes."
+ (with-slots (from to length) this
+ (let ((old-from (+ from 1))
+ (old-to (+ to 1)))
+ (with-current-buffer buffer
+ (destructuring-bind (change-from change-to string)
+ rudel-buffer-change-workaround-data
+ (setq from (- (position-bytes old-from) 1)
+ length (string-bytes
+ (substring string
+ (- old-from change-from)
+ (- old-to change-from))))))))
+ )
+
+(defmethod rudel-obby-char->byte ((this jupiter-compound) buffer)
+ "Convert character positions and lengths in THIS compound to bytes.."
+ (with-slots (children) this
+ (mapc
+ (lambda (child)
+ (rudel-obby-char->byte child buffer))
+ children))
+ )
+
+(defmethod rudel-obby-char->byte ((this jupiter-nop) buffer)
+ "Nothing to convert if THIS is a nop.")
+
+(defgeneric rudel-obby-byte->char ((this jupiter-operation) buffer)
+ "Convert byte positions and lengths in THIS to character positions.")
+
+(defmethod rudel-obby-byte->char ((this jupiter-insert) buffer)
+ "Convert byte positions and lengths in THIS insert to character positions."
+ (with-slots (from) this
+ (with-current-buffer buffer
+ (setq from (- (byte-to-position (+ from 1)) 1)))))
+
+(defmethod rudel-obby-byte->char ((this jupiter-delete) buffer)
+ "Convert byte positions and lengths in THIS delete to character positions."
+ (with-slots (from to length) this
+ (let ((old-from from)
+ (old-length length))
+ (with-current-buffer buffer
+ (setq from (- (byte-to-position (+ old-from 1)) 1)
+ to (- (byte-to-position (+ old-from old-length 1)) 1)))))
+ )
+
+(defmethod rudel-obby-byte->char ((this jupiter-compound) buffer)
+ "Convert byte positions and lengths in THIS compound to character positions."
+ (with-slots (children) this
+ (mapc
+ (lambda (child)
+ (rudel-obby-byte->char child buffer))
+ children))
+ )
+
+(defmethod rudel-obby-byte->char ((this jupiter-nop) buffer)
+ "Nothing to convert if THIS is a nop.")
+
+
+;;; Miscellaneous functions
+;;
+
+(defun rudel-obby-dispatch (object name arguments &optional prefix)
+ "Call method starting with PREFIX and ending in NAME of OBJECT with ARGUMENTS.
+When PREFIX is not specified, \"rudel-obby/\" is used."
+ ;; Default prefix.
+ (unless prefix
+ (setq prefix "rudel-obby/"))
+
+ ;; Construct a matching symbol.
+ (let ((method (intern-soft (concat prefix name))))
+ ;; If we found a suitable method, run it; Otherwise warn and do
+ ;; nothing.
+ (unless (and method
+ (condition-case error
+ ;; Try to call METHOD. If successful, always
+ ;; return t.
+ (progn
+ (apply method object arguments)
+ t)
+ ;; Warn only when the condition is
+ ;; 'no-method-definition' and refers to METHOD,
+ ;; otherwise continue unwinding.
+ (no-method-definition
+ (if (eq method (cadr error))
+ nil
+ (signal (car error) (cdr error))))))
+ (display-warning
+ '(rudel obby)
+ (format "%s: in context `%s': no method: `%s'; arguments: %s"
+ (object-name-string object) prefix name arguments)
+ :debug)))
+ )
+
+(defmacro with-parsed-arguments (specs &rest forms)
+ "Execute FORMS with variable bindings according to SPECS.
+SPECS is structured as follows:
+SPECS ::= (BINDING*)
+BINDING ::= (VAR TYPE)
+VAR is a symbol and TYPE is one of number, color, document-id and
+coding-system."
+ (declare (indent 1)
+ (debug (listp &rest form)))
+ (let ((bindings
+ (mapcar
+ (lambda (spec)
+ (destructuring-bind (var type) spec
+ (list var
+ (case type
+ ;; Number
+ (number
+ `(string-to-number ,var 16))
+ ;; Color
+ (color
+ `(rudel-obby-parse-color ,var))
+ ;; Document Id
+ (document-id
+ `(mapcar
+ (lambda (string)
+ (string-to-number string 16))
+ (split-string ,var " " t)))
+ ;; Coding System
+ (coding-system
+ `(rudel-get-coding-system (downcase ,var)))))))
+ specs)))
+ `(let (,@bindings)
+ ,@forms))
+ )
+
+(provide 'rudel-obby-util)
+;;; rudel-obby-util.el ends here