diff --git a/pkgs/racket-doc/file/scribblings/resource.scrbl b/pkgs/racket-doc/file/scribblings/resource.scrbl index 37a8e51499..263468dd28 100644 --- a/pkgs/racket-doc/file/scribblings/resource.scrbl +++ b/pkgs/racket-doc/file/scribblings/resource.scrbl @@ -23,7 +23,8 @@ [entry string?] [value-box (or/c #f (box/c (or/c string? bytes? exact-integer?))) #f] [file (or/c #f path-string?) #f] - [#:type type (or/c 'string 'bytes 'integer) _derived-from-value-box]) + [#:type type (or/c 'string 'string/utf-16 'bytes 'bytes* 'integer) + _derived-from-value-box]) (or/c #f string? bytes? exact-integer? #t)]{ Gets a value from the Windows registry or an @filepath{.ini} @@ -36,35 +37,66 @@ The resource value is keyed on the combination of @racket[section] and box is filled with the value; when @racket[value-box] is @racket[#f], the result is the found value. -The @racket[type] argument determines how a value in the resource is - converted to a Racket value. If @racket[value-box] is a box, then the - default @racket[type] is derived from the initial box content, - otherwise the default @racket[type] is @racket['string]. -Registry values of any format can be extracted. Values using the - registry format @tt{REG_SZ} are treated as strings, and values with - the format @tt{REG_DWORD} are treated as 32-bit signed integers. All - other formats are treated as raw bytes. Data from the registry is - converted to the requested @racket[type] as follows: +Registry values of any format can be extracted. A combination of the + @racket[type] argument and the type of the resource determines how + the resource is initially converted to a Racket value: @itemlist[ - @item{A @tt{REG_SZ} registry value - is converted to an integer using - @racket[string->number] (using @racket[0] if the result is not - an exact integer), and it is converted to bytes using - @racket[string->bytes/utf-8].} + @item{A @tt{REG_SZ} registry value's bytes are first converted to a + string by a nul-terminated UTF-16 interpretation (not including + the terminator in the string)---unless @racket[type] is + @racket['bytes*], in which case the bytes are kept as-is in a + byte string.} - @item{A @tt{REG_DWORD} registry value is converted to a string or - byte string via @racket[number->string] and (for byte strings) - @racket[string->bytes/utf-8].} + @item{A @tt{REG_DWORD} registry value's bytes are first interpreted + as a 32-bit signed integer, and then the integer is converted + to a string with @racket[number->string].} - @item{Any other kind of registry value is converted to a string or - integer using @racket[bytes->string/utf-8] and (for integers) + @item{Any other kind of register value's bytes are kept as a byte + string.} + +] + +That initial conversion produces either a string or a byte string. The +requested @racket[type] might then trigger an additional +transformation: + +@itemlist[ + + @item{@racket['string]: a string is kept as-is, but a byte string are + converted to a string using @racket[bytes->string/utf-8]. Note + that a UTF-8 conversion is @emph{not} appropriate for some + resource types, such as @tt{REG_EXPAND_SZ}; use + @racket['string/utf-16], instead.} + + @item{@racket['string/utf-16]: a string is kept as-is, but a byte + string is converted to a string by a nul-terminated UTF-16 + interpretation (omitting the nul terminator from the string).} + + @item{@racket['bytes]: a byte string is kept as-is, but a string is + converted using @racket[string->bytes/utf-8]. Note that this + conversion does not produce the original bytes for a + @tt{REG_SZ} resource; use @racket['bytes*], instead, since that + avoids the initial conversion to a string.} + + @item{@racket['bytes*]: the same as @racket['bytes], but + @racket['bytes*] affects the initial conversion for a + @tt{REG_SZ} resource.} + + @item{@racket['integer]: a string is converted to a number using + @racket[string->number], and a byte string is converted by + composing @racket[bytes->string/utf-8] with @racket[string->number].} ] +If @racket[value-box] is a box, then the default @racket[type] is + derived from the initial box content: @racket['string], + @racket['bytes], or @racket['integer]. Otherwise, the default + @racket[type] is @racket['string]. + Resources from @filepath{.ini} files are always strings, and are converted like @tt{REG_SZ} registry values. @@ -75,13 +107,18 @@ for starting a browser: @racketblock[ (get-resource "HKEY_CLASSES_ROOT" "htmlfile\\shell\\open\\command\\") -]} +] + +@history[#:changed "8.0.0.10" @elem{Added @racket['sting/utf-16] + and @racket['bytes*] options for @racket[type].}]} @defproc[(write-resource [section string?] [entry string?] [value (or/c string? bytes? exact-integer?)] [file (or/c path-string? #f) #f] - [#:type type (or/c 'string 'bytes 'integer) 'string] + [#:type type (or/c 'string 'expand-string 'bytes 'integer + 'bytes/string 'bytes/expand-string) + 'string] [#:create-key? create-key? any/c #f]) boolean?]{ @@ -94,13 +131,57 @@ The resource value is keyed on the combination of @racket[section] and fails. The result is @racket[#f] if the write fails or @racket[#t] if it succeeds. -The @racket[type] argument determines the format of the value written to the - registry: @racket['string] writes using the @tt{REG_SZ} format, - @racket['bytes] writes using the @tt{REG_BINARY} format, and - @racket['dword] writes using the @tt{REG_DWORD} format. Any kind of - @racket[value] can be converted for any kind of @racket[type] using - the inverse of the conversions for @racket[get-resource]. +The @racket[type] argument determines both the format of the value + written to the registry and its conversion of the to bytes: + +@itemlist[ + + @item{@racket['string]: writes as @tt{REG_SZ}, where a string + @racket[value] is converted to UTF-16 bytes adding a nul + terminator. A byte string @racket[value] is converted first + with @racket[bytes->string/utf-8], and an integer + @racket[value] is first converted with @racket[number->string], + and then the result in each case is treated like a string. Note + that @racket['string] is unlikely to be a useful conversion for + a byte string @racket[value]; use @racket['bytes/string], + instead.} + + @item{@racket['expand-string]: like @racket['string], but written as + @tt{REG_EXPAND_SZ}. Note that @racket['expand-string] is + unlikely to be a useful conversion for a byte string + @racket[value]; use @racket['bytes/expand-string], instead.} + + @item{@racket['bytes]: @tt{REG_BINARY}, where a byte string + @racket[value] is written as-is, a string @racket[value] is + converted to bytes by @racket[string->bytes/utf-8], and an + integer @racket[value] is converted to bytes by composing + @racket[number->string] with @racket[string->bytes/utf-8].} + + @item{@racket['bytes/string]: writes as @tt{REG_SZ}, where a byte + string @racket[value] is written as-is (unlike + @racket['string], so the byte string must be a UTF-16 encoding + with a nul terminator), a string @racket[value] + is converted to UTF-16 bytes adding a nul terminator, and an + integer @racket[value] is converted to a string with + @racket[number->string] and then to UTF-16 bytes adding a nul + terminator.} + + @item{@racket['bytes/expand-string]: like @racket['bytes/string], but + writes as @tt{REG_EXPAND_SZ}.} + + @item{@racket['dword]: writes as @tt{REG_DWORD}, where an integer + @racket[value] is converted to 32-bit signed integer bytes, a + string @racket[value] is converted with @racket[string->number] + and then the same as an integer, and a byte string + @racket[value] is converted by composing + @racket[bytes->string/utf-8] with @racket[string->number] and + then the same as an integer.} + +] When writing to an @filepath{.ini} file, the format is always a - string, independent of @racket[type].} + string, independent of @racket[type]. +@history[#:changed "8.0.0.10" @elem{Added @racket['expand-string], + @racket['bytes/string], and @racket['bytes/expand-string] + options for @racket[type].}]} diff --git a/pkgs/racket-test-core/tests/racket/resource.rktl b/pkgs/racket-test-core/tests/racket/resource.rktl index f5f35c712f..22634fbf76 100644 --- a/pkgs/racket-test-core/tests/racket/resource.rktl +++ b/pkgs/racket-test-core/tests/racket/resource.rktl @@ -1,85 +1,105 @@ - -;; This test modifies registry entries under Windows -;; within HKEY_CURRENT_USER\Software\PLT - -(load-relative "loadtest.rktl") - -(Section 'resource) - -(require file/resource - racket/file) - -(let () - (define key "HKEY_CURRENT_USER") - (define (entry s) (string-append "SOFTWARE\\PLT\\" s)) - (define (rtest* kws kvs r . l) - (if (eq? 'windows (system-type)) - (keyword-apply test kws kvs r l) - (keyword-apply test kws kvs #f l))) - (define rtest (make-keyword-procedure rtest*)) - (define (xtest r alt-r . l) - (if (eq? 'windows (system-type)) - (apply test r l) - (apply test alt-r l))) - - (rtest #t 'init (write-resource key (entry "Stuff") "Hello" #:create-key? #t)) - - ;; A string-valued resource: - (rtest #t write-resource key (entry "Stuff") "Hola") - (rtest "Hola" get-resource key (entry "Stuff")) - (rtest #"Hola" get-resource key (entry "Stuff") #:type 'bytes) - (rtest 0 get-resource key (entry "Stuff") #:type 'integer) - (let ([b (box "")]) - (rtest #t get-resource key (entry "Stuff") b) - (xtest "Hola" "" unbox b)) - (let ([b (box #"")]) - (rtest #t get-resource key (entry "Stuff") b) - (xtest #"Hola" #"" unbox b)) - (let ([b (box 10)]) - (rtest #t get-resource key (entry "Stuff") b) - (xtest 0 10 unbox b)) - (rtest #t write-resource key (entry "Stuff") 88) - (rtest "88" get-resource key (entry "Stuff")) - (rtest #t write-resource key (entry "Stuff") #"!") - (rtest "!" get-resource key (entry "Stuff")) - - ;; An integer-valued resource - (rtest #t write-resource key (entry "Count") 17 #:type 'dword) - (rtest "17" get-resource key (entry "Count")) - (rtest #t write-resource key (entry "Count") "17" #:type 'dword) - (rtest "17" get-resource key (entry "Count")) - (rtest #t write-resource key (entry "Count") #"17" #:type 'dword) - (rtest "17" get-resource key (entry "Count")) - (rtest #"17" get-resource key (entry "Count") #:type 'bytes) - (rtest 17 get-resource key (entry "Count") #:type 'integer) - (rtest #t write-resource key (entry "Count") -17 #:type 'dword) - (rtest -17 get-resource key (entry "Count") #:type 'integer) - - ;; A bytes-valued resource: - (rtest #t write-resource key (entry "Data") #"i\377mage" #:type 'bytes) - (rtest "i?mage" get-resource key (entry "Data")) - (rtest #"i\377mage" get-resource key (entry "Data") #:type 'bytes) - (rtest 0 get-resource key (entry "Data") #:type 'integer) - (rtest #t write-resource key (entry "Data") 17 #:type 'bytes) - (rtest "17" get-resource key (entry "Data")) - (rtest #t write-resource key (entry "Data") "17" #:type 'bytes) - (rtest "17" get-resource key (entry "Data")) - - ;; .ini file: - (let ([tmp-ini (make-temporary-file "temp~a.ini")]) - (rtest #f get-resource "Temporary" "Stuff" #f tmp-ini) - (rtest #t write-resource "Temporary" "Stuff" "howdy" tmp-ini) - (rtest "howdy" get-resource "Temporary" "Stuff" #f tmp-ini) - (let ([b (box "")]) - (rtest #t get-resource "Temporary" "Stuff" b tmp-ini) - (xtest "howdy" "" unbox b)) - (rtest #f get-resource "Temporary" "more" #f tmp-ini) - (rtest #t write-resource "Temporary" "more" 10 tmp-ini) - (rtest 10 get-resource "Temporary" "more" #f tmp-ini #:type 'integer) - (when (eq? 'windows (system-type)) - (rtest "[Temporary]\r\nStuff=howdy\r\nmore=10\r\n" file->string tmp-ini)) - (delete-file tmp-ini)) - - (void)) - -(report-errs) + +;; This test modifies registry entries under Windows +;; within HKEY_CURRENT_USER\Software\PLT + +(load-relative "loadtest.rktl") + +(Section 'resource) + +(require file/resource + racket/file) + +(let () + (define key "HKEY_CURRENT_USER") + (define (entry s) (string-append "SOFTWARE\\PLT\\" s)) + (define (rtest* kws kvs r . l) + (if (eq? 'windows (system-type)) + (keyword-apply test kws kvs r l) + (keyword-apply test kws kvs #f l))) + (define rtest (make-keyword-procedure rtest*)) + (define (xtest r alt-r . l) + (if (eq? 'windows (system-type)) + (apply test r l) + (apply test alt-r l))) + + (rtest #t 'init (write-resource key (entry "Stuff") "Hello" #:create-key? #t)) + + ;; A string-valued resource: + (rtest #t write-resource key (entry "Stuff") "Hola") + (rtest "Hola" get-resource key (entry "Stuff")) + (rtest "Hola" get-resource key (entry "Stuff") #:type 'string) + (rtest "Hola" get-resource key (entry "Stuff") #:type 'string/utf-16) + (rtest #"Hola" get-resource key (entry "Stuff") #:type 'bytes) + (rtest #"H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff") #:type 'bytes*) + (rtest 0 get-resource key (entry "Stuff") #:type 'integer) + (let ([b (box "")]) + (rtest #t get-resource key (entry "Stuff") b) + (xtest "Hola" "" unbox b)) + (let ([b (box #"")]) + (rtest #t get-resource key (entry "Stuff") b) + (xtest #"Hola" #"" unbox b)) + (let ([b (box 10)]) + (rtest #t get-resource key (entry "Stuff") b) + (xtest 0 10 unbox b)) + (rtest #t write-resource key (entry "Stuff") 88) + (rtest "88" get-resource key (entry "Stuff")) + (rtest #t write-resource key (entry "Stuff") #"!") + (rtest "!" get-resource key (entry "Stuff")) + + ;; A string-valued resource written as bytes: + (rtest #t write-resource key (entry "Stuff") #"H\0o\0l\0a\0\0\0" #:type 'bytes/string) + (rtest "Hola" get-resource key (entry "Stuff")) + + ;; An expand-string-valued resource: + (rtest #t write-resource key (entry "Stuff") "Hola" #:type 'expand-string) + (rtest "H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff")) ; as specified, though undesireable + (rtest "H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff") #:type 'string) + (rtest "Hola" get-resource key (entry "Stuff") #:type 'string/utf-16) + (rtest #"H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff") #:type 'bytes) + (rtest #"H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff") #:type 'bytes*) + + ;; An expand-string-valued resource written as bytes: + (rtest #t write-resource key (entry "Stuff") #"H\0o\0l\0a\0\0\0" #:type 'bytes/expand-string) + (rtest "H\0o\0l\0a\0\0\0" get-resource key (entry "Stuff")) + (rtest "Hola" get-resource key (entry "Stuff") #:type 'string/utf-16) + + ;; An integer-valued resource + (rtest #t write-resource key (entry "Count") 17 #:type 'dword) + (rtest "17" get-resource key (entry "Count")) + (rtest #t write-resource key (entry "Count") "17" #:type 'dword) + (rtest "17" get-resource key (entry "Count")) + (rtest #t write-resource key (entry "Count") #"17" #:type 'dword) + (rtest "17" get-resource key (entry "Count")) + (rtest #"17" get-resource key (entry "Count") #:type 'bytes) + (rtest 17 get-resource key (entry "Count") #:type 'integer) + (rtest #t write-resource key (entry "Count") -17 #:type 'dword) + (rtest -17 get-resource key (entry "Count") #:type 'integer) + + ;; A bytes-valued resource: + (rtest #t write-resource key (entry "Data") #"i\377mage" #:type 'bytes) + (rtest "i?mage" get-resource key (entry "Data")) + (rtest #"i\377mage" get-resource key (entry "Data") #:type 'bytes) + (rtest 0 get-resource key (entry "Data") #:type 'integer) + (rtest #t write-resource key (entry "Data") 17 #:type 'bytes) + (rtest "17" get-resource key (entry "Data")) + (rtest #t write-resource key (entry "Data") "17" #:type 'bytes) + (rtest "17" get-resource key (entry "Data")) + + ;; .ini file: + (let ([tmp-ini (make-temporary-file "temp~a.ini")]) + (rtest #f get-resource "Temporary" "Stuff" #f tmp-ini) + (rtest #t write-resource "Temporary" "Stuff" "howdy" tmp-ini) + (rtest "howdy" get-resource "Temporary" "Stuff" #f tmp-ini) + (let ([b (box "")]) + (rtest #t get-resource "Temporary" "Stuff" b tmp-ini) + (xtest "howdy" "" unbox b)) + (rtest #f get-resource "Temporary" "more" #f tmp-ini) + (rtest #t write-resource "Temporary" "more" 10 tmp-ini) + (rtest 10 get-resource "Temporary" "more" #f tmp-ini #:type 'integer) + (when (eq? 'windows (system-type)) + (rtest "[Temporary]\r\nStuff=howdy\r\nmore=10\r\n" file->string tmp-ini)) + (delete-file tmp-ini)) + + (void)) + +(report-errs) diff --git a/racket/collects/file/resource.rkt b/racket/collects/file/resource.rkt index 03b89a52e4..643d6bd7d4 100644 --- a/racket/collects/file/resource.rkt +++ b/racket/collects/file/resource.rkt @@ -1,290 +1,305 @@ -#lang racket/base -(require ffi/unsafe - ffi/unsafe/define - ffi/winapi) - -(provide get-resource - write-resource) - -(define _HKEY (_cpointer/null 'HKEY)) - -(define (const-hkey v) - (cast (bitwise-ior v (arithmetic-shift -1 32)) _intptr _HKEY)) - -(define HKEY_CLASSES_ROOT (const-hkey #x80000000)) -(define HKEY_CURRENT_USER (const-hkey #x80000001)) -(define HKEY_LOCAL_MACHINE (const-hkey #x80000002)) -(define HKEY_USERS (const-hkey #x80000003)) -(define HKEY_CURRENT_CONFIG (const-hkey #x80000005)) - -(define REG_SZ 1) -(define REG_BINARY 3) -(define REG_DWORD 4) - -(define (section->hkey who section) - (cond - [(equal? section "HKEY_CLASSES_ROOT") - HKEY_CLASSES_ROOT] - [(equal? section "HKEY_CURRENT_CONFIG") - HKEY_CURRENT_CONFIG] - [(equal? section "HKEY_CURRENT_USER") - HKEY_CURRENT_USER] - [(equal? section "HKEY_LOCAL_MACHINE") - HKEY_LOCAL_MACHINE] - [(equal? section "HKEY_USERS") - HKEY_USERS] - [(string? section) #f] - [else - (raise-type-error who "string" section)])) - -(define advapi-dll (and (eq? (system-type) 'windows) - (ffi-lib "Advapi32.dll"))) -(define kernel-dll (and (eq? (system-type) 'windows) - (ffi-lib "kernel32.dll"))) - -(define-ffi-definer define-advapi advapi-dll - #:default-make-fail make-not-available) -(define-ffi-definer define-kernel kernel-dll - #:default-make-fail make-not-available) - -(define _LONG _long) -(define _DWORD _int32) -(define _REGSAM _DWORD) -(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) - -(define KEY_QUERY_VALUE #x1) -(define KEY_SET_VALUE #x2) - -(define ERROR_SUCCESS 0) - -(define-advapi RegOpenKeyExW (_fun #:abi winapi - _HKEY _string/utf-16 _DWORD _REGSAM (hkey : (_ptr o _HKEY)) - -> (r : _LONG) - -> (and (= r ERROR_SUCCESS) hkey))) -(define-advapi RegCreateKeyExW (_fun #:abi winapi - _HKEY _string/utf-16 (_DWORD = 0) - (_pointer = #f) ; class - _DWORD ; options - _REGSAM - _pointer ; security - (hkey : (_ptr o _HKEY)) - (_ptr o _DWORD) ; disposition - -> (r : _LONG) - -> (and (= r ERROR_SUCCESS) hkey))) - -(define-advapi RegQueryValueExW (_fun #:abi winapi - _HKEY _string/utf-16 (_pointer = #f) - (type : (_ptr o _DWORD)) - _pointer (len : (_ptr io _DWORD)) - -> (r : _LONG) - -> (if (= r ERROR_SUCCESS) - (values len type) - (values #f #f)))) -(define-advapi RegSetValueExW (_fun #:abi winapi - _HKEY _string/utf-16 (_pointer = #f) - _DWORD _pointer _DWORD - -> (r : _LONG) - -> (= r ERROR_SUCCESS))) - -(define-advapi RegCloseKey (_fun #:abi winapi _HKEY -> _LONG)) - -(define-kernel WritePrivateProfileStringW (_fun #:abi winapi - _string/utf-16 ; app - _string/utf-16 ; key - _string/utf-16 ; val - _string/utf-16 ; filename - -> _BOOL)) -(define-kernel GetPrivateProfileStringW (_fun #:abi winapi - _string/utf-16 ; app - _string/utf-16 ; key - _string/utf-16 ; default - _pointer ; result - _DWORD ; result size in wide chars - _string/utf-16 ; filename - -> _DWORD)) - -(define (file->ini f) - (cond - [(not f) (file->ini - (build-path (find-system-path 'home-dir) "mred.ini"))] - [(string? f) (file->ini (string->path f))] - [(path? f) (path->string (cleanse-path (path->complete-path f)))])) - -(define (extract-sub-hkey file hkey entry op create-key?) - (cond - [(not (eq? 'windows (system-type))) (values #f #f)] - [file (values #f #f)] - [(regexp-match #rx"^(.*)\\\\+([^\\]*)$" entry) - => (lambda (m) - (let ([sub-hkey (RegOpenKeyExW hkey (cadr m) 0 op)] - [sub-entry (caddr m)]) - (if (and (not sub-hkey) - create-key?) - (values (RegCreateKeyExW hkey (cadr m) 0 op #f) - sub-entry) - (values sub-hkey sub-entry))))] - [else (values hkey entry)])) - -(define (get-resource section entry [value #f] [file #f] - #:type [rtype (or (and (box? value) - (or - (and (exact-integer? (unbox value)) - 'integer) - (and (bytes? (unbox value)) - 'bytes))) - 'string)]) - (define hkey (section->hkey 'get-resource section)) - (unless (string? entry) - (raise-type-error 'get-resource "string" entry)) - (unless (or (not value) - (and (box? value) - (let ([value (unbox value)]) - (or (string? value) (bytes? value) (exact-integer? value))))) - (raise-type-error 'get-resource "#f or box of string, byte string, or exact integer" value)) - (unless (or (not file) - (path-string? file)) - (raise-type-error 'get-resource "path string or #f" file)) - (unless (memq rtype '(string bytes integer)) - (raise-type-error 'get-resource "'string, 'bytes, or 'integer" rtype)) - - (define (to-rtype s) - (let ([to-string (lambda (s) - (if (bytes? s) - (bytes->string/utf-8 s #\?) - s))]) - (cond - [(eq? rtype 'string) (to-string s)] - [(eq? rtype 'integer) - (let ([n (string->number (to-string s))]) - (or (and n (exact-integer? n) n) - 0))] - [else - (if (string? s) - (string->bytes/utf-8 s) - s)]))) - - (define-values (sub-hkey sub-entry) - (extract-sub-hkey file hkey entry KEY_QUERY_VALUE #f)) - - (cond - [sub-hkey - (begin0 - (let-values ([(len type) - ;; Get size, first - (RegQueryValueExW sub-hkey sub-entry #f 0)]) - (and len - (let ([s (make-bytes len)]) - (let-values ([(len2 type2) - ;; Get value, now that we have a bytes string of the right size - (RegQueryValueExW sub-hkey sub-entry s len)]) - (and len2 - (let ([r - ;; Unmarhsal according to requested type: - (let ([s (cond - [(= type REG_SZ) - (cast s _pointer _string/utf-16)] - [(= type REG_DWORD) - (number->string (ptr-ref s _DWORD))] - [else - s])]) - (to-rtype s))]) - (if (box? value) - (begin - (set-box! value r) - #t) - r))))))) - (unless (eq? hkey sub-hkey) - (RegCloseKey sub-hkey)))] - [(eq? 'windows (system-type)) - (let* ([SIZE 1024] - [dest (make-bytes (* SIZE 2) 0)] - [DEFAULT "$$default"] - [len (GetPrivateProfileStringW section entry DEFAULT - dest SIZE - (file->ini file))]) - (let ([s (cast dest _pointer _string/utf-16)]) - (and (not (equal? s DEFAULT)) - (let ([r (to-rtype s)]) - (if value - (begin - (set-box! value r) - #t) - r)))))] - [else #f])) - -(define (write-resource section entry value [file #f] - #:type [type 'string] - #:create-key? [create-key? #f]) - (define hkey (section->hkey 'write-resource section)) - (unless (string? entry) - (raise-type-error 'write-resource "string" entry)) - (unless (or (string? value) (bytes? value) (exact-integer? value)) - (raise-type-error 'write-resource "string, byte string, or exact integer" value)) - (unless (or (not file) - (path-string? file)) - (raise-type-error 'write-resource "path string or #f" file)) - (unless (memq type '(string bytes dword)) - (raise-type-error 'write-resource "'string, 'bytes, or 'dword" type)) - - (define (to-string value) - (cond - [(exact-integer? value) (number->string value)] - [(string? value) value] - [else (bytes->string/utf-8 value #\?)])) - - (define-values (sub-hkey sub-entry) - (extract-sub-hkey file hkey entry KEY_SET_VALUE create-key?)) - - (cond - [sub-hkey - (begin0 - (let ([v (case type - [(string) - (to-utf-16 (to-string value))] - [(bytes) - (cond - [(exact-integer? value) - (string->bytes/utf-8 (number->string value))] - [(string? value) (string->bytes/utf-8 value)] - [else value])] - [(dword) - (to-dword-ptr - (cond - [(exact-integer? value) value] - [(string? value) (string->number value)] - [(bytes? value) - (string->number (bytes->string/utf-8 value #\?))]))])] - [ty (case type - [(string) REG_SZ] - [(bytes) REG_BINARY] - [(dword) REG_DWORD])]) - (RegSetValueExW sub-hkey sub-entry ty v (bytes-length v))) - (unless (eq? hkey sub-hkey) - (RegCloseKey sub-hkey)))] - [(eq? 'windows (system-type)) - (WritePrivateProfileStringW section entry (to-string value) (file->ini file))] - [else #f])) - -(define (to-utf-16 s) - (let ([v (malloc _gcpointer)]) - (ptr-set! v _string/utf-16 s) - (let ([len (* 2 (+ 1 (utf-16-length s)))]) - (ptr-ref v (_bytes o len))))) - -(define (utf-16-length s) - (for/fold ([len 0]) ([c (in-string s)]) - (+ len - (if ((char->integer c) . > . #xFFFF) - 2 - 1)))) - -(define (to-dword-ptr v) - (let ([v (if (and (exact-integer? v) - (<= (- (expt 2 31)) - v - (sub1 (expt 2 31)))) - v - 0)]) - (let ([p (malloc _DWORD)]) - (ptr-set! p _DWORD v) - (cast p _pointer (_bytes o (ctype-sizeof _DWORD)))))) +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define + ffi/winapi) + +(provide get-resource + write-resource) + +(define _HKEY (_cpointer/null 'HKEY)) + +(define (const-hkey v) + (cast (bitwise-ior v (arithmetic-shift -1 32)) _intptr _HKEY)) + +(define HKEY_CLASSES_ROOT (const-hkey #x80000000)) +(define HKEY_CURRENT_USER (const-hkey #x80000001)) +(define HKEY_LOCAL_MACHINE (const-hkey #x80000002)) +(define HKEY_USERS (const-hkey #x80000003)) +(define HKEY_CURRENT_CONFIG (const-hkey #x80000005)) + +(define REG_SZ 1) +(define REG_EXPAND_SZ 2) +(define REG_BINARY 3) +(define REG_DWORD 4) + +(define (section->hkey who section) + (cond + [(equal? section "HKEY_CLASSES_ROOT") + HKEY_CLASSES_ROOT] + [(equal? section "HKEY_CURRENT_CONFIG") + HKEY_CURRENT_CONFIG] + [(equal? section "HKEY_CURRENT_USER") + HKEY_CURRENT_USER] + [(equal? section "HKEY_LOCAL_MACHINE") + HKEY_LOCAL_MACHINE] + [(equal? section "HKEY_USERS") + HKEY_USERS] + [(string? section) #f] + [else + (raise-type-error who "string" section)])) + +(define advapi-dll (and (eq? (system-type) 'windows) + (ffi-lib "Advapi32.dll"))) +(define kernel-dll (and (eq? (system-type) 'windows) + (ffi-lib "kernel32.dll"))) + +(define-ffi-definer define-advapi advapi-dll + #:default-make-fail make-not-available) +(define-ffi-definer define-kernel kernel-dll + #:default-make-fail make-not-available) + +(define _LONG _long) +(define _DWORD _int32) +(define _REGSAM _DWORD) +(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v))))) + +(define KEY_QUERY_VALUE #x1) +(define KEY_SET_VALUE #x2) + +(define ERROR_SUCCESS 0) + +(define-advapi RegOpenKeyExW (_fun #:abi winapi + _HKEY _string/utf-16 _DWORD _REGSAM (hkey : (_ptr o _HKEY)) + -> (r : _LONG) + -> (and (= r ERROR_SUCCESS) hkey))) +(define-advapi RegCreateKeyExW (_fun #:abi winapi + _HKEY _string/utf-16 (_DWORD = 0) + (_pointer = #f) ; class + _DWORD ; options + _REGSAM + _pointer ; security + (hkey : (_ptr o _HKEY)) + (_ptr o _DWORD) ; disposition + -> (r : _LONG) + -> (and (= r ERROR_SUCCESS) hkey))) + +(define-advapi RegQueryValueExW (_fun #:abi winapi + _HKEY _string/utf-16 (_pointer = #f) + (type : (_ptr o _DWORD)) + _pointer (len : (_ptr io _DWORD)) + -> (r : _LONG) + -> (if (= r ERROR_SUCCESS) + (values len type) + (values #f #f)))) +(define-advapi RegSetValueExW (_fun #:abi winapi + _HKEY _string/utf-16 (_pointer = #f) + _DWORD _pointer _DWORD + -> (r : _LONG) + -> (= r ERROR_SUCCESS))) + +(define-advapi RegCloseKey (_fun #:abi winapi _HKEY -> _LONG)) + +(define-kernel WritePrivateProfileStringW (_fun #:abi winapi + _string/utf-16 ; app + _string/utf-16 ; key + _string/utf-16 ; val + _string/utf-16 ; filename + -> _BOOL)) +(define-kernel GetPrivateProfileStringW (_fun #:abi winapi + _string/utf-16 ; app + _string/utf-16 ; key + _string/utf-16 ; default + _pointer ; result + _DWORD ; result size in wide chars + _string/utf-16 ; filename + -> _DWORD)) + +(define (file->ini f) + (cond + [(not f) (file->ini + (build-path (find-system-path 'home-dir) "mred.ini"))] + [(string? f) (file->ini (string->path f))] + [(path? f) (path->string (cleanse-path (path->complete-path f)))])) + +(define (extract-sub-hkey file hkey entry op create-key?) + (cond + [(not (eq? 'windows (system-type))) (values #f #f)] + [file (values #f #f)] + [(regexp-match #rx"^(.*)\\\\+([^\\]*)$" entry) + => (lambda (m) + (let ([sub-hkey (RegOpenKeyExW hkey (cadr m) 0 op)] + [sub-entry (caddr m)]) + (if (and (not sub-hkey) + create-key?) + (values (RegCreateKeyExW hkey (cadr m) 0 op #f) + sub-entry) + (values sub-hkey sub-entry))))] + [else (values hkey entry)])) + +(define (get-resource section entry [value #f] [file #f] + #:type [rtype (or (and (box? value) + (or + (and (exact-integer? (unbox value)) + 'integer) + (and (bytes? (unbox value)) + 'bytes))) + 'string)]) + (define hkey (section->hkey 'get-resource section)) + (unless (string? entry) + (raise-type-error 'get-resource "string" entry)) + (unless (or (not value) + (and (box? value) + (let ([value (unbox value)]) + (or (string? value) (bytes? value) (exact-integer? value))))) + (raise-type-error 'get-resource "#f or box of string, byte string, or exact integer" value)) + (unless (or (not file) + (path-string? file)) + (raise-type-error 'get-resource "path string or #f" file)) + (unless (memq rtype '(string string/utf-16 bytes bytes* integer)) + (raise-type-error 'get-resource "'string, 'string/utf-16, 'bytes, 'bytes*, or 'integer" rtype)) + + (define (to-rtype s) + (let ([to-string (lambda (s) + (if (bytes? s) + (bytes->string/utf-8 s #\?) + s))]) + (cond + [(eq? rtype 'string) (to-string s)] + [(eq? rtype 'string/utf-16) (if (bytes? s) + (cast s _pointer _string/utf-16) + s)] + [(eq? rtype 'integer) + (let ([n (string->number (to-string s))]) + (or (and n (exact-integer? n) n) + 0))] + [else + (if (string? s) + (string->bytes/utf-8 s) + s)]))) + + (define-values (sub-hkey sub-entry) + (extract-sub-hkey file hkey entry KEY_QUERY_VALUE #f)) + + (cond + [sub-hkey + (begin0 + (let-values ([(len type) + ;; Get size, first + (RegQueryValueExW sub-hkey sub-entry #f 0)]) + (and len + (let ([s (make-bytes len)]) + (let-values ([(len2 type2) + ;; Get value, now that we have a bytes string of the right size + (RegQueryValueExW sub-hkey sub-entry s len)]) + (and len2 + (let ([r + ;; Unmarhsal according to requested type: + (let ([s (cond + [(= type REG_SZ) + (if (eq? rtype 'bytes*) + s + (cast s _pointer _string/utf-16))] + [(= type REG_DWORD) + (number->string (ptr-ref s _DWORD))] + [else + s])]) + (to-rtype s))]) + (if (box? value) + (begin + (set-box! value r) + #t) + r))))))) + (unless (eq? hkey sub-hkey) + (RegCloseKey sub-hkey)))] + [(eq? 'windows (system-type)) + (let* ([SIZE 1024] + [dest (make-bytes (* SIZE 2) 0)] + [DEFAULT "$$default"] + [len (GetPrivateProfileStringW section entry DEFAULT + dest SIZE + (file->ini file))]) + (let ([s (cast dest _pointer _string/utf-16)]) + (and (not (equal? s DEFAULT)) + (let ([r (to-rtype s)]) + (if value + (begin + (set-box! value r) + #t) + r)))))] + [else #f])) + +(define (write-resource section entry value [file #f] + #:type [type 'string] + #:create-key? [create-key? #f]) + (define hkey (section->hkey 'write-resource section)) + (unless (string? entry) + (raise-type-error 'write-resource "string" entry)) + (unless (or (string? value) (bytes? value) (exact-integer? value)) + (raise-type-error 'write-resource "string, byte string, or exact integer" value)) + (unless (or (not file) + (path-string? file)) + (raise-type-error 'write-resource "path string or #f" file)) + (unless (memq type '(string expand-string bytes bytes/string bytes/expand-string dword)) + (raise-type-error 'write-resource + "'string, 'expand-string, 'bytes, 'bytes/string, 'bytes/expand-string, or 'dword" + type)) + + (define (to-string value) + (cond + [(exact-integer? value) (number->string value)] + [(string? value) value] + [else (bytes->string/utf-8 value #\?)])) + + (define-values (sub-hkey sub-entry) + (extract-sub-hkey file hkey entry KEY_SET_VALUE create-key?)) + + (cond + [sub-hkey + (begin0 + (let ([v (case type + [(string expand-string) + (to-utf-16 (to-string value))] + [(bytes/string bytes/expand-string) + (cond + [(exact-integer? value) + (to-utf-16 (number->string value))] + [(string? value) (to-utf-16 value)] + [else value])] + [(bytes) + (cond + [(exact-integer? value) + (string->bytes/utf-8 (number->string value))] + [(string? value) (string->bytes/utf-8 value)] + [else value])] + [(dword) + (to-dword-ptr + (cond + [(exact-integer? value) value] + [(string? value) (string->number value)] + [(bytes? value) + (string->number (bytes->string/utf-8 value #\?))]))])] + [ty (case type + [(string bytes/string) REG_SZ] + [(expand-string bytes/expand-string) REG_EXPAND_SZ] + [(bytes) REG_BINARY] + [(dword) REG_DWORD])]) + (RegSetValueExW sub-hkey sub-entry ty v (bytes-length v))) + (unless (eq? hkey sub-hkey) + (RegCloseKey sub-hkey)))] + [(eq? 'windows (system-type)) + (WritePrivateProfileStringW section entry (to-string value) (file->ini file))] + [else #f])) + +(define (to-utf-16 s) + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([len (* 2 (+ 1 (utf-16-length s)))]) + (ptr-ref v (_bytes o len))))) + +(define (utf-16-length s) + (for/fold ([len 0]) ([c (in-string s)]) + (+ len + (if ((char->integer c) . > . #xFFFF) + 2 + 1)))) + +(define (to-dword-ptr v) + (let ([v (if (and (exact-integer? v) + (<= (- (expt 2 31)) + v + (sub1 (expt 2 31)))) + v + 0)]) + (let ([p (malloc _DWORD)]) + (ptr-set! p _DWORD v) + (cast p _pointer (_bytes o (ctype-sizeof _DWORD))))))