Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/lib/protocol/xreply.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/lib/protocol/xreply.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* xreply.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *
5 :     * Routines to decode reply, error and event messages received from the server.
6 :     *
7 :     * TODO
8 :     * events
9 :     * decodeKeymapNotify
10 :     * replies
11 :     * decodeAllocColorCellsReply
12 :     * decodeAllocColorPlanesReply
13 :     * decodeGetPointerMappingReply
14 :     * decodeListExtensionsReply
15 :     * decodeQueryExtensionReply
16 :     * decodeQueryKeymapReply
17 :     *)
18 :    
19 :     structure XReply =
20 :     struct
21 :     local
22 :     structure W8 = Word8 and W8V = Word8Vector
23 :     structure G = Geometry
24 :     structure XTy = XProtTypes
25 :     structure XEvt = XEventTypes
26 :    
27 :     val & = LargeWord.andb
28 :     val ++ = LargeWord.orb
29 :     infix & ++
30 :    
31 :     fun isSet(x, i) = ((x & LargeWord.<<(0w1, i)) <> 0w0)
32 :    
33 :     fun pad n = (case Word.andb(Word.fromInt n, 0w3)
34 :     of 0w0 => n
35 :     | r => (n + (4 - Word.toIntX r))
36 :     (* end case *))
37 :    
38 :     fun getString (bv, i, n) = Byte.unpackStringVec (bv, i, SOME n)
39 :    
40 :     val get8 = W8.toLargeWord o W8V.sub
41 :     fun getWord8 arg = Word.fromLargeWord(W8.toLargeWord(W8V.sub arg))
42 :     fun getInt8 arg = W8.toInt(W8V.sub arg)
43 :     fun getSigned8 arg = W8.toIntX(W8V.sub arg)
44 :    
45 :     fun get16 (s, i) = Pack16Big.subVec(s, i div 2)
46 :     fun getWord16 (s, i) = Word.fromLargeWord(get16(s, i))
47 :     fun getInt16 (s, i) = LargeWord.toInt(get16(s, i))
48 :     fun getSigned16 (s, i) = LargeWord.toIntX(Pack16Big.subVecX(s, i div 2))
49 :    
50 :     fun get32 (s, i) = Word32.fromLargeWord(Pack32Big.subVec(s, i div 4))
51 :     fun getSigned32 (s, i) =
52 :     Int32.fromLarge(LargeWord.toLargeInt(Pack32Big.subVecX(s, i div 4)))
53 :     fun getWord (s, i) = Word.fromLargeWord(get32(s, i))
54 :     fun getInt (s, i) = LargeWord.toIntX(Pack32Big.subVecX(s, i div 4))
55 :    
56 :     fun wrapFn name f (s, i) = (f(s, i) handle ex => (
57 :     XDebug.errTrace(fn () => ["**** ", name, "(", Int.toString(W8V.length s), ",",
58 :     Int.toString i, ")\n"]); raise ex))
59 :     val get8 = wrapFn "get8" get8
60 :     val getWord8 = wrapFn "getWord8" getWord8
61 :     val getInt8 = wrapFn "getInt8" getInt8
62 :     val getSigned8 = wrapFn "getSigned8" getSigned8
63 :     val get16 = wrapFn "get16" get16
64 :     val getWord16 = wrapFn "getWord16" getWord16
65 :     val getInt16 = wrapFn "getInt16" getInt16
66 :     val getSigned16 = wrapFn "getSigned16" getSigned16
67 :     val get32 = wrapFn "get32" get32
68 :     val getSigned32 = wrapFn "getSigned32" getSigned32
69 :     val getWord = wrapFn "getWord" getWord
70 :     val getInt = wrapFn "getInt" getInt
71 :    
72 :     fun getList (f, sz : int) (buf, i, n) = let
73 :     fun get (_, 0, l) = List.rev l
74 :     | get (i, n, l) = get (i+sz, n-1, f(buf, i)::l)
75 :     in
76 :     get (i, n, [])
77 :     end
78 :    
79 :     (* get a list of strings, where each string is preceded by a one-byte length
80 :     * field.
81 :     *)
82 :     fun getStringList (buf, i, n) = let
83 :     fun get (_, 0, l) = List.rev l
84 :     | get (i, n, l) = let
85 :     val len = getInt8(buf, i) and j = i+1
86 :     in
87 :     get (j+len, n-1, getString(buf, j, len) :: l)
88 :     end
89 :     in
90 :     get (i, n, [])
91 :     end
92 :    
93 :     val getXAtom = (XTy.XAtom o getWord)
94 :     fun getXAtomOption arg = (case getWord arg
95 :     of 0w0 => NONE
96 :     | x => SOME(XTy.XAtom x)
97 :     (* end case *))
98 :     val getXId = (XTy.XID o getWord)
99 :     fun getXIdOption arg = (case getWord arg
100 :     of 0w0 => NONE
101 :     | x => SOME(XTy.XID x)
102 :     (* end case *))
103 :    
104 :     val getEventMask = (XTy.XEVTMASK o getWord)
105 :     val getVisualId = (XTy.VISUALID o getWord)
106 :     fun getVisualIdOption arg = (case getWord arg
107 :     of 0w0 => NONE
108 :     | x => SOME(XTy.VISUALID x)
109 :     (* end case *))
110 :     val getPixel = XTy.PIXEL o getInt
111 :    
112 :     (* Are time values signed??? *)
113 :     fun getTime (s, i) = XTime.XT(get32(s, i))
114 :     fun getTS (s, i) = (case get32(s, i)
115 :     of 0w0 => XTy.CurrentTime
116 :     | t => XTy.TimeStamp(XTime.XT t)
117 :     (* end case *))
118 :    
119 :     fun getBool arg = (case (W8V.sub arg) of 0w0 => false | _ => true)
120 :     fun getPt (s, i) = G.PT{ x = getSigned16(s, i), y = getSigned16(s, i+2) }
121 :     fun getSize (s, i) = G.SIZE{ wid = getInt16(s, i), ht = getInt16(s, i+2) }
122 :     fun getRect (s, i) = G.RECT{
123 :     x = getSigned16(s, i), y = getSigned16(s, i+2),
124 :     wid = getInt16(s, i+4), ht = getInt16(s, i+6)
125 :     }
126 :     fun getWGeom (s, i) = G.WGEOM{
127 :     pos = getPt(s, i), sz = getSize(s, i+4), border = getInt16(s, i+8)
128 :     }
129 :    
130 :     val getKeyCode = XTy.KEYCODE o getInt8
131 :    
132 :     fun getStkPos arg = (case (W8V.sub arg)
133 :     of 0w0 => XTy.PlaceOnTop
134 :     | _ => XTy.PlaceOnBottom
135 :     (* end case *))
136 :    
137 :     fun getFocusMode (s, i) = (case W8V.sub(s, i)
138 :     of 0w0 => XTy.FocusNormal | 0w1 => XTy.FocusGrab
139 :     | 0w2 => XTy.FocusUngrab | 0w3 => XTy.FocusWhileGrabbed
140 :     | _ => MLXError.impossible "bad focus mode"
141 :     (* end case *))
142 :     fun getFocusDetail (s, i) = (case W8V.sub(s, i)
143 :     of 0w0 => XTy.FocusAncestor | 0w1 => XTy.FocusVirtual
144 :     | 0w2 => XTy.FocusInferior | 0w3 => XTy.FocusNonlinear
145 :     | 0w4 => XTy.FocusNonlinearVirtual | 0w5 => XTy.FocusPointer
146 :     | 0w6 => XTy.FocusPointerRoot | 0w7 => XTy.FocusNone
147 :     | _ => MLXError.impossible "bad focus detail"
148 :     (* end case *))
149 :    
150 :     fun getKeyButSet (s, i) = let val m = getWord16(s, i)
151 :     in
152 :     ( XTy.MKState(Word.andb(m, 0wxFF)),
153 :     XTy.MBState(Word.andb(m, 0wx1F00)))
154 :     end
155 :    
156 :     fun getRGB (buf, i) = XTy.RGB{
157 :     red = getWord16(buf, i),
158 :     green = getWord16(buf, i+2),
159 :     blue = getWord16(buf, i+4)
160 :     }
161 :    
162 :     fun getBS (buf, i) = (case W8V.sub(buf, i)
163 :     of 0w0 => XTy.BS_NotUseful
164 :     | 0w1 => XTy.BS_WhenMapped
165 :     | _ => XTy.BS_Always
166 :     (* end case *))
167 :    
168 :     fun getFontDir (buf, i) = (case W8V.sub(buf, i)
169 :     of 0w0 => XTy.FontLeftToRight | 0w1 => XTy.FontRightToLeft
170 :     | _ => MLXError.impossible "bad font direction"
171 :     (* end case *))
172 :    
173 :     val getXIdList = getList (getXId, 4)
174 :     val getXAtomList = getList (getXAtom, 4)
175 :    
176 :     local
177 :     fun toGravity (0w1 : Word8.word) = SOME XTy.NorthWestGravity
178 :     | toGravity 0w2 = SOME XTy.NorthGravity
179 :     | toGravity 0w3 = SOME XTy.NorthEastGravity
180 :     | toGravity 0w4 = SOME XTy.WestGravity
181 :     | toGravity 0w5 = SOME XTy.CenterGravity
182 :     | toGravity 0w6 = SOME XTy.EastGravity
183 :     | toGravity 0w7 = SOME XTy.SouthWestGravity
184 :     | toGravity 0w8 = SOME XTy.SouthGravity
185 :     | toGravity 0w9 = SOME XTy.SouthEastGravity
186 :     | toGravity 0w10 = SOME XTy.StaticGravity
187 :     | toGravity _ = NONE
188 :     in
189 :     fun getBitGravity arg = (case toGravity(W8V.sub arg)
190 :     of NONE => XTy.ForgetGravity
191 :     | SOME g => g
192 :     (* end case *))
193 :     fun getWinGravity arg = (case toGravity(W8V.sub arg)
194 :     of NONE => XTy.UnmapGravity
195 :     | SOME g => g
196 :     (* end case *))
197 :     end (* local *)
198 :    
199 :     fun getRawFormat arg = (case (W8V.sub arg)
200 :     of 0w8 => XTy.Raw8 | 0w16 => XTy.Raw16 | 0w32 => XTy.Raw32
201 :     | _ => MLXError.impossible "[getRawFormat: bad ClientMessage]")
202 :    
203 :     in
204 :    
205 :     (** Get the reply from a connection request **)
206 :     local
207 :     val prefix_sz = 8
208 :     fun getOrder(buf, i) = (case get8(buf, i)
209 :     of 0w0 => XTy.LSBFirst
210 :     | _ => XTy.MSBFirst)
211 :     fun getFormat (buf, i) = XTy.FORMAT {
212 :     depth = getInt8(buf, i),
213 :     bits_per_pixel = getInt8(buf, i+1),
214 :     scanline_pad = getRawFormat(buf, i+2)
215 :     }
216 :     fun getVisualDepth (buf, i, depth) = XTy.VisualDepth{
217 :     id = getVisualId(buf, i),
218 :     depth = depth,
219 :     class = (case W8V.sub(buf, i+4)
220 :     of 0w0 => XTy.StaticGray | 0w1 => XTy.GrayScale
221 :     | 0w2 => XTy.StaticColor | 0w3 => XTy.PseudoColor
222 :     | 0w4 => XTy.TrueColor | 0w5 => XTy.DirectColor
223 :     | _ => MLXError.impossible "bad visual depth"
224 :     (* end case *)),
225 :     bits_per_rgb = getInt8(buf, i+5),
226 :     cmap_entries = getInt16(buf, i+6),
227 :     red_mask = getWord(buf, i+8),
228 :     green_mask = getWord(buf, i+12),
229 :     blue_mask = getWord(buf, i+16)
230 :     }
231 :     fun getVisualDepthList (buf, i, ndepths) = let
232 :     fun getDepths (0, i, l) = (List.rev l, i)
233 :     | getDepths (ndepths, i, l) = let
234 :     val depth = getInt8(buf, i)
235 :     in
236 :     case (getInt16(buf, i+2))
237 :     of 0 => getDepths (ndepths-1, i+8, (XTy.Depth depth)::l)
238 :     | nVisuals => getVisuals (ndepths-1, depth, nVisuals, i+8, l)
239 :     end
240 :     and getVisuals (ndepths, _, 0, i, l) = getDepths (ndepths, i, l)
241 :     | getVisuals (ndepths, depth, k, i, l) =
242 :     getVisuals (ndepths, depth, k-1, i+24,
243 :     getVisualDepth(buf, i, depth)::l)
244 :     in
245 :     getDepths (ndepths, i, [])
246 :     end
247 :     fun getScreen (buf, i) = let
248 :     val (vdepths, next) = getVisualDepthList(buf, i+40, getInt8(buf, i+39))
249 :     in (
250 :     {
251 :     root_win = getXId(buf, i),
252 :     cmap = getXId(buf, i+4),
253 :     white = getPixel(buf, i+8),
254 :     black = getPixel(buf, i+12),
255 :     input_masks = getEventMask(buf, i+16),
256 :     pixel_wid = getInt16(buf, i+20),
257 :     pixel_ht = getInt16(buf, i+22),
258 :     mm_wid = getInt16(buf, i+24),
259 :     mm_ht = getInt16(buf, i+26),
260 :     installed_maps = {min = getInt16(buf, i+28), max = getInt16(buf, i+30)},
261 :     root_visualid = getVisualId(buf, i+32),
262 :     backing_store = getBS(buf, i+36),
263 :     save_unders = getBool(buf, i+37),
264 :     root_depth = getInt8(buf, i+38),
265 :     visualdepths = vdepths
266 :     }, next)
267 :     end
268 :     val getFormats = getList (getFormat, 8)
269 :     fun getScreens (buf, i, nscreens) = let
270 :     fun get (0, _, l) = List.rev l
271 :     | get (n, i, l) = let
272 :     val (scr, next) = getScreen(buf, i)
273 :     in
274 :     get(n-1, next, scr::l)
275 :     end
276 :     in
277 :     get (nscreens, i, [])
278 :     end
279 :     in
280 :     fun decodeConnectReqReply (prefix, msg) = let
281 :     val vendor_len = getInt16(msg, 16)
282 :     val nscreens = getInt8(msg, 20)
283 :     val nformats = getInt8(msg, 21)
284 :     val format_offset = pad (32 + vendor_len)
285 :     val screen_offset = format_offset + 8*nformats
286 :     in {
287 :     protocol_version = {
288 :     major = getInt16(prefix, 2),
289 :     minor = getInt16(prefix, 4)
290 :     },
291 :     release_num = getInt(msg, 0),
292 :     rsrc_id_base = getWord(msg, 4),
293 :     rsrc_id_mask = getWord(msg, 8),
294 :     motion_buf_sz = getInt(msg, 12),
295 :     max_req_len = getInt16(msg, 18),
296 :     im_byte_order = getOrder(msg, 22),
297 :     bitmap_order = getOrder(msg, 23),
298 :     bitmap_scanline_unit = getRawFormat(msg, 24),
299 :     bitmap_scanline_pad = getRawFormat(msg, 25),
300 :     min_keycode = getKeyCode(msg, 26),
301 :     max_keycode = getKeyCode(msg, 27),
302 :     vendor = getString(msg, 32, vendor_len),
303 :     formats = getFormats(msg, format_offset, nformats),
304 :     roots = getScreens(msg, screen_offset, nscreens)
305 :     } end
306 :     end (* local *)
307 :    
308 :    
309 :     (** decode event messages **)
310 :    
311 :     local
312 :     fun getKeyXEvt buf = let val (mks, mbs) = getKeyButSet(buf, 28)
313 :     in {
314 :     keycode = getKeyCode(buf, 1),
315 :     time = getTime(buf, 4),
316 :     root = getXId(buf, 8),
317 :     event = getXId(buf, 12),
318 :     child = getXIdOption(buf, 16),
319 :     root_pt = getPt(buf, 20),
320 :     event_pt = getPt(buf, 24),
321 :     mod_state = mks,
322 :     mbut_state = mbs,
323 :     same_screen = getBool(buf, 30)
324 :     } end
325 :     fun getButtonXEvt buf = let val (mks, mbs) = getKeyButSet(buf, 28)
326 :     in {
327 :     button = XTy.MButton(getInt8(buf, 1)),
328 :     time = getTime(buf, 4),
329 :     root = getXId(buf, 8),
330 :     event = getXId(buf, 12),
331 :     child = getXIdOption(buf, 16),
332 :     root_pt = getPt(buf, 20),
333 :     event_pt = getPt(buf, 24),
334 :     mod_state = mks,
335 :     mbut_state = mbs,
336 :     same_screen = getBool(buf, 30)
337 :     } end
338 :     fun decodeMotionNotify buf = let
339 :     val (mks, mbs) = getKeyButSet(buf, 28)
340 :     in
341 :     XEvt.MotionNotifyXEvt {
342 :     hint = getBool(buf, 1),
343 :     time = getTime(buf, 4),
344 :     root = getXId(buf, 8),
345 :     event = getXId(buf, 12),
346 :     child = getXIdOption(buf, 16),
347 :     root_pt = getPt(buf, 20),
348 :     event_pt = getPt(buf, 24),
349 :     mod_state = mks,
350 :     mbut_state = mbs,
351 :     same_screen = getBool(buf, 30)
352 :     }
353 :     end
354 :     fun getEnterLeaveXEvt buf = let
355 :     val (mks, mbs) = getKeyButSet(buf, 28)
356 :     val flags = get8(buf, 31)
357 :     in {
358 :     detail = getFocusDetail(buf, 1),
359 :     time = getTime(buf, 4),
360 :     root = getXId(buf, 8),
361 :     event = getXId(buf, 12),
362 :     child = getXIdOption(buf, 16),
363 :     root_pt = getPt(buf, 20),
364 :     event_pt = getPt(buf, 24),
365 :     mod_state = mks,
366 :     mbut_state = mbs,
367 :     mode = getFocusMode(buf, 30),
368 :     focus = isSet(flags, 0w0),
369 :     same_screen = isSet(flags, 0w1)
370 :     } end
371 :     fun getFocusXEvt buf = {
372 :     detail = getFocusDetail(buf, 1),
373 :     event = getXId(buf, 4),
374 :     mode = getFocusMode(buf, 8)
375 :     }
376 :     fun decodeKeymapNotify buf =
377 :     XEvt.KeymapNotifyXEvt {}(** NOTE: no seqn # **) (** FIX **)
378 :     fun decodeExpose buf = XEvt.ExposeXEvt {
379 :     window = getXId(buf, 4),
380 :     rects = [getRect(buf, 8)],
381 :     count = getInt16(buf, 16)
382 :     }
383 :     fun decodeGraphicsExpose buf = XEvt.GraphicsExposeXEvt {
384 :     drawable = getXId(buf, 4),
385 :     rect = getRect(buf, 8),
386 :     minor_opcode = getWord16(buf, 16),
387 :     count = getInt16(buf, 18),
388 :     major_opcode = getWord16(buf, 20)
389 :     }
390 :     fun decodeNoExpose buf = XEvt.NoExposeXEvt {
391 :     drawable = getXId(buf, 4),
392 :     minor_opcode = getWord16(buf, 8),
393 :     major_opcode = getWord16(buf, 10)
394 :     }
395 :     fun decodeVisibilityNotify buf = XEvt.VisibilityNotifyXEvt {
396 :     window = getXId(buf, 4),
397 :     state = (case W8V.sub(buf, 8)
398 :     of 0w0 => XTy.VisibilityUnobscured
399 :     | 0w1 => XTy.VisibilityPartiallyObscured
400 :     | 0w2 => XTy.VisibilityFullyObscured
401 :     | _ => MLXError.impossible "bad VisibilityNotify"
402 :     (* end case *))
403 :     }
404 :     fun decodeCreateNotify buf = XEvt.CreateNotifyXEvt {
405 :     parent = getXId(buf, 4),
406 :     window = getXId(buf, 8),
407 :     rect = getRect(buf, 12),
408 :     border_wid = getInt16(buf, 20),
409 :     override_redirect = getBool(buf, 21)
410 :     }
411 :     fun decodeDestroyNotify buf = XEvt.DestroyNotifyXEvt {
412 :     event = getXId(buf, 4),
413 :     window = getXId(buf, 8)
414 :     }
415 :     fun decodeUnmapNotify buf = XEvt.UnmapNotifyXEvt {
416 :     event = getXId(buf, 4),
417 :     window = getXId(buf, 8),
418 :     from_config = getBool(buf, 12)
419 :     }
420 :     fun decodeMapNotify buf = XEvt.MapNotifyXEvt {
421 :     event = getXId(buf, 4),
422 :     window = getXId(buf, 8),
423 :     override_redirect = getBool(buf, 12)
424 :     }
425 :     fun decodeMapRequest buf = XEvt.MapRequestXEvt {
426 :     parent = getXId(buf, 4),
427 :     window = getXId(buf, 8)
428 :     }
429 :     fun decodeReparentNotify buf = XEvt.ReparentNotifyXEvt {
430 :     event = getXId(buf, 4),
431 :     parent = getXId(buf, 8),
432 :     window = getXId(buf, 12),
433 :     corner = getPt(buf, 16),
434 :     override_redirect = getBool(buf, 20)
435 :     }
436 :     fun decodeConfigureNotify buf = XEvt.ConfigureNotifyXEvt {
437 :     event = getXId(buf, 4),
438 :     window = getXId(buf, 8),
439 :     sibling = getXIdOption(buf, 12),
440 :     rect = getRect(buf, 16),
441 :     border_wid = getInt16(buf, 20),
442 :     override_redirect = getBool(buf, 22)
443 :     }
444 :     fun decodeConfigureRequest buf = let
445 :     val mask = get16(buf, 26)
446 :     fun getOpt getFn (i, j) = if isSet(mask, i)
447 :     then SOME(getFn(buf, j))
448 :     else NONE
449 :     in
450 :     XEvt.ConfigureRequestXEvt{
451 :     stack_mode = if isSet(mask, 0w6)
452 :     then (case W8V.sub(buf, 1)
453 :     of 0w0 => SOME XTy.Above
454 :     | 0w1 => SOME XTy.Below
455 :     | 0w2 => SOME XTy.TopIf
456 :     | 0w3 => SOME XTy.BottomIf
457 :     | 0w4 => SOME XTy.Opposite
458 :     | _ => MLXError.impossible "bad ConfigureRequest"
459 :     (* end case *))
460 :     else NONE,
461 :     parent = getXId(buf, 4),
462 :     window = getXId(buf, 8),
463 :     sibling = getXIdOption(buf, 12),
464 :     x = getOpt getSigned16 (0w0, 16),
465 :     y = getOpt getSigned16 (0w1, 18),
466 :     wid = getOpt getInt16 (0w2, 20),
467 :     ht = getOpt getInt16 (0w3, 22),
468 :     border_wid = getOpt getInt16 (0w4, 24)
469 :     }
470 :     end
471 :     fun decodeGravityNotify buf = XEvt.GravityNotifyXEvt {
472 :     event = getXId(buf, 4),
473 :     window = getXId(buf, 8),
474 :     corner = getPt(buf, 12)
475 :     }
476 :     fun decodeResizeRequest buf = XEvt.ResizeRequestXEvt {
477 :     window = getXId(buf, 4),
478 :     req_sz = getSize(buf, 8)
479 :     }
480 :     fun decodeCirculateNotify buf = XEvt.CirculateNotifyXEvt {
481 :     event = getXId(buf, 4),
482 :     window = getXId(buf, 8),
483 :     parent = getXId(buf, 12),
484 :     place = getStkPos(buf, 16)
485 :     }
486 :     fun decodeCirculateRequest buf = XEvt.CirculateRequestXEvt {
487 :     parent = getXId(buf, 4),
488 :     window = getXId(buf, 8),
489 :     place = getStkPos(buf, 12)
490 :     }
491 :     fun decodePropertyNotify buf = XEvt.PropertyNotifyXEvt {
492 :     window = getXId(buf, 4),
493 :     atom = getXAtom(buf, 8),
494 :     time = getTime(buf, 12),
495 :     deleted = getBool(buf, 16)
496 :     }
497 :     fun decodeSelectionClear buf = XEvt.SelectionClearXEvt {
498 :     time = getTime(buf, 4),
499 :     owner = getXId(buf, 8),
500 :     selection = getXAtom(buf, 12)
501 :     }
502 :     fun decodeSelectionRequest buf = XEvt.SelectionRequestXEvt {
503 :     time = getTS(buf, 4),
504 :     owner = getXId(buf, 8),
505 :     requestor = getXId(buf, 12),
506 :     selection = getXAtom(buf, 16),
507 :     target = getXAtom(buf, 20),
508 :     property = getXAtomOption(buf, 24)
509 :     }
510 :     fun decodeSelectionNotify buf = XEvt.SelectionNotifyXEvt {
511 :     time = getTS(buf, 4),
512 :     requestor = getXId(buf, 8),
513 :     selection = getXAtom(buf, 12),
514 :     target = getXAtom(buf, 16),
515 :     property = getXAtomOption(buf, 20)
516 :     }
517 :     fun decodeColormapNotify buf = XEvt.ColormapNotifyXEvt {
518 :     window = getXId(buf, 4),
519 :     cmap = getXIdOption(buf, 8),
520 :     new = getBool(buf, 12),
521 :     installed = getBool(buf, 13)
522 :     }
523 :     fun decodeClientMessage buf = XEvt.ClientMessageXEvt {
524 :     window = getXId(buf, 4),
525 :     typ = getXAtom(buf, 8),
526 :     value = XTy.RAW_DATA {
527 :     format = getRawFormat(buf, 1),
528 :     data = W8V.extract(buf, 12, SOME 20)
529 :     }
530 :     }
531 :     fun decodeMappingNotify buf = (case W8V.sub(buf, 4)
532 :     of 0w0 => XEvt.ModifierMappingNotifyXEvt
533 :     | 0w1 => XEvt.KeyboardMappingNotifyXEvt {
534 :     first_keycode = getKeyCode(buf, 5),
535 :     count = getInt8(buf, 6)
536 :     }
537 :     | 0w2 => XEvt.PointerMappingNotifyXEvt
538 :     | _ => MLXError.impossible "bad MappingNotify")
539 :     in
540 :     fun decodeXEvent (code : Word8.word, buf) = let
541 :     val n = W8.andb(code, 0wx7f)
542 :     val xevt = case n
543 :     of 0w2 => XEvt.KeyPressXEvt (getKeyXEvt buf)
544 :     | 0w3 => XEvt.KeyReleaseXEvt (getKeyXEvt buf)
545 :     | 0w4 => XEvt.ButtonPressXEvt (getButtonXEvt buf)
546 :     | 0w5 => XEvt.ButtonReleaseXEvt (getButtonXEvt buf)
547 :     | 0w6 => decodeMotionNotify buf
548 :     | 0w7 => XEvt.EnterNotifyXEvt (getEnterLeaveXEvt buf)
549 :     | 0w8 => XEvt.LeaveNotifyXEvt (getEnterLeaveXEvt buf)
550 :     | 0w9 => XEvt.FocusInXEvt (getFocusXEvt buf)
551 :     | 0w10 => XEvt.FocusOutXEvt (getFocusXEvt buf)
552 :     | 0w11 => decodeKeymapNotify buf
553 :     | 0w12 => decodeExpose buf
554 :     | 0w13 => decodeGraphicsExpose buf
555 :     | 0w14 => decodeNoExpose buf
556 :     | 0w15 => decodeVisibilityNotify buf
557 :     | 0w16 => decodeCreateNotify buf
558 :     | 0w17 => decodeDestroyNotify buf
559 :     | 0w18 => decodeUnmapNotify buf
560 :     | 0w19 => decodeMapNotify buf
561 :     | 0w20 => decodeMapRequest buf
562 :     | 0w21 => decodeReparentNotify buf
563 :     | 0w22 => decodeConfigureNotify buf
564 :     | 0w23 => decodeConfigureRequest buf
565 :     | 0w24 => decodeGravityNotify buf
566 :     | 0w25 => decodeResizeRequest buf
567 :     | 0w26 => decodeCirculateNotify buf
568 :     | 0w27 => decodeCirculateRequest buf
569 :     | 0w28 => decodePropertyNotify buf
570 :     | 0w29 => decodeSelectionClear buf
571 :     | 0w30 => decodeSelectionRequest buf
572 :     | 0w31 => decodeSelectionNotify buf
573 :     | 0w32 => decodeColormapNotify buf
574 :     | 0w33 => decodeClientMessage buf
575 :     | 0w34 => decodeMappingNotify buf
576 :     | _ => MLXError.impossible "bad event code"
577 :     in
578 :     (code = n, xevt)
579 :     end
580 :     (* we export the decode functions for reporting graphics exposures *)
581 :     val decodeGraphicsExpose = decodeGraphicsExpose
582 :     val decodeNoExpose = decodeNoExpose
583 :     end (* local *)
584 :    
585 :    
586 :     (** decode error messages **)
587 :     local
588 :     structure XErr = XErrors
589 :     fun get_err (kind, buf) = XErr.XErr{
590 :     kind = kind,
591 :     minor_op = getWord16(buf, 8),
592 :     major_op = W8V.sub(buf, 10)
593 :     }
594 :     in
595 :     fun decodeError buf = (case (W8V.sub (buf, 1))
596 :     of 0w1 => get_err (XErr.BadRequest, buf)
597 :     | 0w2 => get_err (XErr.BadValue(getString(buf, 4, 4)), buf)
598 :     | 0w3 => get_err (XErr.BadWindow(getXId(buf, 4)), buf)
599 :     | 0w4 => get_err (XErr.BadPixmap(getXId(buf, 4)), buf)
600 :     | 0w5 => get_err (XErr.BadAtom(getXId(buf, 4)), buf)
601 :     | 0w6 => get_err (XErr.BadCursor(getXId(buf, 4)), buf)
602 :     | 0w7 => get_err (XErr.BadFont(getXId(buf, 4)), buf)
603 :     | 0w8 => get_err (XErr.BadMatch, buf)
604 :     | 0w9 => get_err (XErr.BadDrawable(getXId(buf, 4)), buf)
605 :     | 0w10 => get_err (XErr.BadAccess, buf)
606 :     | 0w11 => get_err (XErr.BadAlloc, buf)
607 :     | 0w12 => get_err (XErr.BadColor(getXId(buf, 4)), buf)
608 :     | 0w13 => get_err (XErr.BadGC(getXId(buf, 4)), buf)
609 :     | 0w14 => get_err (XErr.BadIDChoice(getXId(buf, 4)), buf)
610 :     | 0w15 => get_err (XErr.BadName, buf)
611 :     | 0w16 => get_err (XErr.BadLength, buf)
612 :     | 0w17 => get_err (XErr.BadImplementation, buf)
613 :     | _ => MLXError.impossible "bad error number")
614 :     end (* local *)
615 :    
616 :    
617 :     (** decode reply messages **)
618 :    
619 :     fun decodeGetWindowAttributesReply msg = {
620 :     backing_store = getBS(msg, 1),
621 :     visual = getVisualId(msg, 8),
622 :     input_only = (case get16(msg, 12)
623 :     of 0w1 => false | 0w2 => true
624 :     | _ => MLXError.impossible "bad GetWindowAttributes reply"
625 :     (* end case *)),
626 :     bit_gravity = getBitGravity(msg, 14),
627 :     win_gravity = getWinGravity(msg, 15),
628 :     backing_planes = XTy.PLANEMASK(getWord(msg, 16)),
629 :     backing_pixel = getPixel(msg,20),
630 :     save_under = getBool(msg, 24),
631 :     map_is_installed = getBool(msg, 25),
632 :     map_state = (case W8V.sub(msg, 26)
633 :     of 0w0 => XTy.WinIsUnmapped
634 :     | 0w1 => XTy.WinIsUnviewable
635 :     | 0w2 => XTy.WinIsViewable
636 :     | _ => MLXError.impossible "bad GetWindowAttributes reply"
637 :     (* end case *)),
638 :     override_redirect = getBool(msg, 27),
639 :     colormap = getXIdOption(msg, 28),
640 :     all_event_mask = getEventMask(msg, 32),
641 :     event_mask = getEventMask(msg, 36),
642 :     do_not_propagate = getEventMask(msg, 40)
643 :     }
644 :    
645 :     fun decodeAllocColorCellsReply msg = {
646 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
647 :     }
648 :     fun decodeAllocColorPlanesReply msg = {
649 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
650 :     }
651 :    
652 :     fun decodeAllocColorReply msg = {
653 :     visual_rgb = getRGB(msg, 8),
654 :     pixel = getPixel(msg, 16)
655 :     }
656 :    
657 :     fun decodeAllocNamedColorReply msg = {
658 :     pixel = getPixel(msg, 8),
659 :     exact_rgb = getRGB(msg, 12),
660 :     visual_rgb = getRGB(msg, 18)
661 :     }
662 :    
663 :     fun decodeGetAtomNameReply msg = getString(msg, 32, getInt16(msg, 8))
664 :    
665 :     fun decodeGetFontPathReply msg = getStringList (msg, 32, getInt16(msg, 8))
666 :    
667 :     fun decodeGetGeometryReply msg = {
668 :     depth = getInt8(msg, 1),
669 :     root = getXId(msg, 8),
670 :     geom = getWGeom(msg, 12)
671 :     }
672 :    
673 :     fun decodeGetImageReply msg = {
674 :     depth = getInt8(msg, 1),
675 :     visualid = getVisualIdOption(msg, 8),
676 :     data = W8V.extract(msg, 32, SOME(4*getInt(msg, 4)))
677 :     }
678 :    
679 :     fun decodeGetInputFocusReply msg = {
680 :     revert_to = (case W8V.sub(msg, 1)
681 :     of 0w0 => XTy.RevertToNone
682 :     | 0w1 => XTy.RevertToPointerRoot
683 :     | _ => XTy.RevertToParent
684 :     (* end case *)),
685 :     focus = (case getWord(msg, 8)
686 :     of 0w0 => XTy.InputFocus_None
687 :     | 0w1 => XTy.InputFocus_PointerRoot
688 :     | w => XTy.InputFocus_Window(XTy.XID w)
689 :     (* end case *))
690 :     }
691 :    
692 :     fun decodeGetKeyboardControlReply msg = {
693 :     glob_auto_repeat = getBool(msg, 1),
694 :     led_mask = get32(msg, 8),
695 :     key_click_pct = getInt8(msg, 12),
696 :     bell_pct = getInt8(msg, 13),
697 :     bell_pitch = getInt16(msg, 14),
698 :     bell_duration = getInt16(msg, 16),
699 :     auto_repeats = W8V.extract(msg, 20, SOME 32)
700 :     }
701 :    
702 :     fun decodeGetKeyboardMappingReply msg = let
703 :     val symsPerCode = getInt8(msg, 1)
704 :     val nKeyCodes = getInt(msg, 4) div symsPerCode
705 :     (* get the keysyms bound to a given keycode; Discard trailing NoSymbols,
706 :     * but include intermediate ones. *)
707 :     fun cleanTl (XTy.NoSymbol :: r) = cleanTl r
708 :     | cleanTl l = rev l
709 :     fun getSyms (i, 0, l) = cleanTl l
710 :     | getSyms (i, j, l) = (case getInt(msg, i)
711 :     of 0 => getSyms(i+4, j-1, XTy.NoSymbol :: l)
712 :     | k => getSyms(i+4, j-1, (XTy.KEYSYM k) :: l))
713 :     in
714 :     getList (fn (_, i) => getSyms(i, symsPerCode, []), symsPerCode*4)
715 :     (msg, 32, nKeyCodes)
716 :     end
717 :    
718 :     fun decodeGetModifierMappingReply msg = let
719 :     val codesPerMod = getInt8(msg, 1)
720 :     fun getSyms k = let
721 :     fun get (i, 0) = []
722 :     | get (i, j) = (case getInt8(msg, i)
723 :     of 0 => get(i+1, j-1) (* 0 == unused *)
724 :     | k => (XTy.KEYCODE k) :: get(i+1, j-1)
725 :     (* end case *))
726 :     in
727 :     get (32 + codesPerMod*k, codesPerMod)
728 :     end
729 :     in {
730 :     shift_keycodes = getSyms 0,
731 :     lock_keycodes = getSyms 1,
732 :     cntl_keycodes = getSyms 2,
733 :     mod1_keycodes = getSyms 3,
734 :     mod2_keycodes = getSyms 4,
735 :     mod3_keycodes = getSyms 5,
736 :     mod4_keycodes = getSyms 6,
737 :     mod5_keycodes = getSyms 7
738 :     } end
739 :    
740 :     local
741 :     val getEvts = getList
742 :     ((fn (buf, i) => { time = getTime(buf, i), coord = getPt(buf, i+4) }), 8)
743 :     in
744 :     fun decodeGetMotionEventsReply msg = getEvts (msg, 32, getInt16(msg, 8))
745 :     end (* local *)
746 :    
747 :     fun decodeGetPointerControlReply msg = {
748 :     acceleration_numerator = get16(msg, 8),
749 :     acceleration_denominator = get16(msg, 10),
750 :     threshold = get16(msg, 12)
751 :     }
752 :    
753 :     fun decodeGetPointerMappingReply msg = {
754 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
755 :     }
756 :    
757 :     fun decodeGetPropertyReply msg = (case getWord(msg, 8)
758 :     of 0w0 => NONE
759 :     | t => let
760 :     val nitems = getInt(msg, 16)
761 :     val (fmt, nbytes) = (case W8V.sub(msg, 1)
762 :     of 0w8 => (XTy.Raw8, nitems)
763 :     | 0w16 => (XTy.Raw16, 2*nitems)
764 :     | 0w32 => (XTy.Raw32, 4*nitems)
765 :     | _ => MLXError.impossible "bad GetProperty reply"
766 :     (* end case *))
767 :     in
768 :     SOME {
769 :     typ = XTy.XAtom t,
770 :     bytes_after = getInt(msg, 12),
771 :     value = XTy.RAW_DATA {
772 :     format = fmt,
773 :     data = W8V.extract(msg, 32, SOME nbytes)
774 :     }
775 :     }
776 :     end)
777 :    
778 :     fun decodeGetScreenSaverReply msg = {
779 :     timeout = get16(msg, 8),
780 :     interval = get16(msg, 10),
781 :     prefer_blanking = getBool(msg, 12),
782 :     allow_exposures = getBool(msg, 13)
783 :     }
784 :    
785 :     fun decodeGetSelectionOwnerReply msg = getXIdOption(msg, 8)
786 :    
787 :     local
788 :     fun decodeGrabReply msg = (case W8V.sub(msg, 1)
789 :     of 0w0 => XTy.GrabSuccess | 0w1 => XTy.AlreadyGrabbed
790 :     | 0w2 => XTy.GrabInvalidTime | 0w3 => XTy.GrabNotViewable
791 :     | _ => XTy.GrabFrozen
792 :     (* end case *))
793 :     in
794 :     val decodeGrabKeyboardReply = decodeGrabReply
795 :     val decodeGrabPointerReply = decodeGrabReply
796 :     end (* local *)
797 :    
798 :     fun decodeInternAtomReply msg = getXAtom(msg, 8)
799 :    
800 :     fun decodeListExtensionsReply msg = {
801 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
802 :     }
803 :    
804 :     fun decodeListFontsReply msg = getStringList (msg, 32, getInt16(msg, 8))
805 :    
806 :     local
807 :     fun getHostList (buf, n) = let
808 :     fun get (_, 0, l) = l
809 :     | get (i, n, l) = let
810 :     val addrLen = getInt16(buf, i+2)
811 :     val addr = getString(buf, i+4, addrLen)
812 :     val host = case W8V.sub(buf, i)
813 :     of 0w0 => XTy.InternetHost addr
814 :     | 0w1 => XTy.DECnetHost addr
815 :     | 0w2 => XTy.ChaosHost addr
816 :     | _ => raise (MLXError.xerror "unknown host family"
817 :     (* end case *))
818 :     in
819 :     get (i+(pad addrLen)+4, n-1, host::l)
820 :     end
821 :     in
822 :     get (32, n, [])
823 :     end
824 :     in
825 :     fun decodeListHostsReply msg = {
826 :     enabled = getBool(msg, 1),
827 :     hosts = getHostList(msg, getInt16(msg, 8))
828 :     }
829 :     end (* local *)
830 :    
831 :     fun decodeListInstalledColormapsReply msg = getXIdList(msg, 32, getInt16(msg, 8))
832 :    
833 :     fun decodeListPropertiesReply msg = getXAtomList(msg, 32, getInt16(msg, 8))
834 :    
835 :     fun decodeLookupColorReply msg = {
836 :     exact_rgb = getRGB(msg, 8),
837 :     visual_rgb = getRGB(msg, 14)
838 :     }
839 :    
840 :     fun decodeQueryBestSizeReply msg = {
841 :     wid = getInt16(msg, 8),
842 :     ht = getInt16(msg, 10)
843 :     }
844 :    
845 :     local
846 :     val getRGBList = getList (getRGB, 8)
847 :     in
848 :     fun decodeQueryColorsReply msg = getRGBList(msg, 32, getInt16(msg, 8))
849 :     end (* local *)
850 :    
851 :     fun decodeQueryExtensionReply msg = {
852 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
853 :     }
854 :    
855 :     local
856 :     val getProps = getList ((fn (buf, i) => XTy.FontProp{
857 :     name = getXAtom(buf, i),
858 :     value = get32(buf, i+4)
859 :     }), 8)
860 :     fun getCharInfo (buf, i) = XTy.CharInfo{
861 :     left_bearing = getSigned16(buf, i),
862 :     right_bearing = getSigned16(buf, i+2),
863 :     char_wid = getSigned16(buf, i+4),
864 :     ascent = getSigned16(buf, i+6),
865 :     descent = getSigned16(buf, i+8),
866 :     attributes = getWord16(buf, i+10)
867 :     }
868 :     val getCharInfoList = getList (getCharInfo, 12)
869 :     fun getInfo buf = let
870 :     val n_props = getInt16(buf, 46)
871 :     in {
872 :     min_bounds = getCharInfo(buf, 8),
873 :     max_bounds = getCharInfo(buf, 24),
874 :     min_char = getInt16(buf, 40),
875 :     max_char = getInt16(buf, 42),
876 :     default_char = getInt16(buf, 44),
877 :     draw_dir = getFontDir(buf, 48),
878 :     min_byte1 = getInt8(buf, 49),
879 :     max_byte1 = getInt8(buf, 50),
880 :     all_chars_exist = getBool(buf, 51),
881 :     font_ascent = getInt16(buf, 52),
882 :     font_descent = getInt16(buf, 54),
883 :     n_props = n_props,
884 :     properties = getProps(buf, 60, n_props)
885 :     } end
886 :     in
887 :     (****** THIS GENERATES MULTIPLE REPLYS ****
888 :     (* this gets a list of font name/info replies *)
889 :     fun decodeListFontsWithInfoReply msg = let
890 :     fun getList l = let
891 :     val (msg, extra) = getReply (conn, sizeOfListFontsWithInfoReply)
892 :     val name_len = get8(msg, 1)
893 :     in
894 :     if (name_len = 0)
895 :     then (* this is the last in a series of replies *)
896 :     (rev l)
897 :     else let
898 :     val info = getInfo(msg, extra)
899 :     val reply = {
900 :     min_bounds = #min_bounds info,
901 :     max_bounds = #max_bounds info,
902 :     min_char = #min_char info,
903 :     max_char = #max_char info,
904 :     default_char = #default_char info,
905 :     draw_dir = #draw_dir info,
906 :     min_byte1 = #min_byte1 info,
907 :     max_byte1 = #max_byte1 info,
908 :     all_chars_exist = #all_chars_exist info,
909 :     font_ascent = #font_ascent info,
910 :     font_descent = #font_descent info,
911 :     replies_hint = get32(msg, 56),
912 :     properties = #properties info,
913 :     name = getString(extra, 8*(#n_props info), name_len)
914 :     }
915 :     in
916 :     getList (reply :: l)
917 :     end
918 :     end (* getList *)
919 :     in
920 :     getList []
921 :     end (* getListFontsWithInfoReply *)
922 :     *********)
923 :    
924 :     fun decodeQueryFontReply msg = let
925 :     val info = getInfo msg
926 :     in {
927 :     min_bounds = #min_bounds info,
928 :     max_bounds = #max_bounds info,
929 :     min_char = #min_char info,
930 :     max_char = #max_char info,
931 :     default_char = #default_char info,
932 :     draw_dir = #draw_dir info,
933 :     min_byte1 = #min_byte1 info,
934 :     max_byte1 = #max_byte1 info,
935 :     all_chars_exist = #all_chars_exist info,
936 :     font_ascent = #font_ascent info,
937 :     font_descent = #font_descent info,
938 :     properties = #properties info,
939 :     char_infos = getCharInfoList(msg, 60+8*(#n_props info), getInt(msg, 56))
940 :     } end
941 :     end (* local *)
942 :    
943 :     fun decodeQueryKeymapReply msg = {
944 :     err = MLXError.impossible "unimplemented" (*** FIX ***)
945 :     }
946 :    
947 :     fun decodeQueryPointerReply msg = let val (mks, mbs) = getKeyButSet(msg, 24)
948 :     in {
949 :     same_scr = getBool(msg, 1),
950 :     root = getXId(msg, 8),
951 :     child = getXIdOption(msg, 12),
952 :     root_pt = getPt(msg, 16),
953 :     win_pt = getPt(msg, 20),
954 :     mod_state = mks,
955 :     mbut_state = mbs
956 :     } end
957 :    
958 :     fun decodeQueryTextExtentsReply msg = {
959 :     draw_dir = getFontDir(msg, 1),
960 :     font_ascent = get16(msg, 8),
961 :     font_descent = get16(msg, 10),
962 :     overall_ascent = get16(msg, 12),
963 :     overall_descent = get16(msg, 14),
964 :     overall_wid = get16(msg, 16),
965 :     overall_left = get16(msg, 18),
966 :     overall_right = get16(msg, 20)
967 :     }
968 :    
969 :     fun decodeQueryTreeReply msg = {
970 :     root = getXId(msg, 8),
971 :     parent = getXIdOption(msg, 12),
972 :     children = getXIdList (msg, 32, getInt16(msg, 16))
973 :     }
974 :    
975 :     local
976 :     fun getSetMappingReply msg = (case get8(msg, 1)
977 :     of 0w0 => XTy.MappingSuccess
978 :     | 0w1 => XTy.MappingBusy
979 :     | _ => XTy.MappingFailed
980 :     (* end case *))
981 :     in
982 :     val decodeSetModifierMappingReply = getSetMappingReply
983 :     val decodeSetPointerMappingReply = getSetMappingReply
984 :     end (* local *)
985 :    
986 :     fun decodeTranslateCoordsReply msg = {
987 :     child = getXIdOption(msg, 8),
988 :     dst_pt = getPt(msg, 12)
989 :     }
990 :    
991 :     end (* local open XTypes *)
992 :    
993 :     end (* XReply *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0