graphic-forms-cvs May 2006

graphic-forms-cvs@common-lisp.net

1 participants
27 discussions

[graphic-forms-cvs] r131 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 14 May '06

14 May '06

Author: junrue Date: Sun May 14 00:12:08 2006 New Revision: 131 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented :callback initarg for control initializer; got the initial focus, IDCANCEL, and IDOK button behaviors working in modal dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun May 14 00:12:08 2006 @@ -183,6 +183,14 @@ @deffn Initarg :image @end deffn @deffn Initarg :style +@table @code +@item :cancel-button +@item :check-box +@item :default-button +@item :push-button +@item :radio-button +@item :toggle-button +@end table @end deffn @deffn Initarg :text @end deffn @@ -742,6 +750,12 @@ Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn +@deffn GenericFunction cancel-widget self +Returns the @ref{widget} that responds to the @sc{esc} key or +otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this +widget must be a @ref{button} and is typically labelled @emph{Cancel}. +@end deffn + @anchor{center-on-owner} @deffn GenericFunction center-on-owner self Position @code{self} such that it is centrally located relative to its Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun May 14 00:12:08 2006 @@ -92,14 +92,14 @@ (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) - #'(lambda () - (if (null flag) - (progn - (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) - (progn - (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun May 14 00:12:08 2006 @@ -139,12 +139,6 @@ (call-next-method) (gfs:dispose dlg)) -(defun btn-callback (disp btn time rect) - (declare (ignore disp time rect)) - (let ((dlg (gfw:parent btn))) - (gfw:show dlg nil) - (gfs:dispose dlg))) - (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -163,15 +157,20 @@ :style '(:vertical)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback #'btn-callback + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback #'btn-callback - :style '(:push-button) + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) + :style '(:cancel-button) :text "Cancel" :parent btn-panel))) + (declare (ignore panel ok-btn cancel-btn)) (gfw:pack dlg) (gfw:center-on-owner dlg) (gfw:show dlg t) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun May 14 00:12:08 2006 @@ -832,6 +832,7 @@ (defconstant +wm-syschar+ #x0106) (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message +(defconstant +wm-initdialog+ #x0110) (defconstant +wm-command+ #x0111) (defconstant +wm-syscommand+ #x0112) (defconstant +wm-timer+ #x0113) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun May 14 00:12:08 2006 @@ -552,6 +552,11 @@ (lparam WPARAM)) (defcfun + ("SetActiveWindow" set-active-window) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun May 14 00:12:08 2006 @@ -49,7 +49,7 @@ (setf std-flags (logior std-flags gfs::+bs-checkbox+))) ((eq sym :default-button) (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) - ((eq sym :push-button) + ((or (eq sym :push-button) (eq sym :cancel-button)) (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) @@ -67,7 +67,13 @@ (gfs:handle parent) std-style ex-style - (increment-widget-id (thread-context))))) + (cond + ((find :default-button (style-of btn)) + gfs::+idok+) + ((find :cancel-button (style-of btn)) + gfs::+idcancel+) + (t + (increment-widget-id (thread-context))))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun May 14 00:12:08 2006 @@ -136,9 +136,12 @@ (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) (error 'gfs:toolkit-error "set-focus failed"))) -(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) - (error 'gfs:disposed-error))) + (error 'gfs:disposed-error)) + (unless (or disp callbacks (not (functionp callback))) + (let ((class (define-dispatcher `((event-select . ,callback))))) + (setf (dispatcher ctrl) (make-instance (class-name class)))))) (defmethod preferred-size :before ((ctrl control) width-hint height-hint) (declare (ignorable width-hint height-hint)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun May 14 00:12:08 2006 @@ -61,9 +61,43 @@ (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) -(defmethod event-close ((self event-dispatcher) (dlg dialog) time) - (declare (ignore time)) - (show dlg nil)) +(defmethod cancel-widget :before ((self dialog)) + (if (gfs:disposed-p self) + (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)) + +(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) + (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) + (error 'gfs:disposed-error))) + +(defmethod (setf cancel-widget) ((cancel-widget widget) (self dialog)) + (when (or (not (typep cancel-widget 'button)) + (and (style-of cancel-widget) + (null (intersection '(:push-button :cancel-button :default-button) + (style-of cancel-widget))))) + (warn 'gfs:toolkit-warning :detail "only push buttons may serve as cancel widgets in a dialog") + (return-from cancel-widget nil)) + (let ((old-widget (cancel-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) + (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (let* ((hwnd (gfs:handle cancel-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logior style gfs::+bs-pushbutton+)) + (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -85,24 +119,31 @@ (defmethod (setf default-widget) ((def-widget widget) (self dialog)) (when (or (not (typep def-widget 'button)) (and (style-of def-widget) - (null (find :push-button (style-of def-widget))))) + (null (intersection '(:push-button :cancel-button :default-button) + (style-of def-widget))))) (warn 'gfs:toolkit-warning :detail "only push buttons may serve as default widgets in a dialog") (return-from default-widget nil)) - (let ((old-def-widget (default-widget self))) - (if old-def-widget - (let* ((hwnd (gfs:handle old-def-widget)) + (let ((old-widget (default-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) (style (gfs::get-window-long hwnd gfs::+gwl-style+))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) (style (gfs::get-window-long hwnd gfs::+gwl-style+))) (setf style (logior style gfs::+bs-defpushbutton+)) + (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address hwnd) 1) (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) +(defmethod gfs:dispose ((self dialog)) + (if (visible-p self) + (show self nil)) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) @@ -121,6 +162,10 @@ ;; (init-window self +dialog-classname+ #'register-dialog-class owner text)) +(defmethod event-close ((self event-dispatcher) (dlg dialog) time) + (declare (ignore time)) + (show dlg nil)) + (defmethod show ((self dialog) flag) (let* ((tc (thread-context)) (hutility (utility-hwnd tc)) @@ -139,7 +184,10 @@ (enable win (null flag)))))) ((and owner-modal owner) (enable owner (null flag)))) - (call-next-method) + (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)) + (let ((focus-hwnd (gfs::get-next-dlg-tab-item hdlg (cffi:null-pointer) 0))) + (unless (gfs:null-handle-p focus-hwnd) + (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address focus-hwnd) 1))) (when (and flag (or app-modal owner-modal)) (message-loop (lambda (gm-code msg-ptr) (cond Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun May 14 00:12:08 2006 @@ -35,7 +35,7 @@ (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:item integer gfs:rectangle)))) + (gfw:event-select . (gfw:event-source integer gfs:rectangle)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -69,8 +69,8 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) - (unless (null callbacks) +(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys) + (unless (or disp (null callbacks)) (let ((class (define-dispatcher callbacks))) (setf (dispatcher self) (make-instance (class-name class)))))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 14 00:12:08 2006 @@ -167,6 +167,13 @@ (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) +#| +(defmethod process-message (hwnd (msg (eql gfs::+wm-initdialog+)) wparam lparam) + (declare (ignore hwnd lparam)) + (format t "WM_INITDIALOG: ~x~%" wparam) + 1) +|# + (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignore hwnd lparam)) (let* ((tc (thread-context)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun May 14 00:12:08 2006 @@ -292,8 +292,7 @@ (error 'gfs:disposed-error))) (defmethod show ((w widget) flag) - (gfs::show-window (gfs:handle w) - (if flag gfs::+sw-showna+ gfs::+sw-hide+))) + (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+))) (defmethod update :before ((w widget)) (if (gfs:disposed-p w)

1 0

[graphic-forms-cvs] r130 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 14 May '06

14 May '06

