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/xdisplay.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1856 - (view) (download)

1 : monnier 2 (* xdisplay.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *)
5 :    
6 :     structure XDisplay : sig
7 :    
8 :     exception BadAddr of string
9 :    
10 :     datatype xdisplay = XDPY of {
11 :     conn : XIo.connection, (* the connection to the server *)
12 :     name : string, (* "host:display.scr" *)
13 :     vendor : string, (* the name of the server's vendor *)
14 :     default_scr : int, (* the number of the default screen *)
15 :     screens : xscreen list, (* the screens attached to this display. *)
16 :     pixmap_formats : XProtTypes.pixmap_format list,
17 :     max_req_len : int,
18 :     image_byte_order : XProtTypes.order,
19 :     bitmap_bit_order : XProtTypes.order,
20 :     bitmap_scanline_unit : XProtTypes.raw_format,
21 :     bitmap_scanline_pad : XProtTypes.raw_format,
22 :     min_keycode : XProtTypes.keycode,
23 :     max_keycode : XProtTypes.keycode,
24 :     nextXId : unit -> XProtTypes.xid (* resource id allocator *)
25 :     }
26 :    
27 :     and xscreen = XSCR of {
28 :     id : int, (* the number of this screen *)
29 :     root : XProtTypes.win_id, (* the root window id of this screen *)
30 :     cmap : XProtTypes.colormap_id, (* the default colormap *)
31 :     white : XProtTypes.pixel, (* White and Black pixel values *)
32 :     black : XProtTypes.pixel,
33 :     root_input_mask : XProtTypes.event_mask,
34 :     (* initial root input mask *)
35 :     sz_in_pixels : Geometry.size, (* the width and height in pixels *)
36 :     sz_in_mm : Geometry.size, (* the width and height in millimeters *)
37 :     min_installed_cmaps : int,
38 :     max_installed_cmaps : int,
39 :     root_visual : XProtTypes.visual_depth,
40 :     backing_store : XProtTypes.backing_store,
41 :     save_unders : bool,
42 :     visualdepths : XProtTypes.visual_depth list
43 :     }
44 :    
45 :     val openXDisplay : {
46 :     dpyName : string,
47 :     auth : XProtTypes.authentication option
48 :     } -> xdisplay
49 :    
50 :     val closeDisplay : xdisplay -> unit
51 :     val depthOfVisual : XProtTypes.visual_depth -> int
52 :     val displayClassOfVisual : XProtTypes.visual_depth
53 :     -> XProtTypes.display_class option
54 :    
55 :     end = struct
56 :    
57 :     exception BadAddr = XServerAddr.BadAddr
58 :    
59 :     structure NDB = NetHostDB
60 :     structure W8V = Word8Vector
61 :     structure G = Geometry
62 :     structure XTy = XProtTypes
63 :    
64 :     structure XD = XDebug
65 :    
66 :     datatype xdisplay = XDPY of {
67 :     conn : XIo.connection, (* the connection to the server *)
68 :     name : string, (* "host:display.scr" *)
69 :     vendor : string, (* the name of the server's vendor *)
70 :     default_scr : int, (* the number of the default screen *)
71 :     screens : xscreen list, (* the screens attached to this display. *)
72 :     pixmap_formats : XTy.pixmap_format list,
73 :     max_req_len : int,
74 :     image_byte_order : XTy.order,
75 :     bitmap_bit_order : XTy.order,
76 :     bitmap_scanline_unit : XTy.raw_format,
77 :     bitmap_scanline_pad : XTy.raw_format,
78 :     min_keycode : XTy.keycode,
79 :     max_keycode : XTy.keycode,
80 :     nextXId : unit -> XTy.xid (* resource id allocator *)
81 :     }
82 :    
83 :     and xscreen = XSCR of {
84 :     id : int, (* the number of this screen *)
85 :     root : XTy.win_id, (* the root window id of this screen *)
86 :     cmap : XTy.colormap_id, (* the default colormap *)
87 :     white : XTy.pixel, (* White and Black pixel values *)
88 :     black : XTy.pixel,
89 :     root_input_mask : XTy.event_mask, (* initial root input mask *)
90 :     sz_in_pixels : G.size, (* the width and height in pixels *)
91 :     sz_in_mm : G.size, (* the width and height in millimeters *)
92 :     min_installed_cmaps : int,
93 :     max_installed_cmaps : int,
94 :     root_visual : XTy.visual_depth,
95 :     backing_store : XTy.backing_store,
96 :     save_unders : bool,
97 :     visualdepths : XTy.visual_depth list
98 :     }
99 :    
100 :     (* return index of first bit set (starting at 1), return 0 if n = 0, and
101 :     * assume that n > 0.
102 :     *)
103 :     fun ffs 0w0 = MLXError.xerror "bogus resource mask"
104 :     | ffs w = let
105 :     fun lp (w, i) =
106 :     if (Word.andb(w, 0w1) = 0w0)
107 :     then lp(Word.>>(w, 0w1), i+0w1) else i
108 :     in
109 :     lp (w, 0w1)
110 :     end
111 :    
112 :     (* initialize a connection by sending a connection request *)
113 :     fun initConnection (sock, auth, name, scrNum) = let
114 :     (*+DEBUG*)
115 :     val _ = XDebug.trace(XDebug.ioTM, fn () => [
116 :     "initializing connection to \"", name, "\"\n"
117 :     ])
118 :     (*-DEBUG*)
119 :     val connectMsg = XRequest.encodeConnectionReq {
120 :     minorVersion = 0,
121 :     auth = auth
122 :     }
123 :     val _ = SockUtil.sendVec (sock, connectMsg)
124 :     (*+DEBUG*)
125 :     val _ = XDebug.trace(XDebug.ioTM, fn () => ["reading connection reply header\n"])
126 :     (*-DEBUG*)
127 :     val hdr = SockUtil.recvVec (sock, 8)
128 : mblume 1856 val len = 4 * LargeWord.toIntX(PackWord16Big.subVec(hdr, 3))
129 : monnier 2 (*+DEBUG*)
130 :     val _ = XDebug.trace(XDebug.ioTM, fn () => [
131 :     "reading connection reply body (", Int.toString len, " bytes)\n"
132 :     ])
133 :     (*-DEBUG*)
134 :     val reply = SockUtil.recvVec (sock, len)
135 : mblume 1381 fun getMsg () = Byte.unpackStringVec(Word8VectorSlice.slice(
136 : monnier 2 reply,
137 :     0,
138 : mblume 1381 SOME(Word8.toIntX(W8V.sub(hdr, 1)))))
139 : monnier 2 fun error msg = (Socket.close sock; MLXError.xerror msg)
140 :     in
141 :     case W8V.sub(hdr, 0)
142 :     of 0w0 => error ("connection refused: " ^ getMsg())
143 :     | 0w1 => let
144 :     val info = XReply.decodeConnectReqReply (hdr, reply)
145 :     val conn = XIo.openConn sock
146 :     in
147 :     (conn, info, name, scrNum)
148 :     end
149 :     | 0w2 => error "connection requires more authentication"
150 :     | _ => error "unknown connection reply"
151 :     (* end case *)
152 :     end
153 :    
154 :     (* Parse the address and open the appropriate kind of connection *)
155 :     fun connect (s, auth) = let
156 :     val {addr, dpy_name, screen} = XServerAddr.getServerAddr s
157 :     fun repeat connFn = let
158 :     fun loop 0 = connFn()
159 :     | loop n = (connFn() handle _ => loop(n-1))
160 :     in
161 :     loop 4 (* try upto five times *)
162 :     end
163 :     handle (OS.SysErr(s, _)) => raise (BadAddr s)
164 :     fun inetConn (addr, port) = let
165 :     val _ = TraceCML.trace (XD.ioTM, fn () => [
166 :     "inetConn: addr = \"", NDB.toString addr, "\", port = ",
167 :     Int.toString port, "\n"
168 :     ])
169 :     val sock = INetSock.TCP.socket ()
170 :     in
171 :     repeat (fn () =>
172 :     Socket.connect (sock, INetSock.toAddr(addr, port)));
173 :     initConnection (sock, auth, dpy_name, screen)
174 :     end
175 :     in
176 :     case addr
177 :     of XServerAddr.UNIX path => let
178 :     val sock = UnixSock.Strm.socket ()
179 :     in
180 :     repeat (fn () => Socket.connect (sock, UnixSock.toAddr path));
181 :     initConnection (sock, auth, dpy_name, screen)
182 :     end
183 :     | XServerAddr.INET_Addr(host, port) => (
184 :     case NDB.fromString host
185 :     of (SOME addr) => inetConn (addr, port)
186 :     | NONE => raise BadAddr "bad IP address format"
187 :     (* end case *))
188 :     | XServerAddr.INET_Hostname(host, port) => (
189 :     case NDB.getByName host
190 :     of (SOME entry) => inetConn (NDB.addr entry, port)
191 :     | NONE => raise BadAddr "host not found"
192 :     (* end case *))
193 :     (* end case *)
194 :     end
195 :    
196 :     (* build a resource-id allocation function *)
197 :     fun mkResourceFn (base, mask) = let
198 :     val resCh = CML.channel()
199 :     val incr = ffs(mask)
200 :     fun loop i = (CML.send(resCh, XTy.XID i); loop(i+incr))
201 :     in
202 :     (* CML.spawn (fn () => (loop base)); *)
203 :     XDebug.xspawn ("ResourceIdAlloc", fn () => (loop base));
204 :     fn () => (CML.recv resCh)
205 :     end
206 :    
207 :     fun mkScreen (scr_num) {
208 :     root_win, cmap, white, black, input_masks, pixel_wid, pixel_ht,
209 :     mm_wid, mm_ht, installed_maps = {min, max}, root_visualid,
210 :     backing_store, save_unders, root_depth, visualdepths
211 :     } = let
212 :     fun getRootVisual [] = (MLXError.xerror "cannot find root visual")
213 :     | getRootVisual ((XTy.Depth _) :: r) = getRootVisual r
214 :     | getRootVisual ((v as XTy.VisualDepth{id, depth, ...}) :: r) =
215 :     if ((id = root_visualid) andalso (depth = root_depth))
216 :     then v
217 :     else (getRootVisual r)
218 :     in
219 :     XSCR{
220 :     id = scr_num,
221 :     root = root_win,
222 :     cmap = cmap,
223 :     white = white,
224 :     black = black,
225 :     root_input_mask = input_masks,
226 :     sz_in_pixels = G.SIZE{wid = pixel_wid, ht = pixel_ht},
227 :     sz_in_mm = G.SIZE{wid = mm_wid, ht = mm_ht},
228 :     min_installed_cmaps = min,
229 :     max_installed_cmaps = max,
230 :     root_visual = getRootVisual visualdepths,
231 :     backing_store = backing_store,
232 :     save_unders = save_unders,
233 :     visualdepths = visualdepths
234 :     }
235 :     end (* mkScreen *)
236 :    
237 :     fun mkScreens info_list = let
238 :     fun mkS (i, []) = []
239 :     | mkS (i, info::r) = (mkScreen i info) :: mkS(i+1, r)
240 :     in
241 :     mkS (0, info_list)
242 :     end
243 :    
244 :     fun openXDisplay {dpyName, auth} = let
245 :     val (conn, info, name, scrNum) = connect (dpyName, auth)
246 :     val _ = XShutdown.logConnection conn
247 :     val screens = mkScreens (#roots info)
248 :     val (dpy as (XDPY dpyrec)) = XDPY{
249 :     conn = conn,
250 :     name = name,
251 :     vendor = #vendor info,
252 :     screens = screens,
253 :     default_scr = scrNum,
254 :     pixmap_formats = #formats info,
255 :     max_req_len = #max_req_len info,
256 :     image_byte_order = #im_byte_order info,
257 :     bitmap_bit_order = #bitmap_order info,
258 :     bitmap_scanline_unit = #bitmap_scanline_unit info,
259 :     bitmap_scanline_pad = #bitmap_scanline_pad info,
260 :     min_keycode = #min_keycode info,
261 :     max_keycode = #max_keycode info,
262 :     nextXId = mkResourceFn (#rsrc_id_base info, #rsrc_id_mask info)
263 :     }
264 :     fun errHandler () = let
265 :     val (seqn, errMsg) = XIo.readXError conn
266 :     in
267 :     TraceCML.trace (XD.errorTM, fn () => [
268 :     "Error on request #", Word.fmt StringCvt.DEC seqn,
269 :     ": ", XPrint.xerrorToString(XReply.decodeError errMsg),
270 :     "\n"
271 :     ]);
272 :     errHandler ()
273 :     end
274 :     in
275 :     XDebug.xspawn("errHandler", errHandler);
276 :     dpy
277 :     end
278 :    
279 :     (* closeDisplay : xdisplay -> unit *)
280 :     fun closeDisplay (XDPY{conn, ...}) = (
281 :     let val tid = CML.getTid() in TraceCML.trace(XD.ioTM, fn () => [
282 :     CML.tidToString tid, " ***** closeDisplay *****\n"
283 :     ])
284 :     end;
285 :     XIo.closeConn conn;
286 :     XShutdown.unlogConnection conn)
287 :    
288 :     fun depthOfVisual (XTy.Depth d) = d
289 :     | depthOfVisual (XTy.VisualDepth{depth, ...}) = depth
290 :    
291 :     fun displayClassOfVisual (XTy.Depth _) = NONE
292 :     | displayClassOfVisual (XTy.VisualDepth{class, ...}) = SOME class
293 :    
294 :     end (* XDisplay *)

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