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 +@anchor{dialog} +@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. +@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 +@anchor{file-dialog} +@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: +@itemize @bullet +@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 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.@*@* +@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. +@end deffn +@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}. +@end deffn +@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. +@end deffn +@deffn Initarg :initial-filename +This initarg accepts a @sc{file namestring} which has several +purposes: +@itemize @bullet +@item populate the edit field in the file dialog with the file name +and extension +@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 +@item if the file actually exists in the directory, set the other +components of the file dialog to reflect the attributes of the file +@end itemize +@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. +@end deffn +@deffn Initarg :style +This initarg accepts a list of keyword symbols, as follows: +@table @code +@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. +@item :multiple-select +This configures the dialog to accept multiple selections. +@item :open +This configures the dialog to be used to select one or more files +for loading data. +@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. +@item :save +This configures the dialog to be used to specify a destination file +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 +@sc{system} will not be displayed in any case. Also, be aware that +using this keyword effectively overrides the user's preference +settings. +@end table +@end deffn +@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}. +@end deffn +@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 -@deffn GenericFunction item-at self index -Return the item at the given zero-based index from the object. -@end deffn - -@deffn GenericFunction item-count self -Return the number of items possessed by the object. -@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)