Mercurial > hg > xemacs-beta

comparison src/epoch.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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 }