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