Changeset 13588 in project


Ignore:
Timestamp:
03/08/09 07:39:40 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/macosx/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/macosx/trunk/macosx-env.scm

    r13584 r13588  
    2121  (no-procedure-checks)
    2222  (bound-to-procedure
    23     ##sys#check-number ) )
     23    ##sys#check-number))
    2424
    2525;;;
     
    3535#include <Security/AuthSession.h>
    3636
    37 #define VECLEN( v ) (sizeof( v ) / sizeof( (v)[0] ))
     37#define VECLEN( v) (sizeof( v) / sizeof( (v)(0)))
    3838
    3939static void
     
    4242#       define LONG_CHARS_PER_UTF8 6 /* worst case assumption */
    4343
    44         CFIndex buflen = LONG_CHARS_PER_UTF8 * CFStringGetLength( cfsr) + 1;
     44        CFIndex buflen = LONG_CHARS_PER_UTF8 * CFStringGetLength( cfsr ) + 1;
    4545
    4646        *outstr = (unsigned char *) C_malloc( buflen );
     
    6363short_user_name( unsigned char **outstr )
    6464{
    65         cfsr_to_utf8str( CSCopyUserName( true), outstr );
     65        cfsr_to_utf8str( CSCopyUserName( true ), outstr );
    6666}
    6767
     
    7575machine_location( double *lat, double *lon, int *dls, long *gmt )
    7676{
    77 #       define ROUNDN( v, p ) (round( (v) * ((p) * 10.0) ) / ((p) * 10.0))
     77#       define ROUNDN( v, p ) (round( (v ) * ((p) * 10.0)) / ((p) * 10.0))
    7878
    7979        MachineLocation machloc;
     
    8181        ReadLocation( &machloc );
    8282
    83         *lat = ROUNDN( ((double) FractToFloat( machloc.latitude)) * 90.0, 4 );
    84         *lon = ROUNDN( ((double) FractToFloat( machloc.longitude)) * 90.0, 4 );
    85         *dls = 0 < machloc.u.dls.Delta ? 3600 : (0 > machloc.u.dls.Delta ? -3600 : 0 );
     83        *lat = ROUNDN( ((double) FractToFloat( machloc.latitude )) * 90.0, 4);
     84        *lon = ROUNDN( ((double) FractToFloat( machloc.longitude )) * 90.0, 4);
     85        *dls = 0 < machloc.u.dls.Delta ? 3600 : (0 > machloc.u.dls.Delta ? -3600 : 0);
    8686        *gmt = ((machloc.u.gmtDelta & 0x00FFFFFF) << 8) >> 8;
    8787
     
    149149
    150150static uint32_t
    151 string_to_OSType( char *str )
    152 {
    153   union {uint32_t v; uint8_t c[4];} ost;
     151stringToOSType( char *str )
     152{
     153  union {uint32_t v; uint8_t c(4);} ost;
    154154
    155155  int i;
     
    157157  /* Copy existing */
    158158  for (i = 0; i < VECLEN( ost.c ) && *str; ++i, ++str)
    159     ost.c[i] = (uint8_t) *str;
     159    ost.c(i) = (uint8_t) *str;
    160160
    161161  /* Pad remaining */
    162162  for (; i < VECLEN( ost.c ); ++i)
    163     ost.c[i] = (uint8_t) ' ';
     163    ost.c(i) = (uint8_t) ' ';
    164164
    165165  return ost.v;
     
    167167
    168168static int
    169 this_session_info_1( uint32_t *psid, uint32_t *psab )
     169sessionInfo( uint32_t *psid, uint32_t *psab )
    170170{
    171171  SecuritySessionId mySession;
     
    184184
    185185static void
    186 this_session_info_2( unsigned char **outstr, uint32_t *puid, uint32_t *pcon, uint32_t *pbit )
     186sessionInfoProperties( unsigned char **outstr, uint32_t *puid, uint32_t *pcon, uint32_t *pbit )
    187187{
    188188  CFDictionaryRef sessionInfoDict = CGSessionCopyCurrentDictionary();
     
    193193    CFBooleanRef userIsActive = CFDictionaryGetValue( sessionInfoDict, kCGSessionOnConsoleKey );
    194194    CFBooleanRef loginCompleted = CFDictionaryGetValue( sessionInfoDict, kCGSessionLoginDoneKey );
     195
    195196    CFNumberGetValue( userUID, kCFNumberSInt32Type, puid );
    196197    CFNumberGetValue( consoleSet, kCFNumberSInt32Type, pcon );
     
    205206
    206207;;;
     208
     209(require-library dollar)
    207210
    208211(module macosx-env (;export
     
    224227
    225228(import scheme chicken foreign)
     229(import dollar)
    226230
    227231;;
    228232
    229233(define (make-exn-condition loc msg . args)
    230   (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
     234  (make-property-condition 'exn 'location loc 'message msg 'arguments args))
    231235
    232236(define (make-osstatus-condition code)
    233   (make-property-condition 'osstatus 'code code) )
     237  (make-property-condition 'osstatus 'code code))
    234238
    235239(define (make-exn-osstatus-condition loc msg code . args)
    236240  (make-composite-condition
    237241   (apply make-exn-condition loc msg args)
    238    (make-osstatus-condition code)) )
     242   (make-osstatus-condition code)))
    239243
    240244(define (make-oserr-condition code)
    241   (make-property-condition 'oserr 'code code) )
     245  (make-property-condition 'oserr 'code code))
    242246
    243247(define (make-exn-oserr-condition loc msg code . args)
    244248  (make-composite-condition
    245249   (apply make-exn-condition loc msg args)
    246    (make-oserr-condition code)) )
     250   (make-oserr-condition code)))
    247251
    248252;;
    249253
    250254(define (osstatus-error loc msg code args)
    251   (abort (make-exn-osstatus-condition loc msg code args)) )
     255  (abort (make-exn-osstatus-condition loc msg code args)))
    252256
    253257(define (oserr-error loc msg code args)
    254   (abort (make-exn-oserr-condition loc msg code args)) )
    255 
    256 ;;
    257 
    258 (define-syntax call/unsigned-string-result
     258  (abort (make-exn-oserr-condition loc msg code args)))
     259
     260;;
     261
     262(define-syntax $/string:out#1
     263  (lambda (form r c)
     264    (##sys#check-syntax '$/string:out#1 form '(_ symbol . #(_ 0)))
     265    (let (($$ (r '$))
     266          ($void (r 'void))
     267          ($unsigned-c-string* (r 'unsigned-c-string*))
     268          ($location (r 'location))
     269          ($let-location (r 'let-location)))
     270      (let ((c-nam (cadr form))
     271            (args (cddr form))
     272            (stroutvar (gensym)))
     273        `(,$let-location ((,stroutvar ,$unsigned-c-string*))
     274           (,$$ ,$void ,c-nam (,$location ,stroutvar) ,@args)
     275           ,stroutvar)))))
     276         
     277(define-syntax bitwise-test?/foreign-mask
    259278  (syntax-rules ()
    260     [(_ (?c-nam ?typ0 ...) ?arg0 ...)
    261            (let-location ([outstr unsigned-c-string*])
    262              ((foreign-lambda void ?c-nam
    263                                    unsigned-c-string* ?typ0 ...)
    264               (location outstr) ?arg0 ...)
    265                    outstr ) ] ) )
    266 
    267 (define-syntax foreign-mask-set?
    268   (syntax-rules ()
    269     [(_ ?bits ?c-nam)
    270      (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))) ] ) )
     279    ((_ ?bits ?c-nam)
     280     (not (zero? (bitwise-and ?bits (foreign-value ?c-nam unsigned-integer32)))))))
    271281
    272282;;
    273283
    274284(define (session-info)
    275   (let-location ([sid unsigned-integer32] [sab unsigned-integer32])
    276     (let ([sta ((foreign-lambda int "this_session_info_1"
    277                                     unsigned-integer32 unsigned-integer32)
    278                 (location sid) (location sab))])
     285  (let-location ((sid unsigned-integer32)
     286                 (sab unsigned-integer32))
     287    (let ((sta ($ int sessionInfo #$sid #$sab)))
    279288      (if (not (fx= 0 sta)) (osstatus-error 'session-info "SessionGetInfo failed" sta)
    280           (let ([vec (vector
    281                       sid
    282                       (foreign-mask-set? sab "sessionIsRoot")
    283                       (foreign-mask-set? sab "sessionHasGraphicAccess")
    284                       (foreign-mask-set? sab "sessionHasTTY")
    285                       (foreign-mask-set? sab "sessionIsRemote")
    286                       (foreign-mask-set? sab "sessionWasInitialized")
    287                       #f #f #f #f #f)])
    288             (let-location ([uid unsigned-integer32]
    289                            [con unsigned-integer32]
    290                            [bits unsigned-integer32])
    291               (let ([nam (call/unsigned-string-result
    292                           ("this_session_info_2"
    293                            unsigned-integer32 unsigned-integer32 unsigned-integer32)
    294                           (location uid) (location con) (location bits))])
    295                 (if (not nam) (osstatus-error 'session-info "CGSessionCopyCurrentDictionary failed" 'unknown)
    296                   (vector-set! vec 6 nam)
    297                   (vector-set! vec 7 uid)
    298                   (vector-set! vec 8 con)
    299                   (vector-set! vec 9 (foreign-mask-set? bits "session_LoginCompleted"))
    300                   (vector-set! vec 10 (foreign-mask-set? bits "session_UserIsActive")) )
    301                 vec ) ) ) ) ) ) )
     289          (let-location ((uid unsigned-integer32)
     290                         (con unsigned-integer32)
     291                         (bits unsigned-integer32))
     292            (let ((nam ($/string:out#1 sessionInfoProperties #$uid #$con #$bits)))
     293              (if (not nam) (osstatus-error 'session-info "CGSessionCopyCurrentDictionary failed" 0)
     294                  (vector sid
     295                          (bitwise-test?/foreign-mask sab sessionIsRoot)
     296                          (bitwise-test?/foreign-mask sab sessionHasGraphicAccess)
     297                          (bitwise-test?/foreign-mask sab sessionHasTTY)
     298                          (bitwise-test?/foreign-mask sab sessionIsRemote)
     299                          (bitwise-test?/foreign-mask sab sessionWasInitialized)
     300                          nam
     301                          uid
     302                          con
     303                          (bitwise-test?/foreign-mask bits session_LoginCompleted)
     304                          (bitwise-test?/foreign-mask bits session_UserIsActive)))))))))
    302305
    303306;;
    304307
    305308(define (machine-name)
    306         (call/unsigned-string-result ("machine_name")) )
     309        ($/string:out#1 machine_name))
    307310
    308311(define (short-user-name)
    309         (call/unsigned-string-result ("short_user_name")) )
     312        ($/string:out#1 short_user_name))
    310313
    311314(define (long-user-name)
    312         (call/unsigned-string-result ("long_user_name")) )
     315        ($/string:out#1 long_user_name))
    313316
    314317(define (machine-location)
    315         (let-location ([lat double] [lon double] [dls int] [gmt long])
    316                 ((foreign-lambda void "machine_location"
    317                                       (c-pointer double) (c-pointer double)
    318                                       (c-pointer int) (c-pointer long))
    319                  (location lat) (location lon)
    320                  (location dls) (location gmt))
    321                 (vector lat lon dls gmt) ) )
     318        (let-location ((lat double) (lon double) (dls int) (gmt long))
     319                ($ void machine_location #$lat #$lon #$dls #$gmt)
     320                (vector lat lon dls gmt)))
    322321
    323322(define (metric?)
    324         ((foreign-lambda bool "IsMetric")) )
     323        ((foreign-lambda bool "IsMetric")))
    325324
    326325;;
    327326
    328327(define (computer-name #!optional (store #f))
    329         (call/unsigned-string-result ("computer_name" c-pointer) store) )
     328        ($/string:out#1 computer_name (c-pointer store)))
    330329
    331330(define (console-user #!optional (store #f))
    332         (let-location ([uid unsigned-integer32] [gid unsigned-integer32])
    333           (let ([nam (call/unsigned-string-result
    334                       ("console_user" unsigned-integer32 unsigned-integer32 c-pointer)
    335                       (location uid) (location gid) store)])
     331        (let-location ((uid unsigned-integer32) (gid unsigned-integer32))
     332          (let ((nam ($/string:out#1 console_user #$uid #$gid (c-pointer store))))
    336333            (and nam
    337                       (vector nam uid gid) ) ) ) )
     334                      (vector nam uid gid)))))
    338335
    339336(define (local-host-name #!optional (store #f))
    340         (call/unsigned-string-result ("local_host_name" c-pointer) store) )
     337        ($/string:out#1 local_host_name (c-pointer store)))
    341338
    342339(define (location-name #!optional (store #f))
    343         (call/unsigned-string-result ("location_name" c-pointer) store) )
     340        ($/string:out#1 location_name (c-pointer store)))
    344341
    345342;;
    346343
    347344(define (main-bundle-path)
    348   (call/unsigned-string-result ("main_bundle_path")) )
     345  ($/string:out#1 main_bundle_path))
    349346
    350347;;
    351348
    352349(define (tick-count)
    353   ((foreign-lambda unsigned-integer32 "TickCount")) )
     350  ($ unsigned-integer32 TickCount))
    354351
    355352(define (delay ticks)
    356         (let-location ([fticks unsigned-long])
    357     ((foreign-lambda void "Delay" unsigned-long (c-pointer unsigned-long)) (location fticks))
    358     fticks ) )
     353        (let-location ((fticks unsigned-long))
     354    ($ void Delay (unsigned-long ticks) #$fticks)
     355    fticks))
    359356
    360357;;
    361358
    362359(define (gestalt sel)
    363   ; Symbolic selector -> numeric
    364   (when (symbol? sel)
    365     (set! sel (symbol->string sel)) )
    366   (when (string? sel)
    367     (set! sel ((foreign-lambda unsigned-integer32 "string_to_OSType" c-string) sel)) )
    368   ; Must be numeric
     360  (when (symbol? sel) (set! sel (symbol->string sel)))
     361  (when (string? sel) (set! sel ((foreign-lambda unsigned-integer32 "stringToOSType" c-string) sel)))
    369362  (##sys#check-number sel 'gestalt)
    370   ;
    371         (let-location ([resp long])
    372     (let ([err ((foreign-lambda short "Gestalt"
    373                                       unsigned-integer32 (c-pointer long))
    374                 sel (location resp))])
     363        (let-location ((resp long))
     364    (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
    375365      (if (fx= 0 err) resp
    376           (oserr-error 'gestalt "Gestalt failed" err) ) ) ) )
     366          (oserr-error 'gestalt "Gestalt failed" err)))))
    377367
    378368) ;module macosx-env
  • release/4/macosx/trunk/macosx-url.scm

    r13584 r13588  
    1313  (bound-to-procedure
    1414    ##sys#check-string ) )
     15
     16
     17;;;
    1518
    1619#>
     
    3437;;;
    3538
     39(require-library dollar)
     40
    3641(module macosx-url (;export
    3742  open-url)
    3843
    3944(import scheme chicken foreign)
     45(import dollar)
    4046
    4147;;
     
    6167(define (open-url url)
    6268  (##sys#check-string url 'open-url)
    63         (let ([sta ((foreign-lambda int "open_url" c-string int) url (string-length url))])
    64           (unless (zero? sta) (osstatus-error 'open-url "open url failed" sta url) ) ) )
     69        (let ((sta ($ int open_url (c-string url) (int (string-length url)))))
     70          (unless (zero? sta) (osstatus-error 'open-url "open url failed" sta url))))
    6571
    6672) ;module macosx-url
  • release/4/macosx/trunk/macosx.setup

    r13584 r13588  
    55(verify-extension-name "macosx")
    66
     7(setup-shared-extension-module 'macosx-url (extension-version "2.0.0")
     8  compile-options: '(
     9    -extend dollar
     10    -framework CoreFoundation -framework ApplicationServices))
     11
    712(setup-shared-extension-module 'macosx-env (extension-version "2.0.0")
    813  compile-options: '(
     14    -extend dollar
    915    -framework CoreFoundation -framework CoreServices
    1016    -framework SystemConfiguration
    1117    -framework Security
    1218    -framework ApplicationServices))
    13 
    14 (setup-shared-extension-module 'macosx-url (extension-version "2.0.0")
    15   compile-options: '(-framework CoreFoundation -framework ApplicationServices))
Note: See TracChangeset for help on using the changeset viewer.