diff --git a/collects/file/resource.rkt b/collects/file/resource.rkt new file mode 100644 index 0000000000..d668497a7c --- /dev/null +++ b/collects/file/resource.rkt @@ -0,0 +1,251 @@ +#lang racket/base +(require ffi/unsafe + ffi/unsafe/define) + +(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] + [else + (raise-type-error who + (string-append + "\"HKEY_CLASSES_ROOT\", \"HKEY_CURRENT_CONFIG\", " + "\"HKEY_CURRENT_USER\", \"HKEY_LOCAL_MACHINE\", " + "or \"HKEY_USERS\"") + section)])) + +(define advapi-dll (and (eq? (system-type) 'windows) + (ffi-lib "Advapi32.dll"))) + +(define-ffi-definer define-advapi advapi-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)) + +(define _LONG _long) +(define _DWORD _int32) +(define _REGSAM _DWORD) + +(define KEY_QUERY_VALUE #x1) +(define KEY_SET_VALUE #x2) + +(define ERROR_SUCCESS 0) + +(define-advapi RegOpenKeyExW (_fun #:abi win_abi + _HKEY _string/utf-16 _DWORD _REGSAM (hkey : (_ptr o _HKEY)) + -> (r : _LONG) + -> (and (= r ERROR_SUCCESS) hkey))) +(define-advapi RegCreateKeyExW (_fun #:abi win_abi + _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 win_abi + _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 win_abi + _HKEY _string/utf-16 (_pointer = #f) + _DWORD _pointer _DWORD + -> (r : _LONG) + -> (= r ERROR_SUCCESS))) + +(define-advapi RegCloseKey (_fun #:abi win_abi _HKEY -> _LONG)) + +(define (check-platform who) + (unless (eq? 'windows (system-type)) + (raise + (make-exn:fail:unsupported + (format "~a: unsupported on this platform" who) + (current-continuation-marks))))) + +(define (extract-sub-hkey hkey entry op create-key?) + (cond + [(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 "box of string, byte string, or exact integer")) + (unless (not file) + (raise-type-error 'get-resource "#f" file)) + (unless (memq rtype '(string bytes integer)) + (raise-type-error 'get-resource "'string, 'bytes, or 'integer" rtype)) + + (check-platform 'get-resource) + + (define-values (sub-hkey sub-entry) + (extract-sub-hkey 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))))) + +(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")) + (unless (not file) + (raise-type-error 'write-resource "#f" file)) + (unless (memq type '(string bytes dword)) + (raise-type-error 'write-resource "'string, 'bytes, or 'dword" type)) + + (check-platform 'write-resource) + + (define-values (sub-hkey sub-entry) + (extract-sub-hkey 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))))) + +(define (to-utf-16 s) + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (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)))))) diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl index e9ccc91601..4ab38c6d8a 100644 --- a/collects/file/scribblings/file.scrbl +++ b/collects/file/scribblings/file.scrbl @@ -13,6 +13,7 @@ @include-section["md5.scrbl"] @include-section["sha1.scrbl"] @include-section["gif.scrbl"] +@include-section["resource.scrbl"] @(bibliography (bib-entry #:key "Gervautz1990" diff --git a/collects/file/scribblings/resource.scrbl b/collects/file/scribblings/resource.scrbl new file mode 100644 index 0000000000..4fc5254a68 --- /dev/null +++ b/collects/file/scribblings/resource.scrbl @@ -0,0 +1,100 @@ +#lang scribble/doc +@(require "common.ss" + (for-label file/resource)) + +@title[#:tag "resource"]{Windows Registry} + +@defmodule[file/resource] + +@defproc[(get-resource [section (or/c "HKEY_CLASSES_ROOT" + "HKEY_CURRENT_CONFIG" + "HKEY_CURRENT_USER" + "HKEY_LOCAL_MACHINE" + "HKEY_USERS")] + [entry string?] + [value-box (or/f #f (box/c (or/c string? bytes? exact-integer?))) #f] + [file #f #f] + [#: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. Under platforms other than + Windows, an @racket[exn:fail:unsupported] exception is raised. + +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 + the specified @racket[section] and @racket[entry]. If @racket[value-box] + is a box, then the result is @racket[#t] if a value is found, and the + 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 + 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 type @racket[type]: + +@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_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{Any other kind of registry value is converted to a string or + integer using @racket[bytes->string/utf-8] and (for integers) + @racket[string->number].} + +] + +The @racket[file] argument is included for backward compatibility and + must be @racket[#f]. + +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: + +@racketblock[ + (get-resource "HKEY_CLASSES_ROOT" + "htmlfile\\shell\\open\\command\\") +]} + +@defproc[(write-resource [section (or/c "HKEY_CLASSES_ROOT" + "HKEY_CURRENT_CONFIG" + "HKEY_CURRENT_USER" + "HKEY_LOCAL_MACHINE" + "HKEY_USERS")] + [entry string?] + [value (or/c string? bytes? exact-integer?)] + [file #f #f] + [#:type type (or/c 'string 'bytes 'integer) 'string] + [#:create-key? create-key? any/c #f]) + boolean?]{ + +Write a value to the Windows registry. Under platforms other than + Windows, an @racket[exn:fail:unsupported] exception is raised. + +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. + +The @racket[type] argument determines the format of the value in 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[file] argument must be @racket[#f]. A path is allowed for + backward compatibility of arguments, but providing a path causes an + @racket[exn:fail:unsupported] exception to be raised.} + diff --git a/collects/tests/racket/mzlib-tests.rktl b/collects/tests/racket/mzlib-tests.rktl index 81fc47b394..5305a069b0 100644 --- a/collects/tests/racket/mzlib-tests.rktl +++ b/collects/tests/racket/mzlib-tests.rktl @@ -27,5 +27,6 @@ (load-in-sandbox "shared.rktl") (load-in-sandbox "kw.rktl") (load-in-sandbox "macrolib.rktl") +(load-in-sandbox "resource.rktl") (report-errs) diff --git a/collects/tests/racket/resource.rktl b/collects/tests/racket/resource.rktl new file mode 100644 index 0000000000..9ab8b8c98f --- /dev/null +++ b/collects/tests/racket/resource.rktl @@ -0,0 +1,50 @@ + +;; This test modifies registry entries under Windows +;; within HKEY_CURRENT_USER\Software\PLT + +(load-relative "loadtest.rktl") + +(Section 'resource) + +(require file/resource) + +(when (eq? 'windows (system-type)) + (define key "HKEY_CURRENT_USER") + (define (entry s) (string-append "SOFTWARE\\PLT\\" s)) + + (test #t 'init (write-resource key (entry "Stuff") "Hello" #:create-key? #t)) + + ;; A string-valued resource: + (test #t write-resource key (entry "Stuff") "Hola") + (test "Hola" get-resource key (entry "Stuff")) + (test #"Hola" get-resource key (entry "Stuff") #:type 'bytes) + (test 0 get-resource key (entry "Stuff") #:type 'integer) + (let ([b (box "")]) + (test #t get-resource key (entry "Stuff") b) + (test "Hola" unbox b)) + (let ([b (box #"")]) + (test #t get-resource key (entry "Stuff") b) + (test #"Hola" unbox b)) + (let ([b (box 10)]) + (test #t get-resource key (entry "Stuff") b) + (test 0 unbox b)) + + ;; An integer-valued resource + (test #t write-resource key (entry "Count") 17 #:type 'dword) + (test "17" get-resource key (entry "Count")) + (test #"17" get-resource key (entry "Count") #:type 'bytes) + (test 17 get-resource key (entry "Count") #:type 'integer) + (test #t write-resource key (entry "Count") -17 #:type 'dword) + (test -17 get-resource key (entry "Count") #:type 'integer) + + ;; A bytes-valued resource: + (test #t write-resource key (entry "Data") #"i\377mage" #:type 'bytes) + (test "i?mage" get-resource key (entry "Data")) + (test #"i\377mage" get-resource key (entry "Data") #:type 'bytes) + (test 0 get-resource key (entry "Data") #:type 'integer) + + (void)) + +(report-errs) + +