emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/src/mac.c


From: YAMAMOTO Mitsuharu
Subject: [Emacs-diffs] Changes to emacs/src/mac.c
Date: Wed, 16 Mar 2005 03:05:56 -0500

Index: emacs/src/mac.c
diff -c emacs/src/mac.c:1.27 emacs/src/mac.c:1.28
*** emacs/src/mac.c:1.27        Fri Mar  4 11:08:05 2005
--- emacs/src/mac.c     Wed Mar 16 08:05:56 2005
***************
*** 26,56 ****
  #include <errno.h>
  #include <time.h>
  
! #ifdef HAVE_CARBON
! #ifdef MAC_OSX
! #undef mktime
! #undef DEBUG
! #undef free
! #undef malloc
! #undef realloc
! #undef init_process
! #include <Carbon/Carbon.h>
! #undef mktime
! #define mktime emacs_mktime
! #undef free
! #define free unexec_free
! #undef malloc
! #define malloc unexec_malloc
! #undef realloc
! #define realloc unexec_realloc
! #undef init_process
! #define init_process emacs_init_process
! #else  /* not MAC_OSX */
! #undef SIGHUP
! #define OLDP2C 1
! #include <Carbon.h>
! #endif        /* not MAC_OSX */
! #else /* not HAVE_CARBON */
  #include <Files.h>
  #include <MacTypes.h>
  #include <TextUtils.h>
--- 26,40 ----
  #include <errno.h>
  #include <time.h>
  
! #include "lisp.h"
! #include "process.h"
! #include "sysselect.h"
! #include "systime.h"
! #include "blockinput.h"
! 
! #include "macterm.h"
! 
! #ifndef HAVE_CARBON
  #include <Files.h>
  #include <MacTypes.h>
  #include <TextUtils.h>
***************
*** 81,92 ****
  #include <unistd.h>
  #endif
  
- #include "lisp.h"
- #include "process.h"
- #include "sysselect.h"
- #include "systime.h"
- #include "blockinput.h"
- 
  Lisp_Object QCLIPBOARD;
  
  /* An instance of the AppleScript component.  */
--- 65,70 ----
***************
*** 272,278 ****
--- 250,274 ----
    return 1;
  }
  
+ 
+ /***********************************************************************
+        Conversion between Lisp and Core Foundation objects
+  ***********************************************************************/
+ 
  #if TARGET_API_MAC_CARBON
+ static Lisp_Object Qstring, Qnumber, Qboolean, Qdate, Qdata;
+ static Lisp_Object Qarray, Qdictionary;
+ extern Lisp_Object Qutf_8;
+ #define DECODE_UTF_8(str) code_convert_string_norecord (str, Qutf_8, 0)
+ 
+ struct cfdict_context
+ {
+   Lisp_Object *result;
+   int with_tag, hash_bound;
+ };
+ 
+ /* C string to CFString. */
+ 
  CFStringRef
  cfstring_create_with_utf8_cstring (c_str)
       const char *c_str;
***************
*** 286,293 ****
--- 282,1088 ----
  
    return str;
  }
