;;; mchat.el --- Multicast Chatting package for XEmacs.

;; Copyright (C) 1997-1998 Didier Verna.			 

;; Author:          Didier Verna <verna@inf.enst.fr>
;; Maintainer:      Didier Verna <verna@inf.enst.fr>
;; Created:         Fri Nov 28 17:43:51 1997 
;; Last Revision:   Mon Jan 12 19:40:38 1998
;; Current Version: 1.0
;; Keywords:        comm processes

;; This file is part of MChat.				 

;; MChat is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.			 
;; 							    
;; MChat is distributed in the hope that it will be useful, 
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.		 

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


;;; Commentary:

;; Initial contents by file-contents v.0.4 (Didier Verna <verna@inf.enst.fr>)
;; Written on emacs version 20.4 "Angora" XEmacs  Lucid (beta6)

;; MChat is a small utility designed to illustrate the use of a multicast
;; connection inside of xemacs. The connection, as for TCP, is seen as a
;; subprocess.
;; This program opens a multicast connection on the specified dest/port/ttl,
;; and allows you to chat in (almost) real time with other participants on the
;; group. The messages are displayed in a special buffer, and you can enter
 ;; your own messages from the minibuffer. A message is simply a short line of
;; text.  The original idea of mchat is from Philippe Dax.

;; M-x mchat to open a group (with a prefix -> in a new frame).
;; From the mchat buffer, type:
;; 'return' to enter a line of text to send.
;; 'w' (who) to see the list of known group members.
;; 'W' (Who) to request identification from members of the group.
;; 'b' (beep) to ring the group.
;; 'q' (quit) to quit the group.
;; 'e' (erase) to erase the mchat buffer.
;; 'd' (define) to save this group definition.
;; 'r' (remove) to remove this group definition.
;; 'a' (address) to see the current mchat group address
;; 'v' (version) to see the current mchat version.
;; 's' (suspend) to toggle between listening and suspended mode.


;;; Change Log:

;; Rev. of Mon Jan 12 1998 : Packaging cleanup.
;; Rev. of Mon Dec 22 1997 : Added the menu.
;; Rev. of Mon Dec 15 1997 : Improved completion + mchat-know-groups.
;; Rev. of Mon Dec 15 1997 : added mchat-suspend
;; Rev. of Fri Dec 12 1997 : Added mchat-group-address + eob when inserting.
;; Rev. of Thu Dec 11 1997 : Added mchat-Who
;; Rev. of Thu Dec 11 1997 : Added prefix management for mchat()
;; Rev. of Wed Dec 10 1997 : Added mchat-erase-buffer & mchat-version
;; Rev. of Wed Dec 10 1997 : mchat-with-meta-face macro + cleanup
;; Rev. of Wed Dec 10 1997 : Added mchat-with-mchat-buffer macro
;; Rev. of Tue Dec  9 1997 : Code cleanup
;; Rev. of Tue Dec  9 1997 : Handle possible messages concatenation
;; Rev. of Fri Dec  5 1997 : Added completion mechanism
;; Rev. of Fri Dec  5 1997 : Added predefined groups
;; Rev. of Fri Dec  5 1997 : Added the 'beep' command + cleanup
;; Rev. of Mon Dec  1 1997 : Added the 'who' command
;; Rev. of Mon Dec  1 1997 : Added mchat-living-groups
;; Rev. of Sun Nov 30 1997 : Added join, quit commands.
;; Rev. of Fri Nov 28 1997 : Inital version.


;;; Code:

;;; Public variables --------------------------------------------------------

(defgroup mchat nil
  "Multicast Chatting package.")

