[graphic-forms-cvs] r103 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Apr 24 06:38:34 UTC 2006
Author: junrue
Date: Mon Apr 24 02:38:32 2006
New Revision: 103
Added:
trunk/src/uitoolkit/widgets/file-dialog.lisp
Modified:
trunk/docs/manual/api.texinfo
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/system-types.lisp
trunk/src/uitoolkit/system/system-utils.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
Log:
implemented open and save file dialogs; revised widget-with-items to store items as a list rather than a vector
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon Apr 24 02:38:32 2006
@@ -186,6 +186,14 @@
@ref{widget}.
@end deftp
+ at anchor{dialog}
+ at deftp Class dialog
+This is the base class for system and user-defined dialogs. A dialog
+is a windowed UI component that is @emph{typically} defined to remain
+on top of the primary application window(s). Of course, some
+applications are entirely dialog-based.
+ at end deftp
+
@anchor{display}
@deftp Class display primary
Instances of this class describe characteristics of monitors attached
@@ -227,6 +235,94 @@
@end deffn
@end deftp
+ at anchor{file-dialog}
+ at deftp Class file-dialog
+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
+implemented regardless of other style flags or initarg values:
+ at itemize @bullet
+ at item in @code{:save} mode, the user will be prompted to confirm
+overwrite when an existing file is selected
+ at end itemize
+Applications retrieve selected files by calling the @code{items}
+function, which returns a list 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.@*@*
+ at 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
+be removed. Also, only the first three characters are used.
+ at end deffn
+ at deffn Initarg :filters
+This initarg accepts a list of conses, @sc{first} holding a string
+that describes a filter, e.g., @samp{Text Files}, and @sc{second}
+specifying the actual filter pattern, e.g., @samp{*.TXT}. Note that
+multiple filter patterns can be grouped with a single description by
+separating them with semicolons, e.g., @samp{*.TXT;*.BAK}.
+ at end deffn
+ at deffn Initarg :initial-directory
+This initarg accepts a @sc{directory namestring} identifying the
+location in the file system whose contents are to be browsed by the
+file dialog. @strong{Note:} setting this value will result in the
+side-effect of changing the current working directory of the @sc{lisp}
+process. Also, the supplied value is used only if the @sc{namestring}
+supplied for @code{:initial-filename} does not contain a path.
+ at end deffn
+ at deffn Initarg :initial-filename
+This initarg accepts a @sc{file namestring} which has several
+purposes:
+ at itemize @bullet
+ at item populate the edit field in the file dialog with the file name
+and extension
+ at item set the initial directory of the file dialog (and hence
+the current working directory of the @sc{lisp} process) if it contains
+a directory path
+ at item if the file actually exists in the directory, set the other
+components of the file dialog to reflect the attributes of the file
+ at end itemize
+ at end deffn
+ at deffn Initarg :owner
+A value is required for this initarg, and it may be either a
+ at ref{window} or a @ref{dialog}. The file dialog will remain above the
+specified @code{owner} in the window system Z-order.
+ at end deffn
+ at deffn Initarg :style
+This initarg accepts a list of keyword symbols, as follows:
+ at table @code
+ at item :add-to-recent
+This enables the system to add a link to the selected file
+in the directory that contains the user's most recently
+used documents.
+ at item :multiple-select
+This configures the dialog to accept multiple selections.
+ at item :open
+This configures the dialog to be used to select one or more files
+for loading data.
+ at item :path-must-exist
+This keyword enables a validation check that constrains the user's
+selection to file paths that actually exist. A warning dialog will be
+displayed if the user supplies a non-existent path.
+ at item :save
+This configures the dialog to be used to specify a destination file
+for data to be saved.
+ at 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
+ at sc{system} will not be displayed in any case. Also, be aware that
+using this keyword effectively overrides the user's preference
+settings.
+ at end table
+ at end deffn
+ at deffn Initarg :text
+This initarg accepts a string that will become the title of the file
+dialog. By default, a file dialog with the @code{:open} style flag
+will display @samp{Open} whereas the @code{:save} style flag will
+result in a title of @samp{Save As}.
+ at end deffn
+ at end deftp
+
@anchor{item}
@deftp Class item item-id
The @code{item} class is the base class for all non-windowed user
@@ -581,14 +677,6 @@
Returns T if the object is enabled; nil otherwise.
@end deffn
- at deffn GenericFunction item-at self index
-Return the item at the given zero-based index from the object.
- at end deffn
-
- at deffn GenericFunction item-count self
-Return the number of items possessed by the object.
- at end deffn
-
@deffn GenericFunction item-index self item
Return the zero-based index of the location of the other object in this object.
@end deffn
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Mon Apr 24 02:38:32 2006
@@ -109,5 +109,6 @@
(:file "root-window")
(:file "top-level")
(:file "panel")
+ (:file "file-dialog")
(:file "layout")
(:file "flow-layout")))))))))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Apr 24 02:38:32 2006
@@ -81,6 +81,7 @@
#:zero-mem
;; conditions
+ #:comdlg-error
#:disposed-error
#:toolkit-error
#:toolkit-warning
@@ -219,6 +220,7 @@
#:display
#:event-dispatcher
#:event-source
+ #:file-dialog
#:flow-layout
#:item
#:layout-manager
@@ -387,8 +389,6 @@
#:initial-delay-of
#:horizontal-scrollbar
#:image
- #:item-at
- #:item-count
#:item-height
#:item-id
#:item-index
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Apr 24 02:38:32 2006
@@ -44,8 +44,8 @@
(defun find-checked-item (disp menu time)
(declare (ignore disp time))
- (dotimes (i (gfw:item-count menu))
- (let ((item (gfw:item-at menu i)))
+ (dotimes (i (length (gfw:items menu)))
+ (let ((item (elt (gfw:items menu) i)))
(when (gfw:checked-p item)
(setf *last-checked-drawing-item* item)
(return)))))
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Apr 24 02:38:32 2006
@@ -200,7 +200,7 @@
(defun manage-file-menu (disp menu time)
(declare (ignore disp time))
- (let ((item (gfw:item-at menu 0)))
+ (let ((item (elt (gfw:items menu) 0)))
(setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
(defun manage-timer (disp item time rect)
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Apr 24 02:38:32 2006
@@ -183,8 +183,8 @@
(defun check-flow-orient-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
- (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout)))
- (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout)))))
+ (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout)))
+ (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))
(defun set-flow-horizontal (disp item time rect)
(declare (ignorable disp item time rect))
@@ -216,7 +216,7 @@
(defun enable-flow-spacing-items (disp menu time)
(declare (ignore disp time))
(let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
- (gfw:enable (gfw:item-at menu 0) (> spacing 0))))
+ (gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))
(defun decrease-flow-spacing (disp item time rect)
(declare (ignore disp item time rect))
@@ -236,22 +236,22 @@
(defun enable-left-flow-margin-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
- (gfw:enable (gfw:item-at menu 0) (> (gfw:left-margin-of layout) 0))))
+ (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0))))
(defun enable-top-flow-margin-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
- (gfw:enable (gfw:item-at menu 0) (> (gfw:top-margin-of layout) 0))))
+ (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0))))
(defun enable-right-flow-margin-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
- (gfw:enable (gfw:item-at menu 0) (> (gfw:right-margin-of layout) 0))))
+ (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0))))
(defun enable-bottom-flow-margin-items (disp menu time)
(declare (ignore disp time))
(let ((layout (gfw:layout-of *layout-tester-win*)))
- (gfw:enable (gfw:item-at menu 0) (> (gfw:bottom-margin-of layout) 0))))
+ (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0))))
(defun inc-left-flow-margin (disp item time rect)
(declare (ignore disp item time rect))
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Mon Apr 24 02:38:32 2006
@@ -96,16 +96,40 @@
(setf (gfw:text window) "Palette")
(gfw:show window t)))
+(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))))
+
+(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))))
+
(defun run-windlg-internal ()
(let ((menubar nil))
(setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events)
:style '(:workspace)))
(setf menubar (gfw:defmenu ((:item "&File"
:submenu ((:item "E&xit" :callback #'windlg-exit-fn)))
+ (:item "&Dialogs"
+ :submenu ((: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/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Mon Apr 24 02:38:32 2006
@@ -109,6 +109,27 @@
(defconstant +cchdevicename+ 32)
+(defconstant +ccerr-choosecolorcodes+ #x5000)
+
+(defconstant +cderr-dialogfailure+ #xffff)
+(defconstant +cderr-generalcodes+ #x0000)
+(defconstant +cderr-structsize+ #x0001)
+(defconstant +cderr-initialization+ #x0002)
+(defconstant +cderr-notemplate+ #x0003)
+(defconstant +cderr-nohinstance+ #x0004)
+(defconstant +cderr-loadstrfailure+ #x0005)
+(defconstant +cderr-findresfailure+ #x0006)
+(defconstant +cderr-loadresfailure+ #x0007)
+(defconstant +cderr-lockresfailure+ #x0008)
+(defconstant +cderr-memallocfailure+ #x0009)
+(defconstant +cderr-memlockfailure+ #x000a)
+(defconstant +cderr-nohook+ #x000b)
+(defconstant +cderr-registermsgfail+ #x000c)
+
+(defconstant +cferr-choosefontcodes+ #x2000)
+(defconstant +cferr-nofonts+ #x2001)
+(defconstant +cferr-maxlessthanmin+ #x2002)
+
(defconstant +color-scrollbar+ 0)
(defconstant +color-background+ 1)
(defconstant +color-activecaption+ 2)
@@ -199,6 +220,11 @@
(defconstant +eto-ignorelanguage+ #x1000)
(defconstant +eto-pdy+ #x2000)
+(defconstant +fnerr-filenamecodes+ #x3000)
+(defconstant +fnerr-subclassfailure+ #x3001)
+(defconstant +fnerr-invalidfilename+ #x3002)
+(defconstant +fnerr-buffertoosmall+ #x3003)
+
(defconstant +ff-dontcare+ #x0000)
(defconstant +ff-roman+ #x0010)
(defconstant +ff-swiss+ #x0020)
@@ -209,6 +235,9 @@
(defconstant +fr-private+ #x10)
(defconstant +fr-not-enum+ #x20)
+(defconstant +frerr-findreplacecodes+ #x4000)
+(defconstant +frerr-bufferlengthzero+ #x4001)
+
(defconstant +fw-dontcare+ 0)
(defconstant +fw-thin+ 100)
(defconstant +fw-extralight+ 200)
@@ -372,6 +401,38 @@
(defconstant +obm-size+ 32766)
(defconstant +obm-old-close+ 32767)
+(defconstant +ofn-readonly+ #x00000001)
+(defconstant +ofn-overwriteprompt+ #x00000002)
+(defconstant +ofn-hidereadonly+ #x00000004)
+(defconstant +ofn-nochangedir+ #x00000008)
+(defconstant +ofn-showhelp+ #x00000010)
+(defconstant +ofn-enablehook+ #x00000020)
+(defconstant +ofn-enabletemplate+ #x00000040)
+(defconstant +ofn-enabletemplatehandle+ #x00000080)
+(defconstant +ofn-novalidate+ #x00000100)
+(defconstant +ofn-allowmultiselect+ #x00000200)
+(defconstant +ofn-extensiondifferent+ #x00000400)
+(defconstant +ofn-pathmustexist+ #x00000800)
+(defconstant +ofn-filemustexist+ #x00001000)
+(defconstant +ofn-createprompt+ #x00002000)
+(defconstant +ofn-shareaware+ #x00004000)
+(defconstant +ofn-noreadonlyreturn+ #x00008000)
+(defconstant +ofn-notestfilecreate+ #x00010000)
+(defconstant +ofn-nonetworkbutton+ #x00020000)
+(defconstant +ofn-nolongnames+ #x00040000)
+(defconstant +ofn-explorer+ #x00080000)
+(defconstant +ofn-nodereferencelinks+ #x00100000)
+(defconstant +ofn-longnames+ #x00200000)
+(defconstant +ofn-enableincludenotify+ #x00400000)
+(defconstant +ofn-enablesizing+ #x00800000)
+(defconstant +ofn-dontaddtorecent+ #x02000000)
+(defconstant +ofn-forceshowhidden+ #x10000000)
+(defconstant +ofn-ex-noplacesbar+ #x00000001)
+
+(defconstant +ofn-sharefallthrough 2)
+(defconstant +ofn-sharenowarn 1)
+(defconstant +ofn-sharewarn 0)
+
(defconstant +oic-sample+ 32512)
(defconstant +oic-hand+ 32513)
(defconstant +oic-ques+ 32514)
@@ -408,6 +469,20 @@
(defconstant +out-screen-outline-precis+ 9)
(defconstant +out-ps-only-precis+ 10)
+(defconstant +pderr-printercodes+ #x1000)
+(defconstant +pderr-setupfailure+ #x1001)
+(defconstant +pderr-parsefailure+ #x1002)
+(defconstant +pderr-retdeffailure+ #x1003)
+(defconstant +pderr-loaddrvfailure+ #x1004)
+(defconstant +pderr-getdevmodefail+ #x1005)
+(defconstant +pderr-initfailure+ #x1006)
+(defconstant +pderr-nodevices+ #x1007)
+(defconstant +pderr-nodefaultprn+ #x1008)
+(defconstant +pderr-dndmmismatch+ #x1009)
+(defconstant +pderr-createicfailure+ #x100a)
+(defconstant +pderr-printernotfound+ #x100b)
+(defconstant +pderr-defaultdifferent+ #x100c)
+
(defconstant +qs-key+ #x0001)
(defconstant +qs-mousemove+ #x0002)
(defconstant +qs-mousebutton+ #x0004)
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Mon Apr 24 02:38:32 2006
@@ -212,11 +212,11 @@
(ofnsize DWORD)
(ofnhwnd HANDLE)
(ofnhinst HANDLE)
- (ofnfilter :string)
- (ofncustomfilter :string)
+ (ofnfilter LPTR)
+ (ofncustomfilter LPTR)
(ofnmaxcustfilter DWORD)
(ofnfilterindex DWORD)
- (ofnfile :string)
+ (ofnfile LPTR)
(ofnmaxfile DWORD)
(ofnfiletitle :string)
(ofnmaxfiletitle DWORD)
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Mon Apr 24 02:38:32 2006
@@ -50,6 +50,10 @@
`(loop for ,i from 0 below (foreign-type-size (quote ,type)) do
(setf (mem-aref ,object :char ,i) 0))))
+#+lispworks (defun native-object-special-action (obj)
+ (if (typep obj 'gfs:native-object)
+ (gfs:dispose obj)))
+
;;;
;;; convenience macros
;;;
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Mon Apr 24 02:38:32 2006
@@ -38,7 +38,7 @@
;;;
(defmethod compute-style-flags ((btn button) style &rest extra-data)
- (declare (ignore btn extra-data))
+ (declare (ignore extra-data))
(let ((std-flags 0)
(ex-flags 0))
(setf style (gfs:flatten style))
Added: trunk/src/uitoolkit/widgets/file-dialog.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Apr 24 02:38:32 2006
@@ -0,0 +1,141 @@
+;;;;
+;;;; file-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)
+
+;;;
+;;; helper functions
+;;;
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((dlg file-dialog) style &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
+ do (cond
+ ((eq sym :add-to-recent)
+ (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+))))
+ ((eq sym :multiple-select)
+ (setf std-flags (logior std-flags gfs::+ofn-allowmultiselect+)))
+ ((eq sym :path-must-exist)
+ (setf std-flags (logior std-flags gfs::+ofn-filemustexist+)))
+ ((eq sym :show-hidden)
+ (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+)))))
+ (values std-flags 0)))
+
+(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
+ ;; multi-select mode.
+ ;;
+ (if (null owner)
+ (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))
+ (filters-buffer (if filters
+ (collect-foreign-strings (loop for entry in filters
+ append (list (car entry) (cdr entry))))
+ (cffi:null-pointer)))
+ (title-buffer (cffi:null-pointer))
+ (dir-buffer (cffi:null-pointer))
+ (ext-buffer (cffi:null-pointer))
+ (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above
+ (if text
+ (setf title-buffer (collect-foreign-strings (list text))))
+ (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))))))
+ (if initial-filename
+ (cffi:with-foreign-string (tmp-str (namestring initial-filename))
+ (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 style)
+ (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
+ 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)
+ (setf gfs::ofnsize (cffi:foreign-type-size 'gfs::openfilename)
+ gfs::ofnhwnd (gfs:handle owner)
+ gfs::ofnhinst (cffi:null-pointer)
+ gfs::ofnfilter filters-buffer
+ gfs::ofncustomfilter (cffi:null-pointer)
+ gfs::ofnmaxcustfilter 0
+ gfs::ofnfilterindex 1 ; first pair of filter strings is identified by index 1 not 0
+ gfs::ofnfile file-buffer
+ gfs::ofnmaxfile 1024
+ gfs::ofnfiletitle (cffi:null-pointer)
+ gfs::ofnmaxfiletitle 0
+ gfs::ofninitialdir dir-buffer
+ gfs::ofntitle title-buffer
+ gfs::ofnflags std-style
+ gfs::ofnfileoffset 0
+ gfs::ofnfileext 0
+ gfs::ofndefext ext-buffer
+ gfs::ofncustdata 0
+ gfs::ofnhookfn (cffi:null-pointer)
+ gfs::ofntemplname (cffi:null-pointer)
+ 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))))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Apr 24 02:38:32 2006
@@ -208,7 +208,7 @@
(put-menuitem (thread-context) it)
(insert-separator hmenu)
(setf (slot-value it 'gfs:handle) hmenu)
- (vector-push-extend it (items owner))))
+ (push it (items owner))))
(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
(let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Mon Apr 24 02:38:32 2006
@@ -119,8 +119,8 @@
nil)))
(defun visit-menu-tree (menu fn)
- (dotimes (index (item-count menu))
- (let ((it (item-at menu index))
+ (dotimes (index (length (items menu)))
+ (let ((it (elt (items menu) index))
(child (sub-menu menu index)))
(unless (null child)
(visit-menu-tree child fn))
@@ -139,7 +139,7 @@
(insert-menuitem hmenu id text (cffi:null-pointer))
(setf (item-id item) id)
(put-menuitem tc item)
- (vector-push-extend item (items owner))
+ (push item (items owner))
item))
(defmethod append-submenu ((parent menu) text (submenu menu) disp)
@@ -153,7 +153,7 @@
(insert-submenu hparent id text (cffi:null-pointer) hmenu)
(setf (item-id item) id)
(put-menuitem tc item)
- (vector-push-extend item (items parent))
+ (push item (items parent))
(put-widget tc submenu)
(cond
((null disp))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Apr 24 02:38:32 2006
@@ -77,10 +77,15 @@
(defclass widget-with-items (widget)
((items
:accessor items
- ;; FIXME: allow subclasses to set initial size?
- :initform (make-array 7 :fill-pointer 0 :adjustable t)))
+ :initform nil))
(: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)."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Apr 24 02:38:32 2006
@@ -183,12 +183,6 @@
(defgeneric image (self)
(:documentation "Returns the object's image object if it has one, or nil otherwise."))
-(defgeneric item-at (self index)
- (:documentation "Return the item at the given zero-based index from the object."))
-
-(defgeneric item-count (self)
- (:documentation "Return the number of items possessed by the object."))
-
(defgeneric item-height (self)
(:documentation "Return the height of the area if one of the object's items were displayed."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Apr 24 02:38:32 2006
@@ -41,6 +41,7 @@
(run-default-message-loop))
#+lispworks (defun startup (thread-name start-fn)
+ (hcl:add-special-free-action 'gfs::native-object-special-action)
(gfg::initialize-magick (cffi:null-pointer))
(when (null (mp:list-all-processes))
(mp:initialize-multiprocessing))
@@ -55,7 +56,7 @@
(gfs::post-quit-message exit-code))
(defun clear-all (w)
- (let ((count (gfw:item-count w)))
+ (let ((count (length (items w))))
(unless (zerop count)
(gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
@@ -129,3 +130,24 @@
(setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0)))
(gfs::with-hfont-selected (hdc hfont)
(gfg::text-bounds hdc (text widget) dt-flags 0)))))
+
+(defun extract-foreign-strings (buffer)
+ (let ((strings nil))
+ (do ((curr-ptr buffer))
+ ((zerop (cffi:mem-ref curr-ptr :char)))
+ (let ((tmp (cffi:foreign-string-to-lisp curr-ptr)))
+ (push tmp strings)
+ (setf curr-ptr (cffi:make-pointer (+ (cffi:pointer-address curr-ptr) (1+ (length tmp)))))))
+ (reverse strings)))
+
+(defun collect-foreign-strings (strings)
+ (let* ((total-size (1+ (loop for str in strings
+ sum (1+ (length (namestring str))))))
+ (buffer (cffi:foreign-alloc :char :initial-element 0 :count total-size))
+ (curr-addr (cffi:pointer-address buffer)))
+ (loop for str in strings
+ do (let* ((tmp-str (namestring str))
+ (str-len (1+ (length tmp-str))))
+ (cffi:lisp-string-to-foreign tmp-str (cffi:make-pointer curr-addr) str-len)
+ (incf curr-addr str-len)))
+ buffer))
Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Apr 24 02:38:32 2006
@@ -44,8 +44,9 @@
(error 'gfs:disposed-error)))
(defmethod clear-item ((w widget-with-items) index)
- (let ((it (item-at w index)))
- (delete it (items w) :test #'items-equal-p)
+ (let* ((items (items w))
+ (it (elt items index)))
+ (setf (items w) (remove-if #'(lambda (x) (items-equal-p x it)) items))
(if (gfs:disposed-p it)
(error 'gfs:disposed-error))
(gfs:dispose it)))
@@ -59,26 +60,6 @@
(dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
(clear-item w (gfs:span-start sp))))
-(defmethod item-at :before ((w widget-with-items) index)
- (declare (ignore index))
- (if (gfs:disposed-p w)
- (error 'gfs:disposed-error)))
-
-(defmethod item-at ((w widget-with-items) index)
- (elt (items w) index))
-
-(defmethod (setf item-at) :before (index (it item) (w widget-with-items))
- (declare (ignorable index it))
- (if (gfs:disposed-p w)
- (error 'gfs:disposed-error)))
-
-(defmethod item-count :before ((w widget-with-items))
- (if (gfs:disposed-p w)
- (error 'gfs:disposed-error)))
-
-(defmethod item-count ((w widget-with-items))
- (length (items w)))
-
(defmethod item-index :before ((w widget-with-items) (it item))
(declare (ignore it))
(if (gfs:disposed-p w)
More information about the Graphic-forms-cvs
mailing list