+ 
+ 
+ /* From CFData to a lisp string.  Always returns a unibyte string.  */
+ 
+ Lisp_Object
+ cfdata_to_lisp (data)
+      CFDataRef data;
+ {
+   CFIndex len = CFDataGetLength (data);
+   Lisp_Object result = make_uninit_string (len);
+   
+   CFDataGetBytes (data, CFRangeMake (0, len), SDATA (result));
+ 
+   return result;
+ }
+ 
+ 
+ /* From CFString to a lisp string.  Never returns a unibyte string
+    (even if it only contains ASCII characters).
+    This may cause GC during code conversion. */
+ 
+ Lisp_Object
+ cfstring_to_lisp (string)
+      CFStringRef string;
+ {
+   Lisp_Object result = Qnil;
+   const char *s = CFStringGetCStringPtr (string, kCFStringEncodingUTF8);
+ 
+   if (s)
+     result = make_unibyte_string (s, strlen (s));
+   else
+     {
+       CFDataRef data =
+       CFStringCreateExternalRepresentation (NULL, string,
+                                             kCFStringEncodingUTF8, '?');
+ 
+       if (data)
+       {
+         result = cfdata_to_lisp (data);
+         CFRelease (data);
+       }
+     }
+ 
+   if (!NILP (result))
+     {
+       result = DECODE_UTF_8 (result);
+       /* This may be superfluous.  Just to make sure that the result
+        is a multibyte string.  */
+       result = string_to_multibyte (result);
+     }
+ 
+   return result;
+ }
+ 
+ 
+ /* CFNumber to a lisp integer or a lisp float.  */
+ 
+ Lisp_Object
+ cfnumber_to_lisp (number)
+      CFNumberRef number;
+ {
+   Lisp_Object result = Qnil;
+ #if BITS_PER_EMACS_INT > 32      
+   SInt64 int_val;
+   CFNumberType emacs_int_type = kCFNumberSInt64Type;
+ #else
+   SInt32 int_val;
+   CFNumberType emacs_int_type = kCFNumberSInt32Type;
+ #endif
+   double float_val;
+ 
+   if (CFNumberGetValue (number, emacs_int_type, &int_val)
+       && !FIXNUM_OVERFLOW_P (int_val))
+     result = make_number (int_val);
+   else
+     if (CFNumberGetValue (number, kCFNumberDoubleType, &float_val))
+       result = make_float (float_val);
+   return result;
+ }
+ 
+ 
+ /* CFDate to a list of three integers as in a return value of
+    `current-time'xo.  */
+ 
+ Lisp_Object
+ cfdate_to_lisp (date)
+      CFDateRef date;
+ {
+   static CFGregorianDate epoch_gdate = {1970, 1, 1, 0, 0, 0.0};
+   static CFAbsoluteTime epoch = 0.0, sec;
+   int high, low;
+ 
+   if (epoch == 0.0)
+     epoch = CFGregorianDateGetAbsoluteTime (epoch_gdate, NULL);
+ 
+   sec = CFDateGetAbsoluteTime (date) - epoch;
+   high = sec / 65536.0;
+   low = sec - high * 65536.0;
+ 
+   return list3 (make_number (high), make_number (low), make_number (0));
+ }
+ 
+ 
+ /* CFBoolean to a lisp symbol, `t' or `nil'.  */
+ 
+ Lisp_Object
+ cfboolean_to_lisp (boolean)
+      CFBooleanRef boolean;
+ {
+   return CFBooleanGetValue (boolean) ? Qt : Qnil;
+ }
+ 
+ 
+ /* Any Core Foundation object to a (lengthy) lisp string.  */
+ 
+ Lisp_Object
+ cfobject_desc_to_lisp (object)
+      CFTypeRef object;
+ {
+   Lisp_Object result = Qnil;
+   CFStringRef desc = CFCopyDescription (object);
+ 
+   if (desc)
+     {
+       result = cfstring_to_lisp (desc);
+       CFRelease (desc);
+     }
+ 
+   return result;
+ }
+ 
+ 
+ /* Callback functions for cfproperty_list_to_lisp.  */
+ 
+ static void
+ cfdictionary_add_to_list (key, value, context)
+      const void *key;
+      const void *value;
+      void *context;
+ {
+   struct cfdict_context *cxt = (struct cfdict_context *)context;
+ 
+   *cxt->result =
+     Fcons (Fcons (cfstring_to_lisp (key),
+                 cfproperty_list_to_lisp (value, cxt->with_tag,
+                                          cxt->hash_bound)),
+          *cxt->result);
+ }
+ 
+ static void
+ cfdictionary_puthash (key, value, context)
+      const void *key;
+      const void *value;
+      void *context;
+ {
+   Lisp_Object lisp_key = cfstring_to_lisp (key);
+   struct cfdict_context *cxt = (struct cfdict_context *)context;
+   struct Lisp_Hash_Table *h = XHASH_TABLE (*(cxt->result));
+   unsigned hash_code;
+ 
+   hash_lookup (h, lisp_key, &hash_code);
+   hash_put (h, lisp_key,
+           cfproperty_list_to_lisp (value, cxt->with_tag, cxt->hash_bound),
+           hash_code);
+ }
+ 
+ 
+ /* Convert CFPropertyList PLIST to a lisp object.  If WITH_TAG is
+    non-zero, a symbol that represents the type of the original Core
+    Foundation object is prepended.  HASH_BOUND specifies which kinds
+    of the lisp objects, alists or hash tables, are used as the targets
+    of the conversion from CFDictionary.  If HASH_BOUND is negative,
+    always generate alists.  If HASH_BOUND >= 0, generate an alist if
+    the number of keys in the dictionary is smaller than HASH_BOUND,
+    and a hash table otherwise.  */
+ 
+ Lisp_Object
+ cfproperty_list_to_lisp (plist, with_tag, hash_bound)
+      CFPropertyListRef plist;
+      int with_tag, hash_bound;
+ {
+   CFTypeID type_id = CFGetTypeID (plist);
+   Lisp_Object tag = Qnil, result = Qnil;
+   struct gcpro gcpro1, gcpro2;
+ 
+   GCPRO2 (tag, result);
+ 
+   if (type_id == CFStringGetTypeID ())
+     {
+       tag = Qstring;
+       result = cfstring_to_lisp (plist);
+     }
+   else if (type_id == CFNumberGetTypeID ())
+     {
+       tag = Qnumber;
+       result = cfnumber_to_lisp (plist);
+     }
+   else if (type_id == CFBooleanGetTypeID ())
+     {
+       tag = Qboolean;
+       result = cfboolean_to_lisp (plist);
+     }
+   else if (type_id == CFDateGetTypeID ())
+     {
+       tag = Qdate;
+       result = cfdate_to_lisp (plist);
+     }
+   else if (type_id == CFDataGetTypeID ())
+     {
+       tag = Qdata;
+       result = cfdata_to_lisp (plist);
+     }
+   else if (type_id == CFArrayGetTypeID ())
+     {
+       CFIndex index, count = CFArrayGetCount (plist);
+ 
+       tag = Qarray;
+       result = Fmake_vector (make_number (count), Qnil);
+       for (index = 0; index < count; index++)
+       XVECTOR (result)->contents[index] =
+         cfproperty_list_to_lisp (CFArrayGetValueAtIndex (plist, index),
+                                  with_tag, hash_bound);
+     }
+   else if (type_id == CFDictionaryGetTypeID ())
+     {
+       struct cfdict_context context;
+       CFIndex count = CFDictionaryGetCount (plist);
+ 
+       tag = Qdictionary;
+       context.result  = &result;
+       context.with_tag = with_tag;
+       context.hash_bound = hash_bound;
+       if (hash_bound < 0 || count < hash_bound)
+       {
+         result = Qnil;
+         CFDictionaryApplyFunction (plist, cfdictionary_add_to_list,
+                                    &context);
+       }
+       else
+       {
+         result = make_hash_table (Qequal,
+                                   make_number (count),
+                                   make_float (DEFAULT_REHASH_SIZE),
+                                   make_float (DEFAULT_REHASH_THRESHOLD),
+                                   Qnil, Qnil, Qnil);
+         CFDictionaryApplyFunction (plist, cfdictionary_puthash,
+                                    &context);
+       }
+     }
+   else
+     abort ();
+ 
+   UNGCPRO;
+ 
+   if (with_tag)
+     result = Fcons (tag, result);
+ 
+   return result;
+ }
+ #endif
+ 
+ 
+ /***********************************************************************
+                Emulation of the X Resource Manager
+  ***********************************************************************/
+ 
+ /* Parser functions for resource lines.  Each function takes an
+    address of a variable whose value points to the head of a string.
+    The value will be advanced so that it points to the next character
+    of the parsed part when the function returns.
+ 
+    A resource name such as "Emacs*font" is parsed into a non-empty
+    list called `quarks'.  Each element is either a Lisp string that
+    represents a concrete component, a Lisp symbol LOOSE_BINDING
+    (actually Qlambda) that represents any number (>=0) of intervening
+    components, or a Lisp symbol SINGLE_COMPONENT (actually Qquote)
+    that represents as any single component.  */
+ 
+ #define P (*p)
+ 
+ #define LOOSE_BINDING    Qlambda /* '*' ("L"oose) */
+ #define SINGLE_COMPONENT Qquote        /* '?' ("Q"uestion) */
+ 
+ static void
+ skip_while_space (p)
+      char **p;
+ {
+   /* WhiteSpace = {<space> | <horizontal tab>} */
+   while (*P == ' ' || *P == '\t')
+     P++;
+ }
+ 
+ static int
+ parse_comment (p)
+      char **p;
+ {
+   /* Comment = "!" {<any character except null or newline>} */
+   if (*P == '!')
+     {
+       P++;
+       while (*P)
+       if (*P++ == '\n')
+         break;
+       return 1;
+     }
+   else
+     return 0;
+ }
+ 
+ /* Don't interpret filename.  Just skip until the newline.  */
+ static int
+ parse_include_file (p)
+      char **p;
+ {
+   /* IncludeFile = "#" WhiteSpace "include" WhiteSpace FileName WhiteSpace */
+   if (*P == '#')
+     {
+       P++;
+       while (*P)
+       if (*P++ == '\n')
+         break;
+       return 1;
+     }
+   else
+     return 0;
+ }
+ 
+ static char
+ parse_binding (p)
+      char **p;
+ {
+   /* Binding = "." | "*"  */
+   if (*P == '.' || *P == '*')
+     {
+       char binding = *P++;
+ 
+       while (*P == '.' || *P == '*')
+       if (*P++ == '*')
+         binding = '*';
+       return binding;
+     }
+   else
+     return '\0';
+ }
+ 
+ static Lisp_Object
+ parse_component (p)
+      char **p;
+ {
+   /*  Component = "?" | ComponentName
+       ComponentName = NameChar {NameChar}
+       NameChar = "a"-"z" | "A"-"Z" | "0"-"9" | "_" | "-" */
+   if (*P == '?')
+     {
+       P++;
+       return SINGLE_COMPONENT;
+     }
+   else if (isalnum (*P) || *P == '_' || *P == '-')
+     {
+       char *start = P++;
+ 
+       while (isalnum (*P) || *P == '_' || *P == '-')
+       P++;
+ 
+       return make_unibyte_string (start, P - start);
+     }
+   else
+     return Qnil;
+ }
+ 
+ static Lisp_Object
+ parse_resource_name (p)
+      char **p;
+ {
+   Lisp_Object result = Qnil, component;
+   char binding;
+ 
+   /* ResourceName = [Binding] {Component Binding} ComponentName */
+   if (parse_binding (p) == '*')
+     result = Fcons (LOOSE_BINDING, result);
+ 
+   component = parse_component (p);
+   if (NILP (component))
+     return Qnil;
+ 
+   result = Fcons (component, result);  
+   while (binding = parse_binding (p))
+     {
+       if (binding == '*')
+       result = Fcons (LOOSE_BINDING, result);
+       component = parse_component (p);
+       if (NILP (component))
+       return Qnil;
+       else
+       result = Fcons (component, result);
+     }
+   
+   /* The final component should not be '?'.  */
+   if (EQ (component, SINGLE_COMPONENT))
+     return Qnil;
+ 
+   return Fnreverse (result);
+ }
+ 
+ static Lisp_Object
+ parse_value (p)
+      char **p;
+ {
+   char *q, *buf;
+   Lisp_Object seq = Qnil, result;
+   int buf_len, total_len = 0, len, continue_p;
+ 
+   q = strchr (P, '\n');
+   buf_len = q ? q - P : strlen (P);
+   buf = xmalloc (buf_len);
+ 
+   while (1)
+     {
+       q = buf;
+       continue_p = 0;
+       while (*P)
+       {
+         if (*P == '\n')
+           {
+             P++;
+             break;
+           }
+         else if (*P == '\\')
+           {
+             P++;
+             if (*P == '\0')
+               break;
+             else if (*P == '\n')
+               {
+                 P++;
+                 continue_p = 1;
+                 break;
+               }
+             else if (*P == 'n')
+               {
+                 *q++ = '\n';
+                 P++;
+               }
+             else if ('0' <= P[0] && P[0] <= '7'
+                      && '0' <= P[1] && P[1] <= '7'
+                      && '0' <= P[2] && P[2] <= '7')
+               {
+                 *q++ = (P[0] - '0' << 6) + (P[1] - '0' << 3) + (P[2] - '0');
+                 P += 3;
+               }
+             else
+               *q++ = *P++;
+           }
+         else
+           *q++ = *P++;
+       }
+       len = q - buf;
+       seq = Fcons (make_unibyte_string (buf, len), seq);
+       total_len += len;
+ 
+       if (continue_p)
+       {
+         q = strchr (P, '\n');
+         len = q ? q - P : strlen (P);
+         if (len > buf_len)
+           {
+             xfree (buf);
+             buf_len = len;
+             buf = xmalloc (buf_len);
+           }
+       }
+       else
+       break;
+     }
+   xfree (buf);
+ 
+   if (SBYTES (XCAR (seq)) == total_len)
+     return make_string (SDATA (XCAR (seq)), total_len);
+   else
+     {
+       buf = xmalloc (total_len);
+       q = buf + total_len;
+       for (; CONSP (seq); seq = XCDR (seq))
+       {
+         len = SBYTES (XCAR (seq)); 
+         q -= len;
+         memcpy (q, SDATA (XCAR (seq)), len);
+       }
+       result = make_string (buf, total_len);
+       xfree (buf);
+       return result;
+     }
+ }
+ 
+ static Lisp_Object
+ parse_resource_line (p)
+      char **p;
+ {
+   Lisp_Object quarks, value;
+ 
+   /* ResourceLine = Comment | IncludeFile | ResourceSpec | <empty line> */
+   if (parse_comment (p) || parse_include_file (p))
+     return Qnil;
+ 
+   /* ResourceSpec = WhiteSpace ResourceName WhiteSpace ":" WhiteSpace Value */
+   skip_while_space (p);
+   quarks = parse_resource_name (p);
+   if (NILP (quarks))
+     goto cleanup;
+   skip_while_space (p);
+   if (*P != ':')
+     goto cleanup;
+   P++;
+   skip_while_space (p);
+   value = parse_value (p);
+   return Fcons (quarks, value);
+ 
+  cleanup:
+   /* Skip the remaining data as a dummy value.  */
+   parse_value (p);
+   return Qnil;
+ }
+ 
+ #undef P
+ 
+ /* Equivalents of X Resource Manager functions.
+ 
+    An X Resource Database acts as a collection of resource names and
+    associated values.  It is implemented as a trie on quarks.  Namely,
+    each edge is labeled by either a string, LOOSE_BINDING, or
+    SINGLE_COMPONENT.  Nodes of the trie are implemented as Lisp hash
+    tables, and a value associated with a resource name is recorded as
+    a value for HASHKEY_TERMINAL at the hash table whose path from the
+    root is the quarks of the resource name. */
+ 
+ #define HASHKEY_TERMINAL Qt /* "T"erminal */
+ 
+ static XrmDatabase
+ xrm_create_database ()
+ {
+   return make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE),
+                         make_float (DEFAULT_REHASH_SIZE),
+                         make_float (DEFAULT_REHASH_THRESHOLD),
+                         Qnil, Qnil, Qnil);  
+ }
+ 
+ static void
+ xrm_q_put_resource (database, quarks, value)
+      XrmDatabase database;
+      Lisp_Object quarks, value;
+ {
+   struct Lisp_Hash_Table *h;
+   unsigned hash_code;
+   int i;
+ 
+   for (; CONSP (quarks); quarks = XCDR (quarks))
+     {
+       h = XHASH_TABLE (database);
+       i = hash_lookup (h, XCAR (quarks), &hash_code);
+       if (i < 0)
+       {
+         database = xrm_create_database ();
+         hash_put (h, XCAR (quarks), database, hash_code);
+       }
+       else
+       database = HASH_VALUE (h, i);
+     }
+ 
+   Fputhash (HASHKEY_TERMINAL, value, database);
+ }
+ 
+ /* Merge multiple resource entries specified by DATA into a resource
+    database DATABASE.  DATA points to the head of a null-terminated
+    string consisting of multiple resource lines.  It's like a
+    combination of XrmGetStringDatabase and XrmMergeDatabases.  */
+ 
+ void
+ xrm_merge_string_database (database, data)
+      XrmDatabase database;
+      char *data;
+ {
+   Lisp_Object quarks_value;
+ 
+   while (*data)
+     {
+       quarks_value = parse_resource_line (&data);
+       if (!NILP (quarks_value))
+       xrm_q_put_resource (database,
+                           XCAR (quarks_value), XCDR (quarks_value));
+     }
+ }
+ 
+ static Lisp_Object
+ xrm_q_get_resource (database, quark_name, quark_class)
+      XrmDatabase database;
+      Lisp_Object quark_name, quark_class;
+ {
+   struct Lisp_Hash_Table *h = XHASH_TABLE (database);
+   Lisp_Object keys[3], value;
+   int i, k;
+   
+   if (!CONSP (quark_name))
+     return Fgethash (HASHKEY_TERMINAL, database, Qnil);
+   
+   /* First, try tight bindings */
+   keys[0] = XCAR (quark_name);
+   keys[1] = XCAR (quark_class);
+   keys[2] = SINGLE_COMPONENT;
+ 
+   for (k = 0; k < sizeof (keys) / sizeof (*keys); k++)
+     {
+       i = hash_lookup (h, keys[k], NULL);
+       if (i >= 0)
+       {
+         value = xrm_q_get_resource (HASH_VALUE (h, i),
+                                     XCDR (quark_name), XCDR (quark_class));
+         if (!NILP (value))
+           return value;
+       }
+     }
+ 
+   /* Then, try loose bindings */
+   i = hash_lookup (h, LOOSE_BINDING, NULL);
+   if (i >= 0)
+     {
+       value = xrm_q_get_resource (HASH_VALUE (h, i), quark_name, quark_class);
+       if (!NILP (value))
+       return value;
+       else
+       return xrm_q_get_resource (database,
+                                  XCDR (quark_name), XCDR (quark_class));
+     }
+   else
+     return Qnil;
+ }
+ 
+ /* Retrieve a resource value for the specified NAME and CLASS from the
+    resource database DATABASE.  It corresponds to XrmGetResource.  */
+ 
+ Lisp_Object
+ xrm_get_resource (database, name, class)
+      XrmDatabase database;
+      char *name, *class;
+ {
+   Lisp_Object quark_name, quark_class, tmp;
+   int nn, nc;
+ 
+   quark_name = parse_resource_name (&name);
+   if (*name != '\0')
+     return Qnil;
+   for (tmp = quark_name, nn = 0; CONSP (tmp); tmp = XCDR (tmp), nn++)
+     if (!STRINGP (XCAR (tmp)))
+       return Qnil;
+ 
+   quark_class = parse_resource_name (&class);
+   if (*class != '\0')
+     return Qnil;
+   for (tmp = quark_class, nc = 0; CONSP (tmp); tmp = XCDR (tmp), nc++)
+     if (!STRINGP (XCAR (tmp)))
+       return Qnil;
+ 
+   if (nn != nc)
+     return Qnil;
+   else
+     return xrm_q_get_resource (database, quark_name, quark_class);
+ }
+ 
+ #if TARGET_API_MAC_CARBON
+ static Lisp_Object
+ xrm_cfproperty_list_to_value (plist)
+      CFPropertyListRef plist;
+ {
+   CFTypeID type_id = CFGetTypeID (plist);
+ 
+   if (type_id == CFStringGetTypeID ())
+       return cfstring_to_lisp (plist);
+   else if (type_id == CFNumberGetTypeID ())
+     {
+       CFStringRef string;
+       Lisp_Object result = Qnil;
+ 
+       string = CFStringCreateWithFormat (NULL, NULL, CFSTR ("%@"), plist);
+       if (string)
+       {
+         result = cfstring_to_lisp (string);
+         CFRelease (string);
+       }
+       return result;
+     }
+   else if (type_id == CFBooleanGetTypeID ())
+     {
+       static value_true = NULL, value_false = NULL;
+ 
+       if (value_true == NULL)
+       {
+         value_true = build_string ("true");
+         value_false = build_string ("false");
+       }
+       return CFBooleanGetValue (plist) ? value_true : value_false;
+     }
+   else if (type_id == CFDataGetTypeID ())
+     return cfdata_to_lisp (plist);
+   else
+     return Qnil;
+ }
+ #endif
+ 
+ /* Create a new resource database from the preferences for the
+    application APPLICATION.  APPLICATION is either a string that
+    specifies an application ID, or NULL that represents the current
+    application.  */
+ 
+ XrmDatabase
+ xrm_get_preference_database (application)
+      char *application;
+ {
+ #if TARGET_API_MAC_CARBON
+   CFStringRef app_id, *keys, user_doms[2], host_doms[2];
+   CFMutableSetRef key_set = NULL;
+   CFArrayRef key_array;
+   CFIndex index, count;
+   char *res_name;
+   XrmDatabase database;
+   Lisp_Object quarks = Qnil, value = Qnil;
+   CFPropertyListRef plist;
+   int iu, ih;
+   struct gcpro gcpro1, gcpro2, gcpro3;
+ 
+   user_doms[0] = kCFPreferencesCurrentUser;
+   user_doms[1] = kCFPreferencesAnyUser;
+   host_doms[0] = kCFPreferencesCurrentHost;
+   host_doms[1] = kCFPreferencesAnyHost;
+ 
+   database = xrm_create_database ();
+ 
+   GCPRO3 (database, quarks, value);
+ 
+   BLOCK_INPUT;
+ 
+   app_id = kCFPreferencesCurrentApplication;
+   if (application)
+     {
+       app_id = cfstring_create_with_utf8_cstring (application);
+       if (app_id == NULL)
+       goto out;
+     }
+ 
+   key_set = CFSetCreateMutable (NULL, 0, &kCFCopyStringSetCallBacks);
+   if (key_set == NULL)
+     goto out;
+   for (iu = 0; iu < sizeof (user_doms) / sizeof (*user_doms) ; iu++)
+     for (ih = 0; ih < sizeof (host_doms) / sizeof (*host_doms); ih++)
+       {
+       key_array = CFPreferencesCopyKeyList (app_id, user_doms[iu],
+                                             host_doms[ih]);
+       if (key_array)
+         {
+           count = CFArrayGetCount (key_array);
+           for (index = 0; index < count; index++)
+             CFSetAddValue (key_set,
+                            CFArrayGetValueAtIndex (key_array, index));
+           CFRelease (key_array);
+         }
+       }
+ 
+   count = CFSetGetCount (key_set);
+   keys = xmalloc (sizeof (CFStringRef) * count);
+   if (keys == NULL)
+     goto out;
+   CFSetGetValues (key_set, (const void **)keys);
+   for (index = 0; index < count; index++)
+     {
+       res_name = SDATA (cfstring_to_lisp (keys[index]));
+       quarks = parse_resource_name (&res_name);
+       if (!(NILP (quarks) || *res_name))
+       {
+         plist = CFPreferencesCopyAppValue (keys[index], app_id);
+         value = xrm_cfproperty_list_to_value (plist);
+         CFRelease (plist);
+         if (!NILP (value))
+           xrm_q_put_resource (database, quarks, value);
+       }
+     }
+ 
+   xfree (keys);
+  out:
+   if (key_set)
+     CFRelease (key_set);
+   CFRelease (app_id);
+ 
+   UNBLOCK_INPUT;
+ 
+   UNGCPRO;
+ 
+   return database;
+ #else
+   return xrm_create_database ();
  #endif
+ }
  
