src/nsselect.m

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