From 4e9b5bcaef12c0b6f5544a4cc2c9247ee0f0ea8f Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 2 Feb 2011 20:10:44 -0600
Subject: [PATCH] adjust the wxme reader so that it now creates image-snip%s
 when it finds image-snips in file   it used to create image% objects that
 were simple containers for the   data in the file; the change _should_ be
 backwards compatibile;   the only know incompatibility is that the
 get-filename method   now returns a path instead of bytes (this is to match
 the   image-snip% class)

   closes PR 1168

   please merge to the 5.1 release branch
(cherry picked from commit 0fce29f552eeef416bfb66459123614518f02513)
---
 collects/racket/snip/private/snip.rkt         |   6 +-
 collects/scribblings/gui/wxme.scrbl           |  20 +--
 .../gracket/image-snip-unmarshalling.rkt      | 142 ++++++++++++++++++
 collects/wxme/image.rkt                       |  59 +++++++-
 collects/wxme/wxme.rkt                        |   8 +-
 5 files changed, 219 insertions(+), 16 deletions(-)
 create mode 100644 collects/tests/gracket/image-snip-unmarshalling.rkt

diff --git a/collects/racket/snip/private/snip.rkt b/collects/racket/snip/private/snip.rkt
index fecdc0bd7c..1bcd4f27dc 100644
--- a/collects/racket/snip/private/snip.rkt
+++ b/collects/racket/snip/private/snip.rkt
@@ -49,7 +49,8 @@
 
          readable-snip<%>
 
-         image-type?)
+         image-type?
+         int->img-type)
 
 ;; these are used only in contracts
 ;; we don't want the real definitions b/c they require the gui
