Browse files

Added common superclass for vector surfaces and some minor API changes

  • Loading branch information...
1 parent 9c35ab2 commit 7d6c9b981633cd3105600a75c4abd53a8450ee88 espen committed Oct 8, 2008
Showing with 92 additions and 46 deletions.
  1. +92 −46 cairo/cairo.lisp
View
138 cairo/cairo.lisp
@@ -20,7 +20,7 @@
;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: cairo.lisp,v 1.21 2008-01-10 13:32:34 espen Exp $
+;; $Id: cairo.lisp,v 1.22 2008-10-08 16:24:11 espen Exp $
(in-package "CAIRO")
@@ -230,15 +230,20 @@
:type int))
(:metaclass surface-class))
- (defclass pdf-surface (surface)
+ (defclass vector-surface (surface)
+ ((width :allocation :virtual :getter surface-width)
+ (height :allocation :virtual :setter surface-height))
+ (:metaclass surface-class))
+
+ (defclass pdf-surface (vector-surface)
()
(:metaclass surface-class))
- (defclass ps-surface (surface)
+ (defclass ps-surface (vector-surface)
()
(:metaclass surface-class))
- (defclass svg-surface (surface)
+ (defclass svg-surface (vector-surface)
()
(:metaclass surface-class))
@@ -868,6 +873,19 @@
(map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))))
:success)
+(define-callback stream-read-func status
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (let ((stream (find-user-data stream-id)))
+ (typecase stream
+ (stream
+ (loop for i below length do
+ (let ((byte (read-byte stream nil)))
+ (if byte
+ (setf (gffi::ref-uint-8 data i) byte)
+ (return-from stream-read-func :read-error)))))
+ ((or symbol function) (funcall stream data length))))
+ :success)
+
(defmacro with-surface ((surface cr) &body body)
`(let ((,cr (make-instance 'context :target ,surface)))
@@ -877,9 +895,14 @@
;; Image Surface
;; Should data be automatically freed when the surface is GCed?
-(defmethod allocate-foreign ((surface image-surface)
- &key filename width height stride format data)
+(defmethod allocate-foreign ((surface image-surface) &key stream filename
+ width height stride format data)
(cond
+ (stream
+ (let ((stream-id (register-user-data stream)))
+ (unwind-protect
+ (%image-surface-create-from-png-stream stream-id)
+ (destroy-user-data stream-id))))
(filename (%image-surface-create-from-png filename))
((not data) (%image-surface-create format width height))
(t
@@ -905,26 +928,65 @@
(defbinding %image-surface-create-from-png () pointer
(filename pathname))
+(defbinding %image-surface-create-from-png-stream (stream) pointer
+ (stream-read-func callback)
+ (stream pointer-data))
+
(defbinding surface-write-to-png () status
(surface surface)
(filename pathname))
-;;; PDF Surface
+(defbinding %surface-write-to-png-stream (surface stream) status
+ (surface surface)
+ (stream-write-func callback)
+ (stream pointer-data))
-(defmethod allocate-foreign ((surface pdf-surface)
- &key filename stream width height)
- (cond
- ((and filename stream)
- (error "Only one of the arguments :filename and :stream may be specified"))
- (filename (%pdf-surface-create filename width height))
- (stream
- (let* ((stream-id (register-user-data stream))
- (location (%pdf-surface-create-for-stream stream-id width height)))
- (%surface-set-user-data location 'stream stream-id)
- location))))
+(defun surface-write-to-png-stream (surface stream)
+ (let ((stream-id (register-user-data stream)))
+ (unwind-protect
+ (%surface-write-to-png-stream surface stream-id)
+ (destroy-user-data stream-id))))
+;;; Virtual size surface (abstract class)
+
+(defmethod initialize-instance :after ((surface vector-surface) &key
+ width height)
+ (setf (user-data surface 'width) width)
+ (setf (user-data surface 'height) height))
+
+(defmethod surface-width ((surface vector-surface))
+ (user-data surface 'width))
+
+(defmethod surface-height ((surface vector-surface))
+ (user-data surface 'height))
+
+
+(defun allocate-vector-surface (surface-create surface-create-for-stream
+ &key output filename stream width height)
+ (let ((location
+ (cond
+ ((/= (count-if #'identity (list output filename stream)) 1)
+ (error "One and only one of the arguments :OUTPUT, :FILENAME and :STREAM shoud be specified"))
+ (filename (funcall surface-create filename width height))
+ ((typep output '(or string pathname))
+ (%svg-surface-create output width height))
+ (t
+ (let* ((stream-id (register-user-data (or stream output)))
+ (location (funcall surface-create-for-stream
+ stream-id width height)))
+ (%surface-set-user-data location 'stream stream-id)
+ location)))))
+ location))
+
+
+;;; PDF Surface
+
+(defmethod allocate-foreign ((surface pdf-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%pdf-surface-create #'%pdf-surface-create-for-stream args))
+
(defbinding %pdf-surface-create () pointer
(filename pathname)
(width double-float)
@@ -944,17 +1006,9 @@
;;; PS Surface
-(defmethod allocate-foreign ((surface ps-surface)
- &key filename stream width height)
- (cond
- ((and filename stream)
- (error "Only one of the arguments :filename and :stream may be specified"))
- (filename (%ps-surface-create filename width height))
- (stream
- (let* ((stream-id (register-user-data stream))
- (location (%ps-surface-create-for-stream stream-id width height)))
- (%surface-set-user-data location 'stream stream-id)
- location))))
+(defmethod allocate-foreign ((surface ps-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%ps-surface-create #'%ps-surface-create-for-stream args))
(defbinding %ps-surface-create () pointer
(filename pathname)
@@ -985,17 +1039,9 @@
;;; SVG Surface
-(defmethod allocate-foreign ((surface svg-surface)
- &key filename stream width height)
- (cond
- ((and filename stream)
- (error "Only one of the arguments :filename and :stream may be specified"))
- (filename (%svg-surface-create filename width height))
- (stream
- (let* ((stream-id (register-user-data stream))
- (location (%svg-surface-create-for-stream stream-id width height)))
- (%surface-set-user-data location 'stream stream-id)
- location))))
+(defmethod allocate-foreign ((surface svg-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%svg-surface-create #'%svg-surface-create-for-stream args))
(defbinding %svg-surface-create () pointer
(filename pathname)
@@ -1016,7 +1062,7 @@
;;; Matrices
-(defbinding matrix-init () nil
+(defbinding matrix-init (xx yx xy yy x0 y0 &optional (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return)
(xx double-float) (yx double-float)
(xy double-float) (yy double-float)
@@ -1031,19 +1077,19 @@
(= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
(= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
-(defbinding matrix-init-translate () nil
+(defbinding matrix-init-translate (tx ty &optional (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return)
(tx double-float)
(ty double-float))
-(defbinding matrix-init-scale (matrix sx &optional (sy sx)) nil
+(defbinding matrix-init-scale (sx &optional (sy sx) (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return)
(sx double-float)
(sy double-float))
-(defbinding matrix-init-rotate () nil
+(defbinding matrix-init-rotate (rotation &optional (matrix (make-instance 'matrix))) nil
(matrix matrix :in/return)
- (radians double-float))
+ (rotation double-float))
(defbinding matrix-translate () nil
(matrix matrix :in/return)
@@ -1057,7 +1103,7 @@
(defbinding matrix-rotate () nil
(matrix matrix :in/return)
- (radians double-float))
+ (rotation double-float))
(defbinding matrix-invert () nil
(matrix matrix :in/return))

0 comments on commit 7d6c9b9

Please sign in to comment.