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, or (at your option)
  10 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; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  20 Boston, MA 02110-1301, USA.
  21
  22 Originally by Carl Edman
  23 Updated by Christian Limpach (chris@nice.ch)
  24 OpenStep/Rhapsody port by Scott Bender (sbender@harmony-ds.com)
  25 MacOSX/Aqua port by Christophe de Dinechin (descubes@earthlink.net)
  26 GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu)
  27
  28 */
  29
  30 #include "config.h"
  31 #include "lisp.h"
  32 #include "nsterm.h"
  33 #include "termhooks.h"
  34
  35 #define CUT_BUFFER_SUPPORT
  36
  37 Lisp_Object QPRIMARY, QSECONDARY, QTEXT, QFILE_NAME;
  38
  39 static Lisp_Object Vns_sent_selection_hooks;
  40 static Lisp_Object Vns_lost_selection_hooks;
  41 static Lisp_Object Vselection_alist;
  42 static Lisp_Object Vselection_converter_alist;
  43
  44 /* 23: new */
  45 /* Coding system for communicating with other programs. */
  46 static Lisp_Object Vselection_coding_system;
  47 /* Coding system for the next communicating with other programs. */
  48 static Lisp_Object Vnext_selection_coding_system;
  49 static Lisp_Object Qforeign_selection;
  50
  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, QPRIMARY))     return NSGeneralPboard;
  67   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
  68   if (EQ (sym, QTEXT))        return NSStringPboardType;
  69   return [NSString stringWithUTF8String: XSTRING (XSYMBOL (sym)->xname)->data];
  70 }
  71
  72
  73 static Lisp_Object
  74 ns_string_to_symbol (NSString *t)
  75 {
  76   if ([t isEqualToString: NSGeneralPboard])
  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 = XVECTOR (obj)->size;
 114       Lisp_Object copy;
 115
 116       if (size == 1)
 117         return clean_local_selection_data (XVECTOR (obj)->contents [0]);
 118       copy = Fmake_vector (size, Qnil);
 119       for (i = 0; i < size; i++)
 120         XVECTOR (copy)->contents [i]
 121           = clean_local_selection_data (XVECTOR (obj)->contents [i]);
 122       return copy;
 123     }
 124
 125   return obj;
 126 }
 127
 128
 129 static void
 130 ns_declare_pasteboard (id pb)
 131 {
 132   [pb declareTypes: ns_send_types owner: NSApp];
 133 }
 134
 135
 136 static void
 137 ns_undeclare_pasteboard (id pb)
 138 {
 139   [pb declareTypes: [NSArray array] owner: nil];
 140 }
 141
 142
 143 static void
 144 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
 145 {
 146   if (EQ (str, Qnil))
 147     {
 148       [pb declareTypes: [NSArray array] owner: nil];
 149     }
 150   else
 151     {
 152       char *utfStr;
 153       NSString *type, *nsStr;
 154       NSEnumerator *tenum;
 155
 156       CHECK_STRING (str);
 157
 158       utfStr = XSTRING (str)->data;
 159       nsStr = [NSString stringWithUTF8String: utfStr];
 160
 161       if (gtype == nil)
 162         {
 163           [pb declareTypes: ns_send_types owner: nil];
 164           tenum = [ns_send_types objectEnumerator];
 165           while ( (type = [tenum nextObject]) )
 166             [pb setString: nsStr forType: type];
 167         }
 168       else
 169         {
 170           [pb setString: nsStr forType: gtype];
 171         }
 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   Fsignal (Qquit, Fcons (build_string (
 219       "invalid data returned by selection-conversion function"),
 220                         Fcons (handler_fn, Fcons (value, 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   id pb =(id)event->x;
 237   NSString *type =(NSString *)event->y;
 238   Lisp_Object selection_name, selection_data, target_symbol, data;
 239   Lisp_Object successful_p, rest;
 240
 241   selection_name =ns_string_to_symbol ([(NSPasteboard *)pb name]);
 242   target_symbol =ns_string_to_symbol (type);
 243   selection_data = assq_no_quit (selection_name, Vselection_alist);
 244   successful_p =Qnil;
 245
 246   if (!NILP (selection_data))
 247     {
 248       data = ns_get_local_selection (selection_name, target_symbol);
 249       if (!NILP (data))
 250         {
 251           if (STRINGP (data))
 252             ns_string_to_pasteboard_internal (pb, data, type);
 253           successful_p =Qt;
 254         }
 255     }
 256
 257   if (!EQ (Vns_sent_selection_hooks, Qunbound))
 258     {
 259       for (rest =Vns_sent_selection_hooks;CONSP (rest); rest =Fcdr (rest))
 260         call3 (Fcar (rest), selection_name, target_symbol, successful_p);
 261     }
 262 }
 263
 264
 265 static void
 266 ns_handle_selection_clear (struct input_event *event)
 267 {
 268   id pb = (id)event->x;
 269   Lisp_Object selection_name, selection_data, rest;
 270
 271   selection_name =ns_string_to_symbol ([(NSPasteboard *)pb name]);
 272   selection_data =assq_no_quit (selection_name, Vselection_alist);
 273   if (NILP (selection_data)) return;
 274
 275   if (EQ (selection_data, Fcar (Vselection_alist)))
 276     Vselection_alist = Fcdr (Vselection_alist);
 277   else
 278     {
 279       for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
 280         if (EQ (selection_data, Fcar (Fcdr (rest))))
 281           Fsetcdr (rest, Fcdr (Fcdr (rest)));
 282     }
 283
 284   if (!EQ (Vns_lost_selection_hooks, Qunbound))
 285     {
 286       for (rest =Vns_lost_selection_hooks;CONSP (rest); rest =Fcdr (rest))
 287         call1 (Fcar (rest), selection_name);
 288     }
 289 }
 290
 291
 292
 293 /* ==========================================================================
 294
 295     Functions used externally
 296
 297    ========================================================================== */
 298
 299
 300 Lisp_Object
 301 ns_string_from_pasteboard (id pb)
 302 {
 303   NSString *type, *str;
 304   const char *utfStr;
 305
 306   type = [pb availableTypeFromArray: ns_return_types];
 307   if (type == nil)
 308     {
 309       Fsignal (Qquit,
 310               Fcons (build_string ("empty or unsupported pasteboard type"),
 311                     Qnil));
 312     return Qnil;
 313     }
 314
 315   /* get the string */
 316   if (! (str = [pb stringForType: type]))
 317     {
 318       NSData *data = [pb dataForType: type];
 319       if (data != nil)
 320         str = [[NSString alloc] initWithData: data
 321                                     encoding: NSUTF8StringEncoding];
 322       if (str != nil)
 323         {
 324           [str autorelease];
 325         }
 326       else
 327         {
 328           Fsignal (Qquit,
 329                   Fcons (build_string ("pasteboard doesn't contain valid data"),
 330                         Qnil));
 331           return Qnil;
 332         }
 333     }
 334
 335   /* assume UTF8 */
 336   NS_DURING
 337     {
 338       /* EOL conversion: PENDING- is this too simple? */
 339       NSMutableString *mstr = [[str mutableCopy] autorelease];
 340       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
 341             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 342       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
 343             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 344
 345       utfStr = [mstr UTF8String];
 346       if (!utfStr)
 347         utfStr = [mstr cString];
 348     }
 349   NS_HANDLER
 350     {
 351       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
 352       utfStr = [str lossyCString];
 353     }
 354   NS_ENDHANDLER
 355
 356   return build_string (utfStr);
 357 }
 358
 359
 360 void
 361 ns_string_to_pasteboard (id pb, Lisp_Object str)
 362 {
 363   ns_string_to_pasteboard_internal (pb, str, nil);
 364 }
 365
 366
 367
 368 /* ==========================================================================
 369
 370     Lisp Defuns
 371
 372    ========================================================================== */
 373
 374
 375 DEFUN ("ns-own-selection-internal", Fns_own_selection_internal,
 376        Sns_own_selection_internal, 2, 2, 0, "Assert a selection.")
 377      (selection_name, selection_value)
 378      Lisp_Object selection_name, selection_value;
 379 {
 380   id pb;
 381   Lisp_Object old_value, new_value;
 382
 383   check_ns ();
 384   CHECK_SYMBOL (selection_name);
 385   if (NILP (selection_value))
 386       error ("selection-value may not be nil.");
 387   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 388   ns_declare_pasteboard (pb);
 389   old_value =assq_no_quit (selection_name, Vselection_alist);
 390   new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
 391   if (NILP (old_value))
 392     Vselection_alist =Fcons (new_value, Vselection_alist);
 393   else
 394     Fsetcdr (old_value, Fcdr (new_value));
 395   /* XXX An evil hack, but a necessary one I fear XXX */
 396   {
 397     struct input_event ev;
 398     ev.kind = SELECTION_REQUEST_EVENT;
 399     ev.modifiers = 0;
 400     ev.code = 0;
 401     ev.x = (int)pb;
 402     ev.y = (int)NSStringPboardType;
 403     ns_handle_selection_request (&ev);
 404   }
 405   return selection_value;
 406 }
 407
 408
 409 DEFUN ("ns-disown-selection-internal", Fns_disown_selection_internal,
 410        Sns_disown_selection_internal, 1, 2, 0,
 411        "If we own the selection SELECTION, disown it.")
 412      (selection_name, time)
 413      Lisp_Object selection_name, time;
 414 {
 415   id pb;
 416   check_ns ();
 417   CHECK_SYMBOL (selection_name);
 418   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
 419
 420   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 421   ns_undeclare_pasteboard (pb);
 422   return Qt;
 423 }
 424
 425
 426 DEFUN ("ns-selection-exists-p", Fns_selection_exists_p, Sns_selection_exists_p,
 427        0, 1, 0, "Whether there is an owner for the given selection.\n\
 428 The arg should be the name of the selection in question, typically one of\n\
 429 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
 430 \(Those are literal upper-case symbol names.)\n\
 431 For convenience, the symbol nil is the same as `PRIMARY',\n\
 432 and t is the same as `SECONDARY'.)")
 433      (selection)
 434      Lisp_Object selection;
 435 {
 436   id pb;
 437   NSArray *types;
 438
 439   check_ns ();
 440   CHECK_SYMBOL (selection);
 441   if (EQ (selection, Qnil)) selection = QPRIMARY;
 442   if (EQ (selection, Qt)) selection = QSECONDARY;
 443   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
 444   types =[pb types];
 445   return ([types count] == 0) ? Qnil : Qt;
 446 }
 447
 448
 449 DEFUN ("ns-selection-owner-p", Fns_selection_owner_p, Sns_selection_owner_p,
 450        0, 1, 0,
 451        "Whether the current Emacs process owns the given selection.\n\
 452 The arg should be the name of the selection in question, typically one of\n\
 453 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
 454 \(Those are literal upper-case symbol names.)\n\
 455 For convenience, the symbol nil is the same as `PRIMARY',\n\
 456 and t is the same as `SECONDARY'.)")
 457      (selection)
 458      Lisp_Object selection;
 459 {
 460   check_ns ();
 461   CHECK_SYMBOL (selection);
 462   if (EQ (selection, Qnil)) selection = QPRIMARY;
 463   if (EQ (selection, Qt)) selection = QSECONDARY;
 464   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
 465 }
 466
 467
 468 DEFUN ("ns-get-selection-internal", Fns_get_selection_internal,
 469        Sns_get_selection_internal, 2, 2, 0,
 470        "Return text selected from some pasteboard.\n\
 471 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.\n\
 472 \(Those are literal upper-case symbol names.)\n\
 473 TYPE is the type of data desired, typically `STRING'.")
 474      (selection_name, target_type)
 475      Lisp_Object selection_name, 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        "Returns the value of the named cut buffer.")
 500      (buffer)
 501      Lisp_Object buffer;
 502 {
 503   id pb;
 504   check_ns ();
 505   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 506   return ns_string_from_pasteboard (pb);
 507 }
 508
 509
 510 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
 511        Sns_rotate_cut_buffers_internal, 1, 1, 0,
 512        "Rotate the values of the cut buffers by the given number of steps;\n\
 513  positive means move values forward, negative means backward. CURRENTLY NOT IMPLEMENTED UNDER NeXTstep.")
 514      (n)
 515      Lisp_Object n;
 516 {
 517   /* XXX This function is unimplemented under NeXTstep XXX */
 518   Fsignal (Qquit, Fcons (build_string (
 519       "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
 520   return Qnil;
 521 }
 522
 523
 524 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
 525        Sns_store_cut_buffer_internal, 2, 2, 0,
 526        "Sets the value of the named cut buffer (typically CUT_BUFFER0).")
 527      (buffer, string)
 528      Lisp_Object buffer, string;
 529 {
 530   id pb;
 531   check_ns ();
 532   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 533   ns_string_to_pasteboard (pb, string);
 534   return Qnil;
 535 }
 536 #endif
 537
 538
 539 void
 540 nxatoms_of_nsselect (void)
 541 {
 542   NXSecondaryPboard = @"Selection";
 543 }
 544
 545 void
 546 syms_of_nsselect (void)
 547 {
 548   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
 549   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
 550   QTEXT      = intern ("TEXT");         staticpro (&QTEXT);
 551   QFILE_NAME = intern ("FILE_NAME");    staticpro (&QFILE_NAME);
 552
 553   defsubr (&Sns_disown_selection_internal);
 554   defsubr (&Sns_get_selection_internal);
 555   defsubr (&Sns_own_selection_internal);
 556   defsubr (&Sns_selection_exists_p);
 557   defsubr (&Sns_selection_owner_p);
 558 #ifdef CUT_BUFFER_SUPPORT
 559   defsubr (&Sns_get_cut_buffer_internal);
 560   defsubr (&Sns_rotate_cut_buffers_internal);
 561   defsubr (&Sns_store_cut_buffer_internal);
 562 #endif
 563
 564   Vselection_alist = Qnil;
 565   staticpro (&Vselection_alist);
 566
 567   DEFVAR_LISP ("ns-sent-selection-hooks", &Vns_sent_selection_hooks,
 568                "A list of functions to be called when Emacs answers a selection request.\n\
 569 The functions are called with four arguments:\n\
 570   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 571   - the selection-type which Emacs was asked to convert the\n\
 572     selection into before sending (for example, `STRING' or `LENGTH');\n\
 573   - a flag indicating success or failure for responding to the request.\n\
 574 We might have failed (and declined the request) for any number of reasons,\n\
 575 including being asked for a selection that we no longer own, or being asked\n\
 576 to convert into a type that we don't know about or that is inappropriate.\n\
 577 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 578 it merely informs you that they have happened.");
 579   Vns_sent_selection_hooks = Qnil;
 580
 581   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
 582                "An alist associating X Windows selection-types with functions.\n\
 583 These functions are called to convert the selection, with three args:\n\
 584 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 585 a desired type to which the selection should be converted;\n\
 586 and the local selection value (whatever was given to `x-own-selection').\n\
 587 \n\
 588 The function should return the value to send to the X server\n\
 589 \(typically a string).  A return value of nil\n\
 590 means that the conversion could not be done.\n\
 591 A return value which is the symbol `NULL'\n\
 592 means that a side-effect was executed,\n\
 593 and there is no meaningful selection value.");
 594   Vselection_converter_alist = Qnil;
 595
 596   DEFVAR_LISP ("ns-lost-selection-hooks", &Vns_lost_selection_hooks,
 597                "A list of functions to be called when Emacs loses an X selection.\n\
 598 \(This happens when some other X client makes its own selection\n\
 599 or when a Lisp program explicitly clears the selection.)\n\
 600 The functions are called with one argument, the selection type\n\
 601 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 602   Vns_lost_selection_hooks = Qnil;
 603
 604 /* 23: { */
 605   DEFVAR_LISP ("selection-coding-system", &Vselection_coding_system,
 606                doc: /* Coding system for communicating with other programs.
 607 When sending or receiving text via cut_buffer, selection, and clipboard,
 608 the text is encoded or decoded by this coding system.
 609 The default value is determined by the system script code.  */);
 610   Vselection_coding_system = Qnil;
 611
 612   DEFVAR_LISP ("next-selection-coding-system", &Vnext_selection_coding_system,
 613                doc: /* Coding system for the next communication with other programs.
 614 Usually, `selection-coding-system' is used for communicating with
 615 other programs.  But, if this variable is set, it is used for the
 616 next communication only.  After the communication, this variable is
 617 set to nil.  */);
 618   Vnext_selection_coding_system = Qnil;
 619
 620   Qforeign_selection = intern ("foreign-selection");
 621   staticpro (&Qforeign_selection);
 622 /* } */
 623
 624 }