source: project/macosx/macosx-env.scm @ 5500

Last change on this file since 5500 was 5500, checked in by Kon Lovett, 13 years ago

Dropped use of CFStringGetCStringPtr.

File size: 8.8 KB
Line 
1;;;; macosx-env.scm
2;;;; Kon Lovett, Sep '06
3
4;; Issues
5;;
6;; - Assumes UTF8 encoding for SCDynamicStoreCopyComputerName
7;;
8;; - No SCDynamicStoreCopyProxies support
9;;
10;; - No CFStringGetCStringPtr use since memory allocation is not performed.
11;; This is sub-par but makes the Scheme invocation more complex.
12
13(declare
14  (no-procedure-checks)
15        (no-bound-checks)
16        (export
17          macosx:session-info
18                macosx:machine-name
19                macosx:short-user-name
20                macosx:long-user-name
21                macosx:machine-location
22                macosx:metric?
23                macosx:computer-name
24                macosx:console-user
25                macosx:local-host-name
26                macosx:location-name
27                macosx:main-bundle-path
28                macosx:tick-count
29                macosx:delay
30                macosx:gestalt
31                ;
32    macosx:get-bundle-path) )
33
34;;;
35
36#>
37#include <math.h>
38#include <unistd.h>
39
40#include <CoreFoundation/CoreFoundation.h>
41#include <CoreServices/CoreServices.h>
42#include <SystemConfiguration/SCDynamicStoreCopySpecific.h>
43#include <ApplicationServices/ApplicationServices.h>
44#include <Security/AuthSession.h>
45
46#ifdef HAVE_STDINT_H
47# include <stdint.h>
48#else
49# include <sys/types.h>
50  typedef u_int8_t  uint8_t;
51  typedef u_int16_t uint16_t;
52  typedef u_int32_t uint32_t;
53  typedef u_int64_t uint64_t;
54#endif
55
56#define VECLEN(v) (sizeof(v)/sizeof((v)[0]))
57
58static void
59cfsr_to_utf8str (CFStringRef cfsr, unsigned char **outstr)
60{
61#       define LONG_CHARS_PER_UTF8 6
62        CFIndex buflen = LONG_CHARS_PER_UTF8 * CFStringGetLength (cfsr) + 1;
63        *outstr = ((unsigned char *) C_malloc (buflen));
64        if (! CFStringGetCString (cfsr, (char *) *outstr, buflen, kCFStringEncodingUTF8)) {
65                C_free (*outstr);
66                *outstr = NULL;
67        }
68#       undef LONG_CHARS_PER_UTF8
69}
70
71static void
72machine_name (unsigned char **outstr)
73{
74        cfsr_to_utf8str (CSCopyMachineName(), outstr);
75}
76
77static void
78short_user_name (unsigned char **outstr)
79{
80        cfsr_to_utf8str (CSCopyUserName (true), outstr);
81}
82
83static void
84long_user_name (unsigned char **outstr)
85{
86        cfsr_to_utf8str (CSCopyUserName (false), outstr);
87}
88
89static void
90machine_location (double *lat, double *lon, int *dls, long *gmt)
91{
92#       define ROUNDN(v,p) (round((v) * ((p) * 10.0)) / ((p) * 10.0))
93        MachineLocation machloc;
94        ReadLocation (&machloc);
95        *lat = ROUNDN (((double) FractToFloat (machloc.latitude)) * 90.0, 4);
96        *lon = ROUNDN (((double) FractToFloat (machloc.longitude)) * 90.0, 4);
97        *dls = 0 < machloc.u.dls.Delta ? 3600 : (0 > machloc.u.dls.Delta ? -3600 : 0);
98        *gmt = ((machloc.u.gmtDelta & 0x00FFFFFF) << 8) >> 8;
99#       undef ROUNDN
100}
101
102static void
103computer_name (unsigned char **outstr, SCDynamicStoreRef store)
104{
105  /* Assumes UTF8 encoding! */
106        CFStringRef cfsr = SCDynamicStoreCopyComputerName (store, NULL);
107        cfsr_to_utf8str (cfsr, outstr);
108        CFRelease (cfsr);
109}
110
111static void
112console_user (unsigned char **outstr, uint32_t *puid, uint32_t *pgid, SCDynamicStoreRef store)
113{
114        uid_t uid;
115        gid_t gid;
116        CFStringRef cfsr = SCDynamicStoreCopyConsoleUser (store, &uid, &gid);
117        cfsr_to_utf8str (cfsr, outstr);
118        CFRelease (cfsr);
119        *puid = uid;
120        *pgid = gid;
121}
122
123static void
124local_host_name (unsigned char **outstr, SCDynamicStoreRef store)
125{
126        CFStringRef cfsr = SCDynamicStoreCopyLocalHostName (store);
127        cfsr_to_utf8str (cfsr, outstr);
128        CFRelease (cfsr);
129}
130
131static void
132location_name (unsigned char **outstr, SCDynamicStoreRef store)
133{
134        CFStringRef cfsr = SCDynamicStoreCopyLocation (store);
135        cfsr_to_utf8str (cfsr, outstr);
136        CFRelease (cfsr);
137}
138
139static void
140main_bundle_path (unsigned char **outstr)
141{
142  CFBundleRef bundle = CFBundleGetMainBundle();
143  *outstr = NULL;
144  if (NULL != bundle) {
145    CFURLRef url = CFBundleCopyExecutableURL (bundle);
146    if (NULL != url) {
147      long buflen = pathconf ("/", _PC_PATH_MAX); /* Any pathname will do */
148      *outstr = ((unsigned char *) C_malloc (buflen));
149      if (NULL != outstr) {
150        if (!CFURLGetFileSystemRepresentation (url, true, *outstr, buflen)) {
151          C_free (outstr);
152          *outstr = NULL;
153        }
154      }
155    }
156  }
157}
158
159static uint32_t
160string_to_OSType (char *str)
161{
162  union {uint32_t v; uint8_t c[4];} ost;
163  int i;
164  for (i = 0; i < VECLEN(ost.c) && *str; ++i, ++str)
165    ost.c[i] = (uint8_t) *str;
166  for (; i < VECLEN(ost.c); ++i)
167    ost.c[i] = (uint8_t) ' ';
168  return ost.v;
169}
170
171static int
172this_session_info_1 (uint32_t *psid, uint32_t *psab)
173{
174  SecuritySessionId mySession;
175  SessionAttributeBits sessionInfo;
176  OSStatus error = SessionGetInfo (callerSecuritySession, &mySession, &sessionInfo);
177  if (errSessionSuccess == error) {
178    *psid = mySession;
179    *psab = sessionInfo;
180    return 0;
181  }
182  return error;
183}
184
185#define session_LoginCompleted  0x0001
186#define session_UserIsActive    0x0010
187
188static void
189this_session_info_2 (unsigned char **outstr, uint32_t *puid, uint32_t *pcon, uint32_t *pbit)
190{
191  CFDictionaryRef sessionInfoDict = CGSessionCopyCurrentDictionary();
192  if (NULL != sessionInfoDict) {
193    CFStringRef shortUserName = CFDictionaryGetValue (sessionInfoDict, kCGSessionUserNameKey);
194    CFNumberRef userUID = CFDictionaryGetValue (sessionInfoDict, kCGSessionUserIDKey);
195    CFNumberRef consoleSet = CFDictionaryGetValue (sessionInfoDict, kCGSessionConsoleSetKey);
196    CFBooleanRef userIsActive = CFDictionaryGetValue (sessionInfoDict, kCGSessionOnConsoleKey);
197    CFBooleanRef loginCompleted = CFDictionaryGetValue (sessionInfoDict, kCGSessionLoginDoneKey);
198    CFNumberGetValue (userUID, kCFNumberSInt32Type, puid);
199    CFNumberGetValue (consoleSet, kCFNumberSInt32Type, pcon);
200    *pbit = (CFBooleanGetValue (loginCompleted) << 1) | CFBooleanGetValue (userIsActive);
201    cfsr_to_utf8str (shortUserName, outstr);
202  } else {
203    *outstr = NULL;
204  }
205}
206<#
207
208;;
209
210(define-macro (call/unsigned-string-result C-NAME . EXTRA)
211        `(let-location ([outstr unsigned-c-string*])
212           ($ void ,C-NAME #$outstr ,@EXTRA)
213                 outstr ) )
214
215(define-macro (foreign-mask-set? ?bits ?c-nam)
216  `(not (zero? (bitwise-and ,?bits (foreign-value ,?c-nam unsigned-integer32)))) )
217
218;;
219
220(define (macosx:session-info)
221  (let-location ([sid unsigned-integer32] [sab unsigned-integer32])
222    (let ([sta ($ int this_session_info_1 #$sid #$sab)])
223      (if (fx= 0 sta)
224        (let ([vec (vector sid
225                           (foreign-mask-set? sab "sessionIsRoot")
226                           (foreign-mask-set? sab "sessionHasGraphicAccess")
227                           (foreign-mask-set? sab "sessionHasTTY")
228                           (foreign-mask-set? sab "sessionIsRemote")
229                           (foreign-mask-set? sab "sessionWasInitialized")
230                           #f #f #f #f #f)])
231          (let-location ([uid unsigned-integer32] [con unsigned-integer32] [bits unsigned-integer32])
232                  (let ([nam (call/unsigned-string-result this_session_info_2 #$uid #$con #$bits)])
233              (when nam
234                (vector-set! vec 6 nam)
235                (vector-set! vec 7 uid)
236                (vector-set! vec 8 con)
237                (vector-set! vec 9 (foreign-mask-set? bits "session_LoginCompleted"))
238                (vector-set! vec 10 (foreign-mask-set? bits "session_UserIsActive")) )
239              vec ) ) )
240        (error 'macosx:session-info "OSStatus" sta) ) ) ) )
241
242;;
243
244(define (macosx:machine-name)
245        (call/unsigned-string-result machine_name) )
246
247(define (macosx:short-user-name)
248        (call/unsigned-string-result short_user_name) )
249
250(define (macosx:long-user-name)
251        (call/unsigned-string-result long_user_name) )
252
253(define (macosx:machine-location)
254        (let-location ([lat double] [lon double] [dls int] [gmt long])
255                ($ void machine_location #$lat #$lon #$dls #$gmt)
256                (vector lat lon dls gmt) ) )
257
258(define (macosx:metric?)
259        ($ bool IsMetric) )
260
261;;
262
263(define (macosx:computer-name #!optional (store #f))
264        (call/unsigned-string-result computer_name (c-pointer store)) )
265
266(define (macosx:console-user #!optional (store #f))
267        (let-location ([uid unsigned-integer32] [gid unsigned-integer32])
268          (let ([nam (call/unsigned-string-result console_user #$uid #$gid (c-pointer store))])
269            (and nam
270                      (vector nam uid gid) ) ) ) )
271
272(define (macosx:local-host-name #!optional (store #f))
273        (call/unsigned-string-result local_host_name (c-pointer store)) )
274
275(define (macosx:location-name #!optional (store #f))
276        (call/unsigned-string-result location_name (c-pointer store)) )
277
278;;
279
280(define (macosx:main-bundle-path)
281  (call/unsigned-string-result main_bundle_path) )
282(define macosx:get-bundle-path macosx:main-bundle-path)
283
284;;
285
286(define (macosx:tick-count)
287  ($ unsigned-integer32 TickCount) )
288
289(define (macosx:delay ticks)
290        (let-location ([fticks unsigned-long])
291    ($ void Delay (unsigned-long ticks) #$fticks)
292    fticks ) )
293
294;;
295
296(define (macosx:gestalt sel)
297  ; Symbolic selector -> numeric
298  (when (symbol? sel)
299    (set! sel (symbol->string sel)))
300  (when (string? sel)
301    (set! sel ($ unsigned-integer32 string_to_OSType (c-string sel))))
302  ; Must be numeric
303  (unless (and (integer? sel) (positive? sel))
304    (error 'macosx:gestalt "invalid selector" sel))
305  ;
306        (let-location ([resp long])
307    (let ([err ($ short Gestalt (unsigned-integer32 sel) #$resp)])
308      (if (fx= 0 err)
309        resp
310        (error 'macosx:gestalt "OSErr" err) ) ) ) )
Note: See TracBrowser for help on using the repository browser.