1;; 2;; testing os.windows 3;; 4 5(use gauche.test) 6(use gauche.uvector) 7 8(cond-expand 9 [gauche.os.windows 10 11(test-start "windows") 12(use os.windows) 13(test-module 'os.windows) 14 15(define hin (sys-get-std-handle STD_INPUT_HANDLE)) 16(define hout (sys-get-std-handle STD_OUTPUT_HANDLE)) 17(define (redirected-handle? hdl) 18 (guard (exc ((<system-error> exc) #t)) 19 (sys-get-console-mode hdl) #f)) 20(define rin (redirected-handle? hin)) 21(define rout (redirected-handle? hout)) 22 23(test-section "Console procedures") 24(test* "sys-alloc-console" (test-error <system-error>) (sys-alloc-console)) 25;; This test causes a program termination. 26;(test* "sys-free-console" (undefined) (sys-free-console)) 27;(test* "sys-generate-console-ctrl-event 1" (undefined) (sys-generate-console-ctrl-event CTRL_C_EVENT 0)) 28;(test* "sys-generate-console-ctrl-event 2" (undefined) (sys-generate-console-ctrl-event CTRL_BREAK_EVENT 0)) 29 30(test-section "Console Buffers") 31(unless rout 32 (let* ((cbuf1 (sys-create-console-screen-buffer (logior GENERIC_READ GENERIC_WRITE) 0 #f)) 33 (cbuf2 (sys-get-std-handle STD_OUTPUT_HANDLE))) 34 (test* "sys-create-console-screen-buffer" '<win:handle> cbuf1 35 (lambda (expected result) (equal? expected (class-name (class-of result))))) 36 (test* "sys-set-console-active-screen-buffer 1" (undefined) (sys-set-console-active-screen-buffer cbuf1)) 37 (test* "sys-set-console-active-screen-buffer 2" (undefined) (sys-set-console-active-screen-buffer cbuf2)) 38 (test* "sys-scroll-console-screen-buffer" (undefined) 39 (sys-scroll-console-screen-buffer cbuf2 (s16vector 0 0 4 2) #f 5 0 0)) 40 )) 41 42(test-section "Console Code Page") 43(let* ((cp1 (sys-get-console-cp)) 44 (cp2 (sys-get-console-output-cp))) 45 (test* "sys-set-console-cp" (undefined) (sys-set-console-cp 65001)) 46 (test* "sys-set-console-output-cp" (undefined) (sys-set-console-output-cp 65001)) 47 (test* "sys-get-console-cp" 65001 (sys-get-console-cp)) 48 (test* "sys-get-console-output-cp" 65001 (sys-get-console-output-cp)) 49 (sys-set-console-cp cp1) 50 (sys-set-console-output-cp cp2) 51 ) 52 53(test-section "Console Cursor Info") 54(unless rout 55 (receive (csize cvisible) (sys-get-console-cursor-info hout) 56 (test* "sys-set-console-cursor-info" (undefined) (sys-set-console-cursor-info hout 1 #f)) 57 (test* "sys-get-console-cursor-info" '(1 #f) (values->list (sys-get-console-cursor-info hout))) 58 (sys-set-console-cursor-info hout csize cvisible) 59 ) 60 ;; This test causes a cursor position change. 61 ;(test* "sys-set-console-cursor-position" (undefined) (sys-set-console-cursor-position hout 0 0)) 62 ;(exit) 63 ) 64 65(test-section "Console Mode") 66(unless (or rin rout) 67 (let* ((cmode1 (sys-get-console-mode hin)) 68 (cmode2 (sys-get-console-mode hout))) 69 (test* "sys-set-console-mode 1" (undefined) (sys-set-console-mode hin ENABLE_LINE_INPUT)) 70 (test* "sys-set-console-mode 2" (undefined) (sys-set-console-mode hout ENABLE_PROCESSED_OUTPUT)) 71 (test* "sys-get-console-mode 1" ENABLE_LINE_INPUT (sys-get-console-mode hin)) 72 (test* "sys-get-console-mode 2" ENABLE_PROCESSED_OUTPUT (sys-get-console-mode hout)) 73 (sys-set-console-mode hin cmode1) 74 (sys-set-console-mode hout cmode2) 75 )) 76 77(test-section "Console Screen Buffer Info") 78(unless rout 79 (let1 cinfo (sys-get-console-screen-buffer-info hout) 80 (test* "sys-get-console-screen-buffer-info" '<win:console-screen-buffer-info> cinfo 81 (lambda (expected result) (equal? expected (class-name (class-of result))))) 82 (test-log "cinfo.size.x = ~a" (~ cinfo 'size.x)) 83 (test-log "cinfo.size.y = ~a" (~ cinfo 'size.y)) 84 (test-log "cinfo.cursor-position.x = ~a" (~ cinfo 'cursor-position.x)) 85 (test-log "cinfo.cursor-position.y = ~a" (~ cinfo 'cursor-position.y)) 86 (test-log "cinfo.attributes = ~a" (~ cinfo 'attributes)) 87 (test-log "window.left = ~a" (~ cinfo 'window.left)) 88 (test-log "window.top = ~a" (~ cinfo 'window.top)) 89 (test-log "window.right = ~a" (~ cinfo 'window.right)) 90 (test-log "window.bottom = ~a" (~ cinfo 'window.bottom)) 91 (test-log "maximum-window-size.x = ~a" (~ cinfo 'maximum-window-size.x)) 92 (test-log "maximum-window-size.y = ~a" (~ cinfo 'maximum-window-size.y)) 93 ) 94 (let1 wsize (values->list (sys-get-largest-console-window-size hout)) 95 (test* "sys-get-largest-console-window-size" 2 wsize 96 (lambda (expected result) (equal? expected (length result)))) 97 (test-log "largest-console-window-width = ~a" (car wsize)) 98 (test-log "largest-console-window-height = ~a" (cadr wsize)) 99 ) 100 ;; This test causes a screen buffer size change. 101 ;(test* "sys-set-screen-buffer-size" (undefined) (sys-set-screen-buffer-size hout 80 25)) 102 ;(exit) 103 ) 104 105(test-section "Console input/output") 106(unless rin 107 (let1 evnum (sys-get-number-of-console-input-events hin) 108 (test* "sys-get-number-of-console-input-events" '<integer> evnum 109 (lambda (expected result) (equal? expected (class-name (class-of result))))) 110 (test-log "number-of-console-input-events = ~a" evnum) 111 ) 112 (let1 mbnum (sys-get-number-of-console-mouse-buttons) 113 (test* "sys-get-number-of-console-mouse-buttons" '<integer> mbnum 114 (lambda (expected result) (equal? expected (class-name (class-of result))))) 115 (test-log "number-of-console-mouse-buttons = ~a" mbnum) 116 )) 117 118(define (event-loop-test) 119 (define KEY_EVENT #x01) 120 (define MOUSE_EVENT #x02) 121 (define WINDOW_BUFFER_SIZE_EVENT #x04) 122 (define MENU_EVENT #x08) 123 (define FOCUS_EVENT #x10) 124 (let* ((hin (sys-get-std-handle STD_INPUT_HANDLE)) 125 (cmode (sys-get-console-mode hin))) 126 (sys-set-console-mode hin (logior ENABLE_WINDOW_INPUT ENABLE_MOUSE_INPUT)) 127 (test-log "Event loop test (Hit [esc] key to exit)") 128 (let loop ((done #f) (irlist (sys-peek-console-input hin))) 129 (unless (null? irlist) 130 (sys-read-console-input hin)) 131 (any 132 (lambda (ir) 133 (let1 evt (~ ir 'event-type) 134 (cond 135 ((= evt KEY_EVENT) 136 (let ((kdown (~ ir 'key.down)) 137 (rept (~ ir 'key.repeat-count)) 138 (vk (~ ir 'key.virtual-key-code)) 139 (vs (~ ir 'key.virtual-scan-code)) 140 (ch (~ ir 'key.unicode-char)) 141 (asc (~ ir 'key.ascii-char)) 142 (ctls (~ ir 'key.control-key-state))) 143 (test-log "key : kdown=~a repeat=~a vk=~a vs=~a ch=~a asc=~a ctrlkeys=~a" kdown rept vk vs ch asc ctls) 144 (if (and kdown (= vk 27)) 145 (set! done #t)))) 146 ((= evt MOUSE_EVENT) 147 (let ((x (~ ir 'mouse.x)) 148 (y (~ ir 'mouse.y)) 149 (btn (~ ir 'mouse.button-state)) 150 (ctls (~ ir 'mouse.control-key-state)) 151 (evflg (~ ir 'mouse.event-flags))) 152 (test-log "mouse : x=~a y=~a button=~a ctrlkeys=~a eventflags=~a" x y btn ctls evflg))) 153 ((= evt WINDOW_BUFFER_SIZE_EVENT) 154 (let ((x (~ ir 'window-buffer-size.x)) 155 (y (~ ir 'window-buffer-size.y))) 156 (test-log "window-buffer-size : x=~a y=~a" x y))) 157 ((= evt MENU_EVENT) 158 (let ((id (~ ir 'menu.command-id))) 159 (test-log "menu : menu-command-id=~a" id))) 160 ((= evt FOCUS_EVENT) 161 (let ((fcs (~ ir 'focus.set-focus))) 162 (test-log "focus : set-focus=~a" fcs))) 163 )) 164 done) 165 irlist) 166 (when (not done) 167 (sys-nanosleep (* 100 1000000)) ; 100msec 168 (loop #f (sys-peek-console-input hin)))) 169 (sys-set-console-mode hin cmode))) 170;; This test causes an event loop. 171;(event-loop-test) 172;(exit) 173 174(define (keyboard-input-test) 175 (let* ((hin (sys-get-std-handle STD_INPUT_HANDLE)) 176 (cmode (sys-get-console-mode hin)) 177 (rbuf (make-u8vector 2 0)) 178 (rnum 0)) 179 (sys-set-console-mode hin 0) 180 (set! rnum (sys-read-console hin rbuf)) 181 (test* "sys-read-console" '<integer> rnum 182 (lambda (expected result) (equal? expected (class-name (class-of result))))) 183 (test-log "read-buffer=~a" (map (cut format "~2,'0Xh" <>) (u8vector->list rbuf))) 184 (test-log "number of read characters=~a" rnum) 185 (sys-set-console-mode hin cmode))) 186;; This test causes a keyboard input waiting. 187;(keyboard-input-test) 188;(exit) 189 190(unless rout 191 (let1 rbuf (sys-read-console-output hout (make-u32vector 6 0) 3 2 0 0 (s16vector 0 3 2 4)) 192 (test* "sys-read-console-output" '<u32vector> rbuf 193 (lambda (expected result) (equal? expected (class-name (class-of result))))) 194 (test-log "read-buffer=~a" (map (cut format "~8,'0Xh" <>) (u32vector->list rbuf))) 195 ) 196 197 (let* ((rbuf (make-u16vector 6 0)) 198 (rnum (sys-read-console-output-attribute hout rbuf 0 3))) 199 (test* "sys-read-console-output-attribute" '<integer> rnum 200 (lambda (expected result) (equal? expected (class-name (class-of result))))) 201 (test-log "read-attribute-buffer=~a" (map (cut format "~4,'0Xh" <>) (u16vector->list rbuf))) 202 (test-log "number of read attributes=~a" rnum) 203 ) 204 205 (let1 rstr (sys-read-console-output-character hout 6 0 3) 206 (test* "sys-read-console-output-character 1" '<string> rstr 207 (lambda (expected result) (equal? expected (class-name (class-of result))))) 208 (test-log "read-string=\"~a\"" rstr) 209 ) 210 (let1 rstr (sys-read-console-output-character hout 65535 0 3) 211 (test* "sys-read-console-output-character 2" '<string> rstr 212 (lambda (expected result) (equal? expected (class-name (class-of result))))) 213 ) 214 (test* "sys-read-console-output-character 3" (test-error <error>) 215 (sys-read-console-output-character hout 65536 0 3)) 216 217 (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 10)) 218 (test-log "color=10") 219 (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 7)) 220 (test-log "color=7") 221 222 ;; This test causes a window size change. 223 ;(test* "sys-set-console-window-info" (undefined) (sys-set-console-window-info hout #t (s16vector 0 0 10 10))) 224 ;(exit) 225 226 (let1 wnum (sys-write-console hout "abcde fghij klmno\n") 227 (test* "sys-write-console 1" '<integer> wnum 228 (lambda (expected result) (equal? expected (class-name (class-of result))))) 229 (test-log "number of write characters=~a" wnum) 230 ) 231 (let1 wnum (sys-write-console hout (string-copy "aaaaa" 0 1)) 232 (test* "sys-write-console 2" '<integer> wnum 233 (lambda (expected result) (equal? expected (class-name (class-of result))))) 234 (test-log "number of write characters=~a" wnum) 235 ) 236 237 (let1 wnum (sys-write-console-output-character hout "ABC" 0 0) 238 (test* "sys-write-console-output-character 1" '<integer> wnum 239 (lambda (expected result) (equal? expected (class-name (class-of result))))) 240 (test-log "number of write characters=~a" wnum) 241 ) 242 (let1 wnum (sys-write-console-output-character hout (string-copy "aaaaa" 0 1) 0 1) 243 (test* "sys-write-console-output-character 2" '<integer> wnum 244 (lambda (expected result) (equal? expected (class-name (class-of result))))) 245 (test-log "number of write characters=~a" wnum) 246 ) 247 248 (let1 wnum (sys-fill-console-output-character hout #\Z 5 0 2) 249 (test* "sys-fill-console-output-character" '<integer> wnum 250 (lambda (expected result) (equal? expected (class-name (class-of result))))) 251 (test-log "number of write characters=~a" wnum) 252 ) 253 254 (let1 wnum (sys-fill-console-output-attribute hout 10 5 0 2) 255 (test* "sys-fill-console-output-attribute" '<integer> wnum 256 (lambda (expected result) (equal? expected (class-name (class-of result))))) 257 (test-log "number of write characters=~a" wnum) 258 )) 259 260(unless rin 261 (test* "sys-flush-console-input-buffer" (undefined) (sys-flush-console-input-buffer hin)) 262 ) 263 264(test-section "Console Title") 265(let1 tstr (sys-get-console-title) 266 (test* "sys-set-console-title 1" (undefined) (sys-set-console-title "abcde")) 267 (test* "sys-get-console-title 1" "abcde" (sys-get-console-title)) 268 (test* "sys-set-console-title 2" (undefined) (sys-set-console-title (string-copy "aaaaa" 0 1))) 269 (test* "sys-get-console-title 2" "a" (sys-get-console-title)) 270 (test* "sys-set-console-title 3" (test-error <error>) (sys-set-console-title (make-string 1024 #\a))) 271 (sys-set-console-title tstr) 272 ) 273 274(test-section "Std Handles") 275(test* "sys-get-std-handle 1" '<win:handle> (sys-get-std-handle STD_INPUT_HANDLE) 276 (lambda (expected result) (equal? expected (class-name (class-of result))))) 277(test* "sys-get-std-handle 2" '<win:handle> (sys-get-std-handle STD_OUTPUT_HANDLE) 278 (lambda (expected result) (equal? expected (class-name (class-of result))))) 279(test* "sys-get-std-handle 3" '<win:handle> (sys-get-std-handle STD_ERROR_HANDLE) 280 (lambda (expected result) (equal? expected (class-name (class-of result))))) 281(test* "sys-set-std-handle" (undefined) (sys-set-std-handle STD_OUTPUT_HANDLE hout)) 282 283;; This test causes a message box. 284;(test-section "MessageBox") 285;(let1 msgret (sys-message-box #f "Hello" "test" (logior MB_OK MB_ICONINFORMATION)) 286; (test* "sys-message-box" '<integer> msgret 287; (lambda (expected result) (equal? expected (class-name (class-of result))))) 288; (test-log "message-box-return-value=~a" msgret) 289; (exit) 290; ) 291 292(test-end) 293 294(test-start "os.windows.console.codepage") 295(use os.windows.console.codepage) 296(test-module 'os.windows.console.codepage) 297(test-end) 298 299 ] ; gauche.os.windows 300 [else]) 301 302