1#lang racket/base
2(require ffi/unsafe
3         ffi/winapi
4         "unsafe/private/win32.rkt")
5
6;; Implements MysterX's "coclass" lookup, which is deprecated
7(provide com-all-coclasses
8         com-all-controls
9         coclass->clsid
10         clsid->coclass)
11
12;; ----------------------------------------
13;; Registry
14
15(define _HKEY (_cpointer/null 'HKEY))
16
17(define KEY_QUERY_VALUE #x1)
18(define KEY_SET_VALUE   #x2)
19(define KEY_READ #x20019)
20
21(define ERROR_SUCCESS 0)
22(define ERROR_MORE_DATA 234)
23(define ERROR_NO_MORE_ITEMS 259)
24
25(define (const-hkey v)
26  (cast (bitwise-ior v (arithmetic-shift -1 32)) _intptr _HKEY))
27
28(define HKEY_CLASSES_ROOT   (const-hkey #x80000000))
29(define HKEY_CURRENT_USER   (const-hkey #x80000001))
30(define HKEY_LOCAL_MACHINE  (const-hkey #x80000002))
31(define HKEY_USERS          (const-hkey #x80000003))
32(define HKEY_CURRENT_CONFIG (const-hkey #x80000005))
33
34(define REG_SZ 1)
35(define REG_BINARY 3)
36(define REG_DWORD 4)
37
38(define-advapi RegOpenKeyExW (_hfun _HKEY _string/utf-16 _DWORD _REGSAM (hkey : (_ptr o _HKEY))
39                                    -> RegOpenKeyExW hkey))
40
41(define-advapi RegEnumKeyExW (_wfun _HKEY _DWORD _pointer (_ptr io _DWORD)
42                                    (_pointer = #f) ; reserved; must be NULL
43                                    (_pointer = #f) (_pointer = #f) ; class
44                                    (_pointer = #f) ; filetime
45                                    -> (r : _LONG)))
46(define (RegEnumKeyExW* hkey index)
47  (let loop ([sz 256])
48    (define bstr (make-bytes sz))
49    (define r (RegEnumKeyExW hkey index bstr (quotient sz 2)))
50    (cond
51     [(= r ERROR_SUCCESS) (cast bstr _pointer _string/utf-16)]
52     [(= r ERROR_MORE_DATA) (loop (* sz 2))]
53     [(= r ERROR_NO_MORE_ITEMS) #f]
54     [else (error "RegEnumKeyExW failed")])))
55
56(define-advapi RegCreateKeyExW (_wfun _HKEY _string/utf-16 (_DWORD = 0)
57                                      (_pointer = #f) ; class
58                                      _DWORD ; options
59                                      _REGSAM
60                                      _pointer ; security
61                                      (hkey : (_ptr o _HKEY))
62                                      (_ptr o _DWORD) ; disposition
63                                      -> (r : _LONG)
64                                      -> (and (= r ERROR_SUCCESS) hkey)))
65
66(define-advapi RegQueryValueExW (_wfun _HKEY _string/utf-16 (_pointer = #f)
67                                       (type : (_ptr o _DWORD))
68                                       _pointer (len : (_ptr io _DWORD))
69                                       -> (r : _LONG)
70                                       -> (if (= r ERROR_SUCCESS)
71                                              (values len type)
72                                              (values #f #f))))
73(define-advapi RegSetValueExW (_wfun _HKEY _string/utf-16 (_pointer = #f)
74                                     _DWORD _pointer _DWORD
75                                     -> (r : _LONG)
76                                     -> (= r ERROR_SUCCESS)))
77
78(define-advapi RegCloseKey (_hfun _HKEY -> RegCloseKey (void)))
79
80(define CLSIDLEN 38)
81
82(define KEY_WOW64_64KEY #x0100)
83(define KEY_WOW64_32KEY #x0200)
84
85(define wow-flags
86  (if win64?
87      (list KEY_WOW64_64KEY KEY_WOW64_32KEY)
88      (list 0)))
89
90(define (enum-keys rx include-clsid? include-name? convert all?)
91  (let wloop ([wow-flags wow-flags])
92    (cond
93     [(null? wow-flags) (if all? null #f)]
94     [else
95      (define r
96        (let ([hkey (RegOpenKeyExW HKEY_CLASSES_ROOT  "CLSID" 0
97                                   (bitwise-ior (car wow-flags) KEY_READ))])
98          (begin0
99           (let loop ([key-index 0])
100             (define sub (RegEnumKeyExW* hkey key-index))
101             (cond
102              [(not sub) (if all? null #f)]
103              [(not (= CLSIDLEN (string-length sub)))
104               ;; Bogus entry? Skip it.
105               (loop (add1 key-index))]
106              [(not (include-clsid? sub))
107               (loop (add1 key-index))]
108              [else
109               (define sub-hkey (RegOpenKeyExW hkey sub 0 KEY_READ))
110               (define buffer (make-bytes 256))
111               (define-values (len type) (RegQueryValueExW sub-hkey "" buffer (bytes-length buffer)))
112               (cond
113                [(and type
114                      (= type REG_SZ))
115                 (define name (cast buffer _pointer _string/utf-16))
116                 (if (include-name? name)
117                     (let sloop ([sub-key-index 0])
118                       (define subsub (RegEnumKeyExW* sub-hkey sub-key-index))
119                       (cond
120                        [(not subsub)
121                         (RegCloseKey sub-hkey)
122                         (loop (add1 key-index))]
123                        [(regexp-match? rx subsub)
124                         (RegCloseKey sub-hkey)
125                         (define val (convert sub name subsub))
126                         (if all?
127                             (cons val (loop (add1 key-index)))
128                             val)]
129                        [else
130                         (sloop (add1 sub-key-index))]))
131                     (begin
132                       (RegCloseKey sub-hkey)
133                       (loop (add1 key-index))))]
134                [else
135                 (RegCloseKey sub-hkey)
136                 (loop (add1 key-index))])]))
137           (RegCloseKey hkey))))
138      (cond
139       [all? (append (wloop (cdr wow-flags)) r)]
140       [r r]
141       [else (wloop (cdr wow-flags))])])))
142
143(define rx:object #rx"^(?i:InprocServer|InprocServer32|LocalServer|LocalServer32)$")
144(define rx:control #rx"^(?i:control)$")
145
146(define (com-all-coclasses)
147  (sort-and-filter
148   (enum-keys rx:object
149              (lambda (sub) #t)
150              (lambda (name) #t)
151              (lambda (sub name subsub) name)
152              #t)))
153
154(define (com-all-controls)
155  (sort-and-filter
156   (enum-keys rx:control
157              (lambda (sub) #t)
158              (lambda (name) #t)
159              (lambda (sub name subsub) name)
160              #t)))
161
162(define (sort-and-filter l)
163  (let loop ([l (sort l string-ci<?)])
164    (cond
165     [(null? l) null]
166     [(null? (cdr l)) l]
167     [(string-ci=? (car l) (cadr l))
168      (loop (cdr l))]
169     [else (cons (car l) (loop (cdr l)))])))
170
171(define (coclass->clsid coclass)
172  (enum-keys rx:object
173             (lambda (sub) #t)
174             (lambda (name) (equal? name coclass))
175             (lambda (sub name subsub) (string->guid sub))
176             #f))
177
178(define (clsid->coclass clsid)
179  (enum-keys rx:object
180             (lambda (sub)
181               (define clsid2 (string->guid sub))
182               (guid=? clsid clsid2))
183             (lambda (name) #t)
184             (lambda (sub name subsub) name)
185             #f))
186