Author: junrue Date: Sat Aug 19 18:56:20 2006 New Revision: 222

Added: trunk/src/uitoolkit/widgets/color-dialog.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/font-dialog.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented and documented system color dialog

Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 18:56:20 2006 @@ -1,8 +1,8 @@

-. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms - includes a small patch to enable the stdcall calling convention for alien - callbacks, located in src/external-libraries/sbcl-callback-patch +. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch +to enable the stdcall calling convention for alien callbacks, located +in src/external-libraries/sbcl-callback-patch

==============================================================================

Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 18:56:20 2006 @@ -28,7 +28,7 @@ @node widget types @subsection widget types

-@strong{NOTE:} A future release will provide additional widget +@strong{Note:} A future release will provide additional widget classes.

@anchor{button} @@ -90,6 +90,46 @@ @end deffn @end deftp

+@anchor{color-dialog} +@deftp Class color-dialog +This class provides a standard dialog for choosing (or defining new) +@ref{color}s. The @ref{with-color-dialog} macro wraps the creation of +this dialog type and subsequent retrieval of the user's color choice. +However, applications may choose to implement these steps manually, in +which case the @ref{obtain-chosen-color} function can be used.@*@* +Like other system dialogs in Graphic-Forms, @code{color-dialog} is +derived from @ref{widget} rather than @ref{dialog} since the majority +of its functionality is implemented by the system. @strong{Note:} A +future release will provide a customization mechanism. +@deffn Initarg :initial-color +This initarg causes the dialog to show the specified color as +initially selected. +@end deffn +@deffn Initarg :initial-custom-colors +This initarg accepts a list of color objects which are used to +populate the custom color editing portion of the dialog. A +maximum of 16 colors are used, with any extras supplied in the +list being ignored. Fewer than 16 may be supplied, in which case +black is displayed as a default color for the remaining entries. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a dialog. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols: +@table @code +@item :allow-custom-colors +This configures the dialog to enable the Define Custom Color +button, which when clicked reveals additional controls for +creating custom colors. +@item :display-solid-only +This configures the dialog to only display solid colors in the +set of basic colors. +@end table +@end deffn +@end deftp + @anchor{control} @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @@ -314,7 +354,7 @@ must be followed by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{file-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority -of its functionality is implemented by the system. @strong{NOTE:} A +of its functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if @@ -354,7 +394,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :add-to-recent This enables the system to add a link to the selected file @@ -374,7 +414,7 @@ for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by -the system. @strong{NOTE:} files marked both @sc{hidden} and +the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. @@ -402,7 +442,7 @@ by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority of its -functionality is implemented by the system. @strong{NOTE:} A future release +functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@* @deffn Initarg :gc This required initarg accepts a @ref{graphics-context} object providing @@ -424,7 +464,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :all-fonts This is a convenience style, used by default if no other font @@ -453,7 +493,7 @@

@anchor{group} @deftp Class group children location size style -@strong{NOTE:} this class is not yet fully implemented +@strong{Note:} this class is not yet fully implemented and does not yet participate in the layout protocol.@*@* A @code{group} represents a logical rectangular aggregation of @ref{window} children which has the following properties @@ -748,7 +788,7 @@ This slot holds a margin value in pixels for the bottom side of the container. @item data -This slot holds a @sc{alist} of pairs, each one associating a +This slot holds an @sc{alist} of pairs, each one associating a @sc{plist} of layout-specific attributes with an item from a container. @item left-margin @@ -1171,7 +1211,7 @@ @end deffn

@anchor{capture-mouse} -@deffn Function capture-mouse self +@defun capture-mouse self Enables the @ref{window} identified by @code{self} to receive mouse input events even when the mouse pointer is outside of the bounds of @code{self}. Only one window at a time can capture the mouse. This @@ -1179,7 +1219,7 @@ background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within the visible portions of such a window. @xref{release-mouse}. -@end deffn +@end defun

