[mcclim-cvs] CVS update: mcclim/Backends/beagle/input/events.lisp
Duncan Rose
drose at common-lisp.net
Tue May 17 17:51:15 UTC 2005
Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input
In directory common-lisp.net:/tmp/cvs-serv19635/beagle/input
Modified Files:
events.lisp
Log Message:
Apply Cyrus Harmon's changes to Beagle key handling posted on
08-MAR-2005. Not sure if these were never applied or if they
have been clobbered since.
Date: Tue May 17 19:51:15 2005
Author: drose
Index: mcclim/Backends/beagle/input/events.lisp
diff -u mcclim/Backends/beagle/input/events.lisp:1.1 mcclim/Backends/beagle/input/events.lisp:1.2
--- mcclim/Backends/beagle/input/events.lisp:1.1 Tue May 17 00:13:16 2005
+++ mcclim/Backends/beagle/input/events.lisp Tue May 17 19:51:14 2005
@@ -28,7 +28,7 @@
#||
-$Id: events.lisp,v 1.1 2005/05/16 22:13:16 drose Exp $
+$Id: events.lisp,v 1.2 2005/05/17 17:51:14 drose Exp $
All these are copied pretty much from CLX/port.lisp
@@ -571,23 +571,24 @@
;; We need to maintain the modifier flags state constantly to be able to
;; implement this; suggest a slot in beagle-port?
(when (equal #$NSFlagsChanged event-type)
- (format *debug-io* "In event-build (flags changed)~%")
+;;; (format *debug-io* "In event-build (flags changed)~%")
;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state'
;; to work out if this is a key up or a key down...
- (setf return-event (make-instance (if (current-mods-map-to-key-down (send event 'modifier-flags))
- 'key-press-event
- 'key-release-event)
- :key-name nil
- :key-character nil
- :x 0
- :y 0
- :graft-x 0
- :graft-y 0
- ;; Irrespective of where the key event happened, send it
- ;; to the sheet that has key-focus for the port.
- :sheet (beagle-port-key-focus *beagle-port*)
- :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags))
- :timestamp (incf timestamp))))
+ (setf return-event
+ (destructuring-bind (event-class key)
+ (current-mods-map-to-key (send event 'modifier-flags))
+ (make-instance event-class
+ :key-name key
+ :key-character nil
+ :x 0
+ :y 0
+ :graft-x 0
+ :graft-y 0
+ ;; Irrespective of where the key event happened, send it
+ ;; to the sheet that has key-focus for the port.
+ :sheet (beagle-port-key-focus *beagle-port*)
+ :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags))
+ :timestamp (incf timestamp)))))
;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event?
;; Then could pull up docs (or could do if there were any!)
@@ -630,7 +631,7 @@
;;; This is really, really horribly written. Hopefully it will just be
;;; temporary until everything is 'band-aided' (!?) at which point we'll
;;; look to migrate to Carbon and reimplement a lot of this stuff.
-(defun current-mods-map-to-key-down (current-modifier-state)
+(defun current-mods-map-to-key (current-modifier-state)
(declare (special *-current-event-modifier-state-*))
;; Are there modifiers in 'current-modifier-state' that don't exist in
;; *-current-event-modifier-state-* (key down) or vice versa (key up)?
@@ -643,38 +644,38 @@
;;#$NSAlternateKeyMask +super-key+
;;#$NSAlphaShiftKeyMask +hyper-key+
(cond ((null *-current-event-modifier-state-*)
- t)
+ '(key-release-event nil))
((and (> (logand *-current-event-modifier-state-* +shift-key+) 0)
(= (logand current-modifier-state #$NSShiftKeyMask) 0))
- nil)
+ '(key-release-event :shift))
((and (= (logand *-current-event-modifier-state-* +shift-key+) 0)
(> (logand current-modifier-state #$NSShiftKeyMask) 0))
- t)
+ '(key-press-event :shift))
((and (> (logand *-current-event-modifier-state-* +control-key+) 0)
(= (logand current-modifier-state #$NSControlKeyMask) 0))
- nil)
+ '(key-release-event :control))
((and (= (logand *-current-event-modifier-state-* +control-key+) 0)
(> (logand current-modifier-state #$NSControlKeyMask) 0))
- t)
+ '(key-press-event :control))
((and (> (logand *-current-event-modifier-state-* +meta-key+) 0)
(= (logand current-modifier-state #$NSCommandKeyMask) 0))
- nil)
+ '(key-release-event :meta))
((and (= (logand *-current-event-modifier-state-* +meta-key+) 0)
(> (logand current-modifier-state #$NSCommandKeyMask) 0))
- t)
+ '(key-press-event :meta))
((and (> (logand *-current-event-modifier-state-* +super-key+) 0)
(= (logand current-modifier-state #$NSAlternateKeyMask) 0))
- nil)
+ '(key-release-event :super))
((and (= (logand *-current-event-modifier-state-* +super-key+) 0)
(> (logand current-modifier-state #$NSAlternateKeyMask) 0))
- t)
+ '(key-press-event :super))
((and (> (logand *-current-event-modifier-state-* +hyper-key+) 0)
(= (logand current-modifier-state #$NSAlphaShiftKeyMask) 0))
- nil)
+ '(key-release-event :hyper))
((and (= (logand *-current-event-modifier-state-* +hyper-key+) 0)
(> (logand current-modifier-state #$NSAlphaShiftKeyMask) 0))
- t)
- (t nil)))
+ '(key-press-event :hyper))
+ (t '(key-release-event))))
;; Need to make use of the Cocoa method for getting modifier state - this is independent of events
@@ -764,21 +765,29 @@
(let ((key-name (lookup-keysym (send ns-string-characters-in :character-at-index 0))))
;; If key-name is nil after all that, see if we can look up a mapping from those supported in
;; Cocoa...
-;;; (when (null key-name)
-;;; (setf key-name (get-key-name-from-cocoa-constants ns-string-characters-in)))
-;;; (format *terminal-io* "Got key-name of: ~A~%" key-name)
- key-name))))
+ (cond
+ ((null key-name)
+ (let ((clim-key
+ (get-key-name-from-cocoa-constants
+ (send ns-string-characters-in :character-at-index 0))))
+ clim-key))
+ (t key-name))))))
;;; From CLX/keysyms.lisp
(defun numeric-keysym-to-character (keysym)
- (and (<= 0 keysym 255)
- (code-char keysym)))
+ (cond
+ ((= #x1b keysym)
+ (get-key-name-from-cocoa-constants keysym))
+ ((and (<= 0 keysym 255))
+ (code-char keysym))
+ (t nil)))
(defun keysym-to-character (keysym)
(numeric-keysym-to-character (reverse-lookup-keysym keysym)))
-(defconstant *beagle-key-constants* '(#$NSUpArrowFunctionKey :UP
+(defconstant *beagle-key-constants* (list
+ #$NSUpArrowFunctionKey :UP
#$NSDownArrowFunctionKey :DOWN
#$NSLeftArrowFunctionKey :LEFT
#$NSRightArrowFunctionKey :RIGHT
@@ -849,10 +858,33 @@
#$NSRedoFunctionKey :REDO
#$NSFindFunctionKey :FIND
#$NSHelpFunctionKey :HELP
- #$NSModeSwitchFunctionKey :MODE-SWITCH))
+ #$NSModeSwitchFunctionKey :MODE-SWITCH
+ #x1b :ESCAPE))
;;;(defun get-key-name-from-cocoa-constants (ns-in)
;;; (loop for target, key in *cocoa-key-constants*
;;; (do
;;; (when (send target :is-equal-to-string ns-in)
;;; key))))
+
+(defvar *beagle-key-hash-table*
+ (make-hash-table :test #'eql))
+
+(defvar *reverse-beagle-key-hash-table*
+ (make-hash-table :test #'eq))
+
+(defun define-beagle-key (ns-key clim-key)
+ (pushnew clim-key (gethash ns-key *beagle-key-hash-table*))
+ (setf (gethash clim-key *reverse-beagle-key-hash-table*) ns-key))
+
+(defun lookup-beagle-key (ns-key)
+ (car (last (gethash ns-key *beagle-key-hash-table*))))
+
+(defun reverse-lookup-beagle-key (clim-key)
+ (gethash clim-key *reverse-beagle-key-hash-table*))
+
+(loop for key-binding on *beagle-key-constants* by #'cddr
+ do (define-beagle-key (car key-binding) (cadr key-binding)))
+
+(defun get-key-name-from-cocoa-constants (ns-in)
+ (lookup-beagle-key ns-in))
More information about the Mcclim-cvs
mailing list