X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/49e7a2c0b12aa4189b55c2f7c6c40c6f6a93434a..2a205424e771703217ce8c6b4252d810d3310cd2:/src/mac.c diff --git a/src/mac.c b/src/mac.c index 9f3455ab5d..5558cbb797 100644 --- a/src/mac.c +++ b/src/mac.c @@ -1,5 +1,5 @@ /* Unix emulation routines for GNU Emacs on the Mac OS. - Copyright (C) 2000, 2001 Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2005 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -15,8 +15,8 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ +the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ /* Contributed by Andrew Choi (akochoi@mac.com). */ @@ -24,37 +24,19 @@ Boston, MA 02111-1307, USA. */ #include #include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#if __MWERKS__ -#include -#endif -#ifdef MAC_OSX -#undef mktime -#undef DEBUG -#undef free -#undef malloc -#undef realloc -#undef init_process -#include -#undef free -#define free unexec_free -#undef malloc -#define malloc unexec_malloc -#undef realloc -#define realloc unexec_realloc +#include "lisp.h" +#include "process.h" #undef init_process -#define init_process emacs_init_process -#else /* not MAC_OSX */ +#include "systime.h" +#include "sysselect.h" +#include "blockinput.h" + +#include "macterm.h" + +#include "charset.h" +#include "coding.h" +#if !TARGET_API_MAC_CARBON #include #include #include @@ -66,14 +48,30 @@ Boston, MA 02111-1307, USA. */ #include #include #include -#endif /* not MAC_OSX */ +#include +#include +#include +#include +#include +#endif /* not TARGET_API_MAC_CARBON */ -#include "lisp.h" -#include "process.h" -#include "sysselect.h" -#include "systime.h" +#include +#include +#include +#include +#include +#include +#include +#include +#if __MWERKS__ +#include +#endif -Lisp_Object QCLIPBOARD; +/* The system script code. */ +static int mac_system_script_code; + +/* The system locale identifier string. */ +static Lisp_Object Vmac_system_locale; /* An instance of the AppleScript component. */ static ComponentInstance as_scripting_component; @@ -258,6 +256,886 @@ posix_to_mac_pathname (const char *ufn, char *mfn, int mfnbuflen) 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; +#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; +{ + CFStringRef str; + + str = CFStringCreateWithCString (NULL, c_str, kCFStringEncodingUTF8); + if (str == NULL) + /* Failed to interpret as UTF 8. Fall back on Mac Roman. */ + str = CFStringCreateWithCString (NULL, c_str, kCFStringEncodingMacRoman); + + return str; +} + + +/* Lisp string to CFString. */ + +CFStringRef +cfstring_create_with_string (s) + Lisp_Object s; +{ + CFStringRef string = NULL; + + if (STRING_MULTIBYTE (s)) + { + char *p, *end = SDATA (s) + SBYTES (s); + + for (p = SDATA (s); p < end; p++) + if (!isascii (*p)) + { + s = ENCODE_UTF_8 (s); + break; + } + string = CFStringCreateWithBytes (NULL, SDATA (s), SBYTES (s), + kCFStringEncodingUTF8, false); + } + + if (string == NULL) + /* Failed to interpret as UTF 8. Fall back on Mac Roman. */ + string = CFStringCreateWithBytes (NULL, SDATA (s), SBYTES (s), + kCFStringEncodingMacRoman, false); + + return string; +} + + +/* 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'. */ + +Lisp_Object +cfdate_to_lisp (date) + CFDateRef date; +{ + static const 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_white_space (p) + char **p; +{ + /* WhiteSpace = { | } */ + while (*P == ' ' || *P == '\t') + P++; +} + +static int +parse_comment (p) + char **p; +{ + /* Comment = "!" {} */ + 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)) != '\0') + { + 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 | */ + if (parse_comment (p) || parse_include_file (p)) + return Qnil; + + /* ResourceSpec = WhiteSpace ResourceName WhiteSpace ":" WhiteSpace Value */ + skip_white_space (p); + quarks = parse_resource_name (p); + if (NILP (quarks)) + goto cleanup; + skip_white_space (p); + if (*P != ':') + goto cleanup; + P++; + skip_white_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. Each node has a node id, which is a unique + nonnegative integer, and the root node id is 0. A database is + implemented as a hash table that maps a pair (SRC-NODE-ID . + EDGE-LABEL) to DEST-NODE-ID. It also holds a maximum node id used + in the table as a value for HASHKEY_MAX_NID. A value associated to + a node is recorded as a value for the node id. */ + +#define HASHKEY_MAX_NID (make_number (0)) + +static XrmDatabase +xrm_create_database () +{ + XrmDatabase database; + + database = make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE), + make_float (DEFAULT_REHASH_SIZE), + make_float (DEFAULT_REHASH_THRESHOLD), + Qnil, Qnil, Qnil); + Fputhash (HASHKEY_MAX_NID, make_number (0), database); + + return database; +} + +static void +xrm_q_put_resource (database, quarks, value) + XrmDatabase database; + Lisp_Object quarks, value; +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (database); + unsigned hash_code; + int max_nid, i; + Lisp_Object node_id, key; + + max_nid = XINT (Fgethash (HASHKEY_MAX_NID, database, Qnil)); + + XSETINT (node_id, 0); + for (; CONSP (quarks); quarks = XCDR (quarks)) + { + key = Fcons (node_id, XCAR (quarks)); + i = hash_lookup (h, key, &hash_code); + if (i < 0) + { + max_nid++; + XSETINT (node_id, max_nid); + hash_put (h, key, node_id, hash_code); + } + else + node_id = HASH_VALUE (h, i); + } + Fputhash (node_id, value, database); + + Fputhash (HASHKEY_MAX_NID, make_number (max_nid), 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_1 (database, node_id, quark_name, quark_class) + XrmDatabase database; + Lisp_Object node_id, quark_name, quark_class; +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (database); + Lisp_Object key, labels[3], value; + int i, k; + + if (!CONSP (quark_name)) + return Fgethash (node_id, database, Qnil); + + /* First, try tight bindings */ + labels[0] = XCAR (quark_name); + labels[1] = XCAR (quark_class); + labels[2] = SINGLE_COMPONENT; + + key = Fcons (node_id, Qnil); + for (k = 0; k < sizeof (labels) / sizeof (*labels); k++) + { + XSETCDR (key, labels[k]); + i = hash_lookup (h, key, NULL); + if (i >= 0) + { + value = xrm_q_get_resource_1 (database, HASH_VALUE (h, i), + XCDR (quark_name), XCDR (quark_class)); + if (!NILP (value)) + return value; + } + } + + /* Then, try loose bindings */ + XSETCDR (key, LOOSE_BINDING); + i = hash_lookup (h, key, NULL); + if (i >= 0) + { + value = xrm_q_get_resource_1 (database, HASH_VALUE (h, i), + quark_name, quark_class); + if (!NILP (value)) + return value; + else + return xrm_q_get_resource_1 (database, node_id, + XCDR (quark_name), XCDR (quark_class)); + } + else + return Qnil; +} + +static Lisp_Object +xrm_q_get_resource (database, quark_name, quark_class) + XrmDatabase database; + Lisp_Object quark_name, quark_class; +{ + return xrm_q_get_resource_1 (database, make_number (0), + quark_name, quark_class); +} + +/* 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 ()) + return build_string (CFBooleanGetValue (plist) ? "true" : "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 @@ -792,9 +1670,90 @@ sys_fopen (const char *name, const char *mode) } -#include +#include "keyboard.h" +extern Boolean mac_wait_next_event (EventRecord *, UInt32, Boolean); + +int +select (n, rfds, wfds, efds, timeout) + int n; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + struct timeval *timeout; +{ + OSErr err; +#if TARGET_API_MAC_CARBON + EventTimeout timeout_sec = + (timeout + ? (EMACS_SECS (*timeout) * kEventDurationSecond + + EMACS_USECS (*timeout) * kEventDurationMicrosecond) + : kEventDurationForever); + + BLOCK_INPUT; + err = ReceiveNextEvent (0, NULL, timeout_sec, kEventLeaveInQueue, NULL); + UNBLOCK_INPUT; +#else /* not TARGET_API_MAC_CARBON */ + EventRecord e; + UInt32 sleep_time = EMACS_SECS (*timeout) * 60 + + ((EMACS_USECS (*timeout) * 60) / 1000000); -long target_ticks = 0; + /* Can only handle wait for keyboard input. */ + if (n > 1 || wfds || efds) + return -1; + + /* Also return true if an event other than a keyDown has occurred. + This causes kbd_buffer_get_event in keyboard.c to call + read_avail_input which in turn calls XTread_socket to poll for + these events. Otherwise these never get processed except but a + very slow poll timer. */ + if (mac_wait_next_event (&e, sleep_time, false)) + err = noErr; + else + err = -9875; /* eventLoopTimedOutErr */ +#endif /* not TARGET_API_MAC_CARBON */ + + if (FD_ISSET (0, rfds)) + if (err == noErr) + return 1; + else + { + FD_ZERO (rfds); + return 0; + } + else + if (err == noErr) + { + if (input_polling_used ()) + { + /* It could be confusing if a real alarm arrives while + processing the fake one. Turn it off and let the + handler reset it. */ + extern void poll_for_input_1 P_ ((void)); + int old_poll_suppress_count = poll_suppress_count; + poll_suppress_count = 1; + poll_for_input_1 (); + poll_suppress_count = old_poll_suppress_count; + } + errno = EINTR; + return -1; + } + else + return 0; +} + + +/* Simulation of SIGALRM. The stub for function signal stores the + signal handler function in alarm_signal_func if a SIGALRM is + encountered. */ + +#include +#include "syssignal.h" + +static TMTask mac_atimer_task; + +static QElemPtr mac_atimer_qlink = (QElemPtr) &mac_atimer_task; + +static int signal_mask = 0; #ifdef __MRC__ __sigfun alarm_signal_func = (__sigfun) 0; @@ -804,146 +1763,156 @@ __signal_func_ptr alarm_signal_func = (__signal_func_ptr) 0; You lose!!! #endif /* not __MRC__ and not __MWERKS__ */ +#undef signal +#ifdef __MRC__ +extern __sigfun signal (int signal, __sigfun signal_func); +__sigfun +sys_signal (int signal_num, __sigfun signal_func) +#elif __MWERKS__ +extern __signal_func_ptr signal (int signal, __signal_func_ptr signal_func); +__signal_func_ptr +sys_signal (int signal_num, __signal_func_ptr signal_func) +#else /* not __MRC__ and not __MWERKS__ */ + You lose!!! +#endif /* not __MRC__ and not __MWERKS__ */ +{ + if (signal_num != SIGALRM) + return signal (signal_num, signal_func); + else + { +#ifdef __MRC__ + __sigfun old_signal_func; +#elif __MWERKS__ + __signal_func_ptr old_signal_func; +#else + You lose!!! +#endif + old_signal_func = alarm_signal_func; + alarm_signal_func = signal_func; + return old_signal_func; + } +} + + +static pascal void +mac_atimer_handler (qlink) + TMTaskPtr qlink; +{ + if (alarm_signal_func) + (alarm_signal_func) (SIGALRM); +} -/* These functions simulate SIG_ALRM. The stub for function signal - stores the signal handler function in alarm_signal_func if a - SIG_ALRM is encountered. check_alarm is called in XTread_socket, - which emacs calls periodically. A pending alarm is represented by - a non-zero target_ticks value. check_alarm calls the handler - function pointed to by alarm_signal_func if one has been set up and - an alarm is pending. */ -void -check_alarm () +static void +set_mac_atimer (count) + long count; { - if (target_ticks && TickCount () > target_ticks) - { - target_ticks = 0; - if (alarm_signal_func) - (*alarm_signal_func)(SIGALRM); - } + static TimerUPP mac_atimer_handlerUPP = NULL; + + if (mac_atimer_handlerUPP == NULL) + mac_atimer_handlerUPP = NewTimerUPP (mac_atimer_handler); + mac_atimer_task.tmCount = 0; + mac_atimer_task.tmAddr = mac_atimer_handlerUPP; + mac_atimer_qlink = (QElemPtr) &mac_atimer_task; + InsTime (mac_atimer_qlink); + if (count) + PrimeTime (mac_atimer_qlink, count); } int -select (n, rfds, wfds, efds, timeout) - int n; - SELECT_TYPE *rfds; - SELECT_TYPE *wfds; - SELECT_TYPE *efds; - struct timeval *timeout; +remove_mac_atimer (remaining_count) + long *remaining_count; { -#ifdef TARGET_API_MAC_CARBON - return 1; -#else /* not TARGET_API_MAC_CARBON */ - EMACS_TIME end_time, now; - EventRecord e; + if (mac_atimer_qlink) + { + RmvTime (mac_atimer_qlink); + if (remaining_count) + *remaining_count = mac_atimer_task.tmCount; + mac_atimer_qlink = NULL; - /* Can only handle wait for keyboard input. */ - if (n > 1 || wfds || efds) + return 0; + } + else return -1; +} - EMACS_GET_TIME (end_time); - EMACS_ADD_TIME (end_time, end_time, *timeout); - - do - { - /* Also return true if an event other than a keyDown has - occurred. This causes kbd_buffer_get_event in keyboard.c to - call read_avail_input which in turn calls XTread_socket to - poll for these events. Otherwise these never get processed - except but a very slow poll timer. */ - if (FD_ISSET (0, rfds) && EventAvail (everyEvent, &e)) - return 1; - /* Also check movement of the mouse. */ - { - Point mouse_pos; - static Point old_mouse_pos = {-1, -1}; - - GetMouse (&mouse_pos); - if (!EqualPt (mouse_pos, old_mouse_pos)) - { - old_mouse_pos = mouse_pos; - return 1; - } - } +int +sigblock (int mask) +{ + int old_mask = signal_mask; - WaitNextEvent (0, &e, 1UL, NULL); /* Accept no event; wait 1 - tic. by T.I. */ + signal_mask |= mask; - EMACS_GET_TIME (now); - EMACS_SUB_TIME (now, end_time, now); - } - while (!EMACS_TIME_NEG_P (now)); + if ((old_mask ^ signal_mask) & sigmask (SIGALRM)) + remove_mac_atimer (NULL); - return 0; -#endif /* not TARGET_API_MAC_CARBON */ + return old_mask; } -/* Called in sys_select to wait for an alarm signal to arrive. */ - int -pause () +sigsetmask (int mask) { - EventRecord e; - unsigned long tick; - - if (!target_ticks) /* no alarm pending */ - return -1; + int old_mask = signal_mask; - if ((tick = TickCount ()) < target_ticks) - WaitNextEvent (0, &e, target_ticks - tick, NULL); /* Accept no event; - just wait. by T.I. */ + signal_mask = mask; - target_ticks = 0; - if (alarm_signal_func) - (*alarm_signal_func)(SIGALRM); + if ((old_mask ^ signal_mask) & sigmask (SIGALRM)) + if (signal_mask & sigmask (SIGALRM)) + remove_mac_atimer (NULL); + else + set_mac_atimer (mac_atimer_task.tmCount); - return 0; + return old_mask; } int alarm (int seconds) { - long remaining = target_ticks ? (TickCount () - target_ticks) / 60 : 0; + long remaining_count; + + if (remove_mac_atimer (&remaining_count) == 0) + { + set_mac_atimer (seconds * 1000); - target_ticks = seconds ? TickCount () + 60 * seconds : 0; + return remaining_count / 1000; + } + else + { + mac_atimer_task.tmCount = seconds * 1000; - return (remaining < 0) ? 0 : (unsigned int) remaining; + return 0; + } } -#undef signal -#ifdef __MRC__ -extern __sigfun signal (int signal, __sigfun signal_func); -__sigfun -sys_signal (int signal_num, __sigfun signal_func) -#elif __MWERKS__ -extern __signal_func_ptr signal (int signal, __signal_func_ptr signal_func); -__signal_func_ptr -sys_signal (int signal_num, __signal_func_ptr signal_func) -#else /* not __MRC__ and not __MWERKS__ */ - You lose!!! -#endif /* not __MRC__ and not __MWERKS__ */ +int +setitimer (which, value, ovalue) + int which; + const struct itimerval *value; + struct itimerval *ovalue; { - if (signal_num != SIGALRM) - return signal (signal_num, signal_func); - else + long remaining_count; + long count = (EMACS_SECS (value->it_value) * 1000 + + (EMACS_USECS (value->it_value) + 999) / 1000); + + if (remove_mac_atimer (&remaining_count) == 0) { -#ifdef __MRC__ - __sigfun old_signal_func; -#elif __MWERKS__ - __signal_func_ptr old_signal_func; -#else - You lose!!! -#endif - old_signal_func = alarm_signal_func; - alarm_signal_func = signal_func; - return old_signal_func; + if (ovalue) + { + bzero (ovalue, sizeof (*ovalue)); + EMACS_SET_SECS_USECS (ovalue->it_value, remaining_count / 1000, + (remaining_count % 1000) * 1000); + } + set_mac_atimer (count); } + else + mac_atimer_task.tmCount = count; + + return 0; } @@ -1074,35 +2043,6 @@ sys_time (time_t *timer) } -/* MPW strftime broken for "%p" format */ -#ifdef __MRC__ -#undef strftime -#include -size_t -sys_strftime (char * s, size_t maxsize, const char * format, - const struct tm * timeptr) -{ - if (strcmp (format, "%p") == 0) - { - if (maxsize < 3) - return 0; - if (timeptr->tm_hour < 12) - { - strcpy (s, "AM"); - return 2; - } - else - { - strcpy (s, "PM"); - return 2; - } - } - else - return strftime (s, maxsize, format, timeptr); -} -#endif /* __MRC__ */ - - /* no subprocesses, empty wait */ int @@ -1120,13 +2060,6 @@ croak (char *badfunc) } -char * -index (const char * str, int chr) -{ - return strchr (str, chr); -} - - char * mktemp (char *template) { @@ -1315,20 +2248,6 @@ sys_subshell () } -int -sigsetmask (int x) -{ - return 0; -} - - -int -sigblock (int mask) -{ - return 0; -} - - void request_sigio (void) { @@ -1424,6 +2343,39 @@ path_from_vol_dir_name (char *path, int man_path_len, short vol_ref_num, return 1; /* success */ } + +OSErr +posix_pathname_to_fsspec (ufn, fs) + const char *ufn; + FSSpec *fs; +{ + Str255 mac_pathname; + + if (posix_to_mac_pathname (ufn, mac_pathname, sizeof (mac_pathname)) == 0) + return fnfErr; + else + { + c2pstr (mac_pathname); + return FSMakeFSSpec (0, 0, mac_pathname, fs); + } +} + +OSErr +fsspec_to_posix_pathname (fs, ufn, ufnbuflen) + const FSSpec *fs; + char *ufn; + int ufnbuflen; +{ + char mac_pathname[MAXPATHLEN]; + + if (path_from_vol_dir_name (mac_pathname, sizeof (mac_pathname) - 1, + fs->vRefNum, fs->parID, fs->name) + && mac_to_posix_pathname (mac_pathname, ufn, ufnbuflen)) + return noErr; + else + return fnfErr; +} + #ifndef MAC_OSX int @@ -1535,6 +2487,22 @@ chmod (const char *path, mode_t mode) } +int +fchmod (int fd, mode_t mode) +{ + /* say it always succeed for now */ + return 0; +} + + +int +fchown (int fd, uid_t owner, gid_t group) +{ + /* say it always succeed for now */ + return 0; +} + + int dup (int oldd) { @@ -1902,9 +2870,6 @@ uname (struct utsname *name) } -#include -#include - /* Event class of HLE sent to subprocess. */ const OSType kEmacsSubprocessSend = 'ESND'; @@ -1976,7 +2941,7 @@ run_mac_command (argv, workdir, infn, outfn, errfn) const char *workdir; const char *infn, *outfn, *errfn; { -#ifdef TARGET_API_MAC_CARBON +#if TARGET_API_MAC_CARBON return -1; #else /* not TARGET_API_MAC_CARBON */ char macappname[MAXPATHLEN+1], macworkdir[MAXPATHLEN+1]; @@ -2061,7 +3026,7 @@ run_mac_command (argv, workdir, infn, outfn, errfn) strcat (t, newargv[0]); #endif /* 0 */ Lisp_Object path; - openp (Vexec_path, build_string (newargv[0]), EXEC_SUFFIXES, &path, + openp (Vexec_path, build_string (newargv[0]), Vexec_suffixes, &path, make_number (X_OK)); if (NILP (path)) @@ -2386,61 +3351,327 @@ readdir (DIR *dp) p++; } - s_dirent.d_ino = cipb.dirInfo.ioDrDirID; - /* value unimportant: non-zero for valid file */ - s_dirent.d_name = s_name; + s_dirent.d_ino = cipb.dirInfo.ioDrDirID; + /* value unimportant: non-zero for valid file */ + s_dirent.d_name = s_name; + + return &s_dirent; + } +} + + +char * +getwd (char *path) +{ + char mac_pathname[MAXPATHLEN+1]; + Str255 directory_name; + OSErr errno; + CInfoPBRec cipb; + + if (path_from_vol_dir_name (mac_pathname, 255, 0, 0, "\p") == 0) + return NULL; + + if (mac_to_posix_pathname (mac_pathname, path, MAXPATHLEN+1) == 0) + return 0; + else + return path; +} + +#endif /* ! MAC_OSX */ + + +void +initialize_applescript () +{ + AEDesc null_desc; + OSAError osaerror; + + /* if open fails, as_scripting_component is set to NULL. Its + subsequent use in OSA calls will fail with badComponentInstance + error. */ + as_scripting_component = OpenDefaultComponent (kOSAComponentType, + kAppleScriptSubtype); + + null_desc.descriptorType = typeNull; + null_desc.dataHandle = 0; + osaerror = OSAMakeContext (as_scripting_component, &null_desc, + kOSANullScript, &as_script_context); + if (osaerror) + as_script_context = kOSANullScript; + /* use default context if create fails */ +} + + +void +terminate_applescript() +{ + OSADispose (as_scripting_component, as_script_context); + CloseComponent (as_scripting_component); +} + +/* Convert a lisp string to the 4 byte character code. */ + +OSType +mac_get_code_from_arg(Lisp_Object arg, OSType defCode) +{ + OSType result; + if (NILP(arg)) + { + result = defCode; + } + else + { + /* check type string */ + CHECK_STRING(arg); + if (SBYTES (arg) != 4) + { + error ("Wrong argument: need string of length 4 for code"); + } + result = EndianU32_BtoN (*((UInt32 *) SDATA (arg))); + } + return result; +} + +/* Convert the 4 byte character code into a 4 byte string. */ + +Lisp_Object +mac_get_object_from_code(OSType defCode) +{ + UInt32 code = EndianU32_NtoB (defCode); + + return make_unibyte_string ((char *)&code, 4); +} + + +DEFUN ("mac-get-file-creator", Fmac_get_file_creator, Smac_get_file_creator, 1, 1, 0, + doc: /* Get the creator code of FILENAME as a four character string. */) + (filename) + Lisp_Object filename; +{ + OSErr status; +#ifdef MAC_OSX + FSRef fref; +#else + FSSpec fss; +#endif + OSType cCode; + Lisp_Object result = Qnil; + CHECK_STRING (filename); + + if (NILP(Ffile_exists_p(filename)) || !NILP(Ffile_directory_p(filename))) { + return Qnil; + } + filename = Fexpand_file_name (filename, Qnil); + + BLOCK_INPUT; +#ifdef MAC_OSX + status = FSPathMakeRef(SDATA(ENCODE_FILE(filename)), &fref, NULL); +#else + status = posix_pathname_to_fsspec (SDATA (ENCODE_FILE (filename)), &fss); +#endif + + if (status == noErr) + { +#ifdef MAC_OSX + FSCatalogInfo catalogInfo; + + status = FSGetCatalogInfo(&fref, kFSCatInfoFinderInfo, + &catalogInfo, NULL, NULL, NULL); +#else + FInfo finder_info; + + status = FSpGetFInfo (&fss, &finder_info); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + result = mac_get_object_from_code(((FileInfo*)&catalogInfo.finderInfo)->fileCreator); +#else + result = mac_get_object_from_code (finder_info.fdCreator); +#endif + } + } + UNBLOCK_INPUT; + if (status != noErr) { + error ("Error while getting file information."); + } + return result; +} + +DEFUN ("mac-get-file-type", Fmac_get_file_type, Smac_get_file_type, 1, 1, 0, + doc: /* Get the type code of FILENAME as a four character string. */) + (filename) + Lisp_Object filename; +{ + OSErr status; +#ifdef MAC_OSX + FSRef fref; +#else + FSSpec fss; +#endif + OSType cCode; + Lisp_Object result = Qnil; + CHECK_STRING (filename); + + if (NILP(Ffile_exists_p(filename)) || !NILP(Ffile_directory_p(filename))) { + return Qnil; + } + filename = Fexpand_file_name (filename, Qnil); + + BLOCK_INPUT; +#ifdef MAC_OSX + status = FSPathMakeRef(SDATA(ENCODE_FILE(filename)), &fref, NULL); +#else + status = posix_pathname_to_fsspec (SDATA (ENCODE_FILE (filename)), &fss); +#endif + + if (status == noErr) + { +#ifdef MAC_OSX + FSCatalogInfo catalogInfo; + + status = FSGetCatalogInfo(&fref, kFSCatInfoFinderInfo, + &catalogInfo, NULL, NULL, NULL); +#else + FInfo finder_info; - return &s_dirent; + status = FSpGetFInfo (&fss, &finder_info); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + result = mac_get_object_from_code(((FileInfo*)&catalogInfo.finderInfo)->fileType); +#else + result = mac_get_object_from_code (finder_info.fdType); +#endif + } } + UNBLOCK_INPUT; + if (status != noErr) { + error ("Error while getting file information."); + } + return result; } - -char * -getwd (char *path) +DEFUN ("mac-set-file-creator", Fmac_set_file_creator, Smac_set_file_creator, 1, 2, 0, + doc: /* Set creator code of file FILENAME to CODE. +If non-nil, CODE must be a 4-character string. Otherwise, 'EMAx' is +assumed. Return non-nil if successful. */) + (filename, code) + Lisp_Object filename, code; { - char mac_pathname[MAXPATHLEN+1]; - Str255 directory_name; - OSErr errno; - CInfoPBRec cipb; + OSErr status; +#ifdef MAC_OSX + FSRef fref; +#else + FSSpec fss; +#endif + OSType cCode; + CHECK_STRING (filename); - if (path_from_vol_dir_name (mac_pathname, 255, 0, 0, "\p") == 0) - return NULL; + cCode = mac_get_code_from_arg(code, 'EMAx'); - if (mac_to_posix_pathname (mac_pathname, path, MAXPATHLEN+1) == 0) - return 0; - else - return path; -} + if (NILP(Ffile_exists_p(filename)) || !NILP(Ffile_directory_p(filename))) { + return Qnil; + } + filename = Fexpand_file_name (filename, Qnil); -#endif /* ! MAC_OSX */ + BLOCK_INPUT; +#ifdef MAC_OSX + status = FSPathMakeRef(SDATA(ENCODE_FILE(filename)), &fref, NULL); +#else + status = posix_pathname_to_fsspec (SDATA (ENCODE_FILE (filename)), &fss); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + FSCatalogInfo catalogInfo; + FSRef parentDir; + status = FSGetCatalogInfo(&fref, kFSCatInfoFinderInfo, + &catalogInfo, NULL, NULL, &parentDir); +#else + FInfo finder_info; -void -initialize_applescript () + status = FSpGetFInfo (&fss, &finder_info); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + ((FileInfo*)&catalogInfo.finderInfo)->fileCreator = cCode; + status = FSSetCatalogInfo(&fref, kFSCatInfoFinderInfo, &catalogInfo); + /* TODO: on Mac OS 10.2, we need to touch the parent dir, FNNotify? */ +#else + finder_info.fdCreator = cCode; + status = FSpSetFInfo (&fss, &finder_info); +#endif + } + } + UNBLOCK_INPUT; + if (status != noErr) { + error ("Error while setting creator information."); + } + return Qt; +} + +DEFUN ("mac-set-file-type", Fmac_set_file_type, Smac_set_file_type, 2, 2, 0, + doc: /* Set file code of file FILENAME to CODE. +CODE must be a 4-character string. Return non-nil if successful. */) + (filename, code) + Lisp_Object filename, code; { - AEDesc null_desc; - OSAError osaerror; + OSErr status; +#ifdef MAC_OSX + FSRef fref; +#else + FSSpec fss; +#endif + OSType cCode; + CHECK_STRING (filename); - /* if open fails, as_scripting_component is set to NULL. Its - subsequent use in OSA calls will fail with badComponentInstance - error. */ - as_scripting_component = OpenDefaultComponent (kOSAComponentType, - kAppleScriptSubtype); + cCode = mac_get_code_from_arg(code, 0); /* Default to empty code*/ - null_desc.descriptorType = typeNull; - null_desc.dataHandle = 0; - osaerror = OSAMakeContext (as_scripting_component, &null_desc, - kOSANullScript, &as_script_context); - if (osaerror) - as_script_context = kOSANullScript; - /* use default context if create fails */ -} + if (NILP(Ffile_exists_p(filename)) || !NILP(Ffile_directory_p(filename))) { + return Qnil; + } + filename = Fexpand_file_name (filename, Qnil); + + BLOCK_INPUT; +#ifdef MAC_OSX + status = FSPathMakeRef(SDATA(ENCODE_FILE(filename)), &fref, NULL); +#else + status = posix_pathname_to_fsspec (SDATA (ENCODE_FILE (filename)), &fss); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + FSCatalogInfo catalogInfo; + FSRef parentDir; + status = FSGetCatalogInfo(&fref, kFSCatInfoFinderInfo, + &catalogInfo, NULL, NULL, &parentDir); +#else + FInfo finder_info; -void terminate_applescript() -{ - OSADispose (as_scripting_component, as_script_context); - CloseComponent (as_scripting_component); + status = FSpGetFInfo (&fss, &finder_info); +#endif + if (status == noErr) + { +#ifdef MAC_OSX + ((FileInfo*)&catalogInfo.finderInfo)->fileType = cCode; + status = FSSetCatalogInfo(&fref, kFSCatInfoFinderInfo, &catalogInfo); + /* TODO: on Mac OS 10.2, we need to touch the parent dir, FNNotify? */ +#else + finder_info.fdType = cCode; + status = FSpSetFInfo (&fss, &finder_info); +#endif + } + } + UNBLOCK_INPUT; + if (status != noErr) { + error ("Error while setting creator information."); + } + return Qt; } @@ -2533,12 +3764,12 @@ do_applescript (char *script, char **result) DEFUN ("do-applescript", Fdo_applescript, Sdo_applescript, 1, 1, 0, - doc: /* Compile and execute AppleScript SCRIPT and retrieve and return the result. + doc: /* Compile and execute AppleScript SCRIPT and return the result. If compilation and execution are successful, the resulting script value is returned as a string. Otherwise the function aborts and displays the error message returned by the AppleScript scripting component. */) - (script) + (script) Lisp_Object script; { char *result, *temp; @@ -2547,7 +3778,9 @@ component. */) CHECK_STRING (script); + BLOCK_INPUT; status = do_applescript (SDATA (script), &result); + UNBLOCK_INPUT; if (status) { if (!result) @@ -2576,16 +3809,15 @@ component. */) DEFUN ("mac-file-name-to-posix", Fmac_file_name_to_posix, Smac_file_name_to_posix, 1, 1, 0, - doc: /* Convert Macintosh filename to Posix form. */) - (mac_filename) - Lisp_Object mac_filename; + doc: /* Convert Macintosh FILENAME to Posix form. */) + (filename) + Lisp_Object filename; { char posix_filename[MAXPATHLEN+1]; - CHECK_STRING (mac_filename); + CHECK_STRING (filename); - if (mac_to_posix_pathname (SDATA (mac_filename), posix_filename, - MAXPATHLEN)) + if (mac_to_posix_pathname (SDATA (filename), posix_filename, MAXPATHLEN)) return build_string (posix_filename); else return Qnil; @@ -2594,172 +3826,362 @@ DEFUN ("mac-file-name-to-posix", Fmac_file_name_to_posix, DEFUN ("posix-file-name-to-mac", Fposix_file_name_to_mac, Sposix_file_name_to_mac, 1, 1, 0, - doc: /* Convert Posix filename to Mac form. */) - (posix_filename) - Lisp_Object posix_filename; + doc: /* Convert Posix FILENAME to Mac form. */) + (filename) + Lisp_Object filename; { char mac_filename[MAXPATHLEN+1]; - CHECK_STRING (posix_filename); + CHECK_STRING (filename); - if (posix_to_mac_pathname (SDATA (posix_filename), mac_filename, - MAXPATHLEN)) + if (posix_to_mac_pathname (SDATA (filename), mac_filename, MAXPATHLEN)) return build_string (mac_filename); else return Qnil; } -/* set interprogram-paste-function to mac-paste-function in mac-win.el - to enable Emacs to obtain the contents of the Mac clipboard. */ -DEFUN ("mac-paste-function", Fmac_paste_function, Smac_paste_function, 0, 0, 0, - doc: /* Return the contents of the Mac clipboard as a string. */) - () -{ #if TARGET_API_MAC_CARBON - ScrapRef scrap; - ScrapFlavorFlags sff; - Size s; - int i; - char *data; +static Lisp_Object Qxml, Qmime_charset; +static Lisp_Object QNFD, QNFKD, QNFC, QNFKC, QHFS_plus_D, QHFS_plus_C; + +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. Return nil if +lookup is failed at some stage. + +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 Vector 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 (GetCurrentScrap (&scrap) != noErr) - return Qnil; + 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); - if (GetScrapFlavorFlags (scrap, kScrapFlavorTypeText, &sff) != noErr) - return Qnil; + BLOCK_INPUT; - if (GetScrapFlavorSize (scrap, kScrapFlavorTypeText, &s) != noErr) - return Qnil; + app_id = kCFPreferencesCurrentApplication; + if (!NILP (application)) + { + app_id = cfstring_create_with_string (application); + if (app_id == NULL) + goto out; + } + key_str = cfstring_create_with_string (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_string (XCAR (key)); + if (key_str == NULL) + goto out; + plist = CFDictionaryGetValue (plist, key_str); + CFRelease (key_str); + if (plist == NULL) + goto out; + } - if ((data = (char*) alloca (s)) == NULL) - return Qnil; + 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)); - if (GetScrapFlavorData (scrap, kScrapFlavorTypeText, &s, data) != noErr - || s == 0) - return Qnil; + out: + if (app_plist) + CFRelease (app_plist); + CFRelease (app_id); - /* Emacs expects clipboard contents have Unix-style eol's */ - for (i = 0; i < s; i++) - if (data[i] == '\r') - data[i] = '\n'; + UNBLOCK_INPUT; - return make_string (data, s); -#else /* not TARGET_API_MAC_CARBON */ - Lisp_Object value; - Handle my_handle; - long scrap_offset, rc, i; + return result; +} - my_handle = NewHandle (0); /* allocate 0-length data area */ - rc = GetScrap (my_handle, 'TEXT', &scrap_offset); - if (rc < 0) - return Qnil; +static CFStringEncoding +get_cfstring_encoding_from_lisp (obj) + Lisp_Object obj; +{ + CFStringRef iana_name; + CFStringEncoding encoding = kCFStringEncodingInvalidId; - HLock (my_handle); + if (INTEGERP (obj)) + return XINT (obj); - /* Emacs expects clipboard contents have Unix-style eol's */ - for (i = 0; i < rc; i++) - if ((*my_handle)[i] == '\r') - (*my_handle)[i] = '\n'; + if (SYMBOLP (obj) && !NILP (obj) && !NILP (Fcoding_system_p (obj))) + { + Lisp_Object coding_spec, plist; - value = make_string (*my_handle, rc); + coding_spec = Fget (obj, Qcoding_system); + plist = XVECTOR (coding_spec)->contents[3]; + obj = Fplist_get (XVECTOR (coding_spec)->contents[3], Qmime_charset); + } - HUnlock (my_handle); + if (SYMBOLP (obj)) + obj = SYMBOL_NAME (obj); - DisposeHandle (my_handle); + if (STRINGP (obj)) + { + iana_name = cfstring_create_with_string (obj); + if (iana_name) + { + encoding = CFStringConvertIANACharSetNameToEncoding (iana_name); + CFRelease (iana_name); + } + } - return value; -#endif /* not TARGET_API_MAC_CARBON */ + return encoding; } - -/* set interprogram-cut-function to mac-cut-function in mac-win.el - to enable Emacs to write the top of the kill-ring to the Mac clipboard. */ -DEFUN ("mac-cut-function", Fmac_cut_function, Smac_cut_function, 1, 2, 0, - doc: /* Put the value of the string parameter to the Mac clipboard. */) - (value, push) - Lisp_Object value, push; +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1020 +static CFStringRef +cfstring_create_normalized (str, symbol) + CFStringRef str; + Lisp_Object symbol; { - char *buf; - int len, i; - - /* fixme: ignore the push flag for now */ - - CHECK_STRING (value); + int form = -1; + TextEncodingVariant variant; + float initial_mag = 0.0; + CFStringRef result = NULL; + + if (EQ (symbol, QNFD)) + form = kCFStringNormalizationFormD; + else if (EQ (symbol, QNFKD)) + form = kCFStringNormalizationFormKD; + else if (EQ (symbol, QNFC)) + form = kCFStringNormalizationFormC; + else if (EQ (symbol, QNFKC)) + form = kCFStringNormalizationFormKC; + else if (EQ (symbol, QHFS_plus_D)) + { + variant = kUnicodeHFSPlusDecompVariant; + initial_mag = 1.5; + } + else if (EQ (symbol, QHFS_plus_C)) + { + variant = kUnicodeHFSPlusCompVariant; + initial_mag = 1.0; + } - len = SCHARS (value); - buf = (char *) alloca (len+1); - bcopy (SDATA (value), buf, len); - buf[len] = '\0'; + if (form >= 0) + { + CFMutableStringRef mut_str = CFStringCreateMutableCopy (NULL, 0, str); - /* convert to Mac-style eol's before sending to clipboard */ - for (i = 0; i < len; i++) - if (buf[i] == '\n') - buf[i] = '\r'; + if (mut_str) + { + CFStringNormalize (mut_str, form); + result = mut_str; + } + } + else if (initial_mag > 0.0) + { + UnicodeToTextInfo uni = NULL; + UnicodeMapping map; + CFIndex length; + UniChar *in_text, *buffer = NULL, *out_buf = NULL; + OSErr err = noErr; + ByteCount out_read, out_size, out_len; + + map.unicodeEncoding = CreateTextEncoding (kTextEncodingUnicodeDefault, + kUnicodeNoSubset, + kTextEncodingDefaultFormat); + map.otherEncoding = CreateTextEncoding (kTextEncodingUnicodeDefault, + variant, + kTextEncodingDefaultFormat); + map.mappingVersion = kUnicodeUseLatestMapping; + + length = CFStringGetLength (str); + out_size = (int)((float)length * initial_mag) * sizeof (UniChar); + if (out_size < 32) + out_size = 32; + + in_text = (UniChar *)CFStringGetCharactersPtr (str); + if (in_text == NULL) + { + buffer = xmalloc (sizeof (UniChar) * length); + if (buffer) + { + CFStringGetCharacters (str, CFRangeMake (0, length), buffer); + in_text = buffer; + } + } -#if TARGET_API_MAC_CARBON - { - ScrapRef scrap; - ClearCurrentScrap (); - if (GetCurrentScrap (&scrap) != noErr) - error ("cannot get current scrap"); - - if (PutScrapFlavor (scrap, kScrapFlavorTypeText, kScrapFlavorMaskNone, len, - buf) != noErr) - error ("cannot put to scrap"); - } -#else /* not TARGET_API_MAC_CARBON */ - ZeroScrap (); - PutScrap (len, 'TEXT', buf); -#endif /* not TARGET_API_MAC_CARBON */ + if (in_text) + err = CreateUnicodeToTextInfo(&map, &uni); + while (err == noErr) + { + out_buf = xmalloc (out_size); + if (out_buf == NULL) + err = mFulErr; + else + err = ConvertFromUnicodeToText (uni, length * sizeof (UniChar), + in_text, + kUnicodeDefaultDirectionMask, + 0, NULL, NULL, NULL, + out_size, &out_read, &out_len, + out_buf); + if (err == noErr && out_read < length * sizeof (UniChar)) + { + xfree (out_buf); + out_size += length; + } + else + break; + } + if (err == noErr) + result = CFStringCreateWithCharacters (NULL, out_buf, + out_len / sizeof (UniChar)); + if (uni) + DisposeUnicodeToTextInfo (&uni); + if (out_buf) + xfree (out_buf); + if (buffer) + xfree (buffer); + } + else + { + result = str; + CFRetain (result); + } - return Qnil; + return result; } +#endif - -DEFUN ("x-selection-exists-p", Fx_selection_exists_p, Sx_selection_exists_p, - 0, 1, 0, - doc: /* Whether there is an owner for the given X Selection. -The arg should be the name of the selection in question, typically one of -the symbols `PRIMARY', `SECONDARY', or `CLIPBOARD'. -\(Those are literal upper-case symbol names, since that's what X expects.) -For convenience, the symbol nil is the same as `PRIMARY', -and t is the same as `SECONDARY'. */) - (selection) - Lisp_Object selection; +DEFUN ("mac-code-convert-string", Fmac_code_convert_string, Smac_code_convert_string, 3, 4, 0, + doc: /* Convert STRING from SOURCE encoding to TARGET encoding. +The conversion is performed using the converter provided by the system. +Each encoding is specified by either a coding system symbol, a mime +charset string, or an integer as a CFStringEncoding value. +On Mac OS X 10.2 and later, you can do Unicode Normalization by +specifying the optional argument NORMALIZATION-FORM with a symbol NFD, +NFKD, NFC, NFKC, HFS+D, or HFS+C. +On successful conversion, return the result string, else return nil. */) + (string, source, target, normalization_form) + Lisp_Object string, source, target, normalization_form; { - CHECK_SYMBOL (selection); - - /* Return nil for PRIMARY and SECONDARY selections; for CLIPBOARD, check - if the clipboard currently has valid text format contents. */ - - if (EQ (selection, QCLIPBOARD)) + Lisp_Object result = Qnil; + CFStringEncoding src_encoding, tgt_encoding; + CFStringRef str = NULL; + CFDataRef data = NULL; + + CHECK_STRING (string); + if (!INTEGERP (source) && !STRINGP (source)) + CHECK_SYMBOL (source); + if (!INTEGERP (target) && !STRINGP (target)) + CHECK_SYMBOL (target); + CHECK_SYMBOL (normalization_form); + + BLOCK_INPUT; + + src_encoding = get_cfstring_encoding_from_lisp (source); + tgt_encoding = get_cfstring_encoding_from_lisp (target); + + /* We really want string_to_unibyte, but since it doesn't exist yet, we + use string_as_unibyte which works as well, except for the fact that + it's too permissive (it doesn't check that the multibyte string only + contain single-byte chars). */ + string = Fstring_as_unibyte (string); + if (src_encoding != kCFStringEncodingInvalidId + && tgt_encoding != kCFStringEncodingInvalidId) + str = CFStringCreateWithBytes (NULL, SDATA (string), SBYTES (string), + src_encoding, true); +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1020 + if (str) { - Lisp_Object val = Qnil; - -#if TARGET_API_MAC_CARBON - ScrapRef scrap; - ScrapFlavorFlags sff; + CFStringRef saved_str = str; - if (GetCurrentScrap (&scrap) == noErr) - if (GetScrapFlavorFlags (scrap, kScrapFlavorTypeText, &sff) == noErr) - val = Qt; -#else /* not TARGET_API_MAC_CARBON */ - Handle my_handle; - long rc, scrap_offset; + str = cfstring_create_normalized (saved_str, normalization_form); + CFRelease (saved_str); + } +#endif + if (str) + { + data = CFStringCreateExternalRepresentation (NULL, str, + tgt_encoding, '\0'); + CFRelease (str); + } + if (data) + { + result = cfdata_to_lisp (data); + CFRelease (data); + } - my_handle = NewHandle (0); + UNBLOCK_INPUT; - rc = GetScrap (my_handle, 'TEXT', &scrap_offset); - if (rc >= 0) - val = Qt; + return result; +} +#endif /* TARGET_API_MAC_CARBON */ - DisposeHandle (my_handle); -#endif /* not TARGET_API_MAC_CARBON */ - return val; - } +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. */) + () +{ + check_mac (); + mac_clear_font_name_table (); return Qnil; } @@ -2769,91 +4191,267 @@ and t is the same as `SECONDARY'. */) extern int inhibit_window_system; extern int noninteractive; -/* When Emacs is started from the Finder, SELECT always immediately - returns as if input is present when file descriptor 0 is polled for - input. Strangely, when Emacs is run as a GUI application from the - command line, it blocks in the same situation. This `wrapper' of - the system call SELECT corrects this discrepancy. */ +/* Unlike in X11, window events in Carbon do not come from sockets. + So we cannot simply use `select' to monitor two kinds of inputs: + window events and process outputs. We emulate such functionality + by regarding fd 0 as the window event channel and simultaneously + monitoring both kinds of input channels. It is implemented by + dividing into some cases: + 1. The window event channel is not involved. + -> Use `select'. + 2. Sockets are not involved. + -> Use ReceiveNextEvent. + 3. [If SELECT_USE_CFSOCKET is defined] + Only the window event channel and socket read channels are + involved, and timeout is not too short (greater than + SELECT_TIMEOUT_THRESHHOLD_RUNLOOP seconds). + -> Create CFSocket for each socket and add it into the current + event RunLoop so that an `ready-to-read' event can be posted + to the event queue that is also used for window events. Then + ReceiveNextEvent can wait for both kinds of inputs. + 4. Otherwise. + -> Periodically poll the window input channel while repeatedly + executing `select' with a short timeout + (SELECT_POLLING_PERIOD_USEC microseconds). */ + +#define SELECT_POLLING_PERIOD_USEC 20000 +#ifdef SELECT_USE_CFSOCKET +#define SELECT_TIMEOUT_THRESHOLD_RUNLOOP 0.2 +#define EVENT_CLASS_SOCK 'Sock' + +static void +socket_callback (s, type, address, data, info) + CFSocketRef s; + CFSocketCallBackType type; + CFDataRef address; + const void *data; + void *info; +{ + EventRef event; + + CreateEvent (NULL, EVENT_CLASS_SOCK, 0, 0, kEventAttributeNone, &event); + PostEventToQueue (GetCurrentEventQueue (), event, kEventPriorityStandard); + ReleaseEvent (event); +} +#endif /* SELECT_USE_CFSOCKET */ + +static int +select_and_poll_event (n, rfds, wfds, efds, timeout) + int n; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + struct timeval *timeout; +{ + int r; + OSErr err; + + r = select (n, rfds, wfds, efds, timeout); + if (r != -1) + { + BLOCK_INPUT; + err = ReceiveNextEvent (0, NULL, kEventDurationNoWait, + kEventLeaveInQueue, NULL); + UNBLOCK_INPUT; + if (err == noErr) + { + FD_SET (0, rfds); + r++; + } + } + return r; +} + +#if MAC_OS_X_VERSION_MAX_ALLOWED < 1020 +#undef SELECT_INVALIDATE_CFSOCKET +#endif + int sys_select (n, rfds, wfds, efds, timeout) - int n; - SELECT_TYPE *rfds; - SELECT_TYPE *wfds; - SELECT_TYPE *efds; - struct timeval *timeout; + int n; + SELECT_TYPE *rfds; + SELECT_TYPE *wfds; + SELECT_TYPE *efds; + struct timeval *timeout; { - if (!inhibit_window_system && rfds && FD_ISSET (0, rfds)) - return 1; - else if (inhibit_window_system || noninteractive || - (timeout && (EMACS_SECS(*timeout)==0) && - (EMACS_USECS(*timeout)==0))) - return select(n, rfds, wfds, efds, timeout); - else + OSErr err; + int i, r; + EMACS_TIME select_timeout; + + if (inhibit_window_system || noninteractive + || rfds == NULL || !FD_ISSET (0, rfds)) + return select (n, rfds, wfds, efds, timeout); + + FD_CLR (0, rfds); + + if (wfds == NULL && efds == NULL) { - EMACS_TIME end_time, now; + int nsocks = 0; + SELECT_TYPE orfds = *rfds; - EMACS_GET_TIME (end_time); - if (timeout) - EMACS_ADD_TIME (end_time, end_time, *timeout); + EventTimeout timeout_sec = + (timeout + ? (EMACS_SECS (*timeout) * kEventDurationSecond + + EMACS_USECS (*timeout) * kEventDurationMicrosecond) + : kEventDurationForever); - do - { - int r; - EMACS_TIME one_second; - SELECT_TYPE orfds; + for (i = 1; i < n; i++) + if (FD_ISSET (i, rfds)) + nsocks++; - FD_ZERO (&orfds); - if (rfds) + if (nsocks == 0) + { + BLOCK_INPUT; + err = ReceiveNextEvent (0, NULL, timeout_sec, + kEventLeaveInQueue, NULL); + UNBLOCK_INPUT; + if (err == noErr) { - orfds = *rfds; + FD_SET (0, rfds); + return 1; } + else + return 0; + } + + /* Avoid initial overhead of RunLoop setup for the case that + some input is already available. */ + EMACS_SET_SECS_USECS (select_timeout, 0, 0); + r = select_and_poll_event (n, rfds, wfds, efds, &select_timeout); + if (r != 0 || timeout_sec == 0.0) + return r; - EMACS_SET_SECS (one_second, 1); - EMACS_SET_USECS (one_second, 0); + *rfds = orfds; + +#ifdef SELECT_USE_CFSOCKET + if (timeout_sec > 0 && timeout_sec <= SELECT_TIMEOUT_THRESHOLD_RUNLOOP) + goto poll_periodically; + + { + CFRunLoopRef runloop = + (CFRunLoopRef) GetCFRunLoopFromEventLoop (GetCurrentEventLoop ()); + EventTypeSpec specs[] = {{EVENT_CLASS_SOCK, 0}}; +#ifdef SELECT_INVALIDATE_CFSOCKET + CFSocketRef *shead, *s; +#else + CFRunLoopSourceRef *shead, *s; +#endif - if (timeout && EMACS_TIME_LT(*timeout, one_second)) - one_second = *timeout; + BLOCK_INPUT; - if ((r = select (n, &orfds, wfds, efds, &one_second)) > 0) +#ifdef SELECT_INVALIDATE_CFSOCKET + shead = xmalloc (sizeof (CFSocketRef) * nsocks); +#else + shead = xmalloc (sizeof (CFRunLoopSourceRef) * nsocks); +#endif + s = shead; + for (i = 1; i < n; i++) + if (FD_ISSET (i, rfds)) { - *rfds = orfds; - return r; + CFSocketRef socket = + CFSocketCreateWithNative (NULL, i, kCFSocketReadCallBack, + socket_callback, NULL); + CFRunLoopSourceRef source = + CFSocketCreateRunLoopSource (NULL, socket, 0); + +#ifdef SELECT_INVALIDATE_CFSOCKET + CFSocketSetSocketFlags (socket, 0); +#endif + CFRunLoopAddSource (runloop, source, kCFRunLoopDefaultMode); +#ifdef SELECT_INVALIDATE_CFSOCKET + CFRelease (source); + *s = socket; +#else + CFRelease (socket); + *s = source; +#endif + s++; } - mac_check_for_quit_char(); + err = ReceiveNextEvent (0, NULL, timeout_sec, kEventLeaveInQueue, NULL); - EMACS_GET_TIME (now); - EMACS_SUB_TIME (now, end_time, now); - } - while (!timeout || !EMACS_TIME_NEG_P (now)); + do + { + --s; +#ifdef SELECT_INVALIDATE_CFSOCKET + CFSocketInvalidate (*s); +#else + CFRunLoopRemoveSource (runloop, *s, kCFRunLoopDefaultMode); +#endif + CFRelease (*s); + } + while (s != shead); - return 0; - } -} + xfree (shead); -#undef read -int sys_read (fds, buf, nbyte) - int fds; - char *buf; - unsigned int nbyte; -{ - SELECT_TYPE rfds; - EMACS_TIME one_second; - int r; + if (err) + { + FD_ZERO (rfds); + r = 0; + } + else + { + FlushEventsMatchingListFromQueue (GetCurrentEventQueue (), + GetEventTypeCount (specs), + specs); + EMACS_SET_SECS_USECS (select_timeout, 0, 0); + r = select_and_poll_event (n, rfds, wfds, efds, &select_timeout); + } - /* Use select to block on IO while still checking for quit_char */ - if (!inhibit_window_system && !noninteractive && - ! (fcntl(fds, F_GETFL, 0) & O_NONBLOCK)) - { - FD_ZERO (&rfds); - FD_SET (fds, &rfds); - if (sys_select (fds+1, &rfds, 0, 0, NULL) < 0) - return -1; + UNBLOCK_INPUT; + + return r; + } +#endif /* SELECT_USE_CFSOCKET */ } - return read (fds, buf, nbyte); -} + poll_periodically: + { + EMACS_TIME end_time, now, remaining_time; + SELECT_TYPE orfds = *rfds, owfds, oefds; + + if (wfds) + owfds = *wfds; + if (efds) + oefds = *efds; + if (timeout) + { + remaining_time = *timeout; + EMACS_GET_TIME (now); + EMACS_ADD_TIME (end_time, now, remaining_time); + } + do + { + EMACS_SET_SECS_USECS (select_timeout, 0, SELECT_POLLING_PERIOD_USEC); + if (timeout && EMACS_TIME_LT (remaining_time, select_timeout)) + select_timeout = remaining_time; + r = select_and_poll_event (n, rfds, wfds, efds, &select_timeout); + if (r != 0) + return r; + + *rfds = orfds; + if (wfds) + *wfds = owfds; + if (efds) + *efds = oefds; + + if (timeout) + { + EMACS_GET_TIME (now); + EMACS_SUB_TIME (remaining_time, end_time, now); + } + } + while (!timeout || EMACS_TIME_LT (now, end_time)); + + FD_ZERO (rfds); + if (wfds) + FD_ZERO (wfds); + if (efds) + FD_ZERO (efds); + return 0; + } +} /* Set up environment variables so that Emacs can correctly find its support files when packaged as an application bundle. Directories @@ -2880,8 +4478,13 @@ init_mac_osx_environment () app_bundle_pathname. */ bundle = CFBundleGetMainBundle (); - if (!bundle) - return; + if (!bundle || CFBundleGetIdentifier (bundle) == NULL) + { + /* We could not find the bundle identifier. For now, prevent + the fatal error by bringing it up in the terminal. */ + inhibit_window_system = 1; + return; + } bundleURL = CFBundleCopyBundleURL (bundle); if (!bundleURL) @@ -2989,19 +4592,78 @@ init_mac_osx_environment () } #endif /* MAC_OSX */ + +static Lisp_Object +mac_get_system_locale () +{ + OSErr err; + LangCode lang; + RegionCode region; + LocaleRef locale; + Str255 str; + + lang = GetScriptVariable (smSystemScript, smScriptLang); + region = GetScriptManagerVariable (smRegionCode); + err = LocaleRefFromLangOrRegionCode (lang, region, &locale); + if (err == noErr) + err = LocaleRefGetPartString (locale, kLocaleAllPartsMask, + sizeof (str), str); + if (err == noErr) + return build_string (str); + else + return Qnil; +} + + void syms_of_mac () { - 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); + + Qmime_charset = intern ("mime-charset"); + staticpro (&Qmime_charset); + + QNFD = intern ("NFD"); staticpro (&QNFD); + QNFKD = intern ("NFKD"); staticpro (&QNFKD); + QNFC = intern ("NFC"); staticpro (&QNFC); + QNFKC = intern ("NFKC"); staticpro (&QNFKC); + QHFS_plus_D = intern ("HFS+D"); staticpro (&QHFS_plus_D); + QHFS_plus_C = intern ("HFS+C"); staticpro (&QHFS_plus_C); +#endif - defsubr (&Smac_paste_function); - defsubr (&Smac_cut_function); - defsubr (&Sx_selection_exists_p); +#if TARGET_API_MAC_CARBON + defsubr (&Smac_get_preference); + defsubr (&Smac_code_convert_string); +#endif + defsubr (&Smac_clear_font_name_table); + defsubr (&Smac_set_file_creator); + defsubr (&Smac_set_file_type); + defsubr (&Smac_get_file_creator); + defsubr (&Smac_get_file_type); defsubr (&Sdo_applescript); defsubr (&Smac_file_name_to_posix); defsubr (&Sposix_file_name_to_mac); + + DEFVAR_INT ("mac-system-script-code", &mac_system_script_code, + doc: /* The system script code. */); + mac_system_script_code = (ScriptCode) GetScriptManagerVariable (smSysScript); + + DEFVAR_LISP ("mac-system-locale", &Vmac_system_locale, + doc: /* The system locale identifier string. +This is not a POSIX locale ID, but an ICU locale ID. So encoding +information is not included. */); + Vmac_system_locale = mac_get_system_locale (); } /* arch-tag: 29d30c1f-0c6b-4f88-8a6d-0558d7f9dbff