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