src/nsselect.m

   1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
   2    Copyright (C) 1993-1994, 2005-2006, 2008-2014 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, 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       check = XCDR (value);
 207     }
 208
 209   if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
 210       || INTEGERP (check) || NILP (value))
 211     return value;
 212
 213   if (CONSP (check)
 214       && INTEGERP (XCAR (check))
 215       && (INTEGERP (XCDR (check))||
 216           (CONSP (XCDR (check))
 217            && INTEGERP (XCAR (XCDR (check)))
 218            && NILP (XCDR (XCDR (check))))))
 219     return value;
 220
 221   // FIXME: Why `quit' rather than `error'?
 222   Fsignal (Qquit,
 223            list3 (build_string ("invalid data returned by"
 224                                 " selection-conversion function"),
 225                   handler_fn, value));
 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       return Qnil;
 260     }
 261
 262   /* get the string */
 263   if (! (str = [pb stringForType: type]))
 264     {
 265       NSData *data = [pb dataForType: type];
 266       if (data != nil)
 267         str = [[NSString alloc] initWithData: data
 268                                     encoding: NSUTF8StringEncoding];
 269       if (str != nil)
 270         {
 271           [str autorelease];
 272         }
 273       else
 274         {
 275           return Qnil;
 276         }
 277     }
 278
 279   /* assume UTF8 */
 280   NS_DURING
 281     {
 282       /* EOL conversion: PENDING- is this too simple? */
 283       NSMutableString *mstr = [[str mutableCopy] autorelease];
 284       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
 285             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 286       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
 287             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 288
 289       utfStr = [mstr UTF8String];
 290       length = [mstr lengthOfBytesUsingEncoding: NSUTF8StringEncoding];
 291
 292 #if ! defined (NS_IMPL_COCOA)
 293       if (!utfStr)
 294         {
 295           utfStr = [mstr cString];
 296           length = strlen (utfStr);
 297         }
 298 #endif
 299     }
 300   NS_HANDLER
 301     {
 302       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
 303 #if defined (NS_IMPL_COCOA)
 304       utfStr = "Conversion failed";
 305 #else
 306       utfStr = [str lossyCString];
 307 #endif
 308       length = strlen (utfStr);
 309     }
 310   NS_ENDHANDLER
 311
 312     return make_string (utfStr, length);
 313 }
 314
 315
 316 void
 317 ns_string_to_pasteboard (id pb, Lisp_Object str)
 318 {
 319   ns_string_to_pasteboard_internal (pb, str, nil);
 320 }
 321
 322
 323
 324 /* ==========================================================================
 325
 326     Lisp Defuns
 327
 328    ========================================================================== */
 329
 330
 331 DEFUN ("ns-own-selection-internal", Fns_own_selection_internal,
 332        Sns_own_selection_internal, 2, 2, 0,
 333        doc: /* Assert an X selection of type SELECTION and value VALUE.
 334 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 335 \(Those are literal upper-case symbol names, since that's what X expects.)
 336 VALUE is typically a string, or a cons of two markers, but may be
 337 anything that the functions on `selection-converter-alist' know about.  */)
 338      (Lisp_Object selection, Lisp_Object value)
 339 {
 340   id pb;
 341   Lisp_Object old_value, new_value;
 342   NSString *type;
 343   Lisp_Object successful_p = Qnil, rest;
 344   Lisp_Object target_symbol, data;
 345
 346   check_window_system (NULL);
 347   CHECK_SYMBOL (selection);
 348   if (NILP (value))
 349     error ("Selection value may not be nil");
 350   pb = ns_symbol_to_pb (selection);
 351   if (pb == nil) return Qnil;
 352
 353   ns_declare_pasteboard (pb);
 354   old_value = assq_no_quit (selection, Vselection_alist);
 355   new_value = list2 (selection, value);
 356
 357   if (NILP (old_value))
 358     Vselection_alist = Fcons (new_value, Vselection_alist);
 359   else
 360     Fsetcdr (old_value, Fcdr (new_value));
 361
 362   /* We only support copy of text.  */
 363   type = NSStringPboardType;
 364   target_symbol = ns_string_to_symbol (type);
 365   data = ns_get_local_selection (selection, target_symbol);
 366   if (!NILP (data))
 367     {
 368       if (STRINGP (data))
 369         ns_string_to_pasteboard_internal (pb, data, type);
 370       successful_p = Qt;
 371     }
 372
 373   if (!EQ (Vns_sent_selection_hooks, Qunbound))
 374     {
 375       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
 376         call3 (Fcar (rest), selection, target_symbol, successful_p);
 377     }
 378
 379   return value;
 380 }
 381
 382
 383 DEFUN ("ns-disown-selection-internal", Fns_disown_selection_internal,
 384        Sns_disown_selection_internal, 1, 1, 0,
 385        doc: /* If we own the selection SELECTION, disown it.
 386 Disowning it means there is no such selection.  */)
 387   (Lisp_Object selection)
 388 {
 389   id pb;
 390   check_window_system (NULL);
 391   CHECK_SYMBOL (selection);
 392   if (NILP (assq_no_quit (selection, Vselection_alist))) return Qnil;
 393
 394   pb = ns_symbol_to_pb (selection);
 395   if (pb != nil) ns_undeclare_pasteboard (pb);
 396   return Qt;
 397 }
 398
 399
 400 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 401        0, 2, 0, doc: /* Whether there is an owner for the given X selection.
 402 SELECTION should be the name of the selection in question, typically
 403 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  (X expects
 404 these literal upper-case names.)  The symbol nil is the same as
 405 `PRIMARY', and t is the same as `SECONDARY'.
 406
 407 TERMINAL should be a terminal object or a frame specifying the X
 408 server to query.  If omitted or nil, that stands for the selected
 409 frame's display, or the first available X display.
 410
 411 On Nextstep, TERMINAL is unused.  */)
 412      (Lisp_Object selection, Lisp_Object terminal)
 413 {
 414   id pb;
 415   NSArray *types;
 416
 417   if (!window_system_available (NULL))
 418     return Qnil;
 419
 420   CHECK_SYMBOL (selection);
 421   if (EQ (selection, Qnil)) selection = QPRIMARY;
 422   if (EQ (selection, Qt)) selection = QSECONDARY;
 423   pb = ns_symbol_to_pb (selection);
 424   if (pb == nil) return Qnil;
 425
 426   types = [pb types];
 427   return ([types count] == 0) ? Qnil : Qt;
 428 }
 429
 430
 431 DEFUN ("ns-selection-owner-p", Fns_selection_owner_p, Sns_selection_owner_p,
 432        0, 2, 0,
 433        doc: /* Whether the current Emacs process owns the given X Selection.
 434 The arg should be the name of the selection in question, typically one of
 435 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 436 \(Those are literal upper-case symbol names, since that's what X expects.)
 437 For convenience, the symbol nil is the same as `PRIMARY',
 438 and t is the same as `SECONDARY'.
 439
 440 TERMINAL should be a terminal object or a frame specifying the X
 441 server to query.  If omitted or nil, that stands for the selected
 442 frame's display, or the first available X display.
 443
 444 On Nextstep, TERMINAL is unused.  */)
 445      (Lisp_Object selection, Lisp_Object terminal)
 446 {
 447   check_window_system (NULL);
 448   CHECK_SYMBOL (selection);
 449   if (EQ (selection, Qnil)) selection = QPRIMARY;
 450   if (EQ (selection, Qt)) selection = QSECONDARY;
 451   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
 452 }
 453
 454
 455 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
 456        Sx_get_selection_internal, 2, 4, 0,
 457        doc: /* Return text selected from some X window.
 458 SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 459 \(Those are literal upper-case symbol names, since that's what X expects.)
 460 TARGET-TYPE is the type of data desired, typically `STRING'.
 461
 462 TIME-STAMP is the time to use in the XConvertSelection call for foreign
 463 selections.  If omitted, defaults to the time for the last event.
 464
 465 TERMINAL should be a terminal object or a frame specifying the X
 466 server to query.  If omitted or nil, that stands for the selected
 467 frame's display, or the first available X display.
 468
 469 On Nextstep, TIME-STAMP and TERMINAL are unused.  */)
 470      (Lisp_Object selection_name, Lisp_Object target_type,
 471       Lisp_Object time_stamp, Lisp_Object terminal)
 472 {
 473   Lisp_Object val;
 474
 475   check_window_system (NULL);
 476   CHECK_SYMBOL (selection_name);
 477   CHECK_SYMBOL (target_type);
 478   val = ns_get_local_selection (selection_name, target_type);
 479   if (NILP (val))
 480     val = ns_get_foreign_selection (selection_name, target_type);
 481   if (CONSP (val) && SYMBOLP (Fcar (val)))
 482     {
 483       val = Fcdr (val);
 484       if (CONSP (val) && NILP (Fcdr (val)))
 485         val = Fcar (val);
 486     }
 487   val = clean_local_selection_data (val);
 488   return val;
 489 }
 490
 491
 492 DEFUN ("ns-get-selection-internal", Fns_get_selection_internal,
 493        Sns_get_selection_internal, 1, 1, 0,
 494        doc: /* Returns the value of SELECTION as a string.
 495 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.  */)
 496      (Lisp_Object selection)
 497 {
 498   id pb;
 499   check_window_system (NULL);
 500   pb = ns_symbol_to_pb (selection);
 501   return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
 502 }
 503
 504
 505 DEFUN ("ns-store-selection-internal", Fns_store_selection_internal,
 506        Sns_store_selection_internal, 2, 2, 0,
 507        doc: /* Sets the string value of SELECTION.
 508 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.  */)
 509      (Lisp_Object selection, Lisp_Object string)
 510 {
 511   id pb;
 512   check_window_system (NULL);
 513   pb = ns_symbol_to_pb (selection);
 514   if (pb != nil) ns_string_to_pasteboard (pb, string);
 515   return Qnil;
 516 }
 517
 518
 519 void
 520 nxatoms_of_nsselect (void)
 521 {
 522   NXPrimaryPboard = @"Selection";
 523   NXSecondaryPboard = @"Secondary";
 524 }
 525
 526 void
 527 syms_of_nsselect (void)
 528 {
 529   QCLIPBOARD = intern_c_string ("CLIPBOARD");   staticpro (&QCLIPBOARD);
 530   QSECONDARY = intern_c_string ("SECONDARY");   staticpro (&QSECONDARY);
 531   QTEXT      = intern_c_string ("TEXT");        staticpro (&QTEXT);
 532   QFILE_NAME = intern_c_string ("FILE_NAME");   staticpro (&QFILE_NAME);
 533
 534   defsubr (&Sns_disown_selection_internal);
 535   defsubr (&Sx_get_selection_internal);
 536   defsubr (&Sns_own_selection_internal);
 537   defsubr (&Sx_selection_exists_p);
 538   defsubr (&Sns_selection_owner_p);
 539   defsubr (&Sns_get_selection_internal);
 540   defsubr (&Sns_store_selection_internal);
 541
 542   Vselection_alist = Qnil;
 543   staticpro (&Vselection_alist);
 544
 545   DEFVAR_LISP ("ns-sent-selection-hooks", Vns_sent_selection_hooks,
 546                "A list of functions to be called when Emacs answers a selection request.\n\
 547 The functions are called with four arguments:\n\
 548   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 549   - the selection-type which Emacs was asked to convert the\n\
 550     selection into before sending (for example, `STRING' or `LENGTH');\n\
 551   - a flag indicating success or failure for responding to the request.\n\
 552 We might have failed (and declined the request) for any number of reasons,\n\
 553 including being asked for a selection that we no longer own, or being asked\n\
 554 to convert into a type that we don't know about or that is inappropriate.\n\
 555 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 556 it merely informs you that they have happened.");
 557   Vns_sent_selection_hooks = Qnil;
 558
 559   DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
 560                "An alist associating X Windows selection-types with functions.\n\
 561 These functions are called to convert the selection, with three args:\n\
 562 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 563 a desired type to which the selection should be converted;\n\
 564 and the local selection value (whatever was given to `x-own-selection').\n\
 565 \n\
 566 The function should return the value to send to the X server\n\
 567 \(typically a string).  A return value of nil\n\
 568 means that the conversion could not be done.\n\
 569 A return value which is the symbol `NULL'\n\
 570 means that a side-effect was executed,\n\
 571 and there is no meaningful selection value.");
 572   Vselection_converter_alist = Qnil;
 573
 574   DEFVAR_LISP ("ns-lost-selection-hooks", Vns_lost_selection_hooks,
 575                "A list of functions to be called when Emacs loses an X selection.\n\
 576 \(This happens when some other X client makes its own selection\n\
 577 or when a Lisp program explicitly clears the selection.)\n\
 578 The functions are called with one argument, the selection type\n\
 579 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 580   Vns_lost_selection_hooks = Qnil;
 581
 582   Qforeign_selection = intern_c_string ("foreign-selection");
 583   staticpro (&Qforeign_selection);
 584 }