src/macselect.c

   1 /* Selection processing for Emacs on Mac OS.
   2    Copyright (C) 2005, 2006 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 Boston, MA 02110-1301, USA.  */
  20
  21 #include <config.h>
  22
  23 #include "lisp.h"
  24 #include "macterm.h"
  25 #include "blockinput.h"
  26 #include "keymap.h"
  27
  28 #if !TARGET_API_MAC_CARBON
  29 #include <Endian.h>
  30 typedef int ScrapRef;
  31 typedef ResType ScrapFlavorType;
  32 #endif /* !TARGET_API_MAC_CARBON */
  33
  34 static OSStatus get_scrap_from_symbol P_ ((Lisp_Object, int, ScrapRef *));
  35 static ScrapFlavorType get_flavor_type_from_symbol P_ ((Lisp_Object));
  36 static int valid_scrap_target_type_p P_ ((Lisp_Object));
  37 static OSStatus clear_scrap P_ ((ScrapRef *));
  38 static OSStatus put_scrap_string P_ ((ScrapRef, Lisp_Object, Lisp_Object));
  39 static OSStatus put_scrap_private_timestamp P_ ((ScrapRef, unsigned long));
  40 static ScrapFlavorType scrap_has_target_type P_ ((ScrapRef, Lisp_Object));
  41 static Lisp_Object get_scrap_string P_ ((ScrapRef, Lisp_Object));
  42 static OSStatus get_scrap_private_timestamp P_ ((ScrapRef, unsigned long *));
  43 static Lisp_Object get_scrap_target_type_list P_ ((ScrapRef));
  44 static void x_own_selection P_ ((Lisp_Object, Lisp_Object));
  45 static Lisp_Object x_get_local_selection P_ ((Lisp_Object, Lisp_Object, int));
  46 static Lisp_Object x_get_foreign_selection P_ ((Lisp_Object,
  47                                                 Lisp_Object,
  48                                                 Lisp_Object));
  49 EXFUN (Fx_selection_owner_p, 1);
  50 #ifdef MAC_OSX
  51 static OSStatus mac_handle_service_event P_ ((EventHandlerCallRef,
  52                                               EventRef, void *));
  53 void init_service_handler P_ ((void));
  54 #endif
  55
  56 Lisp_Object QPRIMARY, QSECONDARY, QTIMESTAMP, QTARGETS;
  57
  58 static Lisp_Object Vx_lost_selection_functions;
  59 /* Coding system for communicating with other programs via scrap.  */
  60 static Lisp_Object Vselection_coding_system;
  61
  62 /* Coding system for the next communicating with other programs.  */
  63 static Lisp_Object Vnext_selection_coding_system;
  64
  65 static Lisp_Object Qforeign_selection;
  66
  67 /* The timestamp of the last input event Emacs received from the
  68    window server.  */
  69 /* Defined in keyboard.c.  */
  70 extern unsigned long last_event_timestamp;
  71
  72 /* This is an association list whose elements are of the form
  73      ( SELECTION-NAME SELECTION-VALUE SELECTION-TIMESTAMP FRAME)
  74    SELECTION-NAME is a lisp symbol.
  75    SELECTION-VALUE is the value that emacs owns for that selection.
  76      It may be any kind of Lisp object.
  77    SELECTION-TIMESTAMP is the time at which emacs began owning this selection,
  78      as a cons of two 16-bit numbers (making a 32 bit time.)
  79    FRAME is the frame for which we made the selection.
  80    If there is an entry in this alist, and the data for the flavor
  81      type SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP in the corresponding scrap
  82      (if exists) coincides with SELECTION-TIMESTAMP, then it can be
  83      assumed that Emacs owns that selection.
  84    The only (eq) parts of this list that are visible from Lisp are the
  85     selection-values.  */
  86 static Lisp_Object Vselection_alist;
  87
  88 #define SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP 'Etsp'
  89
  90 /* This is an alist whose CARs are selection-types and whose CDRs are
  91    the names of Lisp functions to call to convert the given Emacs
  92    selection value to a string representing the given selection type.
  93    This is for Lisp-level extension of the emacs selection
  94    handling.  */
  95 static Lisp_Object Vselection_converter_alist;
  96
  97 /* A selection name (represented as a Lisp symbol) can be associated
  98    with a named scrap via `mac-scrap-name' property.  Likewise for a
  99    selection type with a scrap flavor type via `mac-ostype'.  */
 100 static Lisp_Object Qmac_scrap_name, Qmac_ostype;
 101
 102 #ifdef MAC_OSX
 103 /* Selection name for communication via Services menu.  */
 104 static Lisp_Object Vmac_service_selection;
 105 #endif
 106 \f
 107 /* Get a reference to the scrap corresponding to the symbol SYM.  The
 108    reference is set to *SCRAP, and it becomes NULL if there's no
 109    corresponding scrap.  Clear the scrap if CLEAR_P is non-zero.  */
 110
 111 static OSStatus
 112 get_scrap_from_symbol (sym, clear_p, scrap)
 113      Lisp_Object sym;
 114      int clear_p;
 115      ScrapRef *scrap;
 116 {
 117   OSStatus err = noErr;
 118   Lisp_Object str = Fget (sym, Qmac_scrap_name);
 119
 120   if (!STRINGP (str))
 121     *scrap = NULL;
 122   else
 123     {
 124 #if TARGET_API_MAC_CARBON
 125 #ifdef MAC_OSX
 126       CFStringRef scrap_name = cfstring_create_with_string (str);
 127       OptionBits options = (clear_p ? kScrapClearNamedScrap
 128                             : kScrapGetNamedScrap);
 129
 130       err = GetScrapByName (scrap_name, options, scrap);
 131       CFRelease (scrap_name);
 132 #else   /* !MAC_OSX */
 133       if (clear_p)
 134         err = ClearCurrentScrap ();
 135       if (err == noErr)
 136         err = GetCurrentScrap (scrap);
 137 #endif  /* !MAC_OSX */
 138 #else   /* !TARGET_API_MAC_CARBON */
 139       if (clear_p)
 140         err = ZeroScrap ();
 141       if (err == noErr)
 142         *scrap = 1;
 143 #endif  /* !TARGET_API_MAC_CARBON */
 144     }
 145
 146   return err;
 147 }
 148
 149 /* Get a scrap flavor type from the symbol SYM.  Return 0 if no
 150    corresponding flavor type.  */
 151
 152 static ScrapFlavorType
 153 get_flavor_type_from_symbol (sym)
 154      Lisp_Object sym;
 155 {
 156   Lisp_Object str = Fget (sym, Qmac_ostype);
 157
 158   if (STRINGP (str) && SBYTES (str) == 4)
 159     return EndianU32_BtoN (*((UInt32 *) SDATA (str)));
 160
 161   return 0;
 162 }
 163
 164 /* Check if the symbol SYM has a corresponding scrap flavor type.  */
 165
 166 static int
 167 valid_scrap_target_type_p (sym)
 168      Lisp_Object sym;
 169 {
 170   return get_flavor_type_from_symbol (sym) != 0;
 171 }
 172
 173 /* Clear the scrap whose reference is *SCRAP. */
 174
 175 static INLINE OSStatus
 176 clear_scrap (scrap)
 177      ScrapRef *scrap;
 178 {
 179 #if TARGET_API_MAC_CARBON
 180 #ifdef MAC_OSX
 181   return ClearScrap (scrap);
 182 #else
 183   return ClearCurrentScrap ();
 184 #endif
 185 #else  /* !TARGET_API_MAC_CARBON */
 186   return ZeroScrap ();
 187 #endif  /* !TARGET_API_MAC_CARBON */
 188 }
 189
 190 /* Put Lisp String STR to the scrap SCRAP.  The target type is
 191    specified by TYPE. */
 192
 193 static OSStatus
 194 put_scrap_string (scrap, type, str)
 195      ScrapRef scrap;
 196      Lisp_Object type, str;
 197 {
 198   ScrapFlavorType flavor_type = get_flavor_type_from_symbol (type);
 199
 200   if (flavor_type == 0)
 201     return noTypeErr;
 202
 203 #if TARGET_API_MAC_CARBON
 204   return PutScrapFlavor (scrap, flavor_type, kScrapFlavorMaskNone,
 205                          SBYTES (str), SDATA (str));
 206 #else  /* !TARGET_API_MAC_CARBON */
 207   return PutScrap (SBYTES (str), flavor_type, SDATA (str));
 208 #endif  /* !TARGET_API_MAC_CARBON */
 209 }
 210
 211 /* Put TIMESTAMP to the scrap SCRAP.  The timestamp is used for
 212    checking if the scrap is owned by the process.  */
 213
 214 static INLINE OSStatus
 215 put_scrap_private_timestamp (scrap, timestamp)
 216      ScrapRef scrap;
 217      unsigned long timestamp;
 218 {
 219 #if TARGET_API_MAC_CARBON
 220   return PutScrapFlavor (scrap, SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP,
 221                          kScrapFlavorMaskSenderOnly,
 222                          sizeof (timestamp), &timestamp);
 223 #else  /* !TARGET_API_MAC_CARBON */
 224   return PutScrap (sizeof (timestamp), SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP,
 225                    &timestamp);
 226 #endif  /* !TARGET_API_MAC_CARBON */
 227 }
 228
 229 /* Check if data for the target type TYPE is available in SCRAP.  */
 230
 231 static ScrapFlavorType
 232 scrap_has_target_type (scrap, type)
 233      ScrapRef scrap;
 234      Lisp_Object type;
 235 {
 236   OSStatus err;
 237   ScrapFlavorType flavor_type = get_flavor_type_from_symbol (type);
 238
 239   if (flavor_type)
 240     {
 241 #if TARGET_API_MAC_CARBON
 242       ScrapFlavorFlags flags;
 243
 244       err = GetScrapFlavorFlags (scrap, flavor_type, &flags);
 245       if (err != noErr)
 246         flavor_type = 0;
 247 #else  /* !TARGET_API_MAC_CARBON */
 248       SInt32 size, offset;
 249
 250       size = GetScrap (NULL, flavor_type, &offset);
 251       if (size < 0)
 252         flavor_type = 0;
 253 #endif  /* !TARGET_API_MAC_CARBON */
 254     }
 255
 256   return flavor_type;
 257 }
 258
 259 /* Get data for the target type TYPE from SCRAP and create a Lisp
 260    string.  Return nil if failed to get data.  */
 261
 262 static Lisp_Object
 263 get_scrap_string (scrap, type)
 264      ScrapRef scrap;
 265      Lisp_Object type;
 266 {
 267   OSStatus err;
 268   Lisp_Object result = Qnil;
 269   ScrapFlavorType flavor_type = get_flavor_type_from_symbol (type);
 270 #if TARGET_API_MAC_CARBON
 271   Size size;
 272
 273   if (flavor_type)
 274     {
 275       err = GetScrapFlavorSize (scrap, flavor_type, &size);
 276       if (err == noErr)
 277         {
 278           do
 279             {
 280               result = make_uninit_string (size);
 281               err = GetScrapFlavorData (scrap, flavor_type,
 282                                         &size, SDATA (result));
 283               if (err != noErr)
 284                 result = Qnil;
 285               else if (size < SBYTES (result))
 286                 result = make_unibyte_string (SDATA (result), size);
 287             }
 288           while (STRINGP (result) && size > SBYTES (result));
 289         }
 290     }
 291 #else
 292   Handle handle;
 293   SInt32 size, offset;
 294
 295   if (flavor_type)
 296     size = GetScrap (NULL, flavor_type, &offset);
 297   if (size >= 0)
 298     {
 299       handle = NewHandle (size);
 300       HLock (handle);
 301       size = GetScrap (handle, flavor_type, &offset);
 302       if (size >= 0)
 303         result = make_unibyte_string (*handle, size);
 304       DisposeHandle (handle);
 305     }
 306 #endif
 307
 308   return result;
 309 }
 310
 311 /* Get timestamp from the scrap SCRAP and set to *TIMPSTAMP.  */
 312
 313 static OSStatus
 314 get_scrap_private_timestamp (scrap, timestamp)
 315      ScrapRef scrap;
 316      unsigned long *timestamp;
 317 {
 318   OSStatus err = noErr;
 319 #if TARGET_API_MAC_CARBON
 320   ScrapFlavorFlags flags;
 321
 322   err = GetScrapFlavorFlags (scrap, SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP, &flags);
 323   if (err == noErr)
 324     {
 325       if (!(flags & kScrapFlavorMaskSenderOnly))
 326         err = noTypeErr;
 327       else
 328         {
 329           Size size = sizeof (*timestamp);
 330
 331           err = GetScrapFlavorData (scrap, SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP,
 332                                     &size, timestamp);
 333           if (err == noErr && size != sizeof (*timestamp))
 334             err = noTypeErr;
 335         }
 336     }
 337 #else  /* !TARGET_API_MAC_CARBON */
 338   Handle handle;
 339   SInt32 size, offset;
 340
 341   size = GetScrap (NULL, SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP, &offset);
 342   if (size == sizeof (*timestamp))
 343     {
 344       handle = NewHandle (size);
 345       HLock (handle);
 346       size = GetScrap (handle, SCRAP_FLAVOR_TYPE_EMACS_TIMESTAMP, &offset);
 347       if (size == sizeof (*timestamp))
 348         *timestamp = *((unsigned long *) *handle);
 349       DisposeHandle (handle);
 350     }
 351   if (size != sizeof (*timestamp))
 352     err = noTypeErr;
 353 #endif  /* !TARGET_API_MAC_CARBON */
 354
 355   return err;
 356 }
 357
 358 /* Get the list of target types in SCRAP.  The return value is a list
 359    of target type symbols possibly followed by scrap flavor type
 360    strings.  */
 361
 362 static Lisp_Object
 363 get_scrap_target_type_list (scrap)
 364      ScrapRef scrap;
 365 {
 366   Lisp_Object result = Qnil, rest, target_type;
 367 #if TARGET_API_MAC_CARBON
 368   OSStatus err;
 369   UInt32 count, i, type;
 370   ScrapFlavorInfo *flavor_info = NULL;
 371   Lisp_Object strings = Qnil;
 372
 373   err = GetScrapFlavorCount (scrap, &count);
 374   if (err == noErr)
 375     flavor_info = xmalloc (sizeof (ScrapFlavorInfo) * count);
 376   err = GetScrapFlavorInfoList (scrap, &count, flavor_info);
 377   if (err != noErr)
 378     {
 379       xfree (flavor_info);
 380       flavor_info = NULL;
 381     }
 382   if (flavor_info == NULL)
 383     count = 0;
 384 #endif
 385   for (rest = Vselection_converter_alist; CONSP (rest); rest = XCDR (rest))
 386     {
 387       ScrapFlavorType flavor_type = 0;
 388
 389       if (CONSP (XCAR (rest)) && SYMBOLP (target_type = XCAR (XCAR (rest)))
 390           && (flavor_type = scrap_has_target_type (scrap, target_type)))
 391         {
 392           result = Fcons (target_type, result);
 393 #if TARGET_API_MAC_CARBON
 394           for (i = 0; i < count; i++)
 395             if (flavor_info[i].flavorType == flavor_type)
 396               {
 397                 flavor_info[i].flavorType = 0;
 398                 break;
 399               }
 400 #endif
 401         }
 402     }
 403 #if TARGET_API_MAC_CARBON
 404   if (flavor_info)
 405     {
 406       for (i = 0; i < count; i++)
 407         if (flavor_info[i].flavorType)
 408           {
 409             type = EndianU32_NtoB (flavor_info[i].flavorType);
 410             strings = Fcons (make_unibyte_string ((char *) &type, 4), strings);
 411           }
 412       result = nconc2 (result, strings);
 413       xfree (flavor_info);
 414     }
 415 #endif
 416
 417   return result;
 418 }
 419 \f
 420 /* Do protocol to assert ourself as a selection owner.
 421    Update the Vselection_alist so that we can reply to later requests for
 422    our selection.  */
 423
 424 static void
 425 x_own_selection (selection_name, selection_value)
 426      Lisp_Object selection_name, selection_value;
 427 {
 428   OSStatus err;
 429   ScrapRef scrap;
 430   struct gcpro gcpro1, gcpro2;
 431   Lisp_Object rest, handler_fn, value, type;
 432   int count;
 433
 434   CHECK_SYMBOL (selection_name);
 435
 436   GCPRO2 (selection_name, selection_value);
 437
 438   BLOCK_INPUT;
 439
 440   err = get_scrap_from_symbol (selection_name, 1, &scrap);
 441   if (err == noErr && scrap)
 442     {
 443       /* Don't allow a quit within the converter.
 444          When the user types C-g, he would be surprised
 445          if by luck it came during a converter.  */
 446       count = SPECPDL_INDEX ();
 447       specbind (Qinhibit_quit, Qt);
 448
 449       for (rest = Vselection_converter_alist; CONSP (rest); rest = XCDR (rest))
 450         {
 451           if (!(CONSP (XCAR (rest))
 452                 && SYMBOLP (type = XCAR (XCAR (rest)))
 453                 && valid_scrap_target_type_p (type)
 454                 && SYMBOLP (handler_fn = XCDR (XCAR (rest)))))
 455             continue;
 456
 457           if (!NILP (handler_fn))
 458             value = call3 (handler_fn, selection_name,
 459                            type, selection_value);
 460
 461           if (STRINGP (value))
 462             err = put_scrap_string (scrap, type, value);
 463           else if (CONSP (value)
 464                    && EQ (XCAR (value), type)
 465                    && STRINGP (XCDR (value)))
 466             err = put_scrap_string (scrap, type, XCDR (value));
 467         }
 468
 469       unbind_to (count, Qnil);
 470
 471       if (err == noErr)
 472         err = put_scrap_private_timestamp (scrap, last_event_timestamp);
 473     }
 474
 475   UNBLOCK_INPUT;
 476
 477   UNGCPRO;
 478
 479   if (scrap && err != noErr)
 480     error ("Can't set selection");
 481
 482   /* Now update the local cache */
 483   {
 484     Lisp_Object selection_time;
 485     Lisp_Object selection_data;
 486     Lisp_Object prev_value;
 487
 488     selection_time = long_to_cons (last_event_timestamp);
 489     selection_data = Fcons (selection_name,
 490                             Fcons (selection_value,
 491                                    Fcons (selection_time,
 492                                           Fcons (selected_frame, Qnil))));
 493     prev_value = assq_no_quit (selection_name, Vselection_alist);
 494
 495     Vselection_alist = Fcons (selection_data, Vselection_alist);
 496
 497     /* If we already owned the selection, remove the old selection data.
 498        Perhaps we should destructively modify it instead.
 499        Don't use Fdelq as that may QUIT.  */
 500     if (!NILP (prev_value))
 501       {
 502         Lisp_Object rest;       /* we know it's not the CAR, so it's easy.  */
 503         for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
 504           if (EQ (prev_value, Fcar (XCDR (rest))))
 505             {
 506               XSETCDR (rest, Fcdr (XCDR (rest)));
 507               break;
 508             }
 509       }
 510   }
 511 }
 512 \f
 513 /* Given a selection-name and desired type, look up our local copy of
 514    the selection value and convert it to the type.
 515    The value is nil or a string.
 516    This function is used both for remote requests (LOCAL_REQUEST is zero)
 517    and for local x-get-selection-internal (LOCAL_REQUEST is nonzero).
 518
 519    This calls random Lisp code, and may signal or gc.  */
 520
 521 static Lisp_Object
 522 x_get_local_selection (selection_symbol, target_type, local_request)
 523      Lisp_Object selection_symbol, target_type;
 524      int local_request;
 525 {
 526   Lisp_Object local_value;
 527   Lisp_Object handler_fn, value, type, check;
 528   int count;
 529
 530   if (NILP (Fx_selection_owner_p (selection_symbol)))
 531     return Qnil;
 532
 533   local_value = assq_no_quit (selection_symbol, Vselection_alist);
 534
 535   /* TIMESTAMP is a special case 'cause that's easiest.  */
 536   if (EQ (target_type, QTIMESTAMP))
 537     {
 538       handler_fn = Qnil;
 539       value = XCAR (XCDR (XCDR (local_value)));
 540     }
 541 #if 0
 542   else if (EQ (target_type, QDELETE))
 543     {
 544       handler_fn = Qnil;
 545       Fx_disown_selection_internal
 546         (selection_symbol,
 547          XCAR (XCDR (XCDR (local_value))));
 548       value = QNULL;
 549     }
 550 #endif
 551   else
 552     {
 553       /* Don't allow a quit within the converter.
 554          When the user types C-g, he would be surprised
 555          if by luck it came during a converter.  */
 556       count = SPECPDL_INDEX ();
 557       specbind (Qinhibit_quit, Qt);
 558
 559       CHECK_SYMBOL (target_type);
 560       handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
 561       /* gcpro is not needed here since nothing but HANDLER_FN
 562          is live, and that ought to be a symbol.  */
 563
 564       if (!NILP (handler_fn))
 565         value = call3 (handler_fn,
 566                        selection_symbol, (local_request ? Qnil : target_type),
 567                        XCAR (XCDR (local_value)));
 568       else
 569         value = Qnil;
 570       unbind_to (count, Qnil);
 571     }
 572
 573   /* Make sure this value is of a type that we could transmit
 574      to another X client.  */
 575
 576   check = value;
 577   if (CONSP (value)
 578       && SYMBOLP (XCAR (value)))
 579     type = XCAR (value),
 580     check = XCDR (value);
 581
 582   if (STRINGP (check)
 583       || VECTORP (check)
 584       || SYMBOLP (check)
 585       || INTEGERP (check)
 586       || NILP (value))
 587     return value;
 588   /* Check for a value that cons_to_long could handle.  */
 589   else if (CONSP (check)
 590            && INTEGERP (XCAR (check))
 591            && (INTEGERP (XCDR (check))
 592                ||
 593                (CONSP (XCDR (check))
 594                 && INTEGERP (XCAR (XCDR (check)))
 595                 && NILP (XCDR (XCDR (check))))))
 596     return value;
 597
 598   signal_error ("Invalid data returned by selection-conversion function",
 599                 list2 (handler_fn, value));
 600 }
 601
 602 \f
 603 /* Clear all selections that were made from frame F.
 604    We do this when about to delete a frame.  */
 605
 606 void
 607 x_clear_frame_selections (f)
 608      FRAME_PTR f;
 609 {
 610   Lisp_Object frame;
 611   Lisp_Object rest;
 612
 613   XSETFRAME (frame, f);
 614
 615   /* Otherwise, we're really honest and truly being told to drop it.
 616      Don't use Fdelq as that may QUIT;.  */
 617
 618   /* Delete elements from the beginning of Vselection_alist.  */
 619   while (!NILP (Vselection_alist)
 620          && EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (Vselection_alist)))))))
 621     {
 622       /* Let random Lisp code notice that the selection has been stolen.  */
 623       Lisp_Object hooks, selection_symbol;
 624
 625       hooks = Vx_lost_selection_functions;
 626       selection_symbol = Fcar (Fcar (Vselection_alist));
 627
 628       if (!EQ (hooks, Qunbound)
 629           && !NILP (Fx_selection_owner_p (selection_symbol)))
 630         {
 631           for (; CONSP (hooks); hooks = Fcdr (hooks))
 632             call1 (Fcar (hooks), selection_symbol);
 633 #if 0 /* This can crash when deleting a frame
 634          from x_connection_closed.  Anyway, it seems unnecessary;
 635          something else should cause a redisplay.  */
 636           redisplay_preserve_echo_area (21);
 637 #endif
 638         }
 639
 640       Vselection_alist = Fcdr (Vselection_alist);
 641     }
 642
 643   /* Delete elements after the beginning of Vselection_alist.  */
 644   for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
 645     if (EQ (frame, Fcar (Fcdr (Fcdr (Fcdr (Fcar (XCDR (rest))))))))
 646       {
 647         /* Let random Lisp code notice that the selection has been stolen.  */
 648         Lisp_Object hooks, selection_symbol;
 649
 650         hooks = Vx_lost_selection_functions;
 651         selection_symbol = Fcar (Fcar (XCDR (rest)));
 652
 653         if (!EQ (hooks, Qunbound)
 654           && !NILP (Fx_selection_owner_p (selection_symbol)))
 655           {
 656             for (; CONSP (hooks); hooks = Fcdr (hooks))
 657               call1 (Fcar (hooks), selection_symbol);
 658 #if 0 /* See above */
 659             redisplay_preserve_echo_area (22);
 660 #endif
 661           }
 662         XSETCDR (rest, Fcdr (XCDR (rest)));
 663         break;
 664       }
 665 }
 666 \f
 667 /* Do protocol to read selection-data from the server.
 668    Converts this to Lisp data and returns it.  */
 669
 670 static Lisp_Object
 671 x_get_foreign_selection (selection_symbol, target_type, time_stamp)
 672      Lisp_Object selection_symbol, target_type, time_stamp;
 673 {
 674   OSStatus err;
 675   ScrapRef scrap;
 676   Lisp_Object result = Qnil;
 677
 678   BLOCK_INPUT;
 679
 680   err = get_scrap_from_symbol (selection_symbol, 0, &scrap);
 681   if (err == noErr && scrap)
 682     {
 683       if (EQ (target_type, QTARGETS))
 684         {
 685           result = get_scrap_target_type_list (scrap);
 686           result = Fvconcat (1, &result);
 687         }
 688       else
 689         {
 690           result = get_scrap_string (scrap, target_type);
 691           if (STRINGP (result))
 692             Fput_text_property (make_number (0), make_number (SBYTES (result)),
 693                                 Qforeign_selection, target_type, result);
 694         }
 695     }
 696
 697   UNBLOCK_INPUT;
 698
 699   return result;
 700 }
 701
 702
 703 DEFUN ("x-own-selection-internal", Fx_own_selection_internal,
 704        Sx_own_selection_internal, 2, 2, 0,
 705        doc: /* Assert a selection of the given TYPE with the given VALUE.
 706 TYPE is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 707 VALUE is typically a string, or a cons of two markers, but may be
 708 anything that the functions on `selection-converter-alist' know about.  */)
 709      (selection_name, selection_value)
 710      Lisp_Object selection_name, selection_value;
 711 {
 712   check_mac ();
 713   CHECK_SYMBOL (selection_name);
 714   if (NILP (selection_value)) error ("SELECTION-VALUE may not be nil");
 715   x_own_selection (selection_name, selection_value);
 716   return selection_value;
 717 }
 718
 719
 720 /* Request the selection value from the owner.  If we are the owner,
 721    simply return our selection value.  If we are not the owner, this
 722    will block until all of the data has arrived.  */
 723
 724 DEFUN ("x-get-selection-internal", Fx_get_selection_internal,
 725        Sx_get_selection_internal, 2, 3, 0,
 726        doc: /* Return text selected from some Mac application.
 727 SELECTION is a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 728 TYPE is the type of data desired, typically `STRING'.
 729 TIME_STAMP is ignored on Mac.  */)
 730      (selection_symbol, target_type, time_stamp)
 731      Lisp_Object selection_symbol, target_type, time_stamp;
 732 {
 733   Lisp_Object val = Qnil;
 734   struct gcpro gcpro1, gcpro2;
 735   GCPRO2 (target_type, val); /* we store newly consed data into these */
 736   check_mac ();
 737   CHECK_SYMBOL (selection_symbol);
 738   CHECK_SYMBOL (target_type);
 739
 740   val = x_get_local_selection (selection_symbol, target_type, 1);
 741
 742   if (NILP (val))
 743     {
 744       val = x_get_foreign_selection (selection_symbol, target_type, time_stamp);
 745       goto DONE;
 746     }
 747
 748   if (CONSP (val)
 749       && SYMBOLP (XCAR (val)))
 750     {
 751       val = XCDR (val);
 752       if (CONSP (val) && NILP (XCDR (val)))
 753         val = XCAR (val);
 754     }
 755  DONE:
 756   UNGCPRO;
 757   return val;
 758 }
 759
 760 DEFUN ("x-disown-selection-internal", Fx_disown_selection_internal,
 761        Sx_disown_selection_internal, 1, 2, 0,
 762        doc: /* If we own the selection SELECTION, disown it.
 763 Disowning it means there is no such selection.  */)
 764      (selection, time)
 765      Lisp_Object selection;
 766      Lisp_Object time;
 767 {
 768   OSStatus err;
 769   ScrapRef scrap;
 770   Lisp_Object local_selection_data;
 771
 772   check_mac ();
 773   CHECK_SYMBOL (selection);
 774
 775   if (NILP (Fx_selection_owner_p (selection)))
 776     return Qnil;  /* Don't disown the selection when we're not the owner.  */
 777
 778   local_selection_data = assq_no_quit (selection, Vselection_alist);
 779
 780   /* Don't use Fdelq as that may QUIT;.  */
 781
 782   if (EQ (local_selection_data, Fcar (Vselection_alist)))
 783     Vselection_alist = Fcdr (Vselection_alist);
 784   else
 785     {
 786       Lisp_Object rest;
 787       for (rest = Vselection_alist; !NILP (rest); rest = Fcdr (rest))
 788         if (EQ (local_selection_data, Fcar (XCDR (rest))))
 789           {
 790             XSETCDR (rest, Fcdr (XCDR (rest)));
 791             break;
 792           }
 793     }
 794
 795   /* Let random lisp code notice that the selection has been stolen.  */
 796
 797   {
 798     Lisp_Object rest;
 799     rest = Vx_lost_selection_functions;
 800     if (!EQ (rest, Qunbound))
 801       {
 802         for (; CONSP (rest); rest = Fcdr (rest))
 803           call1 (Fcar (rest), selection);
 804         prepare_menu_bars ();
 805         redisplay_preserve_echo_area (20);
 806       }
 807   }
 808
 809   BLOCK_INPUT;
 810
 811   err = get_scrap_from_symbol (selection, 0, &scrap);
 812   if (err == noErr && scrap)
 813     clear_scrap (&scrap);
 814
 815   UNBLOCK_INPUT;
 816
 817   return Qt;
 818 }
 819
 820
 821 DEFUN ("x-selection-owner-p", Fx_selection_owner_p, Sx_selection_owner_p,
 822        0, 1, 0,
 823        doc: /* Whether the current Emacs process owns the given SELECTION.
 824 The arg should be the name of the selection in question, typically one of
 825 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 826 For convenience, the symbol nil is the same as `PRIMARY',
 827 and t is the same as `SECONDARY'.  */)
 828      (selection)
 829      Lisp_Object selection;
 830 {
 831   OSStatus err;
 832   ScrapRef scrap;
 833   Lisp_Object result = Qnil, local_selection_data;
 834
 835   check_mac ();
 836   CHECK_SYMBOL (selection);
 837   if (EQ (selection, Qnil)) selection = QPRIMARY;
 838   if (EQ (selection, Qt)) selection = QSECONDARY;
 839
 840   local_selection_data = assq_no_quit (selection, Vselection_alist);
 841
 842   if (NILP (local_selection_data))
 843     return Qnil;
 844
 845   BLOCK_INPUT;
 846
 847   err = get_scrap_from_symbol (selection, 0, &scrap);
 848   if (err == noErr && scrap)
 849     {
 850       unsigned long timestamp;
 851
 852       err = get_scrap_private_timestamp (scrap, &timestamp);
 853       if (err == noErr
 854           && (timestamp
 855               == cons_to_long (XCAR (XCDR (XCDR (local_selection_data))))))
 856         result = Qt;
 857     }
 858   else
 859     result = Qt;
 860
 861   UNBLOCK_INPUT;
 862
 863   return result;
 864 }
 865
 866 DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p,
 867        0, 1, 0,
 868        doc: /* Whether there is an owner for the given SELECTION.
 869 The arg should be the name of the selection in question, typically one of
 870 the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'.
 871 For convenience, the symbol nil is the same as `PRIMARY',
 872 and t is the same as `SECONDARY'.  */)
 873      (selection)
 874      Lisp_Object selection;
 875 {
 876   OSStatus err;
 877   ScrapRef scrap;
 878   Lisp_Object result = Qnil, rest;
 879
 880   /* It should be safe to call this before we have an Mac frame.  */
 881   if (! FRAME_MAC_P (SELECTED_FRAME ()))
 882     return Qnil;
 883
 884   CHECK_SYMBOL (selection);
 885   if (!NILP (Fx_selection_owner_p (selection)))
 886     return Qt;
 887   if (EQ (selection, Qnil)) selection = QPRIMARY;
 888   if (EQ (selection, Qt)) selection = QSECONDARY;
 889
 890   BLOCK_INPUT;
 891
 892   err = get_scrap_from_symbol (selection, 0, &scrap);
 893   if (err == noErr && scrap)
 894     for (rest = Vselection_converter_alist; CONSP (rest); rest = XCDR (rest))
 895       {
 896         if (CONSP (XCAR (rest)) && SYMBOLP (XCAR (XCAR (rest)))
 897             && scrap_has_target_type (scrap, XCAR (XCAR (rest))))
 898           {
 899             result = Qt;
 900             break;
 901           }
 902       }
 903
 904   UNBLOCK_INPUT;
 905
 906   return result;
 907 }
 908
 909 \f
 910 /***********************************************************************
 911                          Apple event support
 912 ***********************************************************************/
 913 int mac_ready_for_apple_events = 0;
 914 static Lisp_Object Vmac_apple_event_map;
 915 static Lisp_Object Qmac_apple_event_class, Qmac_apple_event_id;
 916 static Lisp_Object Qemacs_suspension_id;
 917 extern Lisp_Object Qundefined;
 918 extern void mac_store_apple_event P_ ((Lisp_Object, Lisp_Object,
 919                                        const AEDesc *));
 920
 921 struct apple_event_binding
 922 {
 923   UInt32 code;                  /* Apple event class or ID.  */
 924   Lisp_Object key, binding;
 925 };
 926
 927 struct suspended_ae_info
 928 {
 929   UInt32 expiration_tick, suspension_id;
 930   AppleEvent apple_event, reply;
 931   struct suspended_ae_info *next;
 932 };
 933
 934 /* List of apple events deferred at the startup time.  */
 935 static struct suspended_ae_info *deferred_apple_events = NULL;
 936
 937 /* List of suspended apple events, in order of expiration_tick.  */
 938 static struct suspended_ae_info *suspended_apple_events = NULL;
 939
 940 static void
 941 find_event_binding_fun (key, binding, args, data)
 942      Lisp_Object key, binding, args;
 943      void *data;
 944 {
 945   struct apple_event_binding *event_binding =
 946     (struct apple_event_binding *)data;
 947   Lisp_Object code_string;
 948
 949   if (!SYMBOLP (key))
 950     return;
 951   code_string = Fget (key, args);
 952   if (STRINGP (code_string) && SBYTES (code_string) == 4
 953       && (EndianU32_BtoN (*((UInt32 *) SDATA (code_string)))
 954           == event_binding->code))
 955     {
 956       event_binding->key = key;
 957       event_binding->binding = binding;
 958     }
 959 }
 960
 961 static void
 962 find_event_binding (keymap, event_binding, class_p)
 963      Lisp_Object keymap;
 964      struct apple_event_binding *event_binding;
 965      int class_p;
 966 {
 967   if (event_binding->code == 0)
 968     event_binding->binding =
 969       access_keymap (keymap, event_binding->key, 0, 1, 0);
 970   else
 971     {
 972       event_binding->binding = Qnil;
 973       map_keymap (keymap, find_event_binding_fun,
 974                   class_p ? Qmac_apple_event_class : Qmac_apple_event_id,
 975                   event_binding, 0);
 976     }
 977 }
 978
 979 void
 980 mac_find_apple_event_spec (class, id, class_key, id_key, binding)
 981      AEEventClass class;
 982      AEEventID id;
 983      Lisp_Object *class_key, *id_key, *binding;
 984 {
 985   struct apple_event_binding event_binding;
 986   Lisp_Object keymap;
 987
 988   *binding = Qnil;
 989
 990   keymap = get_keymap (Vmac_apple_event_map, 0, 0);
 991   if (NILP (keymap))
 992     return;
 993
 994   event_binding.code = class;
 995   event_binding.key = *class_key;
 996   event_binding.binding = Qnil;
 997   find_event_binding (keymap, &event_binding, 1);
 998   *class_key = event_binding.key;
 999   keymap = get_keymap (event_binding.binding, 0, 0);
1000   if (NILP (keymap))
1001     return;
1002
1003   event_binding.code = id;
1004   event_binding.key = *id_key;
1005   event_binding.binding = Qnil;
1006   find_event_binding (keymap, &event_binding, 0);
1007   *id_key = event_binding.key;
1008   *binding = event_binding.binding;
1009 }
1010
1011 static OSErr
1012 defer_apple_events (apple_event, reply)
1013      const AppleEvent *apple_event, *reply;
1014 {
1015   OSErr err;
1016   struct suspended_ae_info *new;
1017
1018   new = xmalloc (sizeof (struct suspended_ae_info));
1019   bzero (new, sizeof (struct suspended_ae_info));
1020   new->apple_event.descriptorType = typeNull;
1021   new->reply.descriptorType = typeNull;
1022
1023   err = AESuspendTheCurrentEvent (apple_event);
1024
1025   /* Mac OS 10.3 Xcode manual says AESuspendTheCurrentEvent makes
1026      copies of the Apple event and the reply, but Mac OS 10.4 Xcode
1027      manual says it doesn't.  Anyway we create copies of them and save
1028      them in `deferred_apple_events'.  */
1029   if (err == noErr)
1030     err = AEDuplicateDesc (apple_event, &new->apple_event);
1031   if (err == noErr)
1032     err = AEDuplicateDesc (reply, &new->reply);
1033   if (err == noErr)
1034     {
1035       new->next = deferred_apple_events;
1036       deferred_apple_events = new;
1037     }
1038   else
1039     {
1040       AEDisposeDesc (&new->apple_event);
1041       AEDisposeDesc (&new->reply);
1042       xfree (new);
1043     }
1044
1045   return err;
1046 }
1047
1048 static OSErr
1049 mac_handle_apple_event_1 (class, id, apple_event, reply)
1050      Lisp_Object class, id;
1051      const AppleEvent *apple_event;
1052      AppleEvent *reply;
1053 {
1054   OSErr err;
1055   static UInt32 suspension_id = 0;
1056   struct suspended_ae_info *new;
1057
1058   new = xmalloc (sizeof (struct suspended_ae_info));
1059   bzero (new, sizeof (struct suspended_ae_info));
1060   new->apple_event.descriptorType = typeNull;
1061   new->reply.descriptorType = typeNull;
1062
1063   err = AESuspendTheCurrentEvent (apple_event);
1064   if (err == noErr)
1065     err = AEDuplicateDesc (apple_event, &new->apple_event);
1066   if (err == noErr)
1067     err = AEDuplicateDesc (reply, &new->reply);
1068   if (err == noErr)
1069     err = AEPutAttributePtr (&new->apple_event, KEY_EMACS_SUSPENSION_ID_ATTR,
1070                              typeUInt32, &suspension_id, sizeof (UInt32));
1071   if (err == noErr)
1072     {
1073       OSErr err1;
1074       SInt32 reply_requested;
1075
1076       err1 = AEGetAttributePtr (&new->apple_event, keyReplyRequestedAttr,
1077                                 typeSInt32, NULL, &reply_requested,
1078                                 sizeof (SInt32), NULL);
1079       if (err1 != noErr)
1080         {
1081           /* Emulate keyReplyRequestedAttr in older versions.  */
1082           reply_requested = reply->descriptorType != typeNull;
1083           err = AEPutAttributePtr (&new->apple_event, keyReplyRequestedAttr,
1084                                    typeSInt32, &reply_requested,
1085                                    sizeof (SInt32));
1086         }
1087     }
1088   if (err == noErr)
1089     {
1090       SInt32 timeout = 0;
1091       struct suspended_ae_info **p;
1092
1093       new->suspension_id = suspension_id;
1094       suspension_id++;
1095       err = AEGetAttributePtr (apple_event, keyTimeoutAttr, typeSInt32,
1096                                NULL, &timeout, sizeof (SInt32), NULL);
1097       new->expiration_tick = TickCount () + timeout;
1098
1099       for (p = &suspended_apple_events; *p; p = &(*p)->next)
1100         if ((*p)->expiration_tick >= new->expiration_tick)
1101           break;
1102       new->next = *p;
1103       *p = new;
1104
1105       mac_store_apple_event (class, id, &new->apple_event);
1106     }
1107   else
1108     {
1109       AEDisposeDesc (&new->reply);
1110       AEDisposeDesc (&new->apple_event);
1111       xfree (new);
1112     }
1113
1114   return err;
1115 }
1116
1117 static pascal OSErr
1118 mac_handle_apple_event (apple_event, reply, refcon)
1119      const AppleEvent *apple_event;
1120      AppleEvent *reply;
1121      SInt32 refcon;
1122 {
1123   OSErr err;
1124   UInt32 suspension_id;
1125   AEEventClass event_class;
1126   AEEventID event_id;
1127   Lisp_Object class_key, id_key, binding;
1128
1129   if (!mac_ready_for_apple_events)
1130     {
1131       err = defer_apple_events (apple_event, reply);
1132       if (err != noErr)
1133         return errAEEventNotHandled;
1134       return noErr;
1135     }
1136
1137   err = AEGetAttributePtr (apple_event, KEY_EMACS_SUSPENSION_ID_ATTR,
1138                            typeUInt32, NULL,
1139                            &suspension_id, sizeof (UInt32), NULL);
1140   if (err == noErr)
1141     /* Previously suspended event.  Pass it to the next handler.  */
1142     return errAEEventNotHandled;
1143
1144   err = AEGetAttributePtr (apple_event, keyEventClassAttr, typeType, NULL,
1145                            &event_class, sizeof (AEEventClass), NULL);
1146   if (err == noErr)
1147     err = AEGetAttributePtr (apple_event, keyEventIDAttr, typeType, NULL,
1148                              &event_id, sizeof (AEEventID), NULL);
1149   if (err == noErr)
1150     {
1151       mac_find_apple_event_spec (event_class, event_id,
1152                                  &class_key, &id_key, &binding);
1153       if (!NILP (binding) && !EQ (binding, Qundefined))
1154         {
1155           if (INTEGERP (binding))
1156             return XINT (binding);
1157           err = mac_handle_apple_event_1 (class_key, id_key,
1158                                           apple_event, reply);
1159         }
1160       else
1161         err = errAEEventNotHandled;
1162     }
1163   if (err == noErr)
1164     return noErr;
1165   else
1166     return errAEEventNotHandled;
1167 }
1168
1169 static int
1170 cleanup_suspended_apple_events (head, all_p)
1171      struct suspended_ae_info **head;
1172      int all_p;
1173 {
1174   UInt32 current_tick = TickCount (), nresumed = 0;
1175   struct suspended_ae_info *p, *next;
1176
1177   for (p = *head; p; p = next)
1178     {
1179       if (!all_p && p->expiration_tick > current_tick)
1180         break;
1181       AESetTheCurrentEvent (&p->apple_event);
1182       AEResumeTheCurrentEvent (&p->apple_event, &p->reply,
1183                                (AEEventHandlerUPP) kAENoDispatch, 0);
1184       AEDisposeDesc (&p->reply);
1185       AEDisposeDesc (&p->apple_event);
1186       nresumed++;
1187       next = p->next;
1188       xfree (p);
1189     }
1190   *head = p;
1191
1192   return nresumed;
1193 }
1194
1195 static void
1196 cleanup_all_suspended_apple_events ()
1197 {
1198   cleanup_suspended_apple_events (&deferred_apple_events, 1);
1199   cleanup_suspended_apple_events (&suspended_apple_events, 1);
1200 }
1201
1202 void
1203 init_apple_event_handler ()
1204 {
1205   OSErr err;
1206   long result;
1207
1208   /* Make sure we have Apple events before starting.  */
1209   err = Gestalt (gestaltAppleEventsAttr, &result);
1210   if (err != noErr)
1211     abort ();
1212
1213   if (!(result & (1 << gestaltAppleEventsPresent)))
1214     abort ();
1215
1216   err = AEInstallEventHandler (typeWildCard, typeWildCard,
1217 #if TARGET_API_MAC_CARBON
1218                                NewAEEventHandlerUPP (mac_handle_apple_event),
1219 #else
1220                                NewAEEventHandlerProc (mac_handle_apple_event),
1221 #endif
1222                                0L, false);
1223   if (err != noErr)
1224     abort ();
1225
1226   atexit (cleanup_all_suspended_apple_events);
1227 }
1228
1229 static UInt32
1230 get_suspension_id (apple_event)
1231      Lisp_Object apple_event;
1232 {
1233   Lisp_Object tem;
1234
1235   CHECK_CONS (apple_event);
1236   CHECK_STRING_CAR (apple_event);
1237   if (SBYTES (XCAR (apple_event)) != 4
1238       || strcmp (SDATA (XCAR (apple_event)), "aevt") != 0)
1239     error ("Not an apple event");
1240
1241   tem = assq_no_quit (Qemacs_suspension_id, XCDR (apple_event));
1242   if (NILP (tem))
1243     error ("Suspension ID not available");
1244
1245   tem = XCDR (tem);
1246   if (!(CONSP (tem)
1247         && STRINGP (XCAR (tem)) && SBYTES (XCAR (tem)) == 4
1248         && strcmp (SDATA (XCAR (tem)), "magn") == 0
1249         && STRINGP (XCDR (tem)) && SBYTES (XCDR (tem)) == 4))
1250     error ("Bad suspension ID format");
1251
1252   return *((UInt32 *) SDATA (XCDR (tem)));
1253 }
1254
1255
1256 DEFUN ("mac-process-deferred-apple-events", Fmac_process_deferred_apple_events, Smac_process_deferred_apple_events, 0, 0, 0,
1257        doc: /* Process Apple events that are deferred at the startup time.  */)
1258   ()
1259 {
1260   if (mac_ready_for_apple_events)
1261     return Qnil;
1262
1263   BLOCK_INPUT;
1264   mac_ready_for_apple_events = 1;
1265   if (deferred_apple_events)
1266     {
1267       struct suspended_ae_info *prev, *tail, *next;
1268
1269       /* `nreverse' deferred_apple_events.  */
1270       prev = NULL;
1271       for (tail = deferred_apple_events; tail; tail = next)
1272         {
1273           next = tail->next;
1274           tail->next = prev;
1275           prev = tail;
1276         }
1277
1278       /* Now `prev' points to the first cell.  */
1279       for (tail = prev; tail; tail = next)
1280         {
1281           next = tail->next;
1282           AEResumeTheCurrentEvent (&tail->apple_event, &tail->reply,
1283                                    ((AEEventHandlerUPP)
1284                                     kAEUseStandardDispatch), 0);
1285           AEDisposeDesc (&tail->reply);
1286           AEDisposeDesc (&tail->apple_event);
1287           xfree (tail);
1288         }
1289
1290       deferred_apple_events = NULL;
1291     }
1292   UNBLOCK_INPUT;
1293
1294   return Qt;
1295 }
1296
1297 DEFUN ("mac-cleanup-expired-apple-events", Fmac_cleanup_expired_apple_events, Smac_cleanup_expired_apple_events, 0, 0, 0,
1298        doc: /* Clean up expired Apple events.
1299 Return the number of expired events.   */)
1300      ()
1301 {
1302   int nexpired;
1303
1304   BLOCK_INPUT;
1305   nexpired = cleanup_suspended_apple_events (&suspended_apple_events, 0);
1306   UNBLOCK_INPUT;
1307
1308   return make_number (nexpired);
1309 }
1310
1311 DEFUN ("mac-ae-set-reply-parameter", Fmac_ae_set_reply_parameter, Smac_ae_set_reply_parameter, 3, 3, 0,
1312        doc: /* Set parameter KEYWORD to DESCRIPTOR on reply of APPLE-EVENT.
1313 KEYWORD is a 4-byte string.  DESCRIPTOR is a Lisp representation of an
1314 Apple event descriptor.  It has the form of (TYPE . DATA), where TYPE
1315 is a 4-byte string.  Valid format of DATA is as follows:
1316
1317   * If TYPE is "null", then DATA is nil.
1318   * If TYPE is "list", then DATA is a list (DESCRIPTOR1 ... DESCRIPTORn).
1319   * If TYPE is "reco", then DATA is a list ((KEYWORD1 . DESCRIPTOR1)
1320     ... (KEYWORDn . DESCRIPTORn)).
1321   * If TYPE is "aevt", then DATA is ignored and the descriptor is
1322     treated as null.
1323   * Otherwise, DATA is a string.
1324
1325 If a (sub-)descriptor is in an invalid format, it is silently treated
1326 as null.
1327
1328 Return t if the parameter is successfully set.  Otherwise return nil.  */)
1329      (apple_event, keyword, descriptor)
1330      Lisp_Object apple_event, keyword, descriptor;
1331 {
1332   Lisp_Object result = Qnil;
1333   UInt32 suspension_id;
1334   struct suspended_ae_info *p;
1335
1336   suspension_id = get_suspension_id (apple_event);
1337
1338   CHECK_STRING (keyword);
1339   if (SBYTES (keyword) != 4)
1340     error ("Apple event keyword must be a 4-byte string: %s",
1341            SDATA (keyword));
1342
1343   BLOCK_INPUT;
1344   for (p = suspended_apple_events; p; p = p->next)
1345     if (p->suspension_id == suspension_id)
1346       break;
1347   if (p && p->reply.descriptorType != typeNull)
1348     {
1349       OSErr err;
1350
1351       err = mac_ae_put_lisp (&p->reply,
1352                              EndianU32_BtoN (*((UInt32 *) SDATA (keyword))),
1353                              descriptor);
1354       if (err == noErr)
1355         result = Qt;
1356     }
1357   UNBLOCK_INPUT;
1358
1359   return result;
1360 }
1361
1362 DEFUN ("mac-resume-apple-event", Fmac_resume_apple_event, Smac_resume_apple_event, 1, 2, 0,
1363        doc: /* Resume handling of APPLE-EVENT.
1364 Every Apple event handled by the Lisp interpreter is suspended first.
1365 This function resumes such a suspended event either to complete Apple
1366 event handling to give a reply, or to redispatch it to other handlers.
1367
1368 If optional ERROR-CODE is an integer, it specifies the error number
1369 that is set in the reply.  If ERROR-CODE is t, the resumed event is
1370 handled with the standard dispatching mechanism, but it is not handled
1371 by Emacs again, thus it is redispatched to other handlers.
1372
1373 Return t if APPLE-EVENT is successfully resumed.  Otherwise return
1374 nil, which means the event is already resumed or expired.  */)
1375      (apple_event, error_code)
1376      Lisp_Object apple_event, error_code;
1377 {
1378   Lisp_Object result = Qnil;
1379   UInt32 suspension_id;
1380   struct suspended_ae_info **p, *ae;
1381
1382   suspension_id = get_suspension_id (apple_event);
1383
1384   BLOCK_INPUT;
1385   for (p = &suspended_apple_events; *p; p = &(*p)->next)
1386     if ((*p)->suspension_id == suspension_id)
1387       break;
1388   if (*p)
1389     {
1390       ae = *p;
1391       *p = (*p)->next;
1392       if (INTEGERP (error_code)
1393           && ae->apple_event.descriptorType != typeNull)
1394         {
1395           SInt32 errn = XINT (error_code);
1396
1397           AEPutParamPtr (&ae->reply, keyErrorNumber, typeSInt32,
1398                          &errn, sizeof (SInt32));
1399         }
1400       AESetTheCurrentEvent (&ae->apple_event);
1401       AEResumeTheCurrentEvent (&ae->apple_event, &ae->reply,
1402                                ((AEEventHandlerUPP)
1403                                 (EQ (error_code, Qt) ?
1404                                  kAEUseStandardDispatch : kAENoDispatch)),
1405                                0);
1406       AEDisposeDesc (&ae->reply);
1407       AEDisposeDesc (&ae->apple_event);
1408       xfree (ae);
1409       result = Qt;
1410     }
1411   UNBLOCK_INPUT;
1412
1413   return result;
1414 }
1415
1416 \f
1417 /***********************************************************************
1418                       Drag and drop support
1419 ***********************************************************************/
1420 #if TARGET_API_MAC_CARBON
1421 static Lisp_Object Vmac_dnd_known_types;
1422 static pascal OSErr mac_do_track_drag P_ ((DragTrackingMessage, WindowRef,
1423                                            void *, DragRef));
1424 static pascal OSErr mac_do_receive_drag P_ ((WindowRef, void *, DragRef));
1425 static DragTrackingHandlerUPP mac_do_track_dragUPP = NULL;
1426 static DragReceiveHandlerUPP mac_do_receive_dragUPP = NULL;
1427
1428 extern void mac_store_drag_event P_ ((WindowRef, Point, SInt16,
1429                                       const AEDesc *));
1430
1431 static pascal OSErr
1432 mac_do_track_drag (message, window, refcon, drag)
1433      DragTrackingMessage message;
1434      WindowRef window;
1435      void *refcon;
1436      DragRef drag;
1437 {
1438   OSErr err = noErr;
1439   static int can_accept;
1440   UInt16 num_items, index;
1441
1442   if (GetFrontWindowOfClass (kMovableModalWindowClass, false))
1443     return dragNotAcceptedErr;
1444
1445   switch (message)
1446     {
1447     case kDragTrackingEnterHandler:
1448       err = CountDragItems (drag, &num_items);
1449       if (err != noErr)
1450         break;
1451       can_accept = 0;
1452       for (index = 1; index <= num_items; index++)
1453         {
1454           ItemReference item;
1455           FlavorFlags flags;
1456           Lisp_Object rest;
1457
1458           err = GetDragItemReferenceNumber (drag, index, &item);
1459           if (err != noErr)
1460             continue;
1461           for (rest = Vmac_dnd_known_types; CONSP (rest); rest = XCDR (rest))
1462             {
1463               Lisp_Object str;
1464               FlavorType type;
1465
1466               str = XCAR (rest);
1467               if (!(STRINGP (str) && SBYTES (str) == 4))
1468                 continue;
1469               type = EndianU32_BtoN (*((UInt32 *) SDATA (str)));
1470
1471               err = GetFlavorFlags (drag, item, type, &flags);
1472               if (err == noErr)
1473                 {
1474                   can_accept = 1;
1475                   break;
1476                 }
1477             }
1478         }
1479       break;
1480
1481     case kDragTrackingEnterWindow:
1482       if (can_accept)
1483         {
1484           RgnHandle hilite_rgn = NewRgn ();
1485
1486           if (hilite_rgn)
1487             {
1488               Rect r;
1489
1490               GetWindowPortBounds (window, &r);
1491               OffsetRect (&r, -r.left, -r.top);
1492               RectRgn (hilite_rgn, &r);
1493               ShowDragHilite (drag, hilite_rgn, true);
1494               DisposeRgn (hilite_rgn);
1495             }
1496           SetThemeCursor (kThemeCopyArrowCursor);
1497         }
1498       break;
1499
1500     case kDragTrackingInWindow:
1501       break;
1502
1503     case kDragTrackingLeaveWindow:
1504       if (can_accept)
1505         {
1506           HideDragHilite (drag);
1507           SetThemeCursor (kThemeArrowCursor);
1508         }
1509       break;
1510
1511     case kDragTrackingLeaveHandler:
1512       break;
1513     }
1514
1515   if (err != noErr)
1516     return dragNotAcceptedErr;
1517   return noErr;
1518 }
1519
1520 static pascal OSErr
1521 mac_do_receive_drag (window, refcon, drag)
1522      WindowRef window;
1523      void *refcon;
1524      DragRef drag;
1525 {
1526   OSErr err;
1527   int num_types, i;
1528   Lisp_Object rest, str;
1529   FlavorType *types;
1530   AppleEvent apple_event;
1531   Point mouse_pos;
1532   SInt16 modifiers;
1533
1534   if (GetFrontWindowOfClass (kMovableModalWindowClass, false))
1535     return dragNotAcceptedErr;
1536
1537   num_types = 0;
1538   for (rest = Vmac_dnd_known_types; CONSP (rest); rest = XCDR (rest))
1539     {
1540       str = XCAR (rest);
1541       if (STRINGP (str) && SBYTES (str) == 4)
1542         num_types++;
1543     }
1544
1545   types = xmalloc (sizeof (FlavorType) * num_types);
1546   i = 0;
1547   for (rest = Vmac_dnd_known_types; CONSP (rest); rest = XCDR (rest))
1548     {
1549       str = XCAR (rest);
1550       if (STRINGP (str) && SBYTES (str) == 4)
1551         types[i++] = EndianU32_BtoN (*((UInt32 *) SDATA (str)));
1552     }
1553
1554   err = create_apple_event_from_drag_ref (drag, num_types, types,
1555                                           &apple_event);
1556   xfree (types);
1557
1558   if (err == noErr)
1559     err = GetDragMouse (drag, &mouse_pos, NULL);
1560   if (err == noErr)
1561     {
1562       GlobalToLocal (&mouse_pos);
1563       err = GetDragModifiers (drag, NULL, NULL, &modifiers);
1564     }
1565
1566   if (err == noErr)
1567     {
1568       mac_store_drag_event (window, mouse_pos, modifiers, &apple_event);
1569       AEDisposeDesc (&apple_event);
1570       /* Post a harmless event so as to wake up from ReceiveNextEvent.  */
1571       mac_post_mouse_moved_event ();
1572       return noErr;
1573     }
1574   else
1575     return dragNotAcceptedErr;
1576 }
1577 #endif  /* TARGET_API_MAC_CARBON */
1578
1579 OSErr
1580 install_drag_handler (window)
1581      WindowRef window;
1582 {
1583   OSErr err = noErr;
1584
1585 #if TARGET_API_MAC_CARBON
1586   if (mac_do_track_dragUPP == NULL)
1587     mac_do_track_dragUPP = NewDragTrackingHandlerUPP (mac_do_track_drag);
1588   if (mac_do_receive_dragUPP == NULL)
1589     mac_do_receive_dragUPP = NewDragReceiveHandlerUPP (mac_do_receive_drag);
1590
1591   err = InstallTrackingHandler (mac_do_track_dragUPP, window, NULL);
1592   if (err == noErr)
1593     err = InstallReceiveHandler (mac_do_receive_dragUPP, window, NULL);
1594 #endif
1595
1596   return err;
1597 }
1598
1599 void
1600 remove_drag_handler (window)
1601      WindowRef window;
1602 {
1603 #if TARGET_API_MAC_CARBON
1604   if (mac_do_track_dragUPP)
1605     RemoveTrackingHandler (mac_do_track_dragUPP, window);
1606   if (mac_do_receive_dragUPP)
1607     RemoveReceiveHandler (mac_do_receive_dragUPP, window);
1608 #endif
1609 }
1610
1611 \f
1612 /***********************************************************************
1613                         Services menu support
1614 ***********************************************************************/
1615 #ifdef MAC_OSX
1616 void
1617 init_service_handler ()
1618 {
1619   static const EventTypeSpec specs[] =
1620     {{kEventClassService, kEventServiceGetTypes},
1621      {kEventClassService, kEventServiceCopy},
1622      {kEventClassService, kEventServicePaste},
1623      {kEventClassService, kEventServicePerform}};
1624   InstallApplicationEventHandler (NewEventHandlerUPP (mac_handle_service_event),
1625                                   GetEventTypeCount (specs), specs, NULL, NULL);
1626 }
1627
1628 extern OSStatus mac_store_service_event P_ ((EventRef));
1629
1630 static OSStatus
1631 copy_scrap_flavor_data (from_scrap, to_scrap, flavor_type)
1632      ScrapRef from_scrap, to_scrap;
1633      ScrapFlavorType flavor_type;
1634 {
1635   OSStatus err;
1636   Size size, size_allocated;
1637   char *buf = NULL;
1638
1639   err = GetScrapFlavorSize (from_scrap, flavor_type, &size);
1640   if (err == noErr)
1641     buf = xmalloc (size);
1642   while (buf)
1643     {
1644       size_allocated = size;
1645       err = GetScrapFlavorData (from_scrap, flavor_type, &size, buf);
1646       if (err != noErr)
1647         {
1648           xfree (buf);
1649           buf = NULL;
1650         }
1651       else if (size_allocated < size)
1652         buf = xrealloc (buf, size);
1653       else
1654         break;
1655     }
1656   if (err == noErr)
1657     {
1658       if (buf == NULL)
1659         err = memFullErr;
1660       else
1661         {
1662           err = PutScrapFlavor (to_scrap, flavor_type, kScrapFlavorMaskNone,
1663                                 size, buf);
1664           xfree (buf);
1665         }
1666     }
1667
1668   return err;
1669 }
1670
1671 static OSStatus
1672 mac_handle_service_event (call_ref, event, data)
1673      EventHandlerCallRef call_ref;
1674      EventRef event;
1675      void *data;
1676 {
1677   OSStatus err = noErr;
1678   ScrapRef cur_scrap, specific_scrap;
1679   UInt32 event_kind = GetEventKind (event);
1680   CFMutableArrayRef copy_types, paste_types;
1681   CFStringRef type;
1682   Lisp_Object rest;
1683   ScrapFlavorType flavor_type;
1684
1685   /* Check if Vmac_service_selection is a valid selection that has a
1686      corresponding scrap.  */
1687   if (!SYMBOLP (Vmac_service_selection))
1688     err = eventNotHandledErr;
1689   else
1690     err = get_scrap_from_symbol (Vmac_service_selection, 0, &cur_scrap);
1691   if (!(err == noErr && cur_scrap))
1692     return eventNotHandledErr;
1693
1694   switch (event_kind)
1695     {
1696     case kEventServiceGetTypes:
1697       /* Set paste types. */
1698       err = GetEventParameter (event, kEventParamServicePasteTypes,
1699                                typeCFMutableArrayRef, NULL,
1700                                sizeof (CFMutableArrayRef), NULL,
1701                                &paste_types);
1702       if (err != noErr)
1703         break;
1704
1705       for (rest = Vselection_converter_alist; CONSP (rest);
1706            rest = XCDR (rest))
1707         if (CONSP (XCAR (rest)) && SYMBOLP (XCAR (XCAR (rest)))
1708             && (flavor_type =
1709                 get_flavor_type_from_symbol (XCAR (XCAR (rest)))))
1710           {
1711             type = CreateTypeStringWithOSType (flavor_type);
1712             if (type)
1713               {
1714                 CFArrayAppendValue (paste_types, type);
1715                 CFRelease (type);
1716               }
1717           }
1718
1719       /* Set copy types.  */
1720       err = GetEventParameter (event, kEventParamServiceCopyTypes,
1721                                typeCFMutableArrayRef, NULL,
1722                                sizeof (CFMutableArrayRef), NULL,
1723                                &copy_types);
1724       if (err != noErr)
1725         break;
1726
1727       if (NILP (Fx_selection_owner_p (Vmac_service_selection)))
1728         break;
1729       else
1730         goto copy_all_flavors;
1731
1732     case kEventServiceCopy:
1733       err = GetEventParameter (event, kEventParamScrapRef,
1734                                typeScrapRef, NULL,
1735                                sizeof (ScrapRef), NULL, &specific_scrap);
1736       if (err != noErr
1737           || NILP (Fx_selection_owner_p (Vmac_service_selection)))
1738         {
1739           err = eventNotHandledErr;
1740           break;
1741         }
1742
1743     copy_all_flavors:
1744       {
1745         UInt32 count, i;
1746         ScrapFlavorInfo *flavor_info = NULL;
1747         ScrapFlavorFlags flags;
1748
1749         err = GetScrapFlavorCount (cur_scrap, &count);
1750         if (err == noErr)
1751           flavor_info = xmalloc (sizeof (ScrapFlavorInfo) * count);
1752         err = GetScrapFlavorInfoList (cur_scrap, &count, flavor_info);
1753         if (err != noErr)
1754           {
1755             xfree (flavor_info);
1756             flavor_info = NULL;
1757           }
1758         if (flavor_info == NULL)
1759           break;
1760
1761         for (i = 0; i < count; i++)
1762           {
1763             flavor_type = flavor_info[i].flavorType;
1764             err = GetScrapFlavorFlags (cur_scrap, flavor_type, &flags);
1765             if (err == noErr && !(flags & kScrapFlavorMaskSenderOnly))
1766               {
1767                 if (event_kind == kEventServiceCopy)
1768                   err = copy_scrap_flavor_data (cur_scrap, specific_scrap,
1769                                                 flavor_type);
1770                 else         /* event_kind == kEventServiceGetTypes */
1771                   {
1772                     type = CreateTypeStringWithOSType (flavor_type);
1773                     if (type)
1774                       {
1775                         CFArrayAppendValue (copy_types, type);
1776                         CFRelease (type);
1777                       }
1778                   }
1779               }
1780           }
1781         xfree (flavor_info);
1782       }
1783       break;
1784
1785     case kEventServicePaste:
1786     case kEventServicePerform:
1787       {
1788         int data_exists_p = 0;
1789
1790         err = GetEventParameter (event, kEventParamScrapRef, typeScrapRef,
1791                                  NULL, sizeof (ScrapRef), NULL,
1792                                  &specific_scrap);
1793         if (err == noErr)
1794           err = clear_scrap (&cur_scrap);
1795         if (err == noErr)
1796           for (rest = Vselection_converter_alist; CONSP (rest);
1797                rest = XCDR (rest))
1798             {
1799               if (! (CONSP (XCAR (rest)) && SYMBOLP (XCAR (XCAR (rest)))))
1800                 continue;
1801               flavor_type = get_flavor_type_from_symbol (XCAR (XCAR (rest)));
1802               if (flavor_type == 0)
1803                 continue;
1804               err = copy_scrap_flavor_data (specific_scrap, cur_scrap,
1805                                             flavor_type);
1806               if (err == noErr)
1807                 data_exists_p = 1;
1808             }
1809         if (!data_exists_p)
1810           err = eventNotHandledErr;
1811         else
1812           err = mac_store_service_event (event);
1813       }
1814       break;
1815     }
1816
1817   if (err != noErr)
1818     err = eventNotHandledErr;
1819   return err;
1820 }
1821 #endif
1822
1823
1824 void
1825 syms_of_macselect ()
1826 {
1827   defsubr (&Sx_get_selection_internal);
1828   defsubr (&Sx_own_selection_internal);
1829   defsubr (&Sx_disown_selection_internal);
1830   defsubr (&Sx_selection_owner_p);
1831   defsubr (&Sx_selection_exists_p);
1832   defsubr (&Smac_process_deferred_apple_events);
1833   defsubr (&Smac_cleanup_expired_apple_events);
1834   defsubr (&Smac_resume_apple_event);
1835   defsubr (&Smac_ae_set_reply_parameter);
1836
1837   Vselection_alist = Qnil;
1838   staticpro (&Vselection_alist);
1839
1840   DEFVAR_LISP ("selection-converter-alist", &Vselection_converter_alist,
1841                doc: /* An alist associating selection-types with functions.
1842 These functions are called to convert the selection, with three args:
1843 the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD');
1844 a desired type to which the selection should be converted;
1845 and the local selection value (whatever was given to `x-own-selection').
1846
1847 The function should return the value to send to the Scrap Manager
1848 \(must be a string).  A return value of nil
1849 means that the conversion could not be done.
1850 A return value which is the symbol `NULL'
1851 means that a side-effect was executed,
1852 and there is no meaningful selection value.  */);
1853   Vselection_converter_alist = Qnil;
1854
1855   DEFVAR_LISP ("x-lost-selection-functions", &Vx_lost_selection_functions,
1856                doc: /* A list of functions to be called when Emacs loses a selection.
1857 \(This happens when a Lisp program explicitly clears the selection.)
1858 The functions are called with one argument, the selection type
1859 \(a symbol, typically `PRIMARY', `SECONDARY', or `CLIPBOARD').  */);
1860   Vx_lost_selection_functions = Qnil;
1861
1862   DEFVAR_LISP ("selection-coding-system", &Vselection_coding_system,
1863                doc: /* Coding system for communicating with other programs.
1864 When sending or receiving text via cut_buffer, selection, and clipboard,
1865 the text is encoded or decoded by this coding system.
1866 The default value is determined by the system script code.  */);
1867   Vselection_coding_system = Qnil;
1868
1869   DEFVAR_LISP ("next-selection-coding-system", &Vnext_selection_coding_system,
1870                doc: /* Coding system for the next communication with other programs.
1871 Usually, `selection-coding-system' is used for communicating with
1872 other programs.  But, if this variable is set, it is used for the
1873 next communication only.  After the communication, this variable is
1874 set to nil.  */);
1875   Vnext_selection_coding_system = Qnil;
1876
1877   DEFVAR_LISP ("mac-apple-event-map", &Vmac_apple_event_map,
1878                doc: /* Keymap for Apple events handled by Emacs.  */);
1879   Vmac_apple_event_map = Qnil;
1880
1881 #if TARGET_API_MAC_CARBON
1882   DEFVAR_LISP ("mac-dnd-known-types", &Vmac_dnd_known_types,
1883                doc: /* The types accepted by default for dropped data.
1884 The types are chosen in the order they appear in the list.  */);
1885   Vmac_dnd_known_types = list4 (build_string ("hfs "), build_string ("utxt"),
1886                                 build_string ("TEXT"), build_string ("TIFF"));
1887 #ifdef MAC_OSX
1888   Vmac_dnd_known_types = Fcons (build_string ("furl"), Vmac_dnd_known_types);
1889 #endif
1890 #endif
1891
1892 #ifdef MAC_OSX
1893   DEFVAR_LISP ("mac-service-selection", &Vmac_service_selection,
1894                doc: /* Selection name for communication via Services menu.  */);
1895   Vmac_service_selection = intern ("PRIMARY");
1896 #endif
1897
1898   QPRIMARY   = intern ("PRIMARY");      staticpro (&QPRIMARY);
1899   QSECONDARY = intern ("SECONDARY");    staticpro (&QSECONDARY);
1900   QTIMESTAMP = intern ("TIMESTAMP");    staticpro (&QTIMESTAMP);
1901   QTARGETS   = intern ("TARGETS");      staticpro (&QTARGETS);
1902
1903   Qforeign_selection = intern ("foreign-selection");
1904   staticpro (&Qforeign_selection);
1905
1906   Qmac_scrap_name = intern ("mac-scrap-name");
1907   staticpro (&Qmac_scrap_name);
1908
1909   Qmac_ostype = intern ("mac-ostype");
1910   staticpro (&Qmac_ostype);
1911
1912   Qmac_apple_event_class = intern ("mac-apple-event-class");
1913   staticpro (&Qmac_apple_event_class);
1914
1915   Qmac_apple_event_id = intern ("mac-apple-event-id");
1916   staticpro (&Qmac_apple_event_id);
1917
1918   Qemacs_suspension_id = intern ("emacs-suspension-id");
1919   staticpro (&Qemacs_suspension_id);
1920 }
1921
1922 /* arch-tag: f3c91ad8-99e0-4bd6-9eef-251b2f848732
1923    (do not change this comment) */