Author: junrue Date: Wed Mar 15 20:24:52 2006 New Revision: 44
Added: trunk/src/tests/uitoolkit/windlg.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented thread context cleanup; implemented +style-popup+ window style; implemented draw-filled-rectangle method
Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Mar 15 20:24:52 2006 @@ -53,4 +53,5 @@ (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") - (:file "layout-tester"))))))))) + (:file "layout-tester") + (:file "windlg")))))))))
Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 15 20:24:52 2006 @@ -33,38 +33,35 @@
(in-package #:graphic-forms.uitoolkit.tests)
-(defparameter *hellowin* nil) - -(defun exit-hello-world () - (let ((w *hellowin*)) - (setf *hellowin* nil) - (gfi:dispose w)) - (gfw:shutdown 0)) - (defclass hellowin-events (gfw:event-dispatcher) ())
(defmethod gfw:event-close ((d hellowin-events) widget time) (declare (ignore widget time)) - (exit-hello-world)) + (gfw:shutdown 0))
(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignorable window time rect)) + (declare (ignore window time rect)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point)))
(defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) - (exit-hello-world)) + (gfw:shutdown 0))
(defun run-hello-world-internal () - (let ((menubar nil)) - (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hellowin* nil :style-workspace) + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize window nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar *hellowin*) menubar) - (gfw:show *hellowin* t))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t)))
(defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal))
Added: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Mar 15 20:24:52 2006 @@ -0,0 +1,88 @@ +;;;; +;;;; windlg.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.tests) + +(defclass main-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d main-win-events) window time) + (declare (ignore time)) + (gfi:dispose window) + (gfw:shutdown 0)) + +(defclass test-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d test-win-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defmethod gfw:event-paint ((d test-win-events) window time gc rect) + (declare (ignore time)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect)) + +(defun create-borderless-win ()) + +(defun create-miniframe-win ()) + +(defun create-popup-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) + (gfw:realize window nil :style-popup) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) + (setf (gfw:text window) "Popup") + (gfw:show window t))) + +(defun exit-callback (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:shutdown 0)) + +(defun run-windlg-internal () + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize window nil :style-workspace) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-callback))) + (:item "&Windows" + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Popup" :callback #'create-popup-win)))))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t))) + +(defun run-windlg () + (gfw:startup "Window/Dialog Tester" #'run-windlg-internal))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Mar 15 20:24:52 2006 @@ -60,6 +60,28 @@ (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb)))
+(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (let ((hdc (gfi:handle gc)) + (pnt (gfi:location rect)) + (size (gfi:size rect))) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) + rect-ptr gfs::rect) + (setf gfs::top (gfi:point-y pnt)) + (setf gfs::left (gfi:point-x pnt)) + (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size))) + (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size))) + (gfs::ext-text-out hdc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::+eto-opaque+ + rect-ptr + "" + 0 + (cffi:null-pointer)))))) + (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error))
Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed Mar 15 20:24:52 2006 @@ -93,6 +93,18 @@ (params LPTR))
(defcfun + ("ExtTextOutA" ext-text-out) + BOOL + (hdc HANDLE) + (x INT) + (y INT) + (options UINT) + (rect LPRECT) + (str :string) + (count UINT) + (dx LPTR)) + +(defcfun ("GetBkColor" get-bk-color) COLORREF (hdc HANDLE))
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Mar 15 20:24:52 2006 @@ -173,6 +173,15 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000)
+(defconstant +eto-opaque+ #x0002) +(defconstant +eto-clipped+ #x0004) +(defconstant +eto-glyph_index+ #x0010) +(defconstant +eto-rtlreading+ #x0080) +(defconstant +eto-numericslocal+ #x0400) +(defconstant +eto-numericslatin+ #x0800) +(defconstant +eto-ignorelanguage+ #x1000) +(defconstant +eto-pdy+ #x2000) + (defconstant +ga-parent+ 1) (defconstant +ga-root+ 2) (defconstant +ga-rootowner+ 3) @@ -634,6 +643,7 @@ (defconstant +ws-minimizebox+ #x00020000) (defconstant +ws-maximizebox+ #x00010000) (defconstant +ws-popupwindow+ #x80880000) +(defconstant +ws-overlappedwindow+ #x00CF0000)
(defconstant +ws-ex-dlgmodalframe+ #x00000001) (defconstant +ws-ex-noparentnotify+ #x00000004)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 15 20:24:52 2006 @@ -56,6 +56,9 @@ #+clisp (defun thread-context () *the-thread-context*)
+#+clisp (defun dispose-thread-context () + (setf *the-thread-context* nil)) + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) (when (null tc) @@ -63,6 +66,9 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) tc))
+#+lispworks (defun dispose-thread-context () + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) + (defmethod call-child-visitor-func ((tc thread-context) parent child) "Call the closure at the top of the child window visitor function stack." (let ((fn (first (slot-value tc 'child-visitor-stack))))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 15 20:24:52 2006 @@ -49,7 +49,8 @@ (run-default-message-loop)))))
(defun shutdown (exit-code) - (gfs::post-quit-message exit-code)) + (gfs::post-quit-message exit-code) + (dispose-thread-context))
(defun clear-all (w) (let ((count (gfw:item-count w)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Mar 15 20:24:52 2006 @@ -154,53 +154,50 @@ (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) - (mapcar #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-no-title) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-windowedge+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+ - gfs::+ws-caption+ - gfs::+ws-sysmenu+ - gfs::+ws-thickframe+ - gfs::+ws-minimizebox+ - gfs::+ws-maximizebox+)) - (setf ex-flags 0)))) - (flatten style)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) +#| + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-popup) + (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) + (setf ex-flags gfs::+ws-ex-toolwindow+)) + ((eq sym :style-splash) + (setf std-flags (logior gfs::+ws-overlapped+ + gfs::+ws-popup+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-visible+)) + (setf ex-flags 0)) + ((eq sym :style-tool) + (setf std-flags 0) + (setf ex-flags gfs::+ws-ex-palettewindow+)) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) (values std-flags ex-flags)))
(defmethod gfi:dispose ((win window)) @@ -300,3 +297,9 @@ (let ((sz (gfi:make-size))) (outer-size win sz) sz)) + +(defmethod text ((win window)) + (get-widget-text win)) + +(defmethod (setf text) (str (win window)) + (set-widget-text win str))