suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

file/resource: support REG_EXPAND_SZ

Browse Source 
Also, provide workarounds for some broken conversions --- especially
the 'string/utf-16 conversion for reading. For writing, allow
specifying raw bytes that end up in REG_SZ or REG_EXPAND_SZ via
'bytes/string or 'bytes/expand-string.
This commit is contained in:
Matthew Flatt 2021-03-02 20:18:13 -07:00
parent e615294e78
commit 5114fec2c7
3 changed files with 520 additions and 404 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
pkgs/racket-doc/file/scribblings/resource.scrbl
View File

@ -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].}]}

190
pkgs/racket-test-core/tests/racket/resource.rktl
View File

@ -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)

595
racket/collects/file/resource.rkt
View File

@ -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))))))