src/nsselect.m

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