Skip to content

Instantly share code, notes, and snippets.

@Hamayama

Hamayama/console.stub.diff

Last active Aug 29, 2015
Star
Embed
What would you like to do?
Learn more about clone URLs
Download ZIP
GaucheのWindowsコンソール処理のパッチ(2015-2-27)(2015-3-3修正)(2015-3-3修正2)
Raw
console.stub.diff
--- console_orig.stub 2015-02-24 13:43:19 +0900
+++ console.stub 2015-03-03 13:57:53 +0900
@@ -71,7 +71,7 @@
(define-enum CTRL_C_EVENT)
(define-enum CTRL_BREAK_EVENT)
-(define-cproc sys-generate-console-ctrl-event (event::<int> pgid::<int>)
+(define-cproc sys-generate-console-ctrl-event (event::<int> pgid::<uint>)
::<void>
(check (GenerateConsoleCtrlEvent (DWORD event) (DWORD pgid))))
@@ -84,7 +84,7 @@
(define-enum FILE_SHARE_READ)
(define-enum FILE_SHARE_WRITE)
-(define-cproc sys-create-console-screen-buffer (desired-access::<uint>
+(define-cproc sys-create-console-screen-buffer (desired-access::<int>
share-mode::<uint>
inheritable::<boolean>)
(let* ([sa::SECURITY_ATTRIBUTES])
@@ -106,10 +106,10 @@
x::<short> y::<short>
fill::<ulong>)
::<void>
- (unless (< (SCM_UVECTOR_SIZE scroll-rectangle) 4)
+ (when (< (SCM_UVECTOR_SIZE scroll-rectangle) 4)
(Scm_Error "s16vector of minimum length 4 required for scroll-rectangle: %S"
scroll-rectangle))
- (unless (and clip-rectangle (< (SCM_UVECTOR_SIZE clip-rectangle) 4))
+ (when (and clip-rectangle (< (SCM_UVECTOR_SIZE clip-rectangle) 4))
(Scm_Error "s16vector of minimum length 4 required for clip-rectangle: %S"
clip-rectangle))
(let* ([c::COORD] [ci::CHAR_INFO])
@@ -118,7 +118,7 @@
(check (ScrollConsoleScreenBuffer
(Scm_WinHandle handle '#f)
(cast (SMALL_RECT*) (SCM_UVECTOR_ELEMENTS scroll-rectangle))
- (cast (SMALL_RECT*) (SCM_UVECTOR_ELEMENTS clip-rectangle))
+ (?: clip-rectangle (cast (SMALL_RECT*) (SCM_UVECTOR_ELEMENTS clip-rectangle)) NULL)
c (& ci)))))
;;
@@ -298,12 +298,12 @@
:type <boolean>))
(allocate (c "make_input_record")))
-(define-cproc sys-get-number-of-console-input-events (h) ::<int>
+(define-cproc sys-get-number-of-console-input-events (h) ::<uint>
(let* ([num::DWORD 0])
(check (GetNumberOfConsoleInputEvents (Scm_WinHandle h '#f) (& num)))
(result num)))
-(define-cproc sys-get-number-of-console-mouse-buttons () ::<int>
+(define-cproc sys-get-number-of-console-mouse-buttons () ::<uint>
(let* ([num::DWORD 0])
(check (GetNumberOfConsoleMouseButtons (& num)))
(result num)))
@@ -323,7 +323,7 @@
(define-cproc sys-read-console-input (h)
(peek/read-console-input ReadConsoleInput))
-(define-cproc sys-read-console (h buf::<uvector>) ::<int>
+(define-cproc sys-read-console (h buf::<uvector>) ::<uint>
(unless (or (SCM_U8VECTORP buf) (SCM_U16VECTORP buf))
(Scm_TypeError "buf" "u8vector or u16vector" (SCM_OBJ buf)))
(SCM_UVECTOR_CHECK_MUTABLE buf)
@@ -359,7 +359,7 @@
(define-cproc sys-read-console-output-attribute (handle
buf::<u16vector>
x::<short> y::<short>)
- ::<int>
+ ::<uint>
(let* ([len::DWORD (SCM_UVECTOR_SIZE buf)] [nread::DWORD] [coord::COORD])
(= (ref coord X) x (ref coord Y) y)
(check (ReadConsoleOutputAttribute (Scm_WinHandle handle '#f)
@@ -367,14 +367,16 @@
len coord (& nread)))
(result nread)))
-(define-cproc sys-read-console-output-character (handle len::<ushort>
+(define-cproc sys-read-console-output-character (handle len::<uint>
x::<short> y::<short>)
::<const-cstring>
+ (when (> len USHRT_MAX)
+ (Scm_Error "ReadConsoleOutputCharacter: length argument too large"))
(let* ([coord::COORD] [nread::DWORD 0]
[pbuf::LPTSTR (SCM_NEW_ATOMIC_ARRAY TCHAR (+ len 1))])
(= (ref coord X) x (ref coord Y) y)
- (check (ReadConsoleOutputCharacter handle pbuf len coord (& nread)))
- (= (aref pbuf len) 0)
+ (check (ReadConsoleOutputCharacter (Scm_WinHandle handle '#f) pbuf len coord (& nread)))
+ (= (aref pbuf nread) 0)
(result (SCM_WCS2MBS pbuf))))
(define-cproc sys-set-console-text-attribute (h attr::<ushort>) ::<void>
@@ -390,30 +392,30 @@
(cast (SMALL_RECT*)
(SCM_UVECTOR_ELEMENTS window)))))
-(define-cproc sys-write-console (h s::<string>) ::<int>
- (let* ([b::(const ScmStringBody*) (SCM_STRING_BODY s)]
+(define-cproc sys-write-console (h s::<string>) ::<uint>
+ (let* ([wcs::TCHAR* (SCM_MBS2WCS (Scm_GetStringConst s))]
[nwritten::DWORD 0])
(check (WriteConsole (Scm_WinHandle h '#f)
- (SCM_MBS2WCS (SCM_STRING_BODY_START b))
- (SCM_STRING_BODY_LENGTH b)
+ wcs
+ (_tcslen wcs)
(& nwritten) NULL))
(result nwritten)))
(define-cproc sys-write-console-output-character (h s::<string>
x::<short> y::<short>)
- ::<int>
- (let* ([b::(const ScmStringBody*) (SCM_STRING_BODY s)]
+ ::<uint>
+ (let* ([wcs::TCHAR* (SCM_MBS2WCS (Scm_GetStringConst s))]
[c::COORD] [nwritten::DWORD 0])
(= (ref c X) x (ref c Y) y)
(check (WriteConsoleOutputCharacter (Scm_WinHandle h '#f)
- (SCM_MBS2WCS (SCM_STRING_BODY_START b))
- (SCM_STRING_BODY_LENGTH b)
+ wcs
+ (_tcslen wcs)
c (& nwritten)))
(result nwritten)))
-(define-cproc sys-fill-console-output-character (h c::<char> len::<ulong>
+(define-cproc sys-fill-console-output-character (h c::<char> len::<uint>
x::<short> y::<short>)
- ::<int>
+ ::<uint>
(let* ([ch::ScmChar (Scm_CharToUcs c)]
[coord::COORD] [nwritten::DWORD 0])
(= (ref coord X) x (ref coord Y) y)
@@ -423,9 +425,9 @@
coord (& nwritten)))
(result nwritten)))
-(define-cproc sys-fill-console-output-attribute (h attr::<ushort> len::<ulong>
+(define-cproc sys-fill-console-output-attribute (h attr::<ushort> len::<uint>
x::<short> y::<short>)
- ::<int>
+ ::<uint>
(let* ([c::COORD] [nwritten::DWORD 0])
(= (ref c X) x (ref c Y) y)
(check (FillConsoleOutputAttribute (Scm_WinHandle h '#f)
@@ -447,6 +449,12 @@
(= (aref buf 1023) 0)
(result (SCM_WCS2MBS buf))))
+(define-cproc sys-set-console-title (s::<string>) ::<void>
+ (let* ([wcs::TCHAR* (SCM_MBS2WCS (Scm_GetStringConst s))])
+ (when (>= (_tcslen wcs) 1024)
+ (Scm_Error "SetConsoleTitle: string argument too long"))
+ (check (SetConsoleTitle wcs))))
+
;;
;; Std Handles
;;
Raw
test.scm.diff
--- test_orig.scm 2015-02-24 13:43:19 +0900
+++ test.scm 2015-03-03 14:14:43 +0900
@@ -3,11 +3,279 @@
;;
(use gauche.test)
+(use gauche.uvector)
(cond-expand
[gauche.os.windows
(test-start "windows")
(use os.windows)
(test-module 'os.windows)
+
+(define hin (sys-get-std-handle STD_INPUT_HANDLE))
+(define hout (sys-get-std-handle STD_OUTPUT_HANDLE))
+(define (redirected-handle? hdl)
+ (guard (exc ((<system-error> exc) #t))
+ (sys-get-console-mode hdl) #f))
+(define rin (redirected-handle? hin))
+(define rout (redirected-handle? hout))
+
+(test-section "Console procedures")
+(test* "sys-alloc-console" (test-error <system-error>) (sys-alloc-console))
+;; This test causes a program termination.
+;(test* "sys-free-console" (undefined) (sys-free-console))
+;(test* "sys-generate-console-ctrl-event 1" (undefined) (sys-generate-console-ctrl-event CTRL_C_EVENT 0))
+;(test* "sys-generate-console-ctrl-event 2" (undefined) (sys-generate-console-ctrl-event CTRL_BREAK_EVENT 0))
+
+(when (not rout)
+ (test-section "Console Buffers")
+ (define cbuf1 (sys-create-console-screen-buffer (logior GENERIC_READ GENERIC_WRITE) 0 #f))
+ (define cbuf2 (sys-get-std-handle STD_OUTPUT_HANDLE))
+ (test* "sys-create-console-screen-buffer" '<win:handle> cbuf1
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test* "sys-set-console-active-screen-buffer 1" (undefined) (sys-set-console-active-screen-buffer cbuf1))
+ (test* "sys-set-console-active-screen-buffer 2" (undefined) (sys-set-console-active-screen-buffer cbuf2))
+ (test* "sys-scroll-console-screen-buffer" (undefined)
+ (sys-scroll-console-screen-buffer cbuf2 (s16vector 0 0 4 2) #f 5 0 0))
+ )
+
+(test-section "Console Code Page")
+(define cp1 (sys-get-console-cp))
+(define cp2 (sys-get-console-output-cp))
+(test* "sys-set-console-cp" (undefined) (sys-set-console-cp 65001))
+(test* "sys-set-console-output-cp" (undefined) (sys-set-console-output-cp 65001))
+(test* "sys-get-console-cp" 65001 (sys-get-console-cp))
+(test* "sys-get-console-output-cp" 65001 (sys-get-console-output-cp))
+(sys-set-console-cp cp1)
+(sys-set-console-output-cp cp2)
+
+(when (not rout)
+ (test-section "Console Cursor Info")
+ (define-values (csize cvisible) (sys-get-console-cursor-info hout))
+ (test* "sys-set-console-cursor-info" (undefined) (sys-set-console-cursor-info hout 1 #f))
+ (test* "sys-get-console-cursor-info" '(1 #f) (values->list (sys-get-console-cursor-info hout)))
+ (sys-set-console-cursor-info hout csize cvisible)
+ ;; This test causes a cursor position change.
+ ;(test* "sys-set-console-cursor-position" (undefined) (sys-set-console-cursor-position hout 0 0))
+ ;(exit)
+ )
+
+(when (not rout)
+ (test-section "Console Mode")
+ (define cmode1 (sys-get-console-mode hin))
+ (define cmode2 (sys-get-console-mode hout))
+ (test* "sys-set-console-mode" (undefined) (sys-set-console-mode hin ENABLE_LINE_INPUT))
+ (test* "sys-set-console-mode" (undefined) (sys-set-console-mode hout ENABLE_PROCESSED_OUTPUT))
+ (test* "sys-get-console-mode" ENABLE_LINE_INPUT (sys-get-console-mode hin))
+ (test* "sys-get-console-mode" ENABLE_PROCESSED_OUTPUT (sys-get-console-mode hout))
+ (sys-set-console-mode hin cmode1)
+ (sys-set-console-mode hout cmode2)
+ )
+
+(when (not rout)
+ (test-section "Console Screen Buffer Info")
+ (define cinfo (sys-get-console-screen-buffer-info hout))
+ (test* "sys-get-console-screen-buffer-info" '<win:console-screen-buffer-info> cinfo
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "cinfo.size.x = ~a" (~ cinfo 'size.x))
+ (test-log "cinfo.size.y = ~a" (~ cinfo 'size.y))
+ (test-log "cinfo.cursor-position.x = ~a" (~ cinfo 'cursor-position.x))
+ (test-log "cinfo.cursor-position.y = ~a" (~ cinfo 'cursor-position.y))
+ (test-log "cinfo.attributes = ~a" (~ cinfo 'attributes))
+ (test-log "window.left = ~a" (~ cinfo 'window.left))
+ (test-log "window.top = ~a" (~ cinfo 'window.top))
+ (test-log "window.right = ~a" (~ cinfo 'window.right))
+ (test-log "window.bottom = ~a" (~ cinfo 'window.bottom))
+ (test-log "maximum-window-size.x = ~a" (~ cinfo 'maximum-window-size.x))
+ (test-log "maximum-window-size.y = ~a" (~ cinfo 'maximum-window-size.y))
+ (define wsize (values->list (sys-get-largest-console-window-size hout)))
+ (test* "sys-get-largest-console-window-size" 2 wsize
+ (lambda (expected result) (equal? expected (length result))))
+ (test-log "largest-console-window-width = ~a" (car wsize))
+ (test-log "largest-console-window-height = ~a" (cadr wsize))
+ ;; This test causes a screen buffer size change.
+ ;(test* "sys-set-screen-buffer-size" (undefined) (sys-set-screen-buffer-size hout 80 25))
+ ;(exit)
+ )
+
+(when (not rin)
+ (test-section "Console input")
+ (define evnum (sys-get-number-of-console-input-events hin))
+ (test* "sys-get-number-of-console-input-events" '<integer> evnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (define mbnum (sys-get-number-of-console-mouse-buttons))
+ (test* "sys-get-number-of-console-mouse-buttons" '<integer> mbnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number-of-console-input-events = ~a" evnum)
+ (test-log "number-of-console-mouse-buttons = ~a" mbnum)
+ )
+
+(define KEY_EVENT #x01)
+(define MOUSE_EVENT #x02)
+(define WINDOW_BUFFER_SIZE_EVENT #x04)
+(define MENU_EVENT #x08)
+(define FOCUS_EVENT #x10)
+(define (event-loop-test)
+ (let ((hin (sys-get-std-handle STD_INPUT_HANDLE))
+ (cmode 0)
+ (done #f)
+ (ir #f)
+ (irlist '())
+ (evt #f))
+ (set! cmode (sys-get-console-mode hin))
+ (sys-set-console-mode hin (logior ENABLE_WINDOW_INPUT ENABLE_MOUSE_INPUT))
+ (test-log "Event loop test (Hit [esc] key to exit)")
+ (while (not done)
+ (set! irlist (sys-peek-console-input hin))
+ (when (not (null? irlist))
+ (sys-read-console-input hin)
+ (while (not (null? irlist))
+ (set! ir (car irlist))
+ (set! irlist (cdr irlist))
+ (set! evt (~ ir 'event-type))
+ (cond
+ ((= evt KEY_EVENT)
+ (let ((kdown (~ ir 'key.down))
+ (rept (~ ir 'key.repeat-count))
+ (vk (~ ir 'key.virtual-key-code))
+ (vs (~ ir 'key.virtual-scan-code))
+ (ch (~ ir 'key.unicode-char))
+ (asc (~ ir 'key.ascii-char))
+ (ctls (~ ir 'key.control-key-state)))
+ (test-log "key : kdown=~a repeat=~a vk=~a vs=~a ch=~a asc=~a ctrlkeys=~a" kdown rept vk vs ch asc ctls)
+ (if (and kdown (= vk 27))
+ (set! done #t))))
+ ((= evt MOUSE_EVENT)
+ (let ((x (~ ir 'mouse.x))
+ (y (~ ir 'mouse.y))
+ (btn (~ ir 'mouse.button-state))
+ (ctls (~ ir 'mouse.control-key-state))
+ (evflg (~ ir 'mouse.event-flags)))
+ (test-log "mouse : x=~a y=~a button=~a ctrlkeys=~a eventflags=~a" x y btn ctls evflg)))
+ ((= evt WINDOW_BUFFER_SIZE_EVENT)
+ (let ((x (~ ir 'window-buffer-size.x))
+ (y (~ ir 'window-buffer-size.y)))
+ (test-log "window-buffer-size : x=~a y=~a" x y)))
+ ((= evt MENU_EVENT)
+ (let ((id (~ ir 'menu.command-id)))
+ (test-log "menu : menu-command-id=~a" id)))
+ ((= evt FOCUS_EVENT)
+ (let ((fcs (~ ir 'focus.set-focus)))
+ (test-log "focus : set-focus=~a" fcs)))
+ )))
+ (sys-nanosleep (* 100 1000000)) ; 100msec
+ )
+ (sys-set-console-mode hin cmode)))
+;; This test causes an event loop.
+;(event-loop-test)
+;(exit)
+
+;; This test causes a keyboard input waiting.
+;(when (not rin)
+; (define cmode1 (sys-get-console-mode hin))
+; (sys-set-console-mode hin 0)
+; (define rnum (sys-read-console hin (make-u8vector 2 0)))
+; (test* "sys-read-console" '<integer> rnum
+; (lambda (expected result) (equal? expected (class-name (class-of result)))))
+; (sys-set-console-mode hin cmode1)
+; (test-log "number of read characters=~a" rnum)
+; (exit)
+; )
+
+(when (not rout)
+ (define rbuf (sys-read-console-output hout (make-u32vector 6 0) 3 2 0 0 (s16vector 0 3 2 4)))
+ (test* "sys-read-console-output" '<u32vector> rbuf
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log (string-append "read-buffer=" (x->string (map (cut format "~8,'0Xh" <>) (u32vector->list rbuf)))))
+
+ (define rbuf (make-u16vector 6 0))
+ (define rnum (sys-read-console-output-attribute hout rbuf 0 3))
+ (test* "sys-read-console-output-attribute" '<integer> rnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log (string-append "read-attribute-buffer=" (x->string (map (cut format "~4,'0Xh" <>) (u16vector->list rbuf)))))
+ (test-log "number of read attributes=~a" rnum)
+
+ (define rstr (sys-read-console-output-character hout 6 0 3))
+ (test* "sys-read-console-output-character 1" '<string> rstr
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "read-string=\"~a\"" rstr)
+ (define rstr (sys-read-console-output-character hout 65535 0 3))
+ (test* "sys-read-console-output-character 2" '<string> rstr
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test* "sys-read-console-output-character 3" (test-error <error>)
+ (sys-read-console-output-character hout 65536 0 3))
+
+ (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 10))
+ (test-log "color=10")
+ (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 7))
+ (test-log "color=7")
+
+ ;; This test causes a window size change.
+ ;(test* "sys-set-console-window-info" (undefined) (sys-set-console-window-info hout #t (s16vector 0 0 10 10)))
+ ;(exit)
+
+ (define wnum (sys-write-console hout "abcde fghij klmno\n"))
+ (test* "sys-write-console 1" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ (define wnum (sys-write-console hout (string-copy "aaaaa" 0 1)))
+ (test* "sys-write-console 2" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-write-console-output-character hout "ABC" 0 0))
+ (test* "sys-write-console-output-character 1" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ (define wnum (sys-write-console-output-character hout (string-copy "aaaaa" 0 1) 0 1))
+ (test* "sys-write-console-output-character 2" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-fill-console-output-character hout #\Z 5 0 2))
+ (test* "sys-fill-console-output-character" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-fill-console-output-attribute hout 10 5 0 2))
+ (test* "sys-fill-console-output-attribute" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ )
+
+(when (not rin)
+ (test* "sys-flush-console-input-buffer" (undefined) (sys-flush-console-input-buffer hin))
+ )
+
+
+(test-section "Console Title")
+(define tstr (sys-get-console-title))
+(test* "sys-set-console-title" (test-error <error>) (sys-set-console-title (make-string 1024 #\a)))
+(test* "sys-set-console-title 1" (undefined) (sys-set-console-title "abcde"))
+(test* "sys-get-console-title 1" "abcde" (sys-get-console-title))
+(test* "sys-set-console-title 2" (undefined) (sys-set-console-title (string-copy "aaaaa" 0 1)))
+(test* "sys-get-console-title 2" "a" (sys-get-console-title))
+(sys-set-console-title tstr)
+
+
+(test-section "Std Handles")
+(test* "sys-get-std-handle 1" '<win:handle> (sys-get-std-handle STD_INPUT_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-get-std-handle 2" '<win:handle> (sys-get-std-handle STD_OUTPUT_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-get-std-handle 3" '<win:handle> (sys-get-std-handle STD_ERROR_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-set-std-handle" (undefined) (sys-set-std-handle STD_OUTPUT_HANDLE hout))
+
+
+;; This test causes a message box.
+;(test-section "MessageBox")
+;(define msgret (sys-message-box #f "Hello" "test" (logior MB_OK MB_ICONINFORMATION)))
+;(test* "sys-message-box" '<integer> msgret
+; (lambda (expected result) (equal? expected (class-name (class-of result)))))
+;(test-log "message-box-return-value=~a" msgret)
+;(exit)
+
+
(test-end)]
[else])
+
[gauche.os.windows
(test-start "windows")
(use os.windows)
(test-module 'os.windows)
+
+(define hin (sys-get-std-handle STD_INPUT_HANDLE))
+(define hout (sys-get-std-handle STD_OUTPUT_HANDLE))
+(define (redirected-handle? hdl)
+ (guard (exc ((<system-error> exc) #t))
+ (sys-get-console-mode hdl) #f))
+(define rin (redirected-handle? hin))
+(define rout (redirected-handle? hout))
+
+(test-section "Console procedures")
+(test* "sys-alloc-console" (test-error <system-error>) (sys-alloc-console))
+;; This test causes a program termination.
+;(test* "sys-free-console" (undefined) (sys-free-console))
+;(test* "sys-generate-console-ctrl-event 1" (undefined) (sys-generate-console-ctrl-event CTRL_C_EVENT 0))
+;(test* "sys-generate-console-ctrl-event 2" (undefined) (sys-generate-console-ctrl-event CTRL_BREAK_EVENT 0))
+
+(when (not rout)
+ (test-section "Console Buffers")
+ (define cbuf1 (sys-create-console-screen-buffer (logior GENERIC_READ GENERIC_WRITE) 0 #f))
+ (define cbuf2 (sys-get-std-handle STD_OUTPUT_HANDLE))
+ (test* "sys-create-console-screen-buffer" '<win:handle> cbuf1
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test* "sys-set-console-active-screen-buffer 1" (undefined) (sys-set-console-active-screen-buffer cbuf1))
+ (test* "sys-set-console-active-screen-buffer 2" (undefined) (sys-set-console-active-screen-buffer cbuf2))
+ (test* "sys-scroll-console-screen-buffer" (undefined)
+ (sys-scroll-console-screen-buffer cbuf2 (s16vector 0 0 4 2) #f 5 0 0))
+ )
+
+(test-section "Console Code Page")
+(define cp1 (sys-get-console-cp))
+(define cp2 (sys-get-console-output-cp))
+(test* "sys-set-console-cp" (undefined) (sys-set-console-cp 65001))
+(test* "sys-set-console-output-cp" (undefined) (sys-set-console-output-cp 65001))
+(test* "sys-get-console-cp" 65001 (sys-get-console-cp))
+(test* "sys-get-console-output-cp" 65001 (sys-get-console-output-cp))
+(sys-set-console-cp cp1)
+(sys-set-console-output-cp cp2)
+
+(when (not rout)
+ (test-section "Console Cursor Info")
+ (define-values (csize cvisible) (sys-get-console-cursor-info hout))
+ (test* "sys-set-console-cursor-info" (undefined) (sys-set-console-cursor-info hout 1 #f))
+ (test* "sys-get-console-cursor-info" '(1 #f) (values->list (sys-get-console-cursor-info hout)))
+ (sys-set-console-cursor-info hout csize cvisible)
+ ;; This test causes a cursor position change.
+ ;(test* "sys-set-console-cursor-position" (undefined) (sys-set-console-cursor-position hout 0 0))
+ ;(exit)
+ )
+
+(when (not rout)
+ (test-section "Console Mode")
+ (define cmode1 (sys-get-console-mode hin))
+ (define cmode2 (sys-get-console-mode hout))
+ (test* "sys-set-console-mode" (undefined) (sys-set-console-mode hin ENABLE_LINE_INPUT))
+ (test* "sys-set-console-mode" (undefined) (sys-set-console-mode hout ENABLE_PROCESSED_OUTPUT))
+ (test* "sys-get-console-mode" ENABLE_LINE_INPUT (sys-get-console-mode hin))
+ (test* "sys-get-console-mode" ENABLE_PROCESSED_OUTPUT (sys-get-console-mode hout))
+ (sys-set-console-mode hin cmode1)
+ (sys-set-console-mode hout cmode2)
+ )
+
+(when (not rout)
+ (test-section "Console Screen Buffer Info")
+ (define cinfo (sys-get-console-screen-buffer-info hout))
+ (test* "sys-get-console-screen-buffer-info" '<win:console-screen-buffer-info> cinfo
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "cinfo.size.x = ~a" (~ cinfo 'size.x))
+ (test-log "cinfo.size.y = ~a" (~ cinfo 'size.y))
+ (test-log "cinfo.cursor-position.x = ~a" (~ cinfo 'cursor-position.x))
+ (test-log "cinfo.cursor-position.y = ~a" (~ cinfo 'cursor-position.y))
+ (test-log "cinfo.attributes = ~a" (~ cinfo 'attributes))
+ (test-log "window.left = ~a" (~ cinfo 'window.left))
+ (test-log "window.top = ~a" (~ cinfo 'window.top))
+ (test-log "window.right = ~a" (~ cinfo 'window.right))
+ (test-log "window.bottom = ~a" (~ cinfo 'window.bottom))
+ (test-log "maximum-window-size.x = ~a" (~ cinfo 'maximum-window-size.x))
+ (test-log "maximum-window-size.y = ~a" (~ cinfo 'maximum-window-size.y))
+ (define wsize (values->list (sys-get-largest-console-window-size hout)))
+ (test* "sys-get-largest-console-window-size" 2 wsize
+ (lambda (expected result) (equal? expected (length result))))
+ (test-log "largest-console-window-width = ~a" (car wsize))
+ (test-log "largest-console-window-height = ~a" (cadr wsize))
+ ;; This test causes a screen buffer size change.
+ ;(test* "sys-set-screen-buffer-size" (undefined) (sys-set-screen-buffer-size hout 80 25))
+ ;(exit)
+ )
+
+(when (not rin)
+ (test-section "Console input")
+ (define evnum (sys-get-number-of-console-input-events hin))
+ (test* "sys-get-number-of-console-input-events" '<integer> evnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (define mbnum (sys-get-number-of-console-mouse-buttons))
+ (test* "sys-get-number-of-console-mouse-buttons" '<integer> mbnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number-of-console-input-events = ~a" evnum)
+ (test-log "number-of-console-mouse-buttons = ~a" mbnum)
+ )
+
+(define KEY_EVENT #x01)
+(define MOUSE_EVENT #x02)
+(define WINDOW_BUFFER_SIZE_EVENT #x04)
+(define MENU_EVENT #x08)
+(define FOCUS_EVENT #x10)
+(define (event-loop-test)
+ (let ((hin (sys-get-std-handle STD_INPUT_HANDLE))
+ (cmode 0)
+ (done #f)
+ (ir #f)
+ (irlist '())
+ (evt #f))
+ (set! cmode (sys-get-console-mode hin))
+ (sys-set-console-mode hin (logior ENABLE_WINDOW_INPUT ENABLE_MOUSE_INPUT ))
+ (test-log "Event loop test (Hit [esc] key to exit)")
+ (while (not done)
+ (set! irlist (sys-peek-console-input hin))
+ (when (not (null? irlist))
+ (sys-read-console-input hin)
+ (while (not (null? irlist))
+ (set! ir (car irlist))
+ (set! irlist (cdr irlist))
+ (set! evt (~ ir 'event-type))
+ (cond
+ ((= evt KEY_EVENT)
+ (let ((kdown (~ ir 'key.down))
+ (rept (~ ir 'key.repeat-count))
+ (vk (~ ir 'key.virtual-key-code))
+ (vs (~ ir 'key.virtual-scan-code))
+ (ch (~ ir 'key.unicode-char))
+ (asc (~ ir 'key.ascii-char))
+ (ctls (~ ir 'key.control-key-state)))
+ (test-log "key : kdown=~a repeat=~a vk=~a vs=~a ch=~a asc=~a ctrlkeys=~a" kdown rept vk vs ch asc ctls)
+ (if (and kdown (= vk 27))
+ (set! done #t))))
+ ((= evt MOUSE_EVENT)
+ (let ((x (~ ir 'mouse.x))
+ (y (~ ir 'mouse.y))
+ (btn (~ ir 'mouse.button-state))
+ (ctls (~ ir 'mouse.control-key-state))
+ (evflg (~ ir 'mouse.event-flags)))
+ (test-log "mouse : x=~a y=~a button=~a ctrlkeys=~a eventflags=~a" x y btn ctls evflg)))
+ ((= evt WINDOW_BUFFER_SIZE_EVENT)
+ (let ((x (~ ir 'window-buffer-size.x))
+ (y (~ ir 'window-buffer-size.y)))
+ (test-log "window-buffer-size : x=~a y=~a" x y)))
+ ((= evt MENU_EVENT)
+ (let ((id (~ ir 'menu.command-id)))
+ (test-log "menu : menu-command-id=~a" id)))
+ ((= evt FOCUS_EVENT)
+ (let ((fcs (~ ir 'focus.set-focus)))
+ (test-log "focus : set-focus=~a" fcs)))
+ )))
+ (sys-nanosleep (* 100 1000000)) ; 100msec
+ )
+ (sys-set-console-mode hin cmode)))
+;; This test causes an event loop.
+;(event-loop-test)
+;(exit)
+
+;; This test causes a keyboard input waiting.
+;(when (not rin)
+; (define cmode1 (sys-get-console-mode hin))
+; (sys-set-console-mode hin 0)
+; (define rnum (sys-read-console hin (make-u8vector 2 0)))
+; (test* "sys-read-console" '<integer> rnum
+; (lambda (expected result) (equal? expected (class-name (class-of result)))))
+; (sys-set-console-mode hin cmode1)
+; (test-log "number of read characters=~a" rnum)
+; (exit)
+; )
+
+(when (not rout)
+ (define rbuf (sys-read-console-output hout (make-u32vector 6 0) 3 2 0 0 (s16vector 0 3 2 4)))
+ (test* "sys-read-console-output" '<u32vector> rbuf
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log (string-append "read-buffer=" (x->string (map (cut format "~8,'0Xh" <>) (u32vector->list rbuf)))))
+
+ (define rbuf (make-u16vector 6 0))
+ (define rnum (sys-read-console-output-attribute hout rbuf 0 3))
+ (test* "sys-read-console-output-attribute" '<integer> rnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log (string-append "read-attribute-buffer=" (x->string (map (cut format "~4,'0Xh" <>) (u16vector->list rbuf)))))
+ (test-log "number of read attributes=~a" rnum)
+
+ (define rstr (sys-read-console-output-character hout 6 0 3))
+ (test* "sys-read-console-output-character" '<string> rstr
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "read-string=\"~a\"" rstr)
+
+ (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 10))
+ (test-log "color=10")
+ (test* "sys-set-console-text-attribute" (undefined) (sys-set-console-text-attribute hout 7))
+ (test-log "color=7")
+
+ ;; This test causes a window size change.
+ ;(test* "sys-set-console-window-info" (undefined) (sys-set-console-window-info hout #t (s16vector 0 0 10 10)))
+ ;(exit)
+
+ (define wnum (sys-write-console hout "abcde fghij klmno\n"))
+ (test* "sys-write-console 1" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ (define wnum (sys-write-console hout (string-copy "aaaaa" 0 1)))
+ (test* "sys-write-console 2" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-write-console-output-character hout "ABC" 0 0))
+ (test* "sys-write-console-output-character 1" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ (define wnum (sys-write-console-output-character hout (string-copy "aaaaa" 0 1) 0 1))
+ (test* "sys-write-console-output-character 2" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-fill-console-output-character hout #\Z 5 0 2))
+ (test* "sys-fill-console-output-character" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+
+ (define wnum (sys-fill-console-output-attribute hout 10 5 0 2))
+ (test* "sys-fill-console-output-attribute" '<integer> wnum
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+ (test-log "number of write characters=~a" wnum)
+ )
+
+(when (not rin)
+ (test* "sys-flush-console-input-buffer" (undefined) (sys-flush-console-input-buffer hin))
+ )
+
+
+(test-section "Console Title")
+(define tstr (sys-get-console-title))
+(test* "sys-set-console-title" (test-error <error>) (sys-set-console-title (make-string 1024 #\a)))
+(test* "sys-set-console-title 1" (undefined) (sys-set-console-title "abcde"))
+(test* "sys-get-console-title 1" "abcde" (sys-get-console-title))
+(test* "sys-set-console-title 2" (undefined) (sys-set-console-title (string-copy "aaaaa" 0 1)))
+(test* "sys-get-console-title 2" "a" (sys-get-console-title))
+(sys-set-console-title tstr)
+
+
+(test-section "Std Handles")
+(test* "sys-get-std-handle 1" '<win:handle> (sys-get-std-handle STD_INPUT_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-get-std-handle 2" '<win:handle> (sys-get-std-handle STD_OUTPUT_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-get-std-handle 3" '<win:handle> (sys-get-std-handle STD_ERROR_HANDLE)
+ (lambda (expected result) (equal? expected (class-name (class-of result)))))
+(test* "sys-set-std-handle" (undefined) (sys-set-std-handle STD_OUTPUT_HANDLE hout))
+
+
+;; This test causes a message box.
+;(test-section "MessageBox")
+;(define msgret (sys-message-box #f "Hello" "test" (logior MB_OK MB_ICONINFORMATION)))
+;(test* "sys-message-box" '<integer> msgret
+; (lambda (expected result) (equal? expected (class-name (class-of result)))))
+;(test-log "message-box-return-value=~a" msgret)
+;(exit)
+
+
(test-end)]
[else])
+
Raw
win-compat.h.diff
--- win-compat_orig.h 2015-02-24 13:43:23 +0900
+++ win-compat.h 2015-02-24 11:43:01 +0900
@@ -24,6 +24,7 @@
#include <utime.h>
#include <mswsock.h>
#include <direct.h>
+#include <tchar.h>
#undef small /* windows.h defines 'small' as 'char'; what's the hell? */
#ifndef _BSDTYPES_DEFINED
Raw
windows.scm.diff
--- windows_orig.scm 2015-02-24 13:43:19 +0900
+++ windows.scm 2015-02-26 20:21:25 +0900
@@ -92,6 +92,7 @@
sys-fill-console-output-attribute
sys-flush-console-input-buffer
sys-get-console-title
+ sys-set-console-title
STD_INPUT_HANDLE STD_OUTPUT_HANDLE STD_ERROR_HANDLE
sys-get-std-handle sys-set-std-handle
))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.