code.delx.au - gnu-emacs/blob - src/nsselect.m

   1 /* NeXT/Open/GNUstep / MacOSX Cocoa selection processing for emacs.
   2    Copyright (C) 1993, 1994, 2005, 2006, 2008, 2009
   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
  32 #include "lisp.h"
  33 #include "nsterm.h"
  34 #include "termhooks.h"
  35
  36 #define CUT_BUFFER_SUPPORT
  37
  38 Lisp_Object QPRIMARY, QSECONDARY, QTEXT, QFILE_NAME;
  39
  40 static Lisp_Object Vns_sent_selection_hooks;
  41 static Lisp_Object Vns_lost_selection_hooks;
  42 static Lisp_Object Vselection_alist;
  43 static Lisp_Object Vselection_converter_alist;
  44
  45 static Lisp_Object Qforeign_selection;
  46
  47 NSString *NXSecondaryPboard;
  48
  49
  50
  51 /* ==========================================================================
  52
  53     Internal utility functions
  54
  55    ========================================================================== */
  56
  57
  58 static NSString *
  59 symbol_to_nsstring (Lisp_Object sym)
  60 {
  61   CHECK_SYMBOL (sym);
  62   if (EQ (sym, QPRIMARY))     return NSGeneralPboard;
  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 QPRIMARY;
  74   if ([t isEqualToString: NXSecondaryPboard])
  75     return QSECONDARY;
  76   if ([t isEqualToString: NSStringPboardType])
  77     return QTEXT;
  78   if ([t isEqualToString: NSFilenamesPboardType])
  79     return QFILE_NAME;
  80   if ([t isEqualToString: NSTabularTextPboardType])
  81     return QTEXT;
  82   return intern ([t UTF8String]);
  83 }
  84
  85
  86 static Lisp_Object
  87 clean_local_selection_data (Lisp_Object obj)
  88 {
  89   if (CONSP (obj)
  90       && INTEGERP (XCAR (obj))
  91       && CONSP (XCDR (obj))
  92       && INTEGERP (XCAR (XCDR (obj)))
  93       && NILP (XCDR (XCDR (obj))))
  94     obj = Fcons (XCAR (obj), XCDR (obj));
  95
  96   if (CONSP (obj)
  97       && INTEGERP (XCAR (obj))
  98       && INTEGERP (XCDR (obj)))
  99     {
 100       if (XINT (XCAR (obj)) == 0)
 101         return XCDR (obj);
 102       if (XINT (XCAR (obj)) == -1)
 103         return make_number (- XINT (XCDR (obj)));
 104     }
 105
 106   if (VECTORP (obj))
 107     {
 108       int i;
 109       int size = ASIZE (obj);
 110       Lisp_Object copy;
 111
 112       if (size == 1)
 113         return clean_local_selection_data (AREF (obj, 0));
 114       copy = Fmake_vector (make_number (size), Qnil);
 115       for (i = 0; i < size; i++)
 116         ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
 117       return copy;
 118     }
 119
 120   return obj;
 121 }
 122
 123
 124 static void
 125 ns_declare_pasteboard (id pb)
 126 {
 127   [pb declareTypes: ns_send_types owner: NSApp];
 128 }
 129
 130
 131 static void
 132 ns_undeclare_pasteboard (id pb)
 133 {
 134   [pb declareTypes: [NSArray array] owner: nil];
 135 }
 136
 137
 138 static void
 139 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
 140 {
 141   if (EQ (str, Qnil))
 142     {
 143       [pb declareTypes: [NSArray array] owner: nil];
 144     }
 145   else
 146     {
 147       char *utfStr;
 148       NSString *type, *nsStr;
 149       NSEnumerator *tenum;
 150
 151       CHECK_STRING (str);
 152
 153       utfStr = SDATA (str);
 154       nsStr = [NSString stringWithUTF8String: utfStr];
 155
 156       if (gtype == nil)
 157         {
 158           [pb declareTypes: ns_send_types owner: nil];
 159           tenum = [ns_send_types objectEnumerator];
 160           while ( (type = [tenum nextObject]) )
 161             [pb setString: nsStr forType: type];
 162         }
 163       else
 164         {
 165           [pb setString: nsStr forType: gtype];
 166         }
 167     }
 168 }
 169
 170
 171 static Lisp_Object
 172 ns_get_local_selection (Lisp_Object selection_name,
 173                        Lisp_Object target_type)
 174 {
 175   Lisp_Object local_value;
 176   Lisp_Object handler_fn, value, type, check;
 177   int count;
 178
 179   local_value = assq_no_quit (selection_name, Vselection_alist);
 180
 181   if (NILP (local_value)) return Qnil;
 182
 183   count = specpdl_ptr - specpdl;
 184   specbind (Qinhibit_quit, Qt);
 185   CHECK_SYMBOL (target_type);
 186   handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
 187   if (!NILP (handler_fn))
 188     value = call3 (handler_fn, selection_name, target_type,
 189                 XCAR (XCDR (local_value)));
 190   else
 191     value = Qnil;
 192   unbind_to (count, Qnil);
 193
 194   check = value;
 195   if (CONSP (value) && SYMBOLP (XCAR (value)))
 196     {
 197       type = XCAR (value);
 198       check = XCDR (value);
 199     }
 200
 201   if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
 202       || INTEGERP (check) || NILP (value))
 203     return value;
 204
 205   if (CONSP (check)
 206       && INTEGERP (XCAR (check))
 207       && (INTEGERP (XCDR (check))||
 208           (CONSP (XCDR (check))
 209            && INTEGERP (XCAR (XCDR (check)))
 210            && NILP (XCDR (XCDR (check))))))
 211     return value;
 212
 213   // FIXME: Why `quit' rather than `error'?
 214   Fsignal (Qquit, Fcons (build_string (
 215       "invalid data returned by selection-conversion function"),
 216                         Fcons (handler_fn, Fcons (value, Qnil))));
 217   // FIXME: Beware, `quit' can return!!
 218   return Qnil;
 219 }
 220
 221
 222 static Lisp_Object
 223 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
 224 {
 225   id pb;
 226   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
 227   return ns_string_from_pasteboard (pb);
 228 }
 229
 230
 231 static void
 232 ns_handle_selection_request (struct input_event *event)
 233 {
 234   // FIXME: BIG UGLY HACK!!!
 235   id pb = (id)*(EMACS_INT*)&(event->x);
 236   NSString *type = (NSString *)*(EMACS_INT*)&(event->y);
 237   Lisp_Object selection_name, selection_data, target_symbol, data;
 238   Lisp_Object successful_p, rest;
 239
 240   selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
 241   target_symbol = ns_string_to_symbol (type);
 242   selection_data = assq_no_quit (selection_name, Vselection_alist);
 243   successful_p = Qnil;
 244
 245   if (!NILP (selection_data))
 246     {
 247       data = ns_get_local_selection (selection_name, target_symbol);
 248       if (!NILP (data))
 249         {
 250           if (STRINGP (data))
 251             ns_string_to_pasteboard_internal (pb, data, type);
 252           successful_p = Qt;
 253         }
 254     }
 255
 256   if (!EQ (Vns_sent_selection_hooks, Qunbound))
 257     {
 258       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
 259         call3 (Fcar (rest), selection_name, target_symbol, successful_p);
 260     }
 261 }
 262
 263
 264 static void
 265 ns_handle_selection_clear (struct input_event *event)
 266 {
 267   id pb = (id)*(EMACS_INT*)&(event->x);
 268   Lisp_Object selection_name, selection_data, rest;
 269
 270   selection_name = ns_string_to_symbol ([(NSPasteboard *)pb name]);
 271   selection_data = assq_no_quit (selection_name, Vselection_alist);
 272   if (NILP (selection_data)) return;
 273
 274   if (EQ (selection_data, Fcar (Vselection_alist)))
 275     Vselection_alist = Fcdr (Vselection_alist);
 276   else
 277     {
 278       for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
 279         if (EQ (selection_data, Fcar (Fcdr (rest))))
 280           Fsetcdr (rest, Fcdr (Fcdr (rest)));
 281     }
 282
 283   if (!EQ (Vns_lost_selection_hooks, Qunbound))
 284     {
 285       for (rest = Vns_lost_selection_hooks;CONSP (rest); rest = Fcdr (rest))
 286         call1 (Fcar (rest), selection_name);
 287     }
 288 }
 289
 290
 291
 292 /* ==========================================================================
 293
 294     Functions used externally
 295
 296    ========================================================================== */
 297
 298
 299 Lisp_Object
 300 ns_string_from_pasteboard (id pb)
 301 {
 302   NSString *type, *str;
 303   const char *utfStr;
 304
 305   type = [pb availableTypeFromArray: ns_return_types];
 306   if (type == nil)
 307     {
 308       Fsignal (Qquit,
 309               Fcons (build_string ("empty or unsupported pasteboard type"),
 310                     Qnil));
 311     return Qnil;
 312     }
 313
 314   /* get the string */
 315   if (! (str = [pb stringForType: type]))
 316     {
 317       NSData *data = [pb dataForType: type];
 318       if (data != nil)
 319         str = [[NSString alloc] initWithData: data
 320                                     encoding: NSUTF8StringEncoding];
 321       if (str != nil)
 322         {
 323           [str autorelease];
 324         }
 325       else
 326         {
 327           Fsignal (Qquit,
 328                   Fcons (build_string ("pasteboard doesn't contain valid data"),
 329                         Qnil));
 330           return Qnil;
 331         }
 332     }
 333
 334   /* assume UTF8 */
 335   NS_DURING
 336     {
 337       /* EOL conversion: PENDING- is this too simple? */
 338       NSMutableString *mstr = [[str mutableCopy] autorelease];
 339       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
 340             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 341       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
 342             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 343
 344       utfStr = [mstr UTF8String];
 345       if (!utfStr)
 346         utfStr = [mstr cString];
 347     }
 348   NS_HANDLER
 349     {
 350       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
 351       utfStr = [str lossyCString];
 352     }
 353   NS_ENDHANDLER
 354
 355   return build_string (utfStr);
 356 }
 357
 358
 359 void
 360 ns_string_to_pasteboard (id pb, Lisp_Object str)
 361 {
 362   ns_string_to_pasteboard_internal (pb, str, nil);
 363 }
 364
 365
 366
 367 /* ==========================================================================
 368
 369     Lisp Defuns
 370
 371    ========================================================================== */
 372
 373
 374 DEFUN ("ns-own-selection-internal", Fns_own_selection_internal,
 375        Sns_own_selection_internal, 2, 2, 0,
 376        doc: /* Assert a selection.
 377 SELECTION-NAME is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 378 VALUE is typically a string, or a cons of two markers, but may be
 379 anything that the functions on `selection-converter-alist' know about.  */)
 380      (selection_name, selection_value)
 381      Lisp_Object selection_name, selection_value;
 382 {
 383   id pb;
 384   Lisp_Object old_value, new_value;
 385
 386   check_ns ();
 387   CHECK_SYMBOL (selection_name);
 388   if (NILP (selection_value))
 389       error ("selection-value may not be nil.");
 390   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 391   ns_declare_pasteboard (pb);
 392   old_value = assq_no_quit (selection_name, Vselection_alist);
 393   new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
 394   if (NILP (old_value))
 395     Vselection_alist = Fcons (new_value, Vselection_alist);
 396   else
 397     Fsetcdr (old_value, Fcdr (new_value));
 398   /* XXX An evil hack, but a necessary one I fear XXX */
 399   {
 400     struct input_event ev;
 401     ev.kind = SELECTION_REQUEST_EVENT;
 402     ev.modifiers = 0;
 403     ev.code = 0;
 404     *(EMACS_INT*)(&(ev.x)) = (EMACS_INT)pb; // FIXME: BIG UGLY HACK!!
 405     *(EMACS_INT*)(&(ev.y)) = (EMACS_INT)NSStringPboardType;
 406     ns_handle_selection_request (&ev);
 407   }
 408   return selection_value;
 409 }
 410
 411
 412 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
 413        Sx_disown_selection_internal, 1, 2, 0,
 414        doc: /* If we own the selection SELECTION, disown it.  */)
 415      (selection_name, time)
 416      Lisp_Object selection_name, time;
 417 {
 418   id pb;
 419   check_ns ();
 420   CHECK_SYMBOL (selection_name);
 421   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
 422
 423   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 424   ns_undeclare_pasteboard (pb);
 425   return Qt;
 426 }
 427
 428
 429 DEFUN ("ns-selection-exists-p", Fns_selection_exists_p, Sns_selection_exists_p,
 430        0, 1, 0, doc: /* Whether there is an owner for the given selection.
 431 The arg should be the name of the selection in question, typically one of
 432 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 433 \(Those are literal upper-case symbol names.)
 434 For convenience, the symbol nil is the same as `PRIMARY',
 435 and t is the same as `SECONDARY'.)  */)
 436      (selection)
 437      Lisp_Object selection;
 438 {
 439   id pb;
 440   NSArray *types;
 441
 442   check_ns ();
 443   CHECK_SYMBOL (selection);
 444   if (EQ (selection, Qnil)) selection = QPRIMARY;
 445   if (EQ (selection, Qt)) selection = QSECONDARY;
 446   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
 447   types =[pb types];
 448   return ([types count] == 0) ? Qnil : Qt;
 449 }
 450
 451
 452 DEFUN ("ns-selection-owner-p", Fns_selection_owner_p, Sns_selection_owner_p,
 453        0, 1, 0,
 454        doc: /* Whether the current Emacs process owns the given selection.
 455 The arg should be the name of the selection in question, typically one of
 456 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 457 \(Those are literal upper-case symbol names.)
 458 For convenience, the symbol nil is the same as `PRIMARY',
 459 and t is the same as `SECONDARY'.)  */)
 460      (selection)
 461      Lisp_Object selection;
 462 {
 463   check_ns ();
 464   CHECK_SYMBOL (selection);
 465   if (EQ (selection, Qnil)) selection = QPRIMARY;
 466   if (EQ (selection, Qt)) selection = QSECONDARY;
 467   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
 468 }
 469
 470
 471 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
 472        Sx_get_selection_internal, 2, 2, 0,
 473        doc: /* Return text selected from some pasteboard.
 474 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 475 \(Those are literal upper-case symbol names.)
 476 TYPE is the type of data desired, typically `STRING'.  */)
 477      (selection_name, target_type)
 478      Lisp_Object selection_name, target_type;
 479 {
 480   Lisp_Object val;
 481
 482   check_ns ();
 483   CHECK_SYMBOL (selection_name);
 484   CHECK_SYMBOL (target_type);
 485   val = ns_get_local_selection (selection_name, target_type);
 486   if (NILP (val))
 487     val = ns_get_foreign_selection (selection_name, target_type);
 488   if (CONSP (val) && SYMBOLP (Fcar (val)))
 489     {
 490       val = Fcdr (val);
 491       if (CONSP (val) && NILP (Fcdr (val)))
 492         val = Fcar (val);
 493     }
 494   val = clean_local_selection_data (val);
 495   return val;
 496 }
 497
 498
 499 #ifdef CUT_BUFFER_SUPPORT
 500 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
 501        Sns_get_cut_buffer_internal, 1, 1, 0,
 502        doc: /* Returns the value of the named cut buffer.  */)
 503      (buffer)
 504      Lisp_Object buffer;
 505 {
 506   id pb;
 507   check_ns ();
 508   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 509   return ns_string_from_pasteboard (pb);
 510 }
 511
 512
 513 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
 514        Sns_rotate_cut_buffers_internal, 1, 1, 0,
 515        doc: /* Rotate the values of the cut buffers by N steps.
 516 Positive N means move values forward, negative means
 517 backward. CURRENTLY NOT IMPLEMENTED UNDER NEXTSTEP. */ )
 518      (n)
 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      (buffer, string)
 532      Lisp_Object buffer, string;
 533 {
 534   id pb;
 535   check_ns ();
 536   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 537   ns_string_to_pasteboard (pb, string);
 538   return Qnil;
 539 }
 540 #endif
 541
 542
 543 void
 544 nxatoms_of_nsselect (void)
 545 {
 546   NXSecondaryPboard = @"Selection";
 547 }
 548
 549 void
 550 syms_of_nsselect (void)
 551 {
 552   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
 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 (&Sns_own_selection_internal);
 560   defsubr (&Sns_selection_exists_p);
 561   defsubr (&Sns_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