Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
O
os-utils
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
xemacs
os-utils
Commits
e3f72d8c3341
Commit
e3f72d8c3341
authored
24 years ago
by
didierv
Browse files
Options
Downloads
Patches
Plain Diff
MChat 2.1
parent
4d5331fca010
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
mchat.el
+87
-69
87 additions, 69 deletions
mchat.el
with
87 additions
and
69 deletions
mchat.el
+
87
−
69
View file @
e3f72d8c
;;; 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 th
is
;;
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 th
e 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
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment