From a9389dab40867534ce65f2624bd71b21337d791c Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 18 Oct 2004 04:12:03 +0000
Subject: [PATCH] Add support for Win32 registry access.

---
 v7/src/runtime/make.scm           |   7 +-
 v7/src/runtime/runtime.pkg        |  27 +-
 v7/src/runtime/win32-registry.scm | 427 ++++++++++++++++++++++++++++++
 3 files changed, 457 insertions(+), 4 deletions(-)
 create mode 100644 v7/src/runtime/win32-registry.scm

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index a643922f5..f5bf1115f 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.92 2004/01/15 20:58:36 cph Exp $
+$Id: make.scm,v 14.93 2004/10/18 04:11:41 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
@@ -218,7 +218,7 @@ USA.
 
 (define (package-initialization-sequence specs)
   (let loop ((specs specs))
-    (if (not (null? specs))
+    (if (pair? specs)
 	(let ((spec (car specs)))
 	  (if (or (not (pair? spec))
 		  (symbol? (car spec)))
@@ -522,6 +522,9 @@ USA.
    ;; More debugging
    ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)
    (RUNTIME URL)))
+
+(if (eq? os-name 'NT)
+    (package-initialize '(RUNTIME WIN32-REGISTRY) 'INITIALIZE-PACKAGE! #f))
 
 (let ((obj (file->object "site" #t #t)))
   (if obj
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 6836707b1..7a4668ae9 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.498 2004/10/06 18:46:55 cph Exp $
+$Id: runtime.pkg,v 14.499 2004/10/18 04:11:54 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -4707,4 +4707,27 @@ USA.
 	  pgsql-result-status
 	  pgsql-tuples-ok
 	  poll-pgsql-conn
-	  poll-pgsql-reset))
\ No newline at end of file
+	  poll-pgsql-reset))
+
+
+(os-type-case
+ ((nt)
+  (define-package (runtime win32-registry)
+    (files "win32-registry")
+    (parent (runtime))
+    (export ()
+	    win32-registry/add-subkey
+	    win32-registry/delete-subkey
+	    win32-registry/delete-value
+	    win32-registry/get-value
+	    win32-registry/key-full-name
+	    win32-registry/key-name
+	    win32-registry/key-parent
+	    win32-registry/key?
+	    win32-registry/open-key
+	    win32-registry/set-value
+	    win32-registry/subkey
+	    win32-registry/subkeys
+	    win32-registry/value-names
+	    win32/expand-environment-strings)
+    (initialization (initialize-package!)))))
\ No newline at end of file
diff --git a/v7/src/runtime/win32-registry.scm b/v7/src/runtime/win32-registry.scm
new file mode 100644
index 000000000..42d600a64
--- /dev/null
+++ b/v7/src/runtime/win32-registry.scm
@@ -0,0 +1,427 @@
+#| -*-Scheme-*-
+
+$Id: win32-registry.scm,v 1.1 2004/10/18 04:12:03 cph Exp $
+
+Copyright 1999,2004 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; Win32 Registry Operations
+;;; package: (runtime win32-registry)
+
+(declare (usual-integrations))
+
+(define (win32-registry/open-key name mode)
+  (let ((key
+	 (let loop ((name name))
+	   (receive (prefix name) (split-registry-key-name name)
+	     (if prefix
+		 (let ((parent (loop prefix)))
+		   (and parent
+			(get-subkey parent name
+				    (eq? 'CREATE-IF-NEEDED mode))))
+		 (get-root-key name 'WIN32-REGISTRY/OPEN-KEY))))))
+    (if (and (not key) (eq? 'MUST-EXIST mode))
+	(error "Unable to open registry key:" name))
+    key))
+
+(define (split-registry-key-name name)
+  (let ((slash (string-find-previous-char name #\\)))
+    (if slash
+	(values (string-head name slash)
+		(string-tail name (fix:+ slash 1)))
+	(values #f name))))
+
+(define (get-root-key name procedure-name)
+  (let loop ((keys open-keys))
+    (if (not (pair? keys))
+	(error:bad-range-argument name procedure-name))
+    (if (string-ci=? name (registry-key-name (car keys)))
+	(car keys)
+	(loop (cdr keys)))))
+
+(define (get-subkey parent name create?)
+  (or (find-subkey parent name)
+      (and create?
+	   (let ((key (%make-registry-key parent name #f)))
+	     (open-registry-handle win32-create-registry-key key)
+	     (add-subkey! parent name key)
+	     key))))
+
+(define (win32-registry/add-subkey parent name)
+  (guarantee-registry-key parent 'WIN32-REGISTRY/ADD-SUBKEY)
+  (get-subkey parent name #t))
+
+(define (win32-registry/delete-subkey parent name)
+  (guarantee-registry-key parent 'WIN32-REGISTRY/DELETE-SUBKEY)
+  (win32-delete-registry-key (guarantee-handle parent) name)
+  (delete-subkey! parent name))
+
+(define (win32-registry/key-name key)
+  (guarantee-registry-key key 'WIN32-REGISTRY/KEY-NAME)
+  (registry-key-name key))
+
+(define (win32-registry/key-full-name key)
+  (guarantee-registry-key key 'WIN32-REGISTRY/KEY-FULL-NAME)
+  (if (registry-key-parent key)
+      (string-append (win32-registry/key-name (registry-key-parent key))
+		     "\\"
+		     (registry-key-name key))
+      (registry-key-name key)))
+
+(define (win32-registry/key-parent key)
+  (guarantee-registry-key key 'WIN32-REGISTRY/KEY-PARENT)
+  (registry-key-parent key))
+
+(define (win32-registry/subkeys key)
+  (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEYS)
+  (guarantee-subkeys key)
+  (map (lambda (k.n) (guarantee-subkey key k.n))
+       (registry-key-subkeys key)))
+
+(define (win32-registry/subkey key name)
+  (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEY)
+  (find-subkey key name))
+
+(define (win32-registry/value-names key)
+  (guarantee-registry-key key 'WIN32-REGISTRY/VALUE-NAMES)
+  (guarantee-values key)
+  (map registry-value-name (registry-key-values key)))
+
+(define (win32-registry/get-value key name)
+  (guarantee-registry-key key 'WIN32-REGISTRY/GET-VALUE)
+  (let ((data (win32-query-registry-value (guarantee-handle key) name)))
+    (if data
+	(values (number->value-type (car data)) (cdr data))
+	(values #f #f))))
+
+(define (win32-registry/set-value key name type data)
+  (guarantee-registry-key key 'WIN32-REGISTRY/SET-VALUE)
+  (win32-set-registry-value (guarantee-handle key) name
+			    (value-type->number type) data)
+  (add-value! key name type))
+
+(define (win32-registry/delete-value key name)
+  (guarantee-registry-key key 'WIN32-REGISTRY/DELETE-VALUE)
+  (win32-delete-registry-value (guarantee-handle key) name)
+  (delete-value! key name))
+
+(define (win32/expand-environment-strings string)
+  (let ((result (make-string (win32-expand-environment-strings string ""))))
+    (win32-expand-environment-strings string result)
+    (let ((nul (string-find-next-char result #\nul)))
+      (if nul
+	  (string-head result nul)
+	  result))))
+
+;;;; Data Structures
+
+(define-structure (registry-key
+		   (constructor %make-registry-key (parent name handle))
+		   (predicate win32-registry/key?)
+		   (print-procedure
+		    (standard-unparser-method 'REGISTRY-KEY
+		      (lambda (key port)
+			(write-char #\space port)
+			(write (registry-key-name key) port)))))
+  (name #f read-only #t)
+  (parent #f read-only #t)
+  (handle #f)
+  (subkeys 'UNKNOWN)
+  (values 'UNKNOWN))
+
+(define (guarantee-registry-key object procedure)
+  (if (not (win32-registry/key? object))
+      (error:wrong-type-argument object "registry key" procedure)))
+
+(define (guarantee-handle key)
+  (if (eq? 'DELETED (registry-key-handle key))
+      (error "Registry key has been deleted:" key))
+  (or (registry-key-handle key)
+      (begin
+	(open-registry-handle win32-open-registry-key key)
+	(or (registry-key-handle key)
+	    (error "Registry handle no longer exists:" key)))))
+
+(define-structure (registry-value
+		   (print-procedure
+		    (standard-unparser-method 'REGISTRY-VALUE
+		      (lambda (key port)
+			(write-char #\space port)
+			(write (registry-value-name key) port)))))
+  (name #f read-only #t)
+  (type #f))
+
+;;;; Subkey Manipulation
+
+(define (find-subkey parent name)
+  (guarantee-subkeys parent)
+  (let loop ((subkeys (registry-key-subkeys parent)))
+    (if (pair? subkeys)
+	(if (string-ci=? name (%weak-cdr (car subkeys)))
+	    (guarantee-subkey parent (car subkeys))
+	    (loop (cdr subkeys)))
+	#f)))
+
+(define (guarantee-subkeys key)
+  (if (eq? 'UNKNOWN (registry-key-subkeys key))
+      (set-registry-key-subkeys! key
+				 (map (lambda (key)
+					(%weak-cons key
+						    (registry-key-name key)))
+				      (generate-subkeys key)))))
+
+(define (generate-subkeys key)
+  (enumerate key
+	     win32-enumerate-registry-key
+	     1
+	     (lambda (v) v)
+	     (lambda (name v) v (%make-registry-key key name #f))))
+
+(define (guarantee-subkey parent k.n)
+  (or (%weak-car k.n)
+      (let ((key (%make-registry-key parent (%weak-cdr k.n) #f)))
+	(%weak-set-car! k.n key)
+	key)))
+
+(define (add-subkey! parent name key)
+  (if (not (eq? 'UNKNOWN (registry-key-subkeys parent)))
+      (let loop ((subkeys (registry-key-subkeys parent)))
+	(if (pair? subkeys)
+	    (if (not (string-ci=? name (%weak-cdr (car subkeys))))
+		(loop (cdr subkeys)))
+	    (set-registry-key-subkeys!
+	     parent
+	     (cons (%weak-cons key name) (registry-key-subkeys parent)))))))
+
+(define (delete-subkey! parent name)
+  (if (not (eq? 'UNKNOWN (registry-key-subkeys parent)))
+      (let loop ((subkeys (registry-key-subkeys parent)) (prev #f))
+	(if (pair? subkeys)
+	    (if (string-ci=? name (%weak-cdr (car subkeys)))
+		(without-interrupts
+		 (lambda ()
+		   (let ((key (%weak-car (car subkeys))))
+		     (if key
+			 (begin
+			   (close-registry-handle key)
+			   (set-registry-key-handle! key 'DELETED))))
+		   (if prev
+		       (set-cdr! prev (cdr subkeys))
+		       (set-registry-key-subkeys! parent (cdr subkeys)))))
+		(loop (cdr subkeys) subkeys))))))
+
+;;;; Value Manipulation
+
+(define (guarantee-values key)
+  (if (eq? 'UNKNOWN (registry-key-values key))
+      (set-registry-key-values! key (generate-values key))))
+
+(define (generate-values key)
+  (enumerate key
+	     (lambda (h i b) (win32-enumerate-registry-value h i b #f))
+	     3
+	     (lambda (v) (vector-ref v 0))
+	     (lambda (name v)
+	       (make-registry-value name
+				    (number->value-type (vector-ref v 1))))))
+
+(define (find-value key name)
+  (guarantee-values key)
+  (let loop ((vs (registry-key-values key)))
+    (if (pair? vs)
+	(if (string-ci=? name (registry-value-name (car vs)))
+	    (car vs)
+	    (loop (cdr vs)))
+	#f)))
+
+(define (add-value! key name type)
+  (if (not (eq? 'UNKNOWN (registry-key-values key)))
+      (let loop ((vs (registry-key-values key)))
+	(if (pair? vs)
+	    (if (string-ci=? name (registry-value-name (car vs)))
+		(set-registry-value-type! (car vs) type)
+		(loop (cdr vs)))
+	    (set-registry-key-values!
+	     key
+	     (cons (make-registry-value name type)
+		   (registry-key-values key)))))))
+
+(define (delete-value! key name)
+  (if (not (eq? 'UNKNOWN (registry-key-values key)))
+      (let loop ((vs (registry-key-values key)) (prev #f))
+	(if (pair? vs)
+	    (if (string-ci=? name (registry-value-name (car vs)))
+		(if prev
+		    (set-cdr! prev (cdr vs))
+		    (set-registry-key-values! key (cdr vs)))
+		(loop (cdr vs) vs))))))
+
+;;;; Low-level Handle Tracking
+
+(define (open-registry-handle procedure key)
+  (let ((p (system-pair-cons (ucode-type weak-cons) #f #f)))
+    (dynamic-wind
+     (lambda () unspecific)
+     (lambda ()
+       (let ((v
+	      (procedure (guarantee-handle (registry-key-parent key))
+			 (registry-key-name key)
+			 p)))
+	 (if (%weak-cdr p)
+	     (without-interrupts
+	      (lambda ()
+		(set-registry-key-handle! key (%weak-cdr p))
+		(set-cdr! open-handles-list
+			  (cons p (cdr open-handles-list)))
+		(%weak-set-car! p key))))
+	 v))
+     (lambda ()
+       (if (and (%weak-cdr p) (not (%weak-car p)))
+	   (close-registry-handle key))))))
+
+(define (close-registry-handle key)
+  (let loop ((l1 open-handles-list) (l2 (cdr open-handles-list)))
+    (if (pair? l2)
+	(if (eq? key (%weak-car (car l2)))
+	    (without-interrupts
+	     (lambda ()
+	       (win32-close-registry-key (%weak-cdr (car l2)))
+	       (set-registry-key-handle! key #f)
+	       (set-cdr! l1 (cdr l2))))
+	    (loop l2 (cdr l2))))))
+
+(define open-keys)
+(define open-handles-list)
+
+(define (initialize-package!)
+  (set! open-keys
+	(map (lambda (n.h)
+	       (%make-registry-key #f (car n.h) (cdr n.h)))
+	     (win32-predefined-registry-keys)))
+  (set! open-handles-list (list 'OPEN-HANDLES-LIST))
+  (add-gc-daemon! close-lost-open-keys-daemon))
+
+(define (close-lost-open-keys-daemon)
+  (let loop ((l1 open-handles-list) (l2 (cdr open-handles-list)))
+    (if (pair? l2)
+	(if (%weak-car (car l2))
+	    (loop l2 (cdr l2))
+	    (begin
+	      (win32-close-registry-key (%weak-cdr (car l2)))
+	      (set-cdr! l1 (cdr l2))
+	      (loop l1 (cdr l1)))))))
+
+;;;; Microcode Interface
+
+(define-primitives
+  (win32-predefined-registry-keys 0)
+  (win32-open-registry-key 3)
+  (win32-create-registry-key 3)
+  (win32-close-registry-key 1)
+  (win32-set-registry-value 4)
+  (win32-delete-registry-value 2)
+  (win32-delete-registry-key 2)
+  (win32-enumerate-registry-key 3)
+  (win32-query-info-registry-key 1)
+  (win32-enumerate-registry-value 4)
+  (win32-query-info-registry-value 2)
+  (win32-query-registry-value 2)
+  (win32-expand-environment-strings 2))
+
+(define-structure (registry-key-info (type vector)
+				     (conc-name registry-key-info/))
+  (n-subkeys #f read-only #t)
+  (max-subkey-name-length #f read-only #t)
+  (n-values #f read-only #t)
+  (max-value-name-name #f read-only #t)
+  (max-value-length #f read-only #t))
+
+;;; Value types:
+(define value-types
+  '#((REG_NONE)				; No value type
+     (REG_SZ)				; Unicode null-terminated string
+     (REG_EXPAND_SZ)			; Unicode null-terminated
+					; string (with environment
+					; variable references)
+     (REG_BINARY)			; Free form binary
+     (REG_DWORD REG_DWORD_LITTLE_ENDIAN) ; 32-bit number
+     (REG_DWORD_BIG_ENDIAN)		; 32-bit number
+     (REG_LINK)				; Symbolic Link (unicode)
+     (REG_MULTI_SZ)			; Multiple Unicode strings
+     (REG_RESOURCE_LIST)		; Resource list in the resource map
+     (REG_FULL_RESOURCE_DESCRIPTOR)	; Resource list in the
+					; hardware description
+     (REG_RESOURCE_REQUIREMENTS_LIST)
+     ))
+
+(define (number->value-type n)
+  (if (and (exact-nonnegative-integer? n)
+	   (< n (vector-length value-types)))
+      (car (vector-ref value-types n))
+      n))
+
+(define (value-type->number type)
+  (cond ((symbol? type)
+	 (let ((n (vector-length value-types)))
+	   (let loop ((i 0))
+	     (if (fix:= i n)
+		 (error:bad-range-argument type #f))
+	     (if (memq type (vector-ref value-types i))
+		 i
+		 (loop (fix:+ i 1))))))
+	((and (exact-nonnegative-integer? type)
+	      (< type #x100000000))
+	 type)
+	(else
+	 (error:wrong-type-argument type "registry value type" #f))))
+
+;;;; Utilities
+
+(define (burst-string string delimiter)
+  (let ((end (string-length string)))
+    (let loop ((start 0) (result '()))
+      (let ((index (substring-find-next-char string start end delimiter)))
+	(if index
+	    (loop (fix:+ index 1)
+		  (cons (substring string start index) result))
+	    (list->vector
+	     (reverse! (cons (substring string start end) result))))))))
+
+(define-integrable (%weak-cons a d)
+  (system-pair-cons (ucode-type weak-cons) a d))
+
+(define-integrable (%weak-car p) (system-pair-car p))
+(define-integrable (%weak-set-car! p a) (system-pair-set-car! p a))
+(define-integrable (%weak-cdr p) (system-pair-cdr p))
+(define-integrable (%weak-set-cdr! p d) (system-pair-set-cdr! p d))
+
+(define (enumerate key enumerator length-index get-length make-result)
+  (let* ((handle (guarantee-handle key))
+	 (buffer-length
+	  (vector-ref (win32-query-info-registry-key handle) length-index))
+	 (buffer (make-string buffer-length)))
+    (let loop ((index 0) (vs '()))
+      (let ((v (enumerator handle index buffer)))
+	(if v
+	    (loop (fix:+ index 1)
+		  (cons (make-result (string-head buffer (get-length v)) v)
+			vs))
+	    vs)))))
\ No newline at end of file
-- 
2.25.1