Better seed support for (random).
[emacs.git] / src / nsselect.m
blobe0bbfe58636a8e629a30a935256837a276b36c1d
1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
2    Copyright (C) 1993-1994, 2005-2006, 2008-2012
3      Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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.
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.
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/>.  */
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)
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>
33 #include "lisp.h"
34 #include "nsterm.h"
35 #include "termhooks.h"
36 #include "keyboard.h"
38 Lisp_Object QCLIPBOARD, QSECONDARY, QTEXT, QFILE_NAME;
40 static Lisp_Object Vselection_alist;
42 static Lisp_Object Qforeign_selection;
44 /* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */
45 NSString *NXPrimaryPboard;
46 NSString *NXSecondaryPboard;
50 /* ==========================================================================
52     Internal utility functions
54    ========================================================================== */
57 static NSString *
58 symbol_to_nsstring (Lisp_Object sym)
60   CHECK_SYMBOL (sym);
61   if (EQ (sym, QCLIPBOARD))   return NSGeneralPboard;
62   if (EQ (sym, QPRIMARY))     return NXPrimaryPboard;
63   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
64   if (EQ (sym, QTEXT))        return NSStringPboardType;
65   return [NSString stringWithUTF8String: SSDATA (SYMBOL_NAME (sym))];
68 static NSPasteboard *
69 ns_symbol_to_pb (Lisp_Object symbol)
71   return [NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
74 static Lisp_Object
75 ns_string_to_symbol (NSString *t)
77   if ([t isEqualToString: NSGeneralPboard])
78     return QCLIPBOARD;
79   if ([t isEqualToString: NXPrimaryPboard])
80     return QPRIMARY;
81   if ([t isEqualToString: NXSecondaryPboard])
82     return QSECONDARY;
83   if ([t isEqualToString: NSStringPboardType])
84     return QTEXT;
85   if ([t isEqualToString: NSFilenamesPboardType])
86     return QFILE_NAME;
87   if ([t isEqualToString: NSTabularTextPboardType])
88     return QTEXT;
89   return intern ([t UTF8String]);
93 static Lisp_Object
94 clean_local_selection_data (Lisp_Object obj)
96   if (CONSP (obj)
97       && INTEGERP (XCAR (obj))
98       && CONSP (XCDR (obj))
99       && INTEGERP (XCAR (XCDR (obj)))
100       && NILP (XCDR (XCDR (obj))))
101     obj = Fcons (XCAR (obj), XCDR (obj));
103   if (CONSP (obj)
104       && INTEGERP (XCAR (obj))
105       && INTEGERP (XCDR (obj)))
106     {
107       if (XINT (XCAR (obj)) == 0)
108         return XCDR (obj);
109       if (XINT (XCAR (obj)) == -1)
110         return make_number (- XINT (XCDR (obj)));
111     }
113   if (VECTORP (obj))
114     {
115       ptrdiff_t i;
116       ptrdiff_t size = ASIZE (obj);
117       Lisp_Object copy;
119       if (size == 1)
120         return clean_local_selection_data (AREF (obj, 0));
121       copy = Fmake_vector (make_number (size), Qnil);
122       for (i = 0; i < size; i++)
123         ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
124       return copy;
125     }
127   return obj;
131 static void
132 ns_declare_pasteboard (id pb)
134   [pb declareTypes: ns_send_types owner: NSApp];
138 static void
139 ns_undeclare_pasteboard (id pb)
141   [pb declareTypes: [NSArray array] owner: nil];
145 static void
146 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
148   if (EQ (str, Qnil))
149     {
150       [pb declareTypes: [NSArray array] owner: nil];
151     }
152   else
153     {
154       char *utfStr;
155       NSString *type, *nsStr;
156       NSEnumerator *tenum;
158       CHECK_STRING (str);
160       utfStr = SSDATA (str);
161       nsStr = [[NSString alloc] initWithBytesNoCopy: utfStr
162                                              length: SBYTES (str)
163                                            encoding: NSUTF8StringEncoding
164                                        freeWhenDone: NO];
165       if (gtype == nil)
166         {
167           [pb declareTypes: ns_send_types owner: nil];
168           tenum = [ns_send_types objectEnumerator];
169           while ( (type = [tenum nextObject]) )
170             [pb setString: nsStr forType: type];
171         }
172       else
173         {
174           [pb setString: nsStr forType: gtype];
175         }
176       [nsStr release];
177     }
181 Lisp_Object
182 ns_get_local_selection (Lisp_Object selection_name,
183                        Lisp_Object target_type)
185   Lisp_Object local_value;
186   Lisp_Object handler_fn, value, type, check;
187   ptrdiff_t count;
189   local_value = assq_no_quit (selection_name, Vselection_alist);
191   if (NILP (local_value)) return Qnil;
193   count = specpdl_ptr - specpdl;
194   specbind (Qinhibit_quit, Qt);
195   CHECK_SYMBOL (target_type);
196   handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
197   if (!NILP (handler_fn))
198     value = call3 (handler_fn, selection_name, target_type,
199                 XCAR (XCDR (local_value)));
200   else
201     value = Qnil;
202   unbind_to (count, Qnil);
204   check = value;
205   if (CONSP (value) && SYMBOLP (XCAR (value)))
206     {
207       type = XCAR (value);
208       check = XCDR (value);
209     }
211   if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
212       || INTEGERP (check) || NILP (value))
213     return value;
215   if (CONSP (check)
216       && INTEGERP (XCAR (check))
217       && (INTEGERP (XCDR (check))||
218           (CONSP (XCDR (check))
219            && INTEGERP (XCAR (XCDR (check)))
220            && NILP (XCDR (XCDR (check))))))
221     return value;
223   // FIXME: Why `quit' rather than `error'?
224   Fsignal (Qquit, Fcons (build_string (
225       "invalid data returned by selection-conversion function"),
226                         Fcons (handler_fn, Fcons (value, Qnil))));
227   // FIXME: Beware, `quit' can return!!
228   return Qnil;
232 static Lisp_Object
233 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
235   id pb;
236   pb = ns_symbol_to_pb (symbol);
237   return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
243 /* ==========================================================================
245     Functions used externally
247    ========================================================================== */
250 Lisp_Object
251 ns_string_from_pasteboard (id pb)
253   NSString *type, *str;
254   const char *utfStr;
255   int length;
257   type = [pb availableTypeFromArray: ns_return_types];
258   if (type == nil)
259     {
260       Fsignal (Qquit,
261               Fcons (build_string ("empty or unsupported pasteboard type"),
262                     Qnil));
263     return Qnil;
264     }
266   /* get the string */
267   if (! (str = [pb stringForType: type]))
268     {
269       NSData *data = [pb dataForType: type];
270       if (data != nil)
271         str = [[NSString alloc] initWithData: data
272                                     encoding: NSUTF8StringEncoding];
273       if (str != nil)
274         {
275           [str autorelease];
276         }
277       else
278         {
279           Fsignal (Qquit,
280                   Fcons (build_string ("pasteboard doesn't contain valid data"),
281                         Qnil));
282           return Qnil;
283         }
284     }
286   /* assume UTF8 */
287   NS_DURING
288     {
289       /* EOL conversion: PENDING- is this too simple? */
290       NSMutableString *mstr = [[str mutableCopy] autorelease];
291       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
292             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
293       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
294             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
296       utfStr = [mstr UTF8String];
297       length = [mstr lengthOfBytesUsingEncoding: NSUTF8StringEncoding];
299 #if ! defined (NS_IMPL_COCOA) || MAC_OS_X_VERSION_MAX_ALLOWED < MAC_OS_X_VERSION_10_4
300       if (!utfStr)
301         {
302           utfStr = [mstr cString];
303           length = strlen (utfStr);
304         }
305 #endif
306     }
307   NS_HANDLER
308     {
309       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
310 #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4
311       utfStr = "Conversion failed";
312 #else
313       utfStr = [str lossyCString];
314 #endif
315       length = strlen (utfStr);
316     }
317   NS_ENDHANDLER
319     return make_string (utfStr, length);
323 void
324 ns_string_to_pasteboard (id pb, Lisp_Object str)
326   ns_string_to_pasteboard_internal (pb, str, nil);
331 /* ==========================================================================
333     Lisp Defuns
335    ========================================================================== */
338 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
339        Sx_own_selection_internal, 2, 3, 0,
340        doc: /* Assert an X selection of type SELECTION and value VALUE.
341 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
342 \(Those are literal upper-case symbol names, since that's what X expects.)
343 VALUE is typically a string, or a cons of two markers, but may be
344 anything that the functions on `selection-converter-alist' know about.
346 FRAME should be a frame that should own the selection.  If omitted or
347 nil, it defaults to the selected frame.
349 On Nextstep, FRAME is unused.  */)
350      (Lisp_Object selection, Lisp_Object value, Lisp_Object frame)
352   id pb;
353   Lisp_Object old_value, new_value;
354   NSString *type;
355   Lisp_Object successful_p = Qnil, rest;
356   Lisp_Object target_symbol, data;
359   check_ns ();
360   CHECK_SYMBOL (selection);
361   if (NILP (value))
362       error ("selection value may not be nil.");
363   pb = ns_symbol_to_pb (selection);
364   if (pb == nil) return Qnil;
366   ns_declare_pasteboard (pb);
367   old_value = assq_no_quit (selection, Vselection_alist);
368   new_value = Fcons (selection, Fcons (value, Qnil));
370   if (NILP (old_value))
371     Vselection_alist = Fcons (new_value, Vselection_alist);
372   else
373     Fsetcdr (old_value, Fcdr (new_value));
375   /* We only support copy of text.  */
376   type = NSStringPboardType;
377   target_symbol = ns_string_to_symbol (type);
378   data = ns_get_local_selection (selection, target_symbol);
379   if (!NILP (data))
380     {
381       if (STRINGP (data))
382         ns_string_to_pasteboard_internal (pb, data, type);
383       successful_p = Qt;
384     }
386   if (!EQ (Vns_sent_selection_hooks, Qunbound))
387     {
388       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
389         call3 (Fcar (rest), selection, target_symbol, successful_p);
390     }
392   return value;
396 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
397        Sx_disown_selection_internal, 1, 3, 0,
398        doc: /* If we own the selection SELECTION, disown it.
399 Disowning it means there is no such selection.
401 Sets the last-change time for the selection to TIME-OBJECT (by default
402 the time of the last event).
404 TERMINAL should be a terminal object or a frame specifying the X
405 server to query.  If omitted or nil, that stands for the selected
406 frame's display, or the first available X display.
408 On Nextstep, the TIME-OBJECT and TERMINAL arguments are unused.
409 On MS-DOS, all this does is return non-nil if we own the selection.  */)
410   (Lisp_Object selection, Lisp_Object time_object, Lisp_Object terminal)
412   id pb;
413   check_ns ();
414   CHECK_SYMBOL (selection);
415   if (NILP (assq_no_quit (selection, Vselection_alist))) return Qnil;
417   pb = ns_symbol_to_pb (selection);
418   if (pb != nil) ns_undeclare_pasteboard (pb);
419   return Qt;
423 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
424        0, 2, 0, doc: /* Whether there is an owner for the given X selection.
425 SELECTION should be the name of the selection in question, typically
426 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  (X expects
427 these literal upper-case names.)  The symbol nil is the same as
428 `PRIMARY', and t is the same as `SECONDARY'.
430 TERMINAL should be a terminal object or a frame specifying the X
431 server to query.  If omitted or nil, that stands for the selected
432 frame's display, or the first available X display.
434 On Nextstep, TERMINAL is unused.  */)
435      (Lisp_Object selection, Lisp_Object terminal)
437   id pb;
438   NSArray *types;
440   check_ns ();
441   CHECK_SYMBOL (selection);
442   if (EQ (selection, Qnil)) selection = QPRIMARY;
443   if (EQ (selection, Qt)) selection = QSECONDARY;
444   pb = ns_symbol_to_pb (selection);
445   if (pb == nil) return Qnil;
447   types = [pb types];
448   return ([types count] == 0) ? Qnil : Qt;
452 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
453        0, 2, 0,
454        doc: /* Whether the current Emacs process owns the given X Selection.
455 The arg should be the name of the selection in question, typically one of
456 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
457 \(Those are literal upper-case symbol names, since that's what X expects.)
458 For convenience, the symbol nil is the same as `PRIMARY',
459 and t is the same as `SECONDARY'.
461 TERMINAL should be a terminal object or a frame specifying the X
462 server to query.  If omitted or nil, that stands for the selected
463 frame's display, or the first available X display.
465 On Nextstep, TERMINAL is unused.  */)
466      (Lisp_Object selection, Lisp_Object terminal)
468   check_ns ();
469   CHECK_SYMBOL (selection);
470   if (EQ (selection, Qnil)) selection = QPRIMARY;
471   if (EQ (selection, Qt)) selection = QSECONDARY;
472   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
476 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
477        Sx_get_selection_internal, 2, 4, 0,
478        doc: /* Return text selected from some X window.
479 SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
480 \(Those are literal upper-case symbol names, since that's what X expects.)
481 TARGET-TYPE is the type of data desired, typically `STRING'.
483 TIME-STAMP is the time to use in the XConvertSelection call for foreign
484 selections.  If omitted, defaults to the time for the last event.
486 TERMINAL should be a terminal object or a frame specifying the X
487 server to query.  If omitted or nil, that stands for the selected
488 frame's display, or the first available X display.
490 On Nextstep, TIME-STAMP and TERMINAL are unused.  */)
491      (Lisp_Object selection_name, Lisp_Object target_type,
492       Lisp_Object time_stamp, Lisp_Object terminal)
494   Lisp_Object val;
496   check_ns ();
497   CHECK_SYMBOL (selection_name);
498   CHECK_SYMBOL (target_type);
499   val = ns_get_local_selection (selection_name, target_type);
500   if (NILP (val))
501     val = ns_get_foreign_selection (selection_name, target_type);
502   if (CONSP (val) && SYMBOLP (Fcar (val)))
503     {
504       val = Fcdr (val);
505       if (CONSP (val) && NILP (Fcdr (val)))
506         val = Fcar (val);
507     }
508   val = clean_local_selection_data (val);
509   return val;
513 DEFUN ("ns-get-selection-internal", Fns_get_selection_internal,
514        Sns_get_selection_internal, 1, 1, 0,
515        doc: /* Returns the value of SELECTION as a string.
516 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. */)
517      (Lisp_Object selection)
519   id pb;
520   check_ns ();
521   pb = ns_symbol_to_pb (selection);
522   return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
526 DEFUN ("ns-store-selection-internal", Fns_store_selection_internal,
527        Sns_store_selection_internal, 2, 2, 0,
528        doc: /* Sets the string value of SELECTION.
529 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. */)
530      (Lisp_Object selection, Lisp_Object string)
532   id pb;
533   check_ns ();
534   pb = ns_symbol_to_pb (selection);
535   if (pb != nil) ns_string_to_pasteboard (pb, string);
536   return Qnil;
540 void
541 nxatoms_of_nsselect (void)
543   NXPrimaryPboard = @"Selection";
544   NXSecondaryPboard = @"Secondary";
547 void
548 syms_of_nsselect (void)
550   QCLIPBOARD = intern_c_string ("CLIPBOARD");   staticpro (&QCLIPBOARD);
551   QSECONDARY = intern_c_string ("SECONDARY");   staticpro (&QSECONDARY);
552   QTEXT      = intern_c_string ("TEXT");        staticpro (&QTEXT);
553   QFILE_NAME = intern_c_string ("FILE_NAME");   staticpro (&QFILE_NAME);
555   defsubr (&Sx_disown_selection_internal);
556   defsubr (&Sx_get_selection_internal);
557   defsubr (&Sx_own_selection_internal);
558   defsubr (&Sx_selection_exists_p);
559   defsubr (&Sx_selection_owner_p);
560   defsubr (&Sns_get_selection_internal);
561   defsubr (&Sns_store_selection_internal);
563   Vselection_alist = Qnil;
564   staticpro (&Vselection_alist);
566   DEFVAR_LISP ("ns-sent-selection-hooks", Vns_sent_selection_hooks,
567                "A list of functions to be called when Emacs answers a selection request.\n\
568 The functions are called with four arguments:\n\
569   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
570   - the selection-type which Emacs was asked to convert the\n\
571     selection into before sending (for example, `STRING' or `LENGTH');\n\
572   - a flag indicating success or failure for responding to the request.\n\
573 We might have failed (and declined the request) for any number of reasons,\n\
574 including being asked for a selection that we no longer own, or being asked\n\
575 to convert into a type that we don't know about or that is inappropriate.\n\
576 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
577 it merely informs you that they have happened.");
578   Vns_sent_selection_hooks = Qnil;
580   DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
581                "An alist associating X Windows selection-types with functions.\n\
582 These functions are called to convert the selection, with three args:\n\
583 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
584 a desired type to which the selection should be converted;\n\
585 and the local selection value (whatever was given to `x-own-selection').\n\
587 The function should return the value to send to the X server\n\
588 \(typically a string).  A return value of nil\n\
589 means that the conversion could not be done.\n\
590 A return value which is the symbol `NULL'\n\
591 means that a side-effect was executed,\n\
592 and there is no meaningful selection value.");
593   Vselection_converter_alist = Qnil;
595   DEFVAR_LISP ("ns-lost-selection-hooks", Vns_lost_selection_hooks,
596                "A list of functions to be called when Emacs loses an X selection.\n\
597 \(This happens when some other X client makes its own selection\n\
598 or when a Lisp program explicitly clears the selection.)\n\
599 The functions are called with one argument, the selection type\n\
600 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
601   Vns_lost_selection_hooks = Qnil;
603   Qforeign_selection = intern_c_string ("foreign-selection");
604   staticpro (&Qforeign_selection);