get-resource' and write-resource': support .ini files
This commit is contained in:
Matthew Flatt
parent
b4c3d82c94
commit
18eb7c86b5
|
|
@ -38,9 +38,13 @@
|
|||
|
||||
(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 win64? (equal? "win32\\x86_64" (path->string (system-library-subpath #f))))
|
||||
(define win_abi (if win64? #f 'stdcall))
|
||||
|
|
@ -48,6 +52,7 @@
|
|||
(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)
|
||||
|
|
@ -85,10 +90,32 @@
|
|||
|
||||
(define-advapi RegCloseKey (_fun #:abi win_abi _HKEY -> _LONG))
|
||||
|
||||
(define-kernel WritePrivateProfileStringW (_fun #:abi win_abi
|
||||
_string/utf-16 ; app
|
||||
_string/utf-16 ; key
|
||||
_string/utf-16 ; val
|
||||
_string/utf-16 ; filename
|
||||
-> _BOOL))
|
||||
(define-kernel GetPrivateProfileStringW (_fun #:abi win_abi
|
||||
_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 #f]
|
||||
[file (values #f #f)]
|
||||
[(regexp-match #rx"^(.*)\\\\+([^\\]*)$" entry)
|
||||
=> (lambda (m)
|
||||
(let ([sub-hkey (RegOpenKeyExW hkey (cadr m) 0 op)]
|
||||
|
|
@ -122,50 +149,70 @@
|
|||
(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))
|
||||
|
||||
(and 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-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)]))])
|
||||
(if (box? value)
|
||||
(begin
|
||||
(set-box! value r)
|
||||
#t)
|
||||
r)))))))
|
||||
(unless (eq? hkey sub-hkey)
|
||||
(RegCloseKey sub-hkey)))))
|
||||
(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]
|
||||
|
|
@ -181,38 +228,44 @@
|
|||
(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?))
|
||||
|
||||
(and sub-hkey
|
||||
(begin0
|
||||
(let ([v (case type
|
||||
[(string)
|
||||
(to-utf-16
|
||||
(cond
|
||||
[(exact-integer? value) (number->string value)]
|
||||
[(string? value) value]
|
||||
[else (bytes->string/utf-8 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)))))
|
||||
(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)])
|
||||
|
|
|
|||
|
|
@ -2,14 +2,19 @@
|
|||
@(require "common.ss"
|
||||
(for-label file/resource))
|
||||
|
||||
@(define-syntax-rule (compat section indexed-racket)
|
||||
@(define-syntax-rule (compat file section indexed-racket what)
|
||||
@elem{For backward compatibilty, the
|
||||
result is @racket[#f] for platforms other than Windows, when
|
||||
@racket[file] is not @racket[#f], or when @racket[section] is not
|
||||
result is @racket[#f] for platforms other than Windows. The registry
|
||||
is @|what| when
|
||||
@racket[file] is @racket[#f] and when @racket[section] is
|
||||
@indexed-racket["HKEY_CLASSES_ROOT"],
|
||||
@indexed-racket["HKEY_CURRENT_CONFIG"],
|
||||
@indexed-racket["HKEY_CURRENT_USER"],
|
||||
@indexed-racket["HKEY_LOCAL_MACHINE"], or @indexed-racket["HKEY_USERS"].})
|
||||
@indexed-racket["HKEY_LOCAL_MACHINE"], or @indexed-racket["HKEY_USERS"].
|
||||
When @racket[file] is @racket[#f] and @racket[section] is not one of
|
||||
the special registry strings, then
|
||||
@racket[(build-path (find-system-path 'home-dir) "mred.ini")]
|
||||
is @|what|.})
|
||||
|
||||
@title[#:tag "resource"]{Windows Registry}
|
||||
|
||||
|
|
@ -22,7 +27,8 @@
|
|||
[#:type type (or/c 'string 'bytes 'integer) _derived-from-value-box])
|
||||
(or/c #f string? bytes? exact-integer? #t)]{
|
||||
|
||||
Gets a value from the Windows registry. @compat[section indexed-racket]
|
||||
Gets a value from the Windows registry or an @filepath{.ini}
|
||||
file. @compat[file section indexed-racket "read"]
|
||||
|
||||
The resource value is keyed on the combination of @racket[section] and
|
||||
@racket[entry]. The result is @racket[#f] if no value is found for
|
||||
|
|
@ -31,7 +37,7 @@ 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 registry is
|
||||
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].
|
||||
|
|
@ -40,11 +46,12 @@ 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 type @racket[type]:
|
||||
converted to the requested @racket[type] as follows:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{A @tt{REG_SZ} registry value is converted to an integer using
|
||||
@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].}
|
||||
|
|
@ -59,9 +66,12 @@ Registry values of any format can be extracted. Values using the
|
|||
|
||||
]
|
||||
|
||||
To get the ``default'' value for an entry, use a trailing backslash. For
|
||||
example, the following expression gets a command line for starting a
|
||||
browser:
|
||||
Resources from @filepath{.ini} files are always strings, and are
|
||||
converted like @tt{REG_SZ} registry values.
|
||||
|
||||
To get the ``default'' value for a registry entry, use a trailing
|
||||
backslash. For example, the following expression gets a command line
|
||||
for starting a browser:
|
||||
|
||||
@racketblock[
|
||||
(get-resource "HKEY_CLASSES_ROOT"
|
||||
|
|
@ -76,17 +86,22 @@ browser:
|
|||
[#:create-key? create-key? any/c #f])
|
||||
boolean?]{
|
||||
|
||||
Write a value to the Windows registry. @compat[section racket]
|
||||
Write a value to the Windows registry or an @filepath{.ini}
|
||||
file. @compat[file section racket "written"]
|
||||
|
||||
The resource value is keyed on the combination of @racket[section] and
|
||||
@racket[entry]. If @racket[create-key?] is false, the resource entry
|
||||
must already exist, otherwise the write fails. The result is
|
||||
@racket[#f] if the write fails or @racket[#t] if it succeeds.
|
||||
@racket[entry]. If @racket[create-key?] is false when writing to the
|
||||
registry, the resource entry must already exist, otherwise the write
|
||||
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 in the
|
||||
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 inverse of the conversions for @racket[get-resource].
|
||||
|
||||
When writing to an @filepath{.ini} file, the format is always a
|
||||
string, independent of @racket[type].}
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
|
||||
(Section 'resource)
|
||||
|
||||
(require file/resource)
|
||||
(require file/resource
|
||||
racket/file)
|
||||
|
||||
(let ()
|
||||
(define key "HKEY_CURRENT_USER")
|
||||
|
|
@ -52,8 +53,18 @@
|
|||
(rtest #"i\377mage" get-resource key (entry "Data") #:type 'bytes)
|
||||
(rtest 0 get-resource key (entry "Data") #:type 'integer)
|
||||
|
||||
;; .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)
|
||||
(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))
|
||||
(test "[Temporary]\r\nStuff=howdy\r\nmore=10\r\n" file->string tmp-ini)
|
||||
(delete-file tmp-ini)))
|
||||
|
||||
(void))
|
||||
|
||||
(report-errs)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user