src/macselect.c

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