Author: junrue Date: Tue May 16 12:08:55 2006 New Revision: 134
Modified: trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced display/top-level/child visit functions with mapcar-like replacements; implemented top-level disabling for :application-modal style
Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue May 16 12:08:55 2006 @@ -36,6 +36,8 @@ (defconstant +default-dialog-title+ " ") (defconstant +dlgwindowextra+ 48)
+(defvar *disabled-top-levels* nil) + ;;; ;;; helper functions ;;; @@ -66,13 +68,10 @@ (error 'gfs:disposed-error)))
(defmethod cancel-widget ((self dialog)) - (let ((def-widget nil)) - (visit-child-widgets self (lambda (parent kid) - (declare (ignore parent)) - (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) - gfs::+idcancel+) - (setf def-widget kid)))) - def-widget)) + (with-children (self kids) + (loop for kid in kids + until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+) + finally (return kid))))
(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -104,13 +103,10 @@ (error 'gfs:disposed-error)))
(defmethod default-widget ((self dialog)) - (let ((def-widget nil)) - (visit-child-widgets self (lambda (parent kid) - (declare (ignore parent)) - (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) - gfs::+idok+) - (setf def-widget kid)))) - def-widget)) + (with-children (self kids) + (loop for kid in kids + until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+) + finally (return kid))))
(defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) @@ -174,14 +170,18 @@ (owner (owner self)) (hdlg (gfs:handle self))) (cond - ((and app-modal owner) - ;; FIXME: need to save and restore each window's prior - ;; enabled state - ;; - (visit-top-level-windows (lambda (win) - (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) - (cffi:pointer-eq (gfs:handle win) hutility)) - (enable win (null flag)))))) + ((and app-modal flag) + (setf *disabled-top-levels* nil) + (maptoplevels (lambda (win) + (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) + (cffi:pointer-eq (gfs:handle win) hutility)) + (if (enabled-p win) + (push win *disabled-top-levels*)) + (enable win nil))))) + ((and app-modal (null flag)) + (loop for win in *disabled-top-levels* + do (enable win t)) + (setf *disabled-top-levels* nil)) ((and owner-modal owner) (enable owner (null flag)))) (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))
Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Tue May 16 12:08:55 2006 @@ -54,9 +54,9 @@ (call-display-visitor-func (thread-context) hmonitor data) 1)
-(defun visit-displays (func) +(defun mapdisplays (func) ;; - ;; supplied closure should expect two parameters: + ;; func should expect two parameters: ;; display handle ;; flag data ;; @@ -67,18 +67,18 @@ (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) #+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) - (setf (display-visitor-func tc) nil))) - nil) + (setf (display-visitor-func tc) nil)) + (let ((tmp (reverse (display-visitor-results tc)))) + (setf (display-visitor-results tc) nil) + tmp)))
(defun obtain-displays () - (let ((display-list nil)) - (visit-displays #'(lambda (hmonitor data) - (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) - gfs::+monitorinfoof-primary+)) - (display (make-instance 'display :handle hmonitor))) - (setf (slot-value display 'primary) pflag) - (push display display-list)))) - display-list)) + (mapdisplays (lambda (hmonitor data) + (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) + gfs::+monitorinfoof-primary+)) + (display (make-instance 'display :handle hmonitor))) + (setf (slot-value display 'primary) pflag) + (push display (display-visitor-results (thread-context)))))))
(defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) @@ -103,9 +103,9 @@ (call-top-level-visitor-func tc win))) 1)
-(defun visit-top-level-windows (func) +(defun maptoplevels (func) ;; - ;; supplied closure should expect one parameter: + ;; func should expect one parameter: ;; top-level window ;; (let ((tc (thread-context))) @@ -117,8 +117,10 @@ #+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) #'top_level_window_visitor 0) - (setf (top-level-visitor-func tc) nil))) - nil) + (setf (top-level-visitor-func tc) nil)) + (let ((tmp (reverse (top-level-visitor-results tc)))) + (setf (top-level-visitor-results tc) nil) + tmp)))
;;; ;;; methods
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue May 16 12:08:55 2006 @@ -34,24 +34,27 @@ (in-package #:graphic-forms.uitoolkit.widgets)
(defclass thread-context () - ((child-visitor-func :initform nil :accessor child-visitor-func) - (display-visitor-func :initform nil :accessor display-visitor-func) - (image-loaders-by-type :initform (make-hash-table :test #'equal)) - (job-table :initform (make-hash-table :test #'equal)) - (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) - (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) - (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) - (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) - (next-menuitem-id :initform 10000 :reader next-menuitem-id) - (next-widget-id :initform 100 :reader next-widget-id) - (size-event-size :initform (gfs:make-size) :accessor size-event-size) - (widgets-by-hwnd :initform (make-hash-table :test #'equal)) - (timers-by-id :initform (make-hash-table :test #'equal)) - (top-level-visitor-func :initform nil :accessor top-level-visitor-func) - (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + ((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) + (image-loaders-by-type :initform (make-hash-table :test #'equal)) + (job-table :initform (make-hash-table :test #'equal)) + (job-table-lock :initform nil) + (event-time :initform 0 :accessor event-time) + (virtual-key :initform 0 :accessor virtual-key) + (menuitems-by-id :initform (make-hash-table :test #'equal)) + (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) + (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) + (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-widget-id :initform 100 :reader next-widget-id) + (size-event-size :initform (gfs:make-size) :accessor size-event-size) + (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (timers-by-id :initform (make-hash-table :test #'equal)) + (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)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
;; TODO: change this when CLISP acquires MT support
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue May 16 12:08:55 2006 @@ -80,7 +80,7 @@ (call-child-visitor-func tc parent child))) 1)
-(defun visit-child-widgets (win func) +(defun mapchildren (win func) ;; ;; supplied closure should expect two parameters: ;; parent window object @@ -100,8 +100,10 @@ (gfs::enum-child-windows ptr #'child_window_visitor (cffi:pointer-address (gfs:handle win)))) - (setf (child-visitor-func tc) nil))) - nil) + (setf (child-visitor-func tc) nil)) + (let ((tmp (reverse (child-visitor-results tc)))) + (setf (child-visitor-results tc) nil) + tmp)))
(defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -144,12 +146,12 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) (let ((hwnd (gensym))) - `(let ((,var nil)) - (visit-child-widgets ,win (lambda (parent child) - (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+))) - (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) - (push child ,var))))) - (setf ,var (reverse ,var)) + `(let ((,var (mapchildren ,win (lambda (parent child) + (let ((,hwnd (gfs::get-ancestor + (gfs:handle child) + gfs::+ga-parent+))) + (if (cffi:pointer-eq (gfs:handle parent) ,hwnd) + (push child (child-visitor-results (thread-context))))))))) ,@body))))
;;;