[graphic-forms-cvs] r424 - trunk/src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Jan 4 06:03:08 UTC 2007
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)
More information about the Graphic-forms-cvs
mailing list