l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/frx/frx_misc.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 (* Delayed global, a.k.a cache&carry *)
  17 let autodef f =
  18   let v = ref None in
  19   (function () ->
  20      match !v with
  21        None ->
  22          let x = f() in
  23            v := Some x;
  24            x
  25      | Some x -> x)
  26
  27 open Camltk
  28
  29 (* allows Data in options *)
  30 let create_photo options =
  31   let hasopt = ref None in
  32   (* Check options *)
  33   List.iter (function
  34       Data s ->
  35         begin match !hasopt with
  36           None -> hasopt := Some (Data s)
  37         | Some _ -> raise (Protocol.TkError "two data sources in options")
  38         end
  39     | File f ->
  40         begin match !hasopt with
  41           None -> hasopt := Some (File f)
  42         | Some _ -> raise (Protocol.TkError "two data sources in options")
  43         end
  44     | o -> ())
  45     options;
  46   match !hasopt with
  47     None -> raise (Protocol.TkError "no data source in options")
  48   | Some (Data s) ->
  49       begin
  50         let tmpfile = Filename.temp_file "img" "" in
  51         let oc = open_out_bin tmpfile in
  52         output_string oc s;
  53         close_out oc;
  54         let newopts =
  55           List.map (function
  56             | Data s -> File tmpfile
  57             | o -> o)
  58             options in
  59         try
  60           let i = Imagephoto.create newopts in
  61           (try Sys.remove tmpfile with Sys_error _ -> ());
  62           i
  63         with
  64           e ->
  65             (try Sys.remove tmpfile with Sys_error _ -> ());
  66             raise e
  67       end
  68   | Some (File s) -> Imagephoto.create options
  69   | _ -> assert false