Author: junrue Date: Sat May 13 19:57:06 2006 New Revision: 130 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: progress towards proper keyboard traversal in dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat May 13 19:57:06 2006 @@ -276,7 +276,7 @@ @anchor{file-dialog} @deftp Class file-dialog open-mode -This class provides a standard @ref{dialog} for navigating the file +This class provides a standard dialog for navigating the file system to select or enter file names. A variety of configurations are possible; however, please note that the following behaviors are implemented regardless of other style flags or initarg values: @@ -290,9 +290,14 @@ steps manually, in which case the @ref{file-dialog-paths} function can be used to obtain the user's selection(s). Unless the @code{:multiple-select} style keyword is specified, there will at most -be one selected file returned, and possibly zero if the user cancelled -the dialog. Also, manual construction of an instance must be followed -by an explicit call to @ref{dispose}.@*@* +be one selected file returned. In either case, zero is returned if the +user cancelled the dialog. Also, manual construction of an instance +must be followed by an explicit call to @ref{dispose}.@*@* +Like other system dialogs, @code{file-dialog} is derived from @ref{widget} +rather than @ref{dialog} since the majority of its functionality is +implemented by the system and is not directly extensible by applications. +@strong{NOTE:} A future release of Graphic-Forms will provide a +customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if the user fails to provide one. Any embedded periods @samp{.} will @@ -783,11 +788,12 @@ enclose the specified desired client area and this object's trim. @end deffn -@deffn GenericFunction default-button self button -Returns the default @ref{button} set for a @ref{dialog}, or @sc{nil} -if none has been set. If @code{button} is @sc{nil}, then no default -button is set. The default button is the button that is selected when -@code{self} is active and the user presses @sc{enter}. +@deffn GenericFunction default-widget self +Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} +if none has been set. If @sc{nil} is passed to the corresponding +@sc{setf} function, then no default widget is set. The default widget +is the one that is selected when @code{self} is active and the user +presses @sc{enter}. @end deffn @deffn GenericFunction display-to-object self pnt Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat May 13 19:57:06 2006 @@ -341,8 +341,8 @@ #:current-font #:cursor #:cut - #:default-item #:default-message-filter + #:default-widget #:defmenu #:delay-of #:disabled-image Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 19:57:06 2006 @@ -164,6 +164,7 @@ :parent dlg)) (ok-btn (make-instance 'gfw:button :callback #'btn-callback + :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat May 13 19:57:06 2006 @@ -72,6 +72,15 @@ (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) +(defconstant +bm-getcheck+ #x00f0) +(defconstant +bm-setcheck+ #x00f1) +(defconstant +bm-getstate+ #x00f2) +(defconstant +bm-setstate+ #x00f3) +(defconstant +bm-setstyle+ #x00f4) +(defconstant +bm-click+ #x00f5) +(defconstant +bm-getimage+ #x00f6) +(defconstant +bm-setimage+ #x00f7) + (defconstant +bs-solid+ 0) (defconstant +bs-null+ 1) (defconstant +bs-hollow+ 1) @@ -113,6 +122,12 @@ (defconstant +bs-flat+ #x00008000) (defconstant +bs-rightbutton+ #x00000020) +(defconstant +bst-unchecked+ #x0000) +(defconstant +bst-checked+ #x0001) +(defconstant +bst-indeterminate+ #x0002) +(defconstant +bst-pushed+ #x0004) +(defconstant +bst-focus+ #x0008) + (defconstant +cbm-init+ #x04) (defconstant +cchdevicename+ 32) @@ -194,6 +209,10 @@ (defconstant +dib-rgb-colors+ 0) (defconstant +dib-pal-colors+ 1) +(defconstant +dm-getdefid+ #x0400) +(defconstant +dm-setdefid+ #x0401) +(defconstant +dm-reposition+ #x0402) + (defconstant +dt-top+ #x00000000) (defconstant +dt-left+ #x00000000) (defconstant +dt-center+ #x00000001) @@ -292,6 +311,19 @@ (defconstant +hs-cross+ 4) (defconstant +hs-diagcross+ 5) +(defconstant +idok+ 1) +(defconstant +idcancel+ 2) +(defconstant +idabort+ 3) +(defconstant +idretry+ 4) +(defconstant +idignore+ 5) +(defconstant +idyes+ 6) +(defconstant +idno+ 7) +(defconstant +idclose+ 8) +(defconstant +idhelp+ 9) +(defconstant +idtryagain+ 10) +(defconstant +idcontinue+ 11) +(defconstant +idtimeout+ 32000) + (defconstant +image-bitmap+ 0) (defconstant +image-icon+ 1) (defconstant +image-cursor+ 2) @@ -766,6 +798,15 @@ (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) (defconstant +wm-getminmaxinfo+ #x0024) +(defconstant +wm-painticon+ #x0026) +(defconstant +wm-iconerasebkgnd+ #x0027) +(defconstant +wm-nextdlgctl+ #x0028) +(defconstant +wm-spoolerstatus+ #x002A) +(defconstant +wm-drawitem+ #x002B) +(defconstant +wm-measureitem+ #x002C) +(defconstant +wm-deleteitem+ #x002D) +(defconstant +wm-vkeytoitem+ #x002E) +(defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) (defconstant +wm-ncmousemove+ #x00A0) @@ -848,8 +889,10 @@ (defconstant +ws-hscroll+ #x00100000) (defconstant +ws-sysmenu+ #x00080000) (defconstant +ws-thickframe+ #x00040000) +(defconstant +ws-group+ #x00020000) (defconstant +ws-minimizebox+ #x00020000) (defconstant +ws-maximizebox+ #x00010000) +(defconstant +ws-tabstop+ #x00010000) (defconstant +ws-popupwindow+ #x80880000) (defconstant +ws-overlappedwindow+ #x00CF0000) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat May 13 19:57:06 2006 @@ -108,6 +108,14 @@ (flags UINT)) (defcfun + ("DefDlgProcA" def-dlg-proc) + LRESULT + (hwnd HANDLE) + (msg UINT) + (wp WPARAM) + (lp LPARAM)) + +(defcfun ("DefWindowProcA" def-window-proc) LRESULT (hwnd HANDLE) @@ -367,6 +375,13 @@ (monitor-info LPTR)) (defcfun + ("GetNextDlgTabItem" get-next-dlg-tab-item) + HANDLE + (hdlg HANDLE) + (hctl HANDLE) + (flag BOOL)) + +(defcfun ("GetParent" get-parent) HANDLE (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 19:57:06 2006 @@ -39,7 +39,8 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (style (style-of btn))) (loop for sym in (style-of btn) do (cond ;; primary button styles @@ -54,6 +55,8 @@ (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) ((eq sym :toggle-button) (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (if (null style) + (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) (defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) @@ -63,9 +66,12 @@ (or text " ") (gfs:handle parent) std-style - ex-style))) + ex-style + (increment-widget-id (thread-context))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) + (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) + (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) (setf (slot-value btn 'gfs:handle) hwnd))) (init-control btn)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sat May 13 19:57:06 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.widgets) (defconstant +default-dialog-title+ " ") +(defconstant +dlgwindowextra+ 48) ;;; ;;; helper functions @@ -45,7 +46,8 @@ (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ gfs::+cs-bytealignwindow+) - gfs::+color-btnface+)) + gfs::+color-btnface+ + +dlgwindowextra+)) ;;; ;;; methods @@ -63,7 +65,45 @@ (declare (ignore time)) (show dlg nil)) -(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys) +(defmethod default-widget :before ((self dialog)) + (if (gfs:disposed-p self) + (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)) + +(defmethod (setf default-widget) :before ((def-widget widget) (self dialog)) + (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) + (error 'gfs:disposed-error))) + +(defmethod (setf default-widget) ((def-widget widget) (self dialog)) + (when (or (not (typep def-widget 'button)) + (and (style-of def-widget) + (null (find :push-button (style-of def-widget))))) + (warn 'gfs:toolkit-warning :detail "only push buttons may serve as default widgets in a dialog") + (return-from default-widget nil)) + (let ((old-def-widget (default-widget self))) + (if old-def-widget + (let* ((hwnd (gfs:handle old-def-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (let* ((hdlg (gfs:handle self)) + (hwnd (gfs:handle def-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logior style gfs::+bs-defpushbutton+)) + (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) + (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address hwnd) 1) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + +(defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -75,14 +115,19 @@ ;; (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) (setf owner nil)) - (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) + ;; FIXME: check if owner is actually a top-level or dialog, and if not, + ;; walk up the ancestors until one is found. Only top level hwnds can + ;; be owners. + ;; + (init-window self +dialog-classname+ #'register-dialog-class owner text)) -(defmethod show ((dlg dialog) flag) - (let ((hutility (utility-hwnd (thread-context))) - (app-modal (find :application-modal (style-of dlg))) - (owner-modal (find :owner-modal (style-of dlg))) - (owner (owner dlg)) - (hdlg (gfs:handle dlg))) +(defmethod show ((self dialog) flag) + (let* ((tc (thread-context)) + (hutility (utility-hwnd tc)) + (app-modal (find :application-modal (style-of self))) + (owner-modal (find :owner-modal (style-of self))) + (owner (owner self)) + (hdlg (gfs:handle self))) (cond ((and app-modal owner) ;; FIXME: need to save and restore each window's prior @@ -98,7 +143,7 @@ (when (and flag (or app-modal owner-modal)) (message-loop (lambda (gm-code msg-ptr) (cond - ((or (gfs:disposed-p dlg) (not (visible-p dlg))) + ((or (gfs:disposed-p self) (not (visible-p self))) t) ; dialog closed, so exit loop ((zerop gm-code) ;; IMPORTANT: allow WM_QUIT to propagate back through @@ -114,7 +159,7 @@ ((= gm-code -1) (warn 'gfs:win32-warning :detail "get-message failed") t) - ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0) + ((/= (gfs::is-dialog-message (gfs:handle self) msg-ptr) 0) ;; It was a dialog message and has been processed, ;; so nothing else to do. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 19:57:06 2006 @@ -123,6 +123,9 @@ ;;; (defmethod process-message (hwnd msg wparam lparam) + (let ((w (get-widget (thread-context) hwnd))) + (if (typep w 'dialog) + (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) (gfs::def-window-proc hwnd msg wparam lparam)) (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) @@ -139,7 +142,6 @@ (wparam-hi (hi-word wparam)) (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) -(format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner (cond ((zerop lparam) @@ -152,7 +154,7 @@ (event-time tc) (make-instance 'gfs:rectangle)))))) ; FIXME ((eq wparam-hi 1) - (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) + (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) @@ -186,8 +188,9 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (declare (ignore wparam lparam)) - (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot + (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep w 'dialog) + (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Sat May 13 19:57:06 2006 @@ -160,7 +160,8 @@ (or text " ") (gfs:handle parent) (logior std-style) - ex-style))) + ex-style + (increment-widget-id (thread-context))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value label 'gfs:handle) hwnd) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sat May 13 19:57:06 2006 @@ -59,7 +59,7 @@ ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) (style-of self)) - (values std-flags 0))) + (values std-flags gfs::+ws-ex-controlparent+))) (defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) (if (null parent) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat May 13 19:57:06 2006 @@ -93,6 +93,12 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass file-dialog (widget) + ((open-mode + :reader open-mode + :initform t)) + (:documentation "This class represents the standard file open/save dialog.")) + (defclass widget-with-items (widget) ((items :accessor items @@ -116,12 +122,6 @@ (defclass dialog (window) () (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) -(defclass file-dialog (dialog) - ((open-mode - :reader open-mode - :initform t)) - (:documentation "This class represents the standard file open/save dialog.")) - (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat May 13 19:57:06 2006 @@ -120,8 +120,8 @@ (defgeneric cut (self) (:documentation "Copies the current selection to the clipboard and removes it from the object.")) -(defgeneric default-item (self) - (:documentation "Returns the item in this object that has the default emphasis.")) +(defgeneric default-widget (self) + (:documentation "Returns the child widget or item that has the default emphasis.")) (defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat May 13 19:57:06 2006 @@ -82,7 +82,7 @@ ex-style cname-ptr title-ptr - std-style + (if child-id (logior std-style gfs::+ws-tabstop+) std-style) gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+ Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat May 13 19:57:06 2006 @@ -145,10 +145,10 @@ (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))))) + (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)) ,@body))))

