l4/pkg/ocaml/contrib/otherlibs/labltk/examples_camltk/fileopen.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 open Camltk;;
  17
  18 let win = opentk();;
  19
  20 let cvs = Canvas.create win [];;
  21
  22 let t = Label.create cvs [Text "File name"];;
  23
  24 let b =
  25   Button.create cvs
  26     [Text "Save";
  27      Command
  28        (function _ ->
  29          let s =
  30            getSaveFile
  31              [Title "SAVE FILE TEST";
  32               DefaultExtension ".foo";
  33               FileTypes [ { typename= "just test";
  34                             extensions= [".foo"; ".test"];
  35                             mactypes= ["FOOO"; "BARR"] } ];
  36               InitialDir Filename.temp_dir_name;
  37               InitialFile "hogehoge" ] in
  38          Label.configure t [Text s])];;
  39
  40 let bb =
  41   Button.create cvs
  42     [Text "Open";
  43      Command
  44        (function _ ->
  45           let s = getOpenFile [] in
  46           Label.configure t [Text s])];;
  47
  48 let q =
  49   Button.create cvs
  50     [Text "Quit";
  51      Command
  52        (function _ -> closeTk (); exit 0)];;
  53
  54 pack [cvs; q;  bb; b; t] [];;
  55
  56 mainLoop ();;