graphic-forms-cvs

Download

graphic-forms-cvs@lists.common-lisp.net

July 2006

1 participants
31 discussions

[graphic-forms-cvs] r168 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 02 Jul '06

02 Jul '06

Author: junrue Date: Sun Jul 2 14:32:26 2006 New Revision: 168 Added: trunk/src/uitoolkit/widgets/font-dialog.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image.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/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented font-dialog, refactored font-data and font classes, implemented show-common-dialog to centralize system dialog invocation Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 14:32:26 2006 @@ -377,18 +377,17 @@ @end itemize 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 +by the user. However, applications may choose to implement 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. In either case, zero is returned if the -user cancelled the dialog. Also, manual construction of an instance +user cancelled the dialog. 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.@*@* +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 +future release 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 @@ -424,8 +423,7 @@ @end deffn @deffn Initarg :owner A value is required for this initarg, and it may be either a -@ref{window} or a @ref{dialog}. The file dialog will remain above the -specified @code{owner} in the window system Z-order. +@ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style This initarg accepts a list of keyword symbols, as follows: @@ -448,7 +446,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. @@ -462,8 +460,73 @@ @end deffn @end deftp +@anchor{font-dialog} +@deftp Class font-dialog +This class provides a standard dialog for choosing attributes +of a @ref{font}, either from scratch or relative to an existing font. +A variety of style options may be selected, including strikeout +and font color.@*@* +The @ref{with-font-dialog} macro wraps the creation of a @code{font-dialog} +and provides a new font object based on the user's selections. However, +applications may choose to implement these steps manually, in which case +the @ref{font-dialog-results} function can be called to obtain the results +of the user's selections. Manual construction of an instance must be followed +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 +will provide a customization mechanism.@* +@deffn Initarg :gc +This required initarg accepts a @ref{graphics-context} object providing +context for the font selection, such as when the set of fonts to be offered +depends on a printer device. +@end deffn +@deffn Initarg :initial-color +This initarg accepts a @ref{color} object which the font dialog +will use for its initial color selection (as long as the @code{:no-effects} +style is @strong{not} set). +@end deffn +@deffn Initarg :initial-font +This initarg accepts a @ref{font} object which the font dialog +will use for its initial font attribute selections. If not +specified, the dialog will be set to the system font's attributes. +@end deffn +@deffn Initarg :owner +A value is required for this initarg, and it may be either a +@ref{window} or a @ref{dialog}. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols, as follows: +@table @code +@item :all-fonts +This is a convenience style, used by default if no other font +criteria are specified, that enables the dialog to offer all +possible fonts. +@item :fixed-pitch-fonts +Enables the dialog to offer fixed pitch fonts. +@item :no-effects +Causes the font dialog to hide the controls that +allow the user to specify strikeout, underline, and text color +attributes. +@item :printer-fonts +Enables the dialog to offer fonts supported by the printer associated +with the graphics-context supplied via the @code{:gc} initarg. +@item :screen-fonts +Enables the dialog to offer screen fonts supported by the system. +@item :truetype-fonts +Enables the dialog to offer TrueType fonts. +@item :wysiwyg-fonts +Enables the dialog to offer the intersection of the sets of fonts +available on the screen and the printer associated with the +graphics-context specified by the @code{:gc} initarg. +@end table +@end deffn +@end deftp + @anchor{group} @deftp Class group layout children location size style +@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 and behaviors: @@ -970,11 +1033,12 @@ @end deffn @anchor{file-dialog-paths} -@deffn Function file-dialog-paths dlg +@deffn Function 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. +of file @sc{namestring}s. Use this function when manually constructing +a file dialog. @xref{with-file-dialog}. @end deffn @deffn GenericFunction focus-p self @@ -982,6 +1046,19 @@ otherwise. @end deffn +@anchor{font-dialog-results} +@deffn Function 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 +them via @sc{values}. The @code{gc} parameter should be the same +@ref{graphics-context} object with which the dialog was created. +If the user cancelled the dialog, the font value will be @sc{nil}. +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 + @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @end deffn @@ -1173,8 +1250,18 @@ @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}. +and the subsequent retrieval of the user's file selections (supplied to @code{body} +via @code{paths}). @xref{file-dialog}. +@end deffn + +@anchor{with-font-dialog} +@deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body +This macro wraps the instantiation of a standard font dialog and binds +@code{font} to a font object, and @code{color} to a @ref{color} object, +corresponding to the attributes selected by the user. If the user cancels +the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also +be @sc{nil} if the dialog was created with the @code{:no-effects} style +keyword. @xref{font-dialog}. @end deffn @@ -1226,6 +1313,7 @@ @strong{NOTE:} A future release will provide additional graphics classes. +@anchor{color} @deftp Structure color red green blue This is a structure representing a color using three bytes in the RGB colorspace. @end deftp @@ -1304,6 +1392,7 @@ may use to position graphical elements. @xref{font}. @end deftp +@anchor{graphics-context} @deftp Class graphics-context This subclass of @ref{native-object} wraps a native device context, hence instances of this class are used to perform drawing operations. @@ -1425,8 +1514,11 @@ Returns a color object corresponding to the current background color. @end deffn -@deffn GenericFunction data-obj self -Returns the data structure representing the raw form of the object. +@deffn GenericFunction data-object self &optional gc => object +Returns the data structure representing the raw data form of the +object. The @code{gc} argument must be supplied when calling this +function on a @ref{font}, and the value must be a +@ref{graphics-context}. @end deffn @deffn GenericFunction depth self Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Jul 2 14:32:26 2006 @@ -113,6 +113,7 @@ (: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 Sun Jul 2 14:32:26 2006 @@ -140,7 +140,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics - #:data-obj + #:data-object #:depth #:descent #:draw-arc @@ -231,6 +231,7 @@ #:event-dispatcher #:event-source #:file-dialog + #:font-dialog #:flow-layout #:heap-layout #:item @@ -393,6 +394,7 @@ #:file-dialog-paths #:focus-index #:focus-p + #:font-dialog-results #:foreground-color #:give-focus #:grid-line-width @@ -492,6 +494,7 @@ #:visible-p #:with-children #:with-file-dialog + #:with-font-dialog ;; conditions )) Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Sun Jul 2 14:32:26 2006 @@ -58,7 +58,7 @@ (assert-equal (gfs:size-width size1) (gfs:size-width size2) path) (assert-equal (gfs:size-height size1) (gfs:size-height size2) path)) (gfg:load im path) - (setf d3 (gfg:data-obj im)) + (setf d3 (gfg:data-object im)) (assert-equal (gfg:depth d1) (gfg:depth d3) path) (let ((size1 (gfg:size d1)) (size2 (gfg:size d3))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Jul 2 14:32:26 2006 @@ -118,6 +118,17 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-font-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*))) + (unwind-protect + (gfw:with-font-dialog (*main-win* nil font color :gc gc) + (if color + (print color)) + (if font + (print (gfg:data-object font gc)))) + (gfs:dispose gc)))) + (defclass dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) @@ -231,16 +242,17 @@ :style '(:workspace))) (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))) (: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))) + :submenu ((: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) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font-data.lisp (original) +++ trunk/src/uitoolkit/graphics/font-data.lisp Sun Jul 2 14:32:26 2006 @@ -33,50 +33,99 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defun compute-font-weight (style) - (if (null (find :bold style)) - gfs::+fw-normal+ - gfs::+fw-bold+)) - -(defun compute-font-precis (style) - (if (find :truetype-only style) - (return-from compute-font-precis gfs::+out-tt-only-precis+)) - (if (find :outline style) - (return-from compute-font-precis gfs::+out-outline-precis+)) - gfs::+out-default-precis+) - -(defun compute-font-pitch (style) - (if (find :fixed style) - (return-from compute-font-pitch gfs::+fixed-pitch+)) - (if (find :variable style) - (return-from compute-font-pitch gfs::+variable-pitch+)) - gfs::+default-pitch+) +(defun pntsize->lfheight (hdc pntsize) + (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+))) + (- (floor (+ (/ (* pntsize log-height) 72) 0.5))))) -(defun data->font (hdc data) - (let ((hfont (cffi:null-pointer)) +(defun lfheight->pntsize (hdc lfheight) + (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+))) + (floor (* (+ (- lfheight) 0.5) 72) log-height))) + +(defun style->logfont (style lf-ptr) + (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily) + lf-ptr gfs::logfont) + (setf gfs::lfweight (if (find :bold style) gfs::+fw-bold+ gfs::+fw-normal+)) + (setf gfs::lfitalic (if (find :italic style) 1 0)) + (setf gfs::lfunderline (if (find :underline style) 1 0)) + (setf gfs::lfstrikeout (if (find :strikeout style) 1 0)) + (setf gfs::lfoutprec (cond + ((find :truetype-only style) gfs::+out-tt-only-precis+) + ((find :outline style) gfs::+out-outline-precis+) + (t gfs::+out-default-precis+))) + (setf gfs::lfpitchandfamily (cond + ((find :fixed style) gfs::+fixed-pitch+) + ((find :variable style) gfs::+variable-pitch+) + (t gfs::+default-pitch+))))) + +(defun logfont->style (lf-ptr) + (let ((style nil)) + (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily) + lf-ptr gfs::logfont) + (if (= gfs::lfweight gfs::+fw-bold+) + (push :bold style)) + (unless (zerop gfs::lfitalic) + (push :italic style)) + (unless (zerop gfs::lfunderline) + (push :underline style)) + (unless (zerop gfs::lfstrikeout) + (push :strikeout style)) + (case gfs::lfoutprec + (#.gfs::+out-tt-only-precis+ (push :truetype-only style)) + (#.gfs::+out-outline-precis+ (push :outline style))) + (case gfs::lfpitchandfamily + (#.gfs::+fixed-pitch+ (push :fixed style)) + (#.gfs::+variable-pitch+ (push :variable style)))) + style)) + +(defun data->logfont (hdc data) + (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont)) (style (font-data-style data))) - (cffi:with-foreign-object (lf-ptr 'gfs::logfont) - (gfs:zero-mem lf-ptr gfs::logfont) - (cffi:with-foreign-slots ((gfs::lfheight gfs::lfweight gfs::lfitalic gfs::lfunderline - gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec - gfs::lfpitchandfamily gfs::lffacename) - lf-ptr gfs::logfont) - (setf gfs::lfheight (- (floor (+ (/ (* (font-data-point-size data) - (gfs::get-device-caps hdc gfs::+logpixelsy+)) - 72) - 0.5)))) - (setf gfs::lfweight (compute-font-weight style)) - (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) - (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) - (setf gfs::lfstrikeout (if (null (find :strikeout style)) 0 1)) - (setf gfs::lfcharset (font-data-char-set data)) - (setf gfs::lfoutprec (compute-font-precis style)) - (setf gfs::lfpitchandfamily (compute-font-pitch style)) - (cffi:with-foreign-string (str (font-data-face-name data)) - (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) - (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) - (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) - (setf hfont (gfs::create-font-indirect lf-ptr)) - (if (gfs:null-handle-p hfont) - (error 'gfs:win32-error :detail "create-font-indirect failed"))) + (gfs:zero-mem lf-ptr gfs::logfont) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont) + (setf gfs::lfheight (pntsize->lfheight hdc (font-data-point-size data))) + (setf gfs::lfcharset (font-data-char-set data)) + (style->logfont style lf-ptr) + (cffi:with-foreign-string (str (font-data-face-name data)) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) + (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) + lf-ptr)) + +(defun logfont->data (hdc lf-ptr) + (let ((char-set 0) + (face-name "") + (point-size 0) + (style nil)) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont) + (setf point-size (lfheight->pntsize hdc gfs::lfheight)) + (setf char-set gfs::lfcharset) + (setf style (logfont->style lf-ptr)) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (setf face-name (cffi:foreign-string-to-lisp lffacename-ptr)))) + (gfg:make-font-data :char-set char-set + :face-name face-name + :point-size point-size + :style style))) + +(defun data->font (hdc data) + (let ((hfont (cffi:null-pointer))) + (setf hfont (gfs::create-font-indirect (data->logfont hdc data))) + (if (gfs:null-handle-p hfont) + (error 'gfs:win32-error :detail "create-font-indirect failed")) hfont)) + +(defun font->data (hdc hfont) + (cffi:with-foreign-object (lf-ptr 'gfs::logfont) + (gfs:zero-mem lf-ptr gfs::logfont) + (if (zerop (gfs::get-object hfont (cffi:foreign-type-size 'gfs::logfont) lf-ptr)) + (error 'gfs:win32-error :detail "get-object failed")) + (logfont->data hdc lf-ptr))) + +(defmethod print-object ((self font-data) stream) + (print-unreadable-object (self stream :type t) + (format stream "face name: ~a " (font-data-face-name self)) + (format stream "point size: ~d " (font-data-point-size self)) + (format stream "style: ~a " (font-data-style self)) + (format stream "char-set: ~d" (font-data-char-set self)))) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Sun Jul 2 14:32:26 2006 @@ -37,12 +37,17 @@ ;;; methods ;;; -(defmethod gfs:dispose ((fn font)) - (let ((hgdi (gfs:handle fn))) +(defmethod data-object ((self font) &optional gc) + (if (or (gfs:disposed-p self) (gfs:disposed-p gc)) + (error 'gfs:disposed-error)) + (font->data (gfs:handle gc) (gfs:handle self))) + +(defmethod gfs:dispose ((self font)) + (let ((hgdi (gfs:handle self))) (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (slot-value fn 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) -(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) +(defmethod initialize-instance :after ((self font) &key gc data &allow-other-keys) (if gc - (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data)))) + (setf (slot-value self 'gfs:handle) (data->font (gfs:handle gc) data)))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Jul 2 14:32:26 2006 @@ -36,7 +36,7 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric data-obj (self) +(defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of the object.")) (defgeneric depth (self) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Jul 2 14:32:26 2006 @@ -72,15 +72,16 @@ (gfs::delete-object hgdi))) (setf (slot-value im 'gfs:handle) nil)) -(defmethod data-obj ((im image)) - (when (gfs:disposed-p im) +(defmethod data-object ((self image) &optional gc) + (declare (ignore gc)) + (when (gfs:disposed-p self) (error 'gfs:disposed-error)) - (image->data (gfs:handle im))) + (image->data (gfs:handle self))) -(defmethod (setf data-obj) ((id image-data) (im image)) - (unless (gfs:disposed-p im) - (gfs:dispose im)) - (setf (slot-value im 'gfs:handle) (data->image id))) +(defmethod (setf data-object) ((id image-data) (self image)) + (unless (gfs:disposed-p self) + (gfs:dispose self)) + (setf (slot-value self 'gfs:handle) (data->image id))) (defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) (cond @@ -108,7 +109,7 @@ (defmethod load ((im image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-obj im) data) + (setf (data-object im) data) data)) (defmethod size ((image image)) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sun Jul 2 14:32:26 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseFontA" choose-font) + BOOL + (struct LPTR)) + +(defcfun ("CommDlgExtendedError" comm-dlg-extended-error) DWORD) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 2 14:32:26 2006 @@ -142,6 +142,35 @@ (defconstant +cderr-nohook+ #x000b) (defconstant +cderr-registermsgfail+ #x000C) +(defconstant +cf-screenfonts+ #x00000001) +(defconstant +cf-printerfonts+ #x00000002) +(defconstant +cf-both+ #x00000003) +(defconstant +cf-showhelp+ #x00000004) +(defconstant +cf-enablehook+ #x00000008) +(defconstant +cf-enabletemplate+ #x00000010) +(defconstant +cf-enabletemplatehandle+ #x00000020) +(defconstant +cf-inittologfontstruct+ #x00000040) +(defconstant +cf-usestyle+ #x00000080) +(defconstant +cf-effects+ #x00000100) +(defconstant +cf-apply+ #x00000200) +(defconstant +cf-ansionly+ #x00000400) +(defconstant +cf-scriptsonly+ #x00000400) +(defconstant +cf-novectorfonts+ #x00000800) +(defconstant +cf-nooemfonts+ #x00000800) +(defconstant +cf-nosimulations+ #x00001000) +(defconstant +cf-limitsize+ #x00002000) +(defconstant +cf-fixedpitchonly+ #x00004000) +(defconstant +cf-wysiwyg+ #x00008000) +(defconstant +cf-forcefontexist+ #x00010000) +(defconstant +cf-scalableonly+ #x00020000) +(defconstant +cf-ttonly+ #x00040000) +(defconstant +cf-nofacesel+ #x00080000) +(defconstant +cf-nostylesel+ #x00100000) +(defconstant +cf-nosizesel+ #x00200000) +(defconstant +cf-selectscript+ #x00400000) +(defconstant +cf-noscriptsel+ #x00800000) +(defconstant +cf-novertfonts+ #x01000000) + (defconstant +cferr-choosefontcodes+ #x2000) (defconstant +cferr-nofonts+ #x2001) (defconstant +cferr-maxlessthanmin+ #x2002) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sun Jul 2 14:32:26 2006 @@ -127,6 +127,23 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosefont + (structsize DWORD) + (howner HANDLE) + (hdc HANDLE) + (logfont LPTR) + (pointsize INT) + (flags DWORD) + (color COLORREF) + (data LPARAM) + (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (templname :string) + (hinstance HANDLE) + (style :string) + (fonttype WORD) + (minsize INT) + (maxsize INT)) + (defcstruct drawtextparams (cbsize UINT) (tablength INT) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Jul 2 14:32:26 2006 @@ -74,12 +74,12 @@ ;;; methods ;;; -(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data) +(defmethod compute-style-flags ((self 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-of dlg) + (loop for sym in (style-of self) do (cond ((eq sym :add-to-recent) (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+)))) @@ -91,8 +91,8 @@ (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))) +(defmethod gfs:dispose ((self file-dialog)) + (let ((ofn-ptr (gfs:handle self))) (unless (cffi:null-pointer-p ofn-ptr) (cffi:with-foreign-slots ((gfs::ofnfile gfs::ofnfilter gfs::ofntitle gfs::ofninitialdir gfs::ofndefext) @@ -106,9 +106,9 @@ (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))))) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) -(defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text) +(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 ;; so that the file buffer can be resized as needed for ;; multi-select mode. @@ -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) + (compute-style-flags self) (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 @@ -168,12 +168,11 @@ gfs::ofnpvreserved (cffi:null-pointer) gfs::ofndwreserved 0 gfs::ofnexflags ex-style))) - (setf (slot-value dlg 'gfs:handle) ofn-ptr) - (setf (slot-value dlg 'open-mode) (find :open style)))) + (setf (slot-value self 'gfs:handle) ofn-ptr) + (setf (slot-value self 'open-mode) (find :open style)))) -(defmethod show ((dlg file-dialog) flag) +(defmethod show ((self 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")))) + (if (open-mode self) + (show-common-dialog self #'gfs::get-open-filename) + (show-common-dialog self #'gfs::get-save-filename))) Added: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sun Jul 2 14:32:26 2006 @@ -0,0 +1,144 @@ +;;;; +;;;; font-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) + +(defconstant +font-dialog-flags+ (logior gfs::+cf-effects+ gfs::+cf-inittologfontstruct+)) + +;;; +;;; helper functions +;;; + +(defun font-dialog-results (dlg gc) + (if (or (gfs:disposed-p dlg) (gfs:disposed-p gc)) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::logfont gfs::color) (gfs:handle dlg) gfs::choosefont) + (values (make-instance 'gfg:font :handle (gfs::create-font-indirect gfs::logfont)) + (gfg::rgb->color gfs::color)))) + +(defun lookup-default-font () + (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont))) + (gfs:zero-mem lf-ptr gfs::logfont) + (gfs::get-object (gfs::get-stock-object gfs::+system-font+) + (cffi:foreign-type-size 'gfs::logfont) + lf-ptr) + lf-ptr)) + +(defmacro with-font-dialog ((owner style font color &key gc initial-color initial-font) &body body) + (let ((dlg (gensym))) + `(let ((,font nil) + (,color nil) + (,dlg (make-instance 'font-dialog + :gc ,gc + :initial-color ,initial-color + :initial-font ,initial-font + :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)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self font-dialog) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior gfs::+cf-both+ +font-dialog-flags+))) + (loop for sym in (style-of self) + do (ecase sym + ;; primary styles + ;; + (:all-fonts + (setf std-flags (logior gfs::+cf-both+ +font-dialog-flags+))) + (:fixed-pitch-fonts + (setf std-flags (logior gfs::+cf-fixedpitchonly+ +font-dialog-flags+))) + (:printer-fonts + (setf std-flags (logior gfs::+cf-printerfonts+ +font-dialog-flags+))) + (:screen-fonts + (setf std-flags (logior gfs::+cf-screenfonts+ +font-dialog-flags+))) + (:truetype-fonts + (setf std-flags (logior gfs::+cf-ttonly+ +font-dialog-flags+))) + (:wsyiwyg-fonts + (setf std-flags (logior gfs::+cf-both+ + gfs::+cf-scalableonly+ + gfs::+cf-wysiwyg+ + +font-dialog-flags+))) + + ;; styles that can be combined + ;; + (:no-effects + (setf std-flags (logand std-flags (lognot gfs::+cf-effects+)))))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self font-dialog)) + (let ((cf-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cf-ptr) + (cffi:with-foreign-slots ((gfs::logfont) cf-ptr gfs::choosefont) + (unless (cffi:null-pointer-p gfs::logfont) + (cffi:foreign-free gfs::logfont))) + (cffi:foreign-free cf-ptr))) + (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + +(defmethod initialize-instance :after ((self font-dialog) &key gc initial-color initial-font owner &allow-other-keys) + (if (null gc) + (error 'gfs:toolkit-error :detail ":gc initarg is required")) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cf-ptr (cffi:foreign-alloc 'gfs::choosefont)) + (lf-ptr (if initial-font + (gfg::data->logfont (gfs:handle gc) (gfg:data-object initial-font gc)) + (lookup-default-font)))) + (multiple-value-bind (std-style ex-style) (compute-style-flags self) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::structsize gfs::howner gfs::hdc gfs::logfont + gfs::flags gfs::color) + cf-ptr gfs::choosefont) + (setf gfs::structsize (cffi:foreign-type-size 'gfs::choosefont) + gfs::howner (gfs:handle owner) + gfs::hdc (gfs:handle gc) + gfs::logfont lf-ptr + gfs::flags std-style + gfs::color (if initial-color (gfg:color->rgb initial-color) 0)))) + (setf (slot-value self 'gfs:handle) cf-ptr))) + +(defmethod show ((self font-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-font)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 2 14:32:26 2006 @@ -130,6 +130,9 @@ :initform t)) (:documentation "This class represents the standard file open/save dialog.")) +(defclass font-dialog (widget) () + (:documentation "This class represents the standard font dialog.")) + (defclass widget-with-items (widget) ((items :accessor items Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jul 2 14:32:26 2006 @@ -107,6 +107,13 @@ (error 'gfs:win32-error :detail "create-window failed")) hwnd)))) +(defun show-common-dialog (dlg dlg-func) + (let* ((struct-ptr (gfs:handle dlg)) + (retval (funcall dlg-func struct-ptr))) + (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error)))) + (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) + retval)) + (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error))

1 0