Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms In directory clnet:/tmp/cvs-serv21895

Modified Files: gadgets.lisp graft.lisp medium.lisp port.lisp Log Message:

g-f fixes, including keyboard and mouse events.

* Backends/Graphic-Forms/gadgets.lisp (REALIZE-MIRROR): Spell gfw-scroll-bar correctly, with a dash.

* Backends/Graphic-Forms/graft.lisp (graft-height): Fixed order of arguments to gethash.

* Backends/Graphic-Forms/medium.lisp (sync-text-style): It's :sans-serif, not :sansserif. Use ECASE to avoid this going undetected. Allow family names that are strings, not symbols, and pass them through unchanged.

* Backends/Graphic-Forms/port.lisp (resolve-abstract-pane-name): Copy&paste from gtkairo. (make-pane-2): Call make-instance with a real class name, not the pane type spec. ((realize-mirror mirrored-sheet-mixin)): Removed the :border style. (port-frame-keyboard-input-focus, and its setf method): New methods. (translate-button-name, char-to-sym): New functions. (gfw:event-mouse-move, gfw:event-mouse-up, gfw:event-mouse-down, gfw:event-key-up, gfw:event-key-down): New methods.

--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/gadgets.lisp 2007/03/14 23:42:40 1.2 @@ -141,7 +141,7 @@ (defmethod realize-mirror ((port graphic-forms-port) (gadget scroll-bar)) (gfs::debug-format "realizing ~a~%" gadget) (let* ((parent-mirror (sheet-mirror (sheet-parent gadget))) - (mirror (make-instance 'gfw-scrollbar :parent parent-mirror :style :vertical))) + (mirror (make-instance 'gfw-scroll-bar :parent parent-mirror :style :vertical))) (climi::port-register-mirror port gadget mirror) mirror))

--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/graft.lisp 2007/03/14 23:42:40 1.2 @@ -37,7 +37,7 @@

