[mcclim-cvs] CVS mcclim
tmoore
tmoore at common-lisp.net
Wed Mar 15 15:38:39 UTC 2006
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv18917
Modified Files:
builtin-commands.lisp commands.lisp decls.lisp frames.lisp
mcclim.asd presentation-defs.lisp presentations.lisp
stream-input.lisp system.lisp utils.lisp
Log Message:
Fixed destination highlighting for drag-and-drop translators. Added documentation for dnd translators. Corrected the default value for modifier-state in find-innermost-applicable-presentation and friends. This isn't as big as it looks :)
--- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2005/06/22 11:41:34 1.20
+++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/03/15 15:38:38 1.21
@@ -136,7 +136,9 @@
:for-menu t))
;;; Action for possibilities menu of complete-input
-
+;;;
+;;; XXX The context type needs to change to COMPLETER or something so that this
+;;; isn't applicable all over the place.
(define-presentation-action possibilities-menu
(blank-area nil global-command-table
:documentation "Possibilities menu for completion"
--- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/10 21:58:12 1.58
+++ /project/mcclim/cvsroot/mcclim/commands.lisp 2006/03/15 15:38:39 1.59
@@ -178,19 +178,6 @@
:menu ',menu
:errorp nil))))
-(defun command-name-from-symbol (symbol)
- (let ((name (symbol-name symbol)))
- (string-capitalize
- (substitute
- #\Space #\-
- (subseq name (if (string= "COM-" name :end2 (min (length name) 4))
- 4
- 0))))))
-
-(defun keyword-arg-name-from-symbol (symbol)
- (let ((name (symbol-name symbol)))
- (string-capitalize (substitute #\Space #\- name))))
-
(defun remove-command-from-command-table (command-name
command-table
&key (errorp t))
--- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/10 21:58:12 1.36
+++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/03/15 15:38:39 1.37
@@ -502,6 +502,10 @@
(defgeneric port-disable-sheet (port sheet))
(defgeneric port-pointer (port))
+(defgeneric pointer-update-state (pointer event)
+ (:documentation "Called by port event dispatching code to update the modifier
+and button states of the pointer."))
+
;;;
;; Used in stream-input.lisp, defined in frames.lisp
--- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/13 06:08:12 1.116
+++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/15 15:38:39 1.117
@@ -1460,17 +1460,19 @@
;;; Classic CLIM seems to agree. -- moore
(defun highlight-for-tracking-pointer (frame stream event input-context
highlight)
- (let ((context-ptype (input-context-type (car input-context)))
- (presentation nil)
+ (let ((presentation nil)
(current-hilited (frame-hilited-presentation frame)))
(when (output-recording-stream-p stream)
- (setq presentation (find-innermost-applicable-presentation
- input-context
- stream
- (device-event-x event)
- (device-event-y event)
- :frame frame
- :event event)))
+ ;; XXX Massive hack to prevent the presentation action for completions
+ ;; from being applicable. After the .9.2.2 release that action will have
+ ;; a more restrictive context type.
+ (let ((*completion-possibilities-continuation* nil))
+ (setq presentation (find-innermost-applicable-presentation
+ input-context
+ stream
+ (device-event-x event)
+ (device-event-y event)
+ :frame frame))))
(when (and current-hilited (not (eq (car current-hilited) presentation)))
(highlight-presentation-1 (car current-hilited)
(cdr current-hilited)
@@ -1641,7 +1643,7 @@
(tracking-pointer (window :context-type `(or ,(mapcar #'from-type
translators))
:highlight nil
- :multiple-window t)
+ :multiple-window nil) ;XXX
(:presentation (&key presentation window event x y)
(let ((dest-translator (find-dest-translator presentation window
x y)))
--- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/10 21:58:13 1.8
+++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/15 15:38:39 1.9
@@ -321,7 +321,8 @@
(:file "presentation-test")
#+clx (:file "gadget-test")
(:file "accepting-values")
- (:file "method-browser")))))
+ (:file "method-browser")
+ (:file "dragndrop-translator")))))
;;; This won't load in SBCL, either. I have really crappy code to
;;; extract dependency information from :serial t ASDF systems, but
--- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/12 23:09:27 1.52
+++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/15 15:38:39 1.53
@@ -2047,7 +2047,7 @@
(gesture :select)
(tester 'default-translator-tester)
documentation
- pointer-documentation
+ (pointer-documentation nil pointer-doc-p)
(menu t)
(priority 0)
(feedback 'frame-drag-and-drop-feedback)
@@ -2056,14 +2056,25 @@
&body body)
(declare (ignore tester gesture documentation pointer-documentation
menu priority))
- (let ((real-dest-type (expand-presentation-type-abbreviation
- destination-type)))
-
- (with-keywords-removed (args (:feedback :highlighting))
+ (let* ((real-dest-type (expand-presentation-type-abbreviation
+ destination-type))
+ (name-string (command-name-from-symbol name))
+ (drag-string (format nil "Drag to ~A" name-string))
+ (pointer-doc (if pointer-doc-p
+ nil
+ `(:pointer-documentation
+ ((object destination-object stream)
+ (declare (ignore object))
+ (write-string (if destination-object
+ ,name-string
+ ,drag-string)
+ stream))))))
+ (with-keywords-removed (args (:feedback :highlighting))
`(progn
(define-presentation-translator ,name
(,from-type ,to-type ,command-table
, at args
+ , at pointer-doc
:feedback #',feedback :highlighting #',highlighting
:destination-ptype ',real-dest-type
:destination-translator #',(make-translator-fun arglist body)
--- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/12 23:09:27 1.73
+++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/15 15:38:39 1.74
@@ -1598,8 +1598,6 @@
x y)
context-type))
(return-from test-presentation-translator nil))))
-
-
t)
;;; presentation-contains-position moved to presentation-defs.lisp
@@ -1661,9 +1659,14 @@
presentation
x y)))))
+(defun window-modifier-state (window)
+ "Provides default modifier state for presentation translator functions."
+ (let ((pointer (port-pointer (port window))))
+ (pointer-modifier-state pointer)))
+
(defun find-applicable-translators
(presentation input-context frame window x y
- &key event (modifier-state 0) for-menu fastp)
+ &key event (modifier-state (window-modifier-state window)) for-menu fastp)
(let ((results nil))
(flet ((fast-func (translator presentation context)
(declare (ignore translator presentation context))
@@ -1751,7 +1754,9 @@
(defun find-innermost-applicable-presentation
(input-context window x y
- &key (frame *application-frame*) modifier-state event)
+ &key (frame *application-frame*)
+ (modifier-state (window-modifier-state window))
+ event)
(values (find-innermost-presentation-match input-context
(stream-output-history window)
frame
@@ -1761,12 +1766,13 @@
modifier-state
nil)))
-(defun find-innermost-presentation-context (input-context window x y
- &key
- (top-record
- (stream-output-history window))
- (frame *application-frame*)
- event modifier-state button)
+(defun find-innermost-presentation-context
+ (input-context window x y
+ &key (top-record (stream-output-history window))
+ (frame *application-frame*)
+ event
+ (modifier-state (window-modifier-state window))
+ button)
(find-innermost-presentation-match input-context
top-record
frame
--- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/10 21:58:13 1.44
+++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2006/03/15 15:38:39 1.45
@@ -644,7 +644,10 @@
;;; backends.
(defclass standard-pointer (pointer)
- ((port :reader port :initarg :port)))
+ ((port :reader port :initarg :port)
+ (state-lock :reader state-lock :initform (make-lock "pointer lock"))
+ (button-state :initform 0 )
+ (modifier-state :initform 0)))
(defgeneric pointer-sheet (pointer))
@@ -680,8 +683,37 @@
(with-accessors ((port-pointer-sheet port-pointer-sheet))
(port sheet)
(when (eq port-pointer-sheet sheet)
+
(setq port-pointer-sheet nil))))
+(defmethod pointer-button-state ((pointer standard-pointer))
+ (with-lock-held ((state-lock pointer))
+ (slot-value pointer 'button-state)))
+
+(defmethod pointer-modifier-state ((pointer standard-pointer))
+ (with-lock-held ((state-lock pointer))
+ (slot-value pointer 'modifier-state)))
+
+(defmethod pointer-update-state
+ ((pointer standard-pointer) (event keyboard-event))
+ (with-lock-held ((state-lock pointer))
+ (setf (slot-value pointer 'modifier-state) (event-modifier-state event))))
+
+(defmethod pointer-update-state
+ ((pointer standard-pointer) (event pointer-button-press-event))
+ (with-lock-held ((state-lock pointer))
+ (setf (slot-value pointer 'button-state)
+ (logior (slot-value pointer 'button-state)
+ (pointer-event-button event)))))
+
+(defmethod pointer-update-state
+ ((pointer standard-pointer) (event pointer-button-release-event))
+ (with-lock-held ((state-lock pointer))
+ (setf (slot-value pointer 'button-state)
+ (logandc2 (slot-value pointer 'button-state)
+ (pointer-event-button event)))))
+
+(defmethod pointer-butt)
(defgeneric stream-pointer-position (stream &key pointer))
(defmethod stream-pointer-position ((stream standard-extended-input-stream)
--- /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/10 21:58:13 1.113
+++ /project/mcclim/cvsroot/mcclim/system.lisp 2006/03/15 15:38:39 1.114
@@ -89,6 +89,7 @@
(clim-defsystem (:clim-core :depends-on (:clim-lisp))
"decls"
+ "protocol-classes"
#.(or
#+(and :cmu :mp (not :pthread)) "Lisp-Dep/mp-cmu"
@@ -213,6 +214,7 @@
"Examples/dragndrop"
"Examples/gadget-test"
"Examples/method-browser"
+ "Examples/dragndrop-translator"
"Goatee/goatee-test"
"Examples/accepting-values")
--- /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/10 21:58:13 1.43
+++ /project/mcclim/cvsroot/mcclim/utils.lisp 2006/03/15 15:38:39 1.44
@@ -574,3 +574,18 @@
(intern (symbol-name obj) :keyword))
(string
(intern (string-upcase obj) :keyword))))
+
+;;; Command name utilities that are useful elsewhere.
+
+(defun command-name-from-symbol (symbol)
+ (let ((name (symbol-name symbol)))
+ (string-capitalize
+ (substitute
+ #\Space #\-
+ (subseq name (if (string= '#:com- name :end2 (min (length name) 4))
+ 4
+ 0))))))
+
+(defun keyword-arg-name-from-symbol (symbol)
+ (let ((name (symbol-name symbol)))
+ (string-capitalize (substitute #\Space #\- name))))
More information about the Mcclim-cvs
mailing list