Mercurial > hg > xemacs-beta
annotate src/select-gtk.c @ 5609:3152c2c21461
Correct and clarify docstring, #'load-time-value
lisp/ChangeLog addition:
2011-12-09 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (load-time-value):
Clarify the docstring here, thanks for pointing out its inaccuracy
Julian Bradfield.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Fri, 09 Dec 2011 08:38:07 +0000 |
parents | 56144c8593a8 |
children | 79e9934779c1 |
rev | line source |
---|---|
462 | 1 /* GTK selection processing for XEmacs |
2 Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. | |
771 | 3 Copyright (C) 2001 Ben Wing. |
462 | 4 |
5 This file is part of XEmacs. | |
6 | |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4985
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
462 | 8 under the terms of the GNU General Public License as published by the |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4985
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4985
diff
changeset
|
10 option) any later version. |
462 | 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 | |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4985
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
462 | 19 |
20 /* Synched up with: Not synched with FSF. */ | |
21 | |
22 /* Authorship: | |
23 | |
24 Written by Kevin Gallo for FSF Emacs. | |
25 Rewritten for mswindows by Jonathan Harris, December 1997 for 21.0. | |
26 Rewritten for GTK by William Perry, April 2000 for 21.1 | |
27 */ | |
28 | |
29 | |
30 #include <config.h> | |
31 #include "lisp.h" | |
872 | 32 |
462 | 33 #include "buffer.h" |
872 | 34 #include "device-impl.h" |
35 #include "events.h" | |
36 #include "frame.h" | |
37 #include "opaque.h" | |
462 | 38 #include "select.h" |
872 | 39 |
40 #include "console-gtk-impl.h" | |
462 | 41 |
42 static Lisp_Object Vretrieved_selection; | |
43 static gboolean waiting_for_selection; | |
44 Lisp_Object Vgtk_sent_selection_hooks; | |
45 | |
778 | 46 extern int lisp_to_time (Lisp_Object, time_t *); |
47 extern Lisp_Object time_to_lisp (time_t); | |
48 | |
647 | 49 static GdkAtom |
2286 | 50 symbol_to_gtk_atom (struct device *UNUSED (d), Lisp_Object sym, |
51 int only_if_exists) | |
647 | 52 { |
53 if (NILP (sym)) return GDK_SELECTION_PRIMARY; | |
54 if (EQ (sym, Qt)) return GDK_SELECTION_SECONDARY; | |
55 if (EQ (sym, QPRIMARY)) return GDK_SELECTION_PRIMARY; | |
56 if (EQ (sym, QSECONDARY)) return GDK_SELECTION_SECONDARY; | |
57 | |
58 { | |
59 const Extbyte *nameext; | |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
60 nameext = LISP_STRING_TO_EXTERNAL (Fsymbol_name (sym), Qctext); |
647 | 61 return gdk_atom_intern (nameext, only_if_exists ? TRUE : FALSE); |
62 } | |
63 } | |
462 | 64 |
647 | 65 static Lisp_Object |
2286 | 66 atom_to_symbol (struct device *UNUSED (d), GdkAtom atom) |
647 | 67 { |
68 if (atom == GDK_SELECTION_PRIMARY) return (QPRIMARY); | |
69 if (atom == GDK_SELECTION_SECONDARY) return (QSECONDARY); | |
70 | |
71 { | |
867 | 72 Ibyte *intstr; |
647 | 73 Extbyte *str = gdk_atom_name (atom); |
74 | |
75 if (! str) return Qnil; | |
462 | 76 |
4981
4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
77 intstr = EXTERNAL_TO_ITEXT (str, Qctext); |
647 | 78 g_free (str); |
4953
304aebb79cd3
function renamings to track names of char typedefs
Ben Wing <ben@xemacs.org>
parents:
2620
diff
changeset
|
79 return intern_istring (intstr); |
647 | 80 } |
81 } | |
82 | |
4984 | 83 #define THIS_IS_GTK |
84 #include "select-xlike-inc.c" | |
85 #undef THIS_IS_GTK | |
647 | 86 |
87 | |
462 | 88 /* Set the selection data to GDK_NONE and NULL data, meaning we were |
89 ** unable to do what they wanted. | |
90 */ | |
91 static void | |
92 gtk_decline_selection_request (GtkSelectionData *data) | |
93 { | |
94 gtk_selection_data_set (data, GDK_NONE, 0, NULL, 0); | |
95 } | |
96 | |
97 /* Used as an unwind-protect clause so that, if a selection-converter signals | |
98 an error, we tell the requestor that we were unable to do what they wanted | |
99 before we throw to top-level or go into the debugger or whatever. | |
100 */ | |
101 struct _selection_closure | |
102 { | |
103 GtkSelectionData *data; | |
104 gboolean successful; | |
105 }; | |
106 | |
107 static Lisp_Object | |
108 gtk_selection_request_lisp_error (Lisp_Object closure) | |
109 { | |
110 struct _selection_closure *cl = (struct _selection_closure *) | |
111 get_opaque_ptr (closure); | |
112 | |
113 free_opaque_ptr (closure); | |
114 if (cl->successful == TRUE) | |
115 return Qnil; | |
116 gtk_decline_selection_request (cl->data); | |
117 return Qnil; | |
118 } | |
119 | |
120 /* This provides the current selection to a requester. | |
121 ** | |
122 ** This is connected to the selection_get() signal of the application | |
123 ** shell in device-gtk.c:gtk_init_device(). | |
124 ** | |
125 ** This is radically different than the old selection code (21.1.x), | |
126 ** but has been modeled after the X code, and appears to work. | |
127 ** | |
128 ** WMP Feb 12 2001 | |
129 */ | |
130 void | |
2286 | 131 emacs_gtk_selection_handle (GtkWidget *UNUSED (widget), |
462 | 132 GtkSelectionData *selection_data, |
2286 | 133 guint UNUSED (info), |
462 | 134 guint time_stamp, |
2286 | 135 gpointer UNUSED (data)) |
462 | 136 { |
137 /* This function can GC */ | |
138 struct gcpro gcpro1, gcpro2; | |
139 Lisp_Object temp_obj; | |
140 Lisp_Object selection_symbol; | |
141 Lisp_Object target_symbol = Qnil; | |
142 Lisp_Object converted_selection = Qnil; | |
143 guint32 local_selection_time; | |
144 Lisp_Object successful_p = Qnil; | |
145 int count; | |
146 struct device *d = decode_gtk_device (Qnil); | |
147 struct _selection_closure *cl = NULL; | |
148 | |
149 GCPRO2 (converted_selection, target_symbol); | |
150 | |
151 selection_symbol = atom_to_symbol (d, selection_data->selection); | |
152 target_symbol = atom_to_symbol (d, selection_data->target); | |
153 | |
154 #if 0 /* #### MULTIPLE doesn't work yet */ | |
155 if (EQ (target_symbol, QMULTIPLE)) | |
156 target_symbol = fetch_multiple_target (selection_data); | |
157 #endif | |
158 | |
2620 | 159 temp_obj = get_selection_raw_time(selection_symbol); |
462 | 160 |
161 if (NILP (temp_obj)) | |
162 { | |
163 /* We don't appear to have the selection. */ | |
164 gtk_decline_selection_request (selection_data); | |
165 | |
166 goto DONE_LABEL; | |
167 } | |
168 | |
169 local_selection_time = * (guint32 *) XOPAQUE_DATA (temp_obj); | |
170 | |
171 if (time_stamp != GDK_CURRENT_TIME && | |
172 local_selection_time > time_stamp) | |
173 { | |
174 /* Someone asked for the selection, and we have one, but not the one | |
175 they're looking for. */ | |
176 gtk_decline_selection_request (selection_data); | |
177 goto DONE_LABEL; | |
178 } | |
179 | |
180 converted_selection = select_convert_out (selection_symbol, | |
181 target_symbol, Qnil); | |
182 | |
183 /* #### Is this the right thing to do? I'm no X expert. -- ajh */ | |
184 if (NILP (converted_selection)) | |
185 { | |
186 /* We don't appear to have a selection in that data type. */ | |
187 gtk_decline_selection_request (selection_data); | |
188 goto DONE_LABEL; | |
189 } | |
190 | |
191 count = specpdl_depth (); | |
192 | |
2367 | 193 cl = xnew (struct _selection_closure); |
462 | 194 cl->data = selection_data; |
195 cl->successful = FALSE; | |
196 | |
197 record_unwind_protect (gtk_selection_request_lisp_error, | |
198 make_opaque_ptr (cl)); | |
199 | |
200 { | |
2367 | 201 Rawbyte *data; |
665 | 202 Bytecount size; |
462 | 203 int format; |
204 GdkAtom type; | |
205 lisp_data_to_selection_data (d, converted_selection, | |
206 &data, &type, &size, &format); | |
207 | |
647 | 208 gtk_selection_data_set (selection_data, type, format, data, |
209 /* #### is this right? */ | |
210 (unsigned int) size); | |
462 | 211 successful_p = Qt; |
212 /* Tell x_selection_request_lisp_error() it's cool. */ | |
213 cl->successful = TRUE; | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
214 xfree (data); |
462 | 215 } |
216 | |
771 | 217 unbind_to (count); |
462 | 218 |
219 DONE_LABEL: | |
220 | |
1726 | 221 if (cl) |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4953
diff
changeset
|
222 xfree (cl); |
462 | 223 |
224 UNGCPRO; | |
225 | |
226 /* Let random lisp code notice that the selection has been asked for. */ | |
227 { | |
228 Lisp_Object val = Vgtk_sent_selection_hooks; | |
229 if (!UNBOUNDP (val) && !NILP (val)) | |
230 { | |
231 Lisp_Object rest; | |
232 if (CONSP (val) && !EQ (XCAR (val), Qlambda)) | |
233 for (rest = val; !NILP (rest); rest = Fcdr (rest)) | |
234 call3 (Fcar (rest), selection_symbol, target_symbol, successful_p); | |
235 else | |
236 call3 (val, selection_symbol, target_symbol, successful_p); | |
237 } | |
238 } | |
239 } | |
240 | |
241 | |
746 | 242 void |
2286 | 243 emacs_gtk_selection_clear_event_handle (GtkWidget *UNUSED (widget), |
746 | 244 GdkEventSelection *event, |
2286 | 245 gpointer UNUSED (data)) |
746 | 246 { |
247 GdkAtom selection = event->selection; | |
248 guint32 changed_owner_time = event->time; | |
249 struct device *d = decode_gtk_device (Qnil); | |
250 | |
251 Lisp_Object selection_symbol, local_selection_time_lisp; | |
252 guint32 local_selection_time; | |
253 | |
254 selection_symbol = atom_to_symbol (d, selection); | |
255 | |
2620 | 256 local_selection_time_lisp = get_selection_raw_time (selection_symbol); |
746 | 257 |
258 /* We don't own the selection, so that's fine. */ | |
259 if (NILP (local_selection_time_lisp)) | |
260 return; | |
261 | |
262 local_selection_time = *(guint32 *) XOPAQUE_DATA (local_selection_time_lisp); | |
263 | |
264 /* This SelectionClear is for a selection that we no longer own, so we can | |
265 disregard it. (That is, we have reasserted the selection since this | |
266 request was generated.) | |
267 */ | |
268 if (changed_owner_time != GDK_CURRENT_TIME && | |
269 local_selection_time > changed_owner_time) | |
270 return; | |
271 | |
272 handle_selection_clear (selection_symbol); | |
273 } | |
274 | |
275 | |
462 | 276 |
277 static GtkWidget *reading_selection_reply; | |
278 static GdkAtom reading_which_selection; | |
279 static int selection_reply_timed_out; | |
280 | |
281 /* Gets the current selection owned by another application */ | |
282 void | |
2286 | 283 emacs_gtk_selection_received (GtkWidget *UNUSED (widget), |
462 | 284 GtkSelectionData *selection_data, |
2286 | 285 gpointer UNUSED (user_data)) |
462 | 286 { |
287 waiting_for_selection = FALSE; | |
288 Vretrieved_selection = Qnil; | |
289 | |
290 reading_selection_reply = NULL; | |
291 | |
292 signal_fake_event (); | |
293 | |
294 if (selection_data->length < 0) | |
295 { | |
296 return; | |
297 } | |
298 | |
299 Vretrieved_selection = | |
300 selection_data_to_lisp_data (NULL, | |
301 selection_data->data, | |
302 selection_data->length, | |
303 selection_data->type, | |
304 selection_data->format); | |
305 } | |
306 | |
307 static int | |
2286 | 308 selection_reply_done (void *UNUSED (ignore)) |
462 | 309 { |
310 return !reading_selection_reply; | |
311 } | |
312 | |
313 /* Do protocol to read selection-data from the server. | |
314 Converts this to lisp data and returns it. | |
315 */ | |
316 static Lisp_Object | |
317 gtk_get_foreign_selection (Lisp_Object selection_symbol, | |
318 Lisp_Object target_type) | |
319 { | |
320 /* This function can GC */ | |
321 struct device *d = decode_gtk_device (Qnil); | |
322 GtkWidget *requestor = DEVICE_GTK_APP_SHELL (d); | |
323 guint32 requestor_time = DEVICE_GTK_MOUSE_TIMESTAMP (d); | |
324 GdkAtom selection_atom = symbol_to_gtk_atom (d, selection_symbol, 0); | |
325 int speccount; | |
326 GdkAtom type_atom = symbol_to_gtk_atom (d, (CONSP (target_type) ? | |
327 XCAR (target_type) : target_type), 0); | |
328 | |
329 gtk_selection_convert (requestor, selection_atom, type_atom, | |
330 requestor_time); | |
331 | |
332 signal_fake_event (); | |
333 | |
334 /* Block until the reply has been read. */ | |
335 reading_selection_reply = requestor; | |
336 reading_which_selection = selection_atom; | |
337 selection_reply_timed_out = 0; | |
338 | |
339 speccount = specpdl_depth (); | |
340 | |
341 #if 0 | |
342 /* add a timeout handler */ | |
343 if (gtk_selection_timeout > 0) | |
344 { | |
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
345 Lisp_Object id = Fadd_timeout (make_fixnum (x_selection_timeout), |
462 | 346 Qx_selection_reply_timeout_internal, |
347 Qnil, Qnil); | |
348 record_unwind_protect (Fdisable_timeout, id); | |
349 } | |
350 #endif | |
351 | |
352 /* This is ^Gable */ | |
353 wait_delaying_user_input (selection_reply_done, 0); | |
354 | |
355 if (selection_reply_timed_out) | |
563 | 356 signal_error (Qselection_conversion_error, "timed out waiting for reply from selection owner", Qunbound); |
462 | 357 |
771 | 358 unbind_to (speccount); |
462 | 359 |
360 /* otherwise, the selection is waiting for us on the requested property. */ | |
361 return select_convert_in (selection_symbol, | |
362 target_type, | |
363 Vretrieved_selection); | |
364 } | |
365 | |
366 | |
367 #if 0 | |
368 static void | |
369 gtk_get_window_property (struct device *d, GtkWidget *window, GdkAtom property, | |
370 Extbyte **data_ret, int *bytes_ret, | |
371 GdkAtom *actual_type_ret, int *actual_format_ret, | |
372 unsigned long *actual_size_ret, int delete_p) | |
373 { | |
647 | 374 /* deleted */ |
462 | 375 } |
376 | |
377 | |
378 static void | |
379 receive_incremental_selection (Display *display, Window window, Atom property, | |
380 /* this one is for error messages only */ | |
381 Lisp_Object target_type, | |
382 unsigned int min_size_bytes, | |
383 Extbyte **data_ret, int *size_bytes_ret, | |
384 Atom *type_ret, int *format_ret, | |
385 unsigned long *size_ret) | |
386 { | |
647 | 387 /* deleted */ |
462 | 388 } |
389 | |
390 | |
391 static Lisp_Object | |
392 gtk_get_window_property_as_lisp_data (struct device *d, | |
393 GtkWidget *window, | |
394 GdkAtom property, | |
395 /* next two for error messages only */ | |
396 Lisp_Object target_type, | |
397 GdkAtom selection_atom) | |
398 { | |
647 | 399 /* deleted */ |
462 | 400 } |
401 #endif | |
402 | |
403 | |
404 | |
405 static Lisp_Object | |
2286 | 406 gtk_own_selection (Lisp_Object selection_name, |
407 Lisp_Object UNUSED (selection_value), | |
408 Lisp_Object UNUSED (how_to_add), | |
409 Lisp_Object UNUSED (selection_type), int UNUSED (owned_p)) | |
462 | 410 { |
411 struct device *d = decode_gtk_device (Qnil); | |
412 GtkWidget *selecting_window = GTK_WIDGET (DEVICE_GTK_APP_SHELL (d)); | |
413 /* Use the time of the last-read mouse or keyboard event. | |
414 For selection purposes, we use this as a sleazy way of knowing what the | |
415 current time is in server-time. This assumes that the most recently read | |
416 mouse or keyboard event has something to do with the assertion of the | |
417 selection, which is probably true. | |
418 */ | |
419 guint32 thyme = DEVICE_GTK_MOUSE_TIMESTAMP (d); | |
420 GdkAtom selection_atom; | |
421 | |
422 CHECK_SYMBOL (selection_name); | |
423 selection_atom = symbol_to_gtk_atom (d, selection_name, 0); | |
424 | |
425 gtk_selection_owner_set (selecting_window, | |
426 selection_atom, | |
427 thyme); | |
428 | |
2620 | 429 /* [[ We do NOT use time_to_lisp() here any more, like we used to. |
462 | 430 That assumed equivalence of time_t and Time, which is not |
431 necessarily the case (e.g. under OSF on the Alphas, where | |
432 Time is a 64-bit quantity and time_t is a 32-bit quantity). | |
433 | |
2620 | 434 Opaque pointers are the clean way to go here. ]] |
435 | |
436 See my comment on the same issue in select-x.c -- Aidan. */ | |
793 | 437 return make_opaque (&thyme, sizeof (thyme)); |
462 | 438 } |
439 | |
440 static void | |
441 gtk_disown_selection (Lisp_Object selection, Lisp_Object timeval) | |
442 { | |
443 struct device *d = decode_gtk_device (Qnil); | |
444 GdkAtom selection_atom; | |
445 guint32 timestamp; | |
446 | |
447 CHECK_SYMBOL (selection); | |
448 selection_atom = symbol_to_gtk_atom (d, selection, 0); | |
449 | |
450 if (NILP (timeval)) | |
451 timestamp = DEVICE_GTK_MOUSE_TIMESTAMP (d); | |
452 else | |
453 { | |
454 time_t the_time; | |
455 lisp_to_time (timeval, &the_time); | |
456 timestamp = (guint32) the_time; | |
457 } | |
458 | |
459 gtk_selection_owner_set (NULL, selection_atom, timestamp); | |
460 } | |
461 | |
462 static Lisp_Object | |
463 gtk_selection_exists_p (Lisp_Object selection, | |
2286 | 464 Lisp_Object UNUSED (selection_type)) |
462 | 465 { |
466 struct device *d = decode_gtk_device (Qnil); | |
467 | |
468 return (gdk_selection_owner_get (symbol_to_gtk_atom (d, selection, 0)) ? Qt : Qnil); | |
469 } | |
470 | |
471 | |
472 | |
473 /************************************************************************/ | |
474 /* initialization */ | |
475 /************************************************************************/ | |
476 | |
477 void | |
478 syms_of_select_gtk (void) | |
479 { | |
480 } | |
481 | |
482 void | |
483 console_type_create_select_gtk (void) | |
484 { | |
485 CONSOLE_HAS_METHOD (gtk, own_selection); | |
486 CONSOLE_HAS_METHOD (gtk, disown_selection); | |
487 CONSOLE_HAS_METHOD (gtk, selection_exists_p); | |
488 CONSOLE_HAS_METHOD (gtk, get_foreign_selection); | |
489 } | |
490 | |
491 void | |
492 vars_of_select_gtk (void) | |
493 { | |
494 staticpro (&Vretrieved_selection); | |
495 Vretrieved_selection = Qnil; | |
496 | |
497 DEFVAR_LISP ("gtk-sent-selection-hooks", &Vgtk_sent_selection_hooks /* | |
498 A function or functions to be called after we have responded to some | |
499 other client's request for the value of a selection that we own. The | |
500 function(s) will be called with four arguments: | |
501 - the name of the selection (typically PRIMARY, SECONDARY, or CLIPBOARD); | |
502 - the name of the selection-type which we were requested to convert the | |
503 selection into before sending (for example, STRING or LENGTH); | |
504 - and whether we successfully transmitted the selection. | |
505 We might have failed (and declined the request) for any number of reasons, | |
506 including being asked for a selection that we no longer own, or being asked | |
507 to convert into a type that we don't know about or that is inappropriate. | |
508 This hook doesn't let you change the behavior of emacs's selection replies, | |
509 it merely informs you that they have happened. | |
510 */ ); | |
511 Vgtk_sent_selection_hooks = Qunbound; | |
512 } |