images.loader.gdiplus: implementation of the image>stream word for GDI+
for Windowsdb4
Björn Lindqvist
John Benediktsson
parent
c10c5f5736
commit
c0b4537e1a
|
|
@ -1,11 +1,13 @@
|
|||
! (c)2010 Joe Groff bsd license
|
||||
USING: accessors alien.c-types alien.data alien.enums
|
||||
classes.struct destructors images images.loader kernel locals
|
||||
math windows.com windows.gdiplus windows.streams windows.types
|
||||
typed byte-arrays grouping sequences ;
|
||||
USING: accessors alien alien.c-types alien.data alien.enums alien.strings
|
||||
assocs byte-arrays classes.struct destructors grouping images images.loader
|
||||
io kernel locals math mime.types namespaces sequences specialized-arrays
|
||||
windows.com windows.gdiplus windows.streams windows.types ;
|
||||
FROM: system => os windows? ;
|
||||
IN: images.loader.gdiplus
|
||||
|
||||
SPECIALIZED-ARRAY: ImageCodecInfo
|
||||
|
||||
SINGLETON: gdi+-image
|
||||
|
||||
os windows? [
|
||||
|
|
@ -14,6 +16,7 @@ os windows? [
|
|||
] when
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <GpRect> ( x y w h -- rect )
|
||||
GpRect <struct-boa> ; inline
|
||||
|
||||
|
|
@ -25,9 +28,11 @@ os windows? [
|
|||
: gdi+-bitmap-width ( bitmap -- w )
|
||||
{ UINT } [ GdipGetImageWidth check-gdi+-status ]
|
||||
with-out-parameters ;
|
||||
: gdi+-bitmap-height ( bitmap -- w )
|
||||
|
||||
: gdi+-bitmap-height ( bitmap -- h )
|
||||
{ UINT } [ GdipGetImageHeight check-gdi+-status ]
|
||||
with-out-parameters ;
|
||||
|
||||
: gdi+-lock-bitmap ( bitmap rect mode format -- data )
|
||||
{ BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
|
||||
with-out-parameters ;
|
||||
|
|
@ -40,7 +45,7 @@ os windows? [
|
|||
memory>byte-array :> pixels
|
||||
bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
|
||||
w h pixels ;
|
||||
|
||||
|
||||
:: data>image ( w h pixels -- image )
|
||||
image new
|
||||
{ w h } >>dim
|
||||
|
|
@ -49,11 +54,53 @@ os windows? [
|
|||
ubyte-components >>component-type
|
||||
f >>upside-down? ;
|
||||
|
||||
! Only one pixel format supported, but I can't find images in the
|
||||
! wild, loaded using gdi+, in which the format is different.
|
||||
ERROR: unsupported-pixel-format component-order ;
|
||||
|
||||
: check-pixel-format ( image -- )
|
||||
component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;
|
||||
|
||||
: image>gdi+-bitmap ( image -- bitmap )
|
||||
dup check-pixel-format
|
||||
[ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri
|
||||
{ void* } [
|
||||
GdipCreateBitmapFromScan0 check-gdi+-status
|
||||
] with-out-parameters &GdipFree ;
|
||||
|
||||
: image-encoders-size ( -- num size )
|
||||
{ UINT UINT } [
|
||||
GdipGetImageEncodersSize check-gdi+-status
|
||||
] with-out-parameters ;
|
||||
|
||||
: image-encoders ( -- codec-infos )
|
||||
image-encoders-size dup <byte-array> 3dup
|
||||
GdipGetImageEncoders check-gdi+-status
|
||||
nip swap <direct-ImageCodecInfo-array> ;
|
||||
|
||||
: extension>mime-type ( extension -- mime-type )
|
||||
! Crashes if you let this mime through on my machine.
|
||||
dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;
|
||||
|
||||
: mime-type>clsid ( mime-type -- clsid )
|
||||
image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;
|
||||
|
||||
: startup-gdi+ ( -- )
|
||||
start-gdi+ &stop-gdi+ drop ;
|
||||
|
||||
: write-image-to-stream ( image stream extension -- )
|
||||
[ image>gdi+-bitmap ]
|
||||
[ stream>IStream &com-release ]
|
||||
[ extension>mime-type mime-type>clsid ] tri*
|
||||
f GdipSaveImageToStream check-gdi+-status ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: gdi+-image stream>image*
|
||||
drop
|
||||
start-gdi+ &stop-gdi+ drop
|
||||
drop startup-gdi+
|
||||
stream>gdi+-bitmap
|
||||
gdi+-bitmap>data
|
||||
data>image ;
|
||||
|
||||
M: gdi+-image image>stream ( image extension class -- )
|
||||
drop startup-gdi+ output-stream get swap write-image-to-stream ;
|
||||
|
|
|
|||
|
|
@ -1,16 +1,42 @@
|
|||
USING: continuations images.loader io.files.temp kernel system tools.test ;
|
||||
USING: continuations images.loader io.files.temp kernel sequences system
|
||||
tools.test ;
|
||||
IN: images.loader.tests
|
||||
|
||||
os linux? [
|
||||
[ t ] [
|
||||
"vocab:images/testing/png/basi0g01.png" load-image dup
|
||||
"foo.bmp" temp-file [ save-graphic-image ] [ load-image ] bi =
|
||||
CONSTANT: basi0g01.png "vocab:images/testing/png/basi0g01.png"
|
||||
|
||||
os { linux windows } member? [
|
||||
|
||||
{ { t t t } } [
|
||||
basi0g01.png load-image dup
|
||||
{ "png" "gif" "tif" } [
|
||||
"foo." prepend temp-file [ save-graphic-image ] keep
|
||||
] with map
|
||||
[ load-image = ] with map
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
{ t } [
|
||||
[
|
||||
"vocab:images/testing/png/basi0g01.png" load-image
|
||||
basi0g01.png load-image
|
||||
"hai!" save-graphic-image
|
||||
] [ unknown-image-extension? ] recover
|
||||
] unit-test
|
||||
|
||||
! Windows can't save .bmp-files for unknown reason. It can load
|
||||
! them though.
|
||||
os windows? [
|
||||
[
|
||||
basi0g01.png load-image "foo.bmp" temp-file save-graphic-image
|
||||
] [ unknown-image-extension? ] must-fail-with
|
||||
] [
|
||||
{ t } [
|
||||
basi0g01.png load-image dup
|
||||
"foo.bmp" temp-file [ save-graphic-image ] [ load-image ] bi =
|
||||
] unit-test
|
||||
] if
|
||||
|
||||
{ t } [
|
||||
"vocab:images/testing/bmp/rgb_8bit.bmp" load-image dup
|
||||
"foo.png" temp-file [ save-graphic-image ] [ load-image ] bi =
|
||||
] unit-test
|
||||
|
||||
] when
|
||||
|
|
|
|||
Loading…
Reference in New Issue