(*********************************************************************************) |
(* Cameleon *)
(* *)
(* Copyright (C) 2004-2009 Institut National de Recherche en Informatique *)
(* et en Automatique. All rights reserved. *)
(* *)
(* This program is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU Library General Public License as *)
(* published by the Free Software Foundation; either version 2 of the *)
(* License, or any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU Library General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Library General Public *)
(* License along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA *)
(* 02111-1307 USA *)
(* *)
(* Contact: Maxence.Guesdon@inria.fr *)
(* *)
(*********************************************************************************) |
type multiclip = {
abst_len : int ;
elts : (string, string) Hashtbl.t ;
}
let default_abst_len = 80;;
let create_multiclip ?(abst_len=default_abst_len) () =
{ abst_len = abst_len ;
elts = Hashtbl.create 111 ;
}
;;
(*c==v=[String.chop_n_char]=1.0====*)
let chop_n_char n s =
let len = String.length s in
if len <= n +1 or n < 0 then
s
else
Printf.sprintf "%s..." (String.sub s 0 (n+1))
(*/c==v=[String.chop_n_char]=1.0====*)
let find_free_abstract t prefix =
let rec iter n =
let s = Printf.sprintf "%s%s"
prefix
(if n = 0 then "" else Printf.sprintf "#%d" n)
in
match
try ignore(Hashtbl.find t.elts s); None
with Not_found -> Some s
with
Some s -> s
| None -> iter (n + 1)
in
iter 0
;;
(*c==v=[String.split_string]=1.1====*)
let split_string ?(keep_empty=false) s chars =
let len = String.length s in
let rec iter acc pos =
if pos >= len then
match acc with
"" -> []
| _ -> [acc]
else
if List.mem s.[pos] chars then
match acc with
"" ->
if keep_empty then
"" :: iter "" (pos + 1)
else
iter "" (pos + 1)
| _ -> acc :: (iter "" (pos + 1))
else
iter (Printf.sprintf "%s%c" acc s.[pos]) (pos + 1)
in
iter "" 0
(*/c==v=[String.split_string]=1.1====*)
let replace_blanks s =
let l = split_string s ['\n';'\r';'\t';' '] in
String.concat " " l
;;
let add t ?abs contents =
let abstract =
match abs with
None ->
let prefix = replace_blanks (chop_n_char t.abst_len contents) in
find_free_abstract t prefix
| Some s -> replace_blanks s
in
Hashtbl.replace t.elts abstract contents
;;
let elements t = Hashtbl.fold (fun abstract elt acc -> (abstract, elt) :: acc) t.elts [] ;;
let remove t abstract = Hashtbl.remove t.elts abstract ;;
type storable_multiclip =
{ mutable clip : multiclip ;
file : string ;
op_group : Config_file.group ;
op_abst_len : Config_file.int_cp ;
op_elts : (string * string) Config_file.list_cp ;
}
let create_storable_multiclip ?(abst_len=default_abst_len) file =
let group = new Config_file.group in
let op_elts = new Config_file.list_cp
(Config_file.tuple2_wrappers
Config_file.string_wrappers
Config_file.string_wrappers)
["elements"]
~group
[]
""
in
let op_abst_len = new Config_file.int_cp ~group ["abstract_length"] abst_len "" in
let clip = create_multiclip ~abst_len () in
{ clip = clip ;
file = file ;
op_group = group ;
op_abst_len = op_abst_len ;
op_elts = op_elts ;
}
let read_multiclip t =
t.op_group#read t.file;
let clip = create_multiclip ~abst_len: t.op_abst_len#get () in
List.iter
(fun (abs, contents) -> add clip ~abs contents)
t.op_elts#get;
t.clip <- clip
;;
let write_multiclip t =
t.op_elts#set (elements t.clip);
t.op_abst_len#set t.clip.abst_len ;
t.op_group#write t.file
;;
let storable_get_multiclip t = t.clip;;
let storable_get_file t = t.file;;