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
   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      (Lisp_Object selection_name, Lisp_Object 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      (Lisp_Object selection_name, Lisp_Object time)
 416 {
 417   id pb;
 418   check_ns ();
 419   CHECK_SYMBOL (selection_name);
 420   if (NILP (assq_no_quit (selection_name, Vselection_alist))) return Qnil;
 421
 422   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (selection_name)];
 423   ns_undeclare_pasteboard (pb);
 424   return Qt;
 425 }
 426
 427
 428 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 429        0, 1, 0, doc: /* Whether there is an owner for the given selection.
 430 The arg should be the name of the selection in question, typically one of
 431 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 432 \(Those are literal upper-case symbol names.)
 433 For convenience, the symbol nil is the same as `PRIMARY',
 434 and t is the same as `SECONDARY'.)  */)
 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 ("x-selection-owner-p", Fx_selection_owner_p, Sx_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      (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 ("x-get-selection-internal", Fx_get_selection_internal,
 469        Sx_get_selection_internal, 2, 2, 0,
 470        doc: /* Return text selected from some pasteboard.
 471 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 472 \(Those are literal upper-case symbol names.)
 473 TYPE is the type of data desired, typically `STRING'.  */)
 474      (Lisp_Object selection_name, Lisp_Object target_type)
 475 {
 476   Lisp_Object val;
 477
 478   check_ns ();
 479   CHECK_SYMBOL (selection_name);
 480   CHECK_SYMBOL (target_type);
 481   val = ns_get_local_selection (selection_name, target_type);
 482   if (NILP (val))
 483     val = ns_get_foreign_selection (selection_name, target_type);
 484   if (CONSP (val) && SYMBOLP (Fcar (val)))
 485     {
 486       val = Fcdr (val);
 487       if (CONSP (val) && NILP (Fcdr (val)))
 488         val = Fcar (val);
 489     }
 490   val = clean_local_selection_data (val);
 491   return val;
 492 }
 493
 494
 495 #ifdef CUT_BUFFER_SUPPORT
 496 DEFUN ("ns-get-cut-buffer-internal", Fns_get_cut_buffer_internal,
 497        Sns_get_cut_buffer_internal, 1, 1, 0,
 498        doc: /* Returns the value of the named cut buffer.  */)
 499      (Lisp_Object buffer)
 500 {
 501   id pb;
 502   check_ns ();
 503   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 504   return ns_string_from_pasteboard (pb);
 505 }
 506
 507
 508 DEFUN ("ns-rotate-cut-buffers-internal", Fns_rotate_cut_buffers_internal,
 509        Sns_rotate_cut_buffers_internal, 1, 1, 0,
 510        doc: /* Rotate the values of the cut buffers by N steps.
 511 Positive N means move values forward, negative means
 512 backward. CURRENTLY NOT IMPLEMENTED UNDER NEXTSTEP. */ )
 513      (Lisp_Object n)
 514 {
 515   /* XXX This function is unimplemented under NeXTstep XXX */
 516   Fsignal (Qquit, Fcons (build_string (
 517       "Warning: ns-rotate-cut-buffers-internal not implemented\n"), Qnil));
 518   return Qnil;
 519 }
 520
 521
 522 DEFUN ("ns-store-cut-buffer-internal", Fns_store_cut_buffer_internal,
 523        Sns_store_cut_buffer_internal, 2, 2, 0,
 524        doc: /* Sets the value of the named cut buffer (typically CUT_BUFFER0).  */)
 525      (Lisp_Object buffer, Lisp_Object string)
 526 {
 527   id pb;
 528   check_ns ();
 529   pb =[NSPasteboard pasteboardWithName: symbol_to_nsstring (buffer)];
 530   ns_string_to_pasteboard (pb, string);
 531   return Qnil;
 532 }
 533 #endif
 534
 535
 536 void
 537 nxatoms_of_nsselect (void)
 538 {
 539   NXSecondaryPboard = @"Selection";
 540 }
 541
 542 void
 543 syms_of_nsselect (void)
 544 {
 545   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
 546   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
 547   QTEXT      = intern ("TEXT");         staticpro (&QTEXT);
 548   QFILE_NAME = intern ("FILE_NAME");    staticpro (&QFILE_NAME);
 549
 550   defsubr (&Sx_disown_selection_internal);
 551   defsubr (&Sx_get_selection_internal);
 552   defsubr (&Sx_own_selection_internal);
 553   defsubr (&Sx_selection_exists_p);
 554   defsubr (&Sx_selection_owner_p);
 555 #ifdef CUT_BUFFER_SUPPORT
 556   defsubr (&Sns_get_cut_buffer_internal);
 557   defsubr (&Sns_rotate_cut_buffers_internal);
 558   defsubr (&Sns_store_cut_buffer_internal);
 559 #endif
 560
 561   Vselection_alist = Qnil;
 562   staticpro (&Vselection_alist);
 563
 564   DEFVAR_LISP ("ns-sent-selection-hooks", &Vns_sent_selection_hooks,
 565                "A list of functions to be called when Emacs answers a selection request.\n\
 566 The functions are called with four arguments:\n\
 567   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 568   - the selection-type which Emacs was asked to convert the\n\
 569     selection into before sending (for example, `STRING' or `LENGTH');\n\
 570   - a flag indicating success or failure for responding to the request.\n\
 571 We might have failed (and declined the request) for any number of reasons,\n\
 572 including being asked for a selection that we no longer own, or being asked\n\
 573 to convert into a type that we don't know about or that is inappropriate.\n\
 574 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 575 it merely informs you that they have happened.");
 576   Vns_sent_selection_hooks = Qnil;
 577
 578   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
 579                "An alist associating X Windows selection-types with functions.\n\
 580 These functions are called to convert the selection, with three args:\n\
 581 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 582 a desired type to which the selection should be converted;\n\
 583 and the local selection value (whatever was given to `x-own-selection').\n\
 584 \n\
 585 The function should return the value to send to the X server\n\
 586 \(typically a string).  A return value of nil\n\
 587 means that the conversion could not be done.\n\
 588 A return value which is the symbol `NULL'\n\
 589 means that a side-effect was executed,\n\
 590 and there is no meaningful selection value.");
 591   Vselection_converter_alist = Qnil;
 592
 593   DEFVAR_LISP ("ns-lost-selection-hooks", &Vns_lost_selection_hooks,
 594                "A list of functions to be called when Emacs loses an X selection.\n\
 595 \(This happens when some other X client makes its own selection\n\
 596 or when a Lisp program explicitly clears the selection.)\n\
 597 The functions are called with one argument, the selection type\n\
 598 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').");
 599   Vns_lost_selection_hooks = Qnil;
 600
 601   Qforeign_selection = intern ("foreign-selection");
 602   staticpro (&Qforeign_selection);
 603 }
 604
 605 // arch-tag: 39d1dde7-06a6-49ff-95a7-0e7af12d2218