@anchor{center-on-owner} @deffn GenericFunction center-on-owner self @@ -1319,13 +1359,13 @@ @end deffn

@anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg => @sc{list} +@defun file-dialog-paths dlg => @sc{list} 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. Use this function when manually constructing a file dialog. @xref{with-file-dialog}. -@end deffn +@end defun

@deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} @@ -1333,7 +1373,7 @@ @end deffn

@anchor{font-dialog-results} -@deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color} +@defun font-dialog-results dlg gc => @ref{font}, @ref{color} Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns @@ -1343,7 +1383,7 @@ Also, the color value will be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. Use this function when manually constructing a font dialog. @xref{with-font-dialog}. -@end deffn +@end defun

@deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @@ -1420,23 +1460,28 @@ the new minimum. @xref{maximum-size}. @end deffn

-@deffn GenericFunction object-to-display self pnt -Return a point that is the result of transforming the specified point -from this object's coordinate system to display-relative coordinates. -@end deffn +@anchor{obtain-chosen-color} +@defun obtain-chosen-color @ref{color-dialog} => @ref{color}, list +Interrogates the data structure associated with @var{color-dialog} +to retrieve @var{color}. The secondary value is a list of color +objects corresponding to custom colors displayed by the dialog. +If the user cancelled the dialog, @sc{nil} is returned for both +values. Use this function when manually constructing a color dialog. +@xref{with-color-dialog}. +@end defun

@anchor{obtain-displays} -@deffn Function obtain-displays +@defun obtain-displays => list Returns a list of @ref{display} objects, each of which describes a monitor attached to the system. The system specifies that one of these is the primary @ref{display}. -@end deffn +@end defun

@anchor{obtain-primary-display} -@deffn Function obtain-primary-display -Return a @ref{display} object that is regarded by the system as +@defun obtain-primary-display => @ref{display} +Return a display object that is regarded by the system as being the primary. -@end deffn +@end defun

@anchor{owner} @deffn GenericFunction owner self @@ -1461,11 +1506,12 @@

@anchor{pack} @deffn GenericFunction pack self -Causes @code{self} to be resized to its preferred @ref{size}. +Causes @var{self} to be resized to the dimensions returned +by @ref{preferred-size}. @end deffn

@anchor{parent} -@deffn GenericFunction parent self +@deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @code{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, @@ -1508,10 +1554,10 @@ must determine how tall it would be given that width. @end deffn

-@deffn Function primary-p display +@defun primary-p display Returns T if the system regards the specified display as the primary display; nil otherwise. -@end deffn +@end defun

@deffn GenericFunction redo-available-p self => boolean Returns T if @code{self} has @sc{redo} capability and has an @@ -1523,10 +1569,10 @@ @end deffn

@anchor{release-mouse} -@deffn Function release-mouse +@defun release-mouse Clears the mouse capture state to restore normal mouse input processing. @xref{capture-mouse}. -@end deffn +@end defun

@anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean @@ -1651,6 +1697,16 @@ @end deffn @end html

+@anchor{with-color-dialog} +@defmac with-color-dialog (owner style color custom-colors &key initial-color initial-custom-colors) &body body +This macro wraps the instantiation of a standard color dialog and +the subsequent retrieval of the user's color selection (supplied to @var{body} +via @var{color}). The @var{custom-colors} argument is bound to a list containing +colors that the user has modified in the extended portion of the dialog. +@xref{color-dialog}. +@end defmac + +@anchor{with-drawing-disabled} @defmac with-drawing-disabled (widget) &body body This macro executes @var{body} while updates of @var{widget} are disabled. Drawing operations attempted while @var{body}

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 18:56:20 2006 @@ -122,6 +122,9 @@ (:file "timer") (:file "item") (:file "widget") + (:file "color-dialog") + (:file "file-dialog") + (:file "font-dialog") (:file "control") (:file "edit") (:file "label") @@ -136,8 +139,6 @@ (:file "top-level") (:file "panel") (:file "dialog") - (:file "file-dialog") - (:file "font-dialog") (:file "layout") (:file "heap-layout") (:file "flow-layout")))))))))

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 19 18:56:20 2006 @@ -244,6 +244,7 @@ ;; classes and structs #:button #:caret + #:color-dialog #:control #:dialog #:display @@ -462,7 +463,7 @@ #:move-above #:move-below #:moveable-p - #:object-to-display + #:obtain-chosen-color #:obtain-displays #:obtain-event-time #:obtain-primary-display @@ -523,6 +524,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-color-dialog #:with-drawing-disabled #:with-file-dialog #:with-font-dialog

Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat Aug 19 18:56:20 2006 @@ -117,6 +117,14 @@ :initial-directory #P"c:/") (print paths)))

