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