(defmethod graft-height ((graft graphic-forms-graft) &key (units :device)) (gfw:with-root-window (window) - (let ((size (first (gethash (gfs:obtain-system-metrics) :display-sizes)))) + (let ((size (first (gethash :display-sizes (gfs:obtain-system-metrics))))) (gfw:with-graphics-context (gc window) (ecase units (:device (gfs:size-height size)) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp 2007/03/14 23:42:40 1.2 @@ -92,10 +92,12 @@ ;; (gfw:with-graphics-context (gc (climi::port-lookup-mirror (port-of medium) (medium-sheet medium))) (let ((old-data (if (font-of medium) (gfg:data-object (font-of medium) gc))) - (face-name (case family - ((:fix :fixed) "Lucida Console") - (:serif "Times New Roman") - (:sansserif "Arial"))) + (face-name (if (stringp family) + family + (ecase family + ((:fix :fixed) "Lucida Console") + (:serif "Times New Roman") + (:sans-serif "Arial")))) (pnt-size (case size (:tiny 6) (:very-small 8) --- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:33:25 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/14 23:42:40 1.2 @@ -122,10 +122,21 @@ (setf (get :graphic-forms :port-type) 'graphic-forms-port) (setf (get :graphic-forms :server-path-parser) 'parse-graphic-forms-server-path)

+(defun resolve-abstract-pane-name (type) + (when (get type 'climi::concrete-pane-class-name) + (setf type (get type 'climi::concrete-pane-class-name))) + (class-name + (or (find-class + (intern (concatenate 'string (symbol-name type) "-PANE") :climi) + nil) + (if (keywordp type) + (find-class (intern (symbol-name type) :climi)) + (find-class type))))) + (defgeneric make-pane-2 (type &rest initargs) (:documentation "Implement this to instantiate specific pane types.") (:method (type &rest initargs) - (apply #'make-instance type initargs))) + (apply #'make-instance (resolve-abstract-pane-name type) initargs)))

;;; ;;; helper functions @@ -211,7 +222,7 @@ (mirror (make-instance 'gfw-panel :sheet sheet :dispatcher *sheet-dispatcher* - :style '(:border) + :style '() ;was: '(:border) :parent parent))) (setf (gfw:size mirror) (requirement->size req)) (multiple-value-bind (x y) @@ -335,6 +346,16 @@

;;; Set the keyboard input focus for the port.

+(defmethod port-frame-keyboard-input-focus + ((port graphic-forms-port) frame) + ;; fixme + (frame-properties frame 'focus)) + +(defmethod (setf port-frame-keyboard-input-focus) + (focus (port graphic-forms-port) frame) + (gfw:give-focus (sheet-mirror focus)) + (setf (frame-properties frame 'focus) focus)) + (defmethod %set-port-keyboard-focus (focus (port graphic-forms-port) &key timestamp) (declare (ignore timestamp)) ()) @@ -420,6 +441,109 @@ :sheet (sheet (gfw:owner mirror)) :item (sheet mirror))))

+(defun translate-button-name (name) + (case name + (:left-button +pointer-left-button+) + (:right-button +pointer-right-button+) + (:middle-button +pointer-middle-button+) + (t + (warn "unknown button name: ~A" name) + nil))) + +(defmethod gfw:event-mouse-move + ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-motion-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-press-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button) + (setf (event (port self)) + (make-instance 'pointer-button-release-event + :pointer 0 + :sheet (sheet mirror) + :x (gfs:point-x point) + :y (gfs:point-y point) + :button (translate-button-name button) + ;; FIXME: +;;; :timestamp +;;; :graft-x +;;; :graft-y + :modifier-state 0 + ))) + +(defun char-to-sym (char) + (case char + (#\ :| |) (#! :!) (#" :|"|) (## :|#|) (#$ :$) (#% :%) (#& :&) + (#' :|'|) (#( :|(|) (#) :|)|) (#* :*) (#+ :+) (#, :|,|) (#- :-) + (#. :|.|) (#/ :/) (#\0 :|0|) (#\1 :|1|) (#\2 :|2|) (#\3 :|3|) (#\4 :|4|) + (#\5 :|5|) (#\6 :|6|) (#\7 :|7|) (#\8 :|8|) (#\9 :|9|) (#: :|:|) (#; :|;|) + (#< :<) (#= :=) (#> :>) (#? :?) (#@ :@) (#\A :A) (#\B :B) (#\C :C) + (#\D :D) (#\E :E) (#\F :F) (#\G :G) (#\H :H) (#\I :I) (#\J :J) (#\K :K) + (#\L :L) (#\M :M) (#\N :N) (#\O :O) (#\P :P) (#\Q :Q) (#\R :R) (#\S :S) + (#\T :T) (#\U :U) (#\V :V) (#\W :W) (#\X :X) (#\Y :Y) (#\Z :Z) (#[ :[) + (#\ :|\|) (#] :]) (#_ :_) (#` :|`|) (#\a :|a|) (#\b :|b|) (#\c :|c|) + (#\d :|d|) (#\e :|e|) (#\f :|f|) (#\g :|g|) (#\h :|h|) (#\i :|i|) (#\j :|j|) + (#\k :|k|) (#\l :|l|) (#\m :|m|) (#\n :|n|) (#\o :|o|) (#\p :|p|) (#\q :|q|) + (#\r :|r|) (#\s :|s|) (#\t :|t|) (#\u :|u|) (#\v :|v|) (#\w :|w|) (#\x :|x|) + (#\y :|y|) (#\z :|z|) (#{ :{) (#| :|||) (#} :}) (#\Backspace :BACKSPACE) + (#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE))) + +(defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-press-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + +(defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char) + (setf (event (port self)) + (make-instance 'key-release-event + :key-name (char-to-sym char) + :key-character char + :sheet (sheet mirror) + ;; FIXME: + :x 0 + :y 0 + :modifier-state 0 +;;; :timestamp time +;;; :graft-x root-x +;;; :graft-y root-y + ))) + + ;;; ;;; McCLIM handle-event methods ;;;