(*
* <COPYRIGHT>
* Copyright 2002 Joachim Schrod Network and Publication Consultance GmbH, Gerd Stolpmann
*
* <GPL>
* This file is part of WDialog.
*
* WDialog is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* WDialog 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 General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with WDialog; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
* </>
*)
(* $Id: wd_interactor.ml,v 3.5 2005-06-11 14:24:14 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Wd_serialize
type id = string;;
exception Element_exists of id;;
type 'value_type t =
{ base_id : int;
mutable next_id : int;
mutable entries : (int * string * 'value_type * id) option array;
mutable n_entries : int;
mutable names : string array;
mutable n_names : int;
}
(* "entries": only the positions 0 to n_entries - 1 are used.
* every entry contains a tuple (name_pos, index, value, id)
* where name_pos is the position in the "names" array; "index" is
* the index value or ""; "value" is an arbitrary extra value.
* "names". only the positions 0 to n_names - 1 are used.
* every entry contains a name.
* The reason for the extra "names" array is that it is expected
* that there many entries share the same names. (Storage efficiency.)
*)
let create (dummy : 'value_type) =
( { base_id = int_of_float (mod_float (Unix.time()) 10000.0);
next_id = 0;
entries = [| None |];
n_entries = 0;
names = [| "" |];
n_names = 0;
}
:
'value_type t
)
;;
let clear ia =
ia.entries <- [| None |];
ia.n_entries <- 0;
ia.names <- [| "" |];
ia.n_names <- 0
;;
let find a x =
let l = Array.length a in
let rec dorec i =
if i<l then begin
if a.(i) = x then
i
else
dorec (i+1)
end
else raise Not_found
in
dorec 0
;;
let pfind a p =
let l = Array.length a in
let rec dorec i =
if i<l then begin
if p a.(i) then
i
else
dorec (i+1)
end
else raise Not_found
in
dorec 0
;;
let iter f ia =
let l = Array.length ia.entries in
let rec dorec i =
if i < l then begin
match ia.entries.( i ) with
None ->
()
| Some (name_pos, index, value, id) ->
assert(name_pos >= 0 & name_pos < ia.n_names);
let _ = f id ia.names.(name_pos) index value in
dorec (i+1)
end
in
dorec 0
;;
let add ia name index opt_id value =
(* Check whether 'opt_id' is illegal *)
begin match opt_id with
None -> ()
| Some n ->
if n <> "" & n.[0] >= '0' & n.[0] <= '9' then
raise(Runtime_error("The name of the CGI parameter `" ^ n ^
"' is illegal (it begins with a digit)"));
end;
(* Check whether 'name' is already used. If not create an entry. *)
let name_pos =
try find ia.names name
with
Not_found ->
let l = Array.length ia.names in
if ia.n_names >= l then begin
(* make space *)
let new_l = 2 * l in
let new_names = Array.create new_l "" in
Array.blit ia.names 0 new_names 0 l;
ia.names <- new_names;
end;
ia.names.( ia.n_names ) <- name;
ia.n_names <- ia.n_names + 1;
ia.n_names - 1
in
(* Check whether the combination (name_pos, index) already exists, or
* if the ID is already used
*)
for i = 0 to ia.n_entries - 1 do
match ia.entries.( i ) with
Some (p, ix, _, id) ->
if p = name_pos && ix = index then raise (Element_exists id);
if Some id = opt_id then
raise(Runtime_error("Conflict for CGI parameter `" ^ id ^ "'"));
| None -> ()
done;
(* Add the combination (name_pos, index, value, opt_id): *)
let l = Array.length ia.entries in
if ia.n_entries >= l then begin
(* make space *)
let new_l = 2 * l in
let new_entries = Array.create new_l None in
Array.blit ia.entries 0 new_entries 0 l;
ia.entries <- new_entries;
end;
let id =
match opt_id with
Some x -> x
| None ->
(* Generate a new ID *)
let x = Printf.sprintf "%04d_%d" ia.base_id ia.next_id in
ia.next_id <- ia.next_id + 1;
x
in
ia.entries.(ia.n_entries) <- Some (name_pos, index, value, id);
ia.n_entries <- ia.n_entries + 1;
id
;;
exception Result of bool
let exists ia name index =
try
let name_pos =
try find ia.names name
with
Not_found ->
raise (Result false)
in
(* Check whether the combination (name_pos, index) already exists. *)
for i = 0 to ia.n_entries - 1 do
match ia.entries.( i ) with
Some (p, ix, _, _) ->
if p = name_pos & ix = index then
raise (Result true)
| None -> ()
done;
false
with
Result r -> r
;;
let lookup ia id =
(* Get the position corresponding to 'id': *)
let position =
(* search the entry *)
try
pfind
ia.entries
(function
None -> false
| Some (_, _, _, n) -> n = id)
with
Not_found ->
failwith "Interactor.lookup: ID not found"
in
if position < 0 or position >= ia.n_entries then
failwith "Interactor.lookup: ID not found";
match ia.entries.(position) with
Some (name_pos, index, value, _) ->
assert(name_pos >= 0 & name_pos < ia.n_names);
ia.names.(name_pos), index, value
| None ->
assert false
;;
let serialize f b ia =
(* Format:
* T(<base_id>,<next_id>,<n_entries>,<n_names>)
* <all names as strings>
* <all entries as tuples>
*
* Strings:
* S(<length>)<string value>
*
* Tuples:
* 0 if None
* or
* <name_pos as string><index as string><value encoded by f><id as string>
*)
Buffer.add_string b "T(";
Buffer.add_string b (string_of_int ia.base_id);
Buffer.add_string b ",";
Buffer.add_string b (string_of_int ia.next_id);
Buffer.add_string b ",";
Buffer.add_string b (string_of_int ia.n_entries);
Buffer.add_string b ",";
Buffer.add_string b (string_of_int ia.n_names);
Buffer.add_string b ")";
for k = 0 to ia.n_names - 1 do
serialize_string b ia.names.(k)
done;
for k = 0 to ia.n_entries - 1 do
match ia.entries.(k) with
| Some (name_pos, index, value, id) ->
serialize_string b (string_of_int name_pos);
serialize_string b index;
Buffer.add_string b (f value);
serialize_string b id
| None ->
assert false
done
;;
let unserialize f buf =
let tok = ds_scan_token buf in
match tok with
| T_tok(base_id,next_id,n_entries,n_names) ->
let l = buf.ds_end - buf.ds_pos in
if n_entries > l || n_names > l then failwith "Wd_interactor.unserialize";
let entries = Array.make n_entries None in
let names = Array.make n_names "" in
for k = 0 to n_names - 1 do
names.(k) <- unserialize_string buf
done;
for k = 0 to n_entries - 1 do
let name_pos_str = unserialize_string buf in
let index = unserialize_string buf in
let value = f buf in
let id = unserialize_string buf in
let name_pos =
try int_of_string name_pos_str
with _ -> failwith "Wd_interactor.unserialize" in
if name_pos < 0 || name_pos >= n_names then
failwith "Wd_interactor.unserialize";
entries.(k) <- Some(name_pos, index, value, id);
done;
{ base_id = base_id;
next_id = next_id;
entries = entries;
n_entries = n_entries;
names = names;
n_names = n_names
}
| _ ->
failwith "Wd_interactor.unserialize"
;;
let revision_interactor = "$Revision: 3.5 $" ;;
(* Intentionally the CVS revision string *)
(* ======================================================================
* History:
*
* $Log: wd_interactor.ml,v $
* Revision 3.5 2005-06-11 14:24:14 stolpmann
* Extension of bracket expressions: many new functions.
* Functions in bracket expressions may now lazily evaluate their arguments.
* ui:if and ui:ifvar may refer to any functions defined for bracket
* expressions.
* New: ui:ifexpr
* Parsing of bracket expressions is now done with ulex. Private interfaces
* of PXP are no longer used for this purpose.
* Serialization has been rewritten, and it is now safe.
* Fix: In ui:context there may now be macro references at any location.
* Also documented all these changes.
*
* Revision 3.4 2002/04/10 21:27:52 stolpmann
* New scheme for automatically generated interactor IDs. There
* are now two parts: <base>_<seq> where <base> is the base number
* (currently derived from the system clock), and where <seq> is the
* sequence number. Sequence numbers are no longer reset to 0 after
* "handle". (The reason for the new ID scheme are buggy browsers that
* try to remember old form values. It is now very unlikely that a
* name for a form field is reused before the page expires.)
*
* Revision 3.3 2002/04/10 20:03:15 stolpmann
* The CVS revision number is exported.
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:29:19 stolpmann
* Initial release at sourceforge.
*
* Revision 1.3 2002/01/14 15:03:24 gerd
* Major change: Typing has been completely revised, and almost
* every tiny thing has now a new type. Also renamed a lot.
*
* Revision 1.2 2000/05/08 17:56:22 gerd
* Changed such that arbitrary strings can be used as interactor
* IDs as well as automatically generated numbers.
*
* Revision 1.1 2000/04/13 17:42:57 gerd
* Initial revision.
*
*
*)
