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, 2010, 2011, 2012
   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
  37 #define CUT_BUFFER_SUPPORT
  38
  39 Lisp_Object QPRIMARY, QSECONDARY, QTEXT, QFILE_NAME;
  40
  41 static Lisp_Object Vns_sent_selection_hooks;
  42 static Lisp_Object Vns_lost_selection_hooks;
  43 static Lisp_Object Vselection_alist;
  44 static Lisp_Object Vselection_converter_alist;
  45
  46 static Lisp_Object Qforeign_selection;
  47
  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, QPRIMARY))     return NSGeneralPboard;
  64   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
  65   if (EQ (sym, QTEXT))        return NSStringPboardType;
  66   return [NSString stringWithUTF8String: SDATA (XSYMBOL (sym)->xname)];
  67 }
  68
  69
  70 static Lisp_Object
  71 ns_string_to_symbol (NSString *t)
  72 {
  73   if ([t isEqualToString: NSGeneralPboard])
  74     return QPRIMARY;
  75   if ([t isEqualToString: NXSecondaryPboard])
  76     return QSECONDARY;
  77   if ([t isEqualToString: NSStringPboardType])
  78     return QTEXT;
  79   if ([t isEqualToString: NSFilenamesPboardType])
  80     return QFILE_NAME;
  81   if ([t isEqualToString: NSTabularTextPboardType])
  82     return QTEXT;
  83   return intern ([t UTF8String]);
  84 }
  85
  86
  87 static Lisp_Object
  88 clean_local_selection_data (Lisp_Object obj)
  89 {
  90   if (CONSP (obj)
  91       && INTEGERP (XCAR (obj))
  92       && CONSP (XCDR (obj))
  93       && INTEGERP (XCAR (XCDR (obj)))
  94       && NILP (XCDR (XCDR (obj))))
  95     obj = Fcons (XCAR (obj), XCDR (obj));
  96
  97   if (CONSP (obj)
  98       && INTEGERP (XCAR (obj))
  99       && INTEGERP (XCDR (obj)))
 100     {
 101       if (XINT (XCAR (obj)) == 0)
 102         return XCDR (obj);
 103       if (XINT (XCAR (obj)) == -1)
 104         return make_number (- XINT (XCDR (obj)));
 105     }
 106
 107   if (VECTORP (obj))
 108     {
 109       int i;
 110       int size = ASIZE (obj);
 111       Lisp_Object copy;
 112
 113       if (size == 1)
 114         return clean_local_selection_data (AREF (obj, 0));
 115       copy = Fmake_vector (make_number (size), Qnil);
 116       for (i = 0; i < size; i++)
 117         ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
 118       return copy;
 119     }
 120
 121   return obj;
 122 }
 123
 124
 125 static void
 126 ns_declare_pasteboard (id pb)
 127 {
 128   [pb declareTypes: ns_send_types owner: NSApp];
 129 }
 130
 131
 132 static void
 133 ns_undeclare_pasteboard (id pb)
 134 {
 135   [pb declareTypes: [NSArray array] owner: nil];
 136 }
 137
 138
 139 static void
 140 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
 141 {
 142   if (EQ (str, Qnil))
 143     {
 144       [pb declareTypes: [NSArray array] owner: nil];
 145     }
 146   else
 147     {
 148       char *utfStr;
 149       NSString *type, *nsStr;
 150       NSEnumerator *tenum;
 151
 152       CHECK_STRING (str);
 153
 154       utfStr = SDATA (str);
 155       nsStr = [NSString stringWithUTF8String: utfStr];
 156
 157       if (gtype == nil)
 158         {
 159           [pb declareTypes: ns_send_types owner: nil];
 160           tenum = [ns_send_types objectEnumerator];
 161           while ( (type = [tenum nextObject]) )
 162             [pb setString: nsStr forType: type];
 163         }
 164       else
 165         {
 166           [pb setString: nsStr forType: gtype];
 167         }
 168     }
 169 }
 170
 171
 172 static Lisp_Object
 173 ns_get_local_selection (Lisp_Object selection_name,
 174                        Lisp_Object target_type)
 175 {
 176   Lisp_Object local_value;
 177   Lisp_Object handler_fn, value, type, check;
 178   int count;
 179
 180   local_value = assq_no_quit (selection_name, Vselection_alist);
 181
 182   if (NILP (local_value)) return Qnil;
 183
 184   count = specpdl_ptr - specpdl;
 185   specbind (Qinhibit_quit, Qt);
 186   CHECK_SYMBOL (target_type);
 187   handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
 188   if (!NILP (handler_fn))
 189     value = call3 (handler_fn, selection_name, target_type,
 190                 XCAR (XCDR (local_value)));
 191   else
 192     value = Qnil;
 193   unbind_to (count, Qnil);
 194
 195   check = value;
 196   if (CONSP (value) && SYMBOLP (XCAR (value)))
 197     {
 198       type = XCAR (value);
 199       check = XCDR (value);
 200     }
 201
 202   if (STRINGP (check) || VECTORP (check) || SYMBOLP (check)
 203       || INTEGERP (check) || NILP (value))
 204     return value;
 205
 206   if (CONSP (check)
 207       && INTEGERP (XCAR (check))
 208       && (INTEGERP (XCDR (check))||
 209           (CONSP (XCDR (check))
 210            && INTEGERP (XCAR (XCDR (check)))
 211            && NILP (XCDR (XCDR (check))))))
 212     return value;
 213
 214   // FIXME: Why `quit' rather than `error'?
 215   Fsignal (Qquit, Fcons (build_string (
 216       "invalid data returned by selection-conversion function"),
 217                         Fcons (handler_fn, Fcons (value, Qnil))));
 218   // FIXME: Beware, `quit' can return!!
 219   return Qnil;
 220 }
 221
 222
 223 static Lisp_Object
 224 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
 225 {
 226   id pb;
 227   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
 228   return ns_string_from_pasteboard (pb);
 229 }
 230
 231
 232 static void
 233 ns_handle_selection_request (struct input_event *event)
 234 {
 235   // FIXME: BIG UGLY HACK!!!
 236   id pb = (id)*(EMACS_INT*)&(event->x);
 237   NSString *type = (NSString *)*(EMACS_INT*)&(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)*(EMACS_INT*)&(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 ("x-own-selection-internal", Fx_own_selection_internal,
 376        Sx_own_selection_internal, 2, 2, 0,
 377        doc: /* Assert a selection.
 378 SELECTION-NAME is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 379 VALUE is typically a string, or a cons of two markers, but may be
 380 anything that the functions on `selection-converter-alist' know about.  */)
 381      (selection_name, selection_value)
 382      Lisp_Object selection_name, selection_value;
 383 {
 384   id pb;
 385   Lisp_Object old_value, new_value;
 386
 387   check_ns ();
 388   CHECK_SYMBOL (selection_name);
 389   if (NILP (selection_value))
 390       error ("selection-value may not be nil.");
 391   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 392   ns_declare_pasteboard (pb);
 393   old_value = assq_no_quit (selection_name, Vselection_alist);
 394   new_value = Fcons (selection_name, Fcons (selection_value, Qnil));
 395   if (NILP (old_value))
 396     Vselection_alist = Fcons (new_value, Vselection_alist);
 397   else
 398     Fsetcdr (old_value, Fcdr (new_value));
 399   /* XXX An evil hack, but a necessary one I fear XXX */
 400   {
 401     struct input_event ev;
 402     ev.kind = SELECTION_REQUEST_EVENT;
 403     ev.modifiers = 0;
 404     ev.code = 0;
 405     *(EMACS_INT*)(&(ev.x)) = (EMACS_INT)pb; // FIXME: BIG UGLY HACK!!
 406     *(EMACS_INT*)(&(ev.y)) = (EMACS_INT)NSStringPboardType;
 407     ns_handle_selection_request (&ev);
 408   }
 409   return selection_value;
 410 }
 411
 412
 413 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
 414        Sx_disown_selection_internal, 1, 2, 0,
 415        doc: /* If we own the selection SELECTION, disown it.  */)
 416      (selection_name, time)
 417      Lisp_Object selection_name, time;
 418 {
 419   id pb;
 420   check_ns ();
 421   CHECK_SYMBOL (selection_name);
 422   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
 423
 424   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 425   ns_undeclare_pasteboard (pb);
 426   return Qt;
 427 }
 428
 429
 430 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 431        0, 1, 0, doc: /* Whether there is an owner for the given selection.
 432 The arg should be the name of the selection in question, typically one of
 433 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 434 \(Those are literal upper-case symbol names.)
 435 For convenience, the symbol nil is the same as `PRIMARY',
 436 and t is the same as `SECONDARY'.)  */)
 437      (selection)
 438      Lisp_Object selection;
 439 {
 440   id pb;
 441   NSArray *types;
 442
 443   check_ns ();
 444   CHECK_SYMBOL (selection);
 445   if (EQ (selection, Qnil)) selection = QPRIMARY;
 446   if (EQ (selection, Qt)) selection = QSECONDARY;
 447   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection)];
 448   types =[pb types];
 449   return ([types count] == 0) ? Qnil : Qt;
 450 }
 451
 452
 453 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
 454        0, 1, 0,
 455        doc: /* Whether the current Emacs process owns the given selection.
 456 The arg should be the name of the selection in question, typically one of
 457 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 458 \(Those are literal upper-case symbol names.)
 459 For convenience, the symbol nil is the same as `PRIMARY',
 460 and t is the same as `SECONDARY'.)  */)
 461      (selection)
 462      Lisp_Object selection;
 463 {
 464   check_ns ();
 465   CHECK_SYMBOL (selection);
 466   if (EQ (selection, Qnil)) selection = QPRIMARY;
 467   if (EQ (selection, Qt)) selection = QSECONDARY;
 468   return (NILP (Fassq (selection, Vselection_alist))) ? Qnil : Qt;
 469 }
 470
 471
 472 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
 473        Sx_get_selection_internal, 2, 2, 0,
 474        doc: /* Return text selected from some pasteboard.
 475 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 476 \(Those are literal upper-case symbol names.)
 477 TYPE is the type of data desired, typically `STRING'.  */)
 478      (selection_name, target_type)
 479      Lisp_Object selection_name, target_type;
 480 {
 481   Lisp_Object val;
 482
 483   check_ns ();
 484   CHECK_SYMBOL (selection_name);
 485   CHECK_SYMBOL (target_type);
 486   val = ns_get_local_selection (selection_name, target_type);
 487   if (NILP (val))
 488     val = ns_get_foreign_selection (selection_name, target_type);
 489   if (CONSP (val) && SYMBOLP (Fcar (val)))
 490     {
 491       val = Fcdr (val);
 492       if (CONSP (val) && NILP (Fcdr (val)))
 493         val = Fcar (val);
 494     }
 495   val = clean_local_selection_data (val);
 496   return val;
 497 }
 498
 499
 500 #ifdef CUT_BUFFER_SUPPORT
 501 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
 502        Sns_get_cut_buffer_internal, 1, 1, 0,
 503        doc: /* Returns the value of the named cut buffer.  */)
 504      (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      (n)
 520      Lisp_Object n;
 521 {
 522   /* XXX This function is unimplemented under NeXTstep XXX */
 523   Fsignal (Qquit, Fcons (build_string (
 524       "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
 525   return Qnil;
 526 }
 527
 528
 529 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
 530        Sns_store_cut_buffer_internal, 2, 2, 0,
 531        doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0).  */)
 532      (buffer, string)
 533      Lisp_Object buffer, string;
 534 {
 535   id pb;
 536   check_ns ();
 537   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 538   ns_string_to_pasteboard (pb, string);
 539   return Qnil;
 540 }
 541 #endif
 542
 543
 544 void
 545 nxatoms_of_nsselect (void)
 546 {
 547   NXSecondaryPboard = @"Selection";
 548 }
 549
 550 void
 551 syms_of_nsselect (void)
 552 {
 553   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
 554   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
 555   QTEXT      = intern ("TEXT");         staticpro (&QTEXT);
 556   QFILE_NAME = intern ("FILE_NAME");    staticpro (&QFILE_NAME);
 557
 558   defsubr (&Sx_disown_selection_internal);
 559   defsubr (&Sx_get_selection_internal);
 560   defsubr (&Sx_own_selection_internal);
 561   defsubr (&Sx_selection_exists_p);
 562   defsubr (&Sx_selection_owner_p);
 563 #ifdef CUT_BUFFER_SUPPORT
 564   defsubr (&Sns_get_cut_buffer_internal);
 565   defsubr (&Sns_rotate_cut_buffers_internal);
 566   defsubr (&Sns_store_cut_buffer_internal);
 567 #endif
 568
 569   Vselection_alist = Qnil;
 570   staticpro (&Vselection_alist);
 571
 572   DEFVAR_LISP ("ns-sent-selection-hooks", &Vns_sent_selection_hooks,
 573                "A list of functions to be called when Emacs answers a selection request.\n\
 574 The functions are called with four arguments:\n\
 575   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 576   - the selection-type which Emacs was asked to convert the\n\
 577     selection into before sending (for example, `STRING' or `LENGTH');\n\
 578   - a flag indicating success or failure for responding to the request.\n\
 579 We might have failed (and declined the request) for any number of reasons,\n\
 580 including being asked for a selection that we no longer own, or being asked\n\
 581 to convert into a type that we don't know about or that is inappropriate.\n\
 582 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 583 it merely informs you that they have happened.");
 584   Vns_sent_selection_hooks = Qnil;
 585
 586   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
 587                "An alist associating X Windows selection-types with functions.\n\
 588 These functions are called to convert the selection, with three args:\n\
 589 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 590 a desired type to which the selection should be converted;\n\
 591 and the local selection value (whatever was given to `x-own-selection').\n\
 592 \n\
 593 The function should return the value to send to the X server\n\
 594 \(typically a string).  A return value of nil\n\
 595 means that the conversion could not be done.\n\
 596 A return value which is the symbol `NULL'\n\
 597 means that a side-effect was executed,\n\
 598 and there is no meaningful selection value.");
 599   Vselection_converter_alist = Qnil;
 600
 601   DEFVAR_LISP ("ns-lost-selection-hooks", &Vns_lost_selection_hooks,
 602                "A list of functions to be called when Emacs loses an X selection.\n\
 603 \(This happens when some other X client makes its own selection\n\
 604 or when a Lisp program explicitly clears the selection.)\n\
 605 The functions are called with one argument, the selection type\n\
 606 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 607   Vns_lost_selection_hooks = Qnil;
 608
 609   Qforeign_selection = intern ("foreign-selection");
 610   staticpro (&Qforeign_selection);
 611 }
 612
 613 // arch-tag: 39d1dde7-06a6-49ff-95a7-0e7af12d2218