+(defun choose-color-dlg (disp item) + (declare (ignore disp item)) + (gfw:with-color-dialog (*main-win* '(:allow-custom-colors) color custom-colors :initial-custom-colors (list gfg:*color-red* gfg:*color-blue*)) + (if color + (print color)) + (if custom-colors + (print custom-colors)))) + (defun choose-font-dlg (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) @@ -235,16 +243,17 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Custom Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&System Dialogs" - :submenu ((:item "&Choose Font" :callback #'choose-font-dlg) - (:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) + :submenu ((:item "Choose &Color" :callback #'choose-color-dlg) + (:item "Choose &Font" :callback #'choose-font-dlg) + (:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t)))

Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sat Aug 19 18:56:20 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll")

(defcfun + ("ChooseColorA" choose-color) + BOOL + (struct LPTR)) ; choosecolor struct + +(defcfun ("ChooseFontA" choose-font) BOOL (struct LPTR)) ; choosefont struct

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Aug 19 18:56:20 2006 @@ -137,10 +137,20 @@

(defconstant +cbm-init+ #x04)

-(defconstant +cchdevicename+ 32) +(defconstant +cc-rgbinit+ #x00000001) +(defconstant +cc-fullopen+ #x00000002) +(defconstant +cc-preventfullopen+ #x00000004) +(defconstant +cc-showhelp+ #x00000008) +(defconstant +cc-enablehook+ #x00000010) +(defconstant +cc-enabletemplate+ #x00000020) +(defconstant +cc-enabletemplatehandle+ #x00000040) +(defconstant +cc-solidcolor+ #x00000080) +(defconstant +cc-anycolor+ #x00000100)

(defconstant +ccerr-choosecolorcodes+ #x5000)

+(defconstant +cchdevicename+ 32) + (defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001)

Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Aug 19 18:56:20 2006 @@ -150,6 +150,17 @@ (biclrused DWORD) (biclrimp DWORD))

+(defcstruct choosecolor + (ccsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (result COLORREF) + (ccolors LPTR) + (flags DWORD) + (cdata LPARAM) + (hookfn LPTR) ; CCHookProc + (templname :string)) + (defcstruct choosefont (structsize DWORD) (howner HANDLE) @@ -159,7 +170,7 @@ (flags DWORD) (color COLORREF) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (hookfn LPTR) ; CFHookProc (templname :string) (hinstance HANDLE) (style :string) @@ -184,7 +195,7 @@ (whatlen WORD) (withlen WORD) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (hookfn LPTR) ; FRHookProc (templname :string))

(defcstruct iconinfo

Added: trunk/src/uitoolkit/widgets/color-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/color-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -0,0 +1,130 @@ +;;;; +;;;; color-dialog.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.widgets) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +custom-color-array-size+ 16)) + +;;; +;;; helper functions +;;; + +(defun obtain-chosen-color (dlg) + (let ((cc-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p cc-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr gfs::choosecolor) + (values (gfg:rgb->color gfs::result) + (loop for index to (1- +custom-color-array-size+) + collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index))))))) + +(defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body) + (let ((dlg (gensym))) + `(let ((,color nil) + (,custom-colors nil) + (,dlg (make-instance 'color-dialog + :initial-custom-colors ,initial-custom-colors + :initial-color ,initial-color + :owner ,owner + :style ,style))) + (unwind-protect + (unless (zerop (show ,dlg t)) + (multiple-value-bind (tmp-color tmp-custom) + (obtain-chosen-color ,dlg) + (setf ,color tmp-color + ,custom-colors tmp-custom) + ,@body)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self color-dialog) &rest extra-data) + (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0)))) + (loop for sym in (style-of self) + do (ecase sym + (:allow-custom-colors + (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+)))) + (:display-solid-only) + (setf std-flags (logior std-flags gfs::+cc-solidcolor+)))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self color-dialog)) + (let ((cc-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cc-ptr) + (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr gfs::choosecolor) + (unless (cffi:null-pointer-p gfs::ccolors) + (cffi:foreign-free gfs::ccolors))) + (cffi:foreign-free cc-ptr) + (setf (slot-value self 'gfs:handle) nil)))) + +(defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cc-ptr (cffi:foreign-alloc 'gfs::choosecolor)) + (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+)) + (index 0) + (default-rgb (gfg:color->rgb gfg:*color-black*))) + (loop for color in initial-custom-colors + when (< index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color)) + (incf index))) + (loop until (>= index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb) + (incf index))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self initial-color) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result + gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname) + cc-ptr gfs::choosecolor) + (setf gfs::ccsize (cffi:foreign-type-size 'gfs::choosecolor) + gfs::howner (gfs:handle owner) + gfs::hinst (cffi:null-pointer) + gfs::result (gfg:color->rgb (or initial-color (gfg:make-color))) + gfs::ccolors colors-ptr + gfs::flags std-style + gfs::cdata 0 + gfs::hookfn (cffi:null-pointer) + gfs::templname (cffi:null-pointer)))) + (setf (slot-value self 'gfs:handle) cc-ptr))) + +(defmethod show ((self color-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-color))

Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -38,19 +38,18 @@ ;;;

(defun file-dialog-paths (dlg) - (let ((paths nil) - (ofn-ptr (gfs:handle dlg))) + (let ((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)) + (if (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + nil (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)) + (if (rest raw-list) + (loop for filename in (rest raw-list) + collect (parse-namestring (concatenate 'string dir-str "\" filename))) + (list (parse-namestring dir-str))))))))

(defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) (let ((dlg (gensym))) @@ -106,7 +105,7 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) nil))))

(defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE

Modified: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/font-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -65,12 +65,11 @@ :owner ,owner :style ,style))) (unwind-protect - (progn - (unless (zerop (show ,dlg t)) - (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) - (setf ,font f) - (setf ,color c)) - ,@body)) + (unless (zerop (show ,dlg t)) + (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) + (setf ,font f) + (setf ,color c)) + ,@body) (gfs:dispose ,dlg)))))

;;;

Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sat Aug 19 18:56:20 2006 @@ -116,15 +116,15 @@ (setf (top-margin-of self) vertical-margins (bottom-margin-of self) vertical-margins)))

-(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) - (let ((orig-layout (layout-of container))) +(defmethod (setf layout-of) :after ((layout layout-manager) (self layout-managed)) + (let ((orig-layout (layout-of self))) (if orig-layout - (setf (data-of self) (loop for item in (data-of orig-layout) - when (not (gfs:disposed-p (first item))) - collect item) + (setf (data-of layout) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) (data-of orig-layout) nil) - (if (typep container 'window) - (setf (data-of self) (mapchildren container (lambda (parent child) + (if (typep self 'window) + (setf (data-of layout) (mapchildren self (lambda (parent child) (declare (ignore parent)) (list child nil))))))))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 18:56:20 2006 @@ -142,6 +142,9 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image."))

+(defclass color-dialog (widget) () + (:documentation "This class represents the standard color chooser dialog.")) + (defclass file-dialog (widget) ((open-mode :reader open-mode

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 18:56:20 2006 @@ -249,9 +249,6 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise."))

-(defgeneric object-to-display (self pnt) - (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) - (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent)."))