+ 
  #ifndef MAC_OSX
  
  /* The following functions with "sys_" prefix are stubs to Unix
***************
*** 2825,2830 ****
--- 3620,3743 ----
    return Qnil;
  }
  
+ #if TARGET_API_MAC_CARBON
+ static Lisp_Object Qxml;
+ 
+ DEFUN ("mac-get-preference", Fmac_get_preference, Smac_get_preference, 1, 4, 
0,
+        doc: /* Return the application preference value for KEY.
+ KEY is either a string specifying a preference key, or a list of key
+ strings.  If it is a list, the (i+1)-th element is used as a key for
+ the CFDictionary value obtained by the i-th element.  If lookup is
+ failed at some stage, nil is returned.
+ 
+ Optional arg APPLICATION is an application ID string.  If omitted or
+ nil, that stands for the current application.
+ 
+ Optional arg FORMAT specifies the data format of the return value.  If
+ omitted or nil, each Core Foundation object is converted into a
+ corresponding Lisp object as follows:
+ 
+   Core Foundation    Lisp                           Tag
+   ------------------------------------------------------------
+   CFString           Multibyte string               string
+   CFNumber           Integer or float               number
+   CFBoolean          Symbol (t or nil)              boolean
+   CFDate             List of three integers         date
+                        (cf. `current-time')
+   CFData             Unibyte string                 data
+   CFArray            Array                          array
+   CFDictionary       Alist or hash table            dictionary
+                        (depending on HASH-BOUND)
+ 
+ If it is t, a symbol that represents the type of the original Core
+ Foundation object is prepended.  If it is `xml', the value is returned
+ as an XML representation.
+ 
+ Optional arg HASH-BOUND specifies which kinds of the list objects,
+ alists or hash tables, are used as the targets of the conversion from
+ CFDictionary.  If HASH-BOUND is a negative integer or nil, always
+ generate alists.  If HASH-BOUND >= 0, generate an alist if the number
+ of keys in the dictionary is smaller than HASH-BOUND, and a hash table
+ otherwise.  */)
+   (key, application, format, hash_bound)
+      Lisp_Object key, application, format, hash_bound;
+ {
+   CFStringRef app_id, key_str;
+   CFPropertyListRef app_plist = NULL, plist;
+   Lisp_Object result = Qnil, tmp;
+ 
+   if (STRINGP (key))
+     key = Fcons (key, Qnil);
+   else
+     {
+       CHECK_CONS (key);
+       for (tmp = key; CONSP (tmp); tmp = XCDR (tmp))
+       CHECK_STRING_CAR (tmp);
+       if (!NILP (tmp))
+       wrong_type_argument (Qlistp, key);
+     }
+   if (!NILP (application))
+     CHECK_STRING (application);
+   CHECK_SYMBOL (format);
+   if (!NILP (hash_bound))
+     CHECK_NUMBER (hash_bound);
+ 
+   BLOCK_INPUT;
+ 
+   app_id = kCFPreferencesCurrentApplication;
+   if (!NILP (application))
+     {
+       app_id = cfstring_create_with_utf8_cstring (SDATA (application));
+       if (app_id == NULL)
+       goto out;
+     }
+   key_str = cfstring_create_with_utf8_cstring (SDATA (XCAR (key)));
+   if (key_str == NULL)
+     goto out;
+   app_plist = CFPreferencesCopyAppValue (key_str, app_id);
+   CFRelease (key_str);
+   if (app_plist == NULL)
+     goto out;
+ 
+   plist = app_plist;
+   for (key = XCDR (key); CONSP (key); key = XCDR (key))
+     {
+       if (CFGetTypeID (plist) != CFDictionaryGetTypeID ())
+       break;
+       key_str = cfstring_create_with_utf8_cstring (SDATA (XCAR (key)));
+       if (key_str == NULL)
+       goto out;
+       plist = CFDictionaryGetValue (plist, key_str);
+       CFRelease (key_str);
+       if (plist == NULL)
+       goto out;
+     }
+ 
+   if (NILP (key))
+     if (EQ (format, Qxml))
+       {
+       CFDataRef data = CFPropertyListCreateXMLData (NULL, plist);
+       if (data == NULL)
+         goto out;
+       result = cfdata_to_lisp (data);
+       CFRelease (data);
+       }
+     else
+       result =
+       cfproperty_list_to_lisp (plist, EQ (format, Qt),
+                                NILP (hash_bound) ? -1 : XINT (hash_bound));
+ 
+  out:
+   if (app_plist)
+     CFRelease (app_plist);
+   CFRelease (app_id);
+ 
+   UNBLOCK_INPUT;
+ 
+   return result;
+ }
+ #endif        /* TARGET_API_MAC_CARBON */
+ 
  
  DEFUN ("mac-clear-font-name-table", Fmac_clear_font_name_table, 
Smac_clear_font_name_table, 0, 0, 0,
         doc: /* Clear the font name table.  */)
