Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Erlang mode updates

  • Loading branch information...
commit a1e948c572833df2ab008770b3713f6e9991d8f4 1 parent 6cd48e4
Michael Klishin authored
View
526 bundles/erlang/distel/derl.el
@@ -0,0 +1,526 @@
+;;; derl.el --- Distributed Erlang networking code.
+
+;;; Commentary:
+;;
+;; This module implements a useful subset of the Erlang distribution
+;; protocol, and provides a small API for sending messages to remote
+;; nodes.
+
+(require 'net-fsm)
+(require 'epmd)
+(require 'erlext)
+(require 'md5)
+(eval-when-compile
+ (require 'cl))
+
+(defvar erl-nodeup-hook nil
+ "Called with two args, NODE and FSM. NODE is a string of the form
+\"mynode@cockatoo\", FSM is the net-fsm process of the connection.")
+
+(defvar erl-nodedown-hook nil
+ "Called with one arg, NODE, a string of the form \"mynode@cockatoo\"")
+
+(defcustom derl-use-trace-buffer t
+ "*Store erlang message communication in a trace buffer."
+ :type 'boolean
+ :group 'distel)
+
+(defvar derl-cookie nil
+ "*Cookie to use in distributed erlang connections, or NIL.
+When NIL, we read ~/.erlang.cookie.")
+
+;; Local variables
+
+(make-variable-buffer-local
+ (defvar derl-connection-node nil
+ "Local variable recording the node name of the connection."))
+
+(make-variable-buffer-local
+ (defvar derl-hdrlen 2
+ "Size in bytes of length headers of packets. Set to 2 during
+handshake, 4 when connected."))
+
+(make-variable-buffer-local
+ (defvar derl-alive nil
+ "Local variable set to t after handshaking."))
+
+(make-variable-buffer-local
+ (defvar derl-shutting-down nil
+ "Set to T during shutdown, when no longer servicing requests."))
+
+(make-variable-buffer-local
+ (defvar derl-request-queue nil
+ "Messages waiting to be sent to node."))
+
+(make-variable-buffer-local
+ (defvar derl-remote-links '()
+ "List of (LOCAL-PID . REMOTE-PID) for all distributed links (per-node.)
+Used for sending exit signals when the node goes down."))
+
+;; Optional feature flags
+(defconst derl-flag-published #x01)
+(defconst derl-flag-atom-cache #x02)
+(defconst derl-flag-extended-references #x04)
+(defconst derl-flag-dist-monitor #x08)
+(defconst derl-flag-fun-tags #x10)
+(defconst derl-flag-dist-monitor-name #x20)
+(defconst derl-flag-hidden-atom-cache #x40)
+(defconst derl-flag-new-fun-tags #x80)
+(defconst derl-flag-extended-pids-ports #x100)
+
+;; ------------------------------------------------------------
+;; External API
+;; ------------------------------------------------------------
+
+(defun erl-connect (node)
+ "Asynchronously connect to NODE. If the connection succeeds,
+`erl-nodeup-hook' is run. If the connection fails, or goes down
+some time later, `erl-nodedown-hook' is run."
+ (when (eq node erl-node-name)
+ (error "Remote node has the same node name as Emacs: %S" node))
+ (let* ((name (derl-node-name node))
+ (host (derl-node-host node))
+ (buffer (get-buffer-create (derl-buffer-name node)))
+ ;; faking a closure with backtick. fun eh?
+ ;; NB: (funcall '(lambda () 1))
+ ;; => 1
+ ;; (let ((n 1)) `(lambda () ,n))
+ ;; => (lambda () 1)
+ (fail-cont `(lambda ()
+ (kill-buffer ,buffer)
+ (derl-nodedown ',node))))
+ (epmd-port-please name host
+ ;; success continuation
+ `(lambda (port)
+ (fsm-connect ,host port #'derl-state0 ',node
+ nil
+ ,fail-cont
+ ,buffer))
+ fail-cont)))
+
+(defun erl-dist-send (pid msg)
+ "Send a message to a process on a remote node."
+ (derl-dist-request (erl-pid-node pid) #'derl-send pid msg))
+
+(defun erl-dist-reg-send (node name msg)
+ "Send a message to a registered process on a remote node."
+ (derl-dist-request node #'derl-reg-send erl-self name msg))
+
+(defun erl-dist-link (pid)
+ "Link the current process with the remote PID."
+ (derl-dist-request (erl-pid-node pid) #'derl-link erl-self pid))
+
+(defun erl-dist-unlink (pid)
+ "Link the current process with the remote PID."
+ (derl-dist-request (erl-pid-node pid) #'derl-unlink erl-self pid))
+
+(defun erl-dist-exit (from to reason)
+ "Send an exit signal to a remote process."
+ (derl-dist-request (erl-pid-node to) #'derl-exit from to reason))
+
+(defun erl-dist-exit2 (from to reason)
+ "Send an `exit2' signal to a remote process.
+Use the distribution protocol's EXIT2 message."
+ ;; I don't know exactly how EXIT2 differs from EXIT. Browsing the
+ ;; emulator code, it looks like EXIT is for propagating a process
+ ;; crash, and EXIT2 is for the exit/2 BIF (where FROM isn't
+ ;; necessarily linked with TO).
+ (derl-dist-request (erl-pid-node to) #'derl-exit2 from to reason))
+
+;; -----------------------------------------------------------
+;; Handshake protocol states. These follow the protocol diagram in
+;; the distributed_handshake.txt file of lib/kernel/internal_doc/ in
+;; Erlang/OTP.
+;; -----------------------------------------------------------
+
+(defun derl-state0 (event node-name)
+ "Start state: send-name and then transition."
+ (check-event event 'init)
+ (setq derl-connection-node node-name)
+ (setq fsm-put-data-in-buffer t)
+ ;; Do nodedown when the buffer is killed in an unexpected way
+ ;; (e.g. by user)
+ (add-hook 'kill-buffer-hook
+ (lambda () (when derl-alive (derl-nodedown derl-connection-node))))
+ (derl-send-name)
+ (fsm-change-state #'derl-recv-status))
+
+(defun derl-recv-status (event data)
+ "Wait for status message."
+ (check-event event 'data)
+ (let ((msg (derl-take-msg)))
+ (when msg
+ (if (string= msg "sok")
+ (fsm-change-state #'derl-recv-challenge t)
+ (fsm-fail)))))
+
+(defun derl-recv-challenge (event data)
+ "Receive challenge message, send response and our challenge."
+ (check-event event 'data)
+ (when (derl-have-msg)
+ (goto-char (point-min))
+ (erlext-read2) ; skip length
+ (let ((tag (erlext-read1)))
+ (unless (equal 110 tag) ; tag-check (n)
+ (fsm-fail (format nil "wrong-tag: %S" tag))))
+ (let ((version (erlext-read2))
+ (flags (erlext-read4))
+ (challenge (erlext-readn 4))
+ (rem-node (buffer-substring (point) (derl-msg-end))))
+ (derl-eat-msg)
+ (derl-send-challenge-reply challenge)
+ (fsm-change-state #'derl-recv-challenge-ack))))
+
+(defun derl-string-make-unibyte (string)
+ (if (fboundp 'string-make-unibyte)
+ (string-make-unibyte string)
+ string))
+
+(defun derl-recv-challenge-ack (event data)
+ "Receive and check challenge ack. If it's OK then the handshake is
+complete and we become live."
+ (if (equal event 'closed)
+ (message "Distel thinks the cookie is %s. Erlang seems to disagree."
+ (erl-cookie)))
+ (check-event event 'data)
+ (when (derl-have-msg)
+ (goto-char (point-min))
+ (erlext-read2) ; skip length
+ (unless (equal 97 (erlext-read1)) ; tag-check (a)
+ (fsm-fail 'wrong-tag))
+ (let ((digest (buffer-substring (point) (+ (point) 16))))
+ (derl-eat-msg)
+ (if (equal (derl-string-make-unibyte (derl-gen-digest (string 0 0 0 42))) digest)
+ (derl-go-live)
+ (fsm-fail)))))
+
+;; Handshake support code
+
+(defun derl-send-name ()
+ (erase-buffer)
+ (derl-send-msg
+ (fsm-build-message
+ (fsm-encode1 110) ; tag (n)
+ (fsm-encode2 5) ; version
+ (fsm-encode4 (logior derl-flag-extended-references
+ derl-flag-extended-pids-ports))
+ (fsm-insert (symbol-name erl-node-name)))))
+
+(defun derl-send-challenge-reply (challenge)
+ (derl-send-msg (fsm-build-message
+ (fsm-encode1 114) ; 114 = ?r
+ (fsm-encode4 42)
+ (fsm-insert (derl-gen-digest challenge)))))
+
+(defun derl-gen-digest (challenge)
+ "Generate a message digest as required for the specification's
+gen_digest() function:
+ (md5 (concat challenge-as-ascii-decimal cookie))"
+ (derl-hexstring-to-binstring
+ (md5 (concat (erl-cookie) (derl-int32-to-decimal challenge)))))
+
+(defun erl-cookie ()
+ (or derl-cookie
+ (with-temp-buffer
+ (insert-file-contents (concat (getenv "HOME") "/.erlang.cookie"))
+ (while (search-forward "\n" nil t)
+ (replace-match ""))
+ (buffer-string))))
+
+;; ------------------------------------------------------------
+;; Alive/connected state
+;; ------------------------------------------------------------
+
+(defun derl-go-live ()
+ (setq derl-alive t)
+ (setq derl-hdrlen 4)
+ (derl-nodeup derl-connection-node)
+ (mapc #'derl-do-request derl-request-queue)
+ (setq derl-request-queue nil)
+ (fsm-change-state #'derl-alive t))
+
+(defun derl-alive (event data)
+ (check-event event 'data 'closed)
+ (if (eq event 'closed)
+ (progn (derl-nodedown derl-connection-node)
+ (setq derl-alive nil)
+ (fsm-fail))
+ (while (derl-handle-tick))
+ (when (derl-have-msg)
+ (let ((msg (derl-take-msg))
+ ctl
+ req)
+ ;; Decode the control message, and the request if it's present
+ (let (default-enable-multibyte-characters)
+ (with-temp-buffer
+ (insert msg)
+ (goto-char (point-min))
+ (assert (= (erlext-read1) 112)) ; type = pass through..
+ (setq ctl (erlext-read-whole-obj))
+ (when (< (point) (point-max))
+ (setq req (erlext-read-whole-obj)))))
+ (ecase (tuple-elt ctl 1)
+ ((1) ;; link: [1 FROM TO]
+ (let ((from (tuple-elt ctl 2))
+ (to (tuple-elt ctl 3)))
+ (derl-trace-input "LINK: %S %S" from to)
+ (add-to-list 'derl-remote-links (cons to from))
+ (erl-add-link to from)))
+ ((2) ;; send: [2 COOKIE TO-PID]
+ (let ((to-pid (tuple-elt ctl 3)))
+ (derl-trace-input "SEND: %S %S" to-pid req)
+ (erl-send to-pid req)))
+ ((3) ;; exit: [FROM TO REASON]
+ (let ((from (tuple-elt ctl 1))
+ (to (tuple-elt ctl 2))
+ (rsn (tuple-elt ctl 3)))
+ (derl-trace-input "EXIT: %S %S %S" from to rsn)
+ (erl-send-exit from to rsn)))
+ ((4) ;; unlink: [4 FROM TO]
+ (let ((from (tuple-elt ctl 2))
+ (to (tuple-elt ctl 3)))
+ (derl-trace-input "UNLINK: %S %S %S" from to)
+ (erl-remove-link to from)))
+ ((6) ;; reg_send: [6 FROM COOKIE NAME]
+ (let ((from (tuple-elt ctl 2))
+ (name (tuple-elt ctl 4)))
+ (derl-trace-input "REG_SEND: %S %S %S" from name req)
+ (condition-case data
+ (erl-send name req)
+ (erl-exit-signal
+ ;; Ignore the error if the name isn't registered -
+ ;; that's what the real nodes do. Seems reasonable,
+ ;; since the send is async, and who knows what the
+ ;; sender is up to now.
+ t))))))
+ ;; Recursively handle other messages
+ (fsm-event 'data 'continue))))
+
+(defun derl-handle-tick ()
+ (when (derl-have-tick)
+ (derl-eat-msg)
+ (derl-send-msg "")
+ t))
+
+(defun derl-have-tick ()
+ (goto-char (point-min))
+ (and (>= (buffer-size) derl-hdrlen)
+ (= 0 (erlext-read4))))
+
+;; ------------------------------------------------------------
+;; Message buffer helpers
+;; ------------------------------------------------------------
+
+(defun derl-send-msg (string)
+ "Send a message (with a length header)."
+ (fsm-send-string (fsm-build-message
+ (fsm-encode (length string) derl-hdrlen)
+ (fsm-insert string))))
+
+(defun derl-take-msg ()
+ "Read and return a message, removing it from the input buffer. If no
+complete message is available, nil is returned and the buffer isn't
+modified."
+ (when (derl-have-msg)
+ (goto-char (point-min))
+ (let* ((length (erlext-read derl-hdrlen))
+ (start (point))
+ (end (+ start length)))
+ (prog1 (buffer-substring start end)
+ (derl-eat-msg)))))
+
+(defun derl-have-msg ()
+ (goto-char (point-min))
+ (when (>= (buffer-size) derl-hdrlen)
+ (let ((len (erlext-read derl-hdrlen)))
+ (>= (buffer-size) (+ derl-hdrlen len)))))
+
+(defun derl-msg-end ()
+ (goto-char (point-min))
+ (+ (point-min) derl-hdrlen (erlext-read derl-hdrlen)))
+
+(defun derl-eat-msg ()
+ (delete-region (point-min) (derl-msg-end)))
+
+;; ------------------------------------------------------------
+;; Distributed erlang protocol requests
+;; ------------------------------------------------------------
+
+(defun derl-dist-request (node &rest request)
+ "Make REQUEST to NODE. If the node isn't live, a connection is
+initiated if necessary and the request is queued."
+ (let ((derl-bufname (derl-buffer-name node)))
+ (unless (get-buffer derl-bufname)
+ (erl-connect node))
+ (with-current-buffer derl-bufname
+ (cond (derl-shutting-down
+ nil)
+ (derl-alive
+ (derl-do-request request))
+ (t
+ (push request derl-request-queue))))))
+
+(defun derl-do-request (req)
+ (apply (car req) (cdr req)))
+
+(defun derl-send (pid msg)
+ (derl-trace-output "SEND: %S %S" pid msg)
+ (derl-send-request (tuple 2 empty-symbol pid) msg))
+
+(defun derl-reg-send (from to term)
+ (derl-trace-output "REG_SEND: %S %S %S" from to term)
+ (derl-send-request (tuple 6 from empty-symbol to) term))
+
+(defun derl-link (from to)
+ (derl-trace-output "LINK: %S %S" from to)
+ (add-to-list 'derl-remote-links (cons from to))
+ (derl-send-request (tuple 1 from to) nil t))
+
+(defun derl-unlink (from to)
+ (derl-trace-output "UNLINK: %S %S" from to)
+ (derl-send-request (tuple 4 from to) nil t))
+
+(defun derl-exit (from to reason)
+ (derl-trace-output "EXIT: %S %S %S" from to reason)
+ (derl-send-request (tuple 3 from to reason) nil t))
+
+(defun derl-exit2 (from to reason)
+ (derl-trace-output "EXIT2: %S %S %S" from to reason)
+ (derl-send-request (tuple 8 from to reason) nil t))
+
+(defun derl-send-request (control message &optional skip-message)
+ (let* ((ctl (erlext-term-to-binary control))
+ (msg (if skip-message "" (erlext-term-to-binary message)))
+ (len (+ 1 (length ctl) (length msg))))
+ (fsm-send-string
+ (fsm-build-message
+ (fsm-encode4 len)
+ (fsm-encode1 121) ; type = pass-through (whatever that means..)
+ (fsm-insert ctl)
+ (fsm-insert msg)))))
+
+;; Tracing
+
+(defface derl-trace-output-face
+ '((t (:inherit font-lock-string-face)))
+ "Face for outgoing messages in the distributed erlang trace
+buffer.")
+
+(defface derl-trace-input-face
+ '((t (:inherit font-lock-comment-face)))
+ "Face for incoming messages in the distributed erlang trace
+buffer.")
+
+(defun derl-trace-output (fmt &rest args)
+ (let ((msg (format ">> %s" (apply #'format (cons fmt args)))))
+ (put-text-property 0 (length msg) 'face 'derl-trace-output-face msg)
+ (derl-trace msg)))
+
+(defun derl-trace-input (fmt &rest args)
+ (let ((msg (format "<< %s" (apply #'format (cons fmt args)))))
+ (put-text-property 0 (length msg) 'face 'derl-trace-input-face msg)
+ (derl-trace msg)))
+
+(defun derl-trace (string)
+ (if derl-use-trace-buffer
+ (with-current-buffer (get-buffer-create
+ (format "*trace %S*" derl-connection-node))
+ (goto-char (point-max))
+ (insert string)
+ (insert "\n"))))
+
+;; ------------------------------------------------------------
+;; Utility
+;; ------------------------------------------------------------
+
+(defun derl-nodedown (node)
+ (setq derl-shutting-down t)
+ (dolist (link derl-remote-links)
+ (let ((local (car link))
+ (remote (cdr link)))
+ (message "LOCAL: %S REMOTE %S" local remote)
+ (erl-send-exit remote local 'noconnection)))
+ (run-hook-with-args 'erl-nodedown-hook node))
+
+(defun derl-nodeup (node)
+ ;; NB: only callable from the state machine
+ (run-hook-with-args 'erl-nodeup-hook node fsm-process))
+
+(eval-and-compile
+ (defun derl-int32-to-decimal (s)
+ "Converts a 32-bit number (represented as a 4-byte string) into its
+decimal printed representation."
+ (format "%.0f" (+ (+ (aref s 3) (* 256 (aref s 2)))
+ (* (+ 0.0 (aref s 1) (* 256 (aref s 0)))
+ 65536)))))
+
+;; Try to establish whether we have enough precision in floating-point
+;; The test is pretty lame, even if it succeeds we cannot be sure
+;; it'll work for all int32's
+;; alas, i'm too ignorant to write a good test
+;; the previous version of the test was nicer, but FSFmacs-specific :<
+
+(unless (string= "1819634533" (derl-int32-to-decimal "luke"))
+ (error "Can't use Emacs's floating-point for `derl-int32-to-decimal'."))
+
+(defun derl-hexstring-to-binstring (s)
+ "Convert the hexidecimal string S into a binary number represented
+as a string of octets."
+ (let ((halves (mapcar #'derl-hexchar-to-int (string-to-list s))))
+ (derl-merge-halves halves)))
+
+(defun derl-merge-halves (halves &optional acc)
+ (if (null halves)
+ (apply #'string (reverse acc))
+ (derl-merge-halves (cddr halves)
+ (cons (+ (ash (car halves) 4)
+ (cadr halves))
+ acc))))
+
+(defun derl-hexchar-to-int (c)
+ (cond ((and (<= ?0 c) (<= c ?9))
+ (- c ?0))
+ ((and (<= ?a c) (<= c ?f))
+ (+ 10 (- c ?a)))
+ (t
+ (error "Not hexchar" c))))
+
+(defun derl-node-p (node)
+ "Check if `node' is a node name, e.g. \"foo@bar\". The @ character
+is not allowed in the node or host name."
+ (and (symbolp node)
+ (string-match "^[^@]+@[^@]+$" (symbol-name node))))
+
+(defun derl-node-name (node)
+ "Take the atom node part of a node name, e.g.
+ (derl-node-name \"foo@bar\") => \"foo\""
+ (assert (derl-node-p node))
+ (let ((string (symbol-name node)))
+ (string-match "^[^@]+" string)
+ (match-string 0 string)))
+
+(defun derl-node-host (node)
+ "Take the host part of a node name, e.g.
+ (derl-node-host \"foo@bar\") => \"bar\""
+ (assert (derl-node-p node))
+ (let ((string (symbol-name node)))
+ (string-match "[^@]+$" string)
+ (match-string 0 string)))
+
+(defun derl-buffer-name (node)
+ (format "*derl %s*" node))
+
+;; ------------------------------------------------------------
+;; Testing and playing around
+;; ------------------------------------------------------------
+
+(defun derl-go (port)
+ (fsm-connect "localhost" port #'derl-state0
+ nil
+ (lambda (result)
+ (message "RESULT: %S" result))
+ (lambda ()
+ (message "FAIL"))))
+
+(provide 'derl)
+
View
234 bundles/erlang/distel/distel-ie.el
@@ -0,0 +1,234 @@
+;;;
+;;; distel-ie - an interactive erlang shell
+;;;
+;;; Some of the code has shamelessly been stolen from Luke Gorrie
+;;; [luke@bluetail.com] - ripped from its elegance and replaced by bugs.
+;;; It just goes to show that you can't trust anyone these days. And
+;;; as if that wasn't enough, I'll even blame Luke: "He _made_ me do it!"
+;;;
+;;; So, without any remorse, I hereby declare this code to be:
+;;;
+;;; copyright (c) 2002 david wallin [david.wallin@ul.ie].
+;;;
+;;; (it's probably going to be released onto an unexpecting public under
+;;; some sort of BSD license).
+
+(eval-when-compile (require 'cl))
+(require 'erlang)
+(require 'erl)
+
+(make-variable-buffer-local
+ (defvar erl-ie-node nil
+ "Erlang node that the session is hosted on."))
+
+;;
+;; erl-ie-session
+
+(defun erl-ie-session (node)
+ "Return the erl-ie-session for NODE, creating it if necessary."
+ (interactive (list (erl-ie-read-nodename)))
+
+ (or (get-buffer (erl-ie-buffer-name node))
+ (erl-ie-create-session node)))
+
+(defun erl-ie-create-session (node)
+ (with-current-buffer (get-buffer-create (erl-ie-buffer-name node))
+ (insert "\
+%%% Welcome to the Distel Interactive Erlang Shell.
+%%
+%% C-j evaluates an expression and prints the result in-line.
+%% C-M-x evaluates a whole function definition.
+
+")
+ (push-mark (point) t)
+
+ (erlang-mode)
+ (erl-session-minor-mode 1)
+ (setq erl-ie-node node)
+
+ ;; hiijack stdin/stdout :
+ (let ((output-buffer (current-buffer)))
+ (setq erl-group-leader
+ (erl-spawn (&erl-ie-group-leader-loop output-buffer))))
+
+ (erl-ie-ensure-registered node)
+
+ (current-buffer)))
+
+(defun erl-ie-read-nodename ()
+ "Get the node for the session, either from buffer state or from the user."
+ (or erl-ie-node (erl-target-node)))
+
+(defun erl-ie-buffer-name (node)
+ (format "*ie session <%S>*" node))
+
+;;
+;; erl-ie-ensure-registered
+
+(defun erl-ie-ensure-registered (node)
+ (interactive (list (erl-ie-read-nodename)))
+ (erl-spawn
+ (erl-send-rpc node 'distel_ie 'ensure_registered '())))
+
+
+(defun erl-ie-eval-expression (node)
+ (interactive (list (erl-ie-read-nodename)))
+ (erl-ie-read-nodename)
+ (let ((end (point))
+ (beg (save-excursion
+ (loop do (re-search-backward "^$")
+ while (looking-at "end"))
+ (point))))
+ (erl-ie-evaluate beg end node t)))
+
+(defun erl-ie-eval-defun (node)
+ (interactive (list (erl-ie-read-nodename)))
+ (erl-ie-read-nodename)
+ (let* ((beg (save-excursion (erlang-beginning-of-function)
+ (point)))
+ (end (save-excursion (goto-char beg)
+ (erlang-end-of-function)
+ (point))))
+ (erl-ie-evaluate beg end node)))
+
+;;
+;; erl-ie-evaluate
+;;
+;; this is doomed to fail, can end be the smaller value ?
+;; want to change to (interactive "r") somehow ...
+
+(defun erl-ie-evaluate (start end node &optional inline)
+ "Evaluate region START to END on NODE.
+The marked region can be a function definition, a function
+call or an expression."
+ (interactive (list
+ (region-beginning)
+ (region-end)
+ (erl-ie-read-nodename)))
+
+ (let* ((string (buffer-substring-no-properties start end))
+ (buffer (current-buffer)))
+ (erl-spawn
+ (erl-send (tuple 'distel_ie node)
+ (tuple 'evaluate erl-self string))
+
+ (message "Sent eval request..")
+
+ ;; move cursor to after the marked region
+ (goto-char (min (point-max) (1+ end)))
+ (erl-receive (buffer inline)
+ ((['ok value]
+ (if inline
+ (with-current-buffer buffer
+ ;; Clear "Sent eval request.." message
+ (message "")
+
+ (let ((my-point (point)))
+ (unless (looking-at "^")
+ (end-of-line)
+ (insert "\n"))
+
+ (let ((beg (point)))
+ ;; Insert value, indent all lines of it 4 places,
+ ;; then draw a " => " at the start.
+ (insert value)
+ (save-excursion (indent-rigidly beg (point) 5)
+ (goto-char beg)
+ (delete-region (point) (+ (point) 5))
+ (insert " -:-> ")))
+ (insert "\n")
+ (goto-char my-point)
+ (push-mark (point) t)))
+ (display-message-or-view (format "Result: %s" value)
+ "*Evaluation Result*")))
+
+ (['msg msg]
+ (with-current-buffer buffer
+ (message msg)))
+
+ (['error reason]
+ (with-current-buffer buffer
+
+ ;; TODO: should check the buffer for first non-whitespace
+ ;; before we do:
+ (newline 1)
+ (insert "Error: ") (insert reason) (newline 1)))
+
+ (other
+ (message "Unexpected: %S" other)))))))
+
+
+(defun erl-ie-xor (a b)
+ "Boolean exclusive or of A and B."
+ (or (and a (not b))
+ (and b (not a))))
+
+;;
+;; &erl-ie-group-leader-loop
+
+(defun &erl-ie-group-leader-loop (buf)
+ (erl-receive (buf)
+ ((['put_chars s]
+ (with-current-buffer buf
+ (insert s))))
+ (&erl-ie-group-leader-loop buf)))
+
+
+;;
+;; erl-ie-show-session
+
+(defun erl-ie-show-session (node)
+ "Show the session for NODE, creating if necessary."
+ (interactive (list (erl-ie-read-nodename)))
+ (switch-to-buffer (erl-ie-session node)))
+
+;;
+;; erl-ie-copy-buffer-to-session
+
+(defun erl-ie-copy-buffer-to-session (node)
+ "Open a distel_ie session on NODE with the content of the current buffer.
+The content is pasted at the end of the session buffer. This can be useful
+for debugging a file without ruining the content by mistake."
+ (interactive (list (erl-ie-read-nodename)))
+ (let ((cloned-buffer (buffer-string)))
+
+ (with-current-buffer (erl-ie-session node)
+ (goto-char (point-max))
+ (insert cloned-buffer))
+ (erl-ie-popup-buffer node)))
+
+;;
+;; erl-ie-copy-region-to-session
+
+(defun erl-ie-copy-region-to-session (start end node)
+ "Open a distel_ie session on NODE with the content of the region.
+The content is pasted at the end of the session buffer. This can be useful
+for debugging a file without ruining the content by mistake."
+ (interactive (list
+ (region-beginning)
+ (region-end)
+ (erl-ie-read-nodename)))
+ (let ((cloned-region (buffer-substring-no-properties start end)))
+
+ (with-current-buffer (erl-ie-session node)
+ (goto-char (point-max))
+ (set-mark (point)) ; so the region will be right
+ (insert cloned-region))
+ (erl-ie-popup-buffer node)))
+
+
+(defun erl-ie-popup-buffer (node)
+ (switch-to-buffer (erl-ie-session node)))
+
+;; ------------------------------------------------------------
+;; Session minor mode.
+
+(define-minor-mode erl-session-minor-mode
+ "Minor mode for Distel Interactive Sessions."
+ nil
+ nil
+ '(("\C-j" . erl-ie-eval-expression)
+ ("\C-\M-x" . erl-ie-eval-defun)))
+
+(provide 'distel-ie)
+
View
282 bundles/erlang/distel/distel.el
@@ -0,0 +1,282 @@
+;;; distel.el --- Top-level of distel package, loads all subparts
+
+;; Prerequisites
+(require 'erlang)
+(require 'easy-mmode)
+
+(provide 'distel)
+
+;; Customization
+
+(defgroup distel '()
+ "Distel and erlang-extended-mode development tools."
+ :group 'tools)
+
+(defcustom distel-tags-compliant nil
+ "Tags compliant, i.e. let M-. ask for confirmation."
+ :type 'boolean
+ :group 'distel)
+
+(defcustom distel-inhibit-backend-check nil
+ "Don't check for the 'distel' module when we connect to new nodes."
+ :type 'boolean
+ :group 'distel)
+
+;; Compatibility with XEmacs
+(unless (fboundp 'define-minor-mode)
+ (defalias 'define-minor-mode 'easy-mmode-define-minor-mode))
+
+;; Distel modules
+
+(require 'erl)
+(require 'erl-service)
+(require 'edb)
+
+(require 'distel-ie)
+
+(defun distel-setup ()
+ (add-hook 'erlang-mode-hook 'distel-erlang-mode-hook))
+
+(defun distel-erlang-mode-hook ()
+ "Function to enable the Distel extensions to Erlang mode.
+You can add this to `erlang-mode-hook' with:
+ (add-hook 'erlang-mode-hook 'distel-erlang-mode-hook)"
+ (erlang-extended-mode t))
+
+;; Extended feature key bindings (C-c C-d prefix)
+
+(define-minor-mode erlang-extended-mode
+ "Extensions to erlang-mode for communicating with a running Erlang node.
+
+These commands generally communicate with an Erlang node. The first
+time you use one, you will be prompted for the name of the node to
+use. This name will be cached for future commands. To override the
+cache, give a prefix argument with C-u before using the command.
+\\<erlang-extended-mode-map>
+
+\\[erl-choose-nodename] - Set Erlang nodename.
+\\[erl-ping] - Check connection between Emacs and Erlang.
+
+\\[erl-find-source-under-point] - Jump from a function call to its definition.
+\\[erl-find-source-unwind] - Jump back from a function definition (multi-level).
+
+\\[erl-reload-module] - (Re)load an Erlang module.
+\\[erl-reload-modules] - Reload all Erlang modules that are out of date.
+\\[erl-find-module] - Find a module.
+\\[erl-who-calls] - Who calls function under point.
+
+\\[erl-process-list] - List all Erlang processes (\"pman\").
+\\[edb-toggle-interpret] - Toggle debug interpreting of the module.
+C-c C-d b/\\[edb-toggle-breakpoint] - Toggle a debugger breakpoint at the current line.
+\\[edb-monitor] - Popup the debugger's process monitor buffer.
+\\[edb-synch-breakpoints] - Synchronizes current breakpoints to erlang.
+\\[edb-save-dbg-state] - Save set of interpreted modules and breakpoints.
+\\[edb-restore-dbg-state] - Restore saved set of interpreted modules and breakpoints.
+
+\\[erl-eval-expression] - Evaluate an erlang expression from the minibuffer.
+\\[erl-ie-show-session] - Create an interactive \"session\" buffer.
+
+\\[erl-complete] - Complete a module or remote function name.
+\\[erl-refactor-subfunction] - Refactor expressions in the region as a new function.
+
+\\[erl-find-sig-under-point] - Show the signature for the function under point.
+\\[erl-find-doc-under-point] - Show the HTML documentation for the function under point.
+\\[erl-find-sig] - Show the signature for a function.
+\\[erl-find-doc] - Show the HTML documentation for a function.
+\\[erl-fdoc-describe] - Describe a function with fdoc.
+\\[erl-fdoc-apropos] - Describe functions matching a regexp with fdoc.
+
+\\[fprof] - Profile (with fprof) an expression from the minibuffer.
+\\[fprof-analyse] - View profiler results from an \"fprof:analyse\" file.
+
+ \"fdoc\" works by looking at the source code. The HTML doc functions
+needs the OTP HTML docs to be installed. who-calls makes use of
+xref, and can take quite some time to initialize.
+
+ Most commands that pop up new buffers will save your original
+window configuration, so that you can restore it by pressing
+'q'. Use `describe-mode' (\\[describe-mode]) on any Distel buffer
+when you want to know what commands are available. To get more
+information about a particular command, use \"\\[describe-key]\"
+followed by the command's key sequence. For general information
+about Emacs' online help, use \"\\[help-for-help]\".
+"
+ nil
+ nil
+ ;; Fake keybinding list just to get the keymap created.
+ ;;
+ ;; define-minor-mode is very inconvenient for redefining keybindings
+ ;; so we do that by hand, below.
+ '(("\M-." 'undefined)))
+
+(defconst distel-keys
+ '(("\C-c\C-di" edb-toggle-interpret)
+ ("\C-x " edb-toggle-breakpoint)
+ ("\C-c\C-db" edb-toggle-breakpoint)
+ ("\C-c\C-ds" edb-synch-breakpoints)
+ ("\C-c\C-dS" edb-save-dbg-state)
+ ("\C-c\C-dR" edb-restore-dbg-state)
+ ("\C-c\C-dm" edb-monitor)
+ ("\C-c\C-d:" erl-eval-expression)
+ ("\C-c\C-dL" erl-reload-module)
+ ("\C-c\C-dr" erl-reload-modules)
+ ("\C-c\C-dp" fprof)
+ ("\C-c\C-dP" fprof-analyse)
+ ("\C-c\C-d." erl-find-source-under-point)
+ ("\C-c\C-d," erl-find-source-unwind)
+ ("\C-c\C-dl" erl-process-list)
+ ("\C-\M-i" erl-complete) ; M-TAB
+ ("\M-?" erl-complete) ; Some windowmanagers hijack M-TAB..
+ ("\C-c\C-de" erl-ie-show-session)
+ ("\C-c\C-df" erl-refactor-subfunction)
+ ("\C-c\C-dF" erl-find-module)
+ ("\C-c\C-dg" erl-ping)
+ ("\C-c\C-dA" erl-show-arglist)
+ ("\C-c\C-dh" erl-find-doc-under-point)
+ ("\C-c\C-dH" erl-find-doc)
+ ("\C-c\C-dz" erl-find-sig-under-point)
+ ("\C-c\C-dZ" erl-find-sig)
+ ("\C-c\C-dd" erl-fdoc-describe)
+ ("\C-c\C-da" erl-fdoc-apropos)
+ ("\C-c\C-dw" erl-who-calls)
+ ("\C-c\C-dn" erl-choose-nodename)
+ ("(" erl-openparen)
+ ;; Possibly "controversial" shorter keys
+ ("\M-." erl-find-source-under-point) ; usually `find-tag'
+ ("\M-*" erl-find-source-unwind) ; usually `pop-tag-mark'
+ ("\M-," erl-find-source-unwind) ; usually `tags-loop-continue'
+ ;;("\M-/" erl-complete) ; usually `dabbrev-expand'
+ )
+ "Keys to bind in distel-mode-map.")
+
+(defun distel-bind-keys ()
+ "Bind `distel-keys' in `erlang-extended-mode-map'."
+ (interactive)
+ (dolist (spec distel-keys)
+ (define-key erlang-extended-mode-map (car spec) (cadr spec))))
+
+(distel-bind-keys)
+
+;; Setup mode-line info for erlang-extended-mode
+;;
+;; NB: Would use the LIGHTER argument for define-minor-mode, but it's
+;; not working portably: my copy of Emacs21 disagrees with emacs20 and
+;; xemacs on whether it should be quoted.
+
+(defvar distel-modeline-node nil
+ "When non-nil the short name of the currently connected node.")
+
+(add-to-list 'minor-mode-alist
+ '(erlang-extended-mode
+ (" EXT"
+ (distel-modeline-node (":" distel-modeline-node) "")
+ (edb-module-interpreted "<interpreted>" ""))))
+
+(add-hook 'erlang-extended-mode-hook
+ '(lambda ()
+ (if erlang-extended-mode
+ (distel-init)
+ (distel-finish))))
+
+(defun distel-init ()
+ (setq erlang-menu-items
+ (erlang-menu-add-below 'distel-menu-items
+ 'erlang-menu-compile-items
+ erlang-menu-items))
+ (erlang-menu-init))
+
+(defun distel-finish ()
+ (setq erlang-menu-items
+ (erlang-menu-delete 'distel-menu-items erlang-menu-items))
+ (erlang-menu-init))
+
+(defvar distel-menu-items
+ '(nil
+ ("Distel"
+ (("List all erlang processes" erl-process-list)
+ ("Eval an erlang expression" erl-eval-expression)
+ ("Reload an erlang module" erl-reload-module)
+ ("Reload all changed erlang modules" erl-reload-modules)
+ nil
+ ("Profile an erlang expression" fprof)
+ ("View profiler results" fprof-analyse)
+ nil
+ ("Toggle debug interpreting of the module" edb-toggle-interpret)
+ ("Toggle a breakpoint at current line" edb-toggle-breakpoint)
+ ("Synchronizes current breakpoints to erlang" edb-synch-breakpoints)
+ ("Save debugger state" edb-save-dbg-state)
+ ("Restore debugger state" edb-restore-dbg-state)
+ ("Popup the debugger process monitor" edb-monitor)
+ nil
+ ("Create an interactive erlang session buffer" erl-ie-show-session)
+ nil
+ ("Specify which node to connect to" erl-choose-nodename)
+ )))
+ "*Description of the Distel menu used by Erlang Extended mode.
+
+Please see the documentation of `erlang-menu-base-items'.")
+
+
+;; Bug reportage
+
+(defvar distel-bugs-address "distel-hackers@lists.sourceforge.net"
+ "Email address to send distel bugs to.")
+
+(eval-when-compile (require 'font-lock))
+
+(defun report-distel-problem (summary)
+ "Report a bug to the distel-hackers mailing list."
+ (interactive (list (read-string "One-line summary: ")))
+ (compose-mail distel-bugs-address
+ (format "PROBLEM: %s" summary))
+ (require 'font-lock)
+ (insert (propertize "\
+;; Distel bug report form.
+;;
+;; This is an email message buffer for you to fill in information
+;; about your problem. When finished, you can enter \"C-c C-c\" to
+;; send the report to the distel-hackers mailing list - or update the
+;; 'To: ' header line to send it somewhere else.
+;;
+;; Please describe the problem in detail in this blank space:
+
+"
+ 'face font-lock-comment-face))
+ (save-excursion
+ (insert (propertize "\
+
+
+;; Below is some automatically-gathered debug information. Please make
+;; sure it doesn't contain any secrets that you don't want to send. If
+;; you decide to censor it or have any other special notes, please
+;; describe them here:
+
+
+
+"
+ 'face font-lock-comment-face))
+ (insert "[ ---- Automatically gathered trace information ---- ]\n\n")
+ (insert (format "Emacs node name: %S\n\n" erl-node-name))
+ (insert (format "Node of most recent command: %S\n\n" erl-nodename-cache))
+ (insert "Recent *Messages*:\n")
+ (distel-indented-insert (distel-last-lines "*Messages*" 15) 2)
+ (insert "\n\n")
+ (when erl-nodename-cache
+ (insert (format "Recent interactions with %S:\n" erl-nodename-cache))
+ (distel-indented-insert (distel-last-lines
+ (format "*trace %S*" erl-nodename-cache) 50)
+ 2))
+ (insert "\n\nThe End.\n\n")))
+
+(defun distel-last-lines (buffer n)
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char (point-max))
+ (forward-line (- n))
+ (buffer-substring (point) (point-max)))))
+
+(defun distel-indented-insert (string level)
+ (let ((pos (point)))
+ (insert string)
+ (indent-rigidly pos (point) level)))
+
View
890 bundles/erlang/distel/edb.el
@@ -0,0 +1,890 @@
+;;; edb.el --- Erlang debugger front-end
+
+(eval-when-compile (require 'cl))
+(require 'erl)
+(require 'erl-service)
+(require 'erlang)
+(require 'ewoc)
+
+(eval-and-compile
+ (autoload 'erlang-extended-mode "distel"))
+
+(when (featurep 'xemacs)
+ (require 'overlay))
+
+;; Hack for XEmacs compatibility..
+(unless (fboundp 'line-beginning-position)
+ (defalias 'line-beginning-position 'point-at-bol))
+
+;; ----------------------------------------------------------------------
+;; Configurables
+
+(defcustom edb-popup-monitor-on-event t
+ "*Automatically popup the monitor on interesting events.
+An interesting event is an unattached process reaching a breakpoint,
+or an attached process exiting."
+ :type 'boolean
+ :group 'distel)
+
+(defface edb-breakpoint-face
+ `((((type tty) (class color))
+ (:background "red" :foreground "black"))
+ (((type tty) (class mono))
+ (:inverse-video t))
+ (((class color) (background dark))
+ (:background "darkred" :foreground "white"))
+ (((class color) (background light))
+ (:background "tomato" :foreground "black"))
+ (t (:background "gray")))
+ "Face for marking a breakpoint definition."
+ :group 'distel)
+
+(defface edb-breakpoint-stale-face
+ `((((type tty) (class color))
+ (:background "yellow" :foreground "black"))
+ (((type tty) (class mono))
+ (:inverse-video t))
+ (((class color) (background dark))
+ (:background "purple4"))
+ (((class color) (background light))
+ (:background "medium purple" :foreground "black"))
+ (t (:background "dark gray")))
+ "Face for marking a stale breakpoint definition."
+ :group 'distel)
+
+;; ----------------------------------------------------------------------
+;; Integration with erlang-extended-mode buffers.
+
+(make-variable-buffer-local
+ (defvar edb-module-interpreted nil
+ "Non-nil means that the buffer's Erlang module is interpreted.
+This variable is meaningful in erlang-extended-mode buffers.
+The interpreted status refers to the node currently being monitored by
+edb."))
+
+(defun edb-setup-source-buffer ()
+ (make-local-variable 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook 'edb-delete-buffer-breakpoints)
+ (make-local-variable 'after-change-functions)
+ (add-to-list 'after-change-functions 'edb-make-breakpoints-stale)
+ (edb-update-interpreted-status)
+ (when edb-module-interpreted
+ (edb-create-buffer-breakpoints (edb-module))))
+
+(add-hook 'erlang-extended-mode-hook
+ 'edb-setup-source-buffer)
+
+;; ----------------------------------------------------------------------
+;; EDB minor mode for erlang-mode source files
+
+(defun edb-toggle-interpret (node module file)
+ "Toggle debug-interpreting of the current buffer's module."
+ (interactive (list (erl-target-node)
+ (edb-module)
+ buffer-file-name))
+ (when (edb-ensure-monitoring node)
+ (erl-spawn
+ (erl-set-name "EDB RPC to toggle interpretation of %S on %S"
+ module node)
+ (erl-send-rpc node 'distel 'debug_toggle (list module file))
+ (erl-receive (module)
+ ((['rex 'interpreted]
+ (message "Interpreting: %S" module))
+ (['rex 'uninterpreted]
+ (message "Stopped interpreting: %S" module))
+ (['rex ['badrpc reason]]
+ (message "Failed to interpret-toggle: %S" reason)))))))
+
+(defun edb-module ()
+ (if (erlang-get-module)
+ (intern (erlang-get-module))
+ (error "Can't determine module for current buffer")))
+
+(defun edb-toggle-breakpoint (node module line)
+ "Toggle a breakpoint on the current line."
+ (interactive (list (erl-target-node)
+ (edb-module)
+ (edb-line-number)))
+ (unless (edb-module-interpreted-p module)
+ (error "Module is not interpreted, can't set breakpoints."))
+ (if edb-buffer-breakpoints-stale
+ (edb-toggle-stale-breakpoint module line)
+ (edb-toggle-real-breakpoint node module line)))
+
+(defun edb-toggle-stale-breakpoint (module line)
+ (let ((overlay (edb-first (lambda (ov) (overlay-get ov 'edb-breakpoint))
+ (overlays-in (line-beginning-position)
+ (1+ (line-end-position))))))
+ (if overlay
+ (delete-overlay overlay)
+ (edb-create-breakpoint module line))))
+
+(defun edb-toggle-real-breakpoint (node module line)
+ (when (edb-ensure-monitoring node)
+ (erl-spawn
+ (erl-set-name "EDB RPC to toggle of breakpoint %S:%S on %S"
+ module line node)
+ (erl-send-rpc node 'distel 'break_toggle (list module line))
+ (erl-receive (module line)
+ ((['rex 'enabled]
+ (message "Enabled breakpoint at %S:%S" module line))
+ (['rex 'disabled]
+ (message "Disabled breakpoint at %S:%S" module line)))))))
+
+(defun edb-module-interpreted-p (module)
+ (assoc module edb-interpreted-modules))
+
+(defun edb-line-number ()
+ "Current line number."
+ ;; Taken from `count-lines' in gud.el
+ (save-restriction
+ (widen)
+ (+ (count-lines 1 (point))
+ (if (bolp) 1 0))))
+
+(defun edb-save-dbg-state (node)
+ "Save debugger state (modules to interpret and breakpoints).
+Use edb-restore-dbg-state to restore the state to the erlang node."
+ (interactive (list (erl-target-node)))
+ (let ((do-save nil))
+ (when (or (null edb-saved-interpreted-modules)
+ (y-or-n-p "You already have a saved debugger state, continue? "))
+ (setq edb-saved-interpreted-modules edb-interpreted-modules)
+ (edb-save-breakpoints node)
+ (message "Debugger state saved."))))
+
+(defun edb-restore-dbg-state (node)
+ "Restore debugger state (modules to interpret and breakpoints)."
+ (interactive (list (erl-target-node)))
+ (if edb-saved-interpreted-modules
+ (when (edb-ensure-monitoring node)
+ (erl-spawn
+ (erl-set-name "EDB RPC to restore debugger state on %S" node)
+ (erl-send-rpc node 'distel 'debug_add
+ (list edb-saved-interpreted-modules))
+ (erl-receive (node)
+ ((['rex 'ok]
+ (when (edb-restore-breakpoints
+ node
+ (lambda ()
+ (message "Debugger state restored.")))))))))
+ (message "No saved debugger state, aborting.")))
+
+
+;; ----------------------------------------------------------------------
+;; Monitor process
+
+(defvar edb-monitor-buffer nil
+ "Monitor process/viewer buffer.")
+
+(defvar edb-monitor-node nil
+ "Node we are debug-monitoring.")
+
+(defvar edb-monitor-mode-map nil
+ "Keymap for Erlang debug monitor mode.")
+
+(defvar edb-interpreted-modules '()
+ "Set of (module filename) being interpreted on the currently monitored node.")
+
+(defvar edb-saved-interpreted-modules '()
+ "Set of (module filename) to interpret if edb-restore-dbg-state is called.")
+
+(unless edb-monitor-mode-map
+ (setq edb-monitor-mode-map (make-sparse-keymap))
+ (define-key edb-monitor-mode-map [return] 'edb-attach-command)
+ (define-key edb-monitor-mode-map [(control m)] 'edb-attach-command)
+ (define-key edb-monitor-mode-map [?a] 'edb-attach-command)
+ (define-key edb-monitor-mode-map [?q] 'erl-bury-viewer)
+ (define-key edb-monitor-mode-map [?k] 'erl-quit-viewer))
+
+(defvar edb-processes nil
+ "EWOC of processes running interpreted code.")
+
+(defstruct (edb-process
+ (:constructor nil)
+ (:constructor make-edb-process (pid mfa status info)))
+ pid mfa status info)
+
+(defun edb-monitor-mode ()
+ "Major mode for viewing debug'able processes.
+
+Available commands:
+\\[edb-attach-command] - Attach to the process at point.
+\\[erl-bury-viewer] - Hide the monitor window.
+\\[erl-quit-viewer] - Quit monitor."
+ (interactive)
+ (kill-all-local-variables)
+ (setq buffer-read-only t)
+ (setq erl-old-window-configuration (current-window-configuration))
+ (use-local-map edb-monitor-mode-map)
+ (setq mode-name "EDB Monitor")
+ (setq major-mode 'edb-monitor-mode))
+
+(defun edb-monitor-insert-process (p)
+ (let ((buffer-read-only nil)
+ (text (edb-monitor-format (erl-pid-to-string (edb-process-pid p))
+ (edb-process-mfa p)
+ (edb-process-status p)
+ (edb-process-info p))))
+ (put-text-property 0 (length text) 'erl-pid (edb-process-pid p) text)
+ (insert text)))
+
+(defun edb-monitor-format (pid mfa status info)
+ (format "%s %s %s %s"
+ (padcut pid 12)
+ (padcut mfa 21)
+ (padcut status 9)
+ (cut info 21)))
+
+(defun padcut (s w)
+ (let ((len (length s)))
+ (cond ((= len w) s)
+ ((< len w) (concat s (make-string (- w len) ? )))
+ ((> len w) (substring s 0 w)))))
+
+(defun cut (s w)
+ (if (> (length s) w)
+ (substring s 0 w)
+ s))
+
+(defun edb-monitor-header ()
+ (edb-monitor-format "PID" "Initial Call" "Status" "Info"))
+
+(defun edb-monitor (node)
+ (interactive (list (erl-target-node)))
+ (when (edb-ensure-monitoring node)
+ (unless (get-buffer-window edb-monitor-buffer)
+ ;; Update the restorable window configuration
+ (with-current-buffer edb-monitor-buffer
+ (setq erl-old-window-configuration
+ (current-window-configuration))))
+ (pop-to-buffer edb-monitor-buffer)
+ (condition-case nil
+ (progn
+ (search-forward "break")
+ (move-beginning-of-line))
+ (error nil))))
+ ;; (goto-char (point-max))
+ ;; (forward-line -2)))
+
+(defun edb-ensure-monitoring (node)
+ "Make sure the debug monitor is watching the node.
+Returns NIL if this cannot be ensured."
+ (if (edb-monitor-node-change-p node)
+ (when (y-or-n-p (format "Attach debugger to %S instead of %S? "
+ node edb-monitor-node))
+ ;; Kill existing edb then start again
+ (kill-buffer edb-monitor-buffer)
+ (edb-start-monitor node))
+ (if (edb-monitor-live-p)
+ t
+ (edb-start-monitor node))))
+
+(defun edb-monitor-node-change-p (node)
+ "Do we have to detach/reattach to debug on NODE?"
+ (and (edb-monitor-live-p)
+ (not (equal node edb-monitor-node))))
+
+(defun edb-monitor-live-p ()
+ "Are we actively debug-monitoring a node?"
+ (and edb-monitor-buffer
+ (buffer-live-p edb-monitor-buffer)))
+
+(defun edb-monitor-buffer-name (node)
+ (format "*edb %S*" node))
+
+(defun edb-start-monitor (node)
+ "Start debug-monitoring NODE."
+ (erl-spawn
+ (erl-set-name "EDB Monitor on %S" node)
+ (setq edb-monitor-node node)
+ (setq edb-monitor-buffer (current-buffer))
+ (rename-buffer (edb-monitor-buffer-name node))
+ (edb-monitor-mode)
+ (make-local-variable 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook 'edb-monitor-cleanup)
+ (erl-send-rpc node 'distel 'debug_subscribe (list erl-self))
+ (erl-receive (node)
+ ((['rex [interpreted breaks snapshot]]
+ (setq edb-interpreted-modules interpreted)
+ (edb-init-breakpoints breaks)
+ (edb-update-source-buffers)
+ (setq edb-processes
+ (ewoc-create 'edb-monitor-insert-process
+ (edb-monitor-header)))
+ (mapc (lambda (item)
+ (mlet [pid mfa status info] item
+ (ewoc-enter-last edb-processes
+ (make-edb-process pid
+ mfa
+ status
+ info))))
+ snapshot)
+ (&edb-monitor-loop))))))
+
+(defun &edb-monitor-loop ()
+ "Monitor process main loop.
+Tracks events and state changes from the Erlang node."
+ (erl-receive ()
+ ((['int ['new_status pid status info]]
+ (let ((proc (edb-monitor-lookup pid)))
+ (if (null proc)
+ (message "Unknown process: %s" (erl-pid-to-string pid))
+ (setf (edb-process-status proc) (symbol-name status))
+ (setf (edb-process-info proc) info)
+ (when (and edb-popup-monitor-on-event
+ (edb-interesting-event-p pid status info))
+ (display-buffer (current-buffer))))))
+ ;;
+ (['int ['new_process (pid mfa status info)]]
+ (ewoc-enter-last edb-processes
+ (make-edb-process pid
+ mfa
+ (symbol-name status)
+ info)))
+ ;;
+ (['int ['interpret mod file]]
+ (push (list mod file) edb-interpreted-modules)
+ (edb-update-source-buffers mod))
+ ;;
+ (['int ['no_interpret mod]]
+ (setq edb-interpreted-modules
+ (assq-delete-all mod edb-interpreted-modules))
+ (edb-update-source-buffers mod))
+ ;;
+ (['int ['no_break mod]]
+ (edb-delete-breakpoints mod))
+ ;;
+ (['int ['new_break [[mod line] _info]]]
+ (edb-create-breakpoint mod line))
+ ;;
+ (['int ['delete_break [mod line]]]
+ (edb-delete-breakpoint mod line)))
+ (ewoc-refresh edb-processes)
+ (&edb-monitor-loop)))
+
+(defun edb-get-buffer (mod)
+ (edb-get-buffer2 mod (buffer-list)))
+
+(defun edb-get-buffer2 (mod bufl)
+ (if (null bufl) nil
+ (with-current-buffer (car bufl)
+ (if (and erlang-extended-mode
+ (eq (edb-source-file-module-name) mod))
+ (car bufl)
+ (edb-get-buffer2 mod (cdr bufl))))))
+
+
+(defun edb-interesting-event-p (pid status info)
+ (or (and (eq status 'exit)
+ (edb-attached-p pid))
+ (and (eq status 'break)
+ (not (edb-attached-p pid)))))
+
+(defun edb-update-interpreted-status ()
+ "Update `edb-module-interpreted' for current buffer."
+ (when erlang-extended-mode
+ (let ((mod (edb-source-file-module-name)))
+ (if (and mod (assq mod edb-interpreted-modules))
+ (setq edb-module-interpreted t)
+ (setq edb-module-interpreted nil)
+ ;; the erlang debugger automatically removes breakpoints when a
+ ;; module becomes uninterpreted, so we match it here
+ (edb-delete-breakpoints (edb-source-file-module-name))))
+ (force-mode-line-update)))
+
+(defun edb-update-source-buffers (&optional mod)
+ "Update the debugging state of all Erlang buffers.
+When MOD is given, only update those visiting that module."
+ (mapc (lambda (buf)
+ (with-current-buffer buf
+ (when (and erlang-extended-mode
+ (or (null mod)
+ (eq (edb-source-file-module-name) mod)))
+ (edb-update-interpreted-status))))
+ (buffer-list)))
+
+(defun edb-source-file-module-name ()
+ "Return the Erlang module of the current buffer as a symbol, or NIL."
+ (let ((name (erlang-get-module)))
+ (if name (intern name) nil)))
+
+(defun edb-monitor-lookup (pid)
+ (car (ewoc-collect edb-processes
+ (lambda (p) (equal (edb-process-pid p) pid)))))
+
+(defun edb-monitor-cleanup ()
+ "Cleanup state after the edb process exits."
+ (setq edb-interpreted-modules '())
+ (edb-delete-all-breakpoints)
+ (edb-update-source-buffers)
+ (setq edb-monitor-node nil))
+
+;; ----------------------------------------------------------------------
+;; Attach process
+
+(make-variable-buffer-local
+ (defvar edb-pid nil
+ "Pid of attached process."))
+
+(make-variable-buffer-local
+ (defvar edb-node nil
+ "Node of attached process."))
+
+(make-variable-buffer-local
+ (defvar edb-module nil
+ "Current module source code in attach buffer."))
+
+(make-variable-buffer-local
+ (defvar edb-variables-buffer nil
+ "Buffer showing variable bindings of attached process."))
+
+(make-variable-buffer-local
+ (defvar edb-attach-buffer nil
+ "True if buffer is attach buffer."))
+
+(defvar edb-attach-with-new-frame nil
+ "When true, attaching to a process opens a new frame.")
+
+;; Attach setup
+
+(defun edb-attach-command ()
+ (interactive)
+ (let ((pid (get-text-property (point) 'erl-pid)))
+ (if pid
+ (progn (when edb-attach-with-new-frame
+ (select-frame (make-frame)))
+ (edb-attach pid))
+ (error "No process at point."))))
+
+(defun edb-attach (pid)
+ (let ((old-window-config (current-window-configuration)))
+ (delete-other-windows)
+ (switch-to-buffer (edb-attach-buffer pid))
+ (setq erl-old-window-configuration old-window-config)))
+
+(defun edb-attach-buffer (pid)
+ (let ((bufname (edb-attach-buffer-name pid)))
+ (or (get-buffer bufname)
+ (edb-new-attach-buffer pid))))
+
+(defun edb-new-attach-buffer (pid)
+ "Start a new attach process and returns its buffer."
+ (erl-pid->buffer
+ (erl-spawn
+ (erl-set-name "EDB Attach to process %S on %S"
+ (erl-pid-id pid)
+ (erl-pid-node pid))
+ (rename-buffer (edb-attach-buffer-name pid))
+ ;; We must inhibit the erlang-new-file-hook, otherwise we trigger
+ ;; it by entering erlang-mode in an empty buffer
+ (let ((erlang-new-file-hook nil))
+ (erlang-mode))
+ (erlang-extended-mode t)
+ (edb-attach-mode t)
+ (setq edb-attach-buffer t)
+ (message "Entered debugger. Press 'h' for help.")
+ (setq buffer-read-only t)
+ (erl-send-rpc (erl-pid-node pid)
+ 'distel 'debug_attach (list erl-self pid))
+ (erl-receive ()
+ ((['rex pid]
+ (assert (erl-pid-p pid))
+ (setq edb-pid pid)
+ (setq edb-node (erl-pid-node pid))
+ (save-excursion (edb-make-variables-window))))
+ (&edb-attach-loop)))))
+
+;; Variables listing window
+
+(defun edb-make-variables-window ()
+ "Make a window and buffer for viewing variable bindings.
+The *Variables* buffer is killed with the current buffer."
+ (split-window-vertically (edb-variables-window-height))
+ (let ((vars-buf (edb-make-variables-buffer)))
+ (setq edb-variables-buffer vars-buf)
+ (make-local-variable 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook
+ (lambda () (kill-buffer edb-variables-buffer)))
+ (other-window 1)
+ (switch-to-buffer vars-buf)
+ (other-window -1)))
+
+(defun edb-variables-window-height ()
+ (- (min (/ (window-height) 2) 12)))
+
+(defun edb-make-variables-buffer ()
+ "Create the edb variable list buffer."
+ (let ((meta-pid edb-pid))
+ (with-current-buffer (generate-new-buffer "*Variables*")
+ (edb-variables-mode)
+ (setq edb-pid meta-pid)
+ (current-buffer))))
+
+(defun edb-variables-mode ()
+ (kill-all-local-variables)
+ (setq major-mode 'edb-variables)
+ (setq mode-name "EDB Variables")
+ (setq buffer-read-only t)
+ (use-local-map edb-variables-mode-map))
+
+(defvar edb-variables-mode-map nil
+ "Keymap for EDB variables viewing.")
+
+(when (null edb-variables-mode-map)
+ (setq edb-variables-mode-map (make-sparse-keymap))
+ (define-key edb-variables-mode-map [?m] 'edb-show-variable)
+ (define-key edb-variables-mode-map [(control m)] 'edb-show-variable))
+
+(defun edb-show-variable ()
+ "Pop a window showing the full value of the variable at point."
+ (interactive)
+ (let ((var (get-text-property (point) 'edb-variable-name)))
+ (if (null var)
+ (message "No variable at point")
+ (edb-attach-meta-cmd `[get_binding ,var]))))
+
+;; Attach process states
+
+(defun &edb-attach-loop ()
+ "Attached process loop."
+ (erl-receive ()
+ ((['location mod line pos max]
+ (let ((msg (format "Location: %S:%S (Stack pos: %S/%S)"
+ mod line pos max)))
+ (setq header-line-format msg))
+ (&edb-attach-goto-source mod line))
+ (['status status]
+ (unless (memq status '(running idle))
+ (message "Unrecognised status: %S" status))
+ (setq header-line-format (format "Status: %S" status))
+ (setq overlay-arrow-position nil)
+ (&edb-attach-loop))
+ (['variables vars]
+ ;; {variables, [{Name, String}]}
+ (when (buffer-live-p edb-variables-buffer)
+ (with-current-buffer edb-variables-buffer
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (mapc (lambda (b)
+ (let ((name (tuple-elt b 1))
+ (string (tuple-elt b 2)))
+ (put-text-property 0 (length string)
+ 'edb-variable-name name
+ string)
+ (insert string)))
+ vars))))
+ (&edb-attach-loop))
+ (['message msg]
+ (message msg)
+ (&edb-attach-loop))
+ (['show_variable value]
+ (save-excursion (display-message-or-view value "*Variable Value*"))
+ (&edb-attach-loop))
+ (other
+ (message "Other: %S" other)
+ (&edb-attach-loop)))))
+
+(defun &edb-attach-goto-source (module line)
+ "Display MODULE:LINE in the attach buffer and reenter attach loop."
+ (if (eq edb-module module)
+ (progn (edb-attach-goto-line line)
+ (&edb-attach-loop))
+ (&edb-attach-find-source module line)))
+
+(defun &edb-attach-find-source (module line)
+ "Load the source code for MODULE into current buffer at LINE.
+Once loaded, reenters the attach loop."
+ (erl-send-rpc edb-node 'distel 'find_source (list module))
+ (erl-receive (module line)
+ ((['rex ['ok path]]
+ (if (file-regular-p path)
+ (progn (setq edb-module module)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert-file-contents path))
+ (edb-delete-buffer-breakpoints)
+ (edb-create-buffer-breakpoints module)
+ (edb-attach-goto-line line))
+ (message "No such file: %s" path))))
+ (&edb-attach-loop)))
+
+(defun edb-attach-goto-line (line)
+ (goto-line line)
+ (setq overlay-arrow-string "=>")
+ (setq overlay-arrow-position (copy-marker (point))))
+
+(defun edb-attach-buffer-name (pid)
+ (format "*edbproc %s on %S*"
+ (erl-pid-to-string pid)
+ (erl-pid-node pid)))
+
+(defun edb-attached-p (pid)
+ "Non-nil when we have an attach buffer viewing PID."
+ (buffer-live-p (get-buffer (edb-attach-buffer-name pid))))
+
+;; ----------------------------------------------------------------------
+;; Attach minor mode and commands
+
+(define-minor-mode edb-attach-mode
+ "Minor mode for debugging an Erlang process.
+
+Available commands:
+\\<edb-attach-mode-map>
+\\[edb-attach-help] - Popup this help text.
+\\[erl-quit-viewer] - Quit the viewer (doesn't kill the process)
+\\[edb-attach-step] - Step (into expression)
+\\[edb-attach-next] - Next (over expression)
+\\[edb-attach-up] - Up to the next stack frame
+\\[edb-attach-down] - Down to the next stack frame
+\\[edb-attach-continue] - Continue (until breakpoint)
+\\[edb-toggle-breakpoint] - Toggle a breakpoint on the current line."
+ nil
+ " (attached)"
+ '(([? ] . edb-attach-step)
+ ([?n] . edb-attach-next)
+ ([?c] . edb-attach-continue)
+ ([?u] . edb-attach-up)
+ ([?d] . edb-attach-down)
+ ([?q] . erl-quit-viewer)
+ ([?h] . edb-attach-help)
+ ([?b] . edb-toggle-breakpoint)))
+
+(defun edb-attach-help ()
+ (interactive)
+ (describe-function 'edb-attach-mode))
+
+(defun edb-attach-step ()
+ (interactive)
+ (edb-attach-meta-cmd 'step))
+(defun edb-attach-next ()
+ (interactive)
+ (edb-attach-meta-cmd 'next))
+(defun edb-attach-continue ()
+ (interactive)
+ (edb-attach-meta-cmd 'continue))
+(defun edb-attach-up ()
+ (interactive)
+ (edb-attach-meta-cmd 'up))
+(defun edb-attach-down ()
+ (interactive)
+ (edb-attach-meta-cmd 'down))
+
+(defun edb-attach-meta-cmd (cmd)
+ (erl-send edb-pid `[emacs meta ,cmd]))
+
+;; ----------------------------------------------------------------------
+;; Breakpoints
+
+(defvar edb-breakpoints '()
+ "List of all breakpoints on the currently monitored node.")
+
+(defvar edb-saved-breakpoints '()
+ "List of breakpoints to set if edb-restore-dbg-state is called.")
+
+(make-variable-buffer-local
+ (defvar edb-buffer-breakpoints nil
+ "List of active buffer breakpoints."))
+
+(make-variable-buffer-local
+ (defvar edb-buffer-breakpoints-stale nil
+ "Nil if the breakpoints in the buffer are stale (out of synch)."))
+
+;; breakpoints
+(defun make-bp (mod line) (list mod line))
+(defun bp-mod (bp) (car bp))
+(defun bp-line (bp) (cadr bp))
+
+;; buffer breakpoints
+(defun make-bbp (mod line ov) (list mod line ov))
+(defun bbp-mod (bbp) (car bbp))
+(defun bbp-line (bbp) (cadr bbp))
+(defun bbp-ov (bbp) (caddr bbp))
+
+(defun edb-init-breakpoints (breaks)
+ (setq edb-breakpoints
+ (mapcar (lambda (pos)
+ (let ((mod (aref pos 0))
+ (line (aref pos 1)))
+ (make-bp mod line)))
+ breaks))
+ (mapc
+ (lambda (buf)
+ (with-current-buffer buf
+ (when erlang-extended-mode
+ (edb-create-buffer-breakpoints (edb-source-file-module-name)))))
+ (buffer-list)))
+
+
+(defun edb-create-breakpoint (mod line)
+ "Updates all internal structures in all buffers with new breakpoint."
+ (push (make-bp mod line) edb-breakpoints)
+ (mapc
+ (lambda (buf)
+ (with-current-buffer buf
+ (if (and erlang-extended-mode
+ (eq (edb-source-file-module-name) mod))
+ (let ((bbp (make-bbp mod line (edb-make-breakpoint-overlay line))))
+ (push bbp edb-buffer-breakpoints)))))
+ (buffer-list)))
+
+(defun edb-delete-all-breakpoints ()
+ "Updates all internal structures in all buffers."
+ (edb-del-breakpoints
+ (lambda (bp) t)
+ (lambda (bbp) t)))
+
+(defun edb-delete-breakpoints (mod)
+ "Updates all internal structures in all buffers."
+ (edb-del-breakpoints
+ (lambda (bp) (eq (bp-mod bp) mod))
+ (lambda (bbp) (eq (bbp-mod bbp) mod))
+ mod))
+
+(defun edb-delete-breakpoint (mod line)
+ "Updates all internal structures in all buffers."
+ (edb-del-breakpoints
+ (lambda (bp) (and (eq (bp-mod bp) mod)
+ (eq (bp-line bp) line)))
+ (lambda (bbp) (and (eq (bbp-mod bbp) mod)
+ (eq (bbp-line bbp) line)))
+ mod))
+
+(defun edb-create-buffer-breakpoints (mod)
+ "Creates buffer breakpoints in the current buffer."
+ (when edb-buffer-breakpoints
+ ;; remove old/stale breakpoints
+ (edb-delete-buffer-breakpoints))
+ (setq edb-buffer-breakpoints (edb-mk-bbps mod)))
+
+(defun edb-delete-buffer-breakpoints ()
+ "Deletes all buffer breakpoints in the current buffer."
+ (setq edb-buffer-breakpoints
+ (edb-del-bbps edb-buffer-breakpoints (lambda (bbp) t))))
+
+(defun edb-del-breakpoints (bp-f bbp-f &optional mod)
+ "Updates all internal structures in all buffers."
+ (setq edb-breakpoints (erl-remove-if bp-f edb-breakpoints))
+ (mapc
+ (lambda (buf)
+ (with-current-buffer buf
+ (if (and erlang-extended-mode
+ (or (not mod)
+ (eq (edb-source-file-module-name) mod)))
+ (setq edb-buffer-breakpoints
+ (edb-del-bbps edb-buffer-breakpoints bbp-f)))))
+ (buffer-list)))
+
+(defun edb-synch-breakpoints (node module)
+ "Synchronizes the breakpoints in the current buffer to erlang.
+I.e. deletes all old breakpoints, and re-applies them at the current line."
+ (interactive (list (erl-target-node)
+ (edb-module)))
+ (when (edb-ensure-monitoring node)
+ (let ((id (lambda (r) r)))
+ (mapc (lambda (new-bbp)
+ (let ((bbp (car new-bbp))
+ (new-line (cdr new-bbp)))
+ (erl-rpc id nil node 'distel 'break_delete
+ (list (bbp-mod bbp) (bbp-line bbp)))
+ (erl-rpc id nil node 'distel 'break_add
+ (list module new-line))))
+ (edb-new-bbps))
+ (setq edb-buffer-breakpoints-stale nil))))
+
+(defun edb-make-breakpoints-stale (begin end length)
+ "Make breakpoints in the current buffer stale.
+Has no effect if the buffer's module is not interpreted, or the
+breakpoints are already marked as stale."
+ (when (and (not edb-attach-buffer)
+ (not edb-buffer-breakpoints-stale)
+ edb-module-interpreted)
+ (mapc (lambda (bbp)
+ (let ((ov (bbp-ov bbp)))
+ (overlay-put ov 'face 'edb-breakpoint-stale-face)))
+ edb-buffer-breakpoints)
+ (setq edb-buffer-breakpoints-stale t)))
+
+(defun edb-save-breakpoints (node)
+ (let ((modules '()))
+ (setq edb-saved-breakpoints '())
+ (mapc
+ (lambda (buf)
+ (with-current-buffer buf
+ (if erlang-extended-mode
+ (let ((cur-mod (edb-source-file-module-name)))
+ (unless (member cur-mod modules)
+ (let ((new-lines (mapcar (lambda (new-bbp) (cdr new-bbp))
+ (edb-new-bbps))))
+ (push cur-mod modules)
+ (push (list cur-mod new-lines) edb-saved-breakpoints)))))))
+ (buffer-list))
+ (mapc (lambda (bp)
+ (unless (member (bp-mod bp) modules)
+ (push (list (bp-mod bp) (list (bp-line bp)))
+ edb-saved-breakpoints)))
+ edb-breakpoints)))
+
+(defun edb-restore-breakpoints (node cont)
+ (erl-send-rpc node 'distel 'break_restore (list edb-saved-breakpoints))
+ (erl-receive (cont)
+ ((['rex 'ok]
+ (funcall cont))
+ (['rex ['badrpc reason]]
+ (message "Failed to restore breakpoints: %S" reason)))))
+
+(defun edb-new-bbps ()
+ (mapcar (lambda (bbp)
+ (let* ((new-pos (overlay-start (bbp-ov bbp)))
+ (new-line (+ (count-lines (point-min) new-pos) 1)))
+ (cons bbp new-line)))
+ edb-buffer-breakpoints))
+
+(defun edb-mk-bbps (mod)
+ (zf
+ (lambda (bp)
+ (let ((bmod (bp-mod bp))
+ (line (bp-line bp)))
+ (if (eq bmod mod)
+ (let ((ov (edb-make-breakpoint-overlay line)))
+ (make-bbp bmod line ov))
+ nil)))
+ edb-breakpoints))
+
+(defun edb-del-bbps (list pred)
+ (zf
+ (lambda (bbp)
+ (cond ((funcall pred bbp)
+ (delete-overlay (bbp-ov bbp))
+ nil)
+ (t bbp)))
+ list))
+
+(defun edb-make-breakpoint-overlay (line)
+ "Creats an overlay at line"
+ (save-excursion
+ (goto-line line)
+ (let ((ov (make-overlay (line-beginning-position)
+ (line-beginning-position 2)
+ (current-buffer)
+ t
+ nil)))
+ (overlay-put ov 'edb-breakpoint t)
+ (if edb-buffer-breakpoints-stale
+ (overlay-put ov 'face 'edb-breakpoint-stale-face)
+ (overlay-put ov 'face 'edb-breakpoint-face))
+ ov)))
+
+(defun zf (f l)
+ (let ((res nil))
+ (dolist (x l)
+ (let ((r (funcall f x)))
+ (if r (push r res))))
+ res))
+
+(defun edb-first (pred list)
+ "Return the first element of LIST that satisfies PRED."
+ (loop for x in list
+ when (funcall pred x) return x))
+
+(provide 'edb)
View
104 bundles/erlang/distel/epmd.el
@@ -0,0 +1,104 @@
+(eval-when-compile (require 'cl))
+(require 'net-fsm)
+
+(defvar epmd-hosts '("localhost")
+ "Hosts to query EPMDs on.")
+
+(defvar epmd-port 4369)
+
+(defun epmd-process (event arg)
+ (check-event event 'init)
+ ;; Arg is the request
+ (let* ((len (length arg))
+ (len-msb (ash len -8))
+ (len-lsb (logand len 255)))
+ (fsm-send-string (concat (string len-msb len-lsb)
+ arg)))
+ (ecase (elt arg 0)
+ ((?n) (fsm-change-state #'epmd-recv-names-resp))
+ ((?z) (fsm-change-state #'epmd-recv-port-resp))
+ ((?a) (fsm-change-state #'epmd-recv-alive-resp))))
+
+(defun epmd-recv-names-resp (event data)
+ (check-event event 'data)
+ (assert (>= (length data) 4))
+ (fsm-terminate (substring arg 4)))
+
+(defun epmd-recv-port-resp (event data)
+ (message "Event: %s" event)
+ (message "data: %s" data)
+ (message "arg: %s" arg)
+ (ecase event
+ ((data)
+ (assert (> (length arg) 2))
+ (assert (= 119 (elt data 0)))
+ (fsm-terminate (+ (ash (elt arg 2) 8)
+ (logand (elt arg 3) 255))))
+ ((closed)
+ (fsm-fail))))
+
+(defun epmd-recv-alive-resp (event data)
+ (ecase event
+ ((closed)
+ (fsm-fail))
+ ((data)
+ (if (equal (string ?y 0) (substring data 0 2))
+ (let ((creation (substring data 2)))
+ ;; Cheat by calling the success continuation without
+ ;; terminating, since we need to keep the socket open.
+ (when fsm-cont
+ (funcall fsm-cont creation))
+ (fsm-change-state #'epmd-alive))
+ (fsm-fail)))))
+
+(defun epmd-alive (event data)
+ (check-event event 'close)
+ (fsm-fail))
+
+(defun epmd-show-nodes ()
+ (interactive)
+ (epmd-collect-names epmd-hosts ""))
+
+(defun epmd-collect-names (hosts string)
+ (if (null hosts)
+ (epmd-show-names string)
+ (lexical-let* ((host (car hosts))
+ (remaining-hosts (cdr hosts))
+ (string string))
+ (let ((cont
+ (lambda (new-result)
+ (epmd-collect-names remaining-hosts
+ (format "%s[%s]\n%s\n"
+ string host new-result))))
+ (fail
+ (lambda ()
+ (epmd-collect-names remaining-hosts
+ (format "%s[%s]\nUnable to connect.\n\n"
+ string host)))))
+ (fsm-connect host epmd-port #'epmd-process "n" cont fail)))))
+
+(defun epmd-port-please (node host cont &optional fail-cont)
+ (fsm-connect host epmd-port #'epmd-process (concat "z" node) cont fail-cont))
+
+;; (defun epmd-login (nodename &optional cont fail-cont)
+;; (fsm-connect host epmd-port #'epmd-process (epmd-make-alive-req nodename)
+;; cont fail-cont))
+
+;; (defun epmd-make-alive-req (nodename)
+;; (with-temp-buffer
+;; (insert ?x)
+
+(defun epmd-show-names (string)
+ (with-current-buffer (get-buffer-create "*epmd nodes*")
+ (erase-buffer)
+ (insert string)
+ (view-buffer-other-window (current-buffer))))
+
+;; testing
+
+(defun epmd-test (node host)
+ (interactive "sNode: \nsHost: ")
+ (epmd-port-please node host (lambda (x) (message "X = %S" x))))
+
+(provide 'epmd)
+
View
59 bundles/erlang/distel/erl-example.el
@@ -0,0 +1,59 @@
+;;; erl-example.el
+
+(eval-when-compile (require 'cl))
+(require 'erl)
+
+;; Echo
+
+(defun erlex-spawn-echo (recipient)
+ "Start a server process that forwards all of its messages to
+RECIPIENT, except for the symbol `exit' which is a shutdown message.
+The server registers the name `echo'."
+ (erl-spawn
+ (erl-register 'echo)
+ (erlex-echo-loop recipient)))
+
+(defun erlex-echo-loop (recipient)
+ "The 'receive loop' of the echo server."
+ (erl-receive (recipient)
+ (('exit t)
+ (msg (erl-send recipient msg)
+ (erlex-echo-loop recipient)))))
+
+(defun erlex-echo-test ()
+ "Test an echo server by having it forward some messages to the null
+process. These messages will end up in the *erl-lost-msgs* buffer -
+check for them there!"
+ (interactive)
+ (erl-spawn
+ (erlex-spawn-echo erl-null-pid)
+ (erl-send 'echo "Hey,")
+ (erl-send 'echo "it works!")
+ (erl-send 'echo 'exit)))
+
+;; Counter
+
+(defun spawn-counter ()
+ (erl-spawn
+ (erl-register 'counter)
+ (counter-loop 1)))
+
+(defun counter-loop (count)
+ (erl-receive (count)
+ ((msg (message "Got message #%S: %S" count msg)))
+ (counter-loop (1+ count))))
+
+(defun counter-test ()
+ (interactive)
+ (erl-spawn
+ ;; Start count server if its not already running
+ (unless (erl-whereis 'counter)
+ (spawn-counter))
+ (erl-send 'counter 'x)
+ (erl-send 'counter 'y)
+ (erl-send 'counter 'z)
+ ;; counter is left alive. It's easy to kill manually because of
+ ;; its registered name - it's buffer is "*reg counter*", and you
+ ;; can safely C-x k it.
+ ))
+
View
1,304 bundles/erlang/distel/erl-service.el
@@ -0,0 +1,1304 @@
+;;; erl-service.el --- High-level calls to Erlang services.
+
+;;;; Frontmatter
+;;
+;; This module implements Emacs commands - i.e. M-x'able key-bind'able
+;; sort - for doing stuff with Erlang nodes.
+;;
+;; The general implementation strategy is to make RPCs to the "distel"
+;; erlang module, which does most of the work for us.
+
+(require 'erlang)
+(eval-when-compile (require 'cl))
+(require 'erl)
+
+;;;; Base framework
+
+;;;;; Target node
+
+(defvar erl-nodename-cache nil
+ "The name of the node most recently contacted, for reuse in future
+commands. Using C-u to bypasses the cache.")
+
+(defvar erl-nodename-history nil
+ "The historical list of node names that have been selected.")
+
+(defun erl-target-node ()
+ "Return the name of the default target node for commands.
+Force node selection if no such node has been choosen yet, or when
+invoked with a prefix argument."
+ (or (and (not current-prefix-arg) erl-nodename-cache)
+ (erl-choose-nodename)))
+
+(defun erl-set-cookie ()
+ "Prompt the user for the cookie."
+ (interactive)
+ (let* ((cookie (read-string "Cookie: ")))
+ (if (string= cookie "")
+ (setq derl-cookie nil)
+ (setq derl-cookie cookie))))
+
+(defun erl-get-cookie ()
+ "Print the cookie."
+ (interactive)
+ (message "Cookie: %s" derl-cookie))
+
+(defun erl-choose-nodename ()
+ "Prompt the user for the nodename to connect to in future."
+ (interactive)
+ (let* ((nodename-string (if erl-nodename-cache
+ (symbol-name erl-nodename-cache)
+ nil))
+ (name-string (read-string (if nodename-string
+ (format "Node (default %s): "
+ nodename-string)
+ "Node: ")
+ nil
+ 'erl-nodename-history
+ nodename-string))
+ (name (intern (if (string-match "@" name-string)
+ name-string
+ (concat name-string
+ "@" (erl-determine-hostname))))))
+ (when (string= name-string "")
+ (error "No node name given"))
+ (setq erl-nodename-cache name)
+ (setq distel-modeline-node name-string)
+ (force-mode-line-update))
+ erl-nodename-cache)
+
+;;;;; Call MFA lookup
+
+(defun erl-read-call-mfa ()
+ "Read module, function, arity at point or from user.
+Returns the result in a list: module and function as strings, arity as
+integer."
+ (interactive) ; for testing
+ (let* ((mfa-at-point (erl-mfa-at-point))
+ (mfa (if (or (null mfa-at-point)
+ current-prefix-arg
+ distel-tags-compliant)
+ (erl-parse-mfa
+ (read-string
+ "Function reference: "
+ (if current-prefix-arg nil (erl-format-mfa mfa-at-point))))
+ mfa-at-point)))
+ mfa))
+
+(defun erl-format-mfa (mfa)
+ "Format (MOD FUN ARITY) as MOD:FUN/ARITY.
+If MFA is nil then return nil.
+If only MOD is nil then return FUN/ARITY."
+ (if mfa
+ (destructuring-bind (m f a) mfa
+ (if m (format "%s:%s/%S" m f a) (format "%s/%S" f a)))))
+
+(defun erl-parse-mfa (string &optional default-module)
+ "Parse MFA from a string using `erl-mfa-at-point'."
+ (when (null default-module) (setq default-module (erl-buffer-module-name)))
+ (with-temp-buffer
+ (with-syntax-table erlang-mode-syntax-table
+ (insert string)
+ (goto-char (point-min))
+ (erl-mfa-at-point default-module))))
+
+(defun erl-buffer-module-name ()
+ "Return the current buffer's module name, or nil."
+ (erlang-get-module))
+
+(defun erl-mfa-at-point (&optional default-module)
+ "Return the module, function, arity of the function reference at point.
+If not module-qualified then use DEFAULT-MODULE."
+ (when (null default-module) (setq default-module (erl-buffer-module-name)))
+ (save-excursion
+ (erl-goto-end-of-call-name)
+ (let ((arity (erl-arity-at-point))
+ (mf (erlang-get-function-under-point)))
+ (if (null mf)
+ nil
+ (destructuring-bind (module function) mf
+ (list (or module default-module) function arity))))))
+
+;;; FIXME: Merge with erlang.el!
+(defun erl-arity-at-point ()
+ "Get the number of arguments in a function reference.
+Should be called with point directly before the opening ( or /."
+ ;; Adapted from erlang-get-function-arity.
+ (save-excursion
+ (cond ((looking-at "/")
+ ;; form is /<n>, like the /2 in foo:bar/2
+ (forward-char)
+ (let ((start (point)))
+ (if (re-search-forward "[0-9]+" nil t)
+ (ignore-errors (car (read-from-string (match-string 0)))))))
+ ((looking-at "[\n\r ]*(")
+ (goto-char (match-end 0))
+ (condition-case nil
+ (let ((res 0)
+ (cont t))
+ (while cont
+ (cond ((eobp)
+ (setq res nil)
+ (setq cont nil))
+ ((looking-at "\\s *)")
+ (setq cont nil))
+ ((looking-at "\\s *\\($\\|%\\)")
+ (forward-line 1))
+ ((looking-at "\\s *,")
+ (incf res)
+ (goto-char (match-end 0)))
+ (t
+ (when (zerop res)
+ (incf res))
+ (forward-sexp 1))))
+ res)
+ (error nil))))))
+
+;;;; Backend code checking
+
+(add-hook 'erl-nodeup-hook 'erl-check-backend)
+
+(defun erl-check-backend (node _fsm)
+ "Check if we have the 'distel' module available on `node'.
+If not then try to send the module over as a binary and load it in."
+ (unless distel-inhibit-backend-check
+ (erl-spawn
+ (erl-send `[rex ,node]
+ `[,erl-self [call
+ code ensure_loaded (distel)
+ ,(erl-group-leader)]])
+ (erl-receive (node)
+ ((['rex ['error _]]
+ (&erl-load-backend node))
+ (_ t))))))
+
+(defvar distel-ebin-directory
+ (file-truename
+ (concat (file-name-directory
+ (or (locate-library "distel") load-file-name)) "../ebin"))
+ "Directory where beam files are located.")
+
+(defun &erl-load-backend (node)
+ (let ((modules '()))
+ (dolist (file (directory-files distel-ebin-directory))
+ (when (string-match "^\\(.*\\)\\.beam$" file)
+ (let ((module (intern (match-string 1 file)))
+ (filename (concat distel-ebin-directory "/" file)))
+ (push (list module filename) modules))))
+ (if (null modules)
+ (erl-warn-backend-problem "don't have beam files")
+ (&erl-load-backend-modules node modules))))
+
+(defun &erl-load-backend-modules (node modules)
+ (message "loading = %S" (car modules))
+ (if (null modules)
+ (message "(Successfully uploaded backend modules into node)")
+ (let* ((module (caar modules))
+ (filename (cadar modules))
+ (content (erl-file-to-string filename))
+ (binary (erl-binary content)))
+ (erl-send `[rex ,node]
+ `[,erl-self [call
+ code load_binary ,(list module filename binary)
+ ,(erl-group-leader)]])
+ (erl-receive (node modules)
+ ((['rex ['error reason]]
+ (erl-warn-backend-problem reason))
+ (['rex _]
+ (&erl-load-backend-modules node (rest modules))))))))
+
+(defun erl-warn-backend-problem (reason)
+ (with-current-buffer (get-buffer-create "*Distel Warning*")
+ (erase-buffer)
+ (insert (format "\
+Distel Warning: node `%s' can't seem to load the `distel' module.
+
+This means that most Distel commands won't function correctly, because
+the supporting library is not available. Please check your node's code
+path, and make sure that Distel's \"ebin\" directory is included.
+
+The most likely cause of this problem is either:
+
+ a) Your ~/.erlang file doesn't add Distel to your load path (the
+ Distel \"make config_install\" target can set this up for you.)
+
+ b) Your system's boot script doesn't consult your ~/.erlang file to
+ read your code path setting.
+
+To disable this warning in future, set `distel-inhibit-backend-check' to t.
+
+"
+ node))
+ (display-buffer (current-buffer))
+ (error "Unable to load or upload distel backend: %S" reason)))
+
+(defun erl-file-to-string (filename)
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (buffer-string)))
+
+;;;; RPC
+
+(defun erl-rpc (k kargs node m f a)
+ "Call {M,F,A} on NODE and deliver the result to the function K.
+The first argument to K is the result from the RPC, followed by the
+elements of KARGS."
+ (erl-spawn
+ (erl-send-rpc node m f a)
+ (erl-rpc-receive k kargs)))
+
+(defun erl-send-rpc (node mod fun args)
+ "Send an RPC request on NODE to apply(MOD, FUN, ARGS).
+The reply will be sent back as an asynchronous message of the form:
+ [rex Result]
+On an error, Result will be [badrpc Reason]."
+ (let ((m 'distel)
+ (f 'rpc_entry)
+ (a (list mod fun args)))
+ (erl-send (tuple 'rex node)
+ ;; {Who, {call, M, F, A, GroupLeader}}
+ (tuple erl-self (tuple 'call m f a (erl-group-leader))))))
+
+(defun erl-rpc-receive (k kargs)
+ "Receive the reply to an `erl-rpc'."
+ (erl-receive (k kargs)
+ ((['rex reply] (apply k (cons reply kargs))))))
+
+(defun erpc (node m f a)
+ "Make an RPC to an erlang node."
+ (interactive (list (erl-target-node)
+ (intern (read-string "Module: "))
+ (intern (read-string "Function: "))
+ (eval-minibuffer "Args: ")))
+ (erl-rpc (lambda (result) (message "RPC result: %S" result))
+ nil
+ node
+ m f a))
+
+(defun erl-ping (node)
+ "Ping the NODE, uploading distel code as a side effect."
+ (interactive (list (erl-target-node)))
+ (erl-spawn
+ (erl-send-rpc node 'erlang 'node nil)
+ (erl-receive (node)
+ ((['rex response]
+ (if (equal node response)
+ (message "Successfully communicated with remote node %S"
+ node)
+ (message "Failed to communicate with node %S: %S"
+ node response)))))))
+
+;;;; Process list
+
+(defun erl-process-list (node)
+ "Show a list of all processes running on NODE.
+The listing is requested asynchronously, and popped up in a buffer
+when ready."
+ (interactive (list (erl-target-node)))
+ (erl-rpc #'erl-show-process-list (list node)
+ node 'distel 'process_list '()))
+
+(defun erl-show-process-list (reply node)
+ (with-current-buffer (get-buffer-create (format "*plist %S*" node))
+ (process-list-mode)
+ (setq buffer-read-only t)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (let ((header (tuple-elt reply 1))
+ (infos (tuple-elt reply 2)))
+ (put-text-property 0 (length header) 'face 'bold header)
+ (insert header)
+ (mapc #'erl-insert-process-info infos))
+ (goto-char (point-min))
+ (next-line 1))
+ (select-window (display-buffer (current-buffer)))))
+
+(defun erl-insert-process-info (info)
+ "Insert INFO into the buffer.
+INFO is [PID SUMMARY-STRING]."
+ (let ((pid (tuple-elt info 1))
+ (text (tuple-elt info 2)))
+ (put-text-property 0 (length text) 'erl-pid pid text)
+ (insert text)))
+
+;; Process list major mode
+
+(defvar erl-viewed-pid nil
+ "PID being viewed.")
+(make-variable-buffer-local 'erl-viewed-pid)
+(defvar erl-old-window-configuration nil
+ "Window configuration to return to when viewing is finished.")
+(make-variable-buffer-local 'erl-old-window-configuration)
+
+(defun erl-quit-viewer (&optional bury)
+ "Quit the current view and restore the old window config.
+When BURY is non-nil, buries the buffer instead of killing it."
+ (interactive)
+ (let ((cfg erl-old-window-configuration))
+ (if bury
+ (bury-buffer)
+ (kill-this-buffer))
+ (set-window-configuration cfg)))
+
+(defun erl-bury-viewer ()
+ "Bury the current view and restore the old window config."
+ (interactive)
+ (erl-quit-viewer t))
+
+(defvar process-list-mode-map nil
+ "Keymap for Process List mode.")
+
+(when (null process-list-mode-map)
+ (setq process-list-mode-map (make-sparse-keymap))
+ (define-key process-list-mode-map [?u] 'erl-process-list)
+ (define-key process-list-mode-map [?q] 'erl-quit-viewer)
+ (define-key process-list-mode-map [?k] 'erl-pman-kill-process)
+ (define-key process-list-mode-map [return] 'erl-show-process-info)
+ (define-key process-list-mode-map [(control m)] 'erl-show-process-info)
+ (define-key process-list-mode-map [?i] 'erl-show-process-info-item)
+ (define-key process-list-mode-map [?b] 'erl-show-process-backtrace)
+ (define-key process-list-mode-map [?m] 'erl-show-process-messages))
+
+(defun process-list-mode ()
+ "Major mode for viewing Erlang process listings.
+
+Available commands:
+
+\\[erl-quit-viewer] - Quit the process listing viewer, restoring old window config.
+\\[erl-process-list] - Update the process list.
+\\[erl-pman-kill-process] - Send an EXIT signal with reason 'kill' to process at point.
+\\[erl-show-process-info] - Show process_info for process at point.
+\\[erl-show-process-info-item] - Show a piece of process_info for process at point.
+\\[erl-show-process-backtrace] - Show a backtrace for the process at point.
+\\[erl-show-process-messages] - Show the message queue for the process at point."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map process-list-mode-map)
+ (setq mode-name "Process List")
+ (setq major-mode 'process-list-mode)
+ (setq erl-old-window-configuration (current-window-configuration))
+ (run-hooks 'process-list-mode-hook))
+
+(defun erl-show-process-info ()
+ "Show information about process at point in a summary buffer."
+ (interactive)
+ (let ((pid (get-text-property (point) 'erl-pid)))
+ (if (null pid)
+ (message "No process at point.")
+ (erl-view-process pid))))
+
+(defun erl-show-process-info-item (item)
+ "Show a piece of information about process at point."
+ (interactive (list (intern (read-string "Item: "))))
+ (let ((pid (get-text-property (point) 'erl-pid)))
+ (cond ((null pid)
+ (message "No process at point."))
+ ((string= "" item)
+ (erl-show-process-info))
+ (t
+ (erl-spawn
+ (erl-send-rpc (erl-pid-node pid)
+ 'distel 'process_info_item (list pid item))
+ (erl-receive (item pid)
+ ((['rex ['ok string]]
+ (display-message-or-view string "*pinfo item*"))
+ (other
+ (message "Error from erlang side of process_info:\n %S"
+ other)))))))))
+
+(defun display-message-or-view (msg bufname &optional select)
+ "Like `display-buffer-or-message', but with `view-buffer-other-window'.
+That is, if a buffer pops up it will be in view mode, and pressing q
+will get rid of it.
+
+Only uses the echo area for single-line messages - or more accurately,
+messages without embedded newlines. They may still need to wrap or
+truncate to fit on the screen."
+ (if (string-match "\n.*[^\\s-]" msg)
+ ;; Contains a newline with actual text after it, so display as a
+ ;; buffer
+ (with-current-buffer (get-buffer-create bufname)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert msg)
+ (goto-char (point-min))
+ (let ((win (display-buffer (current-buffer))))
+ (when select (select-window win)))))
+ ;; Print only the part before the newline (if there is
+ ;; one). Newlines in messages are displayed as "^J" in emacs20,
+ ;; which is ugly
+ (string-match "[^\r\n]*" msg)
+ (message (match-string 0 msg))))
+
+(defun erl-show-process-messages ()
+ (interactive)
+ (erl-show-process-info-item 'messages))
+(defun erl-show-process-backtrace ()
+ (interactive)
+ (erl-show-process-info-item 'backtrace))
+
+(defun erl-pman-kill-process ()
+ "Kill process at point in a summary buffer."
+ (interactive)
+ (let ((pid (get-text-property (point) 'erl-pid)))
+ (if (null pid)
+ (message "No process at point.")
+ (message "Sent EXIT (kill) signal ")
+ (erl-exit 'kill pid))))
+
+;;;; Single process viewer
+
+(defun erl-view-process (pid)
+ (let ((buf (get-buffer (erl-process-view-buffer-name pid))))
+ (if buf
+ (select-window (display-buffer buf))
+ (erl-spawn
+ (process-view-mode)
+ (setq erl-old-window-configuration (current-window-configuration))
+ (setq erl-viewed-pid pid)
+ (erl-send-rpc (erl-pid-node pid)
+ 'distel 'process_summary_and_trace (list erl-self pid))
+ (erl-receive (pid)
+ ((['rex ['error reason]]
+ (message "%s" reason))
+ (['rex ['badrpc reason]]
+ (message