This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/mats/windows.ms

156 lines
5.9 KiB
Scheme
Raw Normal View History

2022-07-29 15:12:07 +02:00
;;; 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")))
))