src/nsselect.m

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