Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv8506/Extensions/Images Modified Files: package.lisp Added Files: image-viewer.lisp Log Message: Added image viewer gadget to MCCLIM-IMAGES. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 @@ -24,4 +24,5 @@ (:use :clim-lisp :clim) (:export :export #:image-format-supported #:load-image #:load-image-of-format - #:unsupported-image-format #:image-format)) + #:unsupported-image-format #:image-format + #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas@sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A simple image viewer gadget. It would be nice if it could modify ;;; its space requirements to fit the image, but MCCLIM-IMAGES does ;;; not provide this functionality. (in-package :mcclim-images) (defclass image-viewer (value-gadget) () (:documentation "An abstract gadget for displaying images. The value of the gadget is the image being displayed.") (:default-initargs :value nil)) (defmethod (setf gadget-value) :after (new-value (gadget image-viewer) &key &allow-other-keys) (handle-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass image-viewer-pane (image-viewer basic-gadget) () (:documentation "A concrete gadget for displaying images. The value of the gadget is the image being displayed.")) (defmethod handle-repaint ((pane image-viewer-pane) region) (declare (ignore region)) ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) ;; Draw the new one, if there is one. (when (gadget-value pane) (draw-design pane (gadget-value pane))))