(defcustom mchat-prompt (user-full-name)
  "*The tag used to identify your messages in the mchat buffer. It must not 
contain any colons. Messages will appear like this:
`prompt' > `message'"
  :type 'string
  :group 'mchat)

(defcustom mchat-verbose-level 2
  "*The verbose level of an mchat buffer.
If 0, never print information not explicitely required.
If > 0, print information on people arriving or quitting the group.
If > 1, print possibly corrupted messages in the buffer too."
  :type 'integer
  :group 'mchat)

(defcustom mchat-loaded-hook nil
  "*Hook to run when mchat is loaded. Convenient place to set variables."
  :type 'hook
  :group 'mchat)

(defface mchat-prompt-face '((t (:bold t)))
  "*The face to display mchat prompts with."
  :group 'mchat)

(defface mchat-meta-face '((t (:italic t)))
  "*The face to display mchat groups information with."
  :group 'mchat)

(defcustom mchat-beep-sound t
  "*Sound to use when somebody rings the mchat group (see `sound-alist').
Otherwise, t means just beep and nil means don't ever produce any sound."
  :group 'mchat
  :type 'symbol)

(defcustom mchat-predefined-groups 
  '(("xemacs-beta" . "230.137.194.160/32010/127"))
  "*An alist of predefined mchat groups. Each element looks like
(NAME . ADDRESS) where NAME is a name used to identify the group, and ADDRESS
is the multicast address."
  :group 'mchat
  :type '(repeat (cons (string :tag "   Name")
		       (string :tag "Address"))))

(defconst mchat-version "0.17"
  "Guess what ? ...")


;;; Private variables -------------------------------------------------------

(defvar mchat-mode-map
  ;; MChat major mode map
  (let ((m (make-sparse-keymap)))
    (set-keymap-name m 'mchat-mode-map)
    (define-key m 'return 'mchat-message)
    (define-key m "q" 'mchat-quit)
    (define-key m "w" 'mchat-who)
    (define-key m "W" 'mchat-Who)
    (define-key m "b" 'mchat-ring)
    (define-key m "s" 'mchat-suspend)
    (define-key m "e" 'mchat-erase-buffer)
    (define-key m "d" 'mchat-define-group)
    (define-key m "r" 'mchat-remove-group)
    (define-key m "a" 'mchat-group-address)
    (define-key m "v" 'mchat-version)
    m)
  "We're a lil' curious aren't we ?!")

(if (featurep 'menubar) ;; not really usefull, but cleaner I think ...
    (defconst mchat-submenu
      '("MChat"
	"Group action:"
	"---"
	("members"
	 [ "show" mchat-who t ]
	 [ "re-ask" mchat-Who t ])
	[ "ring" mchat-ring t ]
	;; see mchat-menu-filter
	[ "listening is " mchat-suspend t "on" ]
	[ "show address" mchat-group-address t ]
	[ "leave" mchat-quit t ]
	"Groups control:"
	"---"
	[ "add group definition" mchat-define-group t ]
	[ "remove group definition" mchat-remove-group t ]
	"Misc."
	"---"
	[ "erase MChat buffer" mchat-erase-buffer t ]
	[ "MChat version" mchat-version t ]
	)
      ;; MChat-menu definition.
      )
  )

(defvar mchat-living-groups nil
  ;; An alist of the currently active mchat groups with related information. 
  ;; Each element of the list looks like this: (PROC INFO ...)
  ;; PROC is the process associated with the multicast connection.
  ;; INFO is an alist of group information. Each element looks like this:
  ;; (KEY VALUE ...). The following keys currently exist:
  ;; name:    the mchat group name and address: "name" "dest/port/ttl"
  ;; buffer:  the mchat group buffer id.		   
  ;; who:     the list of known members of the group.
  ;; mode:    wether you follow the conversation. 'suspended or 'listening
  "Don't even think about this !")


;;; Internal misc utilities -------------------------------------------------

(defun mchat-read-string (prompt)
  ;; Read a non empty string from minibuffer and return it.
  (let ((str ""))
    (while (equal str "")
      (setq str (read-string prompt)))
    str))
	
(defmacro mchat-with-mchat-buffer (where &rest body)
  ;; Execute the forms in BODY with the buffer specified by WHERE as the
  ;; current buffer. WHERE can be an mchat buffer or process. 
  ;; It is temporarily set writable.
  `(save-current-buffer
     (set-buffer 
      (or (and (processp ,where)
	       (cdr (assoc 'buffer (assq ,where mchat-living-groups))))
	  (and (bufferp ,where)
	       ,where)
	  (error "WHERE must be an mchat buffer or process")))
      (setq buffer-read-only nil) ;; temporarily
      (end-of-buffer)
      ,@body
      (setq buffer-read-only t)))

(defmacro mchat-with-meta-face (&rest body)
  ;; Execute body and put all inserted text in mchat-meta-face
  `(let ((start (point)))
     ,@body
     (set-extent-face (make-extent start (point)) 'mchat-meta-face)))


;;; Private functions ------------------------------------------------------

(defun mchat-known-groups ()
  ;; Returns an alist similar to mchat-predefined-groups, but with the living
  ;; groups too.
  (let ((grplist mchat-predefined-groups)
	(ptr mchat-living-groups)
	grp)
    (while ptr
      (setq grp (cdr (assoc 'name (car ptr))))
      ;; If this current group is not predefined, add it.
      (if (not (assoc (car grp) mchat-predefined-groups))
	  (setq grplist (cons (cons (car grp) (cadr grp)) grplist)))
      (setq ptr (cdr ptr)))
    grplist
    ))

(defun mchat-get-group-from (key value)
  ;; Given the (key value) pair, return the first group for which this pair
  ;; exists in the group info alist, or nil otherwise.
  ;; This will be used with ('group "name" "address") or with ('buffer buf)
  ;; which should be unique anyway.
  (let ((grplist mchat-living-groups)
	found)
    (while (and (not found) (car grplist))
      (if (equal value (cdr (assoc key (car grplist))))
	  (setq found t)
	(setq grplist (cdr grplist))))
    (car grplist)))

(defun mchat-maybe-add-member (proc who)
  ;; Add member to the who list if not present. 
  ;; Return t if added, or nil if already present.
  (let* ((group (assq proc mchat-living-groups))
	 (wholist (cdr (assoc 'who group)))
	 (here (member who wholist)))
    (when (not here)
      (setq mchat-living-groups (remassq proc mchat-living-groups))
      (setq group (remassoc 'who group))
      (setq wholist (cons 'who (cons who wholist)))
      (setq group (append group (list wholist)))
      (setq mchat-living-groups (append mchat-living-groups (list group))))
    (not here)))

(defun mchat-maybe-delete-member (proc who)
  ;; Delete member from the 'who' list.
  ;; I don't delete me, since I don't allow multiple occurences in the who 
  ;; list. 
  (when (not (string= who mchat-prompt))
    (let* ((group (assq proc mchat-living-groups))
	   (wholist (cdr (assoc 'who group)))
	   (newlist (delete who wholist)))
      (setq mchat-living-groups (remassq proc mchat-living-groups))
      (setq group (remassoc 'who group))
      (setq group (append group (list (cons 'who newlist))))
      (setq mchat-living-groups (append mchat-living-groups (list group)))
      )))

(defun mchat-buffer-group-or-ask ()
  ;; Return the current-buffer's group info alist, or prompts the user for an
  ;; *existing* group.
  (or (mchat-get-group-from 'buffer (current-buffer))
      (let ((ptr mchat-living-groups)
	    name current-groups)
	(while ptr
	  (setq current-groups 
		(cons (cdr (assoc 'name (car ptr))) current-groups))
	  (setq ptr (cdr ptr)))
	(setq name (completing-read "Group: " current-groups nil t))
	(mchat-get-group-from 'name (assoc name current-groups))
	)))

(defun mchat-kill-buffer-hook ()
  ;; This should be called only on an mchat active group's buffer. The mchat
  ;; buffer is current. However, we handle possible accidents such as 
  ;; process deleted ...
  (let* ((proc (get-buffer-process (current-buffer)))
	 (group (mchat-get-group-from 'buffer (current-buffer))))
    (when proc
      (mchat-message proc ":quit")
      (delete-process proc))
    (when group
      (setq mchat-living-groups (remassq (car group) mchat-living-groups)))
    ))
      

(defun mchat-mode ()
  ;; Setup the mchat major mode in the current buffer.
  (kill-all-local-variables)
  (setq buffer-read-only t)
  (use-local-map mchat-mode-map)
  (setq major-mode 'mchat-mode)
  (setq mode-name "MChat")
  (make-local-hook 'kill-buffer-hook)
  (add-hook 'kill-buffer-hook 'mchat-kill-buffer-hook nil t))

(defun mchat-insert-meta-line (line &rest args)
  ;; Insert a 'meta' message line in the current buffer
  (insert (concat " > " (apply 'format line args) "\n")))

(defun mchat-handle-message (proc from msg)
  ;; Handle the messages and their possible special treatments.
  ;; The messages here correspond to single datagrams.
  (let ((mode (cdr (assoc 'mode (assq proc mchat-living-groups)))))
    (mchat-with-mchat-buffer 
     proc
     (cond ((string= msg ":quit")
	    (mchat-maybe-delete-member proc from)
	    (and (> mchat-verbose-level 0) (equal mode 'listening)
		 (mchat-with-meta-face
		  (mchat-insert-meta-line (concat from " quits")))))
	   ((string= msg ":join")
	    (mchat-message proc ":here") ;; Say we're here.
	    (and (mchat-maybe-add-member proc from)
		 (> mchat-verbose-level 0)
		 (equal mode 'listening)
		 (mchat-with-meta-face
		  (mchat-insert-meta-line (concat from " joins")))))
	   ((string= msg ":who")
	    (mchat-message proc ":here") ;; Say we're here.
	    (and (mchat-maybe-add-member proc from)
		 (> mchat-verbose-level 0)
		 (equal mode 'listening)
		 (mchat-with-meta-face
		  (mchat-insert-meta-line (concat from " is here")))))
	   ((string= msg ":here")
	    (and (mchat-maybe-add-member proc from)
		 (> mchat-verbose-level 0)
		 (equal mode 'listening)
		 (mchat-with-meta-face
		  (mchat-insert-meta-line (concat from " is here")))))
	   ((string= msg ":beep")
	    (mchat-maybe-add-member proc from)
	    (and (> mchat-verbose-level 0)
		 (equal mode 'listening)
		 (progn
		   (mchat-with-meta-face
		    (mchat-insert-meta-line (concat from " rings")))
		   (when mchat-beep-sound
		     (let ((snd (and (or (featurep 'native-sound)
					 (featurep 'nas-sound))
				     (device-sound-enabled-p))))
		       (if (and (not (equal mchat-beep-sound 't)) snd)
			   (ding t mchat-beep-sound)
			 (ding t)))))))
	   (t ;; A normal message
	    (mchat-maybe-add-member proc from) ;; No use signaling him.
	    (if (equal mode 'listening)
		(let ((start (point)))
		  (insert (concat from " > "))
		  (set-extent-face (make-extent start (point))
				   'mchat-prompt-face)
		  (insert (concat msg "\n"))))
	    ))
     )))

(defun mchat-decompose-message (proc str)
  ;; Given a message, separate sender / message and check
  (let ((mode (cdr (assoc 'mode (assq proc mchat-living-groups)))))
    (or (and (string-match "^\\([^:]+\\):\\(.+\\)" str)
	     (let ((from (match-string 1 str))
		   (msg (match-string 2 str)))
	       (when (and from msg)
		 (mchat-handle-message proc from msg)
		 t)))
	(if (and (> mchat-verbose-level 1)
		 (equal mode 'listening))
	    (mchat-with-mchat-buffer
	     proc
	     (mchat-with-meta-face
	      (mchat-insert-meta-line
	       (concat "Corrupted message: '" str "'"))))))
    ))

(defun mchat-process-filter (proc str)
  ;; Filter the output from the multicast group.
  ;; There might be several messages concatenated, but we assume that all
  ;; messages (that are contained in a single datagram) are received entirely.
  ;; Messages are separated by a "\n", so here we separate the messages.
  (let ((rest str)
	(mode (cdr (assoc 'mode (assq proc mchat-living-groups)))))
    (while rest
      (or (and (string-match "\\(.+\\)\n" rest)
	       (let ((end (match-end 0)))
		 (mchat-decompose-message proc (match-string 1 rest))
		 (if (= end (length rest))
		     (setq rest nil)
		   (setq rest (substring rest end)))
		 t))
	  (progn
	    (if (and (> mchat-verbose-level 1)
		     (equal mode 'listening))
		(mchat-with-mchat-buffer
		 proc
		 (mchat-with-meta-face
		  (mchat-insert-meta-line 
		   (concat "Corrupted sequence: '" rest "'")))))
	    (setq rest nil))
	  ))
    ))


;;; Public functions --------------------------------------------------------

(defun mchat-message (proc msg)
  "Prompts you for a message to send to the mchat multicast group associated 
with the current buffer. If not called from an mchat buffer, prompts you for 
the group too."
  (interactive 
   (list (car (mchat-buffer-group-or-ask))
	 (mchat-read-string "line: ")))
  ;; The end of a message is signaled by a "\n"
  (process-send-string proc (concat mchat-prompt ":" msg "\n")))

(defun mchat-ring (proc)
  "Ring the mchat group. If people are not looking at the buffer, 
at least they can hear you... Annoy-user ;-)
If not called from an mchat buffer, prompts you for the group too."
  (interactive (list (car (mchat-buffer-group-or-ask))))
  (mchat-message proc ":beep"))

(defun mchat-who (group)
  "Displays all the people participating to the mchat group associated with
the current buffer. If not called from an mchat buffer, prompts you for 
the group too. This just displays the members you currently know. To actually
send a request to the group, type `W' instead of `w' in the buffer."
  (interactive (list (mchat-buffer-group-or-ask)))
  (mchat-with-mchat-buffer 
   (car group)
   (let ((wholist (cdr (assoc 'who group))))
     (mchat-with-meta-face
      (insert "---\n")
      (while wholist
	(if (string= (car wholist) mchat-prompt)
	    (mchat-insert-meta-line "I'm here")
	  (mchat-insert-meta-line (concat (car wholist) " is here")))
	(setq wholist (cdr wholist)))
      (insert "---\n"))
     )))

(defun mchat-Who (proc)
  "Send an identification request to the group. This will force people to
answer, so you may update your member list if somehow you missed somebody.
People you'd missed before will be displayed in the mchat buffer. To just 
see the list of people you currently know, type `w' instead of `W' in the
mchat buffer."
  (interactive (list (car (mchat-buffer-group-or-ask))))
  (mchat-message proc ":who"))

(defun mchat-quit (group)
  "Leave the mchat group and close the connection associated with the curent 
buffer. If not called from an mchat buffer, prompts you for the group too."
  (interactive (list (mchat-buffer-group-or-ask)))
  ;; The hook will do the cleanup.
  (kill-buffer (buffer-name (cdr (assoc 'buffer group)))))

(defun mchat-suspend (proc)
  "Toggle between listening and suspended mode. The normal mode is listening.
In suspemded mode, you're still connected to the group (that is, you'll 
answer control messages and requests) but the conversation will be lost."
  (interactive (list (car (mchat-buffer-group-or-ask))))
  (let* ((group (assq proc mchat-living-groups))
	 (mode (if (equal (cdr (assoc 'mode group)) 'suspended)
		   'listening 'suspended)))
    (setq mchat-living-groups (remassq proc mchat-living-groups))
    (setq group (remassoc 'mode group))
    (setq group (append group (list (cons 'mode mode))))
    (setq mchat-living-groups (append mchat-living-groups (list group)))
    (mchat-with-mchat-buffer 
     proc
     (if (featurep 'menubar)
	 (add-menu-button '("MChat")
			  `[ "listening is " mchat-suspend t 
			     ,(if (equal mode 'listening) "on" "off")]))
     (mchat-with-meta-face
      (mchat-insert-meta-line "mchat is %s" (symbol-name mode))))
    ))

(defun mchat-erase-buffer (group)
  "Erase the contents of the mchat buffer. If not called from an mchat buffer,
prompts you for the group too."
  (interactive (list (mchat-buffer-group-or-ask)))
  (mchat-with-mchat-buffer
   (car group) ;; proc
   (erase-buffer)))

(defun mchat-define-group ()
  "Add the current group to the list of predefined groups. 
If not called from an mchat buffer, prompts you for the group too."
  ;; The group doesn't have to be living, and doesn't have to bge known
  ;; either. So don't use mchat-buffer-group-or-ask.
  (interactive)
  (let* ((grp (mchat-get-group-from 'buffer (current-buffer)))
	 (name (or (and grp (cadr (assoc 'name grp)))
		   (completing-read "Name: " (mchat-known-groups))))
	 (address (or (and grp (caddr (assoc 'name grp)))
		      (cdr (assoc name (mchat-known-groups)))
		      (mchat-read-string "Address: "))))
    (setq grp (cons name address))
    (if (member grp mchat-predefined-groups)
	(message "This group is already defined.")
      ;; Else
      (setq mchat-predefined-groups 
	    (append (list grp) mchat-predefined-groups))
      (when (y-or-n-p "Group defined. Save it for future sessions ? ")
	(custom-set-variables 
	 `(mchat-predefined-groups (quote ,mchat-predefined-groups) t))
	(custom-save-all)))
    ))
    
(defun mchat-remove-group ()
  "Remove the current group from the list of predefined groups. 
If not called from an mchat buffer, prompts you for the group too."
  ;; The group doesn't have to be living, So don't use
  ;; mchat-buffer-group-or-ask.
  (interactive)
  (let* ((grp (mchat-get-group-from 'buffer (current-buffer)))
	 (name (or (and grp (cadr (assoc 'name grp)))
		   (completing-read "Name: " (mchat-known-groups) nil t))))
    (setq mchat-predefined-groups (remassoc name mchat-predefined-groups))
    (when (y-or-n-p "Group removed. Save it for future sessions ? ")
      (custom-set-variables 
       `(mchat-predefined-groups (quote ,mchat-predefined-groups) t))
      (custom-save-all))
    ))
    

(defun mchat-group-address ()
  "Show the address of the current mchat group. If not called from an mchat
buffer, prompts you for the group too."
  ;; The group doesn't have to be living. So don't use
  ;; mchat-buffer-group-or-ask.
  (interactive)
  (let* ((grp (mchat-get-group-from 'buffer (current-buffer)))
	 (name (or (and grp (cadr (assoc 'name grp)))
		   (completing-read "Name: " (mchat-known-groups) nil t)))
	 (address (or (and grp (caddr (assoc 'name grp)))
		      (cdr (assoc name (mchat-known-groups))))))
    (message "%s address is %s" name address)))

(defun mchat-version ()
  "Print the version number of the current mchat package."
  (interactive)
  (message "MChat version is %s" mchat-version))

;;;###autoload
(defun mchat (name address)
  "This function starts mchat on the given multicast group. You can select 
either a predefined group (see `mchat-predefined-groups'), or give a group 
name and an address. You can give the name you want. See the function 
`open-multicast-group' for more details on the address.

When called with a prefix, open the group in a newly created frame."
  (interactive
   ;; We won't allow the same name for different groups, so if a known name is
   ;; given, don't ask for the address. The completion occurs for both
   ;; predefined and current groups.
   (let* ((groups (mchat-known-groups))
	  (grpname (completing-read "Name: " groups))
	  (grpaddr (or (cdr (assoc grpname groups))
		       (mchat-read-string "Address: "))))
     (list grpname grpaddr)))
  (let ((group (mchat-get-group-from 'name (list name address))))
    (if group
	;; the group already exist, just switch to the buffer.
	(funcall (if current-prefix-arg
		     'switch-to-buffer-other-frame
		   'switch-to-buffer)
		 (cdr (assoc 'buffer group)))
      ;; else (group doesn't exist) create a new group.
      (let* ((bufname (concat "MChat on " name))
	     (proc (open-multicast-group bufname bufname address)))
	(when proc ;; usefull ?? neeeeeey.
	  ;; Add this new group to the list.
	  (setq mchat-living-groups
		(cons
		 `(,proc (name ,name ,address)
			 (buffer . ,(process-buffer proc))
			 (who ,mchat-prompt) ;; I know only me at startup.
			 (mode . listening))
		 mchat-living-groups))
	  (set-process-filter proc 'mchat-process-filter)
	  (if current-prefix-arg
	      (select-frame (make-frame)))
	  (switch-to-buffer (process-buffer proc))
	  (delete-other-windows)
	  (mchat-mode)
	  (if (featurep 'menubar)
	      (add-submenu nil mchat-submenu))
	  ;; Announce my presence.
	  (mchat-message proc ":join")
	  )))
    ))

(provide 'mchat)

(run-hooks 'mchat-loaded-hook)


;;; mchat.el ends here
