* alloc.c (pure_bytes_used_lisp, pure_bytes_used_non_lisp):
[bpt/emacs.git] / src / nsselect.m
1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
2 Copyright (C) 1993-1994, 2005-2006, 2008-2011
3 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20 /*
21 Originally by Carl Edman
22 Updated by Christian Limpach (chris@nice.ch)
23 OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com)
24 MacOSX/Aqua port by Christophe de Dinechin (descubes@earthlink.net)
25 GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
26 */
27
28 /* This should be the first include, as it may set up #defines affecting
29 interpretation of even the system includes. */
30 #include <config.h>
31 #include <setjmp.h>
32
33 #include "lisp.h"
34 #include "nsterm.h"
35 #include "termhooks.h"
36 #include "keyboard.h"
37
38 #define CUT_BUFFER_SUPPORT
39
40 Lisp_Object QCLIPBOARD, QSECONDARY, QTEXT, QFILE_NAME;
41
42 static Lisp_Object Vselection_alist;
43
44 static Lisp_Object Qforeign_selection;
45
46 /* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */
47 NSString *NXPrimaryPboard;
48 NSString *NXSecondaryPboard;
49
50
51
52 /* ==========================================================================
53
54 Internal utility functions
55
56 ========================================================================== */
57
58
59 static NSString *
60 symbol_to_nsstring (Lisp_Object sym)
61 {
62 CHECK_SYMBOL (sym);
63 if (EQ (sym, QCLIPBOARD)) return NSGeneralPboard;
64 if (EQ (sym, QPRIMARY)) return NXPrimaryPboard;
65 if (EQ (sym, QSECONDARY)) return NXSecondaryPboard;
66 if (EQ (sym, QTEXT)) return NSStringPboardType;
67 return [NSString stringWithUTF8String: SDATA (XSYMBOL (sym)->xname)];
68 }
69
70
71 static Lisp_Object
72 ns_string_to_symbol (NSString *t)
73 {
74 if ([t isEqualToString: NSGeneralPboard])
75 return QCLIPBOARD;
76 if ([t isEqualToString: NXPrimaryPboard])
77 return QPRIMARY;
78 if ([t isEqualToString: NXSecondaryPboard])
79 return QSECONDARY;
80 if ([t isEqualToString: NSStringPboardType])
81 return QTEXT;
82 if ([t isEqualToString: NSFilenamesPboardType])
83 return QFILE_NAME;
84 if ([t isEqualToString: NSTabularTextPboardType])
85 return QTEXT;
86 return intern ([t UTF8String]);
87 }
88
89
90 static Lisp_Object
91 clean_local_selection_data (Lisp_Object obj)
92 {
93 if (CONSP (obj)
94 && INTEGERP (XCAR (obj))
95 && CONSP (XCDR (obj))
96 && INTEGERP (XCAR (XCDR (obj)))
97 && NILP (XCDR (XCDR (obj))))
98 obj = Fcons (XCAR (obj), XCDR (obj));
99
100 if (CONSP (obj)
101 && INTEGERP (XCAR (obj))
102 && INTEGERP (XCDR (obj)))
103 {
104 if (XINT (XCAR (obj)) == 0)
105 return XCDR (obj);
106 if (XINT (XCAR (obj)) == -1)
107 return make_number (- XINT (XCDR (obj)));
108 }
109
110 if (VECTORP (obj))
111 {
112 int i;
113 int size = ASIZE (obj);
114 Lisp_Object copy;
115
116 if (size == 1)
117 return clean_local_selection_data (AREF (obj, 0));
118 copy = Fmake_vector (make_number (size), Qnil);
119 for (i = 0; i < size; i++)
120 ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
121 return copy;
122 }
123
124 return obj;
125 }
126
127
128 static void
129 ns_declare_pasteboard (id pb)
130 {
131 [pb declareTypes: ns_send_types owner: NSApp];
132 }
133
134
135 static void
136 ns_undeclare_pasteboard (id pb)
137 {
138 [pb declareTypes: [NSArray array] owner: nil];
139 }
140
141
142 static void
143 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
144 {
145 if (EQ (str, Qnil))
146 {
147 [pb declareTypes: [NSArray array] owner: nil];
148 }
149 else
150 {
151 char *utfStr;
152 NSString *type, *nsStr;
153 NSEnumerator *tenum;
154
155 CHECK_STRING (str);
156
157 utfStr = SDATA (str);
158 nsStr = [[NSString alloc] initWithBytesNoCopy: utfStr
159 length: SBYTES (str)
160 encoding: NSUTF8StringEncoding
161 freeWhenDone: NO];
162 if (gtype == nil)
163 {
164 [pb declareTypes: ns_send_types owner: nil];
165 tenum = [ns_send_types objectEnumerator];
166 while ( (type = [tenum nextObject]) )
167 [pb setString: nsStr forType: type];
168 }
169 else
170 {
171 [pb setString: nsStr forType: gtype];
172 }
173 [nsStr release];
174 }
175 }
176
177
178 Lisp_Object
179 ns_get_local_selection (Lisp_Object selection_name,
180 Lisp_Object target_type)
181 {
182 Lisp_Object local_value;
183 Lisp_Object handler_fn, value, type, check;
184 ptrdiff_t count;
185
186 local_value = assq_no_quit (selection_name, Vselection_alist);
187
188 if (NILP (local_value)) return Qnil;
189
190 count = specpdl_ptr - specpdl;
191 specbind (Qinhibit_quit, Qt);
192 CHECK_SYMBOL (target_type);
193 handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
194 if (!NILP (handler_fn))
195 value = call3 (handler_fn, selection_name, target_type,
196 XCAR (XCDR (local_value)));
197 else
198 value = Qnil;
199 unbind_to (count, Qnil);
200
201 check = value;
202 if (CONSP (value) && SYMBOLP (XCAR (value)))
203 {
204 type = XCAR (value);
205 check = XCDR (value);
206 }
207
208 if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
209 || INTEGERP (check) || NILP (value))
210 return value;
211
212 if (CONSP (check)
213 && INTEGERP (XCAR (check))
214 && (INTEGERP (XCDR (check))||
215 (CONSP (XCDR (check))
216 && INTEGERP (XCAR (XCDR (check)))
217 && NILP (XCDR (XCDR (check))))))
218 return value;
219
220 // FIXME: Why `quit' rather than `error'?
221 Fsignal (Qquit, Fcons (build_string (
222 "invalid data returned by selection-conversion function"),
223 Fcons (handler_fn, Fcons (value, Qnil))));
224 // FIXME: Beware, `quit' can return!!
225 return Qnil;
226 }
227
228
229 static Lisp_Object
230 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
231 {
232 id pb;
233 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
234 return ns_string_from_pasteboard (pb);
235 }
236
237
238 static void
239 ns_handle_selection_request (struct input_event *event)
240 {
241 // FIXME: BIG UGLY HACK!!!
242 id pb = (id)*(EMACS_INT*)&(event->x);
243 NSString *type = (NSString *)*(EMACS_INT*)&(event->y);
244 Lisp_Object selection_name, selection_data, target_symbol, data;
245 Lisp_Object successful_p, rest;
246
247 selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
248 target_symbol = ns_string_to_symbol (type);
249 selection_data = assq_no_quit (selection_name, Vselection_alist);
250 successful_p = Qnil;
251
252 if (!NILP (selection_data))
253 {
254 data = ns_get_local_selection (selection_name, target_symbol);
255 if (!NILP (data))
256 {
257 if (STRINGP (data))
258 ns_string_to_pasteboard_internal (pb, data, type);
259 successful_p = Qt;
260 }
261 }
262
263 if (!EQ (Vns_sent_selection_hooks, Qunbound))
264 {
265 for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
266 call3 (Fcar (rest), selection_name, target_symbol, successful_p);
267 }
268 }
269
270
271 static void
272 ns_handle_selection_clear (struct input_event *event)
273 {
274 id pb = (id)*(EMACS_INT*)&(event->x);
275 Lisp_Object selection_name, selection_data, rest;
276
277 selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
278 selection_data = assq_no_quit (selection_name, Vselection_alist);
279 if (NILP (selection_data)) return;
280
281 if (EQ (selection_data, Fcar (Vselection_alist)))
282 Vselection_alist = Fcdr (Vselection_alist);
283 else
284 {
285 for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
286 if (EQ (selection_data, Fcar (Fcdr (rest))))
287 Fsetcdr (rest, Fcdr (Fcdr (rest)));
288 }
289
290 if (!EQ (Vns_lost_selection_hooks, Qunbound))
291 {
292 for (rest = Vns_lost_selection_hooks;CONSP (rest); rest = Fcdr (rest))
293 call1 (Fcar (rest), selection_name);
294 }
295 }
296
297
298
299 /* ==========================================================================
300
301 Functions used externally
302
303 ========================================================================== */
304
305
306 Lisp_Object
307 ns_string_from_pasteboard (id pb)
308 {
309 NSString *type, *str;
310 const char *utfStr;
311 int length;
312
313 type = [pb availableTypeFromArray: ns_return_types];
314 if (type == nil)
315 {
316 Fsignal (Qquit,
317 Fcons (build_string ("empty or unsupported pasteboard type"),
318 Qnil));
319 return Qnil;
320 }
321
322 /* get the string */
323 if (! (str = [pb stringForType: type]))
324 {
325 NSData *data = [pb dataForType: type];
326 if (data != nil)
327 str = [[NSString alloc] initWithData: data
328 encoding: NSUTF8StringEncoding];
329 if (str != nil)
330 {
331 [str autorelease];
332 }
333 else
334 {
335 Fsignal (Qquit,
336 Fcons (build_string ("pasteboard doesn't contain valid data"),
337 Qnil));
338 return Qnil;
339 }
340 }
341
342 /* assume UTF8 */
343 NS_DURING
344 {
345 /* EOL conversion: PENDING- is this too simple? */
346 NSMutableString *mstr = [[str mutableCopy] autorelease];
347 [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
348 options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
349 [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
350 options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
351
352 utfStr = [mstr UTF8String];
353 length = [mstr lengthOfBytesUsingEncoding: NSUTF8StringEncoding];
354
355 #if ! defined (NS_IMPL_COCOA) || MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_4
356 if (!utfStr)
357 {
358 utfStr = [mstr cString];
359 length = strlen (utfStr);
360 }
361 #endif
362 }
363 NS_HANDLER
364 {
365 message1 ("ns_string_from_pasteboard: UTF8String failed\n");
366 #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4
367 utfStr = "Conversion failed";
368 #else
369 utfStr = [str lossyCString];
370 #endif
371 length = strlen (utfStr);
372 }
373 NS_ENDHANDLER
374
375 return make_string (utfStr, length);
376 }
377
378
379 void
380 ns_string_to_pasteboard (id pb, Lisp_Object str)
381 {
382 ns_string_to_pasteboard_internal (pb, str, nil);
383 }
384
385
386
387 /* ==========================================================================
388
389 Lisp Defuns
390
391 ========================================================================== */
392
393
394 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
395 Sx_own_selection_internal, 2, 2, 0,
396 doc: /* Assert a selection.
397 SELECTION-NAME is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
398 VALUE is typically a string, or a cons of two markers, but may be
399 anything that the functions on `selection-converter-alist' know about. */)
400 (Lisp_Object selection_name, Lisp_Object selection_value)
401 {
402 id pb;
403 Lisp_Object old_value, new_value;
404
405 check_ns ();
406 CHECK_SYMBOL (selection_name);
407 if (NILP (selection_value))
408 error ("selection-value may not be nil.");
409 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
410 ns_declare_pasteboard (pb);
411 old_value = assq_no_quit (selection_name, Vselection_alist);
412 new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
413 if (NILP (old_value))
414 Vselection_alist = Fcons (new_value, Vselection_alist);
415 else
416 Fsetcdr (old_value, Fcdr (new_value));
417 /* XXX An evil hack, but a necessary one I fear XXX */
418 {
419 struct input_event ev;
420 ev.kind = SELECTION_REQUEST_EVENT;
421 ev.modifiers = 0;
422 ev.code = 0;
423 *(EMACS_INT*)(&(ev.x)) = (EMACS_INT)pb; // FIXME: BIG UGLY HACK!!
424 *(EMACS_INT*)(&(ev.y)) = (EMACS_INT)NSStringPboardType;
425 ns_handle_selection_request (&ev);
426 }
427 return selection_value;
428 }
429
430
431 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
432 Sx_disown_selection_internal, 1, 2, 0,
433 doc: /* If we own the selection SELECTION, disown it. */)
434 (Lisp_Object selection_name, Lisp_Object time)
435 {
436 id pb;
437 check_ns ();
438 CHECK_SYMBOL (selection_name);
439 if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
440
441 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
442 ns_undeclare_pasteboard (pb);
443 return Qt;
444 }
445
446
447 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
448 0, 1, 0, doc: /* Whether there is an owner for the given selection.
449 The arg should be the name of the selection in question, typically one of
450 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
451 \(Those are literal upper-case symbol names.)
452 For convenience, the symbol nil is the same as `PRIMARY',
453 and t is the same as `SECONDARY'.) */)
454 (Lisp_Object selection)
455 {
456 id pb;
457 NSArray *types;
458
459 check_ns ();
460 CHECK_SYMBOL (selection);
461 if (EQ (selection, Qnil)) selection = QPRIMARY;
462 if (EQ (selection, Qt)) selection = QSECONDARY;
463 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
464 types =[pb types];
465 return ([types count] == 0) ? Qnil : Qt;
466 }
467
468
469 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
470 0, 1, 0,
471 doc: /* Whether the current Emacs process owns the given selection.
472 The arg should be the name of the selection in question, typically one of
473 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
474 \(Those are literal upper-case symbol names.)
475 For convenience, the symbol nil is the same as `PRIMARY',
476 and t is the same as `SECONDARY'.) */)
477 (Lisp_Object selection)
478 {
479 check_ns ();
480 CHECK_SYMBOL (selection);
481 if (EQ (selection, Qnil)) selection = QPRIMARY;
482 if (EQ (selection, Qt)) selection = QSECONDARY;
483 return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
484 }
485
486
487 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
488 Sx_get_selection_internal, 2, 2, 0,
489 doc: /* Return text selected from some pasteboard.
490 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
491 \(Those are literal upper-case symbol names.)
492 TYPE is the type of data desired, typically `STRING'. */)
493 (Lisp_Object selection_name, Lisp_Object target_type)
494 {
495 Lisp_Object val;
496
497 check_ns ();
498 CHECK_SYMBOL (selection_name);
499 CHECK_SYMBOL (target_type);
500 val = ns_get_local_selection (selection_name, target_type);
501 if (NILP (val))
502 val = ns_get_foreign_selection (selection_name, target_type);
503 if (CONSP (val) && SYMBOLP (Fcar (val)))
504 {
505 val = Fcdr (val);
506 if (CONSP (val) && NILP (Fcdr (val)))
507 val = Fcar (val);
508 }
509 val = clean_local_selection_data (val);
510 return val;
511 }
512
513
514 #ifdef CUT_BUFFER_SUPPORT
515 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
516 Sns_get_cut_buffer_internal, 1, 1, 0,
517 doc: /* Returns the value of the named cut buffer. */)
518 (Lisp_Object buffer)
519 {
520 id pb;
521 check_ns ();
522 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
523 return ns_string_from_pasteboard (pb);
524 }
525
526
527 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
528 Sns_rotate_cut_buffers_internal, 1, 1, 0,
529 doc: /* Rotate the values of the cut buffers by N steps.
530 Positive N means move values forward, negative means
531 backward. CURRENTLY NOT IMPLEMENTED UNDER NEXTSTEP. */ )
532 (Lisp_Object n)
533 {
534 /* XXX This function is unimplemented under NeXTstep XXX */
535 Fsignal (Qquit, Fcons (build_string (
536 "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
537 return Qnil;
538 }
539
540
541 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
542 Sns_store_cut_buffer_internal, 2, 2, 0,
543 doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0). */)
544 (Lisp_Object buffer, Lisp_Object string)
545 {
546 id pb;
547 check_ns ();
548 pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
549 ns_string_to_pasteboard (pb, string);
550 return Qnil;
551 }
552 #endif
553
554
555 void
556 nxatoms_of_nsselect (void)
557 {
558 NXPrimaryPboard = @"Selection";
559 NXSecondaryPboard = @"Secondary";
560 }
561
562 void
563 syms_of_nsselect (void)
564 {
565 QCLIPBOARD = intern_c_string ("CLIPBOARD"); staticpro (&QCLIPBOARD);
566 QSECONDARY = intern_c_string ("SECONDARY"); staticpro (&QSECONDARY);
567 QTEXT = intern_c_string ("TEXT"); staticpro (&QTEXT);
568 QFILE_NAME = intern_c_string ("FILE_NAME"); staticpro (&QFILE_NAME);
569
570 defsubr (&Sx_disown_selection_internal);
571 defsubr (&Sx_get_selection_internal);
572 defsubr (&Sx_own_selection_internal);
573 defsubr (&Sx_selection_exists_p);
574 defsubr (&Sx_selection_owner_p);
575 #ifdef CUT_BUFFER_SUPPORT
576 defsubr (&Sns_get_cut_buffer_internal);
577 defsubr (&Sns_rotate_cut_buffers_internal);
578 defsubr (&Sns_store_cut_buffer_internal);
579 #endif
580
581 Vselection_alist = Qnil;
582 staticpro (&Vselection_alist);
583
584 DEFVAR_LISP ("ns-sent-selection-hooks", Vns_sent_selection_hooks,
585 "A list of functions to be called when Emacs answers a selection request.\n\
586 The functions are called with four arguments:\n\
587 - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
588 - the selection-type which Emacs was asked to convert the\n\
589 selection into before sending (for example, `STRING' or `LENGTH');\n\
590 - a flag indicating success or failure for responding to the request.\n\
591 We might have failed (and declined the request) for any number of reasons,\n\
592 including being asked for a selection that we no longer own, or being asked\n\
593 to convert into a type that we don't know about or that is inappropriate.\n\
594 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
595 it merely informs you that they have happened.");
596 Vns_sent_selection_hooks = Qnil;
597
598 DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
599 "An alist associating X Windows selection-types with functions.\n\
600 These functions are called to convert the selection, with three args:\n\
601 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
602 a desired type to which the selection should be converted;\n\
603 and the local selection value (whatever was given to `x-own-selection').\n\
604 \n\
605 The function should return the value to send to the X server\n\
606 \(typically a string). A return value of nil\n\
607 means that the conversion could not be done.\n\
608 A return value which is the symbol `NULL'\n\
609 means that a side-effect was executed,\n\
610 and there is no meaningful selection value.");
611 Vselection_converter_alist = Qnil;
612
613 DEFVAR_LISP ("ns-lost-selection-hooks", Vns_lost_selection_hooks,
614 "A list of functions to be called when Emacs loses an X selection.\n\
615 \(This happens when some other X client makes its own selection\n\
616 or when a Lisp program explicitly clears the selection.)\n\
617 The functions are called with one argument, the selection type\n\
618 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
619 Vns_lost_selection_hooks = Qnil;
620
621 Qforeign_selection = intern_c_string ("foreign-selection");
622 staticpro (&Qforeign_selection);
623 }
624