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