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

Contents of /surface.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Mon May 28 19:32:53 2007 UTC (6 years, 10 months ago) by tpapp
File size: 4323 byte(s)
initial import
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     (defclass surface () ((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 '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     surface)))
48    
49     (defmethod destroy ((object surface))
50     (with-alive-surface (object pointer)
51     (cairo_surface_destroy pointer)
52     (setf pointer nil)))
53    
54     ;;;;
55     ;;;; PDF surface
56     ;;;;
57    
58     (export
59     (defun create-pdf-surface (filename width-in-points height-in-points)
60     (new-surface-with-check
61     (cairo_pdf_surface_create filename
62     width-in-points
63     height-in-points))))
64    
65     (export
66     (defun create-pdf-context (filename width-in-points height-in-points)
67     "Create a surface, then a context for a pdf file, then
68     destroy (dereference) the surface. The user only needs to
69     destroy the context when done."
70     (let* ((surface (create-pdf-surface filename width-in-points height-in-points))
71     (context (create-context surface)))
72     (destroy surface)
73     context)))
74    
75     ;;;;
76     ;;;; PostScript surface
77     ;;;;
78    
79     (export
80     (defun create-ps-surface (filename width-in-points height-in-points)
81     (new-surface-with-check
82     (cairo_ps_surface_create filename
83     width-in-points
84     height-in-points))))
85    
86     (export
87     (defun create-ps-context (filename width-in-points height-in-points)
88     "Create a surface, then a context for a postscript file, then
89     destroy (dereference) the surface. The user only needs to
90     destroy the context when done."
91     (let* ((surface (create-ps-surface filename width-in-points height-in-points))
92     (context (create-context surface)))
93     (destroy surface)
94     context)))
95    
96     ;;;;
97     ;;;; image surface
98     ;;;;
99    
100     (export
101     (defun create-image-surface (format width height)
102     (new-surface-with-check
103     (cairo_image_surface_create (lookup-enum format table-format)
104     width height))))
105    
106     (export
107     (defun image-surface-get-format (surface)
108     (with-surface (surface pointer)
109     (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))))
110    
111     (export
112     (defun image-surface-get-width (surface)
113     (with-surface (surface pointer)
114     (cairo_image_surface_get_width pointer))))
115    
116     (export
117     (defun image-surface-get-height (surface)
118     (with-surface (surface pointer)
119     (cairo_image_surface_get_height pointer))))
120    
121     ;;;;
122     ;;;; PNG surfaces
123     ;;;;
124    
125     (export
126     (defun image-surface-create-from-png (filename)
127     (new-surface-with-check (cairo_image_surface_create_from_png filename))))
128    
129     (export
130     (defun surface-write-to-png (surface filename)
131     (with-surface (surface pointer)
132     (cairo_surface_write_to_png pointer filename))))
133    
134     (export
135     (defmacro with-png-file ((filename format width height) &body body)
136     "Execute the body with context bound to a newly created png
137     file, and close it after executing body."
138     (let ((surface-name (gensym)))
139     `(let* ((,surface-name (create-image-surface ,format ,width ,height))
140     (*context* (create-context ,surface-name)))
141     (progn
142     ,@body
143     (surface-write-to-png ,surface-name ,filename)
144     (destroy ,surface-name)
145     (destroy *context*))))))

  ViewVC Help
Powered by ViewVC 1.1.5