add `file/resource'

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))))))

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"

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.}
+

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)

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)
+
+