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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (show annotations)
Sun Mar 23 22:58:24 2008 UTC (6 years ago) by tpapp
File size: 4160 byte(s)
Several small changes:

- dependence on trivial-garbage for finalizer code
- fixes in examples/Makefile

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 (defgeneric get-width (object)
17 (:documentation "return the width of an object"))
18
19 (defgeneric get-height (object)
20 (:documentation "return the height of an object"))
21
22 (defgeneric pixel-based-p (object)
23 (:documentation "return t iff the object uses a pixel-based backend"))
24
25 (defclass surface ()
26 ((pointer :initarg :pointer :initform nil)
27 (width :initarg :width :reader get-width)
28 (height :initarg :height :reader get-height)
29 (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30
31 (defmacro with-alive-surface ((surface pointer) &body body)
32 "Execute body with pointer pointing to cairo surface, if nil,
33 signal error."
34 (let ((pointer-name pointer))
35 `(with-slots ((,pointer-name pointer)) ,surface
36 (if ,pointer-name
37 (progn ,@body)
38 (warn "surface is not alive")))))
39
40 (defmacro check-surface-pointer-status (pointer &body body)
41 "Check status of surface after executing body."
42 (let ((status (gensym)))
43 `(multiple-value-prog1 (progn ,@body)
44 (let ((,status
45 (lookup-cairo-enum (cairo_surface_status ,pointer) table-status)))
46 (unless (eq ,status 'status-success)
47 (warn "function returned with status ~a." ,status))))))
48
49 (defmacro with-surface ((surface pointer) &body body)
50 "Execute body with pointer pointing to surface, and check status."
51 `(with-alive-surface (,surface ,pointer)
52 (check-surface-pointer-status ,pointer
53 ,@body)))
54
55 (defun new-surface-with-check (pointer width height &optional (pixel-based-p nil))
56 "Check if the creation of new surface was successful, if so, return new class."
57 (let ((surface (make-instance 'surface :width width :height height
58 :pixel-based-p pixel-based-p)))
59 (check-surface-pointer-status pointer
60 (setf (slot-value surface 'pointer) pointer)
61 ;; register finalizer
62 (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer)))
63 ;; return surface
64 surface)))
65
66 (defmethod destroy ((object surface))
67 (with-alive-surface (object pointer)
68 (cairo_surface_destroy pointer)
69 (setf pointer nil))
70 ;; deregister finalizer
71 (tg:cancel-finalization object))
72
73 ;;;;
74 ;;;; Macros to create surfaces (that are written into files) and
75 ;;;; direct creation of contexts for these surfaces.
76 ;;;;
77
78 (defmacro define-create-surface (type)
79 "Define the function create-<type>-surface."
80 `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface")
81 (filename width height)
82 (new-surface-with-check
83 (,(prepend-intern "cairo_" type :replace-dash nil
84 :suffix "_surface_create")
85 filename width height)
86 width height)))
87
88 ;;;;
89 ;;;; PDF surface
90 ;;;;
91
92 (define-create-surface pdf)
93
94 ;;;;
95 ;;;; PostScript surface
96 ;;;;
97
98 (define-create-surface ps)
99
100 ;;;;
101 ;;;; SVG surface
102 ;;;;
103
104 (define-create-surface svg)
105
106 ;;;;
107 ;;;; image surface
108 ;;;;
109
110 (defun create-image-surface (format width height)
111 (new-surface-with-check
112 (cairo_image_surface_create (lookup-enum format table-format)
113 width height)
114 width height t))
115
116 (defun image-surface-get-format (surface)
117 (with-surface (surface pointer)
118 (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))
119
120 (defun image-surface-get-width (surface)
121 (with-surface (surface pointer)
122 (cairo_image_surface_get_width pointer)))
123
124 (defun image-surface-get-height (surface)
125 (with-surface (surface pointer)
126 (cairo_image_surface_get_height pointer)))
127
128 ;;;;
129 ;;;; PNG surfaces
130 ;;;;
131
132 (defun image-surface-create-from-png (filename)
133 (let ((surface
134 (new-surface-with-check (cairo_image_surface_create_from_png filename)
135 0 0)))
136 (with-slots (width height) surface
137 (setf width (image-surface-get-width surface)
138 height (image-surface-get-height surface))
139 surface)))
140
141 (defun surface-write-to-png (surface filename)
142 (with-surface (surface pointer)
143 (cairo_surface_write_to_png pointer filename)))
144

  ViewVC Help
Powered by ViewVC 1.1.5