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

Diff of /context.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 15 by tpapp, Thu Dec 20 13:05:07 2007 UTC revision 17 by tpapp, Sun Mar 23 22:58:24 2008 UTC
# Line 25  Line 25 
25  (defclass context ()  (defclass context ()
26    ((pointer :initform nil :initarg :pointer)    ((pointer :initform nil :initarg :pointer)
27     (width :initarg :width :reader get-width)     (width :initarg :width :reader get-width)
28     (height :initarg :height :reader get-height)))     (height :initarg :height :reader get-height)
29       (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p)))
30    
31    (defmethod print-object ((obj context) stream)
32      "Print a canvas object."
33      (print-unreadable-object (obj stream :type t)
34        (with-slots (pointer width height pixel-based-p) obj
35          (format stream "pointer: ~a, width: ~a, height: ~a, pixel-based-p: ~a"
36                  pointer width height pixel-based-p))))
37    
38  (defun create-context (surface)  (defun create-context (surface)
39    (with-surface (surface pointer)    (with-surface (surface pointer)
40      (let ((context (make-instance 'context      (let ((context (make-instance 'context
41                                    :pointer (cairo_create pointer)                                    :pointer (cairo_create pointer)
42                                    :width (get-width surface)                                    :width (get-width surface)
43                                    :height  (get-height surface))))                                    :height (get-height surface)
44                                      :pixel-based-p (pixel-based-p surface))))
45        ;; register finalizer        ;; register finalizer
46        (let ((context-pointer (slot-value context 'pointer)))        (let ((context-pointer (slot-value context 'pointer)))
47          (finalize context          (tg:finalize context
48                    #'(lambda ()                       #'(lambda ()
49                        (cairo_destroy context-pointer))))                           (cairo_destroy context-pointer))))
50        ;; return context        ;; return context
51        context)))        context)))
52    
# Line 47  Line 56 
56        (cairo_destroy pointer)        (cairo_destroy pointer)
57        (setf pointer nil)))        (setf pointer nil)))
58    ;; deregister finalizer    ;; deregister finalizer
59    (cancel-finalization object))    (tg:cancel-finalization object))
60    
61  (defgeneric sync (object)  (defgeneric sync (object)
62    (:documentation "Synchronize contents of the object with the    (:documentation "Synchronize contents of the object with the
# Line 82  nonlocal exits." Line 91  nonlocal exits."
91    
92  (defvar *context* nil "default cairo context")  (defvar *context* nil "default cairo context")
93    
94    (defmacro with-png-file ((filename format width height) &body body)
95      "Execute the body with context bound to a newly created png
96       file, and close it after executing body."
97      (let ((surface-name (gensym)))
98        `(let* ((,surface-name (create-image-surface ,format ,width ,height))
99                (*context* (create-context ,surface-name)))
100           (progn
101             ,@body
102             (surface-write-to-png ,surface-name ,filename)
103             (destroy ,surface-name)
104             (destroy *context*)))))
105    
106  (defmacro with-context ((context pointer) &body body)  (defmacro with-context ((context pointer) &body body)
107    "Execute body with pointer pointing to context, and check status."    "Execute body with pointer pointing to context, and check status."
108    (let ((status (gensym))    (let ((status (gensym))
# Line 260  will be nil, as cairo can't provide that Line 281  will be nil, as cairo can't provide that
281  ;;;;  convenience functions for creating contexts directly  ;;;;  convenience functions for creating contexts directly
282  ;;;;  ;;;;
283    
284    (defmacro define-create-context (type)
285      `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context")
286           (filename width height)
287         "Create a surface, then a context for a file, then
288    destroy (dereference) the surface.  The user only needs to
289    destroy the context when done."
290         (let* ((surface (,(prepend-intern "create-"
291                                           type :replace-dash nil :suffix "-surface")
292                           filename width height))
293                (context (create-context surface)))
294           (destroy surface)
295           context)))
296    
297  (define-create-context ps)  (define-create-context ps)
298  (define-create-context pdf)  (define-create-context pdf)
299  (define-create-context svg)  (define-create-context svg)

Legend:
Removed from v.15  
changed lines
  Added in v.17

  ViewVC Help
Powered by ViewVC 1.1.5