src/nsselect.m

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