Exporting all symbols for raw memory access

[clg] / cairo / cairo.lisp

diff --git a/cairo/cairo.lisp b/cairo/cairo.lisp
index f81c895e23ba66906076fd1626a51bd5467ae625..433b1e247a215a78d8b425f091ed12ca564cee3c 100644 (file)
--- a/cairo/cairo.lisp
+++ b/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.
 
 ;; 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.16 2007/10/16 07:48:39 espen Exp $
+;; $Id: cairo.lisp,v 1.23 2008/10/27 18:39:30 espen Exp $

 
 (in-package "CAIRO")
 
 
 (in-package "CAIRO")
 


@@ -140,6 +140,13 @@   (defclass matrix (struct)
         :accessor matrix-y0 :type double-float))
     (:metaclass struct-class))
 
         :accessor matrix-y0 :type double-float))
     (:metaclass struct-class))
 

+  (defclass font-extents (struct)
+    ((ascent :allocation :alien :reader font-extents-ascent :type double-float)
+     (descent :allocation :alien :reader font-extents-descent :type double-float)
+     (height :allocation :alien :reader font-extents-height :type double-float)
+     (max-x-advance :allocation :alien :reader font-extents-max-x-advance :type double-float)
+     (max-y-advance :allocation :alien :reader font-extents-max-y-advance :type double-float))
+    (:metaclass struct-class))

 
   (defclass text-extents (struct)
     ((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)
 
   (defclass text-extents (struct)
     ((x-bearing :allocation :alien :reader text-extents-x-bearing :type double-float)


@@ -223,15 +230,20 @@   (defclass xlib-surface (surface)
       :type int))
     (:metaclass surface-class))
 
       :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))
   
     ()
     (:metaclass surface-class))
   

-  (defclass ps-surface (surface)
+  (defclass ps-surface (vector-surface)

     ()
     (:metaclass surface-class))
     
     ()
     (:metaclass surface-class))
     

-  (defclass svg-surface (surface)
+  (defclass svg-surface (vector-surface)

     ()
     (:metaclass surface-class))
 
     ()
     (:metaclass surface-class))
 


@@ -292,15 +304,15 @@   (defclass context (ref-counted-object)
       :type double-float)
      (font-matrix
       :allocation :virtual 
       :type double-float)
      (font-matrix
       :allocation :virtual 

-      :getter "cairo_get_font_matrix"
+      :getter font-matrix

       :setter "cairo_set_font_matrix"
       :setter "cairo_set_font_matrix"

-      :accessor font-matrix
+      :writer (setf font-matrix)

       :type matrix)
      (font-options
       :allocation :virtual 
       :type matrix)
      (font-options
       :allocation :virtual 

-      :getter "cairo_get_font_options"
+      :getter font-options

       :setter "cairo_set_font_options"
       :setter "cairo_set_font_options"

-      :accessor font-options
+      :writer (setf font-options)

       :type font-options)
      (font-face
       :allocation :virtual 
       :type font-options)
      (font-face
       :allocation :virtual 


@@ -308,6 +320,13 @@   (defclass context (ref-counted-object)
       :setter "cairo_set_font_face"
       :accessor font-face
       :type font-face)
       :setter "cairo_set_font_face"
       :accessor font-face
       :type font-face)

+     #?(pkg-exists-p "cairo" :atleast-version "1.4")
+     (scaled-font
+      :allocation :virtual 
+      :getter "cairo_get_scaled_font"
+      :setter "cairo_set_scaled_font"
+      :accessor scaled-font
+      :type scaled-font)

      (operator
       :allocation :virtual 
       :getter "cairo_get_operator"
      (operator
       :allocation :virtual 
       :getter "cairo_get_operator"


@@ -326,11 +345,12 @@   (defclass context (ref-counted-object)
     (:unref %destroy))
 
 
     (:unref %destroy))
 
 

-;;   (defclass path (proxy)
-;;     ()
-;;     (:metaclass proxy-class))
-
-  )
+   (defclass path (struct)
+     ((status :allocation :alien :type status)
+      (data :allocation :alien :type pointer)
+      (length :allocation :alien :type int))
+     (:metaclass proxy-class)
+     (:unref %path-destroy)))

 
 
 ;;; Cairo context
 
 
 ;;; Cairo context


@@ -453,6 +473,19 @@ (defbinding show-page () nil
 
 ;;; Paths
 
 
 ;;; Paths
 

+(defbinding %path-destroy () nil
+  (location pointer))
+
+(defbinding copy-path () path
+  (cr context))
+
+(defbinding copy-path-flat () path
+  (cr context))
+
+(defbinding append-path () nil
+  (cr context)
+  (path path))
+

 (defbinding get-current-point () nil
   (cr context)
   (x double-float :out)
 (defbinding get-current-point () nil
   (cr context)
   (x double-float :out)


@@ -634,17 +667,26 @@ (defbinding set-font-size () nil
   (cr context)
   (size double-float))
 
   (cr context)
   (size double-float))
 

+(defbinding (font-matrix "cairo_get_font_matrix") () nil
+  (cr context)
+  ((make-instance 'matrix) matrix :in/return))
+
+(defbinding (font-options "cairo_get_font_options") () nil
+  (cr context)
+  ((make-instance 'font-options) font-options :in/return))
+

 (defbinding show-text () nil
   (cr context)
   (text string))
 
 (defbinding show-glyphs () nil
   (cr context)
 (defbinding show-text () nil
   (cr context)
   (text string))
 
 (defbinding show-glyphs () nil
   (cr context)

-  (glyphs (vector glyph))
+  (glyphs (vector (inlined glyph)))

   ((length glyphs) int))
 
   ((length glyphs) int))
 

-(defbinding font-extents () boolean
-  (cr context))
+(defbinding font-extents (cr &optional (extents (make-instance 'font-extents))) nil
+  (cr context)
+  (extents font-extents :in/return))

 
 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
   (cr context)
 
 (defbinding text-extents (cr text &optional (extents (make-instance 'text-extents))) nil
   (cr context)


@@ -831,6 +873,20 @@ (define-callback stream-write-func status
        (map-c-vector 'vector #'identity data '(unsigned-byte 8) length)))))
   :success)
 
        (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))
+  (block stream-read
+    (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 :read-error)))))
+       ((or symbol function) (funcall stream data length))))
+    :success))
+

 
 (defmacro with-surface ((surface cr) &body body)
   `(let ((,cr (make-instance 'context :target ,surface)))
 
 (defmacro with-surface ((surface cr) &body body)
   `(let ((,cr (make-instance 'context :target ,surface)))


@@ -840,9 +896,14 @@ (defmacro with-surface ((surface cr) &body body)
 ;; Image Surface
 
 ;; Should data be automatically freed when the surface is GCed?
 ;; 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
   (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
    (filename (%image-surface-create-from-png filename))
    ((not data) (%image-surface-create format width height))
    (t


@@ -868,25 +929,64 @@ (defbinding %image-surface-create-for-data () pointer
 (defbinding %image-surface-create-from-png () pointer
   (filename pathname))
 
 (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))
 
 
 (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))
+
+(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))

 
 

-(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 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)
 
 (defbinding %pdf-surface-create () pointer
   (filename pathname)


@@ -907,17 +1007,9 @@ (defbinding pdf-surface-set-size () nil
 
 ;;; PS Surface
 
 
 ;;; 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)
 
 (defbinding %ps-surface-create () pointer
   (filename pathname)


@@ -948,17 +1040,9 @@ (defbinding ps-surface-dsc-comment () nil
 
 ;;; SVG Surface
 
 
 ;;; 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)
 
 (defbinding %svg-surface-create () pointer
   (filename pathname)


@@ -979,7 +1063,7 @@ (defbinding svg-surface-restrict-to-version () nil
 
 ;;; Matrices
 
 
 ;;; 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) 
   (matrix matrix :in/return)
   (xx double-float) (yx double-float) 
   (xy double-float) (yy double-float) 


@@ -994,19 +1078,19 @@ (defun identity-matrix-p (matrix)
      (= xx 1.0d0) (= yx 0.0d0) (= xy 0.0d0)
      (= yy 1.0d0) (= x0 0.0d0) (= y0 0.0d0))))
 
      (= 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))
 
   (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))
 
   (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)
   (matrix matrix :in/return)

-  (radians double-float))
+  (rotation double-float))

 
 (defbinding matrix-translate () nil
   (matrix matrix :in/return)
 
 (defbinding matrix-translate () nil
   (matrix matrix :in/return)


@@ -1020,7 +1104,7 @@ (defbinding matrix-scale (matrix sx &optional (sy sx)) nil
 
 (defbinding matrix-rotate () nil
   (matrix matrix :in/return)
 
 (defbinding matrix-rotate () nil
   (matrix matrix :in/return)

-  (radians double-float))
+  (rotation double-float))

 
 (defbinding matrix-invert () nil
   (matrix matrix :in/return))
 
 (defbinding matrix-invert () nil
   (matrix matrix :in/return))


@@ -1039,3 +1123,17 @@ (defbinding matrix-transform-point () nil
   (matrix matrix)
   (x double-float :in/out)
   (y double-float :in/out))
   (matrix matrix)
   (x double-float :in/out)
   (y double-float :in/out))

+
+
+;; Version information
+
+(defbinding %version () int)
+
+(defun version ()
+  (let ((version (%version)))
+    (values 
+     (mod (truncate version 10000) 100)
+     (mod (truncate version 100) 100)
+     (mod version 100))))
+
+(defbinding version-string () (static string))