156 lines
5.9 KiB
Scheme
156 lines
5.9 KiB
Scheme
;;; windows.ms
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
(if (windows?)
|
|
(begin
|
|
(mat registry
|
|
(error? (get-registry))
|
|
(error? (get-registry 1 2))
|
|
(error? (put-registry! "hi"))
|
|
(error? (put-registry! 1))
|
|
(error? (put-registry! 1 2 3))
|
|
(error? (remove-registry!))
|
|
(error? (remove-registry! 1 2))
|
|
(error? (get-registry 'pooh))
|
|
(error? (put-registry! "hi" 3))
|
|
(error? (put-registry! 3 "hi"))
|
|
(error? (remove-registry! '(a b c)))
|
|
(error? (get-registry "bogus, is it not?"))
|
|
|
|
(not (get-registry "hkey_current_user\\CSmat\\FratRat"))
|
|
(eq? (put-registry! "hkey_current_user\\CSmat\\FratRat" "7233259") (void))
|
|
(equal? (get-registry "hkey_current_user\\CSmat\\FratRat") "7233259")
|
|
(equal? (get-registry "HkEy_CuRrEnT_UsER\\CSmat\\FratRat") "7233259")
|
|
(eq? (remove-registry! "hkey_current_user\\CSmat\\FratRat") (void))
|
|
(error? (remove-registry! "hkey_current_user\\CSmat\\FratRat"))
|
|
(not (get-registry "hkey_current_user\\CSmat\\FratRat"))
|
|
|
|
(eq? (put-registry! "hkey_current_user\\CSmat\\North\\South" "east") (void))
|
|
(equal? (get-registry "hkey_current_user\\CSmat\\North\\South") "east")
|
|
(eq? (remove-registry! "hkey_current_user\\CSmat\\North") (void))
|
|
(not (get-registry "hkey_current_user\\CSmat\\North\\South"))
|
|
|
|
(eq? (put-registry! "hkey_current_user\\CSmat\\Apple\\Orange\\Banana" "kumquat") (void))
|
|
(equal? (get-registry "hkey_current_user\\CSmat\\Apple\\Orange\\Banana") "kumquat")
|
|
(error? (remove-registry! "hkey_current_user\\CSmat\\Apple"))
|
|
(equal? (get-registry "hkey_current_user\\CSmat\\Apple\\Orange\\Banana") "kumquat")
|
|
(eq? (remove-registry! "hkey_current_user\\CSmat\\Apple\\Orange\\Banana") (void))
|
|
(not (get-registry "hkey_current_user\\CSmat\\Apple\\Orange\\Banana"))
|
|
(error? (remove-registry! "hkey_current_user\\CSmat\\Apple"))
|
|
(eq? (remove-registry! "hkey_current_user\\CSmat\\Apple\\Orange") (void))
|
|
(eq? (remove-registry! "hkey_current_user\\CSmat\\Apple") (void))
|
|
(not (get-registry "hkey_current_user\\CSmat\\Apple\\Orange\\Banana"))
|
|
)
|
|
)
|
|
(begin ; provide expected errors
|
|
(set! bad-arg-count
|
|
(lambda (who . args)
|
|
(if (#%$suppress-primitive-inlining)
|
|
(errorf #f "incorrect number of arguments to #<procedure ~a>" who)
|
|
(errorf #f "incorrect argument count in call ~s" (cons who args)))))
|
|
(mat registry
|
|
(error? (bad-arg-count 'get-registry))
|
|
(error? (bad-arg-count 'get-registry 1 2))
|
|
(error? (bad-arg-count 'put-registry! "hi"))
|
|
(error? (bad-arg-count 'put-registry! 1))
|
|
(error? (bad-arg-count 'put-registry! 1 2 3))
|
|
(error? (bad-arg-count 'remove-registry!))
|
|
(error? (bad-arg-count 'remove-registry! 1 2))
|
|
(error? (errorf 'get-registry "pooh is not a string"))
|
|
(error? (errorf 'put-registry! "3 is not a string"))
|
|
(error? (errorf 'put-registry! "3 is not a string"))
|
|
(error? (errorf 'remove-registry! "(a b c) is not a string"))
|
|
(error? (errorf 'get-registry "invalid registry key \"bogus, is it not?\""))
|
|
(error? (errorf 'remove-registry! "cannot remove hkey_current_user\\CSmat\\FratRat (not found)"))
|
|
(error? (errorf 'remove-registry! "cannot remove hkey_current_user\\CSmat\\Apple (insufficient permission or subkeys exist)"))
|
|
(error? (errorf 'remove-registry! "cannot remove hkey_current_user\\CSmat\\Apple (insufficient permission or subkeys exist)"))
|
|
)
|
|
))
|
|
|
|
(when (windows?)
|
|
(mat multibyte
|
|
(guard (c [(equal? (condition-message c) "invalid code page ~s")])
|
|
(string->multibyte -1 "hello")
|
|
#t)
|
|
(guard (c [(equal? (condition-message c) "invalid code page ~s")])
|
|
(string->multibyte 'cp-what? "hello")
|
|
#t)
|
|
(guard (c [(equal? (condition-message c) "invalid code page ~s")])
|
|
(multibyte->string -1 #vu8(#x61 #x62))
|
|
#t)
|
|
(guard (c [(equal? (condition-message c) "invalid code page ~s")])
|
|
(multibyte->string 'cp-not! #vu8(#x61 #x62))
|
|
#t)
|
|
(guard (c [(equal? (condition-message c) "~s is not a bytevector")])
|
|
(multibyte->string 'cp-acp "hello")
|
|
#t)
|
|
(guard (c [(equal? (condition-message c) "~s is not a string")])
|
|
(string->multibyte 'cp-acp 'hello)
|
|
#t)
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->utf8 str)])
|
|
(equal? (multibyte->string 'cp-utf8 bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")
|
|
(f "hel\x0;\x3bb;lo\n")))
|
|
(let ()
|
|
(define (g str)
|
|
(let ([bv (string->multibyte 'cp-utf8 str)])
|
|
(equal? (utf8->string bv) str)))
|
|
(and
|
|
(g "hello\n")
|
|
(g "hel\x0;lo\n")
|
|
(g "hel\x0;\x3bb;lo\n")))
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->multibyte 'cp-acp str)])
|
|
(equal? (multibyte->string 'cp-acp bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")))
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->multibyte 'cp-oemcp str)])
|
|
(equal? (multibyte->string 'cp-oemcp bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")))
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->multibyte 'cp-thread-acp str)])
|
|
(equal? (multibyte->string 'cp-thread-acp bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")))
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->multibyte 'cp-utf7 str)])
|
|
(equal? (multibyte->string 'cp-utf7 bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")
|
|
(f "hel\x0;\x3bb;lo\n")))
|
|
(let ()
|
|
(define (f str)
|
|
(let ([bv (string->multibyte 'cp-utf8 str)])
|
|
(equal? (multibyte->string 'cp-utf8 bv) str)))
|
|
(and
|
|
(f "hello\n")
|
|
(f "hel\x0;lo\n")
|
|
(f "hel\x0;\x3bb;lo\n")))
|
|
))
|