src/nsselect.m

   1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
   2    Copyright (C) 1993, 1994, 2005, 2006, 2008, 2009, 2010
   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 Vns_sent_selection_hooks;
  43 static Lisp_Object Vns_lost_selection_hooks;
  44 static Lisp_Object Vselection_alist;
  45 static Lisp_Object Vselection_converter_alist;
  46
  47 static Lisp_Object Qforeign_selection;
  48
  49 /* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */
  50 NSString *NXPrimaryPboard;
  51 NSString *NXSecondaryPboard;
  52
  53
  54
  55 /* ==========================================================================
  56
  57     Internal utility functions
  58
  59    ========================================================================== */
  60
  61
  62 static NSString *
  63 symbol_to_nsstring (Lisp_Object sym)
  64 {
  65   CHECK_SYMBOL (sym);
  66   if (EQ (sym, QCLIPBOARD))     return NSGeneralPboard;
  67   if (EQ (sym, QPRIMARY))     return NXPrimaryPboard;
  68   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
  69   if (EQ (sym, QTEXT))        return NSStringPboardType;
  70   return [NSString stringWithUTF8String: SDATA (XSYMBOL (sym)->xname)];
  71 }
  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 stringWithUTF8String: utfStr];
 162
 163       if (gtype == nil)
 164         {
 165           [pb declareTypes: ns_send_types owner: nil];
 166           tenum = [ns_send_types objectEnumerator];
 167           while ( (type = [tenum nextObject]) )
 168             [pb setString: nsStr forType: type];
 169         }
 170       else
 171         {
 172           [pb setString: nsStr forType: gtype];
 173         }
 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
 312   type = [pb availableTypeFromArray: ns_return_types];
 313   if (type == nil)
 314     {
 315       Fsignal (Qquit,
 316               Fcons (build_string ("empty or unsupported pasteboard type"),
 317                     Qnil));
 318     return Qnil;
 319     }
 320
 321   /* get the string */
 322   if (! (str = [pb stringForType: type]))
 323     {
 324       NSData *data = [pb dataForType: type];
 325       if (data != nil)
 326         str = [[NSString alloc] initWithData: data
 327                                     encoding: NSUTF8StringEncoding];
 328       if (str != nil)
 329         {
 330           [str autorelease];
 331         }
 332       else
 333         {
 334           Fsignal (Qquit,
 335                   Fcons (build_string ("pasteboard doesn't contain valid data"),
 336                         Qnil));
 337           return Qnil;
 338         }
 339     }
 340
 341   /* assume UTF8 */
 342   NS_DURING
 343     {
 344       /* EOL conversion: PENDING- is this too simple? */
 345       NSMutableString *mstr = [[str mutableCopy] autorelease];
 346       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
 347             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 348       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
 349             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 350
 351       utfStr = [mstr UTF8String];
 352       if (!utfStr)
 353         utfStr = [mstr cString];
 354     }
 355   NS_HANDLER
 356     {
 357       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
 358       utfStr = [str lossyCString];
 359     }
 360   NS_ENDHANDLER
 361
 362   return build_string (utfStr);
 363 }
 364
 365
 366 void
 367 ns_string_to_pasteboard (id pb, Lisp_Object str)
 368 {
 369   ns_string_to_pasteboard_internal (pb, str, nil);
 370 }
 371
 372
 373
 374 /* ==========================================================================
 375
 376     Lisp Defuns
 377
 378    ========================================================================== */
 379
 380
 381 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
 382        Sx_own_selection_internal, 2, 2, 0,
 383        doc: /* Assert a selection.
 384 SELECTION-NAME is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 385 VALUE is typically a string, or a cons of two markers, but may be
 386 anything that the functions on `selection-converter-alist' know about.  */)
 387      (Lisp_Object selection_name, Lisp_Object selection_value)
 388 {
 389   id pb;
 390   Lisp_Object old_value, new_value;
 391
 392   check_ns ();
 393   CHECK_SYMBOL (selection_name);
 394   if (NILP (selection_value))
 395       error ("selection-value may not be nil.");
 396   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 397   ns_declare_pasteboard (pb);
 398   old_value = assq_no_quit (selection_name, Vselection_alist);
 399   new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
 400   if (NILP (old_value))
 401     Vselection_alist = Fcons (new_value, Vselection_alist);
 402   else
 403     Fsetcdr (old_value, Fcdr (new_value));
 404   /* XXX An evil hack, but a necessary one I fear XXX */
 405   {
 406     struct input_event ev;
 407     ev.kind = SELECTION_REQUEST_EVENT;
 408     ev.modifiers = 0;
 409     ev.code = 0;
 410     *(EMACS_INT*)(&(ev.x)) = (EMACS_INT)pb; // FIXME: BIG UGLY HACK!!
 411     *(EMACS_INT*)(&(ev.y)) = (EMACS_INT)NSStringPboardType;
 412     ns_handle_selection_request (&ev);
 413   }
 414   return selection_value;
 415 }
 416
 417
 418 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
 419        Sx_disown_selection_internal, 1, 2, 0,
 420        doc: /* If we own the selection SELECTION, disown it.  */)
 421      (Lisp_Object selection_name, Lisp_Object time)
 422 {
 423   id pb;
 424   check_ns ();
 425   CHECK_SYMBOL (selection_name);
 426   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
 427
 428   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 429   ns_undeclare_pasteboard (pb);
 430   return Qt;
 431 }
 432
 433
 434 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 435        0, 1, 0, doc: /* Whether there is an owner for the given selection.
 436 The arg should be the name of the selection in question, typically one of
 437 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 438 \(Those are literal upper-case symbol names.)
 439 For convenience, the symbol nil is the same as `PRIMARY',
 440 and t is the same as `SECONDARY'.)  */)
 441      (Lisp_Object selection)
 442 {
 443   id pb;
 444   NSArray *types;
 445
 446   check_ns ();
 447   CHECK_SYMBOL (selection);
 448   if (EQ (selection, Qnil)) selection = QPRIMARY;
 449   if (EQ (selection, Qt)) selection = QSECONDARY;
 450   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
 451   types =[pb types];
 452   return ([types count] == 0) ? Qnil : Qt;
 453 }
 454
 455
 456 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
 457        0, 1, 0,
 458        doc: /* Whether the current Emacs process owns the given selection.
 459 The arg should be the name of the selection in question, typically one of
 460 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 461 \(Those are literal upper-case symbol names.)
 462 For convenience, the symbol nil is the same as `PRIMARY',
 463 and t is the same as `SECONDARY'.)  */)
 464      (Lisp_Object selection)
 465 {
 466   check_ns ();
 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, 2, 0,
 476        doc: /* Return text selected from some pasteboard.
 477 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 478 \(Those are literal upper-case symbol names.)
 479 TYPE is the type of data desired, typically `STRING'.  */)
 480      (Lisp_Object selection_name, Lisp_Object target_type)
 481 {
 482   Lisp_Object val;
 483
 484   check_ns ();
 485   CHECK_SYMBOL (selection_name);
 486   CHECK_SYMBOL (target_type);
 487   val = ns_get_local_selection (selection_name, target_type);
 488   if (NILP (val))
 489     val = ns_get_foreign_selection (selection_name, target_type);
 490   if (CONSP (val) && SYMBOLP (Fcar (val)))
 491     {
 492       val = Fcdr (val);
 493       if (CONSP (val) && NILP (Fcdr (val)))
 494         val = Fcar (val);
 495     }
 496   val = clean_local_selection_data (val);
 497   return val;
 498 }
 499
 500
 501 #ifdef CUT_BUFFER_SUPPORT
 502 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
 503        Sns_get_cut_buffer_internal, 1, 1, 0,
 504        doc: /* Returns the value of the named cut buffer.  */)
 505      (Lisp_Object buffer)
 506 {
 507   id pb;
 508   check_ns ();
 509   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 510   return ns_string_from_pasteboard (pb);
 511 }
 512
 513
 514 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
 515        Sns_rotate_cut_buffers_internal, 1, 1, 0,
 516        doc: /* Rotate the values of the cut buffers by N steps.
 517 Positive N means move values forward, negative means
 518 backward. CURRENTLY NOT IMPLEMENTED UNDER NEXTSTEP. */ )
 519      (Lisp_Object n)
 520 {
 521   /* XXX This function is unimplemented under NeXTstep XXX */
 522   Fsignal (Qquit, Fcons (build_string (
 523       "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
 524   return Qnil;
 525 }
 526
 527
 528 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
 529        Sns_store_cut_buffer_internal, 2, 2, 0,
 530        doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0).  */)
 531      (Lisp_Object buffer, Lisp_Object string)
 532 {
 533   id pb;
 534   check_ns ();
 535   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 536   ns_string_to_pasteboard (pb, string);
 537   return Qnil;
 538 }
 539 #endif
 540
 541
 542 void
 543 nxatoms_of_nsselect (void)
 544 {
 545   NXPrimaryPboard = @"Selection";
 546   NXSecondaryPboard = @"Secondary";
 547 }
 548
 549 void
 550 syms_of_nsselect (void)
 551 {
 552   QCLIPBOARD = intern ("CLIPBOARD");    staticpro (&QCLIPBOARD);
 553   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
 554   QTEXT      = intern ("TEXT");         staticpro (&QTEXT);
 555   QFILE_NAME = intern ("FILE_NAME");    staticpro (&QFILE_NAME);
 556
 557   defsubr (&Sx_disown_selection_internal);
 558   defsubr (&Sx_get_selection_internal);
 559   defsubr (&Sx_own_selection_internal);
 560   defsubr (&Sx_selection_exists_p);
 561   defsubr (&Sx_selection_owner_p);
 562 #ifdef CUT_BUFFER_SUPPORT
 563   defsubr (&Sns_get_cut_buffer_internal);
 564   defsubr (&Sns_rotate_cut_buffers_internal);
 565   defsubr (&Sns_store_cut_buffer_internal);
 566 #endif
 567
 568   Vselection_alist = Qnil;
 569   staticpro (&Vselection_alist);
 570
 571   DEFVAR_LISP ("ns-sent-selection-hooks", &Vns_sent_selection_hooks,
 572                "A list of functions to be called when Emacs answers a selection request.\n\
 573 The functions are called with four arguments:\n\
 574   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 575   - the selection-type which Emacs was asked to convert the\n\
 576     selection into before sending (for example, `STRING' or `LENGTH');\n\
 577   - a flag indicating success or failure for responding to the request.\n\
 578 We might have failed (and declined the request) for any number of reasons,\n\
 579 including being asked for a selection that we no longer own, or being asked\n\
 580 to convert into a type that we don't know about or that is inappropriate.\n\
 581 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 582 it merely informs you that they have happened.");
 583   Vns_sent_selection_hooks = Qnil;
 584
 585   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
 586                "An alist associating X Windows selection-types with functions.\n\
 587 These functions are called to convert the selection, with three args:\n\
 588 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 589 a desired type to which the selection should be converted;\n\
 590 and the local selection value (whatever was given to `x-own-selection').\n\
 591 \n\
 592 The function should return the value to send to the X server\n\
 593 \(typically a string).  A return value of nil\n\
 594 means that the conversion could not be done.\n\
 595 A return value which is the symbol `NULL'\n\
 596 means that a side-effect was executed,\n\
 597 and there is no meaningful selection value.");
 598   Vselection_converter_alist = Qnil;
 599
 600   DEFVAR_LISP ("ns-lost-selection-hooks", &Vns_lost_selection_hooks,
 601                "A list of functions to be called when Emacs loses an X selection.\n\
 602 \(This happens when some other X client makes its own selection\n\
 603 or when a Lisp program explicitly clears the selection.)\n\
 604 The functions are called with one argument, the selection type\n\
 605 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 606   Vns_lost_selection_hooks = Qnil;
 607
 608   Qforeign_selection = intern ("foreign-selection");
 609   staticpro (&Qforeign_selection);
 610 }
 611
 612 // arch-tag: 39d1dde7-06a6-49ff-95a7-0e7af12d2218