diff options
author | buisson | 2005-04-29 09:35:43 +0000 |
---|---|---|
committer | buisson | 2005-04-29 09:35:43 +0000 |
commit | 22c1e6dbe7cf74936e5ca29eadeff81312ccc506 (patch) | |
tree | 3304815b956eb5c76674fa2763d3da8a2e73394f | |
parent | 23abb4b87c7e40ed259dd02f653516f60e55ade4 (diff) | |
download | ivy-ocaml-22c1e6dbe7cf74936e5ca29eadeff81312ccc506.zip ivy-ocaml-22c1e6dbe7cf74936e5ca29eadeff81312ccc506.tar.gz ivy-ocaml-22c1e6dbe7cf74936e5ca29eadeff81312ccc506.tar.bz2 ivy-ocaml-22c1e6dbe7cf74936e5ca29eadeff81312ccc506.tar.xz |
Initial revision
-rw-r--r-- | Makefile | 99 | ||||
-rw-r--r-- | README | 18 | ||||
-rw-r--r-- | cglibivy.c | 36 | ||||
-rw-r--r-- | civy.c | 90 | ||||
-rw-r--r-- | civyloop.c | 60 | ||||
-rw-r--r-- | ctkivy.c | 36 | ||||
-rw-r--r-- | debian/changelog | 6 | ||||
-rw-r--r-- | debian/compat | 1 | ||||
-rw-r--r-- | debian/control | 13 | ||||
-rwxr-xr-x | debian/rules | 98 | ||||
-rw-r--r-- | examples/Makefile | 27 | ||||
-rw-r--r-- | examples/glibivyprobe.ml | 9 | ||||
-rw-r--r-- | examples/ivyivyprobe.ml | 8 | ||||
-rw-r--r-- | examples/ivyprobe.ml | 40 | ||||
-rw-r--r-- | examples/tkivyprobe.ml | 10 | ||||
-rw-r--r-- | glibIvy.ml | 8 | ||||
-rw-r--r-- | glibIvy.mli | 13 | ||||
-rw-r--r-- | ivy.ml | 81 | ||||
-rw-r--r-- | ivy.mli | 57 | ||||
-rw-r--r-- | ivyLoop.ml | 22 | ||||
-rw-r--r-- | ivyLoop.mli | 25 | ||||
-rw-r--r-- | tkIvy.ml | 8 | ||||
-rw-r--r-- | tkIvy.mli | 13 |
23 files changed, 778 insertions, 0 deletions
diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..681cc70 --- /dev/null +++ b/Makefile @@ -0,0 +1,99 @@ +# $Id$ + +DESTDIR = / + +OCAMLC = ocamlc -g +OCAMLMLI = ocamlc +OCAMLOPT = ocamlopt -unsafe +OCAMLDEP=ocamldep +OCAMLFLAGS= +OCAMLOPTFLAGS= +CFLAGS=-Wall +GLIBINC=`pkg-config --cflags glib-2.0` + +IVY = ivy.ml ivyLoop.ml + +IVYCMO= $(IVY:.ml=.cmo) +IVYCMI= $(IVY:.ml=.cmi) +IVYMLI= $(IVY:.ml=.mli) +IVYCMX= $(IVY:.ml=.cmx) + +GLIBIVY = ivy.ml glibIvy.ml + +GLIBIVYCMO= $(GLIBIVY:.ml=.cmo) +GLIBIVYCMI= $(GLIBIVY:.ml=.cmi) +GLIBIVYCMX= $(GLIBIVY:.ml=.cmx) + +TKIVY = ivy.ml tkIvy.ml + +TKIVYCMO= $(TKIVY:.ml=.cmo) +TKIVYCMI= $(TKIVY:.ml=.cmi) +TKIVYCMX= $(TKIVY:.ml=.cmx) + +LIBS = ivy-ocaml.cma ivy-ocaml.cmxa glibivy-ocaml.cma glibivy-ocaml.cmxa +# tkivy-ocaml.cma tkivy-ocaml.cmxa + +all : $(LIBS) + +deb : + dpkg-buildpackage -rfakeroot + +ivy : ivy-ocaml.cma ivy-ocaml.cmxa +glibivy : glibivy-ocaml.cma glibivy-ocaml.cmxa +tkivy : tkivy-ocaml.cma tkivy-ocaml.cmxa + +INST_FILES = $(IVYCMI) $(IVYMLI) glibIvy.cmi $(LIBS) libivy-ocaml.a libglibivy-ocaml.a dllivy-ocaml.so dllglibivy-ocaml.so ivy-ocaml.a glibivy-ocaml.a +# tkIvy.cmi libtkivy-ocaml.a dlltkivy-ocaml.so tkivy-ocaml.a + +install : $(LIBS) + mkdir -p $(DESTDIR)/`ocamlc -where` + cp $(INST_FILES) $(DESTDIR)/`ocamlc -where` + +desinstall : + cd `ocamlc -where`; rm -f $(INST_FILES) + +ivy-ocaml.cma : $(IVYCMO) civy.o civyloop.o + ocamlmklib -o ivy-ocaml $^ -livy + +ivy-ocaml.cmxa : $(IVYCMX) civy.o civyloop.o + ocamlmklib -o ivy-ocaml $^ -livy + +glibivy-ocaml.cma : $(GLIBIVYCMO) civy.o cglibivy.o + ocamlmklib -o glibivy-ocaml $^ -lglibivy `pkg-config --libs glib-2.0` -lpcre + +glibivy-ocaml.cmxa : $(GLIBIVYCMX) civy.o cglibivy.o + ocamlmklib -o glibivy-ocaml $^ -lglibivy `pkg-config --libs glib-2.0` -lpcre + +tkivy-ocaml.cma : $(TKIVYCMO) civy.o ctkivy.o + ocamlmklib -o tkivy-ocaml $^ -livy -ltclivy + +tkivy-ocaml.cmxa : $(TKIVYCMX) civy.o ctkivy.o + ocamlmklib -o tkivy-ocaml $^ -livy -ltclivy + +.SUFFIXES: +.SUFFIXES: .ml .mli .mly .mll .cmi .cmo .cmx .c .o .out .opt + +.ml.cmo : + $(OCAMLC) $(OCAMLFLAGS) $(INCLUDES) -c $< +.c.o : + $(CC) -Wall -c $(GLIBINC) $< +.mli.cmi : + $(OCAMLMLI) $(OCAMLFLAGS) -c $< +.ml.cmx : + $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $< +.mly.ml : + ocamlyacc $< +.mll.ml : + ocamllex $< +.cmo.out : + $(OCAMLC) -custom -o $@ unix.cma -I . ivy-ocaml.cma $< -cclib -livy +.cmx.opt : + $(OCAMLOPT) -o $@ unix.cmxa -I . ivy-ocaml.cmxa $< -cclib -livy + +clean: + \rm -f *.cm* *.o *.a .depend *~ *.out *.opt .depend *.so *_stamp + +.depend: + $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend + +include .depend @@ -0,0 +1,18 @@ +OCaml (caml.org) bindings for the Ivy library (www.tls.cena.fr/products/ivy). + +Two libraries are provided: + - ivy-ocaml, running with the Ivy main loop (module IvyLoop) + - glibivy-ocaml, running with the Glib main loop (provided by lablgtk) + +Installation: + - Requires the OCaml compiler and the ivy-c library + - "make" to compile + - "make install" to set the files (DESTDIR may be specified) + - "examples" directory contains the ivyprobe program for both main loops +("make ivyivyprobe.out" and "make glibivyprobe.out") + +Documentation: + - The Ivy documentation (www.tls.cena.fr/products/ivy) + - The .mli files (ivy.mli, ivyLoop.mli and glibIvy.mli) + +Maintainer: Pascal Brisset (pascal dot brisset at enac dot fr) diff --git a/cglibivy.c b/cglibivy.c new file mode 100644 index 0000000..64266e8 --- /dev/null +++ b/cglibivy.c @@ -0,0 +1,36 @@ +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <getopt.h> +#include <timer.h> +#include <glib.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/callback.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include "ivyglibloop.h" + +value ivy_GtkmainLoop(value unit) +{ + g_main_loop_run(g_main_loop_new(NULL, FALSE)); + return Val_unit; +} + +extern void cb_delete_channel(void *delete_read); +extern void cb_read_channel(Channel ch, HANDLE fd, void *closure); + +value ivy_GtkchannelSetUp(value fd, value closure_name) +{ + Channel c; + value * closure = caml_named_value(String_val(closure_name)); + + c = IvyGlibChannelSetUp((HANDLE)Int_val(fd), (void*)closure, cb_delete_channel, cb_read_channel); + return Val_int(c); +} + +value ivy_GtkchannelClose(value ch) +{ + IvyGlibChannelClose((Channel)Int_val(ch)); + return Val_unit; +} @@ -0,0 +1,90 @@ +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <getopt.h> +#include <ivy.h> +#include <ivyloop.h> +#include <timer.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/callback.h> +#include <caml/memory.h> +#include <caml/alloc.h> + +value ivy_sendMsg(value msg) +{ + IvySendMsg(String_val(msg)); + return Val_unit; +} + +value ivy_stop(value unit) +{ + IvyStop (); + return Val_unit; +} + + +void app_cb(IvyClientPtr app, void *user_data, IvyApplicationEvent event ) +{ + value closure = *(value*)user_data; + callback2(closure, Val_int(app), Val_int(event)); +} + +value ivy_init(value vappName, value vready, value closure_name) +{ + value * closure = caml_named_value(String_val(closure_name)); + char * appName = malloc(strlen(String_val(vappName))+1); /* Memory leak */ + strcpy(appName, String_val(vappName)); + char * ready = malloc(strlen(String_val(vready))+1); /* Memory leak */ + strcpy(ready, String_val(vready)); + IvyInit(appName, ready, app_cb, (void*)closure, 0, 0); /* When the "die callback" is called ??? */ + return Val_unit; +} + +value ivy_start(value bus) +{ + IvyStart(String_val(bus)); + return Val_unit; +} + +void ClosureCallback(IvyClientPtr app, void *closure, int argc, char **argv) +{ + char* t[argc+1]; + int i; + /* Copie de argv dans t avec ajout d'un pointeur nul a la fin */ + for(i=0; i < argc; i++) t[i] = argv[i]; + t[argc] = (char*)0L; + callback2(*(value*)closure, Val_int((int)app), copy_string_array((char const **)t)); +} + +value ivy_bindMsg(value cb_name, value regexp) +{ + value * closure = caml_named_value(String_val(cb_name)); + MsgRcvPtr id = IvyBindMsg(ClosureCallback, (void*)closure, String_val(regexp)); + return Val_int((int)id); +} + +value ivy_unbindMsg(value id) +{ + IvyUnbindMsg((MsgRcvPtr)Int_val(id)); + return Val_unit; +} + +value ivy_name_of_client(value c) +{ + return copy_string(IvyGetApplicationName((IvyClientPtr)Int_val(c))); +} +value ivy_host_of_client(value c) +{ + return copy_string(IvyGetApplicationHost((IvyClientPtr)Int_val(c))); +} + +void cb_delete_channel(void *delete_read) +{ +} + + +void cb_read_channel(Channel ch, HANDLE fd, void *closure) +{ + callback(*(value*)closure, Val_int(ch)); +} diff --git a/civyloop.c b/civyloop.c new file mode 100644 index 0000000..0414654 --- /dev/null +++ b/civyloop.c @@ -0,0 +1,60 @@ +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <getopt.h> +#include <ivy.h> +#include <ivyloop.h> +#include <timer.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/callback.h> +#include <caml/memory.h> +#include <caml/alloc.h> + +value ivy_mainLoop(value unit) +{ + IvyMainLoop (0); + return Val_unit; +} + +void timer_cb(TimerId id, void *data, unsigned long delta) +{ + value closure = *(value*)data; + callback(closure, Val_int((int) id)); +} + +value ivy_timerRepeatafter(value nb_ticks,value delay, value closure_name) +{ + value * closure = caml_named_value(String_val(closure_name)); + TimerId id = TimerRepeatAfter(Int_val(nb_ticks), Int_val(delay), timer_cb, (void*)closure); + return Val_int(id); +} + +/* Data associated to Channel callbacks is the couple of delete and +read closures */ + +void cb_delete_channel(void *delete_read); +void cb_read_channel(Channel ch, HANDLE fd, void *closure); + + +value ivy_channelSetUp(value fd, value closure_name) +{ + Channel c; + value * closure = caml_named_value(String_val(closure_name)); + + c = IvyChannelSetUp((HANDLE)Int_val(fd), (void*)closure, cb_delete_channel, cb_read_channel); + return Val_int(c); +} + +value ivy_timerRemove(value t) +{ + TimerRemove((TimerId)Int_val(t)); + return Val_unit; +} + + +value ivy_channelClose(value ch) +{ + IvyChannelClose((Channel)Int_val(ch)); + return Val_unit; +} diff --git a/ctkivy.c b/ctkivy.c new file mode 100644 index 0000000..ae31560 --- /dev/null +++ b/ctkivy.c @@ -0,0 +1,36 @@ +#include <stdlib.h> +#include <string.h> +#include <stdio.h> +#include <getopt.h> +#include <timer.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/callback.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include "ivytcl.h" + +extern void cb_delete_channel(void *delete_read); +extern void cb_read_channel(Channel ch, HANDLE fd, void *closure); + +value ivy_TclmainLoop(value unit) +{ + Tk_MainLoop(); + return Val_unit; +} + + +value ivy_TclchannelSetUp(value fd, value closure_name) +{ + Channel c; + value * closure = caml_named_value(String_val(closure_name)); + + c = IvyTclChannelSetUp((HANDLE)Int_val(fd), (void*)closure, cb_delete_channel, cb_read_channel); + return Val_int(c); +} + +value ivy_TclchannelClose(value ch) +{ + IvyTclChannelClose((Channel)Int_val(ch)); + return Val_unit; +} diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..25f9d91 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +ivy-ocaml (1.0-1) unstable; urgency=low + + * Initial Release. + + -- Pascal Brisset (Hecto) <pascal.brisset@enac.fr> Thu, 7 Oct 2004 13:40:54 +0200 + diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..d1cbb70 --- /dev/null +++ b/debian/control @@ -0,0 +1,13 @@ +Source: ivy-ocaml +Section: net +Priority: optional +Maintainer: Pascal Brisset (Hecto) <pascal.brisset@enac.fr> +Build-Depends: debhelper (>= 4.0.0) +Standards-Version: 3.6.1 + +Package: ivy-ocaml +Architecture: any +Depends: ${shlibs:Depends}, ${misc:Depends} ocaml-nox (= 3.08.2-1), ivy-c +Description: Ocaml binding for the Ivy software bus + This package provides the bindings for the Ivy software bus. Standalone + linking and with the glib mainloop are provided. diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..6a369dc --- /dev/null +++ b/debian/rules @@ -0,0 +1,98 @@ +#!/usr/bin/make -f +# -*- makefile -*- +# Sample debian/rules that uses debhelper. +# This file was originally written by Joey Hess and Craig Small. +# As a special exception, when this file is copied by dh-make into a +# dh-make output file, you may use that output file without restriction. +# This special exception was added by Craig Small in version 0.37 of dh-make. + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + + + + +CFLAGS = -Wall -g + +ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS))) + CFLAGS += -O0 +else + CFLAGS += -O2 +endif + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + + # Add here commands to compile the package. + $(MAKE) + #docbook-to-man debian/ivy-ocaml.sgml > ivy-ocaml.1 + + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + + # Add here commands to clean up after the build process. + -$(MAKE) clean + + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs + + # Add here commands to install the package into debian/ivy-ocaml. + $(MAKE) install DESTDIR=$(CURDIR)/debian/ivy-ocaml + + +# Build architecture-independent files here. +binary-indep: build install +# We have nothing to do by default. + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot + dh_installchangelogs + dh_installdocs examples + dh_installexamples +# dh_install +# dh_installmenu +# dh_installdebconf +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installinfo + dh_installman + dh_link + dh_strip + dh_compress + dh_fixperms +# dh_perl +# dh_python +# dh_makeshlibs + dh_installdeb + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 index 0000000..fe4cb48 --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,27 @@ +# $Id$ + +OCAMLC = ocamlc -I .. +OCAMLMLI = ocamlc -I .. +OCAMLOPT = ocamlopt +OCAMLDEP=ocamldep + +ivyprobe.out : ivyprobe.cmo ivyivyprobe.cmo + $(OCAMLC) -custom -o $@ unix.cma ivy-ocaml.cma $^ + +glibivyprobe.out : ivyprobe.cmo glibivyprobe.cmo + $(OCAMLC) -custom -o $@ unix.cma glibivy-ocaml.cma $^ + +#tkivyprobe.out : ivyprobe.cmo tkivyprobe.cmo +# $(OCAMLC) -custom -o $@ unix.cma -I +labltk labltk.cma -I . $^ +#tkivyprobe.cmo : OCAMLFLAGS=-I +labltk + +%.cmo : %.ml + $(OCAMLC) -c $< + +clean: + \rm -f *.cm* *.o *.a .depend *~ *.out *.opt .depend *.so + +.depend: + $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend + +include .depend diff --git a/examples/glibivyprobe.ml b/examples/glibivyprobe.ml new file mode 100644 index 0000000..fb7e1f3 --- /dev/null +++ b/examples/glibivyprobe.ml @@ -0,0 +1,9 @@ +(* $Id$ *) + +let _ = + Ivyprobe.init (); + try + ignore (GlibIvy.set_up_channel Unix.stdin Ivy.stop (fun _ -> Ivyprobe.read stdin)); + GlibIvy.main () + with + End_of_file -> Ivy.stop () diff --git a/examples/ivyivyprobe.ml b/examples/ivyivyprobe.ml new file mode 100644 index 0000000..b51a708 --- /dev/null +++ b/examples/ivyivyprobe.ml @@ -0,0 +1,8 @@ +let _ = + Ivyprobe.init (); + try + ignore (IvyLoop.set_up_channel Unix.stdin Ivy.stop (fun _ -> Ivyprobe.read stdin)); + IvyLoop.main () + with + End_of_file -> Ivy.stop () + diff --git a/examples/ivyprobe.ml b/examples/ivyprobe.ml new file mode 100644 index 0000000..47bd2aa --- /dev/null +++ b/examples/ivyprobe.ml @@ -0,0 +1,40 @@ +(* $Id$ *) + +let print_message app message = + Printf.printf "%s sent" (Ivy.name_of_client app); + Array.iter (fun s -> Printf.printf " '%s'" s) message; + print_newline () + +let read = fun channel -> + let l = input_line channel in + Ivy.send l + +let watch_clients c e = + let dis = match e with Ivy.Connected -> "" | Ivy.Disconnected -> "dis" in + Printf.printf "%s %sconnected from %s\n" + (Ivy.name_of_client c) + dis + (Ivy.host_of_client c); + flush stdout + +let init = fun () -> + let regexp = ref "" + and name = ref "MLIVYPROBE" + and port = ref 2010 + and domain = ref "127.255.255.255" in + Arg.parse + [ "-b", Arg.Int (fun x -> port := x), "<Port number>\tDefault is 2010, unused if IVYBUS is set"; + "-domain", Arg.String (fun x -> domain := x), "<Network address>\tDefault is 127.255.255.255, unused if IVYBUS is set"; + "-n", Arg.String (fun s -> name := s), "<Name of the prober>\tDefault is MLIVYPROBE"] + (fun s -> regexp := s) + "Usage: "; + + let bus = + try Sys.getenv "IVYBUS" with + Not_found -> Printf.sprintf "%s:%d" !domain !port in + Ivy.init !name "READY" watch_clients; + Ivy.start bus; + + Printf.printf "\nEnd of file to stop\n\n"; flush stdout; + + ignore (Ivy.bind print_message !regexp) diff --git a/examples/tkivyprobe.ml b/examples/tkivyprobe.ml new file mode 100644 index 0000000..67ee3aa --- /dev/null +++ b/examples/tkivyprobe.ml @@ -0,0 +1,10 @@ +let _ = + Ivyprobe.init (); + let top = Tk.openTk () in + try + ignore (TkIvy.set_up_channel Unix.stdin Ivy.stop (fun _ -> Ivyprobe.read stdin)); + TkIvy.main () + with + End_of_file -> Ivy.stop () + + diff --git a/glibIvy.ml b/glibIvy.ml new file mode 100644 index 0000000..17919c5 --- /dev/null +++ b/glibIvy.ml @@ -0,0 +1,8 @@ + +type channel +external main : unit -> unit = "ivy_GtkmainLoop" +external ext_channelSetUp : Unix.file_descr -> string -> channel = "ivy_GtkchannelSetUp" +let set_up_channel fd delete read = + ext_channelSetUp fd (Ivy.cb_register read) +external close_channel : channel -> unit = "ivy_GtkchannelClose" + diff --git a/glibIvy.mli b/glibIvy.mli new file mode 100644 index 0000000..3df31b6 --- /dev/null +++ b/glibIvy.mli @@ -0,0 +1,13 @@ +val main : unit -> unit +(** Glib main loop *) + +type channel +(** Channel handled by the main loop *) + +val set_up_channel : Unix.file_descr -> (unit -> unit) -> (channel -> unit) -> channel +(** [set_up_channel fd delete read] gives the opportunity to the main loop +to call [read] when data is available on [fd] and [delete] when [fd] is +closed *) + +val close_channel : channel -> unit +(** Stops the handling of a channel by the main loop *) @@ -0,0 +1,81 @@ +(* $Id$ *) + + +type binding +type client +type client_event = Connected | Disconnected +type cb = client -> string array -> unit +type client_cb = client -> client_event -> unit + +external send : string -> unit = "ivy_sendMsg" +external stop : unit -> unit = "ivy_stop" +external ext_init : string -> string -> string -> unit = "ivy_init" + + +let gensym = let n = ref 0 in fun p -> incr n; p ^ string_of_int !n +let cb_register = fun closure -> + let s = gensym "callback_" in + Callback.register s closure; + s + +let init = fun name ready ccb -> + ext_init name ready (cb_register ccb) + + +external start : string -> unit = "ivy_start" +external ext_bind : string -> string -> binding = "ivy_bindMsg" + +let bind = fun (cb:cb) regexp -> + ext_bind (cb_register cb) regexp + +external unbind : binding -> unit = "ivy_unbindMsg" + + +external name_of_client : client -> string = "ivy_name_of_client" +external host_of_client : client -> string = "ivy_host_of_client" + + + +let marshal_tag = "MARSHAL" + +let hexa_char = fun c -> + assert(0 <= c && c < 16); + if c < 10 then + Char.chr (c + Char.code '0') + else + Char.chr (c + Char.code 'A' - 10) + +let hexa_code = fun c -> + if '0' <= c && c <= '9' then + Char.code c - Char.code '0' + else if 'A' <= c && c <= 'F' then + Char.code c - Char.code 'A' + 10 + else failwith (Printf.sprintf "hexa_code: %c" c) + + +let hexa_of_string = fun s -> + let n = String.length s in + let h = String.create (n*2) in + for i = 0 to n - 1 do + let c = Char.code s.[i] in + h.[2*i] <- hexa_char (c lsr 4); + h.[2*i+1] <- hexa_char (c land 0xf) + done; + h + +let string_of_hexa = fun h -> + let n = String.length h / 2 in + let s = String.create n in + for i = 0 to n - 1 do + s.[i] <- Char.chr (hexa_code h.[2*i] lsl 4 + hexa_code h.[2*i+1]) + done; + s + + +let send_data = fun tag value -> + let s = hexa_of_string (Marshal.to_string value []) in + send (Printf.sprintf "%s %s %s" marshal_tag tag s) + +let data_bind = fun cb tag -> + let r = Printf.sprintf "%s %s (.*)" marshal_tag tag in + bind (fun c a -> cb c (Marshal.from_string (string_of_hexa a.(0)) 0)) r @@ -0,0 +1,57 @@ +(** $Id$ *) + +(** Interface for ivy-c (http://www.tls.cena.fr/products/ivy/) *) + +type binding +(** Identification of bindings (callback/message) *) + +type client +(** Identification of client applications *) + +val name_of_client : client -> string +val host_of_client : client -> string +(** Access to client identification *) + +type client_event = Connected | Disconnected +(** Status of (de)connecting applications *) + +type cb = client -> string array -> unit +(** Profile of message binding callback *) + +type client_cb = client -> client_event -> unit +(** Profile of callback for (de)connecting applications *) + +val init : string -> string -> client_cb -> unit +(** [init name ready cb] initializes the application as an IVY client, +identifying itself with [name], first sending the [ready] message. [cb] +will be called each time a new application (de)connects to this IVY bus. *) + +val start : string -> unit +(** [start bus] starts the connection to machine/network/port specified in +[bus]. Syntax for [bus] is ["IPaddress:port"] *) + +val bind : cb -> string -> binding +(** [bind cb regexp] binds callback [cb] to messages matching the [regexp] +regular expression. [cb] will be called with the array of matching groups +defined in [regexp]. *) + +val send : string -> unit +(** [send message] sends a message to the IVY initialized bus *) + +val stop : unit -> unit +(** Exits the main loop *) + +val unbind : binding -> unit +(** Removes a message binding *) + +val send_data : string -> 'a -> unit +(** [send_data tag value] marshals [value] into a string and sends it with +[tag] over the IVY bus *) + +val data_bind : (client -> 'a -> unit) -> string -> binding +(** [data_bind cb tag] binds [cb] to IVY messages sent with [send_data] and +tagged with [tag]. This operation IS NOT type safe.*) + +(***) + +val cb_register : ('a -> 'b) -> string diff --git a/ivyLoop.ml b/ivyLoop.ml new file mode 100644 index 0000000..5808de4 --- /dev/null +++ b/ivyLoop.ml @@ -0,0 +1,22 @@ +type channel +type delete_channel_cb = unit -> unit +type timer +type timer_cb = timer -> unit + +external ext_timer : int -> int -> string -> timer = "ivy_timerRepeatafter" + +let timer = fun n t cb -> + let closure_name = Ivy.cb_register cb in + ext_timer n t closure_name + +external remove_timer : timer -> unit = "ivy_timerRemove" + +external main : unit -> unit = "ivy_mainLoop" + +external ext_channelSetUp : Unix.file_descr -> string -> channel = "ivy_channelSetUp" +external close_channel : channel -> unit = "ivy_channelClose" + + +type read_channel_cb = channel -> unit +let set_up_channel fd delete read = + ext_channelSetUp fd (Ivy.cb_register read) diff --git a/ivyLoop.mli b/ivyLoop.mli new file mode 100644 index 0000000..5c84843 --- /dev/null +++ b/ivyLoop.mli @@ -0,0 +1,25 @@ +val main : unit -> unit +(** Starts the loop which handles asynchronous communications. The standard +version does not return until IVY is explictly stopped *) + +type channel +(** Channel handled by the main loop *) + +val set_up_channel : Unix.file_descr -> (unit -> unit) -> (channel -> unit) -> channel +(** [set_up_channel fd delete read] gives the opportunity to the main loop +to call [read] when data is available on [fd] and [delete] when [fd] is +closed *) + +val close_channel : channel -> unit +(** Stops the handling of a channel by the main loop *) + +type timer +(** Timer identifier *) + +val timer : int -> int -> (timer -> unit) -> timer +(** [timer n ms cb] sets a timer which will call [n] times the callback [cb] +with a period of [ms] milliseconds *) + +val remove_timer : timer -> unit +(** [remove_timer t] stops the timer [t] *) + diff --git a/tkIvy.ml b/tkIvy.ml new file mode 100644 index 0000000..907baa9 --- /dev/null +++ b/tkIvy.ml @@ -0,0 +1,8 @@ + +type channel +external main : unit -> unit = "ivy_TclmainLoop" +external ext_channelSetUp : Unix.file_descr -> string -> channel = "ivy_TclchannelSetUp" +let set_up_channel fd delete read = + ext_channelSetUp fd (Ivy.cb_register read) +external close_channel : channel -> unit = "ivy_TclchannelClose" + diff --git a/tkIvy.mli b/tkIvy.mli new file mode 100644 index 0000000..9d56a4d --- /dev/null +++ b/tkIvy.mli @@ -0,0 +1,13 @@ +val main : unit -> unit +(** Tk main loop *) + +type channel +(** Channel handled by the main loop *) + +val set_up_channel : Unix.file_descr -> (unit -> unit) -> (channel -> unit) -> channel +(** [set_up_channel fd delete read] gives the opportunity to the main loop +to call [read] when data is available on [fd] and [delete] when [fd] is +closed *) + +val close_channel : channel -> unit +(** Stops the handling of a channel by the main loop *) |