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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5