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))
