* frames.texi (Pop-Up Menus): Document where menu title comes from (Bug#7684).
[emacs.git] / src / nsselect.m
blob1b1dfc7f0d0ab88e59d4d1de81807db27594c60d
1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
2    Copyright (C) 1993, 1994, 2005, 2006, 2008, 2009, 2010, 2011
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"
37 #define CUT_BUFFER_SUPPORT
39 Lisp_Object QPRIMARY, QSECONDARY, QTEXT, QFILE_NAME;
41 static Lisp_Object Vns_sent_selection_hooks;
42 static Lisp_Object Vns_lost_selection_hooks;
43 static Lisp_Object Vselection_alist;
44 static Lisp_Object Vselection_converter_alist;
46 static Lisp_Object Qforeign_selection;
48 NSString *NXSecondaryPboard;
52 /* ==========================================================================
54     Internal utility functions
56    ========================================================================== */
59 static NSString *
60 symbol_to_nsstring (Lisp_Object sym)
62   CHECK_SYMBOL (sym);
63   if (EQ (sym, QPRIMARY))     return NSGeneralPboard;
64   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
65   if (EQ (sym, QTEXT))        return NSStringPboardType;
66   return [NSString stringWithUTF8String: SDATA (XSYMBOL (sym)->xname)];
70 static Lisp_Object
71 ns_string_to_symbol (NSString *t)
73   if ([t isEqualToString: NSGeneralPboard])
74     return QPRIMARY;
75   if ([t isEqualToString: NXSecondaryPboard])
76     return QSECONDARY;
77   if ([t isEqualToString: NSStringPboardType])
78     return QTEXT;
79   if ([t isEqualToString: NSFilenamesPboardType])
80     return QFILE_NAME;
81   if ([t isEqualToString: NSTabularTextPboardType])
82     return QTEXT;
83   return intern ([t UTF8String]);
87 static Lisp_Object
88 clean_local_selection_data (Lisp_Object obj)
90   if (CONSP (obj)
91       && INTEGERP (XCAR (obj))
92       && CONSP (XCDR (obj))
93       && INTEGERP (XCAR (XCDR (obj)))
94       && NILP (XCDR (XCDR (obj))))
95     obj = Fcons (XCAR (obj), XCDR (obj));
97   if (CONSP (obj)
98       && INTEGERP (XCAR (obj))
99       && INTEGERP (XCDR (obj)))
100     {
101       if (XINT (XCAR (obj)) == 0)
102         return XCDR (obj);
103       if (XINT (XCAR (obj)) == -1)
104         return make_number (- XINT (XCDR (obj)));
105     }
107   if (VECTORP (obj))
108     {
109       int i;
110       int size = ASIZE (obj);
111       Lisp_Object copy;
113       if (size == 1)
114         return clean_local_selection_data (AREF (obj, 0));
115       copy = Fmake_vector (make_number (size), Qnil);
116       for (i = 0; i < size; i++)
117         ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
118       return copy;
119     }
121   return obj;
125 static void
126 ns_declare_pasteboard (id pb)
128   [pb declareTypes: ns_send_types owner: NSApp];
132 static void
133 ns_undeclare_pasteboard (id pb)
135   [pb declareTypes: [NSArray array] owner: nil];
139 static void
140 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
142   if (EQ (str, Qnil))
143     {
144       [pb declareTypes: [NSArray array] owner: nil];
145     }
146   else
147     {
148       char *utfStr;
149       NSString *type, *nsStr;
150       NSEnumerator *tenum;
152       CHECK_STRING (str);
154       utfStr = SDATA (str);
155       nsStr = [NSString stringWithUTF8String: utfStr];
157       if (gtype == nil)
158         {
159           [pb declareTypes: ns_send_types owner: nil];
160           tenum = [ns_send_types objectEnumerator];
161           while ( (type = [tenum nextObject]) )
162             [pb setString: nsStr forType: type];
163         }
164       else
165         {
166           [pb setString: nsStr forType: gtype];
167         }
168     }
172 static Lisp_Object
173 ns_get_local_selection (Lisp_Object selection_name,
174                        Lisp_Object target_type)
176   Lisp_Object local_value;
177   Lisp_Object handler_fn, value, type, check;
178   int count;
180   local_value = assq_no_quit (selection_name, Vselection_alist);
182   if (NILP (local_value)) return Qnil;
184   count = specpdl_ptr - specpdl;
185   specbind (Qinhibit_quit, Qt);
186   CHECK_SYMBOL (target_type);
187   handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
188   if (!NILP (handler_fn))
189     value = call3 (handler_fn, selection_name, target_type,
190                 XCAR (XCDR (local_value)));
191   else
192     value = Qnil;
193   unbind_to (count, Qnil);
195   check = value;
196   if (CONSP (value) && SYMBOLP (XCAR (value)))
197     {
198       type = XCAR (value);
199       check = XCDR (value);
200     }
202   if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
203       || INTEGERP (check) || NILP (value))
204     return value;
206   if (CONSP (check)
207       && INTEGERP (XCAR (check))
208       && (INTEGERP (XCDR (check))||
209           (CONSP (XCDR (check))
210            && INTEGERP (XCAR (XCDR (check)))
211            && NILP (XCDR (XCDR (check))))))
212     return value;
214   // FIXME: Why `quit' rather than `error'?
215   Fsignal (Qquit, Fcons (build_string (
216       "invalid data returned by selection-conversion function"),
217                         Fcons (handler_fn, Fcons (value, Qnil))));
218   // FIXME: Beware, `quit' can return!!
219   return Qnil;
223 static Lisp_Object
224 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
226   id pb;
227   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
228   return ns_string_from_pasteboard (pb);
232 static void
233 ns_handle_selection_request (struct input_event *event)
235   // FIXME: BIG UGLY HACK!!!
236   id pb = (id)*(EMACS_INT*)&(event->x);
237   NSString *type = (NSString *)*(EMACS_INT*)&(event->y);
238   Lisp_Object selection_name, selection_data, target_symbol, data;
239   Lisp_Object successful_p, rest;
241   selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
242   target_symbol = ns_string_to_symbol (type);
243   selection_data = assq_no_quit (selection_name, Vselection_alist);
244   successful_p = Qnil;
246   if (!NILP (selection_data))
247     {
248       data = ns_get_local_selection (selection_name, target_symbol);
249       if (!NILP (data))
250         {
251           if (STRINGP (data))
252             ns_string_to_pasteboard_internal (pb, data, type);
253           successful_p = Qt;
254         }
255     }
257   if (!EQ (Vns_sent_selection_hooks, Qunbound))
258     {
259       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
260         call3 (Fcar (rest), selection_name, target_symbol, successful_p);
261     }
265 static void
266 ns_handle_selection_clear (struct input_event *event)
268   id pb = (id)*(EMACS_INT*)&(event->x);
269   Lisp_Object selection_name, selection_data, rest;
271   selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
272   selection_data = assq_no_quit (selection_name, Vselection_alist);
273   if (NILP (selection_data)) return;
275   if (EQ (selection_data, Fcar (Vselection_alist)))
276     Vselection_alist = Fcdr (Vselection_alist);
277   else
278     {
279       for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
280         if (EQ (selection_data, Fcar (Fcdr (rest))))
281           Fsetcdr (rest, Fcdr (Fcdr (rest)));
282     }
284   if (!EQ (Vns_lost_selection_hooks, Qunbound))
285     {
286       for (rest = Vns_lost_selection_hooks;CONSP (rest); rest = Fcdr (rest))
287         call1 (Fcar (rest), selection_name);
288     }
293 /* ==========================================================================
295     Functions used externally
297    ========================================================================== */
300 Lisp_Object
301 ns_string_from_pasteboard (id pb)
303   NSString *type, *str;
304   const char *utfStr;
306   type = [pb availableTypeFromArray: ns_return_types];
307   if (type == nil)
308     {
309       Fsignal (Qquit,
310               Fcons (build_string ("empty or unsupported pasteboard type"),
311                     Qnil));
312     return Qnil;
313     }
315   /* get the string */
316   if (! (str = [pb stringForType: type]))
317     {
318       NSData *data = [pb dataForType: type];
319       if (data != nil)
320         str = [[NSString alloc] initWithData: data
321                                     encoding: NSUTF8StringEncoding];
322       if (str != nil)
323         {
324           [str autorelease];
325         }
326       else
327         {
328           Fsignal (Qquit,
329                   Fcons (build_string ("pasteboard doesn't contain valid data"),
330                         Qnil));
331           return Qnil;
332         }
333     }
335   /* assume UTF8 */
336   NS_DURING
337     {
338       /* EOL conversion: PENDING- is this too simple? */
339       NSMutableString *mstr = [[str mutableCopy] autorelease];
340       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
341             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
342       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
343             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
345       utfStr = [mstr UTF8String];
346       if (!utfStr)
347         utfStr = [mstr cString];
348     }
349   NS_HANDLER
350     {
351       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
352       utfStr = [str lossyCString];
353     }
354   NS_ENDHANDLER
356   return build_string (utfStr);
360 void
361 ns_string_to_pasteboard (id pb, Lisp_Object str)
363   ns_string_to_pasteboard_internal (pb, str, nil);
368 /* ==========================================================================
370     Lisp Defuns
372    ========================================================================== */
375 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
376        Sx_own_selection_internal, 2, 2, 0,
377        doc: /* Assert a selection.
378 SELECTION-NAME is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
379 VALUE is typically a string, or a cons of two markers, but may be
380 anything that the functions on `selection-converter-alist' know about.  */)
381      (selection_name, selection_value)
382      Lisp_Object selection_name, selection_value;
384   id pb;
385   Lisp_Object old_value, new_value;
387   check_ns ();
388   CHECK_SYMBOL (selection_name);
389   if (NILP (selection_value))
390       error ("selection-value may not be nil.");
391   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
392   ns_declare_pasteboard (pb);
393   old_value = assq_no_quit (selection_name, Vselection_alist);
394   new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
395   if (NILP (old_value))
396     Vselection_alist = Fcons (new_value, Vselection_alist);
397   else
398     Fsetcdr (old_value, Fcdr (new_value));
399   /* XXX An evil hack, but a necessary one I fear XXX */
400   {
401     struct input_event ev;
402     ev.kind = SELECTION_REQUEST_EVENT;
403     ev.modifiers = 0;
404     ev.code = 0;
405     *(EMACS_INT*)(&(ev.x)) = (EMACS_INT)pb; // FIXME: BIG UGLY HACK!!
406     *(EMACS_INT*)(&(ev.y)) = (EMACS_INT)NSStringPboardType;
407     ns_handle_selection_request (&ev);
408   }
409   return selection_value;
413 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
414        Sx_disown_selection_internal, 1, 2, 0,
415        doc: /* If we own the selection SELECTION, disown it.  */)
416      (selection_name, time)
417      Lisp_Object selection_name, time;
419   id pb;
420   check_ns ();
421   CHECK_SYMBOL (selection_name);
422   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
424   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
425   ns_undeclare_pasteboard (pb);
426   return Qt;
430 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
431        0, 1, 0, doc: /* Whether there is an owner for the given selection.
432 The arg should be the name of the selection in question, typically one of
433 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
434 \(Those are literal upper-case symbol names.)
435 For convenience, the symbol nil is the same as `PRIMARY',
436 and t is the same as `SECONDARY'.)  */)
437      (selection)
438      Lisp_Object selection;
440   id pb;
441   NSArray *types;
443   check_ns ();
444   CHECK_SYMBOL (selection);
445   if (EQ (selection, Qnil)) selection = QPRIMARY;
446   if (EQ (selection, Qt)) selection = QSECONDARY;
447   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
448   types =[pb types];
449   return ([types count] == 0) ? Qnil : Qt;
453 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
454        0, 1, 0,
455        doc: /* Whether the current Emacs process owns the given selection.
456 The arg should be the name of the selection in question, typically one of
457 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
458 \(Those are literal upper-case symbol names.)
459 For convenience, the symbol nil is the same as `PRIMARY',
460 and t is the same as `SECONDARY'.)  */)
461      (selection)
462      Lisp_Object selection;
464   check_ns ();
465   CHECK_SYMBOL (selection);
466   if (EQ (selection, Qnil)) selection = QPRIMARY;
467   if (EQ (selection, Qt)) selection = QSECONDARY;
468   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
472 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
473        Sx_get_selection_internal, 2, 2, 0,
474        doc: /* Return text selected from some pasteboard.
475 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
476 \(Those are literal upper-case symbol names.)
477 TYPE is the type of data desired, typically `STRING'.  */)
478      (selection_name, target_type)
479      Lisp_Object selection_name, target_type;
481   Lisp_Object val;
483   check_ns ();
484   CHECK_SYMBOL (selection_name);
485   CHECK_SYMBOL (target_type);
486   val = ns_get_local_selection (selection_name, target_type);
487   if (NILP (val))
488     val = ns_get_foreign_selection (selection_name, target_type);
489   if (CONSP (val) && SYMBOLP (Fcar (val)))
490     {
491       val = Fcdr (val);
492       if (CONSP (val) && NILP (Fcdr (val)))
493         val = Fcar (val);
494     }
495   val = clean_local_selection_data (val);
496   return val;
500 #ifdef CUT_BUFFER_SUPPORT
501 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
502        Sns_get_cut_buffer_internal, 1, 1, 0,
503        doc: /* Returns the value of the named cut buffer.  */)
504      (buffer)
505      Lisp_Object buffer;
507   id pb;
508   check_ns ();
509   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
510   return ns_string_from_pasteboard (pb);
514 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
515        Sns_rotate_cut_buffers_internal, 1, 1, 0,
516        doc: /* Rotate the values of the cut buffers by N steps.
517 Positive N means move values forward, negative means
518 backward. CURRENTLY NOT IMPLEMENTED UNDER NEXTSTEP. */ )
519      (n)
520      Lisp_Object n;
522   /* XXX This function is unimplemented under NeXTstep XXX */
523   Fsignal (Qquit, Fcons (build_string (
524       "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
525   return Qnil;
529 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
530        Sns_store_cut_buffer_internal, 2, 2, 0,
531        doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0).  */)
532      (buffer, string)
533      Lisp_Object buffer, string;
535   id pb;
536   check_ns ();
537   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
538   ns_string_to_pasteboard (pb, string);
539   return Qnil;
541 #endif
544 void
545 nxatoms_of_nsselect (void)
547   NXSecondaryPboard = @"Selection";
550 void
551 syms_of_nsselect (void)
553   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
554   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
555   QTEXT      = intern ("TEXT");         staticpro (&QTEXT);
556   QFILE_NAME = intern ("FILE_NAME");    staticpro (&QFILE_NAME);
558   defsubr (&Sx_disown_selection_internal);
559   defsubr (&Sx_get_selection_internal);
560   defsubr (&Sx_own_selection_internal);
561   defsubr (&Sx_selection_exists_p);
562   defsubr (&Sx_selection_owner_p);
563 #ifdef CUT_BUFFER_SUPPORT
564   defsubr (&Sns_get_cut_buffer_internal);
565   defsubr (&Sns_rotate_cut_buffers_internal);
566   defsubr (&Sns_store_cut_buffer_internal);
567 #endif
569   Vselection_alist = Qnil;
570   staticpro (&Vselection_alist);
572   DEFVAR_LISP ("ns-sent-selection-hooks", &Vns_sent_selection_hooks,
573                "A list of functions to be called when Emacs answers a selection request.\n\
574 The functions are called with four arguments:\n\
575   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
576   - the selection-type which Emacs was asked to convert the\n\
577     selection into before sending (for example, `STRING' or `LENGTH');\n\
578   - a flag indicating success or failure for responding to the request.\n\
579 We might have failed (and declined the request) for any number of reasons,\n\
580 including being asked for a selection that we no longer own, or being asked\n\
581 to convert into a type that we don't know about or that is inappropriate.\n\
582 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
583 it merely informs you that they have happened.");
584   Vns_sent_selection_hooks = Qnil;
586   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
587                "An alist associating X Windows selection-types with functions.\n\
588 These functions are called to convert the selection, with three args:\n\
589 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
590 a desired type to which the selection should be converted;\n\
591 and the local selection value (whatever was given to `x-own-selection').\n\
593 The function should return the value to send to the X server\n\
594 \(typically a string).  A return value of nil\n\
595 means that the conversion could not be done.\n\
596 A return value which is the symbol `NULL'\n\
597 means that a side-effect was executed,\n\
598 and there is no meaningful selection value.");
599   Vselection_converter_alist = Qnil;
601   DEFVAR_LISP ("ns-lost-selection-hooks", &Vns_lost_selection_hooks,
602                "A list of functions to be called when Emacs loses an X selection.\n\
603 \(This happens when some other X client makes its own selection\n\
604 or when a Lisp program explicitly clears the selection.)\n\
605 The functions are called with one argument, the selection type\n\
606 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
607   Vns_lost_selection_hooks = Qnil;
609   Qforeign_selection = intern ("foreign-selection");
610   staticpro (&Qforeign_selection);
613 // arch-tag: 39d1dde7-06a6-49ff-95a7-0e7af12d2218