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

original commit: 0fce29f552eeef416bfb66459123614518f02513
This commit is contained in:
Robby Findler 2011-02-02 20:10:44 -06:00
parent f0f7137803
commit 13a61d62d7
2 changed files with 153 additions and 9 deletions

View File

@ -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].}]

View File

@ -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)