path: root/emacs.d/lisp/rudel/obby/rudel-obby-util.el

;;; 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