|
0
|
1 /* Epoch functionality.
|
|
|
2 Copyright (C) 1985-1995 Free Software Foundation, Inc.
|
|
|
3 Copyright (C) 1996 Ben Wing.
|
|
|
4
|
|
|
5 This file is part of XEmacs.
|
|
|
6
|
|
|
7 XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 under the terms of the GNU General Public License as published by the
|
|
|
9 Free Software Foundation; either version 2, or (at your option) any
|
|
|
10 later version.
|
|
|
11
|
|
|
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
|
|
|
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
|
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
|
15 for more details.
|
|
|
16
|
|
|
17 You should have received a copy of the GNU General Public License
|
|
|
18 along with XEmacs; see the file COPYING. If not, write to
|
|
|
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
20 Boston, MA 02111-1307, USA. */
|
|
|
21
|
|
|
22 /* Synched up with: Not in FSF. */
|
|
|
23
|
|
|
24 #include <config.h>
|
|
|
25 #include "lisp.h"
|
|
|
26
|
|
|
27 #include "console-x.h"
|
|
|
28 #include "objects-x.h"
|
|
|
29 #include "events.h"
|
|
|
30 #include "frame.h"
|
|
|
31
|
|
|
32 Lisp_Object Qx_property_change, Qx_client_message, Qx_map, Qx_unmap;
|
|
|
33 Lisp_Object Vepoch_event, Vepoch_event_handler;
|
|
|
34
|
|
|
35
|
|
|
36 /************************************************************************/
|
|
|
37 /* X resources */
|
|
|
38 /************************************************************************/
|
|
|
39
|
|
|
40 Lisp_Object Qx_resource_live_p;
|
|
|
41
|
|
|
42 #define XX_RESOURCE(x) XRECORD (x, x_resource, struct Lisp_X_Resource)
|
|
|
43 #define XSETX_RESOURCE(x, p) XSETRECORD (x, p, x_resource)
|
|
|
44 #define X_RESOURCEP(x) RECORDP (x, x_resource)
|
|
|
45 #define GC_X_RESOURCEP(x) GC_RECORDP (x, x_resource)
|
|
|
46 #define CHECK_X_RESOURCE(x) CHECK_RECORD (x, x_resource)
|
|
|
47
|
|
|
48 #define X_RESOURCE_LIVE_P(xr) (DEVICE_LIVE_P (XDEVICE ((xr)->device)))
|
|
|
49 #define CHECK_LIVE_X_RESOURCE(x) \
|
|
|
50 do { CHECK_X_RESOURCE (x); \
|
|
|
51 if (!X_RESOURCE_LIVE_P (XX_RESOURCE (x))) \
|
|
|
52 x = wrong_type_argument (Qx_resource_live_p, (x)); \
|
|
|
53 } while (0)
|
|
|
54
|
|
|
55 struct Lisp_X_Resource
|
|
|
56 {
|
|
|
57 struct lcrecord_header header;
|
|
|
58
|
|
|
59 XID xid;
|
|
|
60 Atom type;
|
|
|
61 Lisp_Object device;
|
|
|
62 };
|
|
|
63
|
|
|
64 Lisp_Object Qx_resourcep;
|
|
|
65 static Lisp_Object mark_x_resource (Lisp_Object, void (*) (Lisp_Object));
|
|
|
66 static void print_x_resource (Lisp_Object, Lisp_Object, int);
|
|
|
67 static void finalize_x_resource (void *, int);
|
|
|
68 static int x_resource_equal (Lisp_Object o1, Lisp_Object o2, int depth);
|
|
|
69 static unsigned long x_resource_hash (Lisp_Object obj, int depth);
|
|
|
70 DEFINE_LRECORD_IMPLEMENTATION ("x-resource", x_resource,
|
|
|
71 mark_x_resource, print_x_resource,
|
|
|
72 finalize_x_resource, x_resource_equal,
|
|
|
73 x_resource_hash, struct Lisp_X_Resource);
|
|
|
74
|
|
|
75 static Lisp_Object
|
|
|
76 mark_x_resource (Lisp_Object obj, void (*markobj) (Lisp_Object))
|
|
|
77 {
|
|
|
78 return XX_RESOURCE (obj)->device;
|
|
|
79 }
|
|
|
80
|
|
|
81 static void
|
|
|
82 print_x_resource (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
|
|
|
83 {
|
|
|
84 char buf[100];
|
|
|
85 Bufbyte *default_string = "Resource";
|
|
|
86 Lisp_Object atom_symbol;
|
|
|
87 Lisp_Object device = XX_RESOURCE (obj)->device;
|
|
|
88
|
|
|
89 if (print_readably)
|
|
|
90 {
|
|
|
91 if (!DEVICE_LIVE_P (XDEVICE (device)))
|
|
|
92 error ("printing unreadable object #<dead x-resource>");
|
|
|
93 else
|
|
|
94 error ("printing unreadable object #<x-resource 0x%x>",
|
|
|
95 (unsigned int) XX_RESOURCE (obj)->xid);
|
|
|
96 }
|
|
|
97
|
|
|
98 if (!DEVICE_LIVE_P (XDEVICE (device)))
|
|
|
99 write_c_string ("#<dead x-resource>", printcharfun);
|
|
|
100 else
|
|
|
101 {
|
|
|
102 atom_symbol = x_atom_to_symbol (XDEVICE (device),
|
|
|
103 XX_RESOURCE (obj)->type);
|
|
|
104 sprintf (buf, "#<x-resource %s on ",
|
|
|
105 (NILP (atom_symbol)
|
|
|
106 ? default_string
|
|
14
|
107 : XSTRING_DATA (Fsymbol_name (atom_symbol))));
|
|
0
|
108 write_c_string (buf, printcharfun);
|
|
|
109 print_internal (device, printcharfun, escapeflag);
|
|
|
110 sprintf (buf, " 0x%x>",(unsigned int) XX_RESOURCE (obj)->xid);
|
|
|
111 write_c_string (buf, printcharfun);
|
|
|
112 }
|
|
|
113 }
|
|
|
114
|
|
|
115 static void
|
|
|
116 finalize_x_resource (void *header, int for_disksave)
|
|
|
117 {
|
|
|
118 }
|
|
|
119
|
|
|
120 static int
|
|
|
121 x_resource_equal (Lisp_Object o1, Lisp_Object o2, int depth)
|
|
|
122 {
|
|
|
123 return (XX_RESOURCE (o1)->xid == XX_RESOURCE (o2)->xid &&
|
|
|
124 EQ (XX_RESOURCE (o1)->device, XX_RESOURCE (o2)->device));
|
|
|
125 }
|
|
|
126
|
|
|
127 static unsigned long
|
|
|
128 x_resource_hash (Lisp_Object obj, int depth)
|
|
|
129 {
|
|
|
130 return HASH2 (XX_RESOURCE (obj)->xid,
|
|
|
131 internal_hash (XX_RESOURCE (obj)->device, depth));
|
|
|
132 }
|
|
|
133
|
|
|
134 /*
|
|
|
135 * Epoch equivalent: epoch::resourcep
|
|
|
136 */
|
|
20
|
137 DEFUN ("x-resource-p", Fx_resource_p, 1, 1, 0, /*
|
|
0
|
138 Return non-nil if OBJECT is an X resource object.
|
|
20
|
139 */
|
|
|
140 (object))
|
|
0
|
141 {
|
|
|
142 return (X_RESOURCEP (object) ? Qt : Qnil);
|
|
|
143 }
|
|
|
144
|
|
20
|
145 DEFUN ("x-resource-live-p", Fx_resource_live_p, 1, 1, 0, /*
|
|
0
|
146 Return non-nil if OBJECT is a live X resource object.
|
|
|
147 That means that the X resource's device is live.
|
|
20
|
148 */
|
|
|
149 (object))
|
|
0
|
150 {
|
|
|
151 return (X_RESOURCEP (object) &&
|
|
|
152 X_RESOURCE_LIVE_P (XX_RESOURCE (object)) ? Qt : Qnil);
|
|
|
153 }
|
|
|
154
|
|
20
|
155 DEFUN ("x-resource-device", Fx_resource_device, 1, 1, 0, /*
|
|
0
|
156 Return the device that OBJECT (an X resource object) exists on.
|
|
20
|
157 */
|
|
|
158 (object))
|
|
0
|
159 {
|
|
|
160 CHECK_LIVE_X_RESOURCE (object);
|
|
|
161 return XX_RESOURCE (object)->device;
|
|
|
162 }
|
|
|
163
|
|
|
164 /*
|
|
|
165 * Epoch equivalent: epoch::set-resource-type
|
|
|
166 */
|
|
20
|
167 DEFUN ("set-x-resource-type", Fset_x_resource_type, 2, 2, 0, /*
|
|
0
|
168 Set the type of RESOURCE to TYPE. The new type must be an atom.
|
|
20
|
169 */
|
|
|
170 (resource, type))
|
|
0
|
171 {
|
|
|
172 CHECK_LIVE_X_RESOURCE (resource);
|
|
|
173 CHECK_LIVE_X_RESOURCE (type);
|
|
|
174
|
|
|
175 if (XX_RESOURCE (type)->type != XA_ATOM)
|
|
|
176 error ("New type must be an atom");
|
|
|
177
|
|
|
178 XX_RESOURCE (resource)->type = XX_RESOURCE (type)->xid;
|
|
|
179 return resource;
|
|
|
180 }
|
|
|
181
|
|
|
182 static Lisp_Object
|
|
|
183 make_x_resource (XID xid, Atom type, Lisp_Object device)
|
|
|
184 {
|
|
|
185 struct Lisp_X_Resource *xr =
|
|
|
186 alloc_lcrecord (sizeof (struct Lisp_X_Resource), lrecord_x_resource);
|
|
|
187 Lisp_Object val;
|
|
|
188
|
|
|
189 xr->xid = xid;
|
|
|
190 xr->type = type;
|
|
|
191 xr->device = device;
|
|
|
192 XSETX_RESOURCE (val, xr);
|
|
|
193
|
|
|
194 return val;
|
|
|
195 }
|
|
|
196
|
|
|
197 static Lisp_Object
|
|
|
198 get_symbol_or_string_as_symbol (Lisp_Object name)
|
|
|
199 {
|
|
|
200 retry:
|
|
|
201 if (SYMBOLP (name))
|
|
|
202 return name;
|
|
|
203 else if (STRINGP (name))
|
|
|
204 return Fintern (name, Qnil);
|
|
|
205 else
|
|
|
206 {
|
|
|
207 signal_simple_continuable_error ("Must be symbol or string",
|
|
|
208 name);
|
|
|
209 goto retry;
|
|
|
210 }
|
|
|
211 return Qnil; /* not reached */
|
|
|
212 }
|
|
|
213
|
|
|
214 /*
|
|
|
215 * Epoch equivalent: epoch::intern-atom
|
|
|
216 */
|
|
20
|
217 DEFUN ("x-intern-atom", Fx_intern_atom, 1, 2, 0, /*
|
|
0
|
218 Convert a string or symbol into an atom and return as an X resource.
|
|
|
219 Optional argument DEVICE specifies the display connection and defaults
|
|
|
220 to the selected device.
|
|
20
|
221 */
|
|
|
222 (name, device))
|
|
0
|
223 {
|
|
|
224 Atom atom;
|
|
|
225 struct device *d = decode_x_device (device);
|
|
|
226
|
|
|
227 XSETDEVICE (device, d);
|
|
|
228 atom = symbol_to_x_atom (d, get_symbol_or_string_as_symbol (name), 0);
|
|
|
229 return make_x_resource (atom, XA_ATOM, device);
|
|
|
230 }
|
|
|
231
|
|
|
232 /*
|
|
|
233 * Epoch equivalent: epoch::unintern-atom
|
|
|
234 */
|
|
20
|
235 DEFUN ("x-atom-name", Fx_atom_name, 1, 1, 0, /*
|
|
0
|
236 Return the name of an X atom resource as a string.
|
|
20
|
237 */
|
|
|
238 (atom))
|
|
0
|
239 {
|
|
|
240 Lisp_Object val;
|
|
|
241
|
|
|
242 CHECK_LIVE_X_RESOURCE (atom);
|
|
|
243 if (XX_RESOURCE (atom)->type != XA_ATOM)
|
|
|
244 signal_simple_error ("Resource is not an atom", atom);
|
|
|
245
|
|
|
246 val = x_atom_to_symbol (XDEVICE (XX_RESOURCE (atom)->device),
|
|
|
247 XX_RESOURCE (atom)->xid);
|
|
|
248 if (NILP (val))
|
|
|
249 return Qnil;
|
|
|
250 return Fsymbol_name (val);
|
|
|
251 }
|
|
|
252
|
|
|
253 /*
|
|
|
254 * Epoch equivalent: epoch::string-to-resource
|
|
|
255 */
|
|
20
|
256 DEFUN ("string-to-x-resource", Fstring_to_x_resource, 2, 3, 0, /*
|
|
0
|
257 Convert a numeric STRING to an X-RESOURCE.
|
|
|
258 STRING is assumed to represent a 32-bit numer value. X-RESOURCE must be
|
|
|
259 an X atom. Optional BASE argument should be a number between 2 and 36,
|
|
|
260 specifying the base for converting STRING.
|
|
20
|
261 */
|
|
|
262 (string, type, base))
|
|
0
|
263 {
|
|
|
264 XID xid;
|
|
|
265 struct Lisp_X_Resource *xr;
|
|
|
266 char *ptr;
|
|
|
267 int b;
|
|
|
268
|
|
|
269 CHECK_STRING (string);
|
|
|
270 CHECK_LIVE_X_RESOURCE (type);
|
|
|
271
|
|
|
272 if (NILP (base))
|
|
|
273 b = 0;
|
|
|
274 else
|
|
|
275 {
|
|
|
276 CHECK_INT (base);
|
|
|
277 b = XINT (base);
|
|
|
278 check_int_range (b, 2, 36);
|
|
|
279 }
|
|
|
280
|
|
|
281 if (XX_RESOURCE (type)->type != XA_ATOM)
|
|
|
282 error ("Resource must be an atom");
|
|
|
283 xr = XX_RESOURCE (type);
|
|
|
284
|
|
14
|
285 xid = (XID) strtol ((CONST char *) XSTRING_DATA (string), &ptr, b);
|
|
0
|
286
|
|
14
|
287 return ((ptr == (char *) XSTRING_DATA (string))
|
|
0
|
288 ? Qnil
|
|
|
289 : make_x_resource (xid, xr->xid, xr->device));
|
|
|
290 }
|
|
|
291
|
|
|
292 /*
|
|
|
293 * Epoch equivalent: epoch::resource-to-type
|
|
|
294 */
|
|
20
|
295 DEFUN ("x-resource-to-type", Fx_resource_to_type, 1, 1, 0, /*
|
|
0
|
296 Return an x-resource of type ATOM whose value is the type of the argument
|
|
20
|
297 */
|
|
|
298 (resource))
|
|
0
|
299 {
|
|
|
300 struct Lisp_X_Resource *xr;
|
|
|
301
|
|
|
302 CHECK_LIVE_X_RESOURCE (resource);
|
|
|
303 xr = XX_RESOURCE (resource);
|
|
|
304
|
|
|
305 return make_x_resource (xr->type, XA_ATOM, xr->device);
|
|
|
306 }
|
|
|
307
|
|
|
308 /* internal crap stolen from Epoch */
|
|
|
309 static char LongToStringBuffer[33]; /* can't have statics inside functions! */
|
|
|
310 static char *
|
|
|
311 long_to_string (unsigned long n, unsigned int base)
|
|
|
312 {
|
|
|
313 char *digit = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
|
|
|
314 char *s = LongToStringBuffer + 32; /* at most 33 characters in binary */
|
|
|
315
|
|
|
316 *s = 0; /* terminate */
|
|
|
317 while (n) /* something there */
|
|
|
318 {
|
|
|
319 *--s = digit[n % base]; /* store bottom digit */
|
|
|
320 n /= base; /* shift right */
|
|
|
321 }
|
|
|
322 if (*s == 0) *--s = '0'; /* in case nothing was put in string */
|
|
|
323 return s;
|
|
|
324 }
|
|
|
325
|
|
|
326 /*
|
|
|
327 * Epoch equivalent: epoch::resource-to-string
|
|
|
328 */
|
|
20
|
329 DEFUN ("x-resource-to-string", Fx_resource_to_string, 1, 2, 0, /*
|
|
0
|
330 Convert the xid of RESOURCE to a numeric string.
|
|
|
331 Optional BASE specifies the base for the conversion (2..36 inclusive)
|
|
20
|
332 */
|
|
|
333 (resource, base))
|
|
0
|
334 {
|
|
|
335 int cbase = 10;
|
|
|
336
|
|
|
337 CHECK_LIVE_X_RESOURCE (resource);
|
|
|
338 if (!NILP (base))
|
|
|
339 {
|
|
|
340 CHECK_INT (base);
|
|
|
341 cbase = XINT (base);
|
|
|
342 check_int_range (cbase, 2, 36);
|
|
|
343 }
|
|
|
344
|
|
|
345 return build_string (long_to_string (XX_RESOURCE (resource)->xid, cbase));
|
|
|
346 }
|
|
|
347
|
|
|
348 /*
|
|
|
349 * Epoch equivalent: epoch::xid-of-frame
|
|
|
350 */
|
|
20
|
351 DEFUN ("x-id-of-frame", Fx_id_of_frame, 0, 1, 0, /*
|
|
0
|
352 Return the window ID of FRAME as an x-resource.
|
|
|
353 This differs from `x-window-id' in that its return value is an
|
|
|
354 x-resource rather than a string.
|
|
20
|
355 */
|
|
|
356 (frame))
|
|
0
|
357 {
|
|
|
358 struct frame *f = decode_x_frame (frame);
|
|
|
359
|
|
|
360 return make_x_resource (XtWindow (FRAME_X_SHELL_WIDGET (f)), XA_WINDOW,
|
|
|
361 FRAME_DEVICE (f));
|
|
|
362 }
|
|
|
363
|
|
|
364 /* Given a frame or ID X resource, return the X window and device
|
|
|
365 it refers to. If text_p is non-zero, the window returned corresponds
|
|
|
366 to the text widget of the frame rather than the shell widget. */
|
|
|
367
|
|
|
368 static void
|
|
|
369 epoch_get_window_and_device (Lisp_Object frame, Window *window,
|
|
|
370 Lisp_Object *device, int text_p)
|
|
|
371 {
|
|
|
372 if (X_RESOURCEP (frame))
|
|
|
373 {
|
|
|
374 CHECK_LIVE_X_RESOURCE (frame);
|
|
|
375 if (XX_RESOURCE (frame)->type != XA_WINDOW)
|
|
|
376 error ("Frame resource must be of type WINDOW");
|
|
|
377 *window = XX_RESOURCE (frame)->xid;
|
|
|
378 *device = XX_RESOURCE (frame)->device;
|
|
|
379 }
|
|
|
380 else
|
|
|
381 {
|
|
|
382 struct frame *f = decode_x_frame (frame);
|
|
|
383
|
|
|
384 XSETFRAME (frame, f);
|
|
|
385 if (text_p)
|
|
|
386 *window = XtWindow (FRAME_X_TEXT_WIDGET (f));
|
|
|
387 else
|
|
|
388 *window = XX_RESOURCE (Fx_id_of_frame (frame))->xid;
|
|
|
389 *device = FRAME_DEVICE (f);
|
|
|
390 }
|
|
|
391
|
|
|
392 }
|
|
|
393
|
|
|
394 /*
|
|
|
395 * Epoch equivalent: epoch::query-tree
|
|
|
396 */
|
|
20
|
397 DEFUN ("x-query-tree", Fx_query_tree, 0, 1, 0, /*
|
|
0
|
398 Return the portion of the window tree adjacent to FRAME.
|
|
|
399 Return value is the list ( ROOT PARENT . CHILDREN ). The FRAME arg
|
|
|
400 can either be a frame object or an x-resource of type window.
|
|
20
|
401 */
|
|
|
402 (frame))
|
|
0
|
403 {
|
|
|
404 Window win;
|
|
|
405 Window root, parent, *children;
|
|
|
406 unsigned int count;
|
|
|
407 int retval;
|
|
|
408 Lisp_Object val;
|
|
|
409 Lisp_Object device;
|
|
|
410
|
|
|
411 epoch_get_window_and_device (frame, &win, &device, 0);
|
|
|
412
|
|
|
413 retval =
|
|
|
414 XQueryTree (DEVICE_X_DISPLAY (XDEVICE (device)), win, &root, &parent,
|
|
|
415 &children, &count);
|
|
|
416
|
|
|
417 /* Thank you, X-Consortium. XQueryTree doesn't return Success like everyone
|
|
|
418 * else, it returns 1. (Success is defined to be 0 in the standard header
|
|
|
419 * files)
|
|
|
420 */
|
|
|
421 if (!retval) return Qnil;
|
|
|
422
|
|
|
423 val = Qnil;
|
|
|
424 while (count)
|
|
|
425 val = Fcons (make_x_resource (children[--count], XA_WINDOW, device), val);
|
|
|
426
|
|
|
427 XFree (children);
|
|
|
428
|
|
|
429 return Fcons (make_x_resource (root, XA_WINDOW, device),
|
|
|
430 Fcons ((parent
|
|
|
431 ? make_x_resource (parent, XA_WINDOW, device)
|
|
|
432 : Qnil),
|
|
|
433 val));
|
|
|
434 }
|
|
|
435
|
|
|
436 /* more internal crap stolen from Epoch */
|
|
|
437
|
|
|
438 static void
|
|
|
439 verify_vector_has_consistent_type (Lisp_Object vector)
|
|
|
440 {
|
|
|
441 int i; /* vector index */
|
|
|
442 XID rtype; /* X_resource type (if vector of
|
|
|
443 X_resources) */
|
|
|
444 int length; /* vector length */
|
|
|
445 struct Lisp_Vector *v = XVECTOR (vector);
|
|
|
446 Lisp_Object *element;
|
|
|
447 Lisp_Object sample;
|
|
|
448 Lisp_Object type_obj; /* base type of vector elements */
|
|
|
449 Lisp_Object device;
|
|
|
450
|
|
|
451 sample = v->contents[0];
|
|
|
452 type_obj = sample;
|
|
|
453 if (X_RESOURCEP (sample))
|
|
|
454 {
|
|
|
455 CHECK_LIVE_X_RESOURCE (sample);
|
|
|
456 rtype = XX_RESOURCE (sample)->type;
|
|
|
457 device = XX_RESOURCE (sample)->device;
|
|
|
458 }
|
|
|
459 length = v->size;
|
|
|
460 element = v->contents;
|
|
|
461
|
|
|
462 for (i = 1; i < length; ++i, ++element)
|
|
|
463 {
|
|
|
464 QUIT;
|
|
|
465 if (X_RESOURCEP (type_obj))
|
|
|
466 CHECK_LIVE_X_RESOURCE (type_obj);
|
|
|
467 if ((XTYPE (*element) != XTYPE (type_obj))
|
|
|
468 || (LRECORDP (type_obj) &&
|
|
|
469 (XRECORD_LHEADER (*element)->implementation !=
|
|
|
470 XRECORD_LHEADER (type_obj)->implementation))
|
|
|
471 || (X_RESOURCEP (type_obj) &&
|
|
|
472 (rtype != XX_RESOURCE (*element)->type
|
|
|
473 || !EQ (device, XX_RESOURCE (*element)->device))))
|
|
|
474 error ("Vector has inconsistent types");
|
|
|
475 }
|
|
|
476 }
|
|
|
477
|
|
|
478 static void
|
|
|
479 verify_list_has_consistent_type (Lisp_Object list)
|
|
|
480 {
|
|
|
481 Lisp_Object type_obj;
|
|
|
482 XID rtype; /* X_resource type (if vector of
|
|
|
483 X_resources) */
|
|
|
484 Lisp_Object temp = Fcar (list);
|
|
|
485 Lisp_Object device;
|
|
|
486
|
|
|
487 type_obj = temp;
|
|
|
488 if (X_RESOURCEP (temp))
|
|
|
489 {
|
|
|
490 CHECK_LIVE_X_RESOURCE (temp);
|
|
|
491 rtype = XX_RESOURCE (temp)->type;
|
|
|
492 device = XX_RESOURCE (temp)->device;
|
|
|
493 }
|
|
|
494 list = Fcdr (list);
|
|
|
495
|
|
|
496 for ( ; !NILP (list) ; list = Fcdr (list))
|
|
|
497 {
|
|
|
498 QUIT;
|
|
|
499 temp = Fcar (list);
|
|
|
500 if (X_RESOURCEP (temp))
|
|
|
501 CHECK_LIVE_X_RESOURCE (temp);
|
|
|
502 if ((XTYPE (temp) != XTYPE (type_obj))
|
|
|
503 || (LRECORDP (type_obj) &&
|
|
|
504 (XRECORD_LHEADER (temp)->implementation !=
|
|
|
505 XRECORD_LHEADER (type_obj)->implementation))
|
|
|
506 || (X_RESOURCEP (type_obj) &&
|
|
|
507 (rtype != XX_RESOURCE (temp)->type
|
|
|
508 || !EQ (device, XX_RESOURCE (temp)->device))))
|
|
|
509 error ("List has inconsistent types");
|
|
|
510 }
|
|
|
511 }
|
|
|
512
|
|
|
513 #define BYTESIZE 8
|
|
|
514 /* 16 bit types */
|
|
|
515 typedef short int int16;
|
|
|
516 typedef short unsigned int uint16;
|
|
|
517
|
|
|
518 /* the Calculate functions return allocated memory that must be free'd.
|
|
|
519 I tried to use alloca, but that fails. Sigh.
|
|
|
520 */
|
|
|
521 static void *
|
|
|
522 calculate_vector_property (Lisp_Object vector, unsigned long *count,
|
|
|
523 Atom *type, int *format)
|
|
|
524 {
|
|
|
525 /* !!#### This function has not been Mule-ized */
|
|
|
526 int length;
|
|
|
527 unsigned int size,tsize;
|
|
|
528 int i;
|
|
|
529 struct Lisp_Vector *v;
|
|
|
530 void *addr;
|
|
|
531
|
|
|
532 v = XVECTOR (vector);
|
|
|
533 *count = length = v->size;
|
|
|
534
|
|
|
535 switch (XTYPE (v->contents[0]))
|
|
|
536 {
|
|
|
537 case Lisp_Int:
|
|
|
538 *type = XA_INTEGER;
|
|
|
539 if (*format != 8 && *format != 16) *format = 32;
|
|
|
540 size = *format * length;
|
|
|
541 addr = (void *) xmalloc (size);
|
|
|
542 for ( i = 0 ; i < length ; ++i )
|
|
|
543 switch (*format)
|
|
|
544 {
|
|
|
545 case 32 :
|
|
|
546 ((int *)addr)[i] = XINT (v->contents[i]);
|
|
|
547 break;
|
|
|
548 case 16 :
|
|
|
549 ((int16 *)addr)[i] = XINT (v->contents[i]);
|
|
|
550 break;
|
|
|
551 case 8 :
|
|
|
552 ((char *)addr)[i] = XINT (v->contents[i]);
|
|
|
553 break;
|
|
|
554 }
|
|
|
555 break;
|
|
|
556
|
|
|
557 case Lisp_Record:
|
|
|
558 if (X_RESOURCEP (v->contents[0]))
|
|
|
559 {
|
|
|
560 CHECK_LIVE_X_RESOURCE (v->contents[0]);
|
|
|
561 size = BYTESIZE * sizeof (XID) * length;
|
|
|
562 *format = BYTESIZE * sizeof (XID);
|
|
|
563 *type = XX_RESOURCE (v->contents[0])->type;
|
|
|
564 addr = (void *) xmalloc (size);
|
|
|
565 for ( i = 0 ; i < length ; ++i )
|
|
|
566 ( (XID *) addr) [i] = XX_RESOURCE (v->contents[i])->xid;
|
|
|
567 }
|
|
|
568 break;
|
|
|
569
|
|
|
570 case Lisp_String:
|
|
|
571 *format = BYTESIZE * sizeof (char);
|
|
|
572 *type = XA_STRING;
|
|
|
573 for ( i=0, size=0 ; i < length ; ++i )
|
|
14
|
574 size += (XSTRING_LENGTH (v->contents[i]) +
|
|
0
|
575 1); /* include null */
|
|
|
576 addr = (void *) xmalloc (size);
|
|
|
577 *count = size;
|
|
|
578 for ( i = 0 , size = 0 ; i < length ; ++i )
|
|
|
579 {
|
|
14
|
580 tsize = XSTRING_LENGTH (v->contents[i]) + 1;
|
|
|
581 memmove (((char *) addr), XSTRING_DATA (v->contents[i]),
|
|
0
|
582 tsize);
|
|
|
583 size += tsize;
|
|
|
584 }
|
|
|
585 break;
|
|
|
586
|
|
|
587 default:
|
|
|
588 error ("Invalid type for conversion");
|
|
|
589 }
|
|
|
590 return addr;
|
|
|
591 }
|
|
|
592
|
|
|
593 static void *
|
|
|
594 calculate_list_property (Lisp_Object list, unsigned long *count,
|
|
|
595 Atom *type, int *format)
|
|
|
596 {
|
|
|
597 /* !!#### This function has not been Mule-ized */
|
|
|
598 int length;
|
|
|
599 unsigned int size, tsize;
|
|
|
600 int i;
|
|
|
601 Lisp_Object tlist,temp;
|
|
|
602 void *addr;
|
|
|
603
|
|
|
604 *count = length = XINT (Flength (list));
|
|
|
605
|
|
|
606 switch (XTYPE (Fcar (list)))
|
|
|
607 {
|
|
|
608 case Lisp_Int:
|
|
|
609 *type = XA_INTEGER;
|
|
|
610 if (*format != 8 && *format != 16) *format = 32;
|
|
|
611 size = *format * length;
|
|
|
612 addr = (void *) xmalloc (size);
|
|
|
613 for ( i = 0 ; i < length ; ++i, list = Fcdr (list))
|
|
|
614 switch (*format)
|
|
|
615 {
|
|
|
616 case 32 : ((int *)addr)[i] = XINT (Fcar (list)); break;
|
|
|
617 case 16 : ((int16 *)addr)[i] = XINT (Fcar (list)); break;
|
|
|
618 case 8 : ((char *)addr)[i] = XINT (Fcar (list)); break;
|
|
|
619 }
|
|
|
620 break;
|
|
|
621
|
|
|
622 case Lisp_Record:
|
|
|
623 if (X_RESOURCEP (Fcar (list)))
|
|
|
624 {
|
|
|
625 Lisp_Object car = Fcar (list);
|
|
|
626 CHECK_LIVE_X_RESOURCE (car);
|
|
|
627 size = BYTESIZE * sizeof (XID) * length;
|
|
|
628 *format = BYTESIZE * sizeof (XID);
|
|
|
629 *type = XX_RESOURCE (Fcar (list))->type;
|
|
|
630 addr = (void *) xmalloc (size);
|
|
|
631 for ( i = 0 ; i < length ; ++i, list = Fcdr (list))
|
|
|
632 {
|
|
|
633 Lisp_Object carr = Fcar (list);
|
|
|
634 CHECK_LIVE_X_RESOURCE (carr);
|
|
|
635 ((XID *)addr)[i] = XX_RESOURCE (carr)->xid;
|
|
|
636 }
|
|
|
637 }
|
|
|
638 break;
|
|
|
639
|
|
|
640 case Lisp_String:
|
|
|
641 *format = BYTESIZE * sizeof (char);
|
|
|
642 *type = XA_STRING;
|
|
|
643 for ( i=0, size=0 , tlist=list ; i < length ; ++i, tlist = Fcdr (tlist) )
|
|
14
|
644 size += XSTRING_LENGTH (Fcar (tlist)) + 1; /* include null */
|
|
0
|
645 addr = (void *) xmalloc (size);
|
|
|
646 *count = size;
|
|
|
647 for ( i=0, size=0, tlist=list ; i < length ;
|
|
|
648 ++i , tlist = Fcdr (tlist) )
|
|
|
649 {
|
|
|
650 temp = Fcar (tlist);
|
|
14
|
651 tsize = XSTRING_LENGTH (temp) + 1;
|
|
|
652 memmove (((char *) addr), XSTRING_DATA (temp), tsize);
|
|
0
|
653 size += tsize;
|
|
|
654 }
|
|
|
655 break;
|
|
|
656
|
|
|
657 default:
|
|
|
658 error ("Invalid type for conversion");
|
|
|
659 }
|
|
|
660 return addr;
|
|
|
661 }
|
|
|
662
|
|
|
663 /* Returns whether the conversion was successful or not */
|
|
|
664 static int
|
|
|
665 convert_elisp_to_x (Lisp_Object value, void **addr, unsigned long *count,
|
|
|
666 Atom *type, int *format, int *free_storage)
|
|
|
667 {
|
|
|
668 /* !!#### This function has not been Mule-ized */
|
|
|
669 if (VECTORP (value))
|
|
|
670 verify_vector_has_consistent_type (value);
|
|
|
671 else if (CONSP (value))
|
|
|
672 verify_list_has_consistent_type (value);
|
|
|
673
|
|
|
674 *free_storage = 0;
|
|
|
675 switch (XTYPE (value))
|
|
|
676 {
|
|
|
677 case Lisp_String:
|
|
|
678 *format = BYTESIZE;
|
|
|
679 *type = XA_STRING;
|
|
14
|
680 *count = strlen ((CONST char *) XSTRING_DATA (value)) + 1;
|
|
|
681 *addr = (void *) XSTRING_DATA (value);
|
|
0
|
682 break;
|
|
|
683
|
|
|
684 case Lisp_Int:
|
|
|
685 *type = XA_INTEGER;
|
|
|
686 *count = 1;
|
|
|
687 *free_storage = 1;
|
|
|
688 *addr = (void *) xmalloc (sizeof (int));
|
|
|
689 /* This is ugly -
|
|
|
690 * we have to deal with the possibility of different formats
|
|
|
691 */
|
|
|
692 switch (*format)
|
|
|
693 {
|
|
|
694 default :
|
|
|
695 case 32 :
|
|
|
696 *format = 32;
|
|
|
697 *((int *)(*addr)) = XINT (value);
|
|
|
698 break;
|
|
|
699 case 16 :
|
|
|
700 *((int16 *)(*addr)) = XINT (value);
|
|
|
701 break;
|
|
|
702 case 8 :
|
|
|
703 *((char *)(*addr)) = XINT (value);
|
|
|
704 break;
|
|
|
705 }
|
|
|
706 break;
|
|
|
707
|
|
|
708 case Lisp_Record:
|
|
|
709 if (X_RESOURCEP (value))
|
|
|
710 {
|
|
|
711 CHECK_LIVE_X_RESOURCE (value);
|
|
|
712 *format = sizeof (XID) * BYTESIZE;
|
|
|
713 *type = XX_RESOURCE (value)->type;
|
|
|
714 *count = 1;
|
|
|
715 *addr = (void *) & (XX_RESOURCE (value)->xid);
|
|
|
716 }
|
|
|
717 break;
|
|
|
718
|
|
|
719 case Lisp_Cons:
|
|
|
720 *addr = calculate_list_property (value, count, type, format);
|
|
|
721 *free_storage = 1; /* above allocates storage */
|
|
|
722 break;
|
|
|
723
|
|
|
724 case Lisp_Vector:
|
|
|
725 *addr = calculate_vector_property (value, count, type, format);
|
|
|
726 *free_storage = 1; /* above allocates storage */
|
|
|
727 break;
|
|
|
728
|
|
|
729 default :
|
|
|
730 error ("Improper type for conversion");
|
|
|
731 }
|
|
|
732
|
|
|
733 return 1;
|
|
|
734 }
|
|
|
735
|
|
|
736 static Lisp_Object
|
|
|
737 format_size_hints (XSizeHints *hints)
|
|
|
738 {
|
|
|
739 Lisp_Object result;
|
|
|
740 struct Lisp_Vector *v;
|
|
|
741
|
|
|
742 result = Fmake_vector (make_int (6), Qnil);
|
|
|
743 v = XVECTOR (result);
|
|
|
744
|
|
|
745 /* ugly but straightforward - just step through the members and flags
|
|
|
746 * and stick in the ones that are there
|
|
|
747 */
|
|
|
748 if (hints->flags & (PPosition|USPosition))
|
|
|
749 v->contents[0] = Fcons (make_int (hints->x), make_int (hints->y));
|
|
|
750 if (hints->flags & (PSize|USSize))
|
|
|
751 v->contents[1] = Fcons (make_int (hints->width),
|
|
|
752 make_int (hints->height));
|
|
|
753 if (hints->flags & PMinSize)
|
|
|
754 v->contents[2] = Fcons (make_int (hints->min_width),
|
|
|
755 make_int (hints->min_height));
|
|
|
756 if (hints->flags & PMaxSize)
|
|
|
757 v->contents[3] = Fcons (make_int (hints->max_width),
|
|
|
758 make_int (hints->max_height));
|
|
|
759 if (hints->flags & PResizeInc)
|
|
|
760 v->contents[4] = Fcons (make_int (hints->width_inc),
|
|
|
761 make_int (hints->height_inc));
|
|
|
762 if (hints->flags & PAspect)
|
|
|
763 v->contents[5] = Fcons (make_int (hints->min_aspect.x),
|
|
|
764 Fcons (make_int (hints->min_aspect.y),
|
|
|
765 Fcons (make_int (hints->max_aspect.x),
|
|
|
766 make_int (hints->max_aspect.y))));
|
|
|
767
|
|
|
768 return result;
|
|
|
769 }
|
|
|
770
|
|
|
771 static Lisp_Object
|
|
|
772 format_string_property (char *buffer, unsigned long count)
|
|
|
773 {
|
|
|
774 /* !!#### This function has not been Mule-ized */
|
|
|
775 Lisp_Object value = Qnil; /* data */
|
|
|
776 Lisp_Object temp; /* temp value holder */
|
|
|
777 int len; /* length of current string */
|
|
|
778 char *strend;
|
|
|
779
|
|
|
780 while (count)
|
|
|
781 {
|
|
|
782 strend = memchr (buffer, 0, (int) count);
|
|
|
783 len = strend ? strend - buffer : count;
|
|
|
784 if (len)
|
|
|
785 {
|
|
|
786 temp = make_string ((Bufbyte *) buffer, len);
|
|
|
787 value = Fcons (temp, value);
|
|
|
788 }
|
|
|
789 buffer = strend + 1; /* skip null, or leaving loop if no null */
|
|
|
790 count -= len + !!strend;
|
|
|
791 }
|
|
|
792
|
|
|
793 return (NILP (Fcdr (value))
|
|
|
794 ? Fcar (value)
|
|
|
795 : Fnreverse (value));
|
|
|
796 }
|
|
|
797
|
|
|
798 static Lisp_Object
|
|
|
799 format_integer_32_property (long *buff, unsigned long count)
|
|
|
800 {
|
|
|
801 Lisp_Object value = Qnil; /* return value */
|
|
|
802 while (count)
|
|
|
803 value = Fcons (make_int (buff[--count]), value);
|
|
|
804
|
|
|
805 return (NILP (Fcdr (value))
|
|
|
806 ? Fcar (value)
|
|
|
807 : value);
|
|
|
808 }
|
|
|
809
|
|
|
810 static Lisp_Object
|
|
|
811 format_integer_16_property (int16 *buff, unsigned long count)
|
|
|
812 {
|
|
|
813 Lisp_Object value = Qnil; /* return value */
|
|
|
814
|
|
|
815 while (count)
|
|
|
816 value = Fcons (make_int (buff[--count]), value);
|
|
|
817
|
|
|
818 return (NILP (Fcdr (value))
|
|
|
819 ? Fcar (value)
|
|
|
820 : value);
|
|
|
821 }
|
|
|
822
|
|
|
823 static Lisp_Object
|
|
|
824 format_integer_8_property (char *buff, unsigned long count)
|
|
|
825 {
|
|
|
826 Lisp_Object value = Qnil; /* return value */
|
|
|
827
|
|
|
828 while (count)
|
|
|
829 value = Fcons (make_int (buff[--count]), value);
|
|
|
830
|
|
|
831 return (NILP (Fcdr (value))
|
|
|
832 ? Fcar (value)
|
|
|
833 : value);
|
|
|
834 }
|
|
|
835
|
|
|
836 static Lisp_Object
|
|
|
837 format_integer_property (void *buff, unsigned long count, int format)
|
|
|
838 {
|
|
|
839 switch (format)
|
|
|
840 {
|
|
|
841 case 8:
|
|
|
842 return format_integer_8_property ((char *) buff, count);
|
|
|
843 break;
|
|
|
844 case 16:
|
|
|
845 return format_integer_16_property ((int16 *) buff, count);
|
|
|
846 break;
|
|
|
847 case 32:
|
|
|
848 return format_integer_32_property ((long *) buff, count);
|
|
|
849 break;
|
|
|
850 default:
|
|
|
851 return Qnil;
|
|
|
852 }
|
|
|
853 }
|
|
|
854
|
|
|
855 static Lisp_Object
|
|
|
856 format_cardinal_32_property (unsigned long *buff, unsigned long count)
|
|
|
857 {
|
|
|
858 Lisp_Object value = Qnil; /* return value */
|
|
|
859
|
|
|
860 while (count)
|
|
|
861 value = Fcons (make_int (buff[--count]), value);
|
|
|
862
|
|
|
863 return (NILP (Fcdr (value))
|
|
|
864 ? Fcar (value)
|
|
|
865 : value);
|
|
|
866 }
|
|
|
867
|
|
|
868 static Lisp_Object
|
|
|
869 format_cardinal_16_property (uint16 *buff, unsigned long count)
|
|
|
870 {
|
|
|
871 Lisp_Object value = Qnil; /* return value */
|
|
|
872
|
|
|
873 while (count)
|
|
|
874 value = Fcons (make_int (buff[--count]), value);
|
|
|
875
|
|
|
876 return (NILP (Fcdr (value))
|
|
|
877 ? Fcar (value)
|
|
|
878 : value);
|
|
|
879 }
|
|
|
880
|
|
|
881 static Lisp_Object
|
|
|
882 format_cardinal_8_property (unsigned char *buff, unsigned long count)
|
|
|
883 {
|
|
|
884 Lisp_Object value = Qnil; /* return value */
|
|
|
885
|
|
|
886 while (count)
|
|
|
887 value = Fcons (make_int (buff[--count]), value);
|
|
|
888
|
|
|
889 return (NILP (Fcdr (value))
|
|
|
890 ? Fcar (value)
|
|
|
891 : value);
|
|
|
892 }
|
|
|
893
|
|
|
894 static Lisp_Object
|
|
|
895 format_cardinal_property (void *buff, unsigned long count, int format)
|
|
|
896 {
|
|
|
897 switch (format)
|
|
|
898 {
|
|
|
899 case 8:
|
|
|
900 return format_cardinal_8_property ((unsigned char *) buff, count);
|
|
|
901 break;
|
|
|
902 case 16:
|
|
|
903 return format_cardinal_16_property ((uint16 *) buff, count);
|
|
|
904 break;
|
|
|
905 case 32:
|
|
|
906 return format_cardinal_32_property ((unsigned long *) buff, count);
|
|
|
907 default:
|
|
|
908 return Qnil;
|
|
|
909 }
|
|
|
910 }
|
|
|
911
|
|
|
912 static Lisp_Object
|
|
|
913 format_unknown_property (struct device *d, void *buff, unsigned long count,
|
|
|
914 Atom type, int format)
|
|
|
915 {
|
|
|
916 Lisp_Object value = Qnil; /* return value */
|
|
|
917 Lisp_Object device = Qnil;
|
|
|
918
|
|
|
919 XSETDEVICE (device, d);
|
|
|
920
|
|
|
921 switch (format)
|
|
|
922 {
|
|
|
923 case 32:
|
|
|
924 {
|
|
|
925 XID *xid = (XID *) buff;
|
|
|
926 int non_zero = 0;
|
|
|
927 while (count--)
|
|
|
928 if (non_zero || xid[count])
|
|
|
929 {
|
|
|
930 value = Fcons (make_x_resource (xid[count], type, device),
|
|
|
931 value);
|
|
|
932 non_zero = 1;
|
|
|
933 }
|
|
|
934 }
|
|
|
935 break;
|
|
|
936 }
|
|
|
937
|
|
|
938 return (NILP (Fcdr (value))
|
|
|
939 ? Fcar (value)
|
|
|
940 : value);
|
|
|
941 }
|
|
|
942
|
|
|
943 static Lisp_Object
|
|
|
944 convert_x_to_elisp (struct device *d, void *buffer, unsigned long count,
|
|
|
945 Atom type, int format)
|
|
|
946 {
|
|
|
947 /* !!#### This function has not been Mule-ized */
|
|
|
948 Lisp_Object value = Qnil;
|
|
|
949
|
|
|
950 switch (type)
|
|
|
951 {
|
|
|
952 case None:
|
|
|
953 value = Qnil;
|
|
|
954 break;
|
|
|
955 case XA_STRING:
|
|
|
956 value = format_string_property (buffer, count);
|
|
|
957 break;
|
|
|
958 case XA_INTEGER:
|
|
|
959 value = format_integer_property ((long *) buffer, count, format);
|
|
|
960 break;
|
|
|
961 case XA_CARDINAL:
|
|
|
962 value = format_cardinal_property ((unsigned long *) buffer,
|
|
|
963 count, format);
|
|
|
964 break;
|
|
|
965 case XA_WM_SIZE_HINTS:
|
|
|
966 value = format_size_hints ((XSizeHints *) buffer);
|
|
|
967 break;
|
|
|
968 default:
|
|
|
969 value = format_unknown_property (d, (void *) buffer, count, type,
|
|
|
970 format);
|
|
|
971 break;
|
|
|
972 }
|
|
|
973
|
|
|
974 return value;
|
|
|
975 }
|
|
|
976
|
|
|
977 /* get a property given its atom, device, and window */
|
|
|
978 static Lisp_Object
|
|
|
979 raw_get_property (struct device *d, Window win, Atom prop)
|
|
|
980 {
|
|
|
981 /* !!#### This function has not been Mule-ized */
|
|
|
982 Lisp_Object value = Qnil;
|
|
|
983 Atom actual_type;
|
|
|
984 int actual_format;
|
|
|
985 unsigned char *buffer;
|
|
|
986 unsigned long count, remaining;
|
|
|
987 int zret;
|
|
|
988 Display *dpy = DEVICE_X_DISPLAY (d);
|
|
|
989
|
|
|
990 zret = XGetWindowProperty (dpy, win, prop,
|
|
|
991 0L, 1024L, False, AnyPropertyType,
|
|
|
992 &actual_type, &actual_format,
|
|
|
993 &count, &remaining, &buffer);
|
|
|
994
|
|
|
995 /* If remaining is set, then there's more of the property to get.
|
|
|
996 Let's just do the whole read again, this time with enough space
|
|
|
997 to get it all. */
|
|
|
998 if (zret == Success && remaining > 0)
|
|
|
999 {
|
|
|
1000 XFree (buffer);
|
|
|
1001 zret = XGetWindowProperty (dpy, win, prop,
|
|
|
1002 0L, 1024L + ((remaining + 3) / 4),
|
|
|
1003 False, AnyPropertyType,
|
|
|
1004 &actual_type, &actual_format,
|
|
|
1005 &count, &remaining, &buffer);
|
|
|
1006 }
|
|
|
1007
|
|
|
1008 if (zret != Success)
|
|
|
1009 return Qnil; /* failed */
|
|
|
1010
|
|
|
1011 value = convert_x_to_elisp (d, buffer, count, actual_type, actual_format);
|
|
|
1012
|
|
|
1013 XFree (buffer);
|
|
|
1014 return value;
|
|
|
1015 }
|
|
|
1016
|
|
|
1017 /*
|
|
|
1018 * Epoch equivalent: epoch::get-property
|
|
|
1019 */
|
|
20
|
1020 DEFUN ("x-get-property", Fx_get_property, 1, 2, 0, /*
|
|
0
|
1021 Retrieve the X window property for a frame. Arguments are
|
|
|
1022 PROPERTY: must be a string or an X-resource of type ATOM.
|
|
|
1023 FRAME: (optional) If present, must be a frame object, a frame id, or
|
|
|
1024 and X-resource of type WINDOW. Defaults to the current frame.
|
|
|
1025 Returns the value of the property, or nil if the property couldn't
|
|
|
1026 be retrieved.
|
|
20
|
1027 */
|
|
|
1028 (name, frame))
|
|
0
|
1029 {
|
|
|
1030 Atom prop = None;
|
|
|
1031 Lisp_Object device;
|
|
|
1032 Display *dpy;
|
|
|
1033 Window win;
|
|
|
1034
|
|
|
1035 /* We can't use Fx_id_of_frame because it returns the xid of
|
|
|
1036 the shell widget. But the property change has to take place
|
|
|
1037 on the edit widget in order for a PropertyNotify event to
|
|
|
1038 be generated */
|
|
|
1039 epoch_get_window_and_device (frame, &win, &device, 1);
|
|
|
1040 dpy = DEVICE_X_DISPLAY (XDEVICE (device));
|
|
|
1041
|
|
|
1042 if (STRINGP (name) || SYMBOLP (name))
|
|
|
1043 {
|
|
|
1044 prop = symbol_to_x_atom (XDEVICE (device),
|
|
|
1045 get_symbol_or_string_as_symbol (name),
|
|
|
1046 1);
|
|
|
1047 }
|
|
|
1048 else if (X_RESOURCEP (name))
|
|
|
1049 {
|
|
|
1050 CHECK_LIVE_X_RESOURCE (name);
|
|
|
1051 if (XX_RESOURCE (name)->type != XA_ATOM)
|
|
|
1052 error ("Property must be an ATOM X-resource");
|
|
|
1053 prop = XX_RESOURCE (name)->xid;
|
|
|
1054 }
|
|
|
1055 else
|
|
|
1056 error ("Property must be a string or X-resource ATOM");
|
|
|
1057
|
|
|
1058 if (prop == None)
|
|
|
1059 return Qnil;
|
|
|
1060
|
|
|
1061 /* now we have the atom, let's ask for the property! */
|
|
|
1062 return raw_get_property (XDEVICE (device), win, prop);
|
|
|
1063 }
|
|
|
1064
|
|
|
1065 static Lisp_Object
|
|
|
1066 raw_set_property (Display *dpy, Window win, Atom prop, Lisp_Object value)
|
|
|
1067 {
|
|
|
1068 /* !!#### This function has not been Mule-ized */
|
|
|
1069 Atom actual_type; /* X type of items */
|
|
|
1070 int actual_format; /* size of data items (8,16,32) */
|
|
|
1071 unsigned long count; /* Number of data items */
|
|
|
1072 void* addr; /* address of data item array */
|
|
|
1073 int zret; /* X call return value */
|
|
|
1074 int free_storage; /* set if addr points at non-malloc'd store */
|
|
|
1075
|
|
|
1076 actual_format = 0; /* don't force a particular format */
|
|
|
1077 convert_elisp_to_x (value, &addr, &count, &actual_type, &actual_format,
|
|
|
1078 &free_storage);
|
|
|
1079
|
|
|
1080 zret = XChangeProperty (dpy, win, prop, actual_type, actual_format,
|
|
|
1081 PropModeReplace, (char *) addr, count);
|
|
|
1082 XFlush (dpy);
|
|
|
1083
|
|
|
1084 if (free_storage)
|
|
|
1085 xfree (addr);
|
|
|
1086
|
|
|
1087 return value;
|
|
|
1088 }
|
|
|
1089
|
|
20
|
1090 DEFUN ("x-set-property", Fx_set_property, 2, 3, 0, /*
|
|
0
|
1091 Set a named property for a frame. The first argument (required)
|
|
|
1092 is the name of the property. The second is the value to set the propery
|
|
|
1093 to. The third (optional) is the frame, default is
|
|
|
1094 the current frame.
|
|
20
|
1095 */
|
|
|
1096 (name, value, frame))
|
|
0
|
1097 {
|
|
|
1098 Atom prop = None; /* name of the property */
|
|
|
1099 Lisp_Object device;
|
|
|
1100 Display *dpy;
|
|
|
1101 Window win;
|
|
|
1102
|
|
|
1103 /* We can't use Fx_id_of_frame because it returns the xid of
|
|
|
1104 the shell widget. But the property change has to take place
|
|
|
1105 on the edit widget in order for a PropertyNotify event to
|
|
|
1106 be generated */
|
|
|
1107 epoch_get_window_and_device (frame, &win, &device, 1);
|
|
|
1108 dpy = DEVICE_X_DISPLAY (XDEVICE (device));
|
|
|
1109
|
|
|
1110 /* parse the atom name, either a string or an actual atom */
|
|
|
1111 if (STRINGP (name) || SYMBOLP (name))
|
|
|
1112 {
|
|
|
1113 prop = symbol_to_x_atom (XDEVICE (device),
|
|
|
1114 get_symbol_or_string_as_symbol (name),
|
|
|
1115 0);
|
|
|
1116 }
|
|
|
1117 else if (X_RESOURCEP (name))
|
|
|
1118 {
|
|
|
1119 CHECK_LIVE_X_RESOURCE (name);
|
|
|
1120 if (XX_RESOURCE (name)->type != XA_ATOM)
|
|
|
1121 error ("Property must be an X-resource ATOM");
|
|
|
1122 prop = XX_RESOURCE (name)->xid;
|
|
|
1123 }
|
|
|
1124 else
|
|
|
1125 error ("Property must be a string or X-resource ATOM");
|
|
|
1126
|
|
|
1127 if (prop == None)
|
|
|
1128 return Qnil;
|
|
|
1129
|
|
|
1130 /* that's it. Now set it */
|
|
|
1131 return raw_set_property (dpy, win, prop, value);
|
|
|
1132 }
|
|
|
1133
|
|
|
1134 /*
|
|
|
1135 * Epoch equivalent: epoch::send-client-message
|
|
|
1136 */
|
|
20
|
1137 DEFUN ("x-send-client-message", Fx_send_client_message, 1, 5, 0, /*
|
|
0
|
1138 Send a client message to DEST, marking it as being from SOURCE.
|
|
|
1139 The message is DATA of TYPE with FORMAT. If TYPE and FORMAT are omitted,
|
|
|
1140 they are deduced from DATA. If SOURCE is nil, the current frame is used.
|
|
20
|
1141 */
|
|
|
1142 (dest, source, data, type, format))
|
|
0
|
1143 {
|
|
|
1144 /* !!#### This function has not been Mule-ized */
|
|
|
1145 int actual_format = 0;
|
|
|
1146 Atom actual_type;
|
|
|
1147 unsigned long count;
|
|
|
1148 void *addr;
|
|
|
1149 int free_storage;
|
|
|
1150 XEvent ev;
|
|
|
1151 Lisp_Object result;
|
|
|
1152 Window dest_win;
|
|
|
1153 Lisp_Object dest_device;
|
|
|
1154 Window src_win;
|
|
|
1155 Lisp_Object src_device;
|
|
|
1156 Display *dpy;
|
|
|
1157
|
|
|
1158 epoch_get_window_and_device (dest, &dest_win, &dest_device, 0);
|
|
|
1159
|
|
|
1160 if (NILP (source))
|
|
|
1161 /* This catches a return of nil */
|
|
|
1162 XSETFRAME (source, device_selected_frame (XDEVICE (dest_device)));
|
|
|
1163
|
|
|
1164 epoch_get_window_and_device (source, &src_win, &src_device, 0);
|
|
|
1165
|
|
|
1166 if (!EQ (src_device, dest_device))
|
|
|
1167 error ("Destination and source must be on the same device");
|
|
|
1168
|
|
|
1169 dpy = DEVICE_X_DISPLAY (XDEVICE (dest_device));
|
|
|
1170
|
|
|
1171 ev.xclient.window = src_win;
|
|
|
1172
|
|
|
1173 /* check format before data, because it can cause the data format to vary */
|
|
|
1174 if (!NILP (format))
|
|
|
1175 {
|
|
|
1176 CHECK_INT (format);
|
|
|
1177 actual_format = XINT (format);
|
|
|
1178 if (actual_format != 8 && actual_format != 16 && actual_format != 32)
|
|
|
1179 error ("Format must be 8, 16, or 32, or nil");
|
|
|
1180 }
|
|
|
1181
|
|
|
1182 /* clear out any cruft */
|
|
|
1183 memset ((char *) &ev.xclient.data, 0, 20);
|
|
|
1184
|
|
|
1185 /* look for the data */
|
|
|
1186 if (!NILP (data))
|
|
|
1187 {
|
|
|
1188 convert_elisp_to_x (data, &addr, &count, &actual_type, &actual_format,
|
|
|
1189 &free_storage);
|
|
|
1190 if ((count * actual_format) > 20*8)
|
|
|
1191 {
|
|
|
1192 if (free_storage)
|
|
|
1193 xfree (addr);
|
|
|
1194 error ("Data is too big to fit in a client message");
|
|
|
1195 }
|
|
|
1196 memmove (&ev.xclient.data, (char *)addr, count * (actual_format/8));
|
|
|
1197 if (free_storage)
|
|
|
1198 xfree (addr);
|
|
|
1199 }
|
|
|
1200
|
|
|
1201 if (!NILP (type))
|
|
|
1202 {
|
|
|
1203 CHECK_LIVE_X_RESOURCE (type);
|
|
|
1204 if (XX_RESOURCE (type)->type != XA_ATOM)
|
|
|
1205 error ("Resource for message type must be an atom");
|
|
|
1206 actual_type = XX_RESOURCE (type)->xid;
|
|
|
1207 }
|
|
|
1208
|
|
|
1209 ev.xany.type = ClientMessage;
|
|
|
1210 ev.xclient.message_type = actual_type;
|
|
|
1211 ev.xclient.format = actual_format;
|
|
|
1212 /* There's no better way to set the mask than to hard code the correct
|
|
|
1213 * width bit pattern. 1L<<24 == OwnerGrabButtonMask, is the largest
|
|
|
1214 * This is the word from the X-consortium.
|
|
|
1215 */
|
|
|
1216 result = (XSendEvent (dpy, dest_win, False, (1L<<25)-1L,&ev)
|
|
|
1217 ? Qt
|
|
|
1218 : Qnil);
|
|
|
1219 XFlush (dpy);
|
|
|
1220 return result;
|
|
|
1221 }
|
|
|
1222
|
|
|
1223 /*
|
|
|
1224 * These duplicate the needed functionality from the Epoch event handler.
|
|
|
1225 */
|
|
|
1226 static Lisp_Object
|
|
|
1227 read_client_message (struct device *d, XClientMessageEvent *cm)
|
|
|
1228 {
|
|
|
1229 Lisp_Object result;
|
|
|
1230 Lisp_Object device = Qnil;
|
|
|
1231
|
|
|
1232 XSETDEVICE (device, d);
|
|
|
1233 if (!cm->format) /* this is probably a sign of a bug somewhere else */
|
|
|
1234 result = Qnil;
|
|
|
1235 else
|
|
|
1236 result = Fcons (make_x_resource (cm->message_type, XA_ATOM, device),
|
|
|
1237 Fcons (make_x_resource (cm->window, XA_WINDOW, device),
|
|
|
1238 convert_x_to_elisp (d, (void *) cm->data.b,
|
|
|
1239 (20*8)/cm->format,
|
|
|
1240 cm->message_type,
|
|
|
1241 cm->format)));
|
|
|
1242
|
|
|
1243 return result;
|
|
|
1244 }
|
|
|
1245
|
|
|
1246 static Lisp_Object
|
|
|
1247 read_property_event (XPropertyEvent *pe, Lisp_Object frame)
|
|
|
1248 {
|
|
|
1249 Lisp_Object result, value;
|
|
|
1250 struct frame *f = XFRAME (frame);
|
|
|
1251 struct device *d = XDEVICE (FRAME_DEVICE (f));
|
|
|
1252 Lisp_Object atom;
|
|
|
1253
|
|
|
1254 atom = x_atom_to_symbol (d, pe->atom);
|
|
|
1255
|
|
|
1256 /* didn't get a name, blow this one off */
|
|
|
1257 if (NILP (atom))
|
|
|
1258 return Qnil;
|
|
|
1259
|
|
|
1260 /* We can't use Fx_id_of_frame because it returns the xid of
|
|
|
1261 the shell widget. But the property change has to take place
|
|
|
1262 on the edit widget in order for a PropertyNotify event to
|
|
|
1263 be generated */
|
|
|
1264 value = raw_get_property (d, XtWindow (FRAME_X_TEXT_WIDGET (f)),
|
|
|
1265 pe->atom);
|
|
|
1266 result = Fcons (Fsymbol_name (atom), value);
|
|
|
1267
|
|
|
1268 return result;
|
|
|
1269 }
|
|
|
1270
|
|
|
1271 void dispatch_epoch_event (struct frame *f, XEvent *event, Lisp_Object type);
|
|
|
1272 void
|
|
|
1273 dispatch_epoch_event (struct frame *f, XEvent *event, Lisp_Object type)
|
|
|
1274 {
|
|
|
1275 /* This function can GC */
|
|
|
1276 struct Lisp_Vector *evp;
|
|
|
1277 struct device *d = XDEVICE (FRAME_DEVICE (f));
|
|
|
1278
|
|
|
1279 if (NILP (Vepoch_event_handler))
|
|
|
1280 return;
|
|
|
1281
|
|
|
1282 if (!VECTORP (Vepoch_event) || XVECTOR (Vepoch_event)->size < 3)
|
|
|
1283 Vepoch_event = Fmake_vector (make_int (3), Qnil);
|
|
|
1284 evp = XVECTOR (Vepoch_event);
|
|
|
1285
|
|
|
1286 XSETFRAME (evp->contents[2], f);
|
|
|
1287
|
|
|
1288 if (EQ (type, Qx_property_change))
|
|
|
1289 {
|
|
|
1290 evp->contents[0] = Qx_property_change;
|
|
|
1291 evp->contents[1] =
|
|
|
1292 read_property_event (&event->xproperty, evp->contents[2]);
|
|
|
1293 }
|
|
|
1294 else if (EQ (type, Qx_client_message))
|
|
|
1295 {
|
|
|
1296 evp->contents[0] = Qx_client_message;
|
|
|
1297 evp->contents[1] = read_client_message (d, &event->xclient);
|
|
|
1298 }
|
|
|
1299 else if (EQ (type, Qx_map))
|
|
|
1300 {
|
|
|
1301 evp->contents[0] = Qx_map;
|
|
|
1302 evp->contents[1] = Qt;
|
|
|
1303 }
|
|
|
1304 else if (EQ (type, Qx_unmap))
|
|
|
1305 {
|
|
|
1306 evp->contents[0] = Qx_unmap;
|
|
|
1307 evp->contents[1] = Qnil;
|
|
|
1308 }
|
|
|
1309 else
|
|
|
1310 {
|
|
|
1311 Vepoch_event = Qnil;
|
|
|
1312 }
|
|
|
1313
|
|
|
1314 if (NILP (Vepoch_event))
|
|
|
1315 return;
|
|
|
1316
|
|
|
1317 Ffuncall (1, &Vepoch_event_handler);
|
|
|
1318
|
|
|
1319 Vepoch_event = Qnil;
|
|
|
1320 return;
|
|
|
1321 }
|
|
|
1322
|
|
|
1323
|
|
|
1324 void
|
|
|
1325 syms_of_epoch (void)
|
|
|
1326 {
|
|
20
|
1327 DEFSUBR (Fx_intern_atom);
|
|
|
1328 DEFSUBR (Fx_atom_name);
|
|
|
1329 DEFSUBR (Fstring_to_x_resource);
|
|
|
1330 DEFSUBR (Fx_resource_to_type);
|
|
|
1331 DEFSUBR (Fx_resource_to_string);
|
|
|
1332 DEFSUBR (Fx_id_of_frame);
|
|
|
1333 DEFSUBR (Fx_query_tree);
|
|
|
1334 DEFSUBR (Fx_get_property);
|
|
|
1335 DEFSUBR (Fx_set_property);
|
|
|
1336 DEFSUBR (Fx_send_client_message);
|
|
|
1337 DEFSUBR (Fx_resource_p);
|
|
|
1338 DEFSUBR (Fx_resource_device);
|
|
|
1339 DEFSUBR (Fx_resource_live_p);
|
|
|
1340 DEFSUBR (Fset_x_resource_type);
|
|
0
|
1341
|
|
|
1342 defsymbol (&Qx_resourcep, "x-resource-p");
|
|
|
1343 defsymbol (&Qx_resource_live_p, "x-resource-live-p");
|
|
|
1344 defsymbol (&Qx_property_change, "x-property-change");
|
|
|
1345 defsymbol (&Qx_client_message, "x-client-message");
|
|
|
1346 defsymbol (&Qx_map, "x-map");
|
|
|
1347 defsymbol (&Qx_unmap, "x-unmap");
|
|
|
1348 }
|
|
|
1349
|
|
|
1350 void
|
|
|
1351 vars_of_epoch (void)
|
|
|
1352 {
|
|
|
1353 Fprovide (intern ("epoch"));
|
|
|
1354
|
|
|
1355 DEFVAR_LISP ("epoch-event-handler", &Vepoch_event_handler /*
|
|
|
1356 If this variable is not nil, then it is assumed to have
|
|
|
1357 a function in it. When an epoch event is received for a frame, this
|
|
|
1358 function is called.
|
|
|
1359 */ );
|
|
|
1360 Vepoch_event_handler = Qnil;
|
|
|
1361
|
|
|
1362 DEFVAR_LISP ("epoch-event", &Vepoch_event /*
|
|
|
1363 Bound to the value of the current event when epoch-event-handler is called.
|
|
|
1364 */ );
|
|
|
1365 Vepoch_event = Qnil;
|
|
|
1366 }
|