@@ -826,6 +827,9 @@
                             (values filename
                                     (int->img-type type)
                                     #f))])
+            ;; the call to create an image-snip% object
+            ;; here should match the way that super-make-object
+            ;; is called in wxme/image.rkt
             (let ([snip (make-object image-snip% 
                                      (if (equal? loadfile #"")
                                          #f
diff --git a/collects/scribblings/gui/wxme.scrbl b/collects/scribblings/gui/wxme.scrbl
index e49260956a..875dd4bdd9 100644
--- a/collects/scribblings/gui/wxme.scrbl
+++ b/collects/scribblings/gui/wxme.scrbl
@@ -3,6 +3,7 @@
           (for-label wxme
                      wxme/editor
                      wxme/image
+                     racket/snip
                      (except-in wxme/comment reader)
                      (except-in wxme/xml reader)
                      (except-in wxme/scheme reader)
@@ -302,7 +303,7 @@ Several compatibility mappings are installed automatically for the
 @racketmodname[wxme] library. They correspond to popular graphical
 elements supported by various versions of DrRacket, including comment
 boxes, fractions, XML boxes, Racket boxes, text boxes, and images
-generated by the ``world'' and ``image'' teachpacks (or, more
+generated by the @racketmodname[htdp/image] teachpack (or, more
 generally, from @racketmodname[mrlib/cache-image-snip]), and test-case
 boxes.
 
@@ -323,7 +324,8 @@ special-comment content is the readable instance. XML, Racket, and
 text boxes similarly produce instances of @racket[editor%] and
 @racket[readable<%>] that expand in the usual way; see
 @racketmodname[wxme/xml], @racketmodname[wxme/scheme], and
-@racket[wxme/text]. Images from the ``world'' and ``image'' teachpacks
+@racket[wxme/text]. Images from the 
+@racketmodname[htdp/image] teachpack
 are packaged as instances of @racket[cache-image%] from the
 @racketmodname[wxme/cache-image] library. Test-case boxes are packaged
 as instances of @racket[test-case%] from the
@@ -353,14 +355,14 @@ editor's content.}
 
 @defmodule[wxme/image]
 
-@defclass[image% object% ()]{
+@defclass[image% image-snip% ()]{
 
 Instantiated for images in a @tech{WXME} stream in text mode.
-
-@defmethod[(get-filename) (or/c bytes? false/c)]{
-
-Returns a filename as bytes, or @racket[#f] if data is available
-instead.}
+This class can just be treated like @racket[image-snip%] and should
+behave just like it, except it has the methods below in addition
+in case old code still needs them. In other words, the methods
+below are provided for backwards compatibility with earlier 
+verisons of Racket.
 
 @defmethod[(get-data) (or/c bytes? false/c)]{
 
@@ -543,7 +545,7 @@ rational numbers.}]
 @defthing[reader (is-a?/c snip-reader<%>)]{
 
 A text-mode reader for images in a WXME stream generated by the
-``image'' and ``world'' teachpacks---or, more generally, by
+@racketmodname[htdp/image] teachpack---or, more generally, by
 @racketmodname[mrlib/cache-image-snip].}]
 
 
diff --git a/collects/tests/gracket/image-snip-unmarshalling.rkt b/collects/tests/gracket/image-snip-unmarshalling.rkt
new file mode 100644
index 0000000000..cb8a4937ea
--- /dev/null
+++ b/collects/tests/gracket/image-snip-unmarshalling.rkt
@@ -0,0 +1,142 @@
+#lang racket/gui
+(require wxme
+         wxme/image)
+
+#|
+
+This file tests the wxme image-snip reader against the normal
+image-snip reader (ie image-snip-class%'s read method)
+
+It creates a bunch of different image-snip% objects 
+(the try-perms and below functions)
+and then feeds them thru both paths to get two new image snips 
+(in the beginning of test-wxme-image-snip-reader/proc)
+and compares a bunch of properties of them
+(the end of that function).
+
+|#
+
+(define-syntax (test-wxme-image-snip-reader stx)
+  (syntax-case stx ()
+    [(_ is)
+     (with-syntax ([line (syntax-line stx)])
+       #'(test-wxme-image-snip-reader/proc line is))]))
+
+(define tests 0)
+(define (test-wxme-image-snip-reader/proc line is)
+  (set! tests (+ tests 1))
+  (define t (new text%))
+  (send t insert is)
+  (define sp (open-output-string))
+  (void (send t save-port sp))
+  (define wp (wxme-port->port (open-input-string (get-output-string sp))))
+  (define wxme-is (read-char-or-special wp))
+  
+  (define t2 (new text%))
+  (send t2 insert-port (open-input-string (get-output-string sp)))
+  (define copy-is (send t2 find-first-snip))
+  
+  (define (warn . args)
+    (fprintf (current-error-port)
+             (string-append (format "FAILED test-wxme-image-snip-reader.rkt line ~a: " line)
+                            (apply format args))))
+  
+  (define-syntax-rule (cmp mtd) (cmp/proc (λ (x) (send x mtd)) 'mtd))
+  (define (cmp/proc call-mtd mtd)
+    (let ([is-ans (call-mtd is)]
+          [wxme-is-ans (call-mtd wxme-is)]
+          [copy-is-ans (call-mtd copy-is)])
+      (unless (same? copy-is-ans wxme-is-ans)
+        (warn "~a returned different results; copy-is: ~s wxme-is: ~s\n"
+              mtd
+              copy-is-ans 
+              wxme-is-ans))
+      #;
+      (unless (same? is-ans copy-is-ans)
+        (warn "~a returned different results; is: ~s copy-is: ~s\n"
+              mtd
+              is-ans 
+              copy-is-ans))))
+  
+  (when (is-a? is image%)
+    (warn "the input image-snip% is an image%\n"))
+  
+  (unless (is-a? wxme-is image%)
+    (warn "new image snip is not an image%\n"))
+  
+  (cmp get-filename)
+  (cmp get-filetype)
+  (cmp get-bitmap)
+  (cmp get-bitmap-mask))
+
+(define (same? x y)
+  (cond
+    [(and (is-a? x bitmap%)
+          (is-a? y bitmap%))
+     (and (= (send x get-width)
+             (send y get-width))
+          (= (send x get-height)
+             (send y get-height))
+          (= (send x get-depth)
+             (send y get-depth))
+          (check? (bitmap->bytes x #f)
+                  (bitmap->bytes y #f)
+                  'bitmap/#f)
+          (check? (bitmap->bytes x #t)
+                  (bitmap->bytes y #t)
+                  'bitmap/#t))]
+    [else (equal? x y)]))
+
+
+(define (check? a b what)
+  (cond
+    [(equal? a b) #t]
+    [else 
+     ;(fprintf (current-error-port) "checking ~s, doesn't match\n~s\nvs\n~s\n\n" what a b)
+     #f]))
+
+(define (bitmap->bytes bmp alpha?)
+  (define w (send bmp get-width))
+  (define h (send bmp get-height))
+  (define bytes (make-bytes (* 4 w h) 0))
+  (send bmp get-argb-pixels 0 0 w h bytes alpha?)
+  bytes)
+
+(define (try-perms files kinds relative-path?s inline?s)
+  (for* ([file (in-list files)]
+         [kind (in-list kinds)]
+         [relative-path? (in-list relative-path?s)]
+         [inline? (in-list inline?s)])
+    (test-wxme-image-snip-reader (make-object image-snip% file kind relative-path? inline?))))
+
+(try-perms (list (collection-file-path "b-run.png" "icons"))
+           '(unknown unknown/mask unknown/alpha
+                     png png/mask png/alpha)
+           '(#f)
+           '(#f #t))
+
+(parameterize ([current-directory (collection-path "icons")])
+  (try-perms (list "b-run.png")
+             '(unknown unknown/mask unknown/alpha
+                       png png/mask png/alpha)
+             '(#f)
+             '(#f #t)))
+
+(define (draw-circle bm)
+  (define bdc (make-object bitmap-dc% bm))
+  (send bdc set-smoothing 'smoothed)
+  (send bdc set-brush "red" 'solid)
+  (send bdc draw-ellipse 1 1 8 8)
+  (send bdc set-bitmap #f))
+
+(let ([bm (make-bitmap 10 10 #f)])
+  (draw-circle bm)
+  (test-wxme-image-snip-reader (make-object image-snip% bm))
+  (test-wxme-image-snip-reader (make-object image-snip% bm #f))
+  (test-wxme-image-snip-reader (make-object image-snip% bm bm)))
+
+(let ([bm (make-bitmap 10 10)])
+  (draw-circle bm)
+  (test-wxme-image-snip-reader (make-object image-snip% bm)))
+
+(printf "ran ~a tests\n" tests)
diff --git a/collects/wxme/image.rkt b/collects/wxme/image.rkt
index 27915207b2..24e3dba79b 100644
--- a/collects/wxme/image.rkt
+++ b/collects/wxme/image.rkt
@@ -1,11 +1,62 @@
+#lang racket/base
+(require racket/class
+         racket/snip
+         "private/class-help.ss")
 
-(module image mzscheme
-  (require mzlib/class
-           "private/class-help.ss")
+(provide image%)
 
-  (provide image%)
+#|
+
+This code is a bit strange in order to attempt to
+preserve backwards compatibility with pre-5.1 versions.
+
+The old version is:
 
   (define image%
     (class object%
       (init-accessible filename data w h dx dy)
       (super-new))))
+
+The things I attempted to preserve:
+
+ - image% as a class whose objects can be tested with is-a?
+
+ - the get-* methods that init-accessible provides; with the exception
+   of get-filename, which is now the image-snip% method, these are done
+   still with init-accessible
+
+   The get-filename method changed, tho: it now returns a path (it returned
+   bytes before)
+
+ - the constructor arity (there are now additional optional arguments that
+   wxme supplies to be able to call super-make-object)
+
+The main change is to make this file depend on racket/snip so that
+image% can be a subclass of image-snip% and thus work with things like
+the 2htdp/universe libraries (in executables)
+
+
+|#
+
+(define image%
+  (class image-snip%
+    (init filename)
+    (init-accessible data w h dx dy)
+    (init [relative 1] [type 'unknown])
+    ;; the call to super-make-object is intended to mimic the way that racket/snip/private/snip.rkt
+    ;; creates an image-snip% object in the image-snip-class% class's read method
+    (let ([data (get-data)])
+      (super-make-object
+       (if data
+           (let-values ([(in out) (make-pipe)])
+             (thread (λ () (display data out) (close-output-port out)))
+             in)
+           (if (bytes? filename)
+               (bytes->path filename)
+               #f))
+       (if data 'unknown/alpha type)
+       (positive? relative) 
+       (and data #t)))
+    (inherit resize set-offset)
+    (resize (get-w) (get-h))
+    (set-offset (get-dx) (get-dy))))
diff --git a/collects/wxme/wxme.rkt b/collects/wxme/wxme.rkt
index 819e60b1b1..97f110c0dd 100644
--- a/collects/wxme/wxme.rkt
+++ b/collects/wxme/wxme.rkt
@@ -8,6 +8,7 @@
            mzlib/list
            scheme/gui/dynamic
            syntax/modread
+           (only racket/snip/private/snip int->img-type)
            "image.ss"
            "editor.ss"
            "private/compat.ss")
@@ -449,7 +450,7 @@
                      [h (read-inexact who port vers "image-snip height")]
                      [dx (read-inexact who port vers "image-snip x-offset")]
                      [dy (read-inexact who port vers "image-snip y-offset")]
-                     [rel? (read-integer who port vers "image-snip relative?")])
+                     [relative (read-integer who port vers "image-snip relative?")])
                  (let ([data
                         (and (and (equal? filename #"")
                                   (cvers . > . 1)
@@ -466,7 +467,10 @@
                                        (loop (add1 i))))))))])
                    (if (header-plain-text? header)
                        #"."
-                       (make-object image% (if data #f filename) data w h dx dy)))))]
+                       (make-object image%
+                         (if data #f filename)
+                         data w h dx dy
+                         relative (int->img-type type))))))]
             [else
              (if (header-skip-content? header)
                  #f