[mcclim-cvs] CVS mcclim/Backends/Null
crhodes
crhodes at common-lisp.net
Fri Mar 24 11:45:03 UTC 2006
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 at 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 at 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 at 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 at 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]
More information about the Mcclim-cvs
mailing list