# HG changeset patch # User didierv # Date 965392692 0 # Fri Aug 04 12:38:12 2000 +0000 # Node ID e3f72d8c3341f14a6c52f24b9931919ee58ef8db # Parent 4d5331fca01012f4dece19c83fd6184a85c4b9e5 MChat 2.1 diff --git a/mchat.el b/mchat.el --- a/mchat.el +++ b/mchat.el @@ -1,11 +1,11 @@ ;;; 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) -;; 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,17 +114,17 @@ :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 - 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. -### 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,9 +211,9 @@ ;; 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$\")"$ -(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,35 +378,41 @@ ;; 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. ) +(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