get-resource' and write-resource': support .ini files

collects/file/resource.rkt

@@ -38,9 +38,13 @@
 
 (define advapi-dll (and (eq? (system-type) 'windows)
                      (ffi-lib "Advapi32.dll")))
+(define kernel-dll (and (eq? (system-type) 'windows)
+                        (ffi-lib "kernel32.dll")))
 
 (define-ffi-definer define-advapi advapi-dll
   #:default-make-fail make-not-available)
+(define-ffi-definer define-kernel kernel-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))
@@ -48,6 +52,7 @@
 (define _LONG _long)
 (define _DWORD _int32)
 (define _REGSAM _DWORD)
+(define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v)))))
 
 (define KEY_QUERY_VALUE #x1)
 (define KEY_SET_VALUE   #x2)
@@ -85,10 +90,32 @@
 
 (define-advapi RegCloseKey (_fun #:abi win_abi _HKEY -> _LONG))
 
+(define-kernel WritePrivateProfileStringW (_fun #:abi win_abi
+                                                _string/utf-16 ; app
+                                                _string/utf-16 ; key
+                                                _string/utf-16 ; val
+                                                _string/utf-16 ; filename
+                                                -> _BOOL))
+(define-kernel GetPrivateProfileStringW (_fun #:abi win_abi
+                                              _string/utf-16 ; app
+                                              _string/utf-16 ; key
+                                              _string/utf-16 ; default
+                                              _pointer ; result
+                                              _DWORD ; result size in wide chars
+                                              _string/utf-16 ; filename
+                                              -> _DWORD))
+
+(define (file->ini f)
+  (cond
+   [(not f) (file->ini 
+             (build-path (find-system-path 'home-dir) "mred.ini"))]
+   [(string? f) (file->ini (string->path f))]
+   [(path? f) (path->string (cleanse-path (path->complete-path f)))]))
+
 (define (extract-sub-hkey file hkey entry op create-key?)
   (cond
    [(not (eq? 'windows (system-type))) (values #f #f)]
-   [file #f]
+   [file (values #f #f)]
    [(regexp-match #rx"^(.*)\\\\+([^\\]*)$" entry)
     => (lambda (m)
          (let ([sub-hkey (RegOpenKeyExW hkey (cadr m) 0 op)]
@@ -122,50 +149,70 @@
   (unless (memq rtype '(string bytes integer))
     (raise-type-error 'get-resource "'string, 'bytes, or 'integer" rtype))
   
+  (define (to-rtype s)
+    (let ([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)])))
+
   (define-values (sub-hkey sub-entry)
     (extract-sub-hkey file hkey entry KEY_QUERY_VALUE #f))
 
-  (and sub-hkey
+  (cond
-       (begin0
+   [sub-hkey
-         (let-values ([(len type) 
+    (begin0
-                       ;; Get size, first
+     (let-values ([(len type) 
-                       (RegQueryValueExW sub-hkey sub-entry #f 0)])
+                   ;; Get size, first
-           (and len
+                   (RegQueryValueExW sub-hkey sub-entry #f 0)])
-                (let ([s (make-bytes len)])
+       (and len
-                  (let-values ([(len2 type2) 
+            (let ([s (make-bytes len)])
-                                ;; Get value, now that we have a bytes string of the right size
+              (let-values ([(len2 type2) 
-                                (RegQueryValueExW sub-hkey sub-entry s len)])
+                            ;; Get value, now that we have a bytes string of the right size
-                    (and len2
+                            (RegQueryValueExW sub-hkey sub-entry s len)])
-                         (let ([r
+                (and len2
-                                ;; Unmarhsal according to requested type:
+                     (let ([r
-                                (let ([s (cond
+                            ;; Unmarhsal according to requested type:
-                                          [(= type REG_SZ)
+                            (let ([s (cond
-                                           (cast s _pointer _string/utf-16)]
+                                      [(= type REG_SZ)
-                                          [(= type REG_DWORD)
+                                       (cast s _pointer _string/utf-16)]
-                                           (number->string (ptr-ref s _DWORD))]
+                                      [(= type REG_DWORD)
-                                          [else
+                                       (number->string (ptr-ref s _DWORD))]
-                                           s])]
+                                      [else
-                                      [to-string (lambda (s)
+                                       s])])
-                                                   (if (bytes? s)
+                              (to-rtype s))])
-                                                       (bytes->string/utf-8 s #\?)
+                       (if (box? value)
-                                                       s))])
+                           (begin
-                                  (cond
+                             (set-box! value r)
-                                   [(eq? rtype 'string) (to-string s)]
+                             #t)
-                                   [(eq? rtype 'integer)
+                           r)))))))
-                                    (let ([n (string->number (to-string s))])
+     (unless (eq? hkey sub-hkey)
-                                      (or (and n (exact-integer? n) n)
+       (RegCloseKey sub-hkey)))]
-                                          0))]
+   [(eq? 'windows (system-type))
-                                   [else
+    (let* ([SIZE 1024]
-                                    (if (string? s)
+           [dest (make-bytes (* SIZE 2) 0)]
-                                        (string->bytes/utf-8 s)
+           [DEFAULT "$$default"]
-                                        s)]))])
+           [len (GetPrivateProfileStringW section entry DEFAULT
-                           (if (box? value)
+                                          dest SIZE
-                               (begin
+                                          (file->ini file))])
-                                 (set-box! value r)
+      (let ([s (cast dest _pointer _string/utf-16)])
-                                 #t)
+        (and (not (equal? s DEFAULT))
-                               r)))))))
+             (let ([r (to-rtype s)])
-         (unless (eq? hkey sub-hkey)
+               (if value
-           (RegCloseKey sub-hkey)))))
+                   (begin
+                     (set-box! value r)
+                     #t)
+                   r)))))]
+   [else #f]))
 
 (define (write-resource section entry value [file #f]
                         #:type [type 'string]
@@ -181,38 +228,44 @@
   (unless (memq type '(string bytes dword))
     (raise-type-error 'write-resource "'string, 'bytes, or 'dword" type))
 
+  (define (to-string value)
+    (cond
+     [(exact-integer? value) (number->string value)]
+     [(string? value) value]
+     [else (bytes->string/utf-8 value #\?)]))
+
   (define-values (sub-hkey sub-entry)
     (extract-sub-hkey file hkey entry KEY_SET_VALUE create-key?))
   
-  (and sub-hkey
+  (cond
-       (begin0
+   [sub-hkey
-        (let ([v (case type
+    (begin0
-                   [(string) 
+     (let ([v (case type
-                    (to-utf-16
+                [(string) 
-                     (cond
+                 (to-utf-16 (to-string value))]
-                      [(exact-integer? value) (number->string value)]
+                [(bytes) 
-                      [(string? value) value]
+                 (cond
-                      [else (bytes->string/utf-8 value #\?)]))]
+                  [(exact-integer? value) 
-                   [(bytes) 
+                   (string->bytes/utf-8 (number->string value))]
-                    (cond
+                  [(string? value) (string->bytes/utf-8 value)]
-                     [(exact-integer? value) 
+                  [else value])]
-                      (string->bytes/utf-8 (number->string value))]
+                [(dword) 
-                     [(string? value) (string->bytes/utf-8 value)]
+                 (to-dword-ptr
-                     [else value])]
+                  (cond
-                   [(dword) 
+                   [(exact-integer? value) value]
-                    (to-dword-ptr
+                   [(string? value) (string->number value)]
-                     (cond
+                   [(bytes? value) 
-                      [(exact-integer? value) value]
+                    (string->number (bytes->string/utf-8 value #\?))]))])]
-                      [(string? value) (string->number value)]
+           [ty (case type
-                      [(bytes? value) 
+                 [(string) REG_SZ]
-                       (string->number (bytes->string/utf-8 value #\?))]))])]
+                 [(bytes) REG_BINARY]
-              [ty (case type
+                 [(dword) REG_DWORD])])
-                    [(string) REG_SZ]
+       (RegSetValueExW sub-hkey sub-entry ty v (bytes-length v)))
-                    [(bytes) REG_BINARY]
+     (unless (eq? hkey sub-hkey)
-                    [(dword) REG_DWORD])])
+       (RegCloseKey sub-hkey)))]
-          (RegSetValueExW sub-hkey sub-entry ty v (bytes-length v)))
+   [(eq? 'windows (system-type))
-        (unless (eq? hkey sub-hkey)
+    (WritePrivateProfileStringW section entry (to-string value) (file->ini file))]
-          (RegCloseKey sub-hkey)))))
+   [else #f]))
 
 (define (to-utf-16 s)
   (let ([v (malloc _gcpointer)])

collects/file/scribblings/resource.scrbl

@@ -2,14 +2,19 @@
 @(require "common.ss"
           (for-label file/resource))
 
-@(define-syntax-rule (compat section indexed-racket)
+@(define-syntax-rule (compat file section indexed-racket what)
    @elem{For backward compatibilty, the
- result is @racket[#f] for platforms other than Windows, when
+ result is @racket[#f] for platforms other than Windows. The registry
- @racket[file] is not @racket[#f], or when @racket[section] is not
+ is @|what| when
+ @racket[file] is @racket[#f] and when @racket[section] is 
  @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"].})
+ @indexed-racket["HKEY_LOCAL_MACHINE"], or @indexed-racket["HKEY_USERS"].
+ When @racket[file] is @racket[#f] and @racket[section] is not one of
+ the special registry strings, then 
+ @racket[(build-path (find-system-path 'home-dir) "mred.ini")] 
+ is @|what|.})
 
 @title[#:tag "resource"]{Windows Registry}
 
@@ -22,7 +27,8 @@
                        [#: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. @compat[section indexed-racket]
+Gets a value from the Windows registry or an @filepath{.ini}
+ file. @compat[file section indexed-racket "read"]
 
 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
@@ -31,7 +37,7 @@ The resource value is keyed on the combination of @racket[section] and
  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
+The @racket[type] argument determines how a value in the resource 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].
@@ -40,11 +46,12 @@ 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]:
+ converted to the requested @racket[type] as follows:
 
 @itemlist[
 
- @item{A @tt{REG_SZ} registry value is converted to an integer using
+ @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].}
@@ -59,9 +66,12 @@ Registry values of any format can be extracted. Values using the
 
 ]
 
-To get the ``default'' value for an entry, use a trailing backslash. For
+Resources from @filepath{.ini} files are always strings, and are
-example, the following expression gets a command line for starting a
+converted like @tt{REG_SZ} registry values.
-browser:
+
+To get the ``default'' value for a registry entry, use a trailing
+backslash. For example, the following expression gets a command line
+for starting a browser:
 
 @racketblock[
   (get-resource "HKEY_CLASSES_ROOT" 
@@ -76,17 +86,22 @@ browser:
                          [#:create-key? create-key? any/c #f])
          boolean?]{
 
-Write a value to the Windows registry. @compat[section racket]
+Write a value to the Windows registry or an @filepath{.ini}
+ file. @compat[file section racket "written"]
 
 The resource value is keyed on the combination of @racket[section] and
- @racket[entry]. If @racket[create-key?] is false, the resource entry
+ @racket[entry]. If @racket[create-key?] is false when writing to the
- must already exist, otherwise the write fails. The result is
+ registry, the resource entry must already exist, otherwise the write
- @racket[#f] if the write fails or @racket[#t] if it succeeds.
+ 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
+The @racket[type] argument determines the format of the value written to 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 inverse of the conversions for @racket[get-resource].
+
+When writing to an @filepath{.ini} file, the format is always a
+ string, independent of @racket[type].}
 

collects/tests/racket/resource.rktl

@@ -6,7 +6,8 @@
 
 (Section 'resource)
 
-(require file/resource)
+(require file/resource
+         racket/file)
 
 (let ()
   (define key "HKEY_CURRENT_USER")
@@ -52,8 +53,18 @@
   (rtest #"i\377mage" get-resource key (entry "Data") #:type 'bytes)
   (rtest 0 get-resource key (entry "Data") #:type 'integer)
 
+  ;; .ini file:
+  (let ([tmp-ini (make-temporary-file "temp~a.ini")])
+    (rtest #f get-resource "Temporary" "Stuff" #f tmp-ini)
+    (rtest #t write-resource "Temporary" "Stuff" "howdy" tmp-ini)
+    (rtest "howdy" get-resource "Temporary" "Stuff" #f tmp-ini)
+    (rtest #f get-resource "Temporary" "more" #f tmp-ini)
+    (rtest #t write-resource "Temporary" "more" 10 tmp-ini)
+    (rtest 10 get-resource "Temporary" "more" #f tmp-ini #:type 'integer)
+    (when (eq? 'windows (system-type))
+      (test "[Temporary]\r\nStuff=howdy\r\nmore=10\r\n" file->string tmp-ini)
+      (delete-file tmp-ini)))
+
   (void))
 
 (report-errs)
-
-