Skip to content
Snippets Groups Projects
Commit e3f72d8c3341 authored by didierv's avatar didierv
Browse files

MChat 2.1

parent 4d5331fca010
No related branches found
No related tags found
No related merge requests found
;;; mchat.el --- Multicast Chatting package for XEmacs
;; Copyright (C) 1997-99 Didier Verna.
;; Copyright (C) 1997-2000 Didier Verna.
;; Author: Didier Verna <didier@xemacs.org>
;; Maintainer: Didier Verna <didier@xemacs.org>
;; Created: Mon Feb 15 18:45:02 1999 under XEmacs 21.2 (beta 9)
......@@ -4,8 +4,8 @@
;; Author: Didier Verna <didier@xemacs.org>
;; Maintainer: Didier Verna <didier@xemacs.org>
;; Created: Mon Feb 15 18:45:02 1999 under XEmacs 21.2 (beta 9)
;; Last Revision: Sat Mar 20 15:51:04 1999
;; Last Revision: Fri Aug 4 13:47:56 2000
;; Keywords: comm processes
;; This file is part of XEmacs.
......@@ -36,6 +36,10 @@
;; feature, and almost nobody knew it, appart from the other developpers. This
;; version is much improved and completely backward incompatible ;-).
;; #### NOTE: before using this package, you most likely have to customize the
;; `mchat-nsl-method' first. It specifies a program like nsl or nslookup in
;; order to retreive the IP number of your machine.
;; The main entry point to the package is the `mchat' function which allows
;; you to open a multicast group based on the MChat protocol. There are a
;; number a variables that you can customize in the 'mchat custom group. Their
......@@ -43,7 +47,7 @@
;; at the bindings (C-h b) in MChat buffers, or at the menubar entries to get
;; an idea of what you can do.
;; ### WARNING: the current version (but there's also a limitation in the
;; #### WARNING: the current version (but there's also a limitation in the
;; internals of XEmacs's processes) doesn't let you send messages longer than
;; 500 octets or so, including the protocol header. I plan to change this in
;; the future (see the todo list).
......@@ -51,9 +55,9 @@
;;; Acknowledgements:
;; The original idea of MChat is from Philippe Dax <dax@infres.enst.fr>.
;; Akim Demaille <demaille@infres.enst.fr> was THE beta tester for this
;; release and gave me several good ideas.
;; The original idea of MChat is from Philippe Dax <dax@infres.enst.fr>. Akim
;; Demaille <akim@epita.fr> was *THE* beta tester for the 2.0 release. Many
;; good ideas come from him.
;;; TODO:
......@@ -98,8 +102,8 @@
:type 'integer)
(defcustom mchat-circulate-messages nil
"*If non nil, consider the message caches as circular lists, allowing to
jump directly from one end to the other."
"*If non nil, consider the message caches as circular lists, allowing
to jump directly from one end to the other."
:group 'mchat
:type 'boolean)
......@@ -110,6 +114,6 @@
:type 'symbol)
(defcustom mchat-flash-on-message 'needed
"*When you receive a message in an MChat group, the selected frame can be
flashed according to the value of this variable:
"*When you receive a message in an MChat group, the selected frame can
be flashed according to the value of this variable:
- if t, always flash when a message arrives. As a special exception, this
......@@ -115,6 +119,6 @@
- if t, always flash when a message arrives. As a special exception, this
doesn't flash when you are in one of the two MChat buffers corresponding to
this group.
doesn't flash when you are in one of the two MChat buffers corresponding
to this group.
- if 'needed, flash only when the MChat buffer is not visible,
- if nil, never flash.
......@@ -118,9 +122,9 @@
- if 'needed, flash only when the MChat buffer is not visible,
- if nil, never flash.
### NOTE: currently, it's not always possible to figure out exactly whether
the MChat buffer is visible (for instance if its frame is mapped, but obscured
by some other window)."
NOTE: currently, it's not always possible to figure out exactly whether
the MChat buffer is visible (for instance if its frame is mapped, but
obscured by some other window)."
:group 'mchat
:type '(choice (const :tag "always" t)
(const :tag "needed" needed)
......@@ -147,8 +151,8 @@
:type 'hook)
(defcustom mchat-before-send-hooks nil
"*Hooks to run before sending a message. The hooks are executed in the MChat
message buffer."
"*Hooks to run before sending a message. The hooks are executed in the
MChat message buffer."
:group 'mchat
:type 'hook)
......@@ -207,5 +211,5 @@
;; Private variables ========================================================
;; $Format: "(defconst mchat-prcs-major-version \"$ProjectMajorVersion$\")"$
(defconst mchat-prcs-major-version "version-2-0")
(defconst mchat-prcs-major-version "version-2-1")
;; $Format: "(defconst mchat-prcs-minor-version \"$ProjectMinorVersion$\")"$
......@@ -211,5 +215,5 @@
;; $Format: "(defconst mchat-prcs-minor-version \"$ProjectMinorVersion$\")"$
(defconst mchat-prcs-minor-version "2")
(defconst mchat-prcs-minor-version "1")
(defconst mchat-version
(let ((level mchat-prcs-minor-version)
major minor status)
......@@ -227,7 +231,7 @@
(concat major "." minor "-b" level)))
))
;; ### NOTE: the group informations stored in each entry are constant stuff.
;; #### NOTE: the group informations stored in each entry are constant stuff.
;; Things likely to change (like members) are stored in buffer-local
;; variables.
(defvar mchat-groups nil
......@@ -301,7 +305,7 @@
[ "ring bell" mchat-ring t ]
[ "show who's here" mchat-who t ]
[ "show info" mchat-info t ]
;;; [ "listening is " mchat-suspend t "on" ]
;;[ "listening is " mchat-suspend t "on" ]
[ "quit" mchat-quit t ]
"Control:"
"---"
......@@ -374,32 +378,11 @@
;; this number of times the heart-bit, the guy must have been killed.
)
;; ### FIXME: is it necessary to use 64bits for pids ?
(defconst mchat-user-id
(let ((str (make-string 12 0))
(pid (emacs-pid))
(i 0)
(n (cadddr mchat-nsl-method)))
(with-temp-buffer
(call-process (car mchat-nsl-method)
nil (current-buffer)
nil (eval (cadr mchat-nsl-method)))
(goto-char (point-min))
(re-search-forward (caddr mchat-nsl-method))
(while (< i 4)
(aset str i
(int-to-char (string-to-int (match-string (+ i n)))))
(setq i (1+ i)))
(setq i 11)
(while (> i 4)
(setq n (% pid 256))
(aset str i (int-to-char n))
(setq pid (/ (- pid n) 256))
(setq i (1- i))))
str)
(defvar mchat-user-id nil
;; #### FIXME: is it necessary to use 64bits for pids ?
;; 12 octets header for all mchat messages. Octets list with explanation:
;; 0- 3 -> IP address
;; 4-12 -> emacs pid on 64 bits
;; The pair IP-addres/emacs pid makes a unique identifier for everybody.
)
......@@ -400,9 +383,36 @@
;; 12 octets header for all mchat messages. Octets list with explanation:
;; 0- 3 -> IP address
;; 4-12 -> emacs pid on 64 bits
;; The pair IP-addres/emacs pid makes a unique identifier for everybody.
)
(defun mchat-user-id ()
;; Build and return the user id, or nil.
(condition-case nil
(let ((str (make-string 12 0))
(pid (emacs-pid))
(i 0)
(n (cadddr mchat-nsl-method)))
(with-temp-buffer
(call-process (car mchat-nsl-method)
nil (current-buffer)
nil (eval (cadr mchat-nsl-method)))
(goto-char (point-min))
(re-search-forward (caddr mchat-nsl-method))
(while (< i 4)
(aset str i
(int-to-char (string-to-int (match-string (+ i n)))))
(setq i (1+ i)))
(setq i 11)
(while (> i 4)
(setq n (% pid 256))
(aset str i (int-to-char n))
(setq pid (/ (- pid n) 256))
(setq i (1- i))))
str)
(t nil)
))
;; MChat protocol atoms
(defconst mchat-protocol-atom-join (int-to-char 0))
(defconst mchat-protocol-atom-quit (int-to-char 1))
......@@ -414,7 +424,7 @@
;; Message sending routines ------------------------------------------------
;; ### NOTE: should implement message fragmentation
;; #### NOTE: should implement message fragmentation
(defun mchat-send (proc data)
;; send DATA to the process PROC, in the MChat protocol format. Disable the
;; heart bit before sending, and restores it afterwards.
......@@ -492,7 +502,7 @@
(defmacro mchat-insertion (&rest body)
;; Execute BODY in current buffer as if it was a process output, and put it
;; in face FACE.
;; ### WARNING: BODY must use `insert-before-markers', not `insert'.
;; #### WARNING: BODY must use `insert-before-markers', not `insert'.
`(save-excursion
(let ((proc (get-buffer-process (current-buffer)))
buffer-read-only)
......@@ -502,7 +512,7 @@
))
(put 'mchat-insertion 'lisp-indent-function 0)
;; ### NOTE: For some reason, I've noticed that I'm likely to receive several
;; #### NOTE: For some reason, I've noticed that I'm likely to receive several
;; messages twice. I couldn't figure out why in the multicast API. Maybe a
;; problem of loopback of some sort ? Just ignore doublets anyway.
(defun mchat-treat-join (grp id data) ;; DATA is the user tag
......@@ -538,10 +548,10 @@
))
))
;; ### NOTE: those two functions should probably use the CL package to perform
;; substitutions, but I'm not sure it's worth it. Maybe if one day I have more
;; things to update in the members structure, I could write a more general
;; function.
;; #### NOTE: those two functions should probably use the CL package to
;; perform substitutions, but I'm not sure it's worth it. Maybe if one day I
;; have more things to update in the members structure, I could write a more
;; general function.
(defun mchat-update-time-stamp (id)
;; Update the timestamp for user ID in current MChat group buffer
(let ((who (assoc id mchat-group-members)))
......@@ -616,7 +626,7 @@
(while (setq msg (pop messages))
(mchat-treat-data grp id msg))))))
(t ;; completely known
;; ### FIXME: should check if tag is still the same
;; #### FIXME: should check if tag is still the same
(mchat-update-time-stamp id))))
))
......@@ -717,7 +727,7 @@
(setq end (point))
(run-hook-with-args 'mchat-treat-message-hooks
beg end))))))
;; ### WARNING: do this outside buf !!
;; #### WARNING: do this outside buf !!
;; Now possibly flash if the buffer is not visible (but not if
;; we're in it).
(when flash
......@@ -774,7 +784,7 @@
(mchat-treat-heart-bit grp id)))
))
;; ### FIXME: I think we can loose UDP packets, but we can assume that if one
;; #### FIXME: I think we can loose UDP packets, but we can assume that if one
;; is received, it's not corrupted, right ?
;; Also, I think I've encountered cases where packets were concatenated, so I
;; handle this by adding the length of each DATA segment, and calling again
......@@ -805,7 +815,7 @@
"(also, note that this might just be a corrupted message)\n")
)))
;; else, this protocol version is understood, decode the message.
;; ### NOTE: the following stuff could change for newer protocol
;; #### NOTE: the following stuff could change for newer protocol
;; versions. Just there's only one now (2.0).
(setq id (substring str 2 14)
len (+ (* 256 (char-to-int (aref str 14)))
......@@ -856,7 +866,7 @@
(when wcs
(set-frame-property (selected-frame)
'mchat-window-configurations (cdr wcs))
;; ### NOTE: `set-window-configuration' doesn't seem to produce any
;; #### NOTE: `set-window-configuration' doesn't seem to produce any
;; errors when the window configuration can't be restored (like, if one
;; buffer is killed, or something).
(set-window-configuration (car wcs)))
......@@ -873,7 +883,7 @@
(group-buffer (process-buffer proc))
(message-buffer (cdr (assoc 'buffer grp)))
(zombie-check (cdr (assoc 'zombie-check grp))))
;; ### WARNING: this is the first thing to do, because mchat-send reputs
;; #### WARNING: this is the first thing to do, because mchat-send reputs
;; the timeout after sending the message !!
(mchat-send-quit proc)
;; Don't call the hooks !!
......@@ -892,9 +902,10 @@
;; MChat modes routines =====================================================
;; ### NOTE: for the moment, all of the following functions are supposed to be
;; run only from an MChat buffer. Maybe we could make some of them query the
;; group otherwise, but there again, I don't find this particularly usefull.
;; #### NOTE: for the moment, all of the following functions are supposed to
;; be run only from an MChat buffer. Maybe we could make some of them query
;; the group otherwise, but there again, I don't find this particularly
;; usefull.
(defsubst mchat-interactive ()
(let* ((grp (assoc mchat-group-name mchat-groups)))
......@@ -983,7 +994,7 @@
(mchat-pop-cached-message 0))
))
;; ### NOTE: contrary to `mchat-next-message', this function doesn't consider
;; #### NOTE: contrary to `mchat-next-message', this function doesn't consider
;; the message currently edited as part of the cache. However, it is
;; remembered and can be accessed with one `M-n'.
(defun mchat-last-message (grp)
......@@ -1074,7 +1085,7 @@
(setq mchat-registered-groups
(append `((,(car grp) ,(cadr grp))) mchat-registered-groups))
(when (y-or-n-p "Group registered. Keep it for future sessions ? ")
;; ### FIXME: should I use Custom also to set the variable, or only if
;; #### FIXME: should I use Custom also to set the variable, or only if
;; we want to save the value ?
(custom-set-variables
`(mchat-registered-groups (quote ,mchat-registered-groups) t))
......@@ -1086,7 +1097,7 @@
(interactive (mchat-interactive))
(setq mchat-registered-groups (remassoc (car grp) mchat-registered-groups))
(when (y-or-n-p "Group unregistered. Forget it for future sessions ? ")
;; ### FIXME: should I use Custom also to set the variable, or only if
;; #### FIXME: should I use Custom also to set the variable, or only if
;; we want to save the value ?
(custom-set-variables
`(mchat-registered-groups (quote ,mchat-registered-groups) t))
......@@ -1101,7 +1112,7 @@
;; MChat major mode (for the group buffers) =================================
;; ### NOTE: I could let more bindings here (the message ones in particular),
;; #### NOTE: I could let more bindings here (the message ones in particular),
;; but since people are not supposed to live in the group buffer, I restrict
;; the commands available on purpose.
......@@ -1216,8 +1227,15 @@
))
(defun mchat-create-group (name address)
;; Create the MChat group NAME at address ADDRESS, update mchat-groups, and
;; return the group description.
;; Ensure the user id is created, create the MChat group NAME at address
;; ADDRESS, update mchat-groups, and return the group description.
;; #### NOTE: previously, the user id was created at load time which was
;; VERY BAD, because the user would not have the opportunity to correct a
;; bogus nsl-method.
(unless mchat-user-id
(or (setq mchat-user-id (mchat-user-id))
(error "Can't build user id. Please check your mchat-nsl-method.")
))
(let* ((bufname (concat "MChat (" name ")"))
(proc (open-multicast-group bufname bufname address))
(buf (get-buffer-create (concat "MChat message (" name ")")))
......@@ -1229,8 +1247,8 @@
(with-current-buffer bufname
(mchat-major-mode)
(setq mchat-group-name name)
;; ### NOTE: it's a bit silly, but sending the 'join message will delete
;; this timeout and reput it after :-/
;; #### NOTE: it's a bit silly, but sending the 'join message will
;; delete this timeout and reput it after :-/
(setq mchat-heart-bit-timeout
(add-timeout mchat-heart-bit-delay 'mchat-heart-bit proc
mchat-heart-bit-delay))
......@@ -1264,7 +1282,7 @@
(setq mchat-groups (cons desc mchat-groups))
desc))
;; ### FIXME: remove this function. It seems to be used only once.
;; #### FIXME: remove this function. It seems to be used only once.
(defun mchat-known-groups ()
;; Returns an alist of elements of the form (NAME ADDRESS) for ALL groups
;; known to MChat. This includes those in `mchat-registered-groups', and
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment