(*
* <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_serialize.ml,v 3.1 2005-06-11 14:24:14 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
(* Serialization format (NEW since WDialog 2.1):
*
* Strings:
* S(<length>)<string>
* Enums:
* E(<size>)<items as strings>
* Dyn enums:
* Y(<size>)<list of internal and external items as strings>
* Alists:
* A(<size>)<list of key as string and value>
* Lists in general:
* L(<arity>,<size>)<list of tuples>
* Dialogs:
* - As definition:
* D() for non-existent dialog
* D(<id>)
* <dialog_name as string>
* (from here on serialization is done in dlg#serialize)
* <page_name as string>
* <next_page as string>
* <last_event, see below>
* <IP address, as string>
* <variables as Alist>
* <ui_buttons as string> (serialized interactor)
* <ui_imagebuttons as string> (serialized interactor)
* <ui_anchors as string> (serialized interactor)
* <ui_indexed_buttons as string> (serialized interactor)
* <ui_indexed_imagebuttons as string> (serialized interactor)
* <ui_indexed_anchors as string> (serialized interactor)
* <ui_vars as string> (serialized interactor)
* <ui_enumvars as string> (an L(3,<size>) list)
* <ui_uploads as string> (serialized interactor)
* - As reference:
* R(<id>)
* Interactors:
* I(<length>)<length bytes, private format, see Wd_interactor>
* Events:
* V(b)<name as string> - Button
* V(ib)<name as string><x as string><y as string> - Image_button
* V(xb)<name as string><index as string> - Indexed_button
* V(xib)<name as string><index as string><x as string><y as string>
* - Indexed_image_button
* V(n) - No_event
* V(p)<name as string> - Popup_request
* Missing value:
* 0
*)
let rec serialize_value m b v =
(* Serializes [v] and adds the string representation to [b].
* m is a hashtable of the objects that have already been serialized.
*)
match v with
| String_value s ->
serialize_string b s
| Enum_value e ->
Buffer.add_string b "E(";
Buffer.add_string b (string_of_int (List.length e));
Buffer.add_string b ")";
List.iter (serialize_string b) e
| Dyn_enum_value d ->
Buffer.add_string b "Y(";
Buffer.add_string b (string_of_int (List.length d));
Buffer.add_string b ")";
List.iter (fun (i,x) -> serialize_string b i; serialize_string b x) d
| Alist_value a ->
serialize_alist m b a
| Dialog_value None ->
Buffer.add_string b "D()";
| Dialog_value (Some dlg) ->
if Hashtbl.mem m dlg then (
Buffer.add_string b "R(";
Buffer.add_string b (string_of_int (Oo.id dlg));
Buffer.add_string b ")";
)
else (
Hashtbl.add m dlg ();
Buffer.add_string b "D(";
Buffer.add_string b (string_of_int (Oo.id dlg));
Buffer.add_string b ")";
serialize_string b dlg#name;
dlg # serialize m b
)
and serialize_string b s =
Buffer.add_string b "S(";
Buffer.add_string b (string_of_int (String.length s));
Buffer.add_string b ")";
Buffer.add_string b s;
and serialize_alist m b a =
Buffer.add_string b "A(";
Buffer.add_string b (string_of_int (List.length a));
Buffer.add_string b ")";
List.iter
(fun (k,v) ->
serialize_string b k;
serialize_value m b v
)
a
;;
let serialize_string_option b s_opt =
match s_opt with
| None -> Buffer.add_string b "0"
| Some s -> serialize_string b s
;;
let serialize_unit b () =
Buffer.add_string b "0"
;;
let serialize_event b e =
match e with
| Button n ->
Buffer.add_string b "V(b)";
serialize_string b n
| Image_button (n,x,y) ->
Buffer.add_string b "V(ib)";
serialize_string b n;
serialize_string b (string_of_int x);
serialize_string b (string_of_int y);
| Indexed_button (n,idx) ->
Buffer.add_string b "V(xb)";
serialize_string b n;
serialize_string b idx;
| Indexed_image_button (n,idx,x,y) ->
Buffer.add_string b "V(xib)";
serialize_string b n;
serialize_string b idx;
serialize_string b (string_of_int x);
serialize_string b (string_of_int y);
| No_event ->
Buffer.add_string b "V(n)";
| Popup_request n ->
Buffer.add_string b "V(p)";
serialize_string b n;
;;
type ds_token =
| S_tok of int
| E_tok of int
| Y_tok of int
| A_tok of int
| L_tok of int * int
| D_tok of int option
| R_tok of int
| I_tok of int
| V_tok of string
| T_tok of int * int * int * int
| Null_tok
;;
let int2_re = Netstring_pcre.regexp "^([0-9]+),([0-9]+)$"
let int4_re = Netstring_pcre.regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"
let ds_scan_token buf =
let advance() =
if buf.ds_pos < buf.ds_end then
buf.ds_pos <- buf.ds_pos + 1
else
failwith "ds_scan_token 1"
in
let token_arg() =
let p = ref buf.ds_pos in
if buf.ds_str.[ !p ] <> '(' then failwith "ds_scan_token 2";
incr p;
while !p < buf.ds_end && buf.ds_str.[ !p ] <> ')' do
incr p
done;
if !p >= buf.ds_end then failwith "ds_scan_token 3";
let s = String.sub buf.ds_str (buf.ds_pos + 1) (!p - buf.ds_pos - 1) in
buf.ds_pos <- !p+1;
s
in
let int_token_arg() =
let s = token_arg() in
let n =
try int_of_string s
with _ -> failwith "ds_scan_token 4"
in
n
in
let nat_token_arg() =
let n = int_token_arg() in
if n < 0 then failwith "ds_scan_token 5";
n
in
let int_opt_token_arg() =
let s = token_arg() in
if s = "" then
None
else
try Some(int_of_string s)
with _ -> failwith "ds_scan_token 6"
in
let nat2_token_arg() =
let s = token_arg() in
match Netstring_pcre.string_match int2_re s 0 with
| Some m ->
let s1 = Netstring_pcre.matched_group m 1 s in
let s2 = Netstring_pcre.matched_group m 2 s in
( try
let n1 = int_of_string s1 in
let n2 = int_of_string s2 in
if n1 < 0 || n2 < 0 then failwith "ds_scan_token 7";
(n1,n2)
with
_ -> failwith "ds_scan_token 8"
)
| None ->
failwith "ds_scan_token 9"
in
let nat4_token_arg() =
let s = token_arg() in
match Netstring_pcre.string_match int4_re s 0 with
| Some m ->
let s1 = Netstring_pcre.matched_group m 1 s in
let s2 = Netstring_pcre.matched_group m 2 s in
let s3 = Netstring_pcre.matched_group m 3 s in
let s4 = Netstring_pcre.matched_group m 4 s in
( try
let n1 = int_of_string s1 in
let n2 = int_of_string s2 in
let n3 = int_of_string s3 in
let n4 = int_of_string s4 in
if n1 < 0 || n2 < 0 || n3 < 0 || n4 < 0 then failwith "ds_scan_token 10";
(n1,n2,n3,n4)
with
_ -> failwith "ds_scan_token 11"
)
| None ->
failwith "ds_scan_token 12"
in
match buf.ds_str.[ buf.ds_pos ] with
| 'S' -> advance(); let n = nat_token_arg() in S_tok n
| 'E' -> advance(); let n = nat_token_arg() in E_tok n
| 'Y' -> advance(); let n = nat_token_arg() in Y_tok n
| 'A' -> advance(); let n = nat_token_arg() in A_tok n
| 'L' -> advance(); let n1,n2 = nat2_token_arg() in L_tok(n1,n2)
| 'D' -> advance(); let n_opt = int_opt_token_arg() in D_tok n_opt
| 'R' -> advance(); let n = int_token_arg() in R_tok n
| 'I' -> advance(); let n = nat_token_arg() in I_tok n
| 'V' -> advance(); let s = token_arg() in V_tok s
| 'T' -> advance(); let n1,n2,n3,n4 = nat4_token_arg() in T_tok(n1,n2,n3,n4)
| '0' -> advance(); Null_tok
| _ ->
failwith "ds_scan_token 13"
;;
let ds_string tok buf =
match tok with
| S_tok n ->
if buf.ds_pos + n > buf.ds_end then failwith "ds_scan_token";
let s = String.sub buf.ds_str buf.ds_pos n in
buf.ds_pos <- buf.ds_pos + n;
s
| _ ->
failwith "ds_string"
;;
let unserialize_string buf =
let tok = ds_scan_token buf in
ds_string tok buf
;;
let rec ds_make_list n f =
if n > 0 then
let x = f() in
x :: (ds_make_list (n-1) f)
else
[]
;;
let rec unserialize_value buf =
let tok = ds_scan_token buf in
match tok with
| S_tok n -> String_value (ds_string tok buf)
| E_tok n -> Enum_value (ds_make_list n (fun () -> unserialize_string buf))
| Y_tok n -> Dyn_enum_value (ds_make_list n (fun () ->
let x1 = unserialize_string buf in
let x2 = unserialize_string buf in
(x1,x2)))
| A_tok n -> Alist_value (ds_alist tok buf)
| D_tok n_opt ->
( match n_opt with
| None ->
Dialog_value None
| Some n ->
let name = unserialize_string buf in
let dlg =
try buf.ds_universe # create buf.ds_environment name
with Not_found -> failwith "unserialize_value" in
Hashtbl.add buf.ds_dialogs n dlg;
dlg # unserialize buf;
Dialog_value(Some dlg)
)
| R_tok n ->
( try
let dlg = Hashtbl.find buf.ds_dialogs n in
Dialog_value (Some dlg)
with
Not_found -> failwith "unserialize_value"
)
| _ ->
failwith "unserialize_value"
and ds_alist tok buf =
match tok with
| A_tok n ->
ds_make_list n (fun () ->
let k = unserialize_string buf in
let v = unserialize_value buf in
(k,v))
| _ ->
failwith "ds_alist"
;;
let unserialize_alist buf =
let tok = ds_scan_token buf in
ds_alist tok buf
;;
let unserialize_event buf =
let tok = ds_scan_token buf in
match tok with
| V_tok "b" ->
Button (unserialize_string buf)
| V_tok "ib" ->
let name = unserialize_string buf in
let x = unserialize_string buf in
let y = unserialize_string buf in
( try Image_button(name,int_of_string x,int_of_string y)
with _ -> failwith "unserialize_event"
)
| V_tok "xb" ->
let name = unserialize_string buf in
let index = unserialize_string buf in
Indexed_button(name,index)
| V_tok "xib" ->
let name = unserialize_string buf in
let index = unserialize_string buf in
let x = unserialize_string buf in
let y = unserialize_string buf in
( try Indexed_image_button(name,index,int_of_string x,int_of_string y)
with _ -> failwith "unserialize_event"
)
| V_tok "n" ->
No_event
| V_tok "p" ->
Popup_request(unserialize_string buf)
| _ ->
failwith "unserialize_event"
;;
let unserialize_string_option buf =
let tok = ds_scan_token buf in
match tok with
| S_tok n -> Some(ds_string tok buf)
| Null_tok -> None
| _ -> failwith "unserialize_string_option"
;;
let unserialize_unit buf =
let tok = ds_scan_token buf in
match tok with
| Null_tok -> ()
| _ -> failwith "unserialize_unit"
;;
(* Some functions also in Wd_dialog and in Wd_interactor! *)
