/[cl-cairo2]/surface.lisp
ViewVC logotype

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 8 - (hide annotations)
Sat Jul 21 13:41:55 2007 UTC (6 years, 9 months ago) by tpapp
File size: 4553 byte(s)
changed to longer property names to avoid name clashes
1 tpapp 1 (in-package :cl-cairo2)
2     ;;;;
3     ;;;; Notes
4     ;;;;
5     ;;;; image-surface-get-stride is not implemented, as I don't see how
6     ;;;; it would be used (ask if you need it).
7     ;;;;
8     ;;;; functions that write to/read from streams are not implemented
9    
10    
11    
12     ;;;;
13     ;;;; class surface
14     ;;;;
15    
16 tpapp 6 (defclass surface () ((pointer :initarg :pointer :initform nil)))
17 tpapp 1
18     (defmacro with-alive-surface ((surface pointer) &body body)
19     "Execute body with pointer pointing to cairo surface, if nil,
20     signal error."
21     (let ((pointer-name pointer))
22     `(with-slots ((,pointer-name pointer)) ,surface
23     (if ,pointer-name
24     (progn ,@body)
25     (warn "surface is not alive")))))
26    
27     (defmacro check-surface-pointer-status (pointer &body body)
28     "Check status of surface after executing body."
29     (let ((status (gensym)))
30     `(multiple-value-prog1 (progn ,@body)
31     (let ((,status
32     (lookup-cairo-enum (cairo_surface_status ,pointer) table-status)))
33 tpapp 8 (unless (eq ,status 'status-success)
34 tpapp 1 (warn "function returned with status ~a." ,status))))))
35    
36     (defmacro with-surface ((surface pointer) &body body)
37     "Execute body with pointer pointing to context, and check status."
38     `(with-alive-surface (,surface ,pointer)
39     (check-surface-pointer-status ,pointer
40     ,@body)))
41    
42     (defun new-surface-with-check (pointer)
43     "Check if the creation of new surface was successful, if so, return new class."
44     (let ((surface (make-instance 'surface)))
45     (check-surface-pointer-status pointer
46     (setf (slot-value surface 'pointer) pointer)
47 tpapp 7 ;; register finalizer
48     (finalize surface #'(lambda () (cairo_surface_destroy pointer)))
49     ;; return surface
50 tpapp 1 surface)))
51    
52     (defmethod destroy ((object surface))
53     (with-alive-surface (object pointer)
54     (cairo_surface_destroy pointer)
55 tpapp 7 (setf pointer nil))
56     ;; deregister finalizer
57     (cancel-finalization object))
58 tpapp 1
59     ;;;;
60 tpapp 6 ;;;; Macros to create surfaces (that are written into files) and
61     ;;;; direct creation of contexts for these surfaces.
62 tpapp 1 ;;;;
63    
64 tpapp 6 (defmacro define-create-surface (type)
65     `(export
66     (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface")
67     (filename width-in-points height-in-points)
68     (new-surface-with-check
69     (,(prepend-intern "cairo_" type :replace-dash nil
70     :suffix "_surface_create")
71     filename width-in-points height-in-points)))))
72 tpapp 1
73 tpapp 6 (defmacro define-create-context (type)
74     `(export
75     (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
76     (filename width-in-points height-in-points)
77     "Create a surface, then a context for a file, then
78     destroy (dereference) the surface. The user only needs to
79     destroy the context when done."
80     (let* ((surface (,(prepend-intern "create-"
81     type :replace-dash nil :suffix "-surface")
82     filename width-in-points height-in-points))
83     (context (create-context surface)))
84     (destroy surface)
85     context))))
86 tpapp 1
87 tpapp 6
88 tpapp 1 ;;;;
89 tpapp 6 ;;;; PDF surface
90     ;;;;
91    
92     (define-create-surface pdf)
93     (define-create-context pdf)
94    
95     ;;;;
96 tpapp 1 ;;;; PostScript surface
97     ;;;;
98    
99 tpapp 6 (define-create-surface ps)
100     (define-create-context ps)
101 tpapp 1
102 tpapp 6 ;;;;
103     ;;;; SVG surface
104     ;;;;
105 tpapp 1
106 tpapp 6 (define-create-surface svg)
107     (define-create-context svg)
108    
109 tpapp 1 ;;;;
110     ;;;; image surface
111     ;;;;
112    
113     (export
114     (defun create-image-surface (format width height)
115     (new-surface-with-check
116     (cairo_image_surface_create (lookup-enum format table-format)
117     width height))))
118    
119     (export
120     (defun image-surface-get-format (surface)
121     (with-surface (surface pointer)
122     (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))))
123    
124     (export
125     (defun image-surface-get-width (surface)
126     (with-surface (surface pointer)
127     (cairo_image_surface_get_width pointer))))
128    
129     (export
130     (defun image-surface-get-height (surface)
131     (with-surface (surface pointer)
132     (cairo_image_surface_get_height pointer))))
133    
134     ;;;;
135     ;;;; PNG surfaces
136     ;;;;
137    
138     (export
139     (defun image-surface-create-from-png (filename)
140     (new-surface-with-check (cairo_image_surface_create_from_png filename))))
141    
142     (export
143     (defun surface-write-to-png (surface filename)
144     (with-surface (surface pointer)
145     (cairo_surface_write_to_png pointer filename))))
146    
147     (export
148     (defmacro with-png-file ((filename format width height) &body body)
149     "Execute the body with context bound to a newly created png
150     file, and close it after executing body."
151     (let ((surface-name (gensym)))
152     `(let* ((,surface-name (create-image-surface ,format ,width ,height))
153     (*context* (create-context ,surface-name)))
154     (progn
155     ,@body
156     (surface-write-to-png ,surface-name ,filename)
157     (destroy ,surface-name)
158     (destroy *context*))))))

  ViewVC Help
Powered by ViewVC 1.1.5