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