Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv9598/Backends/Null
Added Files: frame-manager.lisp graft.lisp medium.lisp package.lisp port.lisp Log Message: Add highly experimental Null backend.
The idea is that the null backend implements all the mcclim machinery for a backend, but doesn't side-effect the rest of the world; this should make it possible to write test cases for mcclim-internal invariants, and potentially also mcclim applications, by running them under this backend. This utopia is quite a way off, however; what actually works at present is not much more than: (setf clim:*default-server-path* :null) (let ((stream (clim:open-window-stream) (clim:draw-rectangle* stream 10 10 100 200) (clim:stream-output-history stream)) but it's a start.
(Additionally, the Null backend could be used as a starting point for implementing other backends.)
--- /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL -*-
;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk)
;;; 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.
(in-package :clim-null)
(defclass null-frame-manager (frame-manager) ())
(defmethod make-pane-1 ((fm null-frame-manager) (frame application-frame) type &rest initargs) (apply #'make-instance type :frame frame :manager fm :port (port frame) initargs))
(defmethod adopt-frame :after ((fm null-frame-manager) (frame application-frame)) ())
(defmethod note-space-requirements-changed :after ((graft null-graft) pane) ()) --- /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/graft.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-CLX -*-
;;; (c) copyright 2005 Christophe Rhodes (c.rhodes@gold.ac.uk)
;;; 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.
(in-package :clim-null)
(defclass null-graft (graft) ())
(defmethod graft-width ((graft null-graft) &key (units :device)) ())
(defmethod graft-height ((graft null-graft) &key (units :device)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL -*-
;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk)
;;; 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.
(in-package :clim-null)
(defclass null-medium (basic-medium) ((buffering-output-p :accessor medium-buffering-output-p)))
(defmethod (setf medium-text-style) :before (text-style (medium null-medium)) ())
(defmethod (setf medium-line-style) :before (line-style (medium null-medium)) ())
(defmethod (setf medium-clipping-region) :after (region (medium null-medium)) ())
(defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable null-medium) to-x to-y) nil)
#+nil ; FIXME: PIXMAP class (progn (defmethod medium-copy-area ((from-drawable null-medium) from-x from-y width height (to-drawable pixmap) to-x to-y) nil) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable null-medium) to-x to-y) ()) (defmethod medium-copy-area ((from-drawable pixmap) from-x from-y width height (to-drawable pixmap) to-x to-y) ()))
(defmethod medium-draw-point* ((medium null-medium) x y) ())
(defmethod medium-draw-points* ((medium null-medium) coord-seq) ())
(defmethod medium-draw-line* ((medium null-medium) x1 y1 x2 y2) ())
;; FIXME: Invert the transformation and apply it here, as the :around ;; methods on transform-coordinates-mixin will cause it to be applied ;; twice, and we need to undo one of those. The ;; transform-coordinates-mixin stuff needs to be eliminated. (defmethod medium-draw-lines* ((medium null-medium) coord-seq) (let ((tr (invert-transformation (medium-transformation medium)))) (declare (ignore tr)) nil))
(defmethod medium-draw-polygon* ((medium null-medium) coord-seq closed filled) ())
(defmethod medium-draw-rectangle* ((medium null-medium) left top right bottom filled) ()) (defmethod medium-draw-rectangles* ((medium null-medium) position-seq filled) ())
(defmethod medium-draw-ellipse* ((medium null-medium) center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle filled) ())
(defmethod medium-draw-circle* ((medium null-medium) center-x center-y radius start-angle end-angle filled) ())
(defmethod text-style-ascent (text-style (medium null-medium)) 1) (defmethod text-style-descent (text-style (medium null-medium)) 1) (defmethod text-style-height (text-style (medium null-medium)) (+ (text-style-ascent text-style medium) (text-style-descent text-style medium))) (defmethod text-style-character-width (text-style (medium null-medium) char) 1) ;;; FIXME: this one is nominally backend-independent (defmethod text-style-width (text-style (medium null-medium)) (text-style-character-width text-style medium #\m))
(defmethod text-size ((medium null-medium) string &key text-style (start 0) end) (setf string (etypecase string (character (string string)) (string string))) (let ((width 0) (height (text-style-height text-style medium)) (x (- (or end (length string)) start)) (y 0) (baseline (text-style-ascent text-style medium))) (do ((pos (position #\Newline string :start start :end end) (position #\Newline string :start (1+ pos) :end end))) ((null pos) (values width height x y baseline)) (let ((start start) (end pos)) (setf x (- end start)) (setf y (+ y (text-style-height text-style medium))) (setf width (max width x)) (setf height (+ height (text-style-height text-style medium))) (setf baseline (+ baseline (text-style-height text-style medium)))))))
(defmethod medium-draw-text* ((medium null-medium) string x y start end align-x align-y toward-x toward-y transform-glyphs) ())
#+nil (defmethod medium-buffering-output-p ((medium null-medium)) t) #+nil (defmethod (setf medium-buffering-output-p) (buffer-p (medium null-medium)) buffer-p)
(defmethod medium-draw-glyph ((medium null-medium) element x y align-x align-y toward-x toward-y transform-glyphs) ())
(defmethod medium-finish-output ((medium null-medium)) ()) (defmethod medium-force-output ((medium null-medium)) ())
(defmethod medium-clear-area ((medium null-medium) left top right bottom) ())
(defmethod medium-beep ((medium null-medium)) ())
(defmethod invoke-with-special-choices (continuation (medium null-medium)) (let ((sheet (medium-sheet medium))) (funcall continuation (sheet-medium sheet))))
(defmethod medium-miter-limit ((medium null-medium)) 0) --- /project/mcclim/cvsroot/mcclim/Backends/Null/package.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/package.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
(in-package :common-lisp-user)
(defpackage :clim-null (:use :clim :clim-lisp :clim-backend)) --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2006/03/24 11:45:03 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2006/03/24 11:45:03 1.1 ;;; -*- Mode: Lisp; Package: CLIM-NULL; -*-
;;; (c) 2005 Christophe Rhodes (c.rhodes@gold.ac.uk)
;;; 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.
(in-package :clim-null)
(defclass null-pointer (standard-pointer) ((cursor :accessor pointer-cursor :initform :upper-left) (x :initform 0) (y :initform 0)))
(defclass null-port (basic-port) ((id) (pointer :accessor port-pointer :initform (make-instance 'null-pointer)) (window :initform nil :accessor null-port-window)))
(defun parse-null-server-path (path) path)
;;; FIXME: if :port-type and :server-path-parser aren't CLIM-specified ;;; keywords, they should be altered to be in some mcclim-internal ;;; package instead. (setf (get :null :port-type) 'null-port) (setf (get :null :server-path-parser) 'parse-null-server-path)
(defmethod initialize-instance :after ((port null-port) &rest initargs) (declare (ignore initargs)) (setf (slot-value port 'id) (gensym "NULL-PORT-")) ;; FIXME: it seems bizarre for this to be necessary (push (make-instance 'null-frame-manager :port port) (slot-value port 'climi::frame-managers)))
(defmethod print-object ((object null-port) stream) (print-unreadable-object (object stream :identity t :type t) (format stream "~S ~S" :id (slot-value object 'id))))
(defmethod port-set-mirror-region ((port null-port) mirror mirror-region) ())
(defmethod port-set-mirror-transformation ((port null-port) mirror mirror-transformation) ())
(defmethod realize-mirror ((port null-port) (sheet mirrored-sheet-mixin)) nil)
(defmethod destroy-mirror ((port null-port) (sheet mirrored-sheet-mixin)) ())
(defmethod mirror-transformation ((port null-port) mirror) ())
(defmethod port-set-sheet-region ((port null-port) (graft graft) region) ())
(defmethod port-set-sheet-transformation ((port null-port) (graft graft) transformation) ())
(defmethod port-set-sheet-transformation ((port null-port) (sheet mirrored-sheet-mixin) transformation) ())
(defmethod port-set-sheet-region ((port null-port) (sheet mirrored-sheet-mixin) region) ())
(defmethod port-enable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) ())
(defmethod port-disable-sheet ((port null-port) (mirror mirrored-sheet-mixin)) ())
(defmethod destroy-port :before ((port null-port)) ())
(defmethod port-motion-hints ((port null-port) (mirror mirrored-sheet-mixin)) ())
(defmethod (setf port-motion-hints) (value (port null-port) (sheet mirrored-sheet-mixin)) value)
(defmethod get-next-event ((port null-port) &key wait-function (timeout nil)) ())
(defmethod make-graft ((port null-port) &key (orientation :default) (units :device)) (make-instance 'null-graft :port port :mirror (gensym) :orientation orientation :units units))
(defmethod make-medium ((port null-port) sheet) (make-instance 'null-medium :sheet sheet))
(defmethod text-style-mapping ((port null-port) text-style &optional character-set) ())
(defmethod (setf text-style-mapping) (font-name (port null-port) (text-style text-style) &optional character-set) ())
(defmethod port-character-width ((port null-port) text-style char) ())
(defmethod port-string-width ((port null-port) text-style string &key (start 0) end) ())
(defmethod port-mirror-width ((port null-port) sheet) ())
(defmethod port-mirror-height ((port null-port) sheet) ())
(defmethod graft ((port null-port)) (first (climi::port-grafts port)))
(defmethod port-allocate-pixmap ((port null-port) sheet width height) ())
(defmethod port-deallocate-pixmap ((port null-port) pixmap) #+nil (when (port-lookup-mirror port pixmap) (destroy-mirror port pixmap)))
(defmethod pointer-position ((pointer null-pointer)) (values (slot-value pointer 'x) (slot-value pointer 'y)))
(defmethod pointer-button-state ((pointer null-pointer)) ())
(defmethod port-modifier-state ((port null-port)) ())
(defmethod synthesize-pointer-motion-event ((pointer null-pointer)) ())
;;; Set the keyboard input focus for the port.
(defmethod %set-port-keyboard-focus (focus (port null-port) &key timestamp) ())
(defmethod port-force-output ((port null-port)) ())
;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port null-port) pointer sheet)
[25 lines skipped]