src/nsselect.m

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