Author: junrue Date: Tue Jun 27 22:15:00 2006 New Revision: 164
Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: edit controls can now be created, minimally tested via layout-tester
Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Jun 27 22:15:00 2006 @@ -293,11 +293,14 @@ @item :auto-hscroll Specifies that the @code{edit control} will scroll text content to the right by 10 characters when the user types a character at the end -of the line. +of the line. For single-line @code{edit control}s, this style is set +by the library. @item :auto-vscroll Specifies that the @code{edit control} will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. +@item :horizontal-scrollbar +Specifies that a horizontal scrollbar should be displayed. @item :mask-characters Specifies that each character of text be masked by an echo character instead of the one literally typed. The character can be changed via @@ -319,6 +322,8 @@ @item :read-only Specifies that the @code{edit control}'s contents cannot be modified by the user. +@item :vertical-scrollbar +Specifies that a vertical scrollbar should be displayed. @item :want-return Specifies that a carriage return be inserted when the user types @sc{enter}. This style keyword only applies when the @code{:multi-line} @@ -327,6 +332,9 @@ default button. @end table @end deffn +@deffn Initarg :text +Supplies the initial text for the @code{edit control}. +@end deffn @end deftp
@anchor{event-dispatcher} @@ -987,8 +995,13 @@ Set the size and location of this object's children. @end deffn
-@deffn GenericFunction location self -Returns a @ref{point} object describing the coordinates of the +@anchor{line-count} +@deffn GenericFunction line-count self => integer +Returns the total number of lines (e.g., of text) contained by @code{self}. +@end deffn + +@deffn GenericFunction location self => @ref{point} +Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @end deffn
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Jun 27 22:15:00 2006 @@ -227,6 +227,7 @@ #:control #:dialog #:display + #:edit #:event-dispatcher #:event-source #:file-dialog @@ -414,6 +415,7 @@ #:layout-of #:layout-p #:left-margin-of + #:line-count #:lines-visible-p #:location #:lock
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jun 27 22:15:00 2006 @@ -34,10 +34,11 @@ (in-package #:graphic-forms.uitoolkit.tests)
(defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defconstant +btn-text-after+ "Again!") +(defconstant +edit-text+ "something to edit") +(defconstant +label-text+ "Label") +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3)
(defvar *widget-counter* 0)
@@ -99,7 +100,7 @@
(defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w nil)) + (w nil)) (cond ((or (eql subtype :check-box) (eql subtype :push-button) @@ -112,6 +113,10 @@ :style (list subtype))) (setf (toggle-fn be) (create-button-toggler be)) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :single-line-edit) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :text (format nil "~d ~a" (id be) +edit-text+)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -389,6 +394,8 @@ (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) + (add-edit-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:edit + :subtype :single-line-edit)) (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) (add-tri-state-disp (make-instance 'add-child-dispatcher :subtype :tri-state)) @@ -411,14 +418,15 @@ :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" - :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Checkbox" :dispatcher add-checkbox-disp) + :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Checkbox" :dispatcher add-checkbox-disp) + (:item "Edit" :dispatcher add-edit-disp) (:item "Label - Image" :dispatcher add-image-label-disp) - (:item "Label - Text" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp) - (:item "Radiobutton" :dispatcher add-radio-disp) - (:item "Toggle" :dispatcher add-toggle-disp) - (:item "Tri-State" :dispatcher add-tri-state-disp))) + (:item "Label - Text" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp) + (:item "Radiobutton" :dispatcher add-radio-disp) + (:item "Toggle" :dispatcher add-toggle-disp) + (:item "Tri-State" :dispatcher add-tri-state-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jun 27 22:15:00 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.system)
(defconstant +button-classname+ "button") +(defconstant +edit-classname+ "edit") (defconstant +static-classname+ "static")
(defconstant +ad-counterclockwise+ 1) @@ -47,31 +48,31 @@ (defconstant +bi-png+ 5)
(defconstant +blt-blackness+ #x00000042) -(defconstant +blt-notsrcerase+ #x001100a6) +(defconstant +blt-notsrcerase+ #x001100A6) (defconstant +blt-notsrccopy+ #x00330008) (defconstant +blt-srcerase+ #x00440328) (defconstant +blt-dstinvert+ #x00550009) -(defconstant +blt-patinvert+ #x005a0049) +(defconstant +blt-patinvert+ #x005A0049) (defconstant +blt-srcinvert+ #x00660046) -(defconstant +blt-srcand+ #x008800c6) -(defconstant +blt-mergecopy+ #x00c000ca) -(defconstant +blt-mergepaint+ #x00bb0226) -(defconstant +blt-srccopy+ #x00cc0020) -(defconstant +blt-srcpaint+ #x00ee0086) -(defconstant +blt-patcopy+ #x00f00021) -(defconstant +blt-patpaint+ #x00fb0a09) -(defconstant +blt-whiteness+ #x00ff0062) +(defconstant +blt-srcand+ #x008800C6) +(defconstant +blt-mergecopy+ #x00C000CA) +(defconstant +blt-mergepaint+ #x00BB0226) +(defconstant +blt-srccopy+ #x00CC0020) +(defconstant +blt-srcpaint+ #x00EE0086) +(defconstant +blt-patcopy+ #x00F00021) +(defconstant +blt-patpaint+ #x00FB0A09) +(defconstant +blt-whiteness+ #x00FF0062) (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000)
-(defconstant +bm-getcheck+ #x00f0) -(defconstant +bm-setcheck+ #x00f1) -(defconstant +bm-getstate+ #x00f2) -(defconstant +bm-setstate+ #x00f3) -(defconstant +bm-setstyle+ #x00f4) -(defconstant +bm-click+ #x00f5) -(defconstant +bm-getimage+ #x00f6) -(defconstant +bm-setimage+ #x00f7) +(defconstant +bm-getcheck+ #x00F0) +(defconstant +bm-setcheck+ #x00F1) +(defconstant +bm-getstate+ #x00F2) +(defconstant +bm-setstate+ #x00F3) +(defconstant +bm-setstyle+ #x00F4) +(defconstant +bm-click+ #x00F5) +(defconstant +bm-getimage+ #x00F6) +(defconstant +bm-setimage+ #x00F7)
(defconstant +bs-solid+ 0) (defconstant +bs-null+ 1) @@ -139,7 +140,7 @@ (defconstant +cderr-memallocfailure+ #x0009) (defconstant +cderr-memlockfailure+ #x000a) (defconstant +cderr-nohook+ #x000b) -(defconstant +cderr-registermsgfail+ #x000c) +(defconstant +cderr-registermsgfail+ #x000C)
(defconstant +cferr-choosefontcodes+ #x2000) (defconstant +cferr-nofonts+ #x2001) @@ -230,6 +231,46 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000)
+(defconstant +em-getsel+ #x00B0) +(defconstant +em-setsel+ #x00B1) +(defconstant +em-getrect+ #x00B2) +(defconstant +em-setrect+ #x00B3) +(defconstant +em-setrectnp+ #x00B4) +(defconstant +em-scroll+ #x00B5) +(defconstant +em-linescroll+ #x00B6) +(defconstant +em-scrollcaret+ #x00B7) +(defconstant +em-getmodify+ #x00B8) +(defconstant +em-setmodify+ #x00B9) +(defconstant +em-getlinecount+ #x00BA) +(defconstant +em-lineindex+ #x00BB) +(defconstant +em-sethandle+ #x00BC) +(defconstant +em-gethandle+ #x00BD) +(defconstant +em-getthumb+ #x00BE) +(defconstant +em-linelength+ #x00C1) +(defconstant +em-replacesel+ #x00C2) +(defconstant +em-getline+ #x00C4) +(defconstant +em-limittext+ #x00C5) +(defconstant +em-canundo+ #x00C6) +(defconstant +em-undo+ #x00C7) +(defconstant +em-fmtlines+ #x00C8) +(defconstant +em-linefromchar+ #x00C9) +(defconstant +em-settabstops+ #x00CB) +(defconstant +em-setpasswordchar+ #x00CC) +(defconstant +em-emptyundobuffer+ #x00CD) +(defconstant +em-getfirstvisibleline+ #x00CE) +(defconstant +em-setreadonly+ #x00CF) +(defconstant +em-setwordbreakproc+ #x00D0) +(defconstant +em-getwordbreakproc+ #x00D1) +(defconstant +em-getpasswordchar+ #x00D2) +(defconstant +em-setmargins+ #x00D3) +(defconstant +em-getmargins+ #x00D4) +(defconstant +em-setlimittext+ #x00C5) +(defconstant +em-getlimittext+ #x00D5) +(defconstant +em-posfromchar+ #x00D6) +(defconstant +em-charfrompos+ #x00D7) +(defconstant +em-setimestatus+ #x00D8) +(defconstant +em-getimestatus+ #x00D9) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) @@ -545,8 +586,8 @@ (defconstant +pderr-nodefaultprn+ #x1008) (defconstant +pderr-dndmmismatch+ #x1009) (defconstant +pderr-createicfailure+ #x100a) -(defconstant +pderr-printernotfound+ #x100b) -(defconstant +pderr-defaultdifferent+ #x100c) +(defconstant +pderr-printernotfound+ #x100B) +(defconstant +pderr-defaultdifferent+ #x100C)
(defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002)
Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 22:15:00 2006 @@ -40,10 +40,10 @@ ;;; methods ;;;
-(defmethod compute-style-flags ((btn button) &rest extra-data) +(defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+) - (style (style-of btn))) + (style (style-of self))) (loop for sym in style do (cond ;; primary button styles @@ -64,27 +64,26 @@ (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0)))
-(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) +(defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) - (compute-style-flags btn) + (compute-style-flags self) (let ((hwnd (create-window gfs::+button-classname+ (or text " ") (gfs:handle parent) std-style ex-style (cond - ((find :default-button (style-of btn)) + ((find :default-button (style-of self)) gfs::+idok+) - ((find :cancel-button (style-of btn)) + ((find :cancel-button (style-of self)) gfs::+idcancel+) (t (increment-widget-id (thread-context))))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) - (setf (slot-value btn 'gfs:handle) hwnd))) - (init-control btn)) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self))
(defmethod preferred-size ((self button) width-hint height-hint) (let ((text-size (widget-text-size self gfs::+dt-singleline+))
Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Jun 27 22:15:00 2006 @@ -43,11 +43,7 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) - (error 'gfs:win32-error :detail "send-message failed")))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))))
;;; ;;; methods
Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 22:15:00 2006 @@ -33,30 +33,71 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defconstant +horizontal-edit-text-margin+ 2) +(defconstant +vertical-edit-text-margin+ 2) + ;;; ;;; methods ;;;
(defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+))) - (values (loop for sym in (style-of self) - for std-flags = (logior +default-child-style+ border-flag) - then (logior std-flags - (ecase sym - ;; primary edit styles - ;; - (:multi-line (logior +default-child-style+ - gfs::+es-multiline+ - border-flag)) - - ;; styles that can be combined - ;; - (:auto-hscroll gfs::+es-autohscroll+) - (:auto-vscroll gfs::+es-autovscroll+) - (:mask-characters gfs::+es-password+) - (:no-hide-selection gfs::+es-nohidesel+) - (:read-only gfs::+es-readonly+) - (:want-return gfs::+es-wantreturn+))) - finally (return std-flags)) - 0))) + (let ((std-flags +default-child-style+) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary edit styles + ;; + (:multi-line (setf std-flags (logior +default-child-style+ + gfs::+es-multiline+))) + ;; styles that can be combined + ;; + (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) + (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) + (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) + (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) + (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) + (if (not (find :multi-line style)) + (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) + +(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::+edit-classname+ + (or text "") + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self)) + +(defmethod line-count ((self edit)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0)) + +(defmethod preferred-size ((self edit) width-hint height-hint) + (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (size (gfs:make-size)) + (b-width (* (border-width self) 2))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint) + (setf (gfs:size-width size) (+ b-width + (gfs:size-width text-size) + (* +horizontal-edit-text-margin+ 2)))) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint) + (setf (gfs:size-height size) (+ b-width + (* (gfs:size-height text-size) (line-count self)) + (* +vertical-edit-text-margin+ 2)))) + size)) + +(defmethod text ((self edit)) + (get-widget-text self)) + +(defmethod (setf text) (str (self edit)) + (set-widget-text self str))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Jun 27 22:15:00 2006 @@ -115,7 +115,7 @@ (if (zerop (gfs::set-window-long hwnd gfs::+gwlp-wndproc+ (cffi:pointer-address - (cffi:get-callback 'subclassing_wndproc)))) + (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed")))
;;;
Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Jun 27 22:15:00 2006 @@ -152,6 +152,7 @@ (cffi:pointer-address (gfs:handle image)))))
(defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) (let ((hwnd (create-window gfs::+static-classname+ @@ -160,8 +161,6 @@ (logior std-style) ex-style (increment-widget-id (thread-context))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value label 'gfs:handle) hwnd) (if image (setf (image label) image))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jun 27 22:15:00 2006 @@ -99,8 +99,6 @@ gfs::+ws-border+ gfs::+ws-popup+) 0))) - (if (gfs:null-handle-p hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value tc 'utility-hwnd) hwnd)))
(defmethod call-child-visitor-func ((tc thread-context) parent child)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jun 27 22:15:00 2006 @@ -189,6 +189,9 @@ (defgeneric layout (self) (:documentation "Set the size and location of this object's children."))
+(defgeneric line-count (self) + (:documentation "Returns the total number of lines (e.g., of text).")) + (defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 22:15:00 2006 @@ -78,24 +78,34 @@ (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
+(defun initialize-comctl-classes (icc-flags) + (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) + (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) + (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) + gfs::icc icc-flags)) + (if (zerop (gfs::init-common-controls ic-ptr)) + (warn 'gfs:toolkit-warning :detail "init-common-controls failed")))) + (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (gfs::create-window - ex-style - cname-ptr - title-ptr - (if child-id (logior std-style gfs::+ws-tabstop+) std-style) - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - parent-hwnd - (if (zerop (logand gfs::+ws-child+ std-style)) - (cffi:null-pointer) - (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) - (cffi:null-pointer) - 0)))) + (let ((hwnd (gfs::create-window ex-style + cname-ptr + title-ptr + (if child-id (logior std-style gfs::+ws-tabstop+) std-style) + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + parent-hwnd + (if (zerop (logand gfs::+ws-child+ std-style)) + (cffi:null-pointer) + (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) + (cffi:null-pointer) + 0))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + hwnd))))
(defun get-widget-text (w) (if (gfs:disposed-p w)