***************
*** 3243,3251 ****
--- 4156,4193 ----
    QCLIPBOARD = intern ("CLIPBOARD");
    staticpro (&QCLIPBOARD);
  
+ #if TARGET_API_MAC_CARBON
+   Qstring = intern ("string");
+   staticpro (&Qstring);
+ 
+   Qnumber = intern ("number");
+   staticpro (&Qnumber);
+ 
+   Qboolean = intern ("boolean");
+   staticpro (&Qboolean);
+ 
+   Qdate = intern ("date");
+   staticpro (&Qdate);
+ 
+   Qdata = intern ("data");
+   staticpro (&Qdata);
+ 
+   Qarray = intern ("array");
+   staticpro (&Qarray);
+ 
+   Qdictionary = intern ("dictionary");
+   staticpro (&Qdictionary);
+ 
+   Qxml = intern ("xml");
+   staticpro (&Qxml);
+ #endif
+ 
    defsubr (&Smac_paste_function);
    defsubr (&Smac_cut_function);
    defsubr (&Sx_selection_exists_p);
+ #if TARGET_API_MAC_CARBON
+   defsubr (&Smac_get_preference);
+ #endif
    defsubr (&Smac_clear_font_name_table);
  
    defsubr (&Sdo_applescript);




reply via email to

[Prev in Thread] Current Thread [Next in Thread]