minimal support for freetype/fontconfig font backend

10 files changed, 214 insertions, 6 deletions

diff --git a/ChangeLog b/ChangeLog
index 2627644..887b659 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2004-11-01  Olivier Andrieu  <oliv__a@users.sourceforge.net>
+
+	* src/cairo.ml, src/cairo.mli, src/ml_cairo.c: use int instead of
+	float for the width and height of the PNG target 
+
+	* src/cairo_ft.ml, src/cairo_ft.mli, src/ml_cairo_ft.c: minimal
+	support for freetype/fontconfig font backend.
+
+	* test/font.ml: example/test program
+
 2004-10-28  Olivier Andrieu  <oliv__a@users.sourceforge.net>
 
 	* src/*.c: beautify code, run it through indent.
diff --git a/src/.depend_c b/src/.depend_c
index d47a33d..d3670d2 100644
--- a/src/.depend_c
+++ b/src/.depend_c
@@ -1,3 +1,13 @@
-ml_cairo.o: ml_cairo_wrappers.h ml_cairo_channel.h ml_cairo_status.h ml_cairo.h
-ml_cairo_channel.o: ml_cairo_wrappers.h caml_io.h ml_cairo_channel.h
-ml_cairo_lablgtk.o: ml_cairo_status.h ml_cairo.h 
+ml_cairo_bigarr.o: ml_cairo_bigarr.c
+ml_cairo.o: ml_cairo.c ml_cairo_wrappers.h ml_cairo_channel.h \
+  ml_cairo_status.h ml_cairo.h
+ml_cairo_channel.o: ml_cairo_channel.c ml_cairo_wrappers.h caml_io.h \
+  ml_cairo_channel.h
+ml_cairo_ft.o: ml_cairo_ft.c ml_cairo_wrappers.h ml_cairo.h \
+  ml_cairo_status.h
+ml_cairo_gtkcairo.o: ml_cairo_gtkcairo.c ml_cairo.h
+ml_cairo_lablgtk.o: ml_cairo_lablgtk.c ml_cairo.h ml_cairo_status.h
+ml_cairo_path.o: ml_cairo_path.c ml_cairo_wrappers.h ml_cairo.h \
+  ml_cairo_status.h
+ml_cairo_status.o: ml_cairo_status.c ml_cairo.h ml_cairo_status.h
+ml_cairo_wrappers.o: ml_cairo_wrappers.c ml_cairo_wrappers.h
diff --git a/src/Makefile b/src/Makefile
index 1c20cb6..9534e4c 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -23,9 +23,11 @@ gtkcairo.opt : gtkcairo.cmxa dllmlgtkcairo.so
 
 cairo_SRC = cairo_channel.mli cairo.mli cairo.ml \
             cairo_bigarray.mli cairo_bigarray.ml \
+	    cairo_ft.mli cairo_ft.ml \
             ml_cairo_wrappers.c \
 	    ml_cairo_status.c ml_cairo_channel.c \
-            ml_cairo.c ml_cairo_bigarr.c ml_cairo_path.c
+            ml_cairo.c ml_cairo_bigarr.c ml_cairo_path.c \
+	    ml_cairo_ft.c
 
 cairo.cma : $(call mlobjs,$(cairo_SRC))
 	$(OCAMLMKLIB) -o cairo -oc mlcairo $^ $(CAIRO_LIBS)
@@ -73,7 +75,7 @@ endif
           for lib in dll*.so ; do \
             ln -s $(INSTALLDIR)/$$lib $(DESTDIR)$(OCAMLLIB)/stublibs ; done ; fi
 
-DOCFILES = cairo_channel.mli cairo.mli cairo_bigarray.mli
+DOCFILES = cairo_channel.mli cairo.mli cairo_bigarray.mli cairo_ft.mli
 ifdef LABLGTKDIR
 DOCFILES += cairo_lablgtk.mli
 ifdef GTKCAIRO_CFLAGS
@@ -94,6 +96,9 @@ clean :
 -include .depend
 include .depend_c
 
+depend : .depend $(wildcard *.h *.c)
+	gcc -MM -isystem $(OCAMLLIB) -isystem $(C_LABLGTKDIR) $(patsubst -I%,-isystem %,$(GDK_CFLAGS)) $(filter %.c,$^) > .depend_c
+
 .PHONY : cairo lablgtk gtkcairo doc
 
 include ../Makefile.rules
diff --git a/src/cairo_ft.ml b/src/cairo_ft.ml
new file mode 100644
index 0000000..962e3a4
--- /dev/null
+++ b/src/cairo_ft.ml
@@ -0,0 +1,20 @@
+
+exception FT_Error of int
+let _ = Callback.register_exception "FT_exn" (FT_Error 0)
+
+type ft_library
+type ft_face
+
+external init_freetype : unit -> ft_library = "ml_FT_Init_FreeType"
+external done_freetype : ft_library -> unit = "ml_FT_Done_FreeType"
+
+external new_face  : ft_library -> ?index:int -> string -> ft_face = "ml_FT_New_Face"
+external done_face : ft_face -> unit = "ml_FT_Done_Face"
+
+external font_create_for_ft_face : ft_face -> Cairo.font = "ml_cairo_ft_font_create_for_ft_face"
+
+type fc_pattern
+external fc_name_parse   : string -> fc_pattern = "ml_FcNameParse"
+external fc_name_unparse : fc_pattern -> string = "ml_FcNameUnparse"
+
+external font_create : ft_library -> fc_pattern -> Cairo.font = "ml_cairo_ft_font_create"
diff --git a/src/cairo_ft.mli b/src/cairo_ft.mli
new file mode 100644
index 0000000..d140c6b
--- /dev/null
+++ b/src/cairo_ft.mli
@@ -0,0 +1,23 @@
+(** Minimal support for the Fontconfig/Freetype font interface *)
+
+exception FT_Error of int
+
+type ft_library
+type ft_face
+
+val init_freetype : unit -> ft_library
+external done_freetype : ft_library -> unit = "ml_FT_Done_FreeType"
+
+external new_face : ft_library -> ?index:int -> string -> ft_face
+  = "ml_FT_New_Face"
+external done_face : ft_face -> unit = "ml_FT_Done_Face"
+
+external font_create_for_ft_face : ft_face -> Cairo.font
+  = "ml_cairo_ft_font_create_for_ft_face"
+
+type fc_pattern
+external fc_name_parse : string -> fc_pattern = "ml_FcNameParse"
+external fc_name_unparse : fc_pattern -> string = "ml_FcNameUnparse"
+
+external font_create : ft_library -> fc_pattern -> Cairo.font
+  = "ml_cairo_ft_font_create"
diff --git a/src/ml_cairo.h b/src/ml_cairo.h
index e1ca6a7..68059b7 100644
--- a/src/ml_cairo.h
+++ b/src/ml_cairo.h
@@ -8,4 +8,5 @@ struct ml_cairo {
 #define Val_cairo_format_t(v) Val_int(v)
 
 value Val_cairo_surface_t (cairo_surface_t *);
+value Val_cairo_font_t (cairo_font_t *);
 value Val_cairo_t (cairo_t *);
diff --git a/src/ml_cairo_ft.c b/src/ml_cairo_ft.c
new file mode 100644
index 0000000..5de30a5
--- /dev/null
+++ b/src/ml_cairo_ft.c
@@ -0,0 +1,88 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/custom.h>
+#include <caml/callback.h>
+
+#include "ml_cairo_wrappers.h"
+
+#include <cairo.h>
+#include "ml_cairo.h"
+#include "ml_cairo_status.h"
+
+static void
+ml_raise_FT_Error (FT_Error err)
+{
+  static value *caml_exn;
+  if (err == FT_Err_Ok)
+    return;
+
+  if (caml_exn == NULL)
+    {
+      caml_exn = caml_named_value ("FT_exn");
+      if (caml_exn == NULL)
+	failwith ("freetype error");
+    }
+
+  raise_with_arg (*caml_exn, Val_int (err));
+}
+
+#define FT_Library_val(v) (FT_Library)Pointer_val(v)
+
+CAMLprim value
+ml_FT_Init_FreeType (value unit)
+{
+  FT_Library lib;
+  ml_raise_FT_Error (FT_Init_FreeType (&lib));
+  return Val_ptr (lib);
+}
+
+CAMLprim value
+ml_FT_Done_FreeType (value lib)
+{
+  ml_raise_FT_Error (FT_Done_FreeType (FT_Library_val (lib)));
+  return Val_unit;
+}
+
+#define FT_Face_val(v) (FT_Face)Pointer_val(v)
+
+CAMLprim value
+ml_FT_New_Face (value lib, value o_index, value path)
+{
+  FT_Face face;
+  FT_Long index = Option_val(o_index, Long_val, 0);
+  ml_raise_FT_Error (FT_New_Face (FT_Library_val (lib),
+				  String_val (path),
+				  index, &face));
+  return Val_ptr (face);
+}
+
+CAMLprim value
+ml_FT_Done_Face (value face)
+{
+  ml_raise_FT_Error (FT_Done_Face (FT_Face_val (face)));
+  return Val_unit;
+}
+
+ML_1 (cairo_ft_font_create_for_ft_face, FT_Face_val, Val_cairo_font_t)
+
+Make_Val_final_pointer (FcPattern, Ignore, FcPatternDestroy, 10)
+#define FcPattern_val(v) (FcPattern *)Pointer_val(v)
+
+ML_1 (FcNameParse, String_val, Val_FcPattern)
+
+CAMLprim value
+ml_FcNameUnparse (value patt)
+{
+  FcChar8 *s;
+  value r;
+  s = FcNameUnparse (FcPattern_val (patt));
+  if (s == NULL)
+    failwith ("FcNameUnparse");
+  r = copy_string (s);
+  free (s);
+  return r;
+}
+
+ML_2 (cairo_ft_font_create, FT_Library_val, FcPattern_val, Val_cairo_font_t)
diff --git a/src/ml_cairo_wrappers.h b/src/ml_cairo_wrappers.h
index 73d6495..05a7d03 100644
--- a/src/ml_cairo_wrappers.h
+++ b/src/ml_cairo_wrappers.h
@@ -28,6 +28,8 @@ static inline value Val_ptr(void *p)
 #endif
 #define Double_array_length(v) (Wosize_val(v) / Double_wosize)
 
+#define Option_val(v,conv,def) (Is_long(v) ? def : conv(Field((v),0)))
+
 #define Ignore(x)
 #define Unit(x) ((x), Val_unit)
 
diff --git a/test/Makefile b/test/Makefile
index 5ae6d21..f6a3965 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -2,7 +2,7 @@
 include ../config.make
 
 ifdef LABLGTKDIR
-TARGETS += text demo spline basket knockout
+TARGETS += text demo spline basket knockout font
 ifdef GTKCAIRO_CFLAGS
 TARGETS += cube
 endif
@@ -10,6 +10,9 @@ endif
 
 all : $(TARGETS)
 
+font : font.ml
+	$(OCAMLOPT) -o $@ -I ../src cairo.cmxa $^
+
 text : text.ml
 	$(OCAMLOPT) -w s -o $@ -I ../src -I $(LABLGTKDIR) lablgtk.cmxa cairo.cmxa cairo_lablgtk.cmxa gtkInit.cmx $^
 
diff --git a/test/font.ml b/test/font.ml
new file mode 100644
index 0000000..3d3c192
--- /dev/null
+++ b/test/font.ml
@@ -0,0 +1,46 @@
+
+let out_file name =
+  let oc = open_out name in
+  let channel = Cairo_channel.of_out_channel oc in
+  close_out oc ;
+  channel
+
+let pi = 4. *. atan 1.
+
+let main font_arg =
+  let ft = Cairo_ft.init_freetype () in
+  let font, clean_up =
+    if Sys.file_exists font_arg
+    then
+      let face = Cairo_ft.new_face ft font_arg in
+      let font = Cairo_ft.font_create_for_ft_face face in
+      (font, (fun () -> Cairo_ft.done_face face))
+    else
+      let pattern = Cairo_ft.fc_name_parse font_arg in
+      let font = Cairo_ft.font_create ft pattern in
+      (font, ignore)
+  in
+
+  let cr = Cairo.create () in
+  let file = out_file "test_font.png" in
+  Cairo.set_target_png ~cr ~file Cairo.FORMAT_ARGB32 ~width:200 ~height:200 ;
+
+  Cairo.set_font ~cr ~font ;
+
+  Cairo.scale_font cr 20. ;
+  Cairo.move_to cr 10. 10. ;
+  Cairo.rotate cr (pi /. 2.) ;
+  Cairo.show_text cr "Hello World !" ;
+
+  Cairo.finalise_target ~cr ;
+  Cairo_channel.close file ;
+
+  clean_up () ;
+  Cairo_ft.done_freetype ft
+
+let _ =
+  if Array.length Sys.argv < 2 then exit 1 ;
+  main Sys.argv.(1)
+
+
+