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)