import labltklabltk

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/labltk@2531 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 21 insertions, 0 deletions

diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml
new file mode 100644
index 0000000000..2a8923333a
--- /dev/null
+++ b/otherlibs/labltk/builtin/canvas_bind.ml
@@ -0,0 +1,21 @@
+let bind widget :tag events:eventsequence :action =
+  tkEval [| cCAMLtoTKwidget widget;
+      	    TkToken "bind";
+      	    cCAMLtoTKtagOrId tag;
+       	    cCAMLtoTKeventSequence eventsequence;
+  begin match action with
+     `Remove -> TkToken ""
+  |  `Set (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what))
+  |  `Setbreakable (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("camlcb " ^ cbId ^ (writeeventField what)^
+                " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0"
+                )
+  |  `Extend (what, f) ->
+      let cbId = register_callback widget callback:(wrapeventInfo f what) in
+        TkToken ("+camlcb " ^ cbId ^ (writeeventField what))
+
+  end |];
+  ()