add `svg-dc%'

collects/mred/mred-sig.rkt

@@ -183,6 +183,7 @@ style-list%
 style<%>
 subarea<%>
 subwindow<%>
+svg-dc%
 system-position-ok-before-cancel?
 tab-snip%
 text%

collects/racket/draw.rkt

@@ -13,6 +13,7 @@
          "draw/private/bitmap-dc.rkt"
          "draw/private/post-script-dc.rkt"
          "draw/private/ps-setup.rkt"
+         "draw/private/svg-dc.rkt"
          "draw/private/gl-config.rkt"
          "draw/private/gl-context.rkt")
 
@@ -32,6 +33,7 @@
          post-script-dc%
          pdf-dc%
          ps-setup% current-ps-setup
+         svg-dc%
          get-face-list
          get-family-builtin-face
          gl-config%

collects/racket/draw/draw-sig.rkt

@@ -27,6 +27,7 @@ post-script-dc%
 ps-setup%
 radial-gradient%
 region%
+svg-dc%
 the-brush-list
 the-color-database
 the-font-list

collects/racket/draw/private/post-script-dc.rkt

@@ -6,13 +6,12 @@
          "syntax.rkt"
          racket/gui/dynamic
          ffi/unsafe
-         ffi/unsafe/alloc
          "../unsafe/cairo.ss"
-         "../unsafe/bstr.ss"
 	 "dc.ss"
          "font.ss"
          "local.ss"
-         "ps-setup.ss")
+         "ps-setup.ss"
+         "write-bytes.rkt")
 
 (provide post-script-dc%
          pdf-dc%)
@@ -183,12 +182,3 @@
                           (super-new)))
 (define pdf-dc% (class (dc-mixin (make-dc-backend #t))
                   (super-new)))
-
-(define (write-port-bytes port-box bytes len)
-  (write-bytes (scheme_make_sized_byte_string bytes len 0) 
-               (ptr-ref port-box _racket))
-  CAIRO_STATUS_SUCCESS)
-
-(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t))
-
-(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell))

collects/racket/draw/private/svg-dc.rkt

@@ -0,0 +1,86 @@
+#lang racket/base
+(require racket/class
+         racket/file
+         racket/path
+         racket/math
+         "syntax.rkt"
+         ffi/unsafe
+         "../unsafe/cairo.ss"
+	 "dc.ss"
+         "font.ss"
+         "local.ss"
+         "ps-setup.ss"
+         "write-bytes.rkt")
+
+(provide svg-dc%)
+
+(define dc-backend%
+  (class default-dc-backend%
+    (init [(init-w width)]
+          [(init-h height)]
+          [(init-output output)]
+          [exists 'error])
+
+    (unless (and (real? init-w) (not (negative? init-w)))
+      (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-w))
+    (unless (and (real? init-h) (not (negative? init-h)))
+      (raise-type-error (init-name 'svg-dc%) "nonnegative real or #f" init-h))
+    (unless (or (output-port? init-output)
+                (path-string? init-output))
+      (raise-type-error (init-name 'svg-dc%) "path string or output port" init-output))
+    (unless (memq exists '(error append update can-update
+                                 replace truncate
+                                 must-truncate truncate/replace))
+      (raise-type-error (init-name 'svg-dc%) 
+                        "'error, 'append, 'update, 'can-update, 'replace, 'truncate, 'must-truncate, or 'truncate/replace"
+                        exists))
+
+    (define width init-w)
+    (define height init-h)
+    (define close-port? (path-string? init-output))
+
+    (define port-box ; needs to be accessible as long as `s' or `c'
+      (let ([output (if (output-port? init-output)
+                        init-output
+                        (open-output-file init-output #:exists exists))])
+        (make-immobile output)))
+    (define s (cairo_svg_surface_create_for_stream 
+               write_port_bytes
+               port-box
+               width
+               height))
+
+    (define c (and s (cairo_create s)))    
+    (when s (cairo_surface_destroy s))
+
+    (define/override (ok?) (and c #t))
+
+    (define/override (get-cr) c)
+
+    (def/override (get-size)
+      (values width height))
+
+    (define/override (end-cr)
+      (cairo_surface_finish s)
+      (cairo_destroy c)
+      (set! c #f)
+      (set! s #f)
+      (when close-port?
+        (close-output-port (ptr-ref port-box _racket)))
+      (set! port-box #f))
+
+    (define/override (get-pango font)
+      (send font get-pango))
+
+    (define/override (get-font-metrics-key sx sy)
+      (if (and (= sx 1.0) (= sy 1.0))
+          3
+          0))
+
+    (define/override (can-combine-text? sz)
+      #t)
+
+    (super-new)))
+
+(define svg-dc% (class (dc-mixin dc-backend%)
+                  (super-new)))

collects/racket/draw/private/write-bytes.rkt

@@ -0,0 +1,17 @@
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/alloc
+         "../unsafe/cairo.ss"
+         "../unsafe/bstr.ss")
+
+(provide write_port_bytes
+         make-immobile)
+
+(define (write-port-bytes port-box bytes len)
+  (write-bytes (scheme_make_sized_byte_string bytes len 0) 
+               (ptr-ref port-box _racket))
+  CAIRO_STATUS_SUCCESS)
+
+(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t))
+
+(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell))

collects/racket/draw/unsafe/cairo.rkt

@@ -243,6 +243,10 @@
   ;; As above:
   (_fun  _fpointer _pointer _double* _double* -> _cairo_surface_t)
   #:wrap (allocator cairo_surface_destroy))
+(define-cairo cairo_svg_surface_create_for_stream 
+  ;; As above:
+  (_fun  _fpointer _pointer _double* _double* -> _cairo_surface_t)
+  #:wrap (allocator cairo_surface_destroy))
 (define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int))
 (define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void)
   #:fail (lambda ()

collects/scribblings/draw/dc-intf.scrbl

@@ -439,10 +439,10 @@ See also @method[dc<%> set-text-foreground], @method[dc<%>
 @defmethod[(end-doc)
            void?]{
 
-Ends a document, relevant only when drawing to a printer or PostScript
+Ends a document, relevant only when drawing to a printer, PostScript,
- device (including to a PostScript file).
+ PDF, or SVG device.
 
-For printer or PostScript output, an exception is raised if
+For relevant devices, an exception is raised if
 @scheme[end-doc] is called when the document is not started with
 @method[dc<%> start-doc], when a page is currently started by
 @method[dc<%> start-page] and not ended with @method[dc<%> end-page],
@@ -454,10 +454,10 @@ or when the document has been ended already.
 @defmethod[(end-page)
            void?]{
 
-Ends a single page, relevant only when drawing to a printer or
+Ends a single page, relevant only when drawing to a printer,
- PostScript device (including to a PostScript file).
+ PostScript, PDF, or SVG device.
 
-For printer or PostScript output, an exception is raised if
+For relevant devices, an exception is raised if
 @scheme[end-page] is called when a page is not currently started by
 @method[dc<%> start-page].}
 
@@ -1065,12 +1065,12 @@ get-transformation] for information about @racket[t].}
 @defmethod[(start-doc [message string?])
            boolean?]{
 
-Starts a document, relevant only when drawing to a printer or
+Starts a document, relevant only when drawing to a printer,
- PostScript device (including to a PostScript file).  For some
+ PostScript, PDF, or SVG device.  For some
  platforms, the @scheme[message] string is displayed in a dialog until
  @method[dc<%> end-doc] is called.
 
-For printer or PostScript output, an exception is raised if
+For relevant devices, an exception is raised if
  @scheme[start-doc] has been called already (even if @method[dc<%>
  end-doc] has been called as well). Furthermore, drawing methods raise
  an exception if not called while a page is active as determined by
@@ -1081,10 +1081,10 @@ For printer or PostScript output, an exception is raised if
 @defmethod[(start-page)
            void?]{
 
-Starts a page, relevant only when drawing to a printer or PostScript
+Starts a page, relevant only when drawing to a printer, PostScript,
- device (including to a PostScript file).
+ SVG, or PDF device.
 
-For printer or PostScript output, an exception is raised if
+Relevant devices, an exception is raised if
  @scheme[start-page] is called when a page is already started, or when
  @method[dc<%> start-doc] has not been called, or when @method[dc<%>
  end-doc] has been called already. In addition, in the case of

collects/scribblings/draw/draw.scrbl

@@ -38,6 +38,7 @@ interface, and procedure bindings defined in this manual.}
 @include-section["ps-setup-class.scrbl"]
 @include-section["radial-gradient-class.scrbl"]
 @include-section["region-class.scrbl"]
+@include-section["svg-dc-class.scrbl"]
 @include-section["draw-funcs.scrbl"]
 @include-section["draw-unit.scrbl"]
 

collects/scribblings/draw/pdf-dc-class.scrbl

@@ -9,7 +9,10 @@ Like @racket[post-script-dc%], but generates a PDF file instead of a
 @defconstructor[([interactive any/c #t]
                  [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f]
                  [use-paper-bbox any/c #f]
-                 [as-eps any/c #t])]{
+                 [as-eps any/c #t]
+                 [width (or/c (and/c real? (not/c negative?)) #f) #f]
+                 [height (or/c (and/c real? (not/c negative?)) #f) #f]
+                 [output (or/c path-string? output-port? #f) #f])]{
 
 See @racket[post-script-dc%] for information on the arguments. The
 @racket[as-eps] argument is allowed for consistency with

collects/scribblings/draw/svg-dc-class.scrbl

@@ -0,0 +1,26 @@
+#lang scribble/doc
+@(require "common.ss")
+
+@defclass/title[svg-dc% object% (dc<%>)]{
+
+Similar to @racket[post-script-dc%], but generates a SVG (scalable
+ vector graphics) file instead of a PostScript file.
+
+@defconstructor[([width (and/c real? (not/c negative?))]
+                 [height (and/c real? (not/c negative?))]
+                 [output (or/c path-string? output-port?)]
+                 [exists (or/c 'error 'append 'update 'can-update
+                               'replace 'truncate
+                               'must-truncate 'truncate/replace)
+                         'error])]{
+
+The @racket[width] and @racket[height] arguments determine the width
+ and height of the generated image.
+
+The image is written to @racket[output]. If @racket[output] is a path
+ and the file exists already, then @racket[exists] determines how
+ the existing file is handled in the same way as for the @racket[#:exists]
+ argument to @racket[open-output-file].}
+
+}
+

collects/tests/gracket/draw.rkt

@@ -203,9 +203,9 @@
        [vp (make-object vertical-panel% f)]
        [hp0 (make-object horizontal-panel% vp)]
        [hp (make-object horizontal-panel% vp)]
+       [hp3 (make-object horizontal-panel% vp)]
        [hp2 hp]
        [hp2.5 hp0]
-       [hp3 hp]
        [hp4 (new horizontal-panel% [parent vp]
                  [stretchable-height #f])]
        [bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
@@ -222,6 +222,7 @@
        [use-bad? #f]
        [depth-one? #f]
        [cyan? #f]
+       [multi-page? #f]
        [smoothing 'unsmoothed]
        [save-filename #f]
        [save-file-format #f]
@@ -995,6 +996,14 @@
 		  (let ([dc (if kind
 				(let ([dc (case kind
                                             [(print) (make-object printer-dc%)]
+                                            [(svg)
+                                             (let ([fn (put-file)])
+                                               (and fn
+                                                    (new svg-dc%
+                                                         [width (* xscale DRAW-WIDTH)]
+                                                         [height (* yscale DRAW-HEIGHT)]
+                                                         [output fn]
+                                                         [exists 'truncate])))]
                                             [(ps pdf)
                                              (let ([page?
                                                     (eq? 'yes (message-box
@@ -1178,7 +1187,12 @@
 
 		      (send dc set-clipping-region #f)
 
-		      (send dc end-page)
+
+                      (send dc end-page)
+                      (when (and kind multi-page?)
+                        (send dc start-page)
+                        (send dc draw-text "Page 2" 0 0)
+                        (send dc end-page))
 		      (send dc end-doc)))
 		  
 		  (when save-filename
@@ -1202,6 +1216,28 @@
     (make-object button% "PDF" hp
 		 (lambda (self event)
 		   (send canvas on-paint 'pdf)))
+    (make-object button% "SVG" hp
+		 (lambda (self event)
+		   (send canvas on-paint 'svg)))
+    (make-object check-box% "Multiple Pages" hp
+                 (lambda (self event)
+                   (set! multi-page? (send self get-value))))
+    (make-object button% "Save" hp
+		 (lambda (b e)
+		   (unless use-bitmap?
+		     (error 'save-file "only available for pixmap/bitmap mode"))
+		   (let ([f (put-file)])
+		     (when f
+		       (let ([format
+			      (cond 
+			       [(regexp-match "[.]xbm$" f) 'xbm]
+			       [(regexp-match "[.]xpm$" f) 'xpm]
+			       [(regexp-match "[.]jpe?g$" f) 'jpeg]
+			       [(regexp-match "[.]png$" f) 'png]
+			       [else (error 'save-file "unknown suffix: ~e" f)])])
+			 (set! save-filename f)
+			 (set! save-file-format format)
+			 (send canvas refresh))))))
     (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp
 		 (lambda (self event)
 		   (send canvas set-scale 
@@ -1246,22 +1282,6 @@
     (make-object check-box% "Kern" hp2.5
 		 (lambda (self event)
 		   (send canvas set-kern (send self get-value))))
-    (make-object button% "Save" hp0
-		 (lambda (b e)
-		   (unless use-bitmap?
-		     (error 'save-file "only available for pixmap/bitmap mode"))
-		   (let ([f (put-file)])
-		     (when f
-		       (let ([format
-			      (cond 
-			       [(regexp-match "[.]xbm$" f) 'xbm]
-			       [(regexp-match "[.]xpm$" f) 'xpm]
-			       [(regexp-match "[.]jpe?g$" f) 'jpeg]
-			       [(regexp-match "[.]png$" f) 'png]
-			       [else (error 'save-file "unknown suffix: ~e" f)])])
-			 (set! save-filename f)
-			 (set! save-file-format format)
-			 (send canvas refresh))))))
     (make-object choice% "Clip" 
 		 '("None" "Rectangle" "Rectangle2" "Octagon" 
 		   "Circle" "Wedge" "Round Rectangle" "Lambda"

doc/release-notes/racket/Draw_and_GUI_5_1.txt

@@ -95,8 +95,8 @@ backward-compatibile. Methods like `get-translation',
 `set-translation', `scale', etc. help hide the reundancy.
 
 
-PostScript and PDF Drawing Contexts
+PostScript, PDF, and SVG Drawing Contexts
------------------------------------
+-----------------------------------------
 
 The dimensions for PostScript output are no longer inferred from the
 drawing. Instead, the width and height must be supplied when the
@@ -105,6 +105,9 @@ drawing. Instead, the width and height must be supplied when the
 The new `pdf-dc%' drawing context is like `post-script-dc%', but it
 generates PDF output.
 
+The new `svg-dc%' drawing context is similar to `post-script-dc%',
+but it generates SVG output.
+
 
 Other Drawing-Context Changes
 -----------------------------