images.loader: support for saving images on the gtk-image backend

basis/gdk/pixbuf/ffi/ffi.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2010 Anton Gorenko.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.data alien.libraries alien.syntax
+USING: alien alien.c-types alien.data alien.libraries alien.syntax
 combinators gio.ffi glib.ffi gobject-introspection
 gobject-introspection.standard-types kernel libc
 sequences system vocabs ;
@@ -22,11 +22,32 @@ LIBRARY: gdk.pixbuf
 
 GIR: vocab:gdk/pixbuf/GdkPixbuf-2.0.gir
 
-! <workaround incorrect return-value in gir
+! <workaround incorrect return-values in gir
 
 FORGET: gdk_pixbuf_get_pixels
 FUNCTION: guint8* gdk_pixbuf_get_pixels ( GdkPixbuf* pixbuf ) ;
 
+FORGET: gdk_pixbuf_new_from_data
+FUNCTION: GdkPixbuf* gdk_pixbuf_new_from_data ( guint8* data,
+                                                GdkColorspace colorspace,
+                                                gboolean has_alpha,
+                                                int bits_per_sample,
+                                                int width,
+                                                int height,
+                                                int rowstride,
+                                                GdkPixbufDestroyNotify destroy_fn,
+                                                gpointer destroy_fn_data ) ;
+
+FORGET: gdk_pixbuf_save_to_bufferv
+FUNCTION: gboolean gdk_pixbuf_save_to_bufferv ( GdkPixbuf* pixbuf,
+                                                guint8** data,
+                                                gsize* buffer_size,
+                                                c-string type,
+                                                char **option_keys,
+                                                char **option_values,
+                                                GError **error ) ;
+
+
 ! workaround>
 
 : data>GInputStream ( data -- GInputStream )

basis/images/loader/gtk/gtk-tests.factor

@@ -0,0 +1,21 @@
+USING: accessors arrays continuations gdk.pixbuf.ffi glib.ffi gobject.ffi
+images.loader images.loader.gtk images.loader.gtk.private io
+io.encodings.binary io.files kernel tools.test ;
+IN: images.loader.gtk.tests
+
+: open-png-image ( -- image )
+    "vocab:images/testing/png/basi0g01.png" load-image ;
+
+[ t ] [
+    open-png-image [ dim>> ] [
+        image>GdkPixbuf &g_object_unref
+        [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array
+    ] bi =
+] unit-test
+
+[ t ] [
+    [
+        open-png-image image>GdkPixbuf &g_object_unref
+        "frob" GdkPixbuf>byte-array
+    ] [ g-error? ] recover
+] unit-test

basis/images/loader/gtk/gtk.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2010 Philipp Brüschweiler.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data arrays combinators
+USING: accessors alien.c-types alien.data alien.syntax arrays assocs
-destructors gdk.pixbuf.ffi gobject.ffi grouping images
+combinators destructors gdk.pixbuf.ffi glib.ffi gobject.ffi grouping images
 images.loader io kernel locals math sequences
-specialized-arrays ;
+specialized-arrays unicode.case ;
 FROM: system => os linux? ;
 IN: images.loader.gtk
 SPECIALIZED-ARRAY: uchar
@@ -11,6 +11,8 @@ SPECIALIZED-ARRAY: uchar
 SINGLETON: gtk-image
 
 os linux? [
+    ! Explicit type initialization needed for glib < 2.36.
+    g_type_init
     "png"  gtk-image register-image-class
     "tif"  gtk-image register-image-class
     "tiff" gtk-image register-image-class
@@ -44,12 +46,14 @@ os linux? [
         ] if
     ] ;
 
+CONSTANT: bits>components {
+    { 8 ubyte-components }
+    { 16 ushort-components }
+    { 32 uint-components }
+}
+
 : component-type ( GdkPixbuf -- component-type )
-    gdk_pixbuf_get_bits_per_sample {
+    gdk_pixbuf_get_bits_per_sample bits>components at ;
-        {  8 [ ubyte-components ] }
-        { 16 [ ushort-components ] }
-        { 32 [ uint-components ] }
-    } case ;
 
 : GdkPixbuf>image ( GdkPixbuf -- image )
     [ image new ] dip
@@ -62,6 +66,39 @@ os linux? [
         f >>premultiplied-alpha?
         f >>upside-down? ;
 
+: bits-per-sample ( image -- bits )
+    component-type>> bits>components value-at ;
+
+: rowstride ( image -- rowstride )
+    [ dim>> first ] [ bits-per-sample 8 / ] [ has-alpha? 4 3 ? ] tri * * ;
+
+: image>GdkPixbuf ( image -- GdkPixbuf )
+    {
+        [ bitmap>> ]
+        [ drop GDK_COLORSPACE_RGB ]
+        [ has-alpha? ]
+        [ bits-per-sample ]
+        [ dim>> first2 ]
+        [ rowstride ]
+    } cleave f f gdk_pixbuf_new_from_data ;
+
+: GdkPixbuf>byte-array ( GdkPixbuf type -- byte-array )
+    { void* int } [
+        rot f f
+        { { pointer: GError initial: f } } [
+            gdk_pixbuf_save_to_bufferv drop
+        ] with-out-parameters
+    ] with-out-parameters rot handle-GError memory>byte-array ;
+
+! The type parameter is almost always the same as the file extension,
+! except for in the jpg -> jpeg and tif -> tiff cases.
+: extension>pixbuf-type ( extension -- type )
+    >lower { { "jpg" "jpeg" } { "tif" "tiff" } } ?at drop ;
+
+: write-image ( image extension -- )
+    [ image>GdkPixbuf &g_object_unref ] [ extension>pixbuf-type ] bi*
+    GdkPixbuf>byte-array write ;
+
 PRIVATE>
 
 M: gtk-image stream>image*
@@ -69,3 +106,6 @@ M: gtk-image stream>image*
     stream-contents data>GInputStream &g_object_unref
     GInputStream>GdkPixbuf &g_object_unref
     GdkPixbuf>image ;
+
+M: gtk-image image>stream
+    drop write-image ;

basis/images/loader/loader-tests.factor

@@ -0,0 +1,16 @@
+USING: continuations images.loader io.files.temp kernel 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 =
+    ] unit-test
+
+    [ t ] [
+        [
+            "vocab:images/testing/png/basi0g01.png" load-image
+            "hai!" save-graphic-image
+        ] [ unknown-image-extension? ] recover
+    ] unit-test
+] when

basis/images/loader/loader.factor

@@ -47,9 +47,8 @@ M: pathname load-image*
     [ binary <file-reader> ] dip stream>image ;
 
 ! Image Encode
-
+GENERIC: image>stream ( image extension class -- )
-GENERIC: image>stream ( image class -- )
 
 : save-graphic-image ( image path -- )
-    [ image-class ] [ ] bi
+    dup file-extension dup (image-class) rot
     binary [ image>stream ] with-file-writer ;