`file/resource': improve compatibility
by generating "failure" results instead of exn:fail:unsupported
This commit is contained in:
Matthew Flatt
parent
b4ce4bbd2c
commit
337500552c
|
|
@ -32,13 +32,9 @@
|
|||
HKEY_LOCAL_MACHINE]
|
||||
[(equal? section "HKEY_USERS")
|
||||
HKEY_USERS]
|
||||
[(string? section) #f]
|
||||
[else
|
||||
(raise-type-error who
|
||||
(string-append
|
||||
"\"HKEY_CLASSES_ROOT\", \"HKEY_CURRENT_CONFIG\", "
|
||||
"\"HKEY_CURRENT_USER\", \"HKEY_LOCAL_MACHINE\", "
|
||||
"or \"HKEY_USERS\"")
|
||||
section)]))
|
||||
(raise-type-error who "string" section)]))
|
||||
|
||||
(define advapi-dll (and (eq? (system-type) 'windows)
|
||||
(ffi-lib "Advapi32.dll")))
|
||||
|
|
@ -89,15 +85,10 @@
|
|||
|
||||
(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?)
|
||||
(define (extract-sub-hkey file hkey entry op create-key?)
|
||||
(cond
|
||||
[(not (eq? 'windows (system-type))) (values #f #f)]
|
||||
[file #f]
|
||||
[(regexp-match #rx"^(.*)\\\\+([^\\]*)$" entry)
|
||||
=> (lambda (m)
|
||||
(let ([sub-hkey (RegOpenKeyExW hkey (cadr m) 0 op)]
|
||||
|
|
@ -125,15 +116,14 @@
|
|||
(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 (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))
|
||||
|
||||
(check-platform 'get-resource)
|
||||
|
||||
(define-values (sub-hkey sub-entry)
|
||||
(extract-sub-hkey hkey entry KEY_QUERY_VALUE #f))
|
||||
(extract-sub-hkey file hkey entry KEY_QUERY_VALUE #f))
|
||||
|
||||
(and sub-hkey
|
||||
(begin0
|
||||
|
|
@ -185,15 +175,14 @@
|
|||
(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 (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))
|
||||
|
||||
(check-platform 'write-resource)
|
||||
|
||||
(define-values (sub-hkey sub-entry)
|
||||
(extract-sub-hkey hkey entry KEY_SET_VALUE create-key?))
|
||||
(extract-sub-hkey file hkey entry KEY_SET_VALUE create-key?))
|
||||
|
||||
(and sub-hkey
|
||||
(begin0
|
||||
|
|
|
|||
|
|
@ -2,23 +2,27 @@
|
|||
@(require "common.ss"
|
||||
(for-label file/resource))
|
||||
|
||||
@(define-syntax-rule (compat section indexed-racket)
|
||||
@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
|
||||
@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"].})
|
||||
|
||||
@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")]
|
||||
@defproc[(get-resource [section string?]
|
||||
[entry string?]
|
||||
[value-box (or/f #f (box/c (or/c string? bytes? exact-integer?))) #f]
|
||||
[file #f #f]
|
||||
[file (or/c #f fail-path?) #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.
|
||||
Gets a value from the Windows registry. @compat[section indexed-racket]
|
||||
|
||||
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
|
||||
|
|
@ -55,9 +59,6 @@ Registry values of any format can be extracted. Values using the
|
|||
|
||||
]
|
||||
|
||||
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:
|
||||
|
|
@ -67,20 +68,15 @@ browser:
|
|||
"htmlfile\\shell\\open\\command\\")
|
||||
]}
|
||||
|
||||
@defproc[(write-resource [section (or/c "HKEY_CLASSES_ROOT"
|
||||
"HKEY_CURRENT_CONFIG"
|
||||
"HKEY_CURRENT_USER"
|
||||
"HKEY_LOCAL_MACHINE"
|
||||
"HKEY_USERS")]
|
||||
@defproc[(write-resource [section string?]
|
||||
[entry string?]
|
||||
[value (or/c string? bytes? exact-integer?)]
|
||||
[file #f #f]
|
||||
[file (or/c path-string? #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.
|
||||
Write a value to the Windows registry. @compat[section racket]
|
||||
|
||||
The resource value is keyed on the combination of @racket[section] and
|
||||
@racket[entry]. If @racket[create-key?] is false, the resource entry
|
||||
|
|
@ -92,9 +88,5 @@ The @racket[type] argument determines the format of the value in the
|
|||
@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.}
|
||||
the inverse of the conversions for @racket[get-resource].}
|
||||
|
||||
|
|
|
|||
|
|
@ -8,40 +8,49 @@
|
|||
|
||||
(require file/resource)
|
||||
|
||||
(when (eq? 'windows (system-type))
|
||||
(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)))
|
||||
|
||||
(test #t 'init (write-resource key (entry "Stuff") "Hello" #:create-key? #t))
|
||||
(rtest #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)
|
||||
(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 "")])
|
||||
(test #t get-resource key (entry "Stuff") b)
|
||||
(test "Hola" unbox b))
|
||||
(rtest #t get-resource key (entry "Stuff") b)
|
||||
(xtest "Hola" "" unbox b))
|
||||
(let ([b (box #"")])
|
||||
(test #t get-resource key (entry "Stuff") b)
|
||||
(test #"Hola" unbox b))
|
||||
(rtest #t get-resource key (entry "Stuff") b)
|
||||
(xtest #"Hola" #"" unbox b))
|
||||
(let ([b (box 10)])
|
||||
(test #t get-resource key (entry "Stuff") b)
|
||||
(test 0 unbox b))
|
||||
(rtest #t get-resource key (entry "Stuff") b)
|
||||
(xtest 0 10 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)
|
||||
(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:
|
||||
(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)
|
||||
(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)
|
||||
|
||||
(void))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user