-
-
Notifications
You must be signed in to change notification settings - Fork 24
/
Copy pathCHATEMACS
334 lines (307 loc) · 18.9 KB
/
CHATEMACS
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "31-Mar-89 17:08:22" {ERINYES}<LISPUSERS>MEDLEY>CHATEMACS.;2 19237
changes to%: (FILES CHATDECLS)
(FNS CHAT.BUTTONFN CHAT.TYPEIN CHAT.TYPEOUT CHAT.SCREENPARAMS)
(VARS CHATEMACSCOMS)
previous date%: "18-Jan-89 16:46:52" |{IE:PARC:XEROX}<LISPUSERS>MEDLEY>CHATEMACS.;1|)
(* "
Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CHATEMACSCOMS)
(RPAQQ CHATEMACSCOMS
((DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (SOURCE FROM LOADUP)
CHATDECLS))
(DECLARE%: (GLOBALVARS CHATEMACS.SWITCH.ENABLED CHAT.META.ESC))
(INITVARS (CHATEMACS.SWITCH.ENABLED T)
(CHAT.META.ESC T))
(FNS CHAT.BUTTONFN CHAT.TYPEIN CHAT.TYPEOUT CHAT.SCREENPARAMS)
(ADVISE CHAT.INIT CHAT.CLOSE)))
(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD (SOURCE FROM LOADUP)
CHATDECLS)
)
(DECLARE%:
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CHATEMACS.SWITCH.ENABLED CHAT.META.ESC)
)
)
(RPAQ? CHATEMACS.SWITCH.ENABLED T)
(RPAQ? CHAT.META.ESC T)
(DEFINEQ
(CHAT.BUTTONFN
[LAMBDA (WINDOW) (* ; "Edited 4-Mar-89 21:55 by Randy.Gobbel")
(GETMOUSESTATE)
(if (type? CHAT.STATE (WINDOWPROP WINDOW 'CHATSTATE))
then [with CHAT.STATE (WINDOWPROP WINDOW 'CHATSTATE)
(LET ((CY (LASTMOUSEY WINDOW))
(CX (LASTMOUSEX WINDOW))
(BUTTONS LASTMOUSEBUTTONS)
(TTYLINES (IQUOTIENT TTYHEIGHT FONTHEIGHT))
CSTRING
(SHIFTSTATE 0))
(* ;; "The characters are FONTHEIGHT high by FONTWIDTH wide")
(COND
[(IGREATERP CY TOPMARGIN)
(COND
((MOUSESTATE (ONLY RIGHT))
(DOWINDOWCOM WINDOW))
((MOUSESTATE (ONLY MIDDLE))
(CHAT.MENU WINDOW]
((EQ BUTTONS 0)
NIL)
(CHATINEMACS (for SS in '(SHIFT CTRL META) as I
from 1 by I when (SHIFTDOWNP SS)
do (SETQ SHIFTSTATE (IPLUS SHIFTSTATE I)))
(SETQ CY (MAX (SUB1 (IDIFFERENCE TTYLINES (IQUOTIENT CY
FONTHEIGHT)))
0))
(SETQ CX (IQUOTIENT (IPLUS (IQUOTIENT FONTWIDTH 2)
CX)
FONTWIDTH))
(SETQ CSTRING
(CONCAT (CHARACTER (CHARCODE ^\))
"m" CX ";" CY ";" BUTTONS ";" SHIFTSTATE ";"))
(UNINTERRUPTABLY
(BKSYSBUF CSTRING)))
(T (CHAT.HOLD WINDOW]
else (DOWINDOWCOM WINDOW])
(CHAT.TYPEIN
[LAMBDA (HOST WINDOW LOGOPTION INITSTREAM) (* ; "Edited 4-Mar-89 21:55 by Randy.Gobbel")
(DECLARE (SPECVARS STREAM)) (* ; "so that menu can change it")
(PROG ((THISPROC (THIS.PROCESS))
(DEFAULTSTREAM T)
(STATE (WINDOWPROP WINDOW 'CHATSTATE))
CHATSTREAM INSTREAM WINDOWSTREAM STREAM CH DISPLAYTYPE DISPLAYNAME CHATPROMPTWINDOW
CSTRING)
(SETQ CHATSTREAM (fetch (CHAT.STATE OUTSTREAM) of STATE))
(SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of STATE))
(PROCESSPROP THISPROC 'TTYEXITFN (FUNCTION CHAT.TTYEXITFN))
(PROCESSPROP THISPROC 'TTYENTRYFN (FUNCTION CHAT.TTYENTRYFN))
(COND
((TTY.PROCESSP)
(* ;; "Already have tty (probably from menu), so explicitly turn off interrupts, since our TTYENTRYFN hadn't been set yet (so that ^E could interrupt GETCHATWINDOW)")
(CHAT.TTYENTRYFN THISPROC))
(T (* ;
"want to do this early so users can start typing ahead")
(TTY.PROCESS THISPROC)))
(PROCESSPROP THISPROC 'WINDOW WINDOW)
(SETQ WINDOWSTREAM (WINDOWPROP WINDOW 'DSP))
(DSPFONT (OR CHAT.FONT (DEFAULTFONT 'DISPLAY))
WINDOWSTREAM)
(DSPRESET WINDOWSTREAM)
(WINDOWPROP WINDOW 'PROCESS (THIS.PROCESS))
(WINDOWPROP WINDOW 'CHATHOST (CONS HOST LOGOPTION))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (WINDOW STATE)
(AND RESETSTATE (fetch (CHAT.STATE RUNNING?)
of STATE)
(CHAT.CLOSE WINDOW T]
WINDOW STATE)) (* ;
"If an error occurs, process is killed, or HARDRESET happens, this will flush the connection etc")
[COND
((SETQ DISPLAYTYPE (STREAMPROP INSTREAM 'DISPLAYTYPE))
(SETQ DISPLAYNAME (fetch (CHATDISPLAYTYPE DPYNAME) of DISPLAYTYPE]
(replace (CHAT.STATE TYPEOUTPROC) of STATE
with (ADD.PROCESS `(CHAT.TYPEOUT ,WINDOW ',DISPLAYNAME ',STATE)
'%,NAME
'CHAT.TYPEOUT))
[COND
(DISPLAYTYPE (CHAT.SETDISPLAYTYPE INSTREAM (fetch (CHATDISPLAYTYPE DPYCODE)
of DISPLAYTYPE]
(CHAT.SCREENPARAMS STATE INSTREAM WINDOW)
(AND (NEQ LOGOPTION 'NONE)
(CHAT.LOGIN HOST LOGOPTION WINDOW STATE))
[COND
(INITSTREAM (NLSETQ (SETQ STREAM (COND
((STRINGP INITSTREAM)
(OPENSTRINGSTREAM INITSTREAM))
(T (OPENSTREAM INITSTREAM 'INPUT]
(TTYDISPLAYSTREAM WINDOWSTREAM) (* ;
"So that \TTYBACKGROUND flashes the caret where we expect")
(while (EQ (fetch (CHAT.STATE RUNNING?) of STATE)
T)
do (COND
((NULL STREAM)
(SETQ STREAM DEFAULTSTREAM)))
[COND
[(EQ STREAM T)
(* ;; "Handle terminal differently. Mainly because we may be inside a blocked process's \fillbuffer, making READP think there is input. Ugh!!!")
[COND
((STREAMPROP CHATSTREAM 'SEND.SCREEN.SIZE)
(STREAMPROP CHATSTREAM 'SEND.SCREEN.SIZE NIL)
(SETQ CSTRING (CONCAT (CHARACTER (CHARCODE ^\))
"s"
(IQUOTIENT (fetch (CHAT.STATE TTYWIDTH)
of STATE)
(fetch (CHAT.STATE FONTWIDTH) of
STATE))
";"
(IQUOTIENT (fetch (CHAT.STATE TTYHEIGHT)
of STATE)
(fetch (CHAT.STATE FONTHEIGHT)
of STATE))
";"))
(UNINTERRUPTABLY
(BKSYSBUF CSTRING))]
(OR (TTY.PROCESSP)
(\WAIT.FOR.TTY))
(COND
((\SYSBUFP)
(do (SETQ CH (\GETKEY))
(BOUT CHATSTREAM (COND
((AND CHAT.META.ESC (NEQ (LOGAND CH 256)
0))
(BOUT CHATSTREAM 27)
(LOGAND CH 127))
((EQ CH CHAT.CONTROLCHAR)
(* ; "Controlify it")
(LOGAND (CHAT.BIN CHATSTREAM STATE)
31))
((EQ CH CHAT.METACHAR)
(* ; "Prefix meta, turn on 200q bit")
(LOGOR (CHAT.BIN CHATSTREAM STATE)
128))
(T CH))) repeatwhile (\SYSBUFP))
(FORCEOUTPUT CHATSTREAM]
(T [until (EOFP STREAM)
do (BOUT CHATSTREAM (COND
((AND CHAT.META.ESC
(NEQ (LOGAND (SETQ CH (\BIN STREAM))
256)
0))
(BOUT CHATSTREAM 27)
(LOGAND CH 127))
(T CH]
(FORCEOUTPUT CHATSTREAM)
(CLOSEF STREAM)
(SETQ STREAM)
(COND
((SETQ CHATPROMPTWINDOW (GETPROMPTWINDOW WINDOW NIL NIL T))
(* ;
"Indicate completion of Input if came from menu command")
(CLEARW CHATPROMPTWINDOW]
(\TTYBACKGROUND))
(* ;; "Get here if we close connection.")
[SELECTQ (fetch (CHAT.STATE RUNNING?) of STATE)
(CLOSE (CHAT.CLOSE WINDOW))
(ABORT (CHAT.CLOSE WINDOW T))
(NIL (* ; "Already dead."))
(SHOULDNT (CONCAT "Unknown state in CHAT: " (fetch (CHAT.STATE RUNNING?)
of STATE]
(BLOCK])
(CHAT.TYPEOUT
[LAMBDA (WINDOW DPYNAME CHAT.STATE) (* ; "Edited 4-Mar-89 21:44 by Randy.Gobbel")
(bind (CNT _ 1)
HANDLECHARFN MSG CH INSTREAM DSPSTREAM TYPESCRIPTSTREAM CRPENDING ESCPENDING TERM.STATE
CHAT.OUTSTREAM first (SETQ INSTREAM (fetch (CHAT.STATE INSTREAM) of CHAT.STATE
))
(SETQ CHAT.OUTSTREAM (fetch (CHAT.STATE OUTSTREAM) of
CHAT.STATE
))
(SETQ HANDLECHARFN (CADR (FASSOC DPYNAME CHAT.DRIVERTYPES)))
(replace (CHAT.STATE TERM.STATE) of CHAT.STATE
with (SETQ TERM.STATE (APPLY* (CADDR (FASSOC DPYNAME
CHAT.DRIVERTYPES))
CHAT.STATE)))
[COND
[(EQ DPYNAME 'TEDIT)
(SETQ DSPSTREAM (WINDOWPROP WINDOW 'TEXTSTREAM]
(T (SETQ DSPSTREAM (WINDOWPROP WINDOW 'DSP]
(* ; "TERM.HOME CHAT.STATE")
while (IGEQ (SETQ CH (BIN INSTREAM))
0)
do (while (fetch (CHAT.STATE HELD) of CHAT.STATE) do (BLOCK))
(\CHECKCARET DSPSTREAM)
(COND
((SETQ MSG (STREAMPROP INSTREAM 'MESSAGE))
(PRIN1 MSG DSPSTREAM)
(STREAMPROP INSTREAM 'MESSAGE NIL))) (* ;
"Print any protocol related msgs that might have come along while we where asleep")
(SETQ CH (LOGAND CH (MASK.1'S 0 7)))
(if ESCPENDING
then (SETQ ESCPENDING NIL)
(SELCHARQ CH
(1 (if (NOT (fetch (CHAT.STATE CHATINEMACS) of CHAT.STATE))
then (CHAT.SWITCH.EMACS CHAT.STATE WINDOW)
(STREAMPROP CHAT.OUTSTREAM 'SEND.SCREEN.SIZE T)))
(0 (if (fetch (CHAT.STATE CHATINEMACS) of CHAT.STATE)
then (CHAT.SWITCH.EMACS CHAT.STATE WINDOW)))
(PROGN (SPREADAPPLY* HANDLECHARFN (CHARCODE ESC)
CHAT.STATE TERM.STATE)
(SPREADAPPLY* HANDLECHARFN CH CHAT.STATE TERM.STATE)))
else (if (EQ CH (CHARCODE ESC))
then (SETQ ESCPENDING T)
else (SPREADAPPLY* HANDLECHARFN CH CHAT.STATE TERM.STATE)))
[COND
((SETQ TYPESCRIPTSTREAM (fetch (CHAT.STATE TYPESCRIPTSTREAM) of CHAT.STATE))
(COND
((SELCHARQ CH
(CR (PROG1 CRPENDING (SETQ CRPENDING T)))
(LF (COND
(CRPENDING (\OUTCHAR TYPESCRIPTSTREAM (CHARCODE EOL))
(* ;
"Have the typescript put turn crlf into whatever it likes for eol")
(SETQ CRPENDING NIL))
(T T)))
(PROGN (COND
(CRPENDING (\BOUT TYPESCRIPTSTREAM (CHARCODE CR))
(SETQ CRPENDING NIL)))
T))
(\BOUT TYPESCRIPTSTREAM CH]
[COND
(CHATDEBUGFLG (COND
((OR (EQ CHATDEBUGFLG T)
(IGREATERP (add CNT 1)
CHATDEBUGFLG))
(BLOCK)
(SETQ CNT 1] finally (SELECTQ CH
(-1 (CHAT.TYPEOUT.CLOSE WINDOW
DSPSTREAM CHAT.STATE
'CLOSE "closed"))
(-2 (CHAT.TYPEOUT.CLOSE WINDOW
DSPSTREAM CHAT.STATE
'ABORT "aborted"))
(CHAT.TYPEOUT.CLOSE WINDOW DSPSTREAM
CHAT.STATE 'CLOSE
"closed somehow"))
(COND
((NOT (OPENWP WINDOW))
(DEL.PROCESS (WINDOWPROP WINDOW 'PROCESS])
(CHAT.SCREENPARAMS
[LAMBDA (CHAT.STATE INSTREAM WINDOW) (* ; "Edited 4-Mar-89 22:09 by Randy.Gobbel")
(* ;; "Sends screen width, height to partner and updates title. If INSTREAM is NIL then only update title.")
(PROG ((HEIGHT (IMIN [IQUOTIENT (WINDOWPROP WINDOW 'HEIGHT)
(IABS (DSPLINEFEED NIL (WINDOWPROP WINDOW 'DSP]
127))
(WIDTH (IMIN (LINELENGTH NIL WINDOW)
127))
(TITLE (WINDOWPROP WINDOW 'TITLE))
EMACSMODE TITLEMIDDLE)
(COND
(INSTREAM (CHAT.SENDSCREENPARAMS INSTREAM HEIGHT WIDTH)))
[WINDOWPROP WINDOW 'TITLE (CONCAT (SUBSTRING TITLE 1 (SUB1 (OR (SETQ TITLEMIDDLE
(STRPOS ", height" TITLE))
0)))
", height = " HEIGHT ", width = " WIDTH
(COND
[[OR (SETQ EMACSMODE (fetch (CHAT.STATE CHATINEMACS
) of
CHAT.STATE
))
(AND TITLEMIDDLE (NOT (FIXP (NTHCHAR TITLE -1]
(CONCAT ", Emacs " (COND
(EMACSMODE "ON")
(T "OFF"]
(T ""]
(COND
(EMACSMODE (STREAMPROP (fetch (CHAT.STATE OUTSTREAM) of CHAT.STATE)
'SEND.SCREEN.SIZE T])
)
[XCL:REINSTALL-ADVICE 'CHAT.INIT :AFTER '((:LAST (WINDOWPROP WINDOW 'RIGHTBUTTONFN
(FUNCTION CHAT.BUTTONFN]
[XCL:REINSTALL-ADVICE 'CHAT.CLOSE :AFTER '((:LAST (WINDOWPROP WINDOW 'RIGHTBUTTONFN NIL]
(READVISE CHAT.INIT CHAT.CLOSE)
(PUTPROPS CHATEMACS COPYRIGHT ("Xerox Corporation" 1987 1988 1989))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1254 18858 (CHAT.BUTTONFN 1264 . 3610) (CHAT.TYPEIN 3612 . 11510) (CHAT.TYPEOUT 11512
. 16871) (CHAT.SCREENPARAMS 16873 . 18856)))))
STOP