diff --git a/collects/tests/mred/showkey.ss b/collects/tests/mred/showkey.ss index b763d9e516..3c0a25a381 100644 --- a/collects/tests/mred/showkey.ss +++ b/collects/tests/mred/showkey.ss @@ -3,23 +3,25 @@ (lib "class100.ss")) (let () + (define iter 0) (define c% (class100-asi canvas% (override [on-event (lambda (ev) - (printf "~aMOUSE ~a (~a,~a)~n meta: ~a control: ~a alt: ~a shift: ~a~n buttons: ~a ~a ~a~a~a~a~a~n" + (printf "~a~a MOUSE ~a (~a,~a)\n mods:~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) - (send ev get-meta-down) - (send ev get-control-down) - (send ev get-alt-down) - (send ev get-shift-down) - (send ev get-left-down) - (send ev get-middle-down) - (send ev get-right-down) + (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-left-down) " LEFT" "") + (if (send ev get-middle-down) " MIDDLE" "") + (if (send ev get-right-down) " RIGHT" "") (if (send ev dragging?) " dragging" "") @@ -34,20 +36,27 @@ "")))] [on-char (lambda (ev) - (printf "~aKEY code: ~a rel-code: ~a~n meta: ~a control: ~a alt: ~a shift: ~a~n" + (set! iter (add1 iter)) + (printf "~a~a KEY: ~a\n rel-code: ~a\n other-code: ~a\n mods:~a~a~a~a~n" (es-check) + iter (let ([v (send ev get-key-code)]) (if (symbol? v) v - (format "~a = ASCII ~a" v (char->integer v)))) + (format "~s = ASCII ~a" (string v) (char->integer v)))) (let ([v (send ev get-key-release-code)]) (if (symbol? v) v - (format "~a = ASCII ~a" v (char->integer v)))) - (send ev get-meta-down) - (send ev get-control-down) - (send ev get-alt-down) - (send ev get-shift-down)))]))) + (format "~s = ASCII ~a" (string v) (char->integer v)))) + (let ([v (send ev get-other-shift-key-code)]) + (and v + (if (symbol? v) + v + (format "~s = ASCII ~a" (string v) (char->integer v))))) + (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" "")))]))) (define f (make-object (class100 frame% () (inherit accept-drop-files) (override @@ -59,7 +68,7 @@ (define c (make-object c% f)) (define (es-check) (if (eq? (send f get-eventspace) (current-eventspace)) "" - ">>WRONG EVENTSPACE<< ")) + ">>WRONG EVENTSPACE<<\n")) (send c focus) (send f show #t))