Author: junrue Date: Thu Jan 4 01:03:07 2007 New Revision: 424
Modified: trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: replace thread-context GFs with simple functions; add a thread-context slot for storing raw event data; move status-bar resizing logic from WM_SIZE process-message to top-level and dialog event-resize methods
Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Jan 4 01:03:07 2007 @@ -171,6 +171,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method))
+(defmethod event-resize (disp (self dialog) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner)
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jan 4 01:03:07 2007 @@ -502,13 +502,10 @@ ((= wparam gfs::+size-minimized+) :minimized) ((= wparam gfs::+size-restored+) :restored) (t nil)))) - (when (and w (not (typep w 'status-bar))) + (record-raw-event tc hwnd msg wparam lparam) + (when w (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) w (size-event-size tc) type) - (if (or (typep w 'top-level) (typep w 'dialog)) - (let ((sbar (status-bar-of w))) - (if sbar - (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ wparam lparam)))))) + (event-resize (dispatcher w) w (size-event-size tc) type))) 0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Jan 4 01:03:07 2007 @@ -33,11 +33,14 @@
(in-package #:graphic-forms.uitoolkit.widgets)
+(defstruct event (hwnd (cffi:null-pointer)) (msg 0) (wparam 0) (lparam 0)) + (defclass thread-context () ((child-visitor-func :initform nil :accessor child-visitor-func) (child-visitor-results :initform nil :accessor child-visitor-results) (display-visitor-func :initform nil :accessor display-visitor-func) (display-visitor-results :initform nil :accessor display-visitor-results) + (raw-event :initform (make-event) :reader raw-event) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) @@ -55,7 +58,7 @@ (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + (widget-in-progress :initform nil :accessor widget-in-progress)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
;; TODO: change this when CLISP acquires MT support @@ -107,32 +110,7 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil))
-(defgeneric init-utility-hwnd (self)) -(defgeneric call-child-visitor-func (self parent child)) -(defgeneric call-display-visitor-func (self hmonitor data)) -(defgeneric call-top-level-visitor-func (self window)) -(defgeneric get-widget (self hwnd)) -(defgeneric put-widget (self widget)) -(defgeneric delete-widget (self hwnd)) -(defgeneric widget-in-progress (self)) -(defgeneric (setf widget-in-progress) (widget self)) -(defgeneric clear-widget-in-progress (self)) -(defgeneric put-kbdnav-widget (self widget)) -(defgeneric delete-kbdnav-widget (self widget)) -(defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-item (self id)) -(defgeneric put-item (self item)) -(defgeneric delete-tc-item (self item)) -(defgeneric increment-item-id (self)) -(defgeneric put-job (self id closure)) -(defgeneric take-job (self id)) -(defgeneric increment-job-id (self)) -(defgeneric get-timer (self id)) -(defgeneric put-timer (self timer)) -(defgeneric delete-timer (self timer)) -(defgeneric increment-widget-id (self)) - -(defmethod init-utility-hwnd ((tc thread-context)) +(defun init-utility-hwnd (tc) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here "" ; because of circular dependency @@ -144,65 +122,57 @@ 0))) (setf (slot-value tc 'utility-hwnd) hwnd)))
-(defmethod call-child-visitor-func ((tc thread-context) parent child) +(defun call-child-visitor-func (tc parent child) (let ((func (child-visitor-func tc))) (if func (funcall func parent child) (warn 'gfs:toolkit-warning :detail "child visitor function is nil"))))
-(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) +(defun call-display-visitor-func (tc hmonitor data) (let ((func (display-visitor-func tc))) (if func (funcall func hmonitor data) (warn 'gfs:toolkit-warning :detail "display visitor function is nil"))))
-(defmethod call-top-level-visitor-func ((tc thread-context) win) +(defun call-top-level-visitor-func (tc win) (let ((func (top-level-visitor-func tc))) (if func (funcall func win) (warn 'gfs:toolkit-warning :detail "top-level visitor function is nil"))))
-(defmethod get-widget ((tc thread-context) hwnd) +(defun get-widget (tc hwnd) "Return the widget object corresponding to the specified native window handle." - (let ((tmp-widget (slot-value tc 'wip))) + (let ((tmp-widget (widget-in-progress tc))) (when tmp-widget (setf (slot-value tmp-widget 'gfs:handle) hwnd) (return-from get-widget tmp-widget))) (unless (gfs:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
-(defmethod put-widget ((tc thread-context) (w widget)) +(defun put-widget (tc w) "Add the specified widget to the widget table using its native handle as the key." (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w))
-(defmethod delete-widget ((tc thread-context) hwnd) +(defun delete-widget (tc hwnd) "Remove the widget object corresponding to the specified native window handle." - (when (not (slot-value tc 'wip)) + (when (not (widget-in-progress tc)) (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
-(defmethod widget-in-progress ((tc thread-context)) - "Return the widget currently under construction." - (slot-value tc 'wip)) - -(defmethod (setf widget-in-progress) ((w widget) (tc thread-context)) +(defun clear-widget-in-progress (tc) "Store the widget currently under construction." - (setf (slot-value tc 'wip) w)) + (setf (widget-in-progress tc) nil))
-(defmethod clear-widget-in-progress ((tc thread-context)) - "Store the widget currently under construction." - (setf (slot-value tc 'wip) nil)) - -(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) +(defun put-kbdnav-widget (tc widget) (if (find :keyboard-navigation (style-of widget)) (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc)))))
-(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget)) +(defun delete-kbdnav-widget (tc widget) (setf (kbdnav-widgets tc) (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) (kbdnav-widgets tc) :key #'gfs:handle)))
-(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) +(defun intercept-kbdnav-message (tc msg-ptr) (let ((widgets (kbdnav-widgets tc))) (unless widgets (return-from intercept-kbdnav-message nil)) @@ -217,15 +187,15 @@ (return-from intercept-kbdnav-message widget)))) nil)
-(defmethod get-item ((tc thread-context) id) +(defun get-item (tc id) "Returns the item identified by id." (gethash id (slot-value tc 'items-by-id)))
-(defmethod put-item ((tc thread-context) (it item)) +(defun put-item (tc it) "Stores an item using its id as the key." (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it))
-(defmethod delete-tc-item ((tc thread-context) (it item)) +(defun delete-tc-item (tc it) "Removes the item using its id as the key." (maphash #'(lambda (k v) @@ -234,37 +204,37 @@ (remhash k (slot-value tc 'items-by-id)))) (slot-value tc 'items-by-id)))
-(defmethod increment-item-id ((tc thread-context)) +(defun increment-item-id (tc) "Return the next menu item ID; also increment the internal value." (let ((id (next-item-id tc))) (incf (slot-value tc 'next-item-id)) id))
-(defmethod put-job ((tc thread-context) id closure) +(defun put-job (tc id closure) "Stores a closure using the specified ID for later retrieval." ;; FIXME: thread-safety (setf (gethash id (slot-value tc 'job-table)) closure))
-(defmethod take-job ((tc thread-context) id) +(defun take-job (tc id) (let ((closure (gethash id (slot-value tc 'job-table)))) (remhash id (slot-value tc 'job-table)) closure))
-(defmethod increment-job-id ((tc thread-context)) +(defun increment-job-id (tc) "Return the next job ID; also increment the internal value." (let ((id (next-job-id tc))) (incf (slot-value tc 'next-job-id)) id))
-(defmethod get-timer ((tc thread-context) id) +(defun get-timer (tc id) "Returns the timer identified by the specified (system-defined) id." (gethash id (slot-value tc 'timers-by-id)))
-(defmethod put-timer ((tc thread-context) (timer timer)) +(defun put-timer (tc timer) "Stores a timer using its id as the key." (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer))
-(defmethod delete-timer ((tc thread-context) (timer timer)) +(defun delete-timer (tc timer) "Removes the timer using its id as the key." (maphash #'(lambda (k v) @@ -273,8 +243,16 @@ (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id)))
-(defmethod increment-widget-id ((tc thread-context)) +(defun increment-widget-id (tc) "Return the next timer ID; also increment the internal value." (let ((id (next-widget-id tc))) (incf (slot-value tc 'next-widget-id)) id)) + +(defun record-raw-event (tc hwnd msg wparam lparam) + (let ((event (raw-event tc))) + (setf (event-hwnd event) hwnd + (event-msg event) msg + (event-wparam event) wparam + (event-lparam event) lparam) + event))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Jan 4 01:03:07 2007 @@ -137,6 +137,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method))
+(defmethod event-resize (disp (self top-level) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner)