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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 11 - (show annotations)
Mon Aug 13 14:30:44 2007 UTC (6 years, 8 months ago) by tpapp
File size: 4555 byte(s)
minor bugfixes, complete reworking of x11 support, support for cl-colors
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 (defclass surface () ((pointer :initarg :pointer :initform nil)))
17
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 (unless (eq ,status 'status-success)
34 (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 ;; register finalizer
48 ;; (finalize surface #'(lambda () (cairo_surface_destroy pointer)))
49 ;; return surface
50 surface)))
51
52 (defmethod destroy ((object surface))
53 (with-alive-surface (object pointer)
54 (cairo_surface_destroy pointer)
55 (setf pointer nil))
56 ;; deregister finalizer
57 (cancel-finalization object))
58
59 ;;;;
60 ;;;; Macros to create surfaces (that are written into files) and
61 ;;;; direct creation of contexts for these surfaces.
62 ;;;;
63
64 (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
73 (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
87
88 ;;;;
89 ;;;; PDF surface
90 ;;;;
91
92 (define-create-surface pdf)
93 (define-create-context pdf)
94
95 ;;;;
96 ;;;; PostScript surface
97 ;;;;
98
99 (define-create-surface ps)
100 (define-create-context ps)
101
102 ;;;;
103 ;;;; SVG surface
104 ;;;;
105
106 (define-create-surface svg)
107 (define-create-context svg)
108
109 ;;;;
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