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 ,@args + ,@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))))