Author: junrue Date: Sun Aug 13 22:04:18 2006 New Revision: 215
Modified: trunk/README.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/default.ico trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed problems in multiple-image icon bundles and in the ImageMagick plugin
Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 22:04:18 2006 @@ -157,21 +157,26 @@
(asdf:operate 'asdf:load-op :graphic-forms-tests)
- ;; execute one or more of the following: + ;; execute demos and test programs ;; + (gft:unblocked)
- (in-package :gft) - (run-tests) ;; runs the unit tests (many more to be added) + (gft:textedit) + + (gft:drawing-tester)
- (gft::run-drawing-tester) + (gft:event-tester)
- (gft::run-event-tester) + (gft:image-tester)
- (gft::run-image-tester) + (gft:layout-tester)
- (gft::run-windlg) + (gft:windlg)
- (gft::run-layout-tester) + ;; execute the unit-tests + ;; + (in-package :gft) + (run-tests)
Support and Feedback
Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sun Aug 13 22:04:18 2006 @@ -1333,6 +1333,16 @@ scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn
+@deffn GenericFunction image self => @ref{image} + +(setf (@strong{image} @var{self}) @var{image})@* + +Returns the image currently associated with @var{self}. The @sc{setf} function +changes the image. If @var{self} is a @ref{window}, then this function returns +an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either +an image or an icon-bundle. +@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-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 22:04:18 2006 @@ -37,14 +37,14 @@ (:nicknames #:gft) (:use :common-lisp :lisp-unit) (:export - #:run-drawing-tester - #:run-event-tester - #:run-hello-world - #:run-image-tester - #:run-layout-tester - #:run-windlg + #:drawing-tester + #:event-tester + #:hello-world + #:image-tester + #:layout-tester #:textedit - #:unblocked)) + #:unblocked + #:windlg))
(print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue")
Modified: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary files. No diff available.
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 22:04:18 2006 @@ -342,7 +342,7 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*))
-(defun run-drawing-tester-internal () +(defun drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) @@ -362,7 +362,9 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") +#+load-imagemagick-plugin + (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t)))
-(defun run-drawing-tester () - (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) +(defun drawing-tester () + (gfw:startup "Drawing Tester" #'drawing-tester-internal))
Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 22:04:18 2006 @@ -233,7 +233,7 @@ (gfw:delay-of *timer*))))) (gfw:redraw *event-tester-window*))
-(defun run-event-tester-internal () +(defun event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) @@ -255,5 +255,5 @@ (setf (gfw:menu-bar *event-tester-window*) menubar) (gfw:show *event-tester-window* t)))
-(defun run-event-tester () - (gfw:startup "Event Tester" #'run-event-tester-internal)) +(defun event-tester () + (gfw:startup "Event Tester" #'event-tester-internal))
Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Aug 13 22:04:18 2006 @@ -56,7 +56,7 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point)))
-(defun run-hello-world-internal () +(defun hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) :style '(:frame))) @@ -65,5 +65,5 @@ (setf (gfw:menu-bar *hello-win*) menubar) (gfw:show *hello-win* t)))
-(defun run-hello-world () - (gfw:startup "Hello World" #'run-hello-world-internal)) +(defun hello-world () + (gfw:startup "Hello World" #'hello-world-internal))
Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 22:04:18 2006 @@ -93,7 +93,7 @@ (setf *image-win* nil) (gfw:shutdown 0))
-(defun run-image-tester-internal () +(defun image-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((menubar nil)) (setf *happy-image* (make-instance 'gfg:image)) @@ -111,5 +111,5 @@ (setf (gfw:menu-bar *image-win*) menubar) (gfw:show *image-win* t)))
-(defun run-image-tester () - (gfw:startup "Image Tester" #'run-image-tester-internal)) +(defun image-tester () + (gfw:startup "Image Tester" #'image-tester-internal))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 22:04:18 2006 @@ -387,7 +387,7 @@ (declare (ignorable disp item)) (exit-layout-tester))
-(defun run-layout-tester-internal () +(defun layout-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-counter* 0) (let ((menubar nil) @@ -444,5 +444,5 @@ (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t)))
-(defun run-layout-tester () - (gfw:startup "Layout Tester" #'run-layout-tester-internal)) +(defun layout-tester () + (gfw:startup "Layout Tester" #'layout-tester-internal))
Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 22:04:18 2006 @@ -228,7 +228,7 @@ (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless)))
-(defun run-windlg-internal () +(defun windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) @@ -248,5 +248,5 @@ (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t)))
-(defun run-windlg () - (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) +(defun windlg () + (gfw:startup "Window/Dialog Tester" #'windlg-internal))
Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 22:04:18 2006 @@ -164,7 +164,9 @@ (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) ((typep file 'pathname) - (setf image-list (list (make-instance 'image :file file)))) + (let ((data (load-image-data file))) + (setf image-list (loop for entry in data + collect (make-instance 'gfg:image :handle (data->image entry)))))) ((listp images) (setf image-list images))) (when image-list
Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Sun Aug 13 22:04:18 2006 @@ -149,6 +149,11 @@ (images :pointer)) ;; Image*
(defcfun + ("GetImageListLength" get-image-list-length) + :unsigned-long + (images :pointer)) ;; Image* + +(defcfun ("GetNextImageInList" get-next-image-in-list) :pointer ;; Image* (images :pointer)) ;; Image*
Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 22:04:18 2006 @@ -41,15 +41,15 @@ (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) (if (gethash (pathname-type path) gfg:*image-file-types*) - (with-image-path (path info ex) + (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (loop for ptr = (get-next-image-in-list images-ptr) - until (cffi:null-pointer-p ptr) - collect (make-instance 'magic-data-plugin :handle ptr)))) + (loop for ptr = images-ptr then (get-next-image-in-list ptr) + while (and ptr (not (gfs:null-handle-p ptr))) + collect (make-instance 'magick-data-plugin :handle ptr)))) nil))
(push #'loader gfg::*image-plugins*)
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Aug 13 22:04:18 2006 @@ -480,6 +480,10 @@ (defconstant +icc-standard-classes+ #x00004000) (defconstant +icc-link-class+ #x00008000)
+(defconstant +icon-small+ 0) +(defconstant +icon-big+ 1) +(defconstant +icon-small2+ 2) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) @@ -1004,6 +1008,12 @@ (defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) +(defconstant +wm-contextmenu+ #x007B) +(defconstant +wm-stylechanging+ #x007C) +(defconstant +wm-stylechanged+ #x007D) +(defconstant +wm-displaychange+ #x007E) +(defconstant +wm-geticon+ #x007F) +(defconstant +wm-seticon+ #x0080) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2)
Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Aug 13 22:04:18 2006 @@ -210,6 +210,15 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w)))))
+(defmethod image :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf image) :before (image (self widget)) + (declare (ignore image)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) (setf (slot-value w 'style) (if (listp style) style (list style))))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Aug 13 22:04:18 2006 @@ -165,43 +165,65 @@ (delete-kbdnav-widget (thread-context) self) (call-next-method))
-(defmethod enable-layout :before ((win window) flag) +(defmethod enable-layout :before ((self window) flag) (declare (ignore flag)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))
-(defmethod enable-layout ((win window) flag) - (setf (slot-value win 'layout-p) flag) - (if (and flag (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-layout ((self window) flag) + (setf (slot-value self 'layout-p) flag) + (if (and flag (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
-(defmethod event-resize ((d event-dispatcher) (win window) size type) +(defmethod event-resize ((d event-dispatcher) (self window) size type) (declare (ignore size type)) - (unless (null (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
-(defmethod focus-p :before ((win window)) - (if (gfs:disposed-p win) +(defmethod focus-p :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))
-(defmethod focus-p ((win window)) +(defmethod focus-p ((self window)) (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle self)))))
-(defmethod give-focus :before ((win window)) - (if (gfs:disposed-p win) +(defmethod give-focus :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))
-(defmethod give-focus ((win window)) - (gfs::set-focus (gfs:handle win))) +(defmethod give-focus ((self window)) + (gfs::set-focus (gfs:handle self)))
-(defmethod location ((win window)) - (if (gfs:disposed-p win) +(defmethod image ((self window)) + (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) + (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) + (handles nil)) + (unless (zerop small) + (push (cffi:make-pointer small) handles)) + (unless (zerop large) + (push (cffi:make-pointer large) handles)) + (make-instance 'gfg:icon-bundle :handle handles))) + +(defmethod (setf image) ((image gfg:image) (self window)) + (setf (image self) (make-instance 'gfg:icon-bundle :images (list image)))) + +(defmethod (setf image) ((bundle gfg:icon-bundle) (self window)) + (let ((hwnd (gfs:handle self)) + (small (gfg::icon-handle-ref bundle :small)) + (large (gfg::icon-handle-ref bundle :large))) + (unless (gfs:null-handle-p small) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-small+ (cffi:pointer-address small))) + (unless (gfs:null-handle-p large) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-big+ (cffi:pointer-address large))))) + +(defmethod location ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((pnt (gfs:make-point))) - (outer-location win pnt) + (outer-location self pnt) pnt))
(defmethod layout ((self window))