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/window/selection-server.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/lib/window/selection-server.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 651 - (view) (download)

1 : monnier 2 (* selection-server.sml
2 :     *
3 :     * COPYRIGHT (c) 1994 by AT&T Bell Laboratories. See COPYRIGHT file for details.
4 :     *
5 :     * A per-display server to handle the ICCCM selection protocol.
6 :     *
7 :     * NOTES:
8 :     * - what about incremental transfers?
9 :     * - currently these operations take a window as an argument, since the
10 :     * protocol requires one. The selection server could allocate an unmapped
11 :     * window to serve as the source of ids, which would make selections
12 :     * independent of specific windows. Let's see how the higher-level interfaces
13 :     * work out first.
14 :     *
15 :     * This mechanism must deal with a complicated protocol, and a bunch of different
16 :     * kinds of X events and requests. Here is a summary:
17 :     *
18 :     * REQUESTS:
19 :     * GetSelectionOwner -- used by owner after a SetSelectionOwner to test if the
20 :     * selection was acquired.
21 :     * SetSelectionOwner -- used by owner to acquire the selection.
22 :     * ConvertSelection -- used by requestor to request that the selection value
23 :     * be put into some property.
24 :     * GetProperty -- used by the requestor to get the selection value.
25 :     * ChangeProperty -- used by the owner to put the requested selection in
26 :     * the requested property. And used by the requestor to
27 :     * delete the property, once it gets the value.
28 :     * SendEvent -- used by the owner send a SelectionNotify event to the
29 :     * requester.
30 :     *
31 :     * EVENTS:
32 :     * SelectionRequest -- received by the owner as a result of the requestor
33 :     * sending a ConvertSelection request.
34 :     * SelectionNotify -- sent by the owner to the requestor, once the selection
35 :     * has been put into the requested property.
36 :     * SelectionClear -- received by the owner, when it loses the selection.
37 :     * PropertyNotify -- received by the owner, once the requestor has deleted
38 :     * the property.
39 :     *)
40 :    
41 :     structure SelectionServer : SELECTION_SERVER =
42 :     struct
43 :    
44 :     structure XTy = XProtTypes
45 :     structure XE = XEventTypes
46 :     structure A = AtomServer
47 :     structure Tbl = XAtomTbl
48 :    
49 :     type atom = XTy.atom
50 :     type time = XTime.time
51 :    
52 :     (* +DEBUG *)
53 :     fun trace f = XDebug.trace(XDebug.selTM, f)
54 :     (* -DEBUG *)
55 :    
56 :     (* given message encode and reply decode functions, send and receive a query *)
57 :     fun query (encode, decode) conn = let
58 :     val requestReply = XIo.requestReply conn
59 :     fun ask msg = (decode (CML.sync (requestReply (encode msg))))
60 :     handle XIo.LostReply => raise (MLXError.XERROR "[reply lost]")
61 :     | (XIo.ErrorReply err) =>
62 :     raise (MLXError.XERROR(XPrint.xerrorToString err))
63 :     in
64 :     ask
65 :     end
66 :    
67 :     (* Various protocol requests that we need *)
68 :     val getSelectionOwner = query (
69 :     XRequest.encodeGetSelectionOwner, XReply.decodeGetSelectionOwnerReply)
70 :     fun setSelectionOwner conn arg =
71 :     XIo.request conn (XRequest.encodeSetSelectionOwner arg)
72 :     fun convertSelection conn arg =
73 :     XIo.request conn (XRequest.encodeConvertSelection arg)
74 :     fun selectionNotify conn {requestor, selection, target, prop, time} =
75 :     XIo.request conn (XSendEvent.encodeSendSelectionNotify {
76 :     dst = XTy.SendEvtTo_Window requestor,
77 :     propagate = false, evt_mask = XTy.XEVTMASK 0w0,
78 :     requestor = requestor, selection = selection, target = target,
79 :     property = prop, time = time
80 :     })
81 :     val reqGetProperty = query (
82 :     XRequest.encodeGetProperty, XReply.decodeGetPropertyReply)
83 :     fun changeProperty conn arg =
84 :     XIo.request conn (XRequest.encodeChangeProperty arg)
85 :    
86 :     (* get a property value, which may require several requests *)
87 :     fun getProperty conn (win, prop) = let
88 :     fun sizeOf (XTy.RAW_DATA{data, ...}) = (Word8Vector.length data div 4)
89 :     fun getChunk wordsSoFar = reqGetProperty conn {
90 :     win = win, prop = prop,
91 :     typ = NONE, (* AnyPropertyType *)
92 :     offset = wordsSoFar, len = 1024,
93 :     delete = false
94 :     }
95 :     fun deleteProp () = reqGetProperty conn {
96 :     win = win, prop = prop,
97 :     typ = NONE, (* AnyPropertyType *)
98 :     offset = 0, len = 0, delete = true
99 :     }
100 :     fun extendData (data', XTy.RAW_DATA{data, ...}) = data :: data'
101 :     fun flattenData (data', XTy.RAW_DATA{format, data}) =
102 :     XTy.RAW_DATA{
103 :     format=format,
104 :     data=Word8Vector.concat(rev (data :: data'))
105 :     }
106 :     fun getProp () = (case (getChunk 0)
107 :     of NONE => NONE
108 :     | (SOME{typ, bytes_after, value as XTy.RAW_DATA{data, ...}}) =>
109 :     if (bytes_after = 0)
110 :     then (
111 :     deleteProp();
112 :     SOME(XTy.PROP_VAL{typ=typ, value=value}))
113 :     else getRest (sizeOf value, [data])
114 :     (* end case *))
115 :     and getRest (wordsSoFar, data') = (case (getChunk wordsSoFar)
116 :     of NONE => NONE
117 :     | (SOME{typ, bytes_after, value}) => if (bytes_after = 0)
118 :     then (
119 :     deleteProp();
120 :     SOME(XTy.PROP_VAL{typ=typ, value=flattenData(data', value)}))
121 :     else getRest(
122 :     wordsSoFar + sizeOf value,
123 :     extendData (data', value))
124 :     (* end case *))
125 :     in
126 :     getProp ()
127 :     end
128 :    
129 :     (* the return result of a REQ_RequestSel *)
130 :     type request_res = XTy.prop_val option CML.event
131 :    
132 :     type sel_request = { (* the request for a selection that gets *)
133 :     (* sent to the owner *)
134 :     target : atom,
135 :     time : time,
136 :     reply : XTy.prop_val option -> unit
137 :     }
138 :    
139 :     (* an abstract handle on a selection *)
140 :     datatype selection_handle = SH of {
141 :     selection : atom,
142 :     time : time,
143 :     reqEvt : sel_request CML.event,
144 :     relEvt : unit CML.event,
145 :     release : unit -> unit
146 :     }
147 :    
148 :     datatype request
149 :     = REQ_AcquireSel of { (* acquire a selection *)
150 :     win : XTy.win_id,
151 :     selection : atom,
152 :     time : time,
153 :     ack : selection_handle option SyncVar.ivar
154 :     }
155 :     | REQ_ReleaseSel of atom (* release a selection *)
156 :     | REQ_RequestSel of { (* request the value of a selection *)
157 :     win : XTy.win_id,
158 :     selection : atom,
159 :     target : atom,
160 :     property : atom,
161 :     time : time,
162 :     ack : request_res SyncVar.ivar
163 :     }
164 :    
165 :     (* info about held selections *)
166 :     type selection_info = {
167 :     owner : XTy.win_id,
168 :     reqCh : sel_request CML.chan,
169 :     relV : unit SyncVar.ivar,
170 :     time : time
171 :     }
172 :    
173 :     (* info about outstanding selection requests *)
174 :     type request_info = XTy.prop_val option SyncVar.ivar
175 :    
176 :     (* the representation of the selection server connection *)
177 :     datatype selection_server = SelServer of request CML.chan
178 :    
179 :     fun mkServer (xdpy as XDisplay.XDPY{conn, ...}) = let
180 :     (* table of held selections *)
181 :     val selectionTbl : selection_info Tbl.hash_table =
182 :     Tbl.mkTable (32, Fail "SelectionTbl")
183 :     val insertSel = Tbl.insert selectionTbl
184 :     val findSel = Tbl.find selectionTbl
185 :     val removeSel = Tbl.remove selectionTbl
186 :     (* the table of pending selection requests *)
187 :     val requestTbl : request_info Tbl.hash_table =
188 :     Tbl.mkTable (32, Fail "RequestTbl")
189 :     val insertReq = Tbl.insert requestTbl
190 :     val findReq = Tbl.find requestTbl
191 :     val removeReq = Tbl.remove requestTbl
192 :     (* the X-event and request channels *)
193 :     val evtCh = CML.channel() and reqCh = CML.channel()
194 :     (* handle a selection related X-event *)
195 :     fun handleEvt (XE.SelectionRequestXEvt xevt) = let
196 :     fun rejectReq () = selectionNotify conn {
197 :     requestor = #requestor xevt,
198 :     selection = #selection xevt,
199 :     target = #target xevt,
200 :     prop = NONE,
201 :     time = #time xevt
202 :     }
203 :     in
204 :     trace(fn() => ["SelectionRequestXEvt\n"]);
205 :     case (findSel (#selection xevt), #time xevt)
206 :     of (NONE, _) => (* we don't hold this selection, return NONE *)
207 :     rejectReq ()
208 :     | (_, XTy.CurrentTime) =>
209 :     (* requestor isn't following ICCC, so reject request *)
210 :     rejectReq ()
211 :     | (SOME{reqCh, ...}, XTy.TimeStamp time) => let
212 :     (* propagate the request to the holder of the selection. *)
213 :     val prop = (case (#property xevt)
214 :     of NONE => (#target xevt) (* obsolete client *)
215 :     | (SOME p) => p
216 :     (* end case *))
217 :     val cv = SyncVar.iVar()
218 :     fun replyThread () = (
219 :     CML.send (reqCh, {
220 :     target = #target xevt,
221 :     time = time,
222 :     reply = (fn x => SyncVar.iPut(cv, x))
223 :     });
224 :     case (SyncVar.iGet cv)
225 :     of NONE => rejectReq()
226 :     | (SOME propVal) => (
227 :     (* write out the property value *)
228 :     changeProperty conn {
229 :     win = #requestor xevt,
230 :     name = prop,
231 :     mode = XTy.ReplaceProp,
232 :     prop = propVal
233 :     };
234 :     selectionNotify conn {
235 :     requestor = #requestor xevt,
236 :     selection = #selection xevt,
237 :     target = #target xevt,
238 :     prop = NONE,
239 :     time = time
240 :     })
241 :     (* end case *))
242 :     in
243 :     CML.spawn replyThread; ()
244 :     end
245 :     (* end case *)
246 :     end (* handleEvt SelectionRequestXEvt *)
247 :     | handleEvt (XE.SelectionClearXEvt{selection, ...}) = (
248 :     trace(fn() => ["SelectionClearXEvt\n"]);
249 :     case (findSel selection)
250 :     of NONE => () (* error ??? *)
251 :     | (SOME{relV, ...}) => (
252 :     removeSel selection;
253 :     SyncVar.iPut(relV, ()))
254 :     (* end case *))
255 :     | handleEvt (XE.SelectionNotifyXEvt xevt) = (
256 :     trace(fn() => ["SelectionNotifyXEvt\n"]);
257 :     case (findReq (#selection xevt), #property xevt)
258 :     of (NONE, _) => () (* error ?? *)
259 :     | (SOME replyV, NONE) => (
260 :     removeReq (#selection xevt);
261 :     SyncVar.iPut(replyV, NONE))
262 :     | (SOME replyV, SOME prop) => let
263 :     val propVal = getProperty conn (#requestor xevt, prop)
264 :     in
265 :     removeReq (#selection xevt);
266 :     SyncVar.iPut(replyV, propVal)
267 :     end
268 :     (* end case *))
269 :     | handleEvt xevt = MLXError.impossible "SelectionServer.mkServer.handleEvt"
270 :     (* handle a request *)
271 :     fun handleReq (REQ_AcquireSel{win, selection, time, ack}) = (
272 :     trace(fn() => ["REQ_AcquireSel\n"]);
273 :     setSelectionOwner conn {
274 :     win = SOME win, selection = selection,
275 :     timestamp = XTy.TimeStamp time
276 :     };
277 :     trace(fn() => ["REQ_AcquireSel: check owner\n"]);
278 :     case (getSelectionOwner conn {selection = selection})
279 :     of NONE => SyncVar.iPut(ack, NONE)
280 :     | (SOME id) => if (id = win)
281 :     then let
282 :     val selReqCh = CML.channel() and relV = SyncVar.iVar()
283 :     val res = SH{
284 :     selection = selection,
285 :     time = time,
286 :     reqEvt = CML.recvEvt selReqCh,
287 :     relEvt = SyncVar.iGetEvt relV,
288 :     release =
289 :     fn () => CML.send(reqCh, REQ_ReleaseSel selection)
290 :     }
291 :     in
292 :     insertSel (selection,
293 :     {owner=win, reqCh=selReqCh, relV=relV, time=time});
294 :     SyncVar.iPut(ack, SOME res)
295 :     end
296 :     else SyncVar.iPut(ack, NONE)
297 :     (* end case *))
298 :     | handleReq (REQ_ReleaseSel selection) = (
299 :     trace(fn() => ["REQ_ReleaseSel\n"]);
300 :     removeSel selection;
301 :     setSelectionOwner conn {
302 :     win = NONE, selection = selection,
303 :     timestamp = XTy.CurrentTime (* ??? *)
304 :     };
305 :     XIo.flushOut conn)
306 :     | handleReq (REQ_RequestSel req) = let
307 :     val replV = SyncVar.iVar()
308 :     in
309 :     trace(fn() => ["REQ_RequestSel\n"]);
310 :     insertReq (#selection req, replV);
311 :     convertSelection conn {
312 :     selection = #selection req,
313 :     target = #target req,
314 :     property = SOME(#property req),
315 :     requestor = #win req,
316 :     timestamp = XTy.TimeStamp(#time req)
317 :     };
318 :     SyncVar.iPut (#ack req, SyncVar.iGetEvt replV)
319 :     end
320 :     val evt = CML.choose [
321 :     CML.wrap (CML.recvEvt evtCh, handleEvt),
322 :     CML.wrap (CML.recvEvt reqCh, handleReq)
323 :     ]
324 :     fun loop () = (CML.sync evt; loop())
325 :     in
326 :     XDebug.xspawn ("SelectionServer", loop);
327 :     (evtCh, SelServer reqCh)
328 :     end (* mkServer *)
329 :    
330 :     fun acquireSelection (SelServer reqCh) (win, selection, time) = let
331 :     val replyV = SyncVar.iVar()
332 :     in
333 :     CML.send (reqCh, REQ_AcquireSel{
334 :     win = win, selection = selection, time = time, ack = replyV
335 :     });
336 :     SyncVar.iGet replyV
337 :     end
338 :    
339 :     fun selectionOf (SH{selection, ...}) = selection
340 :    
341 :     fun timeOf (SH{time, ...}) = time
342 :    
343 :     fun requestEvt (SH{reqEvt, ...}) = reqEvt
344 :    
345 :     fun releaseEvt (SH{relEvt, ...}) = relEvt
346 :    
347 :     fun releaseSelection (SH{release, ...}) = release ()
348 :    
349 :     fun requestSelection (SelServer reqCh) {
350 :     win, selection, target, property, time
351 :     } = let
352 :     val replyV = SyncVar.iVar()
353 :     in
354 :     CML.send(reqCh, REQ_RequestSel{
355 :     win=win, selection=selection, target=target, property=property,
356 :     time=time, ack=replyV
357 :     });
358 :     SyncVar.iGet replyV
359 :     end
360 :    
361 :     end; (* SelectionServer *)

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