src/nsselect.m

   1 /* NeXT/Open/GNUstep / macOS Cocoa selection processing for emacs.
   2    Copyright (C) 1993-1994, 2005-2006, 2008-2018 Free Software
   3    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 (at
  10 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 <https://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 macOS/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 #include "keyboard.h"
  36
  37 static Lisp_Object Vselection_alist;
  38
  39 /* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */
  40 static NSString *NXPrimaryPboard;
  41 static NSString *NXSecondaryPboard;
  42
  43
  44 static NSMutableDictionary *pasteboard_changecount;
  45
  46 /* ==========================================================================
  47
  48     Internal utility functions
  49
  50    ========================================================================== */
  51
  52
  53 static NSString *
  54 symbol_to_nsstring (Lisp_Object sym)
  55 {
  56   CHECK_SYMBOL (sym);
  57   if (EQ (sym, QCLIPBOARD))   return NSGeneralPboard;
  58   if (EQ (sym, QPRIMARY))     return NXPrimaryPboard;
  59   if (EQ (sym, QSECONDARY))   return NXSecondaryPboard;
  60   if (EQ (sym, QTEXT))        return NSStringPboardType;
  61   return [NSString stringWithUTF8String: SSDATA (SYMBOL_NAME (sym))];
  62 }
  63
  64 static NSPasteboard *
  65 ns_symbol_to_pb (Lisp_Object symbol)
  66 {
  67   return [NSPasteboard pasteboardWithName: symbol_to_nsstring (symbol)];
  68 }
  69
  70 static Lisp_Object
  71 ns_string_to_symbol (NSString *t)
  72 {
  73   if ([t isEqualToString: NSGeneralPboard])
  74     return QCLIPBOARD;
  75   if ([t isEqualToString: NXPrimaryPboard])
  76     return QPRIMARY;
  77   if ([t isEqualToString: NXSecondaryPboard])
  78     return QSECONDARY;
  79   if ([t isEqualToString: NSStringPboardType])
  80     return QTEXT;
  81   if ([t isEqualToString: NSFilenamesPboardType])
  82     return QFILE_NAME;
  83   if ([t isEqualToString: NSTabularTextPboardType])
  84     return QTEXT;
  85   return intern ([t UTF8String]);
  86 }
  87
  88
  89 static Lisp_Object
  90 clean_local_selection_data (Lisp_Object obj)
  91 {
  92   if (CONSP (obj)
  93       && INTEGERP (XCAR (obj))
  94       && CONSP (XCDR (obj))
  95       && INTEGERP (XCAR (XCDR (obj)))
  96       && NILP (XCDR (XCDR (obj))))
  97     obj = Fcons (XCAR (obj), XCDR (obj));
  98
  99   if (CONSP (obj)
 100       && INTEGERP (XCAR (obj))
 101       && INTEGERP (XCDR (obj)))
 102     {
 103       if (XINT (XCAR (obj)) == 0)
 104         return XCDR (obj);
 105       if (XINT (XCAR (obj)) == -1)
 106         return make_number (- XINT (XCDR (obj)));
 107     }
 108
 109   if (VECTORP (obj))
 110     {
 111       ptrdiff_t i;
 112       ptrdiff_t size = ASIZE (obj);
 113       Lisp_Object copy;
 114
 115       if (size == 1)
 116         return clean_local_selection_data (AREF (obj, 0));
 117       copy = make_uninit_vector (size);
 118       for (i = 0; i < size; i++)
 119         ASET (copy, i, clean_local_selection_data (AREF (obj, i)));
 120       return copy;
 121     }
 122
 123   return obj;
 124 }
 125
 126
 127 static void
 128 ns_declare_pasteboard (id pb)
 129 {
 130   [pb declareTypes: ns_send_types owner: NSApp];
 131 }
 132
 133
 134 static void
 135 ns_undeclare_pasteboard (id pb)
 136 {
 137   [pb declareTypes: [NSArray array] owner: nil];
 138 }
 139
 140 static void
 141 ns_store_pb_change_count (id pb)
 142 {
 143   [pasteboard_changecount
 144         setObject: [NSNumber numberWithLong: [pb changeCount]]
 145            forKey: [pb name]];
 146 }
 147
 148 static NSInteger
 149 ns_get_pb_change_count (Lisp_Object selection)
 150 {
 151   id pb = ns_symbol_to_pb (selection);
 152   return pb != nil ? [pb changeCount] : -1;
 153 }
 154
 155 static NSInteger
 156 ns_get_our_change_count_for (Lisp_Object selection)
 157 {
 158   NSNumber *num = [pasteboard_changecount
 159                     objectForKey: symbol_to_nsstring (selection)];
 160   return num != nil ? (NSInteger)[num longValue] : -1;
 161 }
 162
 163
 164 static void
 165 ns_string_to_pasteboard_internal (id pb, Lisp_Object str, NSString *gtype)
 166 {
 167   if (EQ (str, Qnil))
 168     {
 169       [pb declareTypes: [NSArray array] owner: nil];
 170     }
 171   else
 172     {
 173       char *utfStr;
 174       NSString *type, *nsStr;
 175       NSEnumerator *tenum;
 176
 177       CHECK_STRING (str);
 178
 179       utfStr = SSDATA (str);
 180       nsStr = [[NSString alloc] initWithBytesNoCopy: utfStr
 181                                              length: SBYTES (str)
 182                                            encoding: NSUTF8StringEncoding
 183                                        freeWhenDone: NO];
 184       // FIXME: Why those 2 different code paths?
 185       if (gtype == nil)
 186         {
 187           // Used for ns_string_to_pasteboard
 188           [pb declareTypes: ns_send_types owner: nil];
 189           tenum = [ns_send_types objectEnumerator];
 190           while ( (type = [tenum nextObject]) )
 191             [pb setString: nsStr forType: type];
 192         }
 193       else
 194         {
 195           // Used for ns-own-selection-internal.
 196           eassert (gtype == NSStringPboardType);
 197           [pb setString: nsStr forType: gtype];
 198         }
 199       [nsStr release];
 200       ns_store_pb_change_count (pb);
 201     }
 202 }
 203
 204
 205 Lisp_Object
 206 ns_get_local_selection (Lisp_Object selection_name,
 207                         Lisp_Object target_type)
 208 {
 209   Lisp_Object local_value;
 210   local_value = assq_no_quit (selection_name, Vselection_alist);
 211   return local_value;
 212 }
 213
 214
 215 static Lisp_Object
 216 ns_get_foreign_selection (Lisp_Object symbol, Lisp_Object target)
 217 {
 218   id pb;
 219   pb = ns_symbol_to_pb (symbol);
 220   return pb != nil ? ns_string_from_pasteboard (pb) : Qnil;
 221 }
 222
 223
 224
 225
 226 /* ==========================================================================
 227
 228     Functions used externally
 229
 230    ========================================================================== */
 231
 232
 233 Lisp_Object
 234 ns_string_from_pasteboard (id pb)
 235 {
 236   NSString *type, *str;
 237   const char *utfStr;
 238   int length;
 239
 240   type = [pb availableTypeFromArray: ns_return_types];
 241   if (type == nil)
 242     {
 243       return Qnil;
 244     }
 245
 246   /* get the string */
 247   if (! (str = [pb stringForType: type]))
 248     {
 249       NSData *data = [pb dataForType: type];
 250       if (data != nil)
 251         str = [[NSString alloc] initWithData: data
 252                                     encoding: NSUTF8StringEncoding];
 253       if (str != nil)
 254         {
 255           [str autorelease];
 256         }
 257       else
 258         {
 259           return Qnil;
 260         }
 261     }
 262
 263   /* assume UTF8 */
 264   NS_DURING
 265     {
 266       /* EOL conversion: PENDING- is this too simple? */
 267       NSMutableString *mstr = [[str mutableCopy] autorelease];
 268       [mstr replaceOccurrencesOfString: @"\r\n" withString: @"\n"
 269             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 270       [mstr replaceOccurrencesOfString: @"\r" withString: @"\n"
 271             options: NSLiteralSearch range: NSMakeRange (0, [mstr length])];
 272
 273       utfStr = [mstr UTF8String];
 274       length = [mstr lengthOfBytesUsingEncoding: NSUTF8StringEncoding];
 275
 276 #if ! defined (NS_IMPL_COCOA)
 277       if (!utfStr)
 278         {
 279           utfStr = [mstr cString];
 280           length = strlen (utfStr);
 281         }
 282 #endif
 283     }
 284   NS_HANDLER
 285     {
 286       message1 ("ns_string_from_pasteboard: UTF8String failed\n");
 287 #if defined (NS_IMPL_COCOA)
 288       utfStr = "Conversion failed";
 289 #else
 290       utfStr = [str lossyCString];
 291 #endif
 292       length = strlen (utfStr);
 293     }
 294   NS_ENDHANDLER
 295
 296     return make_string (utfStr, length);
 297 }
 298
 299
 300 void
 301 ns_string_to_pasteboard (id pb, Lisp_Object str)
 302 {
 303   ns_string_to_pasteboard_internal (pb, str, nil);
 304 }
 305
 306
 307
 308 /* ==========================================================================
 309
 310     Lisp Defuns
 311
 312    ========================================================================== */
 313
 314
 315 DEFUN ("ns-own-selection-internal", Fns_own_selection_internal,
 316        Sns_own_selection_internal, 2, 2, 0,
 317        doc: /* Assert an X selection of type SELECTION and value VALUE.
 318 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 319 \(Those are literal upper-case symbol names, since that's what X expects.)
 320 VALUE is typically a string, or a cons of two markers, but may be
 321 anything that the functions on `selection-converter-alist' know about.  */)
 322      (Lisp_Object selection, Lisp_Object value)
 323 {
 324   id pb;
 325   NSString *type;
 326   Lisp_Object successful_p = Qnil, rest;
 327   Lisp_Object target_symbol;
 328
 329   check_window_system (NULL);
 330   CHECK_SYMBOL (selection);
 331   if (NILP (value))
 332     error ("Selection value may not be nil");
 333   pb = ns_symbol_to_pb (selection);
 334   if (pb == nil) return Qnil;
 335
 336   ns_declare_pasteboard (pb);
 337   {
 338     Lisp_Object old_value = assq_no_quit (selection, Vselection_alist);
 339     Lisp_Object new_value = list2 (selection, value);
 340
 341     if (NILP (old_value))
 342       Vselection_alist = Fcons (new_value, Vselection_alist);
 343     else
 344       Fsetcdr (old_value, Fcdr (new_value));
 345   }
 346
 347   /* We only support copy of text.  */
 348   type = NSStringPboardType;
 349   target_symbol = ns_string_to_symbol (type);
 350   if (STRINGP (value))
 351     {
 352       ns_string_to_pasteboard_internal (pb, value, type);
 353       successful_p = Qt;
 354     }
 355
 356   if (!EQ (Vns_sent_selection_hooks, Qunbound))
 357     {
 358       /* FIXME: Use run-hook-with-args!  */
 359       for (rest = Vns_sent_selection_hooks; CONSP (rest); rest = Fcdr (rest))
 360         call3 (Fcar (rest), selection, target_symbol, successful_p);
 361     }
 362
 363   return value;
 364 }
 365
 366
 367 DEFUN ("ns-disown-selection-internal", Fns_disown_selection_internal,
 368        Sns_disown_selection_internal, 1, 1, 0,
 369        doc: /* If we own the selection SELECTION, disown it.
 370 Disowning it means there is no such selection.  */)
 371   (Lisp_Object selection)
 372 {
 373   id pb;
 374   check_window_system (NULL);
 375   CHECK_SYMBOL (selection);
 376
 377   if (ns_get_pb_change_count (selection)
 378       != ns_get_our_change_count_for (selection))
 379       return Qnil;
 380
 381   pb = ns_symbol_to_pb (selection);
 382   if (pb != nil) ns_undeclare_pasteboard (pb);
 383   return Qt;
 384 }
 385
 386
 387 DEFUN ("ns-selection-exists-p", Fns_selection_exists_p, Sns_selection_exists_p,
 388        0, 1, 0, doc: /* Whether there is an owner for the given X selection.
 389 SELECTION should be the name of the selection in question, typically
 390 one of the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.  (X expects
 391 these literal upper-case names.)  The symbol nil is the same as
 392 `PRIMARY', and t is the same as `SECONDARY'.  */)
 393      (Lisp_Object selection)
 394 {
 395   id pb;
 396   NSArray *types;
 397
 398   if (!window_system_available (NULL))
 399     return Qnil;
 400
 401   CHECK_SYMBOL (selection);
 402   if (EQ (selection, Qnil)) selection = QPRIMARY;
 403   if (EQ (selection, Qt)) selection = QSECONDARY;
 404   pb = ns_symbol_to_pb (selection);
 405   if (pb == nil) return Qnil;
 406
 407   types = [pb types];
 408   return ([types count] == 0) ? Qnil : Qt;
 409 }
 410
 411
 412 DEFUN ("ns-selection-owner-p", Fns_selection_owner_p, Sns_selection_owner_p,
 413        0, 1, 0,
 414        doc: /* Whether the current Emacs process owns the given X Selection.
 415 The arg should be the name of the selection in question, typically one of
 416 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 417 \(Those are literal upper-case symbol names, since that's what X expects.)
 418 For convenience, the symbol nil is the same as `PRIMARY',
 419 and t is the same as `SECONDARY'.  */)
 420      (Lisp_Object selection)
 421 {
 422   check_window_system (NULL);
 423   CHECK_SYMBOL (selection);
 424   if (EQ (selection, Qnil)) selection = QPRIMARY;
 425   if (EQ (selection, Qt)) selection = QSECONDARY;
 426   return ns_get_pb_change_count (selection)
 427     == ns_get_our_change_count_for (selection)
 428     ? Qt : Qnil;
 429 }
 430
 431
 432 DEFUN ("ns-get-selection", Fns_get_selection,
 433        Sns_get_selection, 2, 2, 0,
 434        doc: /* Return text selected from some X window.
 435 SELECTION-SYMBOL is typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 436 \(Those are literal upper-case symbol names, since that's what X expects.)
 437 TARGET-TYPE is the type of data desired, typically `STRING'.  */)
 438      (Lisp_Object selection_name, Lisp_Object target_type)
 439 {
 440   Lisp_Object val = Qnil;
 441
 442   check_window_system (NULL);
 443   CHECK_SYMBOL (selection_name);
 444   CHECK_SYMBOL (target_type);
 445
 446   if (ns_get_pb_change_count (selection_name)
 447       == ns_get_our_change_count_for (selection_name))
 448       val = ns_get_local_selection (selection_name, target_type);
 449   if (NILP (val))
 450     val = ns_get_foreign_selection (selection_name, target_type);
 451   if (CONSP (val) && SYMBOLP (Fcar (val)))
 452     {
 453       val = Fcdr (val);
 454       if (CONSP (val) && NILP (Fcdr (val)))
 455         val = Fcar (val);
 456     }
 457   val = clean_local_selection_data (val);
 458   return val;
 459 }
 460
 461
 462 void
 463 nxatoms_of_nsselect (void)
 464 {
 465   NXPrimaryPboard = @"Selection";
 466   NXSecondaryPboard = @"Secondary";
 467
 468   // This is a memory loss, never released.
 469   pasteboard_changecount
 470     = [[NSMutableDictionary
 471          dictionaryWithObjectsAndKeys:
 472              [NSNumber numberWithLong:0], NSGeneralPboard,
 473              [NSNumber numberWithLong:0], NXPrimaryPboard,
 474              [NSNumber numberWithLong:0], NXSecondaryPboard,
 475              [NSNumber numberWithLong:0], NSStringPboardType,
 476              [NSNumber numberWithLong:0], NSFilenamesPboardType,
 477              [NSNumber numberWithLong:0], NSTabularTextPboardType,
 478          nil] retain];
 479 }
 480
 481 void
 482 syms_of_nsselect (void)
 483 {
 484   DEFSYM (QCLIPBOARD, "CLIPBOARD");
 485   DEFSYM (QSECONDARY, "SECONDARY");
 486   DEFSYM (QTEXT, "TEXT");
 487   DEFSYM (QFILE_NAME, "FILE_NAME");
 488
 489   defsubr (&Sns_disown_selection_internal);
 490   defsubr (&Sns_get_selection);
 491   defsubr (&Sns_own_selection_internal);
 492   defsubr (&Sns_selection_exists_p);
 493   defsubr (&Sns_selection_owner_p);
 494
 495   Vselection_alist = Qnil;
 496   staticpro (&Vselection_alist);
 497
 498   DEFVAR_LISP ("ns-sent-selection-hooks", Vns_sent_selection_hooks,
 499                "A list of functions to be called when Emacs answers a selection request.\n\
 500 The functions are called with four arguments:\n\
 501   - the selection name (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');\n\
 502   - the selection-type which Emacs was asked to convert the\n\
 503     selection into before sending (for example, `STRING' or `LENGTH');\n\
 504   - a flag indicating success or failure for responding to the request.\n\
 505 We might have failed (and declined the request) for any number of reasons,\n\
 506 including being asked for a selection that we no longer own, or being asked\n\
 507 to convert into a type that we don't know about or that is inappropriate.\n\
 508 This hook doesn't let you change the behavior of Emacs's selection replies,\n\
 509 it merely informs you that they have happened.");
 510   Vns_sent_selection_hooks = Qnil;
 511 }