1 0

[graphic-forms-cvs] r129 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 13 May '06

13 May '06

Author: junrue Date: Sat May 13 12:50:58 2006 New Revision: 129 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implement :text initarg for buttons; generalize timer id counter in thread-context to all widgets except menu items; specify a runtime-unique ID for every widget; assorted bug fixes for WM_COMMAND process-message Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat May 13 12:50:58 2006 @@ -175,9 +175,17 @@ @strong{NOTE:} A future release will provide additional widget classes. +@anchor{button} @deftp Class button This @ref{control} class represents selectable controls that issue -notifications when clicked. +notifications when clicked.@*@* +The following initargs are supported: +@deffn Initarg :image +@end deffn +@deffn Initarg :style +@end deffn +@deffn Initarg :text +@end deffn @end deftp @anchor{control} @@ -711,10 +719,6 @@ @node widget functions @section widget functions -@strong{NOTE:} There are (and will be) additional widget methods defined -in future releases, they just aren't all documented or implemented at -this time. - @deffn GenericFunction ancestor-p ancestor descendant Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn @@ -779,6 +783,13 @@ enclose the specified desired client area and this object's trim. @end deffn +@deffn GenericFunction default-button self button +Returns the default @ref{button} set for a @ref{dialog}, or @sc{nil} +if none has been set. If @code{button} is @sc{nil}, then no default +button is set. The default button is the button that is selected when +@code{self} is active and the user presses @sc{enter}. +@end deffn + @deffn GenericFunction display-to-object self pnt Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 12:50:58 2006 @@ -139,6 +139,12 @@ (call-next-method) (gfs:dispose dlg)) +(defun btn-callback (disp btn time rect) + (declare (ignore disp time rect)) + (let ((dlg (gfw:parent btn))) + (gfw:show dlg nil) + (gfs:dispose dlg))) + (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -151,14 +157,20 @@ (panel (make-instance 'dlg-test-panel :style '(:border) :parent dlg)) - (btn (make-instance 'gfw:button - :callback (lambda (disp btn time rect) - (declare (ignore disp time rect)) - (let ((dlg (gfw:parent btn))) - (gfw:show dlg nil) - (gfs:dispose dlg))) - :parent dlg))) - (setf (gfw:text btn) "Close") + (btn-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :spacing 4 + :style '(:vertical)) + :parent dlg)) + (ok-btn (make-instance 'gfw:button + :callback #'btn-callback + :text "OK" + :parent btn-panel)) + (cancel-btn (make-instance 'gfw:button + :callback #'btn-callback + :style '(:push-button) + :text "Cancel" + :parent btn-panel))) (gfw:pack dlg) (gfw:center-on-owner dlg) (gfw:show dlg t) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 12:50:58 2006 @@ -40,9 +40,6 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) - ;; FIXME: check whether any of the primary button - ;; styles were specified, default to :push-button - ;; (loop for sym in (style-of btn) do (cond ;; primary button styles @@ -59,11 +56,11 @@ (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) (multiple-value-bind (std-style ex-style) (compute-style-flags btn) (let ((hwnd (create-window gfs::+button-classname+ - " " + (or text " ") (gfs:handle parent) std-style ex-style))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 12:50:58 2006 @@ -137,30 +137,32 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam) (let* ((tc (thread-context)) (wparam-hi (hi-word wparam)) + (wparam-lo (lo-word wparam)) (owner (get-widget tc hwnd))) +(format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) (if owner (cond ((zerop lparam) - (let ((item (get-menuitem tc (lo-word wparam)))) + (let ((item (get-menuitem tc wparam-lo))) (if (null item) - (error 'gfs:toolkit-error :detail "no menu item for id")) - (unless (null (dispatcher item)) - (event-select (dispatcher item) - item - (event-time tc) - (make-instance 'gfs:rectangle))))) ; FIXME + (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) + (unless (null (dispatcher item)) + (event-select (dispatcher item) + item + (event-time tc) + (make-instance 'gfs:rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) (t (let ((w (get-widget tc (cffi:make-pointer lparam)))) (if (null w) - (error 'gfs:toolkit-error :detail "no object for hwnd")) - (unless (null (dispatcher w)) - (event-select (dispatcher w) - w - (event-time tc) - (make-instance 'gfs:rectangle)))))) ; FIXME - (error 'gfs:toolkit-error :detail "no object for hwnd"))) + (warn 'gfs:toolkit-warning :detail "no object for hwnd") + (unless (null (dispatcher w)) + (event-select (dispatcher w) + w + (event-time tc) + (make-instance 'gfs:rectangle))))))) ; FIXME + (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) 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 Sat May 13 12:50:58 2006 @@ -45,7 +45,7 @@ (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-timer-id :initform 1 :reader next-timer-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)) @@ -198,8 +198,8 @@ (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) -(defmethod increment-timer-id ((tc thread-context)) +(defmethod increment-widget-id ((tc thread-context)) "Return the next timer ID; also increment the internal value." - (let ((id (next-timer-id tc))) - (incf (slot-value tc 'next-timer-id)) + (let ((id (next-widget-id tc))) + (incf (slot-value tc 'next-widget-id)) id)) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sat May 13 12:50:58 2006 @@ -63,7 +63,7 @@ (let ((tc (thread-context)) (id (id-of timer))) (when (zerop id) - (setf (slot-value timer 'id) (increment-timer-id tc)) + (setf (slot-value timer 'id) (increment-widget-id tc)) (put-timer tc timer)) (if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer))) (error 'gfs:win32-error :detail "set-timer failed"))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat May 13 12:50:58 2006 @@ -75,7 +75,7 @@ (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) -(defun create-window (class-name title parent-hwnd std-style ex-style) +(defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) (gfs::create-window @@ -88,7 +88,9 @@ gfs::+cw-usedefault+ gfs::+cw-usedefault+ parent-hwnd - (cffi:null-pointer) + (if (zerop (logand gfs::+ws-child+ std-style)) + (cffi:null-pointer) + (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) (cffi:null-pointer) 0))))

1 0

[graphic-forms-cvs] r128 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 12 May '06

12 May '06

Author: junrue Date: Fri May 12 13:20:56 2006 New Revision: 128 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: dialog :owner-modal and :modeless styles now work, but :application-modal style needs further work Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri May 12 13:20:56 2006 @@ -194,11 +194,14 @@ @ref{window}(s). Dialogs typically serve to collect additional information from the user in a specific context. Note that some applications are entirely dialog-based. This class derives from -@ref{window}.@*@* A @emph{modal} dialog constrains the user to respond -to it, whereas a @emph{modeless} dialog allows continued interaction -with other windows. +@ref{window}.@*@* A @emph{modal} dialog forces the user to respond to +it before returning to other application functionality, whereas a +@emph{modeless} dialog does not. @deffn Initarg :owner -Specifies the @ref{owner} of the dialog. +Specifies the @ref{owner} of the dialog. Although no error will be +thrown, the library does not allow @ref{root-window} to be the parent +of any dialog -- the dialog initialization code instead substitutes +@sc{nil} for the owner. @end deffn @deffn Initarg :style @table @code @@ -212,8 +215,9 @@ dialog floats on top of all application-created windows, the user may still interact with other windows and dialogs. @item :owner-modal -Specifies that the dialog is @emph{modal} only in terms of its -@ref{owner} window or dialog. +Specifies that the dialog is @emph{modal} only in relation to its +@ref{owner} (which could be a window or another dialog). This style is +the default if no style keywords are specified. @end table @end deffn @deffn Initarg :text @@ -432,11 +436,10 @@ on the root @ref{window} are somewhat constrained, therefore not all functions normally implemented for other @ref{window} types are available for this @ref{window} type. If an application attempts to -set @code{root-window} as the @ref{owner} of a dialog or -@ref{top-level}, a @ref{toolkit-error} will be thrown. -In a reply to an entry at -@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, -Raymond Chen says: +set @code{root-window} as the @ref{owner} of a dialog, the library +will substitute @sc{nil}. This follows guidance provided by Raymond +Chen in a reply to an entry at his blog +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}: @quotation An owned window is not a child window. Disabling a parent also disables children, but it does NOT disable owned windows. @@ -639,7 +642,7 @@ @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-gain dispatcher widget time +@deffn GenericFunction event-focus-loss dispatcher widget time Implement this to respond to an object losing keyboard focus. @end deffn Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri May 12 13:20:56 2006 @@ -131,26 +131,46 @@ (setf (gfg:foreground-color gc) (gfg:background-color parent)) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) -(defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defclass dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) + (declare (ignore time)) + (format t "dialog-events event-close called~%") + (call-next-method) + (gfs:dispose dlg)) + +(defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 4 - :style '(:horizontal)) - :style '(:modal))) + :dispatcher (make-instance 'dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 4 + :style '(:horizontal)) + :style style + :text title)) (panel (make-instance 'dlg-test-panel :style '(:border) :parent dlg)) (btn (make-instance 'gfw:button + :callback (lambda (disp btn time rect) + (declare (ignore disp time rect)) + (let ((dlg (gfw:parent btn))) + (gfw:show dlg nil) + (gfs:dispose dlg))) :parent dlg))) (setf (gfw:text btn) "Close") (gfw:pack dlg) (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (gfw:show dlg t) + dlg)) + +(defun open-modal-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (open-dlg "Modal" '(:owner-modal))) (defun open-modeless-dlg (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () (let ((menubar nil)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri May 12 13:20:56 2006 @@ -69,4 +69,56 @@ (error 'gfs:disposed-error))) (if (null text) (setf text +default-dialog-title+)) + ;; NOTE: do not allow apps to specify the desktop window as the + ;; owner of the dialog; it would cause the desktop to become + ;; disabled. + ;; + (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) + (setf owner nil)) (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) + +(defmethod show ((dlg dialog) flag) + (let ((hutility (utility-hwnd (thread-context))) + (app-modal (find :application-modal (style-of dlg))) + (owner-modal (find :owner-modal (style-of dlg))) + (owner (owner dlg)) + (hdlg (gfs:handle dlg))) + (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 owner-modal owner) + (enable owner (null flag)))) + (call-next-method) + (when (and flag (or app-modal owner-modal)) + (message-loop (lambda (gm-code msg-ptr) + (cond + ((or (gfs:disposed-p dlg) (not (visible-p dlg))) + t) ; dialog closed, so exit loop + ((zerop gm-code) + ;; IMPORTANT: allow WM_QUIT to propagate back through + ;; nested message loops to the main loop, so that we + ;; shut down correctly -- whether the system injected + ;; the WM_QUIT or it was something the app did, we + ;; handle the shutdown request the same way. + ;; + (gfs::post-quit-message (cffi:foreign-slot-value msg-ptr + 'gfs::msg + 'gfs::wparam)) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0) + ;; It was a dialog message and has been processed, + ;; so nothing else to do. + ;; + nil) + (t + (translate-and-dispatch msg-ptr) + nil))))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri May 12 13:20:56 2006 @@ -33,6 +33,10 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun translate-and-dispatch (msg-ptr) + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr)) + (defun default-message-filter (gm-code msg-ptr) (cond ((zerop gm-code) @@ -42,8 +46,7 @@ (warn 'gfs:win32-warning :detail "get-message failed") t) (t - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr) + (translate-and-dispatch msg-ptr) nil))) #+clisp (defun startup (thread-name start-fn)

