From cad500d802a0009076dc2855b19abb515ac3cba2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Dec 2010 21:09:58 -0700 Subject: [PATCH] fix problems with image-snip%, masks or alpha channels, and saving and also generalize image-snip% to accept input port instead of filenames, and avoid temporary files for loading and saving images --- collects/mred/private/wxme/snip.rkt | 101 +++++++++--------- .../scribblings/gui/image-snip-class.scrbl | 51 +++++---- 2 files changed, 73 insertions(+), 79 deletions(-) diff --git a/collects/mred/private/wxme/snip.rkt b/collects/mred/private/wxme/snip.rkt index faeac4d89d..9737fd4863 100644 --- a/collects/mred/private/wxme/snip.rkt +++ b/collects/mred/private/wxme/snip.rkt @@ -811,8 +811,7 @@ (let-values ([(loadfile type - inlined? - delfile) + inlined?) (if (and (equal? filename #"") can-inline? (positive? type)) @@ -821,24 +820,18 @@ (send f get-fixed len) (if (and (len . > . 0) (send f ok?)) - (let ([fname (make-temporary-file "img~a")]) - (call-with-output-file* - fname - #:exists 'truncate - (lambda (fi) - (for ([i (in-range len)]) - (display (send f get-unterminated-bytes) fi)))) - (values fname - 'unknown/mask - #t - fname)) + (let-values ([(in out) (make-pipe)]) + (for ([i (in-range len)]) + (display (send f get-unterminated-bytes) out)) + (close-output-port out) + (values in + 'unknown/alpha + #t)) (values filename (int->img-type type) - #f #f))) (values filename (int->img-type type) - #f #f))]) (let ([snip (make-object image-snip% (if (equal? loadfile #"") @@ -849,8 +842,6 @@ type (positive? relative) inlined?)]) - (when delfile - (delete-file delfile)) (send snip resize w h) (send snip set-offset dx dy) @@ -901,7 +892,7 @@ args [([bitmap% bm] [(make-or-false bitmap%) [mask #f]]) (set-bitmap bm mask)] - [([(make-or-false path-string?) [name #f]] + [([(make-or-false (make-alts path-string? input-port?)) [name #f]] [image-type? [kind 'unknown]] [bool? [relative-path? #f]] [bool? [inline? #t]]) @@ -963,7 +954,7 @@ (and mask (send mask ok?) (= w (send mask get-width)) - (= w (send mask get-height)) + (= h (send mask get-height)) mask)))] [alpha (send dc get-alpha)]) (when (pair? caret) @@ -1007,64 +998,68 @@ (send f put-fixed 0) (let ([num-lines - (let ([fname (make-temporary-file "img~a")]) - (send bm save-file fname 'png) - (begin0 - (call-with-input-file* - fname - (lambda (fi) - (let loop ([numlines 0]) - (let ([s (read-bytes IMG-MOVE-BUF-SIZE fi)]) - (if (eof-object? s) - numlines - (begin - (send f put-unterminated s) - (loop (add1 numlines)))))))) - (delete-file fname)))]) + (let-values ([(in out) (make-pipe)]) + (send bm save-file out 'png) + (close-output-port out) + (let loop ([numlines 0]) + (let ([s (read-bytes IMG-MOVE-BUF-SIZE in)]) + (if (eof-object? s) + numlines + (begin + (send f put-unterminated s) + (loop (add1 numlines)))))))]) (let ([end (send f tell)]) (send f jump-to lenpos) (send f put-fixed num-lines) (send f jump-to end))))))) - (def/public (load-file [(make-or-false path-string?) [name #f]] + (def/public (load-file [(make-or-false (make-alts path-string? input-port?)) [name #f]] [image-type? [kind 'unknown]] [bool? [rel-path? #f]] [bool? [inline? #t]]) (do-set-bitmap #f #f #f) (let* ([rel-path? (and rel-path? - name + (path-string? name) (relative-path? name))] [name (if rel-path? name - (and name (path->complete-path name)))]) + (and name + (if (path-string? name) + (path->complete-path name) + name)))]) (set! s-flags (if rel-path? (add-flag s-flags USES-BUFFER-PATH) (remove-flag s-flags USES-BUFFER-PATH))) - (let ([name (and name (if (string? name) - (string->path name) - name))]) + (let ([orig-name name] + [name (and name + (path-string? name) + (if (string? name) + (string->path name) + name))]) (unless inline? (set! filename name) (set! filetype kind)) - (when name - (let ([fullpath (if rel-path? - (path->complete-path - name - (or (and s-admin - (let ([e (send s-admin get-editor)]) - (and e - (let ([fn (send e get-filename)]) - (and fn - (let-values ([(base name dir?) (split-path fn)]) - (and (path? base) - (path->complete-path base)))))))) - (current-directory))) - name)]) + (when orig-name + (let ([fullpath (if (input-port? orig-name) + orig-name + (if rel-path? + (path->complete-path + name + (or (and s-admin + (let ([e (send s-admin get-editor)]) + (and e + (let ([fn (send e get-filename)]) + (and fn + (let-values ([(base name dir?) (split-path fn)]) + (and (path? base) + (path->complete-path base)))))))) + (current-directory))) + name))]) (let ([nbm (dynamic-wind begin-busy-cursor (lambda () diff --git a/collects/scribblings/gui/image-snip-class.scrbl b/collects/scribblings/gui/image-snip-class.scrbl index aa45b9c047..d19dd9befa 100644 --- a/collects/scribblings/gui/image-snip-class.scrbl +++ b/collects/scribblings/gui/image-snip-class.scrbl @@ -8,7 +8,7 @@ An @scheme[image-snip%] is a snip that can display bitmap images box containing an ``X'' is drawn. -@defconstructor*/make[(([filename (or/c path-string? false/c) #f] +@defconstructor*/make[(([file (or/c path-string? input-port? #f) #f] [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha 'gif 'gif/mask 'gif/alpha 'jpeg 'png 'png/mask 'png/alpha @@ -16,9 +16,9 @@ An @scheme[image-snip%] is a snip that can display bitmap images [relative-path? any/c #f] [inline? any/c #t]) ([bitmap (is-a?/c bitmap%)] - [mask (or/c (is-a?/c bitmap%) false/c) #f]))]{ + [mask (or/c (is-a?/c bitmap%) #f) #f]))]{ -Creates an image snip, loading the image @scheme[filename] if +Creates an image snip, loading the image @scheme[file] if specified (see also @method[image-snip% load-file]), or using the given @scheme[bitmap]. @@ -57,7 +57,7 @@ See also @scheme[equal<%>].} @defmethod[(get-bitmap) - (or/c (is-a?/c bitmap%) false/c)]{ + (or/c (is-a?/c bitmap%) #f)]{ Returns the bitmap that is displayed by the snip, whether set through @method[image-snip% set-bitmap] or @method[image-snip% load-file]. If @@ -70,7 +70,7 @@ The returned bitmap cannot be selected into a @scheme[bitmap-dc%] as } @defmethod[(get-bitmap-mask) - (or/c (is-a?/c bitmap%) false/c)]{ + (or/c (is-a?/c bitmap%) #f)]{ Returns the mask bitmap that is used for displaying by the snip, if one was installed with @method[image-snip% set-bitmap]. If no mask @@ -82,8 +82,8 @@ The returned bitmap cannot be selected into a @scheme[bitmap-dc%] as } -@defmethod[(get-filename [relative-path (or/c (box/c any/c) false/c) #f]) - (or/c path-string? false/c)]{ +@defmethod[(get-filename [relative-path (or/c (box/c any/c) #f) #f]) + (or/c path-string? #f)]{ Returns the name of the currently loaded, non-inlined file, or @scheme[#f] if a file is not loaded or if a file was loaded with @@ -106,7 +106,7 @@ Returns the kind used to load the currently loaded, non-inlined file, } -@defmethod[(load-file [filename (or/c path-string? false/c)] +@defmethod[(load-file [file (or/c path-string? input-port? #f)] [kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha 'gif 'gif/mask 'gif/alpha 'jpeg 'png 'png/mask 'png/alpha @@ -115,18 +115,20 @@ Returns the kind used to load the currently loaded, non-inlined file, [inline? any/c #t]) void?]{ -Loads the file by passing @scheme[filename] and @scheme[kind] to - @method[bitmap% load-file] If a bitmap had previously been specified +Loads the file by passing @scheme[file] and @scheme[kind] to + @xmethod[bitmap% load-file]. If a bitmap had previously been specified with @method[image-snip% set-bitmap], that bitmap (and mask) will no - longer be used. If @scheme[filename] is @scheme[#f], then the current + longer be used. If @scheme[file] is @scheme[#f], then the current image is cleared. When @scheme['unknown/mask], @scheme['gif/mask], or @scheme['png/mask] is specified and the loaded bitmap object includes a mask (see @method[bitmap% get-loaded-mask]), the mask is used for drawing the - bitmap (see @method[dc<%> draw-bitmap]). + bitmap (see @method[dc<%> draw-bitmap]). The @scheme['unknown/alpha], + @scheme['gif/alpha], or @scheme['png/alpha] variants are recommended, + however. -If @scheme[relative-path?] is not @scheme[#f] and @scheme[filename] is a +If @scheme[relative-path?] is not @scheme[#f] and @scheme[file] is a relative path, then the file will be read using the path of the owning editor's filename. If the image is not inlined, it will be saved as a relative pathname. @@ -162,22 +164,19 @@ The bitmap will be cropped to fit in the given dimensions. } @defmethod[(set-bitmap [bm (is-a?/c bitmap%)] - [mask (or/c (is-a?/c bitmap%) false/c) #f]) + [mask (or/c (is-a?/c bitmap%) #f) #f]) void?]{ -Sets the bitmap that is displayed by the snip. This method also - accepts an optional mask to be used when drawing the bitmap (see - @method[dc<%> draw-bitmap]), but supplying the mask directly is now - deprecated. Instead, if no mask is supplied but the bitmap's - @method[bitmap% get-loaded-mask] method produces a bitmap of the same - dimensions, it is used as the mask. Furthermore, such a mask is saved - with the snip when it is saved to a file or copied (whereas a - directly supplied mask is not saved). +Sets the bitmap that is displayed by the snip. -The supplied bitmap must not be selected into a @scheme[bitmap-dc%] - object, otherwise @|MismatchExn|, and it cannot be selected into - a @scheme[bitmap-dc%] as long as it belongs to the snip, but it - can be used as a pen or brush stipple. +An optional @racket[mask] is used when drawing the bitmap (see + @method[dc<%> draw-bitmap]), but supplying the mask directly is + deprecated. If no mask is supplied but the bitmap's + @method[bitmap% get-loaded-mask] method produces a bitmap of the same + dimensions, it is used as the mask; furthermore, such a mask is saved + with the snip when it is saved to a file or copied (whereas a + directly supplied mask is not saved). Typically, however, @racket[bm] + instead should have an alpha channel instead of a separate mask bitmap. }