;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: rsvg.lisp,v 1.1 2005-11-10 08:53:24 espen Exp $
+;; $Id: rsvg.lisp,v 1.9 2008-10-08 18:24:01 espen Exp $
(in-package "RSVG")
(eval-when (:compile-toplevel :load-toplevel :execute)
-
- (defclass dimension-data (struct)
- ((width
- :allocation :alien
- :initarg :width
- :accessor dimension-data-width
- :type int)
- (height
- :allocation :alien
- :initarg :height
- :accessor dimension-data-height
- :type int)
- (em
- :allocation :alien
- :initarg :em
- :accessor dimension-data-em
- :type double-float)
- (ex
- :allocation :alien
- :initarg :ex
- :accessor dimension-data-ex
- :type double-float))
- (:metaclass struct-class))
-
-
- (defclass handle (proxy)
- ((base-uri
- :allocation :virtual
- :getter "rsvg_handle_get_base_uri"
- :setter "rsvg_handle_set_base_uri"
- :accessor handle-base-uri
- :type string)
- (dimensions
- :allocation :virtual
- :getter handle-get-dimensions
- :reader handle-dimensions
- :type dimension-data)
- (title
- :allocation :virtual
- :getter "rsvg_handle_get_title"
- :reader handle-title
- :type string)
- (description
- :allocation :virtual
- :getter "rsvg_handle_get_desc"
- :reader handle-description
- :type string)
- (metadata
- :allocation :virtual
- :getter "rsvg_handle_get_metadata"
- :reader handle-metadata
- :type string))
- (:metaclass proxy-class))
-
-)
+ (init-types-in-library rsvg "librsvg-2" :prefix "rsvg_")
+
+ (define-types-by-introspection "Rsvg"
+ ("RsvgError" :ignore t)))
+
(defbinding init () nil)
(defbinding term () nil)
-(defbinding set-default-dpi () nil
+(defbinding (set-default-dpi "rsvg_set_default_dpi_x_y") (dpi-x &optional (dpi-y dpi-x)) nil
(dpi-x double-float)
(dpi-y double-float))
-(defbinding handle-set-dpi () nil
- (handle handle)
- (dpi-x double-float)
- (dpi-y double-float))
-
-(defbinding handle-get-dimensions (handle &optional (dimensions (make-instance 'dimension-data))) nil
+(defbinding handle-write () boolean
(handle handle)
- (dimensions dimension-data :return))
-
-
+ (data (vector (integer 8)))
+ ((length data) int)
+ (nil gerror-signal :out))
(defbinding handle-close () boolean
(handle handle)
- (nil gerror :out))
-
-(defbinding %handle-new () pointer)
-
-(defbinding %handle-new-from-file () pointer
- (filename pathname)
- (nil gerror :out))
-
-(defmethod initialize-instance ((handle handle) &key filename)
- (multiple-value-bind (location gerror)
- (cond
- (filename (%handle-new-from-file filename))
- (t (%handle-new)))
- (if gerror
- (signal-gerror gerror)
- (setf (slot-value handle 'location) location)))
- (call-next-method))
+ (nil gerror-signal :out))
+(defbinding (handle-get-pixbuf "rsvg_handle_get_pixbuf_sub") (handle &optional id) boolean
+ (handle handle)
+ (id (or null string)))
-(defbinding %handle-free () nil
- (location pointer))
-(defmethod unreference-foreign ((class (eql (find-class 'handle))) location)
- (%handle-free location))
+(defbinding %handle-new-from-data () pointer
+ (data string)
+ ((1- (utf8-length data)) int)
+ (nil gerror-signal :out))
+(defbinding %handle-new-from-file () pointer
+ (filename pathname)
+ (nil gerror-signal :out))
+(defmethod allocate-foreign ((handle handle) &key data filename)
+ (cond
+ (filename (%handle-new-from-file filename))
+ (data (%handle-new-from-data data))
+ (t (call-next-method))))
+(defmacro with-handle ((handle &rest args) &body body)
+ `(let ((,handle (make-instance 'handle ,@args)))
+ (unwind-protect
+ (progn ,@body)
+ (handle-close ,handle))))
;;; Cairo interface
-(defbinding cairo-render () nil
+(defbinding (render-cairo "rsvg_handle_render_cairo_sub") (handle cr &optional id) nil
+ (handle handle)
(cr cairo:context)
- (handle handle))
\ No newline at end of file
+ (id (or null string)))
+
+(defun image-surface-create-from-svg (filename &key width height (format :argb32)id)
+ (with-handle (handle :filename filename)
+ (multiple-value-bind (width height)
+ (cond
+ ((and width height) (values width height))
+ (width
+ (let ((ratio (/ (handle-height handle) (handle-width handle))))
+ (values width (truncate (* width ratio)))))
+ (height
+ (let ((ratio (/ (handle-width handle) (handle-height handle))))
+ (values (truncate (* height ratio)) height)))
+ (t (values (handle-width handle) (handle-height handle))))
+ (let ((image (make-instance 'cairo:image-surface
+ :width width :height height :format format)))
+ (cairo:with-surface (image cr)
+ (cairo:scale cr (/ width (handle-width handle)) (/ height (handle-height handle)))
+ (render-cairo handle cr id))
+ image))))