1 0

[graphic-forms-cvs] r127 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 12 May '06

12 May '06

Author: junrue Date: Thu May 11 23:20:03 2006 New Revision: 127 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored compute-style-flags GF and implementations; added utility function for traversing top-level windows owned by UI thread Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 11 23:20:03 2006 @@ -189,10 +189,36 @@ @anchor{dialog} @deftp Class dialog This is the base class for system and application-defined dialogs. A -dialog is a windowed UI component that is @emph{typically} defined to -remain on top of the primary application window(s). Of course, some +dialog is a windowed UI component, usually containing at least one +@ref{panel} or @ref{control}, that remains on top of application +@ref{window}(s). Dialogs typically serve to collect additional +information from the user in a specific context. Note that some applications are entirely dialog-based. This class derives from -@ref{window}. +@ref{window}.@*@* A @emph{modal} dialog constrains the user to respond +to it, whereas a @emph{modeless} dialog allows continued interaction +with other windows. +@deffn Initarg :owner +Specifies the @ref{owner} of the dialog. +@end deffn +@deffn Initarg :style +@table @code +@item :application-modal +Specifies that the dialog is @emph{modal} with respect to all +@ref{top-level} windows and @ref{dialog}s created by the application +(specifically those created by the calling thread which are still +realized on-screen). +@item :modeless +Specifies that the dialog is @emph{modeless}, meaning that while the +dialog floats on top of all application-created windows, the user may +still interact with other windows and dialogs. +@item :owner-modal +Specifies that the dialog is @emph{modal} only in terms of its +@ref{owner} window or dialog. +@end table +@end deffn +@deffn Initarg :text +Specifies the dialog's title. +@end deffn @end deftp @anchor{display} @@ -485,19 +511,19 @@ @end deftp @anchor{widget} -@deftp Class widget +@deftp Class widget style The widget class is the base class for all windowed user interface objects. It -derives from @ref{event-source}. +derives from @ref{event-source}. The @code{style} slot is a list of keyword +symbols supplying additional information about the desired look-and-feel or +behavior of the widget; style keywords are widget-specific. @end deftp -@anchor{widget-with-items} +@anchor{widget-with-items} items @deftp Class widget-with-items -The widget-with-items class is the base class for objects composed of sub-items. -It derives from @ref{widget}. -@deffn Initarg :items -@end deffn -@deffn Accessor items -@end deffn +The widget-with-items class is the base class for objects composed of +sub-items. It derives from @ref{widget}. The @code{items} slot is an +@sc{adjustable} @sc{vector} containing @ref{item} objects, +representing sub-elements of the widget. @end deftp @anchor{window} @@ -583,20 +609,11 @@ @ref{control}s. Accelerator keys are also translated by this function. Returns @sc{nil} so that @ref{message-loop} will continue, unless @code{gm-code} is less than or equal to zero, in which case -@sc{t} is returned so that @ref{message-loop} will -exit. @code{gm-code} is zero when @code{msg-ptr} identifies a -@sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is --1, then the system has indicated an error during message retrieval -that should be reported, followed by an orderly -shutdown. @xref{dialog-message-filter}. -@end deffn - -@anchor{dialog-message-filter} -@deffn Function dialog-message-filter gm-code msg-ptr -This function is similar to @ref{default-message-filter}, except that -it is intended to be called from a nested @code{message-loop} -invocation, usually on behalf of a modal @ref{dialog}. In this case, -the function returns @sc{nil} as long as the dialog continues to live. +@sc{t} is returned so that @ref{message-loop} will exit. When +@code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT} +message indicating normal shutdown. If @code{gm-code} is -1, then the +system has reported an error during message retrieval which should be +handled by (hopefully) graceful shutdown. @end deffn @deffn GenericFunction event-activate dispatcher widget time @@ -683,12 +700,8 @@ continues or returns, and this termination condition depends on the context of the message loop being executed. The return value is @sc{nil} if @code{message-loop} should continue, or not @sc{nil} if -the loop should exit. Two pre-defined implementations of message -filter functions are provided: -@itemize @bullet -@item @ref{default-message-filter} -@item @ref{dialog-message-filter} -@end itemize +the loop should exit. The pre-defined implementation +@ref{default-message-filter} is provided. @end deffn @@ -752,10 +765,10 @@ be drawn within or can display data. @end deffn -@deffn GenericFunction compute-style-flags self &rest style -Convert a list of keyword symbols to a pair of native bitmasks; the -first conveys normal/standard flags, whereas the second any extended -flags that the system supports. +@deffn GenericFunction compute-style-flags self &rest extra-data +Convert a list of keyword symbols in the object's @code{style} slot to +a values pair of native bitmasks; the first conveys normal/standard +flags, whereas the second any extended flags that the system supports. @end deffn @deffn GenericFunction compute-outer-size self desired-client-size Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 23:20:03 2006 @@ -236,6 +236,42 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("EnumThreadWindows" enum-thread-windows) + BOOL + (threadid DWORD) + (func :pointer) + (lparam LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-thread-windows "EnumThreadWindows") + ((threadid (:unsigned :long)) + (func :pointer) + (lparam :long)) + :result-type :int) + +#+clisp +(ffi:def-call-out enum-thread-windows + (:name "EnumThreadWindows") + (:library "user32.dll") + (:language :stdc) + (:arguments (threadid ffi:ulong) + (func (ffi:c-function + (:arguments + (hwnd ffi:c-pointer) + (lparam ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (lparam ffi:long)) + (:return-type ffi:int)) + (defcfun ("GetAncestor" get-ancestor) HANDLE @@ -382,6 +418,12 @@ (max INT)) (defcfun + ("GetWindowThreadProcessId" get-window-thread-process-id) + DWORD + (hwnd HANDLE) + (pid LPTR)) + +(defcfun ("InsertMenuItemA" insert-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu May 11 23:20:03 2006 @@ -37,14 +37,13 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) style &rest extra-data) +(defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) - (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button ;; - (loop for sym in style + (loop for sym in (style-of btn) do (cond ;; primary button styles ;; @@ -60,11 +59,9 @@ (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) - (if (not (listp style)) - (setf style (list style))) +(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys) (multiple-value-bind (std-style ex-style) - (compute-style-flags btn style) + (compute-style-flags btn) (let ((hwnd (create-window gfs::+button-classname+ " " (gfs:handle parent) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu May 11 23:20:03 2006 @@ -54,8 +54,8 @@ (defmethod gfg:background-color ((dlg dialog)) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) -(defmethod compute-style-flags ((dlg dialog) style &rest extra-data) - (declare (ignore style extra-data)) +(defmethod compute-style-flags ((dlg dialog) &rest extra-data) + (declare (ignore extra-data)) (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) @@ -63,10 +63,10 @@ (declare (ignore time)) (show dlg nil)) -(defmethod initialize-instance :after ((dlg dialog) &key owner style title &allow-other-keys) +(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) - (if (null title) - (setf title +default-dialog-title+)) - (init-window dlg +dialog-classname+ #'register-dialog-class style owner title)) + (if (null text) + (setf text +default-dialog-title+)) + (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu May 11 23:20:03 2006 @@ -83,6 +83,43 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) +#+lispworks +(fli:define-foreign-callable + ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) + (let* ((tc (thread-context)) + (win (get-widget tc hwnd))) + (unless (null win) + (call-top-level-visitor-func tc win))) + 1) + +#+clisp +(defun top_level_window_visitor (hwnd lparam) + (declare (ignore lparam)) + (let* ((tc (thread-context)) + (win (get-widget tc hwnd))) + (unless (null win) + (call-top-level-visitor-func tc win))) + 1) + +(defun visit-top-level-windows (func) + ;; + ;; supplied closure should expect one parameter: + ;; top-level window + ;; + (let ((tc (thread-context))) + (setf (top-level-visitor-func tc) func) + (unwind-protect +#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (fli:make-pointer :symbol-name "top_level_window_visitor") + 0) +#+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) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Thu May 11 23:20:03 2006 @@ -74,12 +74,12 @@ ;;; methods ;;; -(defmethod compute-style-flags ((dlg file-dialog) style &rest extra-data) +(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+ gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+ gfs::+ofn-explorer+))) - (loop for sym in style + (loop for sym in (style-of dlg) do (cond ((eq sym :add-to-recent) (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) @@ -137,7 +137,7 @@ (gfs::strncpy file-buffer tmp-str 1023)) (setf (cffi:mem-ref file-buffer :char) 0)) (multiple-value-bind (std-style ex-style) - (compute-style-flags dlg style) + (compute-style-flags dlg) (cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu May 11 23:20:03 2006 @@ -91,19 +91,20 @@ (setf (gfg:transparency-pixel-of image) pnt)) (setf (image label) image)))) -(defmethod compute-style-flags ((label label) style &rest extra-data) - (declare (ignore label)) +(defmethod compute-style-flags ((label label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) (let ((std-style (logior gfs::+ws-child+ gfs::+ws-visible+ (cond ((first extra-data) - (compute-image-style-flags (gfs:flatten style))) + (compute-image-style-flags (style-of label))) ((second extra-data) - (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (if (find :vertical (style-of label)) + gfs::+ss-etchedvert+ + gfs::+ss-etchedhorz+)) (t - (compute-text-style-flags (gfs:flatten style))))))) + (compute-text-style-flags (style-of label))))))) (values std-style 0))) (defmethod image ((label label)) @@ -152,11 +153,9 @@ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) -(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys) - (if (not (listp style)) - (setf style (list style))) +(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) (multiple-value-bind (std-style ex-style) - (compute-style-flags label style image separator text) + (compute-style-flags label image separator text) (let ((hwnd (create-window gfs::+static-classname+ (or text " ") (gfs:handle parent) @@ -201,7 +200,7 @@ (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) - (compute-style-flags label nil nil nil str) + (compute-style-flags label nil nil str) (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu May 11 23:20:03 2006 @@ -49,24 +49,21 @@ ;;; methods ;;; -(defmethod compute-style-flags ((self panel) style &rest extra-data) +(defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) - (ex-flags 0)) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) (mapc #'(lambda (sym) (cond ;; styles that can be combined ;; ((eq sym :border) (setf std-flags (logior std-flags gfs::+ws-border+))))) - (gfs:flatten style)) - (values std-flags ex-flags))) + (style-of self)) + (values std-flags 0))) -(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (if (not (listp style)) - (setf style (list style))) - (init-window self +panel-window-classname+ #'register-panel-window-class style parent "")) + (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu May 11 23:20:03 2006 @@ -34,23 +34,24 @@ (in-package #:graphic-forms.uitoolkit.widgets) (defclass thread-context () - ((child-visitor-stack :initform nil) - (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-timer-id :initform 1 :reader next-timer-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)) - (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + ((child-visitor-stack :initform nil) + (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-timer-id :initform 1 :reader next-timer-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)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) ;; TODO: change this when CLISP acquires MT support @@ -122,6 +123,11 @@ (unless (null func) (funcall func hmonitor data)))) +(defmethod call-top-level-visitor-func ((tc thread-context) win) + (let ((func (top-level-visitor-func tc))) + (unless (null func) + (funcall func win)))) + (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 11 23:20:03 2006 @@ -60,7 +60,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) style &rest extra-data) +(defmethod compute-style-flags ((win top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) @@ -114,7 +114,7 @@ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) (setf ex-flags 0)))) - (gfs:flatten style)) + (style-of win)) (values std-flags ex-flags))) (defmethod gfs:dispose ((win top-level)) @@ -124,20 +124,18 @@ (remove-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) +(defmethod initialize-instance :after ((win top-level) &key owner title &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null title) (setf title +default-window-title+)) - (if (not (listp style)) - (setf style (list style))) (let ((classname +toplevel-noerasebkgnd-window-classname+) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace style) + (when (find :workspace (style-of win)) (setf classname +toplevel-erasebkgnd-window-classname+) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func style owner title))) + (init-window win classname register-func owner title))) (defmethod menu-bar :before ((win top-level)) (if (gfs:disposed-p win) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 11 23:20:03 2006 @@ -59,7 +59,11 @@ (defclass menu-item (item) () (:documentation "A subtype of item representing a menu item.")) -(defclass widget (event-source) () +(defclass widget (event-source) + ((style + :reader style-of + :initarg :style + :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects.")) (defclass caret (widget) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 11 23:20:03 2006 @@ -105,7 +105,7 @@ (defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (self style &rest extra-data) +(defgeneric compute-style-flags (self &rest extra-data) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) (defgeneric compute-outer-size (self desired-client-size) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu May 11 23:20:03 2006 @@ -167,6 +167,9 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) + (setf (slot-value w 'style) (if (listp style) style (list style)))) + (defmethod location :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu May 11 23:20:03 2006 @@ -42,12 +42,12 @@ ;;; helper functions ;;; -(defun init-window (win classname register-class-fn style parent text) +(defun init-window (win classname register-class-fn parent text) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (funcall register-class-fn) (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) + (compute-style-flags win) (create-window classname text (if (null parent) (cffi:null-pointer) (gfs:handle parent)) @@ -75,7 +75,7 @@ (defun child_window_visitor (hwnd lparam) (let* ((tc (thread-context)) (child (get-widget tc hwnd)) - (parent (get-widget tc (cffi:make-pointer lparam)))) + (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) (call-child-visitor-func tc parent child))) 1)

1 0

[graphic-forms-cvs] r126 - in trunk: docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

Author: junrue Date: Thu May 11 16:41:47 2006 New Revision: 126 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: refactored message loop in preparation for supporting app-defined dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 11 16:41:47 2006 @@ -577,9 +577,27 @@ @node event functions @section event functions -@strong{NOTE:} There are (and will be) additional event methods defined -in future releases, they just aren't all documented or implemented at -this time. +@anchor{default-message-filter} +@deffn Function default-message-filter gm-code msg-ptr +Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and +@ref{control}s. Accelerator keys are also translated by this +function. Returns @sc{nil} so that @ref{message-loop} will continue, +unless @code{gm-code} is less than or equal to zero, in which case +@sc{t} is returned so that @ref{message-loop} will +exit. @code{gm-code} is zero when @code{msg-ptr} identifies a +@sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is +-1, then the system has indicated an error during message retrieval +that should be reported, followed by an orderly +shutdown. @xref{dialog-message-filter}. +@end deffn + +@anchor{dialog-message-filter} +@deffn Function dialog-message-filter gm-code msg-ptr +This function is similar to @ref{default-message-filter}, except that +it is intended to be called from a nested @code{message-loop} +invocation, usually on behalf of a modal @ref{dialog}. In this case, +the function returns @sc{nil} as long as the dialog continues to live. +@end deffn @deffn GenericFunction event-activate dispatcher widget time Implement this to respond to an object being activated. @@ -656,6 +674,23 @@ Implement this to respond to a tick from a specific timer. @end deffn +@anchor{message-loop} +@deffn Function message-loop msg-filter +This function retrieves messages from the system with the intent of +passing each one to the function specified by @code{msg-filter} so +that it may be translated and dispatched. The return value of the +@code{msg-filter} function determines whether @code{message-loop} +continues or returns, and this termination condition depends on the +context of the message loop being executed. The return value is +@sc{nil} if @code{message-loop} should continue, or not @sc{nil} if +the loop should exit. Two pre-defined implementations of message +filter functions are provided: +@itemize @bullet +@item @ref{default-message-filter} +@item @ref{dialog-message-filter} +@end itemize +@end deffn + @node widget functions @section widget functions Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 11 16:41:47 2006 @@ -342,6 +342,7 @@ #:cursor #:cut #:default-item + #:default-message-filter #:defmenu #:delay-of #:disabled-image @@ -420,6 +421,7 @@ #:maximum-size #:menu #:menu-bar + #:message-loop #:minimum-size #:mouse-over-image #:move-above @@ -446,7 +448,6 @@ #:resizable-p #:retrieve-span #:right-margin-of - #:run-default-message-loop #:scroll #:select #:select-all Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 16:41:47 2006 @@ -397,6 +397,12 @@ (erase BOOL)) (defcfun + ("IsDialogMessageA" is-dialog-message) + BOOL + (hwnd HANDLE) + (msg LPTR)) + +(defcfun ("IsWindowEnabled" is-window-enabled) BOOL (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 11 16:41:47 2006 @@ -66,7 +66,7 @@ ;;; helper functions ;;; -(defun run-default-message-loop () +(defun message-loop (msg-filter) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) @@ -78,14 +78,8 @@ gfs::pnt) msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) - (when (zerop gm) - (dispose-thread-context) - (return-from run-default-message-loop gfs::wparam)) - (when (= gm -1) - (warn 'gfs:win32-warning :detail "get-message failed") - (return-from run-default-message-loop gfs::wparam))) - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr))))) + (when (funcall msg-filter gm msg-ptr) + (return-from message-loop gfs::wparam))))))) (defmacro hi-word (lparam) `(ash (logand #xFFFF0000 ,lparam) -16)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu May 11 16:41:47 2006 @@ -33,11 +33,24 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun default-message-filter (gm-code msg-ptr) + (cond + ((zerop gm-code) + (dispose-thread-context) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + (t + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr) + nil))) + #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (gfg::initialize-magick (cffi:null-pointer)) (funcall start-fn) - (run-default-message-loop)) + (message-loop #'default-message-filter)) #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) @@ -46,9 +59,9 @@ (mp:initialize-multiprocessing)) (mp:process-run-function thread-name nil - #'(lambda () (progn - (funcall start-fn) - (run-default-message-loop))))) + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfg::destroy-magick)

1 0

[graphic-forms-cvs] r125 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

Author: junrue Date: Wed May 10 22:49:06 2006 New Revision: 125 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: rewrote compute-outer-size in terms of AdjustWindowRectEx, which bases its calculation on window styles Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 22:49:06 2006 @@ -122,7 +122,7 @@ (defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) (declare (ignore width-hint height-hint)) - (gfs:make-size :width 180 :height 100)) + (gfs:make-size :width 280 :height 200)) (defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) (declare (ignore time rect)) @@ -137,7 +137,7 @@ :layout (make-instance 'gfw:flow-layout :margins 8 :spacing 4 - :style '(:vertical)) + :style '(:horizontal)) :style '(:modal))) (panel (make-instance 'dlg-test-panel :style '(:border) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed May 10 22:49:06 2006 @@ -39,6 +39,14 @@ (load-foreign-library "user32.dll") (defcfun + ("AdjustWindowRectEx" adjust-window-rect) + BOOL + (rect LPTR) + (style LONG) + (menu BOOL) + (exstyle LONG)) + +(defcfun ("BeginDeferWindowPos" begin-defer-window-pos) HANDLE (numwin INT)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed May 10 22:49:06 2006 @@ -86,10 +86,15 @@ (defmethod border-width ((widget widget)) (let* ((hwnd (gfs:handle widget)) (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) - (when (logand bits gfs::+ws-ex-clientedge+) - (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) - (when (logand bits gfs::+ws-ex-staticedge+) - (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) + (cond + ((/= (logand bits gfs::+ws-ex-clientedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) + ((/= (logand bits gfs::+ws-ex-dlgmodalframe+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+))) + ((/= (logand bits gfs::+ws-ex-staticedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) + ((/= (logand bits gfs::+ws-ex-windowedge+) 0) + (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (when (logand bits gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 22:49:06 2006 @@ -77,7 +77,6 @@ (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) -(format t "~a~%" child) (call-child-visitor-func tc parent child))) 1) @@ -168,17 +167,22 @@ color)) (defmethod compute-outer-size ((win window) desired-client-size) - ;; TODO: consider reimplementing this with AdjustWindowRect - ;; - (let ((client-sz (client-size win)) - (outer-sz (size win)) - (trim-sz (gfs:make-size :width (gfs:size-width desired-client-size) - :height (gfs:size-height desired-client-size)))) - (incf (gfs:size-width trim-sz) (- (gfs:size-width outer-sz) - (gfs:size-width client-sz))) - (incf (gfs:size-height trim-sz) (- (gfs:size-height outer-sz) - (gfs:size-height client-sz))) - trim-sz)) + (let ((hwnd (gfs:handle win)) + (new-size (gfs:make-size))) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) rect-ptr gfs::rect) + (setf gfs::left 0 + gfs::top 0 + gfs::right (gfs:size-width desired-client-size) + gfs::bottom (gfs:size-height desired-client-size)) + (if (zerop (gfs::adjust-window-rect rect-ptr + (gfs::get-window-long hwnd gfs::+gwl-style+) + (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) + (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (error 'gfs:toolkit-error :detail "adjust-window-rect failed")) + (setf (gfs:size-width new-size) (- gfs::right gfs::left) + (gfs:size-height new-size) (- gfs::bottom gfs::top)))) + new-size)) (defmethod enable-layout :before ((win window) flag) (declare (ignore flag))

1 0

[graphic-forms-cvs] r124 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 11 May '06

11 May '06

Author: junrue Date: Wed May 10 21:21:49 2006 New Revision: 124 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: more work towards user-defined dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed May 10 21:21:49 2006 @@ -188,9 +188,9 @@ @anchor{dialog} @deftp Class dialog -This is the base class for system and user-defined dialogs. A dialog -is a windowed UI component that is @emph{typically} defined to remain -on top of the primary application window(s). Of course, some +This is the base class for system and application-defined dialogs. A +dialog is a windowed UI component that is @emph{typically} defined to +remain on top of the primary application window(s). Of course, some applications are entirely dialog-based. This class derives from @ref{window}. @end deftp @@ -261,8 +261,8 @@ be removed. Also, only the first three characters are used. @end deffn @deffn Initarg :filters -This initarg accepts a list of conses, @sc{first} holding a string -that describes a filter, e.g., @samp{Text Files}, and @sc{second} +This initarg accepts a list of conses, @sc{car} holding a string +that describes a filter, e.g., @samp{Text Files}, and @sc{cdr} specifying the actual filter pattern, e.g., @samp{*.TXT}. Note that multiple filter patterns can be grouped with a single description by separating them with semicolons, e.g., @samp{*.TXT;*.BAK}. Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed May 10 21:21:49 2006 @@ -224,6 +224,7 @@ #:button #:caret #:control + #:dialog #:display #:event-dispatcher #:event-source Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 21:21:49 2006 @@ -118,13 +118,36 @@ :initial-directory #P"c:/") (print paths))) +(defclass dlg-test-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfs:make-size :width 180 :height 100)) + +(defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) + (declare (ignore time rect)) + (let ((parent (gfw:parent panel))) + (setf (gfg:background-color gc) (gfg:background-color parent)) + (setf (gfg:foreground-color gc) (gfg:background-color parent)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) + (defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect))) -#| - (let ((dlg (make-instance 'gfw:dialog :owner *main-win* - :style '(:modal)))) + (declare (ignore disp item time rect)) + (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 4 + :style '(:vertical)) + :style '(:modal))) + (panel (make-instance 'dlg-test-panel + :style '(:border) + :parent dlg)) + (btn (make-instance 'gfw:button + :parent dlg))) + (setf (gfw:text btn) "Close") + (gfw:pack dlg) + (gfw:center-on-owner dlg) (gfw:show dlg t))) -|# (defun open-modeless-dlg (disp item time rect) (declare (ignore disp item time rect))) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Wed May 10 21:21:49 2006 @@ -39,8 +39,7 @@ (defmethod compute-style-flags ((btn button) style &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags 0) - (ex-flags 0)) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button @@ -50,16 +49,16 @@ ;; primary button styles ;; ((eq sym :check-box) - (setf std-flags gfs::+bs-checkbox+)) + (setf std-flags (logior std-flags gfs::+bs-checkbox+))) ((eq sym :default-button) - (setf std-flags gfs::+bs-defpushbutton+)) + (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) ((eq sym :push-button) - (setf std-flags gfs::+bs-pushbutton+)) + (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) - (setf std-flags gfs::+bs-radiobutton+)) + (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) ((eq sym :toggle-button) - (setf std-flags gfs::+bs-pushbox+)))) - (values std-flags ex-flags))) + (setf std-flags (logior std-flags gfs::+bs-pushbox+))))) + (values std-flags 0))) (defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) (if (not (listp style)) @@ -69,7 +68,7 @@ (let ((hwnd (create-window gfs::+button-classname+ " " (gfs:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + std-style ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed May 10 21:21:49 2006 @@ -33,21 +33,40 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +default-dialog-title+ " ") + ;;; ;;; helper functions ;;; -#| -(defun register-user-dialog-class () - (register-window-class +user-dialog-classname+ - (cffi:get-callback 'uit_dialog_wndproc) +(defun register-dialog-class () + (register-window-class +dialog-classname+ + (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ gfs::+cs-bytealignwindow+) gfs::+color-btnface+)) -|# ;;; ;;; methods ;;; +(defmethod gfg:background-color ((dlg dialog)) + (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) + +(defmethod compute-style-flags ((dlg dialog) style &rest extra-data) + (declare (ignore style extra-data)) + (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) + (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+))) + +(defmethod event-close ((self event-dispatcher) (dlg dialog) time) + (declare (ignore time)) + (show dlg nil)) + +(defmethod initialize-instance :after ((dlg dialog) &key owner style title &allow-other-keys) + (unless (null owner) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error))) + (if (null title) + (setf title +default-dialog-title+)) + (init-window dlg +dialog-classname+ #'register-dialog-class style owner title)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Wed May 10 21:21:49 2006 @@ -95,14 +95,16 @@ (declare (ignore label)) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) - (values (cond - ((first extra-data) - (compute-image-style-flags (gfs:flatten style))) - ((second extra-data) - (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) - (t - (compute-text-style-flags (gfs:flatten style)))) - 0)) + (let ((std-style (logior gfs::+ws-child+ + gfs::+ws-visible+ + (cond + ((first extra-data) + (compute-image-style-flags (gfs:flatten style))) + ((second extra-data) + (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) + (t + (compute-text-style-flags (gfs:flatten style))))))) + (values std-style 0))) (defmethod image ((label label)) (if (gfs:disposed-p label) @@ -158,7 +160,7 @@ (let ((hwnd (create-window gfs::+static-classname+ (or text " ") (gfs:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + (logior std-style) ex-style))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed May 10 21:21:49 2006 @@ -61,7 +61,7 @@ ;;; (defmethod compute-style-flags ((win top-level) style &rest extra-data) - (declare (ignore win extra-data)) + (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) (mapc #'(lambda (sym) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 21:21:49 2006 @@ -34,9 +34,9 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +dialog-classname+ "GraphicFormsDialog") (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") - (defconstant +user-dialog-classname+ "GraphicFormsUserDialog")) + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) ;;; ;;; helper functions @@ -77,6 +77,7 @@ (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) (unless (or (null child) (null parent)) +(format t "~a~%" child) (call-child-visitor-func tc parent child))) 1)

1 0

[graphic-forms-cvs] r123 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 May '06

10 May '06

Author: junrue Date: Wed May 10 15:41:30 2006 New Revision: 123 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial steps towards support for user-defined dialogs; refactored file-dialog and updated docs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Wed May 10 15:41:30 2006 @@ -191,7 +191,8 @@ This is the base class for system and user-defined dialogs. A dialog is a windowed UI component that is @emph{typically} defined to remain on top of the primary application window(s). Of course, some -applications are entirely dialog-based. +applications are entirely dialog-based. This class derives from +@ref{window}. @end deftp @anchor{display} @@ -236,7 +237,7 @@ @end deftp @anchor{file-dialog} -@deftp Class file-dialog +@deftp Class file-dialog open-mode This class provides a standard @ref{dialog} for navigating the file system to select or enter file names. A variety of configurations are possible; however, please note that the following behaviors are @@ -245,11 +246,15 @@ @item in @code{:save} mode, the user will be prompted to confirm overwrite when an existing file is selected @end itemize -Applications retrieve selected files by calling the @code{items} -function, which returns a @sc{vector} of @sc{file namestring}s, one -for each selection. Unless the @code{:multiple-select} style keyword -is specified, there will at most be one selected file returned, and -possibly zero if the user cancelled the dialog.@*@* +The @ref{with-file-dialog} macro wraps the creation of a +@code{file-dialog} and subsequent retrieval of the file paths selected +by the user. However, applications may choose to implements these +steps manually, in which case the @ref{file-dialog-paths} function can +be used to obtain the user's selection(s). Unless the +@code{:multiple-select} style keyword is specified, there will at most +be one selected file returned, and possibly zero if the user cancelled +the dialog. Also, manual construction of an instance must be followed +by an explicit call to @ref{dispose}.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if the user fails to provide one. Any embedded periods @samp{.} will @@ -743,6 +748,14 @@ Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. @end deffn +@anchor{file-dialog-paths} +@deffn Function file-dialog-paths dlg +Interrogates the data structure associated with an instance of +@ref{file-dialog} to obtain the paths for selected files. This return +value is either @sc{nil} if the user cancelled the dialog, or a list +of file @sc{namestring}s. +@end deffn + @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} otherwise. @@ -870,6 +883,7 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn +@anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. @@ -901,6 +915,13 @@ @end deffn @end html +@anchor{with-file-dialog} +@deffn Macro with-file-dialog (owner style paths &key default extension filters initial-directory initial-filename text) &body body +This macro wraps the instantiation of a standard file open/save dialog +and the subsequent retrieval of the user's file +selections. @xref{file-dialog}. +@end deffn + @node layout functions @section layout functions Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed May 10 15:41:30 2006 @@ -385,6 +385,7 @@ #:event-timer #:expand #:expanded-p + #:file-dialog-paths #:focus-index #:focus-p #:foreground-color @@ -482,6 +483,7 @@ #:visible-item-count #:visible-p #:with-children + #:with-file-dialog ;; conditions )) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed May 10 15:41:30 2006 @@ -98,24 +98,36 @@ (defun open-file-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* - :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") - ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") - ("All Files (*.*)" . "*.*")) - :initial-directory #P"c:/" - :style '(:add-to-recent :multiple-select :open) - :text "Select Lisp-related files..."))) - (print (gfw:items dlg)))) + (gfw:with-file-dialog (*main-win* + '(:open :add-to-recent :multiple-select) + paths + :filters '(("FASL Files (*.fas;*.fsl)" . "*.fas;*.fsl") + ("Lisp Source Files (*.lisp;*.lsp)" . "*.lisp;*.lsp") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/" + :text "Select Lisp-related files...") + (print paths))) (defun save-file-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((dlg (make-instance 'gfw:file-dialog :owner *main-win* - :default-extension "dat" - :filters '(("Data files (*.dat)" . "*.dat") - ("All Files (*.*)" . "*.*")) - :initial-directory #P"c:/" - :style '(:save)))) - (print (gfw:items dlg)))) + (gfw:with-file-dialog (*main-win* + '(:save) + paths + :filters '(("Data files (*.dat)" . "*.dat") + ("All Files (*.*)" . "*.*")) + :initial-directory #P"c:/") + (print paths))) + +(defun open-modal-dlg (disp item time rect) + (declare (ignore disp item time rect))) +#| + (let ((dlg (make-instance 'gfw:dialog :owner *main-win* + :style '(:modal)))) + (gfw:show dlg t))) +|# + +(defun open-modeless-dlg (disp item time rect) + (declare (ignore disp item time rect))) (defun run-windlg-internal () (let ((menubar nil)) @@ -123,13 +135,16 @@ :style '(:workspace))) (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) - (:item "&Dialogs" + (:item "&System Dialogs" :submenu ((:item "&Open File" :callback #'open-file-dlg) (:item "&Save File" :callback #'save-file-dlg))) + (:item "&User Dialogs" + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Wed May 10 15:41:30 2006 @@ -218,17 +218,17 @@ (ofnfilterindex DWORD) (ofnfile LPTR) (ofnmaxfile DWORD) - (ofnfiletitle :string) + (ofnfiletitle :pointer) (ofnmaxfiletitle DWORD) - (ofninitialdir :string) - (ofntitle :string) + (ofninitialdir :pointer) + (ofntitle :pointer) (ofnflags DWORD) (ofnfileoffset WORD) (ofnfileext WORD) - (ofndefext :string) + (ofndefext :pointer) (ofncustdata LPARAM) (ofnhookfn LPTR) - (ofntemplname :string) + (ofntemplname :pointer) (ofnpvreserved LPTR) (ofndwreserved DWORD) (ofnexflags DWORD)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed May 10 15:41:30 2006 @@ -34,27 +34,20 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; -(defmethod focus-p :before ((dlg dialog)) - (if (gfs:disposed-p dlg) - (error 'gfs:disposed-error))) - -(defmethod focus-p ((dlg dialog)) - (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle dlg))))) - -(defmethod give-focus :before ((dlg dialog)) - (if (gfs:disposed-p dlg) - (error 'gfs:disposed-error))) +#| +(defun register-user-dialog-class () + (register-window-class +user-dialog-classname+ + (cffi:get-callback 'uit_dialog_wndproc) + (logior gfs::+cs-dblclks+ + gfs::+cs-savebits+ + gfs::+cs-bytealignwindow+) + gfs::+color-btnface+)) +|# -(defmethod give-focus ((dlg dialog)) - (if (gfs:null-handle-p (gfs::set-focus (gfs:handle dlg))) - (error 'gfs:toolkit-error "set-focus failed"))) +;;; +;;; methods +;;; -(defmethod print-object ((self dialog) stream) - (print-unreadable-object (self stream :type t) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Wed May 10 15:41:30 2006 @@ -37,6 +37,39 @@ ;;; helper functions ;;; +(defun file-dialog-paths (dlg) + (let ((paths nil) + (ofn-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p ofn-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) + (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) + (dir-str (first raw-list))) + (if (cdr raw-list) + (setf paths (loop for filename in (cdr raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) + (setf paths (list (parse-namestring dir-str))))))) + paths)) + +(defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) + (let ((dlg (gensym))) + `(let ((,paths nil) + (,dlg (make-instance 'file-dialog + :default-extension ,default-extension + :filters ,filters + :initial-directory ,initial-directory + :initial-filename ,initial-filename + :owner ,owner + :style ,style + :text ,text))) + (unwind-protect + (progn + (show ,dlg t) + (setf ,paths (file-dialog-paths ,dlg)) + ,@body) + (gfs:dispose ,dlg))))) + ;;; ;;; methods ;;; @@ -58,6 +91,23 @@ (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+))))) (values std-flags 0))) +(defmethod gfs:dispose ((dlg file-dialog)) + (let ((ofn-ptr (gfs:handle dlg))) + (unless (cffi:null-pointer-p ofn-ptr) + (cffi:with-foreign-slots ((gfs::ofnfile gfs::ofnfilter gfs::ofntitle + gfs::ofninitialdir gfs::ofndefext) + ofn-ptr gfs::openfilename) + (cffi:foreign-free gfs::ofnfile) + (cffi:foreign-free gfs::ofnfilter) + (unless (cffi:null-pointer-p gfs::ofntitle) + (cffi:foreign-free gfs::ofntitle)) + (unless (cffi:null-pointer-p gfs::ofninitialdir) + (cffi:foreign-free gfs::ofninitialdir)) + (unless (cffi:null-pointer-p gfs::ofndefext) + (cffi:foreign-free gfs::ofndefext))) + (cffi:foreign-free ofn-ptr) + (setf (slot-value dlg 'gfs:handle) (cffi:null-pointer))))) + (defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE ;; so that the file buffer can be resized as needed for @@ -67,7 +117,7 @@ (error 'gfs:toolkit-error :detail ":owner initarg is required")) (if (gfs:disposed-p owner) (error 'gfs:disposed-error)) - (let ((struct-ptr (cffi:foreign-alloc 'gfs::openfilename)) + (let ((ofn-ptr (cffi:foreign-alloc 'gfs::openfilename)) (filters-buffer (if filters (collect-foreign-strings (loop for entry in filters append (list (car entry) (cdr entry)))) @@ -81,8 +131,7 @@ (if initial-directory (setf dir-buffer (collect-foreign-strings (list initial-directory)))) (if default-extension - (progn - (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension)))))) + (setf ext-buffer (collect-foreign-strings (list (remove #\. default-extension))))) (if initial-filename (cffi:with-foreign-string (tmp-str (namestring initial-filename)) (gfs::strncpy file-buffer tmp-str 1023)) @@ -95,7 +144,7 @@ gfs::ofninitialdir gfs::ofntitle gfs::ofnflags gfs::ofnfileoffset gfs::ofnfileext gfs::ofndefext gfs::ofncustdata gfs::ofnhookfn gfs::ofntemplname gfs::ofnpvreserved gfs::ofndwreserved gfs::ofnexflags) - struct-ptr gfs::openfilename) + ofn-ptr gfs::openfilename) (setf gfs::ofnsize (cffi:foreign-type-size 'gfs::openfilename) gfs::ofnhwnd (gfs:handle owner) gfs::ofnhinst (cffi:null-pointer) @@ -119,23 +168,12 @@ gfs::ofnpvreserved (cffi:null-pointer) gfs::ofndwreserved 0 gfs::ofnexflags ex-style))) - (unwind-protect - (let ((fn (if (find :save style) #'gfs::get-save-filename #'gfs::get-open-filename))) - (if (and (zerop (funcall fn struct-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) - (error 'gfs:comdlg-error :detail "file dialog function failed")) - (unless (or (cffi:null-pointer-p file-buffer) (= (cffi:mem-ref file-buffer :char) 0)) - (let* ((raw-list (extract-foreign-strings file-buffer)) - (dir-str (first raw-list))) - (if (cdr raw-list) - (setf (items dlg) (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf (items dlg) (list (parse-namestring dir-str))))))) - (cffi:foreign-free file-buffer) - (cffi:foreign-free filters-buffer) - (unless (cffi:null-pointer-p title-buffer) - (cffi:foreign-free title-buffer)) - (unless (cffi:null-pointer-p dir-buffer) - (cffi:foreign-free dir-buffer)) - (unless (cffi:null-pointer-p ext-buffer) - (cffi:foreign-free ext-buffer)) - (cffi:foreign-free struct-ptr)))) + (setf (slot-value dlg 'gfs:handle) ofn-ptr) + (setf (slot-value dlg 'open-mode) (find :open style)))) + +(defmethod show ((dlg file-dialog) flag) + (declare (ignore flag)) + (let ((ofn-ptr (gfs:handle dlg)) + (fn (if (open-mode dlg) #'gfs::get-open-filename #'gfs::get-save-filename))) + (if (and (zerop (funcall fn ofn-ptr)) (/= (gfs::comm-dlg-extended-error) 0)) + (error 'gfs:comdlg-error :detail "file dialog function failed")))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed May 10 15:41:30 2006 @@ -96,12 +96,6 @@ :initform (make-array 7 :fill-pointer 0 :adjustable t))) (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) -(defclass dialog (widget-with-items) () - (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) - -(defclass file-dialog (dialog) () - (:documentation "This class represents the standard file open/save dialog.")) - (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) @@ -115,6 +109,15 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) +(defclass dialog (window) () + (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) + +(defclass file-dialog (dialog) + ((open-mode + :reader open-mode + :initform t)) + (:documentation "This class represents the standard file open/save dialog.")) + (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed May 10 15:41:30 2006 @@ -35,7 +35,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") + (defconstant +user-dialog-classname+ "GraphicFormsUserDialog")) ;;; ;;; helper functions @@ -102,7 +103,7 @@ (pop-child-visitor-func tc))) nil) -(defun register-window-class (class-name proc-ptr style bkgcolor) +(defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -120,7 +121,7 @@ (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) - (setf gfs::wndextra 0) + (setf gfs::wndextra (or wndextra 0)) (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer))) (setf gfs::hicon (cffi:null-pointer)) (setf gfs::hcursor (gfs::load-image (cffi:null-pointer)

1 0

[graphic-forms-cvs] r122 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 08 May '06

08 May '06

Author: junrue Date: Sun May 7 19:30:01 2006 New Revision: 122 Modified: trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/timer.lisp Log: timer initial-delay bug fix Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 7 19:30:01 2006 @@ -412,11 +412,17 @@ (timer (get-timer tc wparam))) (if (null timer) (gfs::kill-timer hwnd wparam) - (progn - (if (<= (delay-of timer) 0) - (enable timer nil) - (reset-timer-to-delay timer (delay-of timer))) - (event-timer (dispatcher timer) timer (event-time tc))))) + (cond + ((<= (delay-of timer) 0) + (event-timer (dispatcher timer) timer (event-time tc)) + (gfs:dispose timer)) + ((/= (delay-of timer) (initial-delay-of timer)) + (let ((delay (reset-timer-to-delay timer (delay-of timer)))) + (setf (slot-value timer 'delay) delay) + (setf (slot-value timer 'initial-delay) delay)) + (event-timer (dispatcher timer) timer (event-time tc))) + (t + (event-timer (dispatcher timer) timer (event-time tc)))))) 0) ;;; Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 19:30:01 2006 @@ -57,8 +57,6 @@ (values init-delay delay)) (defun reset-timer-to-delay (timer delay) - (if (and (> (id-of timer) 0) (= (delay-of timer) delay)) - (return-from reset-timer-to-delay nil)) (multiple-value-bind (init-delay clamped) (clamp-delay-values 0 delay) (declare (ignore init-delay)) @@ -79,7 +77,9 @@ (setf (slot-value self 'delay) (reset-timer-to-delay self value))) (defmethod gfs:dispose ((self timer)) - (enable self nil)) + (let ((tc (thread-context))) + (remove-timer tc self) + (gfs::kill-timer (utility-hwnd tc) (id-of self)))) (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) @@ -102,7 +102,7 @@ (if (> init-delay 0) (reset-timer-to-delay self init-delay) (setf (delay-of self) (delay-of self))))) - (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick + (gfs:dispose self))) (defmethod enabled-p ((self timer)) (get-timer (thread-context) (id-of self)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs May 2006