`file/resource': improve compatibility

by generating "failure" results instead of exn:fail:unsupported

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
+    (raise-type-error who "string" section)]))
-                      (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")))
@@ -89,15 +85,10 @@
 
 (define-advapi RegCloseKey (_fun #:abi win_abi _HKEY -> _LONG))
 
-(define (check-platform who)
+(define (extract-sub-hkey file hkey entry op create-key?)
-  (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
+   [(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)
+  (unless (or (not file)
-    (raise-type-error 'get-resource "#f" 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)
+  (unless (or (not file)
-    (raise-type-error 'write-resource "#f" 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

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"
+@defproc[(get-resource [section string?]
-                                      "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]
+                       [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
+Gets a value from the Windows registry. @compat[section indexed-racket]
- 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
@@ -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"
+@defproc[(write-resource [section string?]
-                                        "HKEY_CURRENT_CONFIG"
-                                        "HKEY_CURRENT_USER"
-                                        "HKEY_LOCAL_MACHINE"
-                                        "HKEY_USERS")]
                          [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
+Write a value to the Windows registry. @compat[section racket]
- 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
@@ -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 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.}
 

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")
+  (rtest #t write-resource key (entry "Stuff") "Hola")
-  (test "Hola" get-resource key (entry "Stuff"))
+  (rtest "Hola" get-resource key (entry "Stuff"))
-  (test #"Hola" get-resource key (entry "Stuff") #:type 'bytes)
+  (rtest #"Hola" get-resource key (entry "Stuff") #:type 'bytes)
-  (test 0 get-resource key (entry "Stuff") #:type 'integer)
+  (rtest 0 get-resource key (entry "Stuff") #:type 'integer)
   (let ([b (box "")])
-    (test #t get-resource key (entry "Stuff") b)
+    (rtest #t get-resource key (entry "Stuff") b)
-    (test "Hola" unbox b))
+    (xtest "Hola" "" unbox b))
   (let ([b (box #"")])
-    (test #t get-resource key (entry "Stuff") b)
+    (rtest #t get-resource key (entry "Stuff") b)
-    (test #"Hola" unbox b))
+    (xtest #"Hola" #"" unbox b))
   (let ([b (box 10)])
-    (test #t get-resource key (entry "Stuff") b)
+    (rtest #t get-resource key (entry "Stuff") b)
-    (test 0 unbox b))
+    (xtest 0 10 unbox b))
 
   ;; An integer-valued resource
-  (test #t write-resource key (entry "Count") 17 #:type 'dword)
+  (rtest #t write-resource key (entry "Count") 17 #:type 'dword)
-  (test "17" get-resource key (entry "Count"))
+  (rtest "17" get-resource key (entry "Count"))
-  (test #"17" get-resource key (entry "Count") #:type 'bytes)
+  (rtest #"17" get-resource key (entry "Count") #:type 'bytes)
-  (test 17 get-resource key (entry "Count") #:type 'integer)
+  (rtest 17 get-resource key (entry "Count") #:type 'integer)
-  (test #t write-resource key (entry "Count") -17 #:type 'dword)
+  (rtest #t write-resource key (entry "Count") -17 #:type 'dword)
-  (test -17 get-resource key (entry "Count") #:type 'integer)
+  (rtest -17 get-resource key (entry "Count") #:type 'integer)
 
   ;; A bytes-valued resource:
-  (test #t write-resource key (entry "Data") #"i\377mage" #:type 'bytes)
+  (rtest #t write-resource key (entry "Data") #"i\377mage" #:type 'bytes)
-  (test "i?mage" get-resource key (entry "Data"))
+  (rtest "i?mage" get-resource key (entry "Data"))
-  (test #"i\377mage" get-resource key (entry "Data") #:type 'bytes)
+  (rtest #"i\377mage" get-resource key (entry "Data") #:type 'bytes)
-  (test 0 get-resource key (entry "Data") #:type 'integer)
+  (rtest 0 get-resource key (entry "Data") #:type 'integer)
 
   (void))