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