+(defbinding %surface-write-to-png () status-signal
+ (surface surface)
+ (filename pathname))
+
+(defbinding %surface-write-to-png-stream (surface stream) status-signal
+ (surface surface)
+ (stream-write-func callback)
+ (stream pointer-data))
+
+(defgeneric surface-write-to-png (surface dest))
+
+(defmethod surface-write-to-png (surface filename)
+ (%surface-write-to-png surface filename))
+
+(defmethod surface-write-to-png (surface (stream stream))
+ (let ((stream-id (register-user-data stream)))
+ (unwind-protect
+ (%surface-write-to-png-stream surface stream-id)
+ (destroy-user-data stream-id))))
+
+
+;;; JPEG support
+
+(define-callback jpeg-stream-write-func unsigned
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (%stream-write-func stream-id data length))
+
+(define-callback jpeg-stream-read-func unsigned
+ ((stream-id pointer-data) (data pointer) (length unsigned-int))
+ (%stream-read-func stream-id data length))
+
+(defbinding %image-surface-create-from-jpeg () pointer
+ (filename pathname)
+ (status status-signal :out))
+
+(defbinding %image-surface-create-from-jpeg-stream (stream) pointer
+ (jpeg-stream-read-func callback)
+ (stream pointer-data)
+ (status status-signal :out))
+
+(defgeneric surface-write-to-jpeg (surface dest &key quality interlace))
+
+(defun %surface-acquire-image (surface)
+ (typecase surface
+ (image-surface surface)
+ ((let ((image (make-instance 'image-surface
+ :width (surface-width surface)
+ :height (surface-height surface)
+ :format :argb32)))
+ (with-surface (image cr)
+ (set-source-surface cr surface)
+ (setf (operator cr) :source)
+ (paint cr))
+ image))))
+
+(defbinding %surface-write-to-jpeg () status-signal
+ (surface image-surface)
+ (filename pathname)
+ (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface filename &key
+ (quality 75) (interlace t))
+ (let ((param (make-instance 'jpeg-parameter
+ :quality quality :interlace interlace)))
+ (%surface-write-to-jpeg (%surface-acquire-image surface) filename param)))
+
+(defbinding %surface-write-to-jpeg-stream (surface stream param) status-signal
+ (surface surface)
+ (jpeg-stream-write-func callback)
+ (stream pointer-data)
+ (param jpeg-parameter))
+
+(defmethod surface-write-to-jpeg (surface (stream stream) &key
+ (quality 75) (interlace t))
+ (let ((stream-id (register-user-data stream))
+ (param (make-instance 'jpeg-parameter
+ :quality quality :interlace interlace)))
+ (unwind-protect
+ (%surface-write-to-jpeg-stream (%surface-acquire-image surface) stream-id param)
+ (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)
+ (height double-float))
+
+(defbinding %pdf-surface-create-for-stream (stream width height) pointer
+ (stream-write-func callback)
+ (stream pointer-data)
+ (width double-float)
+ (height double-float))
+
+(defbinding pdf-surface-set-size () nil
+ (surface pdf-surface)
+ (width double-float)
+ (height double-float))
+
+
+;;; PS Surface
+
+(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)
+ (width double-float)
+ (height double-float))
+
+(defbinding %ps-surface-create-for-stream (stream width height) pointer
+ (stream-write-func callback)
+ (stream pointer-data)
+ (width double-float)
+ (height double-float))
+
+(defbinding ps-surface-set-size () nil
+ (surface ps-surface)
+ (width double-float)
+ (height double-float))
+
+(defbinding ps-surface-dsc-begin-setup () nil
+ (surface ps-surface))
+
+(defbinding ps-surface-dsc-begin-page-setup () nil
+ (surface ps-surface))
+
+(defbinding ps-surface-dsc-comment () nil
+ (surface ps-surface)
+ (comment string))
+
+
+;;; SVG Surface
+
+(defmethod allocate-foreign ((surface svg-surface) &rest args)
+ (apply #'allocate-vector-surface
+ #'%svg-surface-create #'%svg-surface-create-for-stream args))