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 ("x-own-selection-internal", Fx_own_selection_internal,
 332        Sx_own_selection_internal, 2, 3, 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
 339 FRAME should be a frame that should own the selection.  If omitted or
 340 nil, it defaults to the selected frame.
 341
 342 On Nextstep, FRAME is unused.  */)
 343      (Lisp_Object selection, Lisp_Object value, Lisp_Object frame)
 344 {
 345   id pb;
 346   Lisp_Object old_value, new_value;
 347   NSString *type;
 348   Lisp_Object successful_p = Qnil, rest;
 349   Lisp_Object target_symbol, data;
 350
 351   check_window_system (NULL);
 352   CHECK_SYMBOL (selection);
 353   if (NILP (value))
 354     error ("Selection value may not be nil");
 355   pb = ns_symbol_to_pb (selection);
 356   if (pb == nil) return Qnil;
 357
 358   ns_declare_pasteboard (pb);
 359   old_value = assq_no_quit (selection, Vselection_alist);
 360   new_value = list2 (selection, value);
 361
 362   if (NILP (old_value))
 363     Vselection_alist = Fcons (new_value, Vselection_alist);
 364   else
 365     Fsetcdr (old_value, Fcdr (new_value));
 366
 367   /* We only support copy of text.  */
 368   type = NSStringPboardType;
 369   target_symbol = ns_string_to_symbol (type);
 370   data = ns_get_local_selection (selection, target_symbol);
 371   if (!NILP (data))
 372     {
 373       if (STRINGP (data))
 374         ns_string_to_pasteboard_internal (pb, data, type);
 375       successful_p = Qt;
 376     }
 377
 378   if (!EQ (Vns_sent_selection_hooks, Qunbound))
 379     {
 380       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
 381         call3 (Fcar (rest), selection, target_symbol, successful_p);
 382     }
 383
 384   return value;
 385 }
 386
 387
 388 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
 389        Sx_disown_selection_internal, 1, 3, 0,
 390        doc: /* If we own the selection SELECTION, disown it.
 391 Disowning it means there is no such selection.
 392
 393 Sets the last-change time for the selection to TIME-OBJECT (by default
 394 the time of the last event).
 395
 396 TERMINAL should be a terminal object or a frame specifying the X
 397 server to query.  If omitted or nil, that stands for the selected
 398 frame's display, or the first available X display.
 399
 400 On Nextstep, the TIME-OBJECT and TERMINAL arguments are unused.
 401 On MS-DOS, all this does is return non-nil if we own the selection.  */)
 402   (Lisp_Object selection, Lisp_Object time_object, Lisp_Object terminal)
 403 {
 404   id pb;
 405   check_window_system (NULL);
 406   CHECK_SYMBOL (selection);
 407   if (NILP (assq_no_quit (selection, Vselection_alist))) return Qnil;
 408
 409   pb = ns_symbol_to_pb (selection);
 410   if (pb != nil) ns_undeclare_pasteboard (pb);
 411   return Qt;
 412 }
 413
 414
 415 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 416        0, 2, 0, doc: /* Whether there is an owner for the given X selection.
 417 SELECTION should be the name of the selection in question, typically
 418 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  (X expects
 419 these literal upper-case names.)  The symbol nil is the same as
 420 `PRIMARY', and t is the same as `SECONDARY'.
 421
 422 TERMINAL should be a terminal object or a frame specifying the X
 423 server to query.  If omitted or nil, that stands for the selected
 424 frame's display, or the first available X display.
 425
 426 On Nextstep, TERMINAL is unused.  */)
 427      (Lisp_Object selection, Lisp_Object terminal)
 428 {
 429   id pb;
 430   NSArray *types;
 431
 432   if (!window_system_available (NULL))
 433     return Qnil;
 434
 435   CHECK_SYMBOL (selection);
 436   if (EQ (selection, Qnil)) selection = QPRIMARY;
 437   if (EQ (selection, Qt)) selection = QSECONDARY;
 438   pb = ns_symbol_to_pb (selection);
 439   if (pb == nil) return Qnil;
 440
 441   types = [pb types];
 442   return ([types count] == 0) ? Qnil : Qt;
 443 }
 444
 445
 446 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
 447        0, 2, 0,
 448        doc: /* Whether the current Emacs process owns the given X 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, since that's what X expects.)
 452 For convenience, the symbol nil is the same as `PRIMARY',
 453 and t is the same as `SECONDARY'.
 454
 455 TERMINAL should be a terminal object or a frame specifying the X
 456 server to query.  If omitted or nil, that stands for the selected
 457 frame's display, or the first available X display.
 458
 459 On Nextstep, TERMINAL is unused.  */)
 460      (Lisp_Object selection, Lisp_Object terminal)
 461 {
 462   check_window_system (NULL);
 463   CHECK_SYMBOL (selection);
 464   if (EQ (selection, Qnil)) selection = QPRIMARY;
 465   if (EQ (selection, Qt)) selection = QSECONDARY;
 466   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
 467 }
 468
 469
 470 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
 471        Sx_get_selection_internal, 2, 4, 0,
 472        doc: /* Return text selected from some X window.
 473 SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 474 \(Those are literal upper-case symbol names, since that's what X expects.)
 475 TARGET-TYPE is the type of data desired, typically `STRING'.
 476
 477 TIME-STAMP is the time to use in the XConvertSelection call for foreign
 478 selections.  If omitted, defaults to the time for the last event.
 479
 480 TERMINAL should be a terminal object or a frame specifying the X
 481 server to query.  If omitted or nil, that stands for the selected
 482 frame's display, or the first available X display.
 483
 484 On Nextstep, TIME-STAMP and TERMINAL are unused.  */)
 485      (Lisp_Object selection_name, Lisp_Object target_type,
 486       Lisp_Object time_stamp, Lisp_Object terminal)
 487 {
 488   Lisp_Object val;
 489
 490   check_window_system (NULL);
 491   CHECK_SYMBOL (selection_name);
 492   CHECK_SYMBOL (target_type);
 493   val = ns_get_local_selection (selection_name, target_type);
 494   if (NILP (val))
 495     val = ns_get_foreign_selection (selection_name, target_type);
 496   if (CONSP (val) && SYMBOLP (Fcar (val)))
 497     {
 498       val = Fcdr (val);
 499       if (CONSP (val) && NILP (Fcdr (val)))
 500         val = Fcar (val);
 501     }
 502   val = clean_local_selection_data (val);
 503   return val;
 504 }
 505
 506
 507 DEFUN ("ns-get-selection-internal", Fns_get_selection_internal,
 508        Sns_get_selection_internal, 1, 1, 0,
 509        doc: /* Returns the value of SELECTION as a string.
 510 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. */)
 511      (Lisp_Object selection)
 512 {
 513   id pb;
 514   check_window_system (NULL);
 515   pb = ns_symbol_to_pb (selection);
 516   return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
 517 }
 518
 519
 520 DEFUN ("ns-store-selection-internal", Fns_store_selection_internal,
 521        Sns_store_selection_internal, 2, 2, 0,
 522        doc: /* Sets the string value of SELECTION.
 523 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'. */)
 524      (Lisp_Object selection, Lisp_Object string)
 525 {
 526   id pb;
 527   check_window_system (NULL);
 528   pb = ns_symbol_to_pb (selection);
 529   if (pb != nil) ns_string_to_pasteboard (pb, string);
 530   return Qnil;
 531 }
 532
 533
 534 void
 535 nxatoms_of_nsselect (void)
 536 {
 537   NXPrimaryPboard = @"Selection";
 538   NXSecondaryPboard = @"Secondary";
 539 }
 540
 541 void
 542 syms_of_nsselect (void)
 543 {
 544   QCLIPBOARD = intern_c_string ("CLIPBOARD");   staticpro (&QCLIPBOARD);
 545   QSECONDARY = intern_c_string ("SECONDARY");   staticpro (&QSECONDARY);
 546   QTEXT      = intern_c_string ("TEXT");        staticpro (&QTEXT);
 547   QFILE_NAME = intern_c_string ("FILE_NAME");   staticpro (&QFILE_NAME);
 548
 549   defsubr (&Sx_disown_selection_internal);
 550   defsubr (&Sx_get_selection_internal);
 551   defsubr (&Sx_own_selection_internal);
 552   defsubr (&Sx_selection_exists_p);
 553   defsubr (&Sx_selection_owner_p);
 554   defsubr (&Sns_get_selection_internal);
 555   defsubr (&Sns_store_selection_internal);
 556
 557   Vselection_alist = Qnil;
 558   staticpro (&Vselection_alist);
 559
 560   DEFVAR_LISP ("ns-sent-selection-hooks", Vns_sent_selection_hooks,
 561                "A list of functions to be called when Emacs answers a selection request.\n\
 562 The functions are called with four arguments:\n\
 563   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 564   - the selection-type which Emacs was asked to convert the\n\
 565     selection into before sending (for example, `STRING' or `LENGTH');\n\
 566   - a flag indicating success or failure for responding to the request.\n\
 567 We might have failed (and declined the request) for any number of reasons,\n\
 568 including being asked for a selection that we no longer own, or being asked\n\
 569 to convert into a type that we don't know about or that is inappropriate.\n\
 570 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 571 it merely informs you that they have happened.");
 572   Vns_sent_selection_hooks = Qnil;
 573
 574   DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist,
 575                "An alist associating X Windows selection-types with functions.\n\
 576 These functions are called to convert the selection, with three args:\n\
 577 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 578 a desired type to which the selection should be converted;\n\
 579 and the local selection value (whatever was given to `x-own-selection').\n\
 580 \n\
 581 The function should return the value to send to the X server\n\
 582 \(typically a string).  A return value of nil\n\
 583 means that the conversion could not be done.\n\
 584 A return value which is the symbol `NULL'\n\
 585 means that a side-effect was executed,\n\
 586 and there is no meaningful selection value.");
 587   Vselection_converter_alist = Qnil;
 588
 589   DEFVAR_LISP ("ns-lost-selection-hooks", Vns_lost_selection_hooks,
 590                "A list of functions to be called when Emacs loses an X selection.\n\
 591 \(This happens when some other X client makes its own selection\n\
 592 or when a Lisp program explicitly clears the selection.)\n\
 593 The functions are called with one argument, the selection type\n\
 594 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 595   Vns_lost_selection_hooks = Qnil;
 596
 597   Qforeign_selection = intern_c_string ("foreign-selection");
 598   staticpro (&Qforeign_selection);
 599 }