From 18eb7c86b5f135445858de032d93c96f36c4ad4e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 5 Feb 2011 07:25:47 -0700 Subject: [PATCH] `get-resource' and `write-resource': support .ini files --- collects/file/resource.rkt | 195 ++++++++++++++--------- collects/file/scribblings/resource.scrbl | 49 ++++-- collects/tests/racket/resource.rktl | 17 +- 3 files changed, 170 insertions(+), 91 deletions(-) diff --git a/collects/file/resource.rkt b/collects/file/resource.rkt index 3ff776541c..9a58731e07 100644 --- a/collects/file/resource.rkt +++ b/collects/file/resource.rkt @@ -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)]) diff --git a/collects/file/scribblings/resource.scrbl b/collects/file/scribblings/resource.scrbl index ff290dce1b..e0c1b3e5ae 100644 --- a/collects/file/scribblings/resource.scrbl +++ b/collects/file/scribblings/resource.scrbl @@ -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].} diff --git a/collects/tests/racket/resource.rktl b/collects/tests/racket/resource.rktl index 7f6a77da8e..cbbe765bd8 100644 --- a/collects/tests/racket/resource.rktl +++ b/collects/tests/racket/resource.rktl @@ -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) - -