images.loader.gdiplus: implementation of the image>stream word for GDI+

for Windows

diff --git a/basis/images/loader/gdiplus/gdiplus.factor b/basis/images/loader/gdiplus/gdiplus.factor
index 26dab0d58d2df4c7ff1e6aef32e3a040892cfb94..0eceef4a26a1a45ef4d4ec9b4cd06bc0ddc44fa7 100644 (file)
--- a/basis/images/loader/gdiplus/gdiplus.factor
+++ b/basis/images/loader/gdiplus/gdiplus.factor
@@ -1,11 +1,13 @@
 ! (c)2010 Joe Groff bsd license\r
-USING: accessors alien.c-types alien.data alien.enums\r
-classes.struct destructors images images.loader kernel locals\r
-math windows.com windows.gdiplus windows.streams windows.types\r
-typed byte-arrays grouping sequences ;\r
+USING: accessors alien alien.c-types alien.data alien.enums alien.strings\r
+assocs byte-arrays classes.struct destructors grouping images images.loader\r
+io kernel locals math mime.types namespaces sequences specialized-arrays\r
+windows.com windows.gdiplus windows.streams windows.types ;\r
 FROM: system => os windows? ;\r
 IN: images.loader.gdiplus\r
 \r
+SPECIALIZED-ARRAY: ImageCodecInfo\r
+\r
 SINGLETON: gdi+-image\r
 \r
 os windows? [\r
@@ -14,6 +16,7 @@ os windows? [
 ] when\r
 \r
 <PRIVATE\r
+\r
 : <GpRect> ( x y w h -- rect )\r
     GpRect <struct-boa> ; inline\r
 \r
@@ -25,9 +28,11 @@ os windows? [
 : gdi+-bitmap-width ( bitmap -- w )\r
     { UINT } [ GdipGetImageWidth check-gdi+-status ]\r
     with-out-parameters ;\r
-: gdi+-bitmap-height ( bitmap -- w )\r
+\r
+: gdi+-bitmap-height ( bitmap -- h )\r
     { UINT } [ GdipGetImageHeight check-gdi+-status ]\r
     with-out-parameters ;\r
+\r
 : gdi+-lock-bitmap ( bitmap rect mode format -- data )\r
     { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]\r
     with-out-parameters ;\r
@@ -40,7 +45,7 @@ os windows? [
     memory>byte-array :> pixels\r
     bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status\r
     w h pixels ;\r
-    \r
+\r
 :: data>image ( w h pixels -- image )\r
     image new\r
         { w h } >>dim\r
@@ -49,11 +54,53 @@ os windows? [
         ubyte-components >>component-type\r
         f >>upside-down? ;\r
 \r
+! Only one pixel format supported, but I can't find images in the\r
+! wild, loaded using gdi+, in which the format is different.\r
+ERROR: unsupported-pixel-format component-order ;\r
+\r
+: check-pixel-format ( image -- )\r
+    component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;\r
+\r
+: image>gdi+-bitmap ( image -- bitmap )\r
+    dup check-pixel-format\r
+    [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri\r
+    { void* } [\r
+        GdipCreateBitmapFromScan0 check-gdi+-status\r
+    ] with-out-parameters &GdipFree ;\r
+\r
+: image-encoders-size ( -- num size )\r
+    { UINT UINT } [\r
+        GdipGetImageEncodersSize check-gdi+-status\r
+    ] with-out-parameters ;\r
+\r
+: image-encoders ( -- codec-infos )\r
+    image-encoders-size dup <byte-array> 3dup\r
+    GdipGetImageEncoders check-gdi+-status\r
+    nip swap <direct-ImageCodecInfo-array> ;\r
+\r
+: extension>mime-type ( extension -- mime-type )\r
+    ! Crashes if you let this mime through on my machine.\r
+    dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;\r
+\r
+: mime-type>clsid ( mime-type -- clsid )\r
+    image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;\r
+\r
+: startup-gdi+ ( -- )\r
+    start-gdi+ &stop-gdi+ drop ;\r
+\r
+: write-image-to-stream ( image stream extension -- )\r
+    [ image>gdi+-bitmap ]\r
+    [ stream>IStream &com-release ]\r
+    [ extension>mime-type mime-type>clsid ] tri*\r
+    f GdipSaveImageToStream check-gdi+-status ;\r
+\r
 PRIVATE>\r
 \r
 M: gdi+-image stream>image*\r
-    drop\r
-    start-gdi+ &stop-gdi+ drop\r
+    drop startup-gdi+\r
     stream>gdi+-bitmap\r
     gdi+-bitmap>data\r
     data>image ;\r
+\r
+M: gdi+-image image>stream ( image extension class -- )\r
+    drop startup-gdi+ output-stream get swap write-image-to-stream ;\r

diff --git a/basis/images/loader/loader-tests.factor b/basis/images/loader/loader-tests.factor
index 54de95e9a67e3c71bd469fee402becaa2e54ca89..4a3c045d818d17ebb10125dbf533b6f0ba12895f 100644 (file)
--- a/basis/images/loader/loader-tests.factor
+++ b/basis/images/loader/loader-tests.factor
@@ -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