showkey as module
This commit is contained in:
Matthew Flatt
parent
1270ba437e
commit
a7a629e45b
|
|
@ -1469,7 +1469,7 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/gracket/paramz.rktl" drdr:command-line (gracket "-f" *)
|
||||
"collects/tests/gracket/png.rktl" drdr:command-line #f
|
||||
"collects/tests/gracket/random.rktl" drdr:command-line #f
|
||||
"collects/tests/gracket/showkey.rktl" drdr:command-line #f
|
||||
"collects/tests/gracket/showkey.rkt" drdr:command-line #f
|
||||
"collects/tests/gracket/sixlib.rktl" drdr:command-line #f
|
||||
"collects/tests/gracket/test-editor-admin.rkt" drdr:command-line (gracket-text "-t" *)
|
||||
"collects/tests/gracket/testing.rktl" drdr:command-line (gracket "-f" *)
|
||||
|
|
|
|||
77
collects/tests/gracket/showkey.rkt
Normal file
77
collects/tests/gracket/showkey.rkt
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class)
|
||||
|
||||
(let ()
|
||||
(define iter 0)
|
||||
(define c%
|
||||
(class canvas%
|
||||
(super-new)
|
||||
(define/override (on-event ev)
|
||||
(lambda (ev)
|
||||
(printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n"
|
||||
(es-check)
|
||||
iter
|
||||
(send ev get-event-type)
|
||||
(send ev get-x)
|
||||
(send ev get-y)
|
||||
(if (send ev get-meta-down) " META" "")
|
||||
(if (send ev get-control-down) " CTL" "")
|
||||
(if (send ev get-alt-down) " ALT" "")
|
||||
(if (send ev get-shift-down) " SHIFT" "")
|
||||
(if (send ev get-caps-down) " CAPS" "")
|
||||
(if (send ev get-left-down) " LEFT" "")
|
||||
(if (send ev get-middle-down) " MIDDLE" "")
|
||||
(if (send ev get-right-down) " RIGHT" "")
|
||||
(if (send ev dragging?)
|
||||
" dragging"
|
||||
"")
|
||||
(if (send ev moving?)
|
||||
" moving"
|
||||
"")
|
||||
(if (send ev entering?)
|
||||
" entering"
|
||||
"")
|
||||
(if (send ev leaving?)
|
||||
" leaving"
|
||||
""))))
|
||||
(define/override (on-char ev)
|
||||
(set! iter (add1 iter))
|
||||
(printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n"
|
||||
(es-check)
|
||||
iter
|
||||
(let ([v (send ev get-key-code)])
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v))))
|
||||
(let ([v (send ev get-key-release-code)])
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v))))
|
||||
(let ([vs (list (send ev get-other-shift-key-code)
|
||||
(send ev get-other-altgr-key-code)
|
||||
(send ev get-other-shift-altgr-key-code)
|
||||
(send ev get-other-caps-key-code))])
|
||||
(map (lambda (v)
|
||||
(and v
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v)))))
|
||||
vs))
|
||||
(if (send ev get-meta-down) " META" "")
|
||||
(if (send ev get-control-down) " CTL" "")
|
||||
(if (send ev get-alt-down) " ALT" "")
|
||||
(if (send ev get-shift-down) " SHIFT" "")
|
||||
(if (send ev get-caps-down) " CAPS" "")))))
|
||||
(define f (make-object (class frame%
|
||||
(inherit accept-drop-files)
|
||||
(define/override (on-drop-file file)
|
||||
(printf "Dropped: ~a\n" file))
|
||||
(super-make-object "tests" #f 100 100)
|
||||
(accept-drop-files #t))))
|
||||
(define c (make-object c% f))
|
||||
(define (es-check) (if (eq? (send f get-eventspace) (current-eventspace))
|
||||
""
|
||||
">>WRONG EVENTSPACE<<\n"))
|
||||
(send c focus)
|
||||
(send f show #t))
|
||||
|
|
@ -1,81 +0,0 @@
|
|||
|
||||
(require mzlib/etc
|
||||
mzlib/class100)
|
||||
|
||||
(let ()
|
||||
(define iter 0)
|
||||
(define c%
|
||||
(class100-asi canvas%
|
||||
(override
|
||||
[on-event
|
||||
(lambda (ev)
|
||||
(printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a~a\n buttons:~a~a~a~a~a~a~a\n"
|
||||
(es-check)
|
||||
iter
|
||||
(send ev get-event-type)
|
||||
(send ev get-x)
|
||||
(send ev get-y)
|
||||
(if (send ev get-meta-down) " META" "")
|
||||
(if (send ev get-control-down) " CTL" "")
|
||||
(if (send ev get-alt-down) " ALT" "")
|
||||
(if (send ev get-shift-down) " SHIFT" "")
|
||||
(if (send ev get-caps-down) " CAPS" "")
|
||||
(if (send ev get-left-down) " LEFT" "")
|
||||
(if (send ev get-middle-down) " MIDDLE" "")
|
||||
(if (send ev get-right-down) " RIGHT" "")
|
||||
(if (send ev dragging?)
|
||||
" dragging"
|
||||
"")
|
||||
(if (send ev moving?)
|
||||
" moving"
|
||||
"")
|
||||
(if (send ev entering?)
|
||||
" entering"
|
||||
"")
|
||||
(if (send ev leaving?)
|
||||
" leaving"
|
||||
"")))]
|
||||
[on-char
|
||||
(lambda (ev)
|
||||
(set! iter (add1 iter))
|
||||
(printf "~a~a KEY: ~a\n rel-code: ~a\n other-codes: ~a\n mods:~a~a~a~a~a\n"
|
||||
(es-check)
|
||||
iter
|
||||
(let ([v (send ev get-key-code)])
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v))))
|
||||
(let ([v (send ev get-key-release-code)])
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v))))
|
||||
(let ([vs (list (send ev get-other-shift-key-code)
|
||||
(send ev get-other-altgr-key-code)
|
||||
(send ev get-other-shift-altgr-key-code)
|
||||
(send ev get-other-caps-key-code))])
|
||||
(map (lambda (v)
|
||||
(and v
|
||||
(if (symbol? v)
|
||||
v
|
||||
(format "~s = ASCII ~a" (string v) (char->integer v)))))
|
||||
vs))
|
||||
(if (send ev get-meta-down) " META" "")
|
||||
(if (send ev get-control-down) " CTL" "")
|
||||
(if (send ev get-alt-down) " ALT" "")
|
||||
(if (send ev get-shift-down) " SHIFT" "")
|
||||
(if (send ev get-caps-down) " CAPS" "")))])))
|
||||
(define f (make-object (class100 frame% ()
|
||||
(inherit accept-drop-files)
|
||||
(override
|
||||
[on-drop-file (lambda (file)
|
||||
(printf "Dropped: ~a\n" file))])
|
||||
(sequence
|
||||
(super-init "tests" #f 100 100)
|
||||
(accept-drop-files #t)))))
|
||||
(define c (make-object c% f))
|
||||
(define (es-check) (if (eq? (send f get-eventspace) (current-eventspace))
|
||||
""
|
||||
">>WRONG EVENTSPACE<<\n"))
|
||||
(send c focus)
|
||||
(send f show #t))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user