More bindings (#128)

* add method get_size to GWindow.window
* add allocated_{width,height} methods to Gtk.misc_ops
* bind set_absolute_size and get_size_is_absolute to pango font desc interface
* add above-child and visible-window properties to event_box
* resurrect support for librsvg2
* remove commented stuff from src-rsvg2/dune
* add missing lablgtk3-rsvg2.opam
* fix lablgtk3-rsvg2.opam
* opam: add 'dune subst' command for to build pinned packages
* add method GMisc.statusbar_context#remove_all

examples/dune

@@ -20,7 +20,8 @@
    link_button ; lissajous
    nihongo notebook
    pango1 pango2
-   ; pixview pousse
+   pixview
+   ; pousse
    progressbar radiobuttons rpn
    ; runthread
    scrolledwin seppala signal_override ; slide_show
@@ -48,7 +49,7 @@
    testthread timer toolbar tooltip tree tree_model tree_store tron
  )
  (flags :standard -w -3-6-7-10-24-26-27-33-35 -no-strict-sequence)
- (libraries lablgtk3))
+ (libraries lablgtk3 lablgtk3-rsvg2))
 
 (executables
  (names spell)

examples/pixview.ml

@@ -10,32 +10,31 @@
 
 (* An image viewer, supporting all formats allowed by GdkPixbuf *)
 
-let pb =
-  if Array.length Sys.argv < 2 then begin
+if Array.length Sys.argv < 2 then begin
     Printf.eprintf "usage : %s <file>\n" Sys.argv.(0);
-    exit 2;
-  end;
-  try GdkPixbuf.from_file Sys.argv.(1)
+    exit 2
+  end;;
+
+let file = Sys.argv.(1)
+let pb =
+  try
+    match String.lowercase_ascii (Filename.extension file) with
+    | "svg" -> Rsvg2.render_from_file file
+    | _ -> GdkPixbuf.from_file file
   with GdkPixbuf.GdkPixbufError(_,msg) as exn ->
     let d = GWindow.message_dialog ~message:msg ~message_type:`ERROR
         ~buttons:GWindow.Buttons.close ~show:true () in
     d#run ();
     raise exn
 
-let pm, _ = GdkPixbuf.create_pixmap pb
-
-let width = GdkPixbuf.get_width pb
-let height = GdkPixbuf.get_height pb
-
-let w = GWindow.window ~width ~height ~title:Sys.argv.(1) ()
-let da = GMisc.drawing_area ~packing:w#add ()
-
-let dw = da#misc#realize (); new GDraw.drawable da#misc#window
-
 let () =
   GMain.init ();
-  da#event#connect#expose (fun _ -> dw#put_pixmap ~x:0 ~y:0 pm; true);
+  let width = GdkPixbuf.get_width pb in
+  let height = GdkPixbuf.get_height pb in
+  let w = GWindow.window ~width ~height ~title:file () in
   w#connect#destroy GMain.quit;
+  let image = GMisc.image ~pixbuf:pb () in
+  w#add image#coerce ;
   w#show ();
   GMain.main ()
 

lablgtk3-gtkspell3.opam

@@ -35,5 +35,6 @@ depexts: [
 ]
 
 build: [
+  [ "dune" "subst" ] {pinned}
   [ "dune" "build" "-p" name "-j" jobs ]
 ]

lablgtk3-rsvg2.opam

@@ -0,0 +1,28 @@
+opam-version: "2.0"
+
+synopsis: "OCaml interface to Gnome rsvg2 library"
+description: """
+OCaml interface to Gnome rsvg2 library.
+
+See https://garrigue.github.io/lablgtk/ for more information.
+"""
+
+maintainer: "garrigue@math.nagoya-u.ac.jp"
+authors: ["Jacques Garrigue et al., Nagoya University"]
+homepage: "https://github.com/garrigue/lablgtk"
+bug-reports: "https://github.com/garrigue/lablgtk/issues"
+dev-repo: "git+https://github.com/garrigue/lablgtk.git"
+doc: "https://garrigue.github.io/lablgtk/lablgtk3-sourceview3"
+license: "LGPL with linking exception"
+
+depends: [
+  "ocaml"                {         >= "4.12.0" }
+  "dune"                 {         >= "1.8.0"  }
+  "lablgtk3"             {          = version  }
+  "conf-librsvg2"        { build & >= "0"      }
+]
+
+build: [
+  [ "dune" "subst" ] {pinned}
+  [ "dune" "build" "-p" name "-j" jobs ]
+]

lablgtk3-sourceview3.opam

@@ -24,5 +24,6 @@ depends: [
 ]
 
 build: [
+  [ "dune" "subst"] {pinned}
   [ "dune" "build" "-p" name "-j" jobs ]
 ]

lablgtk3.opam

@@ -26,6 +26,7 @@ depends: [
 ]
 
 build: [
+  [ "dune" "subst"] {pinned}
   [ "dune" "build" "-p" name "-j" jobs ]
 ]
 run-test: [

src-rsvg2/dune

@@ -0,0 +1,29 @@
+; Dune build file for lablgtk3
+; Written by EJGA, (c) 2018-2019 MINES ParisTech
+; This file is in the public domain
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; lablgtk3-rsvg2                                                       ;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(rule
+ (targets
+   cflag-librsvg-2.0.sexp
+   clink-librsvg-2.0.sexp)
+ (action (run dune_config -pkg librsvg-2.0 -version 2.40)))
+
+(rule
+ (targets cflag-extraflags.sexp)
+ (action (with-outputs-to cflag-extraflags.sexp (echo "(%{env:LABLGTK_EXTRA_FLAGS=})"))))
+
+(library
+ (name lablgtk3_rsvg2)
+ (public_name lablgtk3-rsvg2)
+ (wrapped false)
+ (flags :standard -w -6-7-27-32-33-34-36)
+; (modules_without_implementation librsvg2_types)
+ (c_names ml_rsvg2)
+ (c_flags         (:include cflag-librsvg-2.0.sexp) (:include cflag-extraflags.sexp) -Wno-deprecated-declarations)
+ (c_library_flags (:include clink-librsvg-2.0.sexp))
+ (libraries lablgtk3))
+

src-rsvg2/ml_rsvg2.c

@@ -0,0 +1,106 @@
+/**************************************************************************/
+/*                Lablgtk                                                 */
+/*                                                                        */
+/*    This program is free software; you can redistribute it              */
+/*    and/or modify it under the terms of the GNU Library General         */
+/*    Public License as published by the Free Software Foundation         */
+/*    version 2, with the exception described in file COPYING which       */
+/*    comes with the library.                                             */
+/*                                                                        */
+/*    This program is distributed in the hope that it will be useful,     */
+/*    but WITHOUT ANY WARRANTY; without even the implied warranty of      */
+/*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       */
+/*    GNU Library General Public License for more details.                */
+/*                                                                        */
+/*    You should have received a copy of the GNU Library General          */
+/*    Public License along with this program; if not, write to the        */
+/*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         */
+/*    Boston, MA 02111-1307  USA                                          */
+/*                                                                        */
+/*                                                                        */
+/**************************************************************************/
+
+/* $Id$ */
+/* Author: Olivier Andrieu */
+
+#include <gdk-pixbuf/gdk-pixbuf.h>
+#include <librsvg/rsvg.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include "wrappers.h"
+#include "ml_gdkpixbuf.h"
+#include "ml_gobject.h"
+#include "ml_glib.h"
+
+static
+void ml_rsvg_size_callback(gint *w, gint *h, gpointer user_data)
+{
+  value *cb = user_data;
+  value r;
+  r = callback2_exn(*cb, Val_int(*w), Val_int(*h));
+  if(Is_exception_result(r)) return;
+  *w = Int_val(Field(r, 0));
+  *h = Int_val(Field(r, 1));
+}
+
+ML_0(rsvg_handle_new, Val_pointer)
+
+#define RsvgHandle_val(val) ((RsvgHandle *)Pointer_val(val))
+
+CAMLprim value ml_rsvg_handle_set_size_callback(value vh, value cb)
+{
+  RsvgHandle *h = RsvgHandle_val(vh);
+  value *u_data = ml_global_root_new(cb);
+  rsvg_handle_set_size_callback(h, ml_rsvg_size_callback, u_data, ml_global_root_destroy);
+  return Val_unit;
+}
+
+ML_1(rsvg_handle_free, RsvgHandle_val, Unit)
+
+CAMLprim value ml_rsvg_handle_close(value h)
+{
+  GError *err = NULL;
+  rsvg_handle_close(RsvgHandle_val(h), &err);
+  if (err != NULL)
+    ml_raise_gerror (err);
+  return Val_unit;
+}
+
+static inline
+void check_substring(value s, value o, value l)
+{
+  if(Int_val(o) < 0 || Int_val(l) < 0 ||
+     Int_val(o) + Int_val(l) > string_length(s))
+    invalid_argument("bad substring");
+}
+
+CAMLprim value ml_rsvg_handle_write(value h, value s, value off, value len)
+{
+  GError *err = NULL;
+  check_substring(s, off, len);
+  rsvg_handle_write(RsvgHandle_val(h),
+		    (guchar *) String_val(s)+Int_val(off), Int_val(len), &err);
+  if (err != NULL)
+    ml_raise_gerror (err);
+  return Val_unit;
+}
+
+ML_1(rsvg_handle_get_pixbuf, RsvgHandle_val, Val_GdkPixbuf_new)
+
+#if (LIBRSVG_MAJOR_VERSION == 2) && (LIBRSVG_MINOR_VERSION >= 2)
+ML_2(rsvg_handle_set_dpi, RsvgHandle_val, Double_val, Unit)
+ML_1(rsvg_set_default_dpi, Double_val, Unit)
+#else
+Unsupported(rsvg_handle_set_dpi)
+Unsupported(rsvg_set_default_dpi)
+#endif
+
+CAMLprim value ml_rsvg_init (value unit)
+{
+  ml_register_exn_map(RSVG_ERROR, "ml_rsvg_exn");
+  return Val_unit;
+}

src-rsvg2/rsvg2.ml

@@ -0,0 +1,125 @@
+(**************************************************************************)
+(*                Lablgtk                                                 *)
+(*                                                                        *)
+(*    This program is free software; you can redistribute it              *)
+(*    and/or modify it under the terms of the GNU Library General         *)
+(*    Public License as published by the Free Software Foundation         *)
+(*    version 2, with the exception described in file COPYING which       *)
+(*    comes with the library.                                             *)
+(*                                                                        *)
+(*    This program is distributed in the hope that it will be useful,     *)
+(*    but WITHOUT ANY WARRANTY; without even the implied warranty of      *)
+(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       *)
+(*    GNU Library General Public License for more details.                *)
+(*                                                                        *)
+(*    You should have received a copy of the GNU Library General          *)
+(*    Public License along with this program; if not, write to the        *)
+(*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,         *)
+(*    Boston, MA 02111-1307  USA                                          *)
+(*                                                                        *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+type size_fun = int -> int -> int * int
+
+let round f =
+  int_of_float (if f < 0. then f -. 0.5 else f +. 0.5)
+
+let at_size rw rh w h =
+  (if rw < 0 then w else rw), (if rh < 0 then h else rh)
+let at_zoom zx zy w h =
+  if w < 0 || h < 0
+  then (w, h)
+  else
+    (round (float w *. zx)), (round (float h *. zy))
+let at_max_size mw mh w h =
+  if w < 0 || h < 0
+  then (w, h)
+  else
+    let zx = float mw /. float w in
+    let zy = float mh /. float h in
+    let z = min zx zy in
+    (round (float w *. z)), (round (float h *. z))
+
+let at_zoom_with_max zx zy mw mh w h =
+  if w < 0 || h < 0
+  then (w, h)
+  else
+    let rw = round (float w *. zx) in
+    let rh = round (float h *. zy) in
+    if rw > mw || rh > mh
+    then
+      let zx = float mw /. float w in
+      let zy = float mh /. float h in
+      let z = min zx zy in
+      (round (float w *. z)), (round (float h *. z))
+    else
+      (rw, rh)
+
+type error = Failed
+exception Error of error * string
+external _init : unit -> unit = "ml_rsvg_init"
+let _ =
+  Callback.register_exception "ml_rsvg_exn" (Error (Failed, "")) ;
+  _init ()
+
+type t
+external new_handle : unit -> t
+    = "ml_rsvg_handle_new"
+external set_size_callback : t -> size_fun -> unit
+    = "ml_rsvg_handle_set_size_callback"
+external free_handle : t -> unit
+    = "ml_rsvg_handle_free"
+external close : t -> unit = "ml_rsvg_handle_close"
+external write : t -> string -> off:int -> len:int -> unit = "ml_rsvg_handle_write"
+external get_pixbuf : t -> GdkPixbuf.pixbuf = "ml_rsvg_handle_get_pixbuf"
+external set_dpi : t -> float -> unit = "ml_rsvg_handle_set_dpi"
+external set_default_dpi : float -> unit = "ml_rsvg_set_default_dpi"
+
+type input =
+  | Rsvg_SubString of string * int * int
+  | Rsvg_Buffer of int * (bytes -> int)
+
+let render ?dpi ?size_cb input =
+  let h = new_handle () in
+  Gaux.may (set_size_callback h) size_cb ;
+  Gaux.may (set_dpi h) dpi ;
+  try
+    begin match input with
+    | Rsvg_SubString (s, off, len) ->
+	write h s ~off ~len
+    | Rsvg_Buffer (len, fill) ->
+	let buff = Bytes.create len in
+	let c = ref (fill buff) in
+	while !c > 0 do
+	  write h (Bytes.unsafe_to_string buff) 0 !c ;
+	  c := fill buff
+	done
+    end ;
+    close h ;
+    let pb = get_pixbuf h in
+    free_handle h ;
+    pb
+  with exn ->
+    free_handle h ; raise exn
+
+let render_from_string ?dpi ?size_cb ?pos ?len s =
+  let off = Gaux.default 0 ~opt:pos in
+  let len = Gaux.default (String.length s - off) ~opt:len in
+  render ?dpi ?size_cb
+    (Rsvg_SubString (s, off, len))
+
+let render_from_file ?dpi ?size_cb fname =
+  let ic = open_in fname in
+  let pb =
+    try
+      render ?dpi ?size_cb
+        (Rsvg_Buffer (4096, (fun b -> input ic b 0 (Bytes.length b))))
+    with exn ->
+        close_in ic ; raise exn
+  in
+  close_in ic ;
+  pb
+