From e4db039f201f8f18b3b258e19b465354d7266791 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Feb 2011 14:24:22 -0700 Subject: [PATCH] `file/resource': improve compatibility by generating "failure" results instead of exn:fail:unsupported (cherry picked from commit 337500552c8bbf3c3078236a483c889003b2a44c) --- collects/file/resource.rkt | 37 ++++++----------- collects/file/scribblings/resource.scrbl | 40 +++++++----------- collects/tests/racket/resource.rktl | 53 ++++++++++++++---------- 3 files changed, 60 insertions(+), 70 deletions(-) diff --git a/collects/file/resource.rkt b/collects/file/resource.rkt index d668497a7c..3ff776541c 100644 --- a/collects/file/resource.rkt +++ b/collects/file/resource.rkt @@ -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 diff --git a/collects/file/scribblings/resource.scrbl b/collects/file/scribblings/resource.scrbl index 4fc5254a68..ff290dce1b 100644 --- a/collects/file/scribblings/resource.scrbl +++ b/collects/file/scribblings/resource.scrbl @@ -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].} diff --git a/collects/tests/racket/resource.rktl b/collects/tests/racket/resource.rktl index 9ab8b8c98f..7f6a77da8e 100644 --- a/collects/tests/racket/resource.rktl +++ b/collects/tests/racket/resource.rktl @@ -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))