(*
* <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_transform.ml,v 3.26 2005-08-31 18:08:49 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Pxp_types
open Pxp_document
open Printf
module D = Wd_dictionary
(* Idea:
* 'scan_application': Scans the whole tree and puts the result into the
* passed variable.
* 'scan_dialog': Scans an ui:dialog tree and puts the result into the
* passed variable
*
* The part of the tree from ui:application until ui:dialog is called
* "application tree".
* The part of the tree from ui:dialog until ui:page is called
* "dialog tree".
* The part of the tree below ui:page is called "page tree".
*)
let escape_html = Wd_encoding.encode_as_html ;;
let escape_html_flags = Pcre.rflags [];;
let escape_comment_re = Netstring_pcre.regexp "--\\>";;
let escape_comment s =
Netstring_pcre.global_replace escape_comment_re "==>" s
;;
(*
let buffer_add_escaped buffer s =
(* Same as Buffer.add (escape_html s) - but much faster *)
let l = String.length s in
let rec dorec i =
let i' =
try (Pcre.pcre_exec
~iflags:escape_html_flags ~rex:escape_html_re ~pos:i s).(0)
with Not_found -> l
in
if i' > i then
Buffer.add_substring buffer s i (i' - i);
if i' < l then begin
begin match s.[ i' ] with
'<' -> Buffer.add_string buffer "<"
| '>' -> Buffer.add_string buffer ">"
| '&' -> Buffer.add_string buffer "&"
| '"' -> Buffer.add_string buffer """
| _ -> assert false
end;
if i'+1 < l then
dorec (i' + 1)
end
in
dorec 0
;;
*)
let only_whitespace_re = (Pcre.regexp "^[ \t\r\n]*$");;
let only_whitespace s =
Pcre.pmatch ~rex:only_whitespace_re s
;;
let escape_js = Wd_encoding.encode_as_js_string ;;
let split_re = Pcre.regexp "[ \t\r\n]+";;
let split s = Netstring_pcre.split split_re s;;
let list_mapi f l =
let rec loop k l =
match l with
x :: l' ->
let y = f k x in
y :: loop (k+1) l'
| [] ->
[]
in
loop 0 l
;;
(**********************************************************************)
(*** Syntax Tree ***)
(**********************************************************************)
(*
let init_vars within_popup =
{ within_popup = within_popup;
current_page = "";
popup_env_initialized = false;
condition_code = false;
}
;;
*)
class virtual type_method_to_html =
(* Contains only the type of to_html to simplify the definitions below. *)
object
method virtual to_html :
?context: syntax_tree_type dict ->
?vars: trans_vars ->
dialog_type ->
Netchannels.out_obj_channel ->
unit
end
;;
class virtual type_method_to_text =
(* Contains only the type of to_text to simplify the definitions below. *)
object
method virtual to_text :
?context: syntax_tree_type dict ->
?vars: trans_vars ->
dialog_type ->
Netchannels.out_obj_channel ->
unit
end
;;
class virtual type_method_instantiate =
(* Contains only the type of [instantiate] *)
object
method virtual instantiate :
?context: syntax_tree_type dict ->
?vars: trans_vars ->
?params: syntax_tree_type dict ->
dialog_type ->
syntax_tree_type
end
;;
(* The class "syntax_tree" defines the type and default behaviour for
* all nodes of the XML tree.
* The nodes have the type: syntax_tree node, i.e. syntax_tree has the
* role of the extension class of the XML node class.
*)
class syntax_tree =
object (self)
inherit type_method_to_html
inherit type_method_to_text
inherit type_method_instantiate
(* --- default_ext --- *)
(* The definitions that are necessary such that this class can play
* the role of an extension to XML nodes.
*)
val mutable node = (None : syntax_tree node option)
method clone = {< >}
method node =
match node with
None ->
assert false
| Some n -> n
method set_node n =
node <- Some n
(* --- Here definitions of methods that have only a sensible meaning
* for some of the classes that follow below. The methods
* have the default behaviour to fail; they are overridden in
* classes that want to change that to some "real" action.
*)
method scan_application
(appdecl : application_type) : unit =
failwith "syntax_tree # scan_application"
method scan_dialog (app : application_type) (dlgdecl : dialog_decl_type) : unit =
failwith "syntax_tree # scan_dialog"
method scan_enumeration (enumdecl : enum_decl) : unit =
failwith "syntax_tree # scan_enumeration"
method scan_literal() : var_value =
failwith "syntax_tree # scan_literal"
method instantiate ?context ?vars ?params dialog =
failwith "syntax_tree # instantiate" (* overridden below *)
method study (_:application_type) : unit =
failwith "syntax_tree # study"
(* Advanced data nodes: [See class data_node] *)
method escaped_data : string =
failwith "syntax_tree # escaped_data" (* overridden below *)
method to_html ?context ?vars dlg outch =
failwith "syntax_tree # to_html"
method to_text ?context ?vars dlg outch =
failwith "syntax_tree # to_text"
method private major_version =
int_of_string
(Pxp_dtd.Entity.replacement_text
(self # node # dtd # par_entity "major-version"))
(* The error methods return an exn value, but do not raise the exception.
* This is because methods cannot be polymorphic.
*)
method private formal_user_error msg =
let ent,line,pos = self # node # position in
if line >= 1 then
Formal_user_error("Entity " ^ ent ^ ", line " ^ string_of_int line ^
", position " ^ string_of_int pos ^ ": " ^ msg)
else
Formal_user_error(msg ^
" - Sorry, cannot remember where this error occurs");
method private runtime_error msg =
let ent,line,pos = self # node # position in
if line >= 1 then
Runtime_error("Entity " ^ ent ^ ", line " ^ string_of_int line ^
", position " ^ string_of_int pos ^ ": " ^ msg)
else
Runtime_error(msg ^
" - Sorry, cannot remember where this error occurs");
method private bad_context =
let name =
(match self # node # node_type with
T_element n -> n
| _ -> assert false
)
in
self # formal_user_error ("tried to expand <" ^ name ^ "> in bad context");
end
;;
(* Typing constraints: *)
let _ = lazy (new syntax_tree :> syntax_tree_type) in ();;
let _ = lazy (new syntax_tree :> template_type) in ();;
(**********************************************************************)
(*** Mixin Classes I ***)
(**********************************************************************)
class virtual mixin_skip_output =
object (self)
(* Defines a variant of 'to_html' which does not output any HTML text
* for this node but continues directly with the subnodes.
*)
method to_html ?context ?vars dlg outch =
let n = (self # node : syntax_tree node) in
n # iter_nodes
(fun n' ->
n' # extension # to_html ?context ?vars dlg outch);
method to_text ?context ?vars dlg outch =
let n = (self # node : syntax_tree node) in
n # iter_nodes
(fun n' ->
n' # extension # to_text ?context ?vars dlg outch);
end
;;
class virtual mixin_no_output =
object (self)
inherit type_method_to_html
inherit type_method_to_text
(* Defines a variant of 'to_html' which does not output any HTML text
* for this node nor for any subnode
*)
method to_html ?context ?vars dlg outch = ()
method to_text ?context ?vars dlg outch = ()
end
;;
let empty_elements =
let ht = Hashtbl.create 50 in
List.iter
(fun (name, (_, constr)) ->
if constr = `Empty then
Hashtbl.add ht name ()
)
Nethtml.html40_dtd;
ht
;;
class virtual mixin_output =
object(self)
inherit type_method_to_html
inherit type_method_to_text
val mutable element_name_lc = None
(* The element name in lowercase characters *)
method to_html ?context ?vars dlg outch =
(* to_html: outputs the node and all subnodes as HTML into the 'outch'.
* The other parameters, 'dlg', 'uidecl', 'appdecl', 'context'
* and 'mode' modify the behaviour of various aspects.
* The subnodes are output by recursively invoking 'to_html' on the
* subnodes; many subnode objects redefine 'to_html'.
*)
let n = self # node in
match n # node_type with
T_data ->
outch # output_string (n # extension # escaped_data)
| T_element el ->
(* Note: it is tried to avoid allocating memory - this reduces
* the load on the GC
*)
let out = outch # output_string in
out "<";
out el;
out " ";
List.iter
(fun a ->
match n # attribute a with
Value s ->
out a;
out "=\"";
out (escape_html s); (* OPTIMIZE *)
out "\" ";
| Implied_value ->
()
| _ ->
()
)
(n # attribute_names);
out ">";
(* The following test on empty elements is HTML-4.0-specific: *)
let el_lc =
match element_name_lc with
Some lc -> lc
| None ->
let lc = String.lowercase el in
element_name_lc <- Some lc;
lc
in
if not (Hashtbl.mem empty_elements el_lc) then begin
n # iter_nodes
(fun n' ->
n' # extension # to_html ?context ?vars dlg outch);
out "</";
out el;
out ">";
end
| _ ->
assert false
method to_text ?context ?vars dlg outch =
(* to_text: outputs the node and all subnodes as plain text - this
* method is used if a $-parameter occurs in an attribute to get the
* replacement text.
* The text is written into the 'outch'. The argument 'dlg'
* modifies the behaviour (mostly if there are references to variables).
* The subnodes are output by recursively invoking 'to_text' on the
* subnodes; many subnode objects redefine 'to_text'.
*)
(* ui:* nodes are left out *)
let out = outch # output_string in
let n = self # node in
match n # node_type with
T_data -> out (n # data)
| T_element el ->
(* Note: it is tried to avoid allocating memory - this reduces
* the load on the GC
*)
out "<";
out el;
out " ";
List.iter
(fun a ->
match n # attribute a with
Value s ->
out a;
out "=\"";
out (escape_html s); (* OPTIMIZE *)
out "\" ";
| Implied_value ->
()
| _ ->
()
)
(n # attribute_names);
out ">";
(* The following test on empty elements is HTML-4.0-specific: *)
let el_lc =
match element_name_lc with
Some lc -> lc
| None ->
let lc = String.lowercase el in
element_name_lc <- Some lc;
lc
in
if not (Hashtbl.mem empty_elements el_lc) then begin
n # iter_nodes
(fun n' ->
n' # extension # to_text ?context ?vars dlg outch);
out "</";
out el;
out ">";
end
| _ ->
assert false
end
;;
(**********************************************************************)
(*** General-purpose subclasses ***)
(**********************************************************************)
(* The following classes are modifications of syntax_tree *)
class default_node =
object (self)
inherit syntax_tree
inherit mixin_output
(* 'default_node': defines the behaviour for "neutral nodes". The scan_*
* methods simply forward scanning to the subnodes (this is why this
* class is called 'skip_node').
*)
method scan_application app =
self # node # iter_nodes
(fun n -> n # extension # scan_application app)
method scan_dialog app obj =
self # node # iter_nodes
(fun n -> n # extension # scan_dialog app obj)
method scan_enumeration obj =
self # node # iter_nodes
(fun n -> n # extension # scan_enumeration obj)
end
;;
class data_node =
object (self)
inherit default_node
(* This is the data_node which is used together with character data
* nodes.
* It provides optimized access to HTMLized versions of the data
* string.
*)
val mutable escaped_data = ref None
(* May contain the version of the data string where the characters that
* are special in HTML are converted to their entity representation
* (e.g. "<" becomes "<").
* This slot is intentionally a reference (and not simply "mutable"),
* because it is shared by the clone of a node and this node. This
* means that if one of the clones of a node computes escaped_data,
* all other clones and the original node will also see this.
*)
method set_node n =
(* If this extension node has got a new main node, we must reset
* 'escaped_data'. The criterion is the physical identity of the
* data string.
*)
begin match node with
None ->
escaped_data <- ref None
| Some n' ->
if n' # data != n # data then
escaped_data <- ref None;
end;
node <- Some n;
method escaped_data =
(* Access the data string in its escaped form (HTML special characters
* replaced by the corresponding entity invocations).
*)
match !escaped_data with
Some d -> d (* We already have it *)
| None ->
(* We must compute this string. *)
let d = escape_html (self # node # data) in
escaped_data := Some d;
d
end
;;
class virtual application_tree =
object (self)
inherit syntax_tree
(* "Application tree": The part from ui:application to ui:dialog.
* These nodes are special because they must have the capability
* to collect the occurring templates and ui:dialogs (method
* scan_application).
*)
(* We force that whoever inherits from application_tree must define
* the following method.
*)
method virtual scan_application : application_type -> unit
end
;;
class virtual literal_tree =
object (self)
inherit syntax_tree
(* "Literal tree": These are trees defining values (such as
* ui:string-value). Nodes must be able to return the denoted value
* (method scan_literal).
*)
(* We force that whoever inherits from literal_tree must define
* the following methods.
*)
method virtual scan_literal : unit -> var_value
end
;;
class virtual dialog_tree =
object (self)
inherit syntax_tree
(* "Object tree": The part of the tree below ui:dialog until ui:page.
* These nodes can collect the occurring declarations and pages
* (method scan_dialog).
*)
(* We force that whoever inherits from object_tree must define
* the following methods.
*)
method virtual scan_dialog : application_type -> dialog_decl_type -> unit
end
;;
class virtual page_tree =
object (self)
inherit syntax_tree
inherit mixin_output
(* "Page tree": Everything below ui:page. There are a number of
* special capabilities provided as private methods.
*)
method private get_variable ?(allow_assoc = false) dlg =
let vname = self # node # required_string_attribute "variable" in
let index = self # node # optional_string_attribute "index" in
let is_associative =
try
match dlg # variable vname with
Alist_value _ -> true
| _ -> false
with
Not_found ->
raise (self # runtime_error("Reference to non-existent variable `" ^
vname ^ "'"))
in
if is_associative then begin
if index = None && not allow_assoc then
raise (self # runtime_error("Variable `" ^ vname ^
"' is associative but used in a non-associative way (index attribute missing)"))
end
else
if index <> None then
raise(self # runtime_error("Variable `" ^ vname ^
"' is plain but used as associative variable (extra index attribute)"));
vname,index
method private get_assoc_variable dlg =
let vname = self # node # required_string_attribute "variable" in
let index = self # node # optional_string_attribute "index" in
let is_associative =
try
match dlg # variable vname with
Alist_value _ -> true
| _ -> false
with
Not_found ->
raise(self # runtime_error("Reference to non-existent variable `" ^
vname ^ "'"))
in
if not is_associative then begin
if index <> None then
raise(self # runtime_error("Variable `" ^ vname ^
"' is plain but used as associative variable (extra index attribute)"));
end;
is_associative & index = None, vname, index
method private allocate_variable dlg =
let vname, index = self # get_variable dlg in
let ui = dlg # interactors in
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some vname
| _ -> assert false
in
match index with
None ->
begin
try Wd_interactor.add ui.ui_vars vname "" cgi_id (), vname, None
with
Wd_interactor.Element_exists id ->
id, vname, None
end
| Some x ->
begin
if cgi_id <> None then
raise(self # runtime_error("Variable `" ^ vname ^ "': cgi='keep' incompatible with presence of 'index' attribute"));
try Wd_interactor.add ui.ui_vars vname x None (), vname, index
with
Wd_interactor.Element_exists id ->
id, vname, index
end
method private get_base dlg =
let vname =
match self # node # attribute "base" with
Value s -> s
| Implied_value -> raise Not_found
| _ -> assert false in
let index =
self # node # optional_string_attribute "baseindex" in
let is_associative =
try
match dlg # variable vname with
Alist_value _ -> true
| _ -> false
with
Not_found ->
raise(self # runtime_error("Reference to non-existent variable `" ^
vname ^ "'"))
in
if is_associative then begin
if index = None then
raise(self # runtime_error("Variable `" ^ vname ^
"' is associative but used in a non-associative way (index attribute missing)"))
end
else
if index <> None then
raise(self # runtime_error("Variable `" ^ vname ^
"' is plain but used as associative variable (extra index attribute)"));
vname,index
method private string_variable dlg name index =
match index with
None -> dlg # string_variable name
| Some x ->
try
dlg # lookup_string_variable name x
with
Not_found ->
raise(self # runtime_error("Variable `" ^ name ^ "' not defined for index value `" ^ x ^ "'"))
method private dyn_enum_variable dlg name index =
match index with
None -> dlg # dyn_enum_variable name
| Some x ->
try
dlg # lookup_dyn_enum_variable name x
with
Not_found ->
raise(self # runtime_error("Variable `" ^ name ^ "' not defined for index value `" ^ x ^ "'"))
method private other_attributes but =
(* Returns the values of the attributes of the node (except those
* mentioned in 'but') as a single string to be included into
* HTML tags.
*)
let atts =
List.filter
(fun (aname,avalue) -> not (List.mem aname but))
(self # node # attributes) in
String.concat
" "
(List.map
(fun (aname, avalue) ->
(* This must be a CDATA attribute. *)
let v =
match avalue with
Value s -> s
| _ -> assert false
in
aname ^ "=\"" ^ escape_html v ^ "\""
)
atts
)
end
;;
(**********************************************************************)
(*** Auxiliary classes/functions ***)
(**********************************************************************)
(* Output template of the standard library: *)
let stdlib_to_html ?context ?vars ?(params=[]) (dlg : dialog_type) outch name =
let template =
try dlg # application # template name
with
Not_found -> failwith ("Standard library template not found: " ^ name);
in
let dict_params =
Wd_dictionary.of_alist
(List.map
(fun (n,v) ->
let d = new data_impl (new data_node) in
d # set_data v;
(n, d#extension ))
params) in
let instance =
template # instantiate ~params:dict_params ?context ?vars dlg in
instance # to_html ?context ?vars dlg outch
;;
let make_template_parameter_from_node ?context ?vars dlg n =
{ Wd_templrep.param_tree = n;
Wd_templrep.param_text = lazy (let b = Buffer.create 80 in
let ch = new Netchannels.output_buffer b in
n # extension # to_text
?context ?vars dlg ch;
Buffer.contents b);
}
;;
class container =
object (self)
inherit page_tree
inherit mixin_skip_output
(* This class serves only as container for sub nodes *)
end
;;
let new_container() = new element_impl (new container);;
class uicontext =
object(self)
inherit page_tree
val container = new_container()
(* Note: ui:context is subject to whitespace normalization.
* See [normalize_whitespace] below.
*)
method private process context =
let rec process_subnodes context nodes =
match nodes with
node :: nodes' ->
begin match node#node_type with
T_element "ui:param" ->
let name = node # required_string_attribute "name" in
let context' =
D.add name node#extension context in
process_subnodes context' nodes'
| _ ->
assert false
end
| [] ->
context
in
(* Assume the transformation of transl_ui_context (below): *)
match self # node # sub_nodes with
| n :: l when n # node_type = T_element "ui:internal:container" ->
(process_subnodes context (n # sub_nodes), l)
| _ ->
assert false
method scan_dialog app obj =
(* Collect the ui:param subnodes, and set the default_context of
* 'obj'.
*)
let context, body = self # process D.empty in
if body <> [] then
raise(self # runtime_error("ui:context is malformed"));
if obj # default_context <> D.empty then
raise(self # runtime_error("There is already a default context"));
obj # set_default_context context;
method to_html ?(context=D.empty) ?vars dlg outch =
let context', body = self # process context in
List.iter
(fun n ->
n # extension # to_html ?context:(Some context') ?vars dlg outch)
body
method to_text ?(context=D.empty) ?vars dlg outch =
let context', body = self # process context in
List.iter
(fun n ->
n # extension # to_text ?context:(Some context') ?vars dlg outch)
body
end
;;
let new_uicontext() = new element_impl (new uicontext);;
let collect_and_encode f n dlg =
let encodings =
(try
match n # node # attribute "enc" with
Value s ->
split s
| Valuelist l ->
l
| _ ->
[]
with
Not_found -> []
) in
let buffer = Buffer.create 1000 in
let outch' = new Netchannels.output_buffer buffer in
n # node # iter_nodes (f outch');
let v = ref (Buffer.contents buffer) in
List.iter
(fun enc ->
let f =
try dlg # application # output_encoding enc
with
Not_found ->
failwith ("Unknown encoding: " ^ enc)
in
v := f !v
)
encodings;
!v
;;
class uiencode =
object (self)
inherit page_tree
method to_html ?context ?vars dlg outch =
try
let s =
collect_and_encode
(fun outch' n -> n # extension # to_html ?context ?vars dlg outch')
self
dlg
in
outch # output_string s
with
Failure s -> raise(self # runtime_error s)
method to_text ?context ?vars dlg outch =
try
let s =
collect_and_encode
(fun outch' n -> n # extension # to_text ?context ?vars dlg outch')
self
dlg
in
outch # output_string s
with
Failure s -> raise(self # runtime_error s)
end
;;
let new_uiencode () = new element_impl (new uiencode);;
(**********************************************************************)
(*** Mixin Classes II ***)
(**********************************************************************)
type scope = Lexical | Dynamic
class virtual mixin_instantiate
?force_version
(eltype : string) =
object (self)
inherit type_method_instantiate
(* Defines the method 'instantiate' that interprets the subnodes of this
* node as template definition.
* 'eltype' is used to compose error messages.
*)
(* Note: ui:template is subject to whitespace normalization
* (see [normalize_whitespace] below.
*)
val mutable prepared_template = None (* See comment in 'instantiate' *)
val container = new_container()
val uicontext = new_uicontext()
method private error_string =
(* Returns a prefix for error messages *)
let ent,line,pos = self # node # position in
"In " ^ eltype ^ " `" ^
( match self # node # attribute "name" with
Value s -> s
| _ -> "<anonymous>"
) ^ "', found in entity " ^ ent ^ " at line " ^ string_of_int line ^
", position " ^ string_of_int pos
method private eval_expr dlg e =
let rec eval e =
match e with
Wd_templrep.Expr_var var_name ->
dlg # variable var_name
| Wd_templrep.Expr_strconst s ->
String_value s
| Wd_templrep.Expr_apply ("type", args) ->
( match args with
[ Wd_templrep.Expr_var var_name ] ->
let d = dlg # declaration # variable var_name in
( match d.var_type with
String_type -> String_value "string"
| Enum_type e -> String_value e.enum_name
| Dialog_type -> String_value "dialog"
| Dyn_enum_type -> String_value "dynamic-enumerator"
)
| _ ->
failwith "Function `type' must be applied to a variable"
)
| Wd_templrep.Expr_apply (("is_associative" | "is-associative"), args) ->
( match args with
[ Wd_templrep.Expr_var var_name ] ->
let d = dlg # declaration # variable var_name in
String_value(if d.var_associative then "yes" else "no")
| _ ->
failwith "Function `is_associative' must be applied to a variable"
)
| Wd_templrep.Expr_apply ("default", args) ->
( match args with
[ Wd_templrep.Expr_var var_name ] ->
let d = dlg # declaration # variable var_name in
( match d.var_default with
Some def -> def
| None ->
failwith "Function `default': this variable does not have a default value"
)
| _ ->
failwith "Function `default' must be applied to a variable"
)
| Wd_templrep.Expr_apply ("enum", args) ->
( match args with
[ Wd_templrep.Expr_var var_name ] ->
( try
let e = dlg # declaration # enumeration var_name in
Dyn_enum_value e.enum_definition
with
Not_found ->
failwith("Function `enum': enumeration not found: " ^ var_name)
)
| _ ->
failwith "Function `enum': bad usage"
)
| Wd_templrep.Expr_apply ("words", args) ->
let s =
String.concat " "
(List.map
(function
| Wd_templrep.Expr_var var_name ->
var_name
| _ ->
failwith "Function `words': bad usage"
)
args) in
String_value s
| Wd_templrep.Expr_apply (fn_name, args) ->
let args' = List.map (fun arg -> lazy(eval arg)) args in
let fn =
try
dlg # application # lazy_var_function fn_name
with
Not_found ->
failwith("No such function: " ^ fn_name)
in
fn dlg args'
| Wd_templrep.Expr_param(_,_) ->
assert false
in
try
( match eval e with
String_value s -> s
| _ ->
failwith("The final result of an expression must be a string")
)
with
Failure msg ->
raise(Instantiation_error msg)
| No_such_variable msg ->
raise(Instantiation_error ("No such variable: " ^ msg))
method study app =
let version =
match force_version with
Some v -> v
| None -> self # major_version
in
try
match version with
1 -> self # study_v1 app
| 2 -> self # study_v2 app
| _ -> assert false
with
Formal_user_error msg ->
raise(Formal_user_error (self#error_string ^ ": " ^ msg))
method instantiate ?context ?vars ?params dlg =
let version =
match force_version with
Some v -> v
| None -> self # major_version
in
match version with
1 -> self # instantiate_v1 ?context ?vars ?params dlg
| 2 -> self # instantiate_v2 ?context ?vars ?params dlg
| _ -> assert false
(****************** INSTANTIATION FOR VERSION 1 ***********************)
val mutable prepared_expectparams = D.empty
(* A list [ (name, (scope, default)); ... ] enumerating the parameters
* declared with <ui:expectparam>. [name] are the names of the
* params. [scope] is either [Lexical] or [Dynamic]. [default]
* is [None] if no default is specified, or [Some t] where [t] is
* the default value as syntax tree.
*)
method private study_v1 app =
(* Prepare the template, i.e. scan it for $-variables etc. This is
* only done once.
* This method initializes [prepared_template] and
* [prepared_expectparams]
*)
let dtd = ( self # node : syntax_tree node) # dtd in
(* A function to extract the ui:expectparam clauses from the list
* of subnodes. The function returns a list [name, (scope, default); ... ]
* where the 'names' are the values from the "name" attributes
* and where the 'scopes' are the values from the "scope" attributes.
* The 'defaults' are the trees specifying the default value.
*)
let rec extract_expectparams nodes =
match nodes with
n :: nodes' ->
( match n # node_type with
T_element "ui:expectparam" ->
let name = n # required_string_attribute "name" in
let scope =
match n # required_string_attribute "scope" with
"lexical" -> Lexical
| "dynamic" -> Dynamic
| _ -> assert false
in
let force =
n # required_string_attribute "force-default" = "yes" in
let default =
if n # sub_nodes = [] && not force then
None
else begin
let c = container # create_element
dtd
(T_element "ui:internal:container")
[] in
c # set_nodes
(List.map
(fun m -> m # orphaned_clone)
(n # sub_nodes));
Some (c#extension :> syntax_tree_type)
end
in
let rest, nodes'' = extract_expectparams nodes' in
if List.mem_assoc name rest then
raise(self # formal_user_error("double ui:expectparam for parameter `" ^
name ^ "'"));
((name, (scope, default)) :: rest, nodes'')
| T_data when only_whitespace n#data ->
(* There is no previous whitespace normalization pass
* for DTD version 1, so we have to skip over whitespace
* here
*)
extract_expectparams nodes'
| _ ->
([], nodes)
)
| [] ->
([], [])
in
if prepared_template = None then begin
(* The first subnodes of the template are usually the
* <ui:expectparam> nodes. We done now:
* (a) extract these nodes and store their contents in
* [prepared_expectparams]
* (b) extract the part after the last <ui:expectparam> node,
* and do whitespace stripping
*)
let expectparams, contents =
extract_expectparams (self # node # sub_nodes) in
let tmpl_name = self # error_string in
let new_pt =
Wd_templrep.prepare_tree_with_parameters
~mk_uiencode:new_uiencode
tmpl_name
app
contents
in
prepared_expectparams <- D.of_alist expectparams;
prepared_template <- Some new_pt;
end
method private instantiate_v1 ?(context = D.empty) ?vars ?(params = D.empty) dlg =
(* 'context': contains the bindings of context parameters.
* 'params': contains the bindings of the parameters passed by
* ui:param.
* There are differences between 'context' and 'params' with respect
* to the meaning of the ui:expectparam clauses.
*
* Return value (c, new_context):
* 'c': The node tree resulting from instantiation
* 'new_context': The context that must be used to instantiate further
* templates within 'c'
*)
(* Get the prepared template 'pt' of type Templrep.t. If this is the first
* time the template is instantiated, we must compute 'pt'. Otherwise,
* we can use the old 'pt' value again; it is stored in the slot
* 'prepared_template'.
*)
let dtd = ( self # node : syntax_tree node) # dtd in
let pt =
match prepared_template with
Some x -> x
| None -> failwith "method [instantiate]: Template is not prepared"
in
(* Compute the effective list of parameters. This list is actually used
* for parameter replacement
*)
let eff_params =
(D.mapi
(fun name (scope, default) ->
(* If the parameter has been passed using ui:param, it will
* always become an effective parameter.
*)
try
D.find name params
with
Not_found ->
(* Check if there is a default value. If yes, use it. *)
match default with
Some d ->
d
| None ->
(* Search the parameter in 'context' *)
try
D.find name context
with
Not_found ->
(* The required parameter is missing! *)
raise(Instantiation_error
("The required parameter `" ^
name ^ "' has neither been passed directly nor indirectly"))
)
prepared_expectparams
)
in
(* ONLY eff_params is passed to the instantiation function, so other
* parameters are invisible.
*)
(* Next, we can instantiate 'pt'. We need a container that collects
* the result objects.
*)
let c = container # create_element
dtd
(T_element "ui:internal:container")
[] in
let eff_params' =
D.map
(fun node ->
make_template_parameter_from_node ~context ?vars dlg node#node)
eff_params
in
let eval_expr = self # eval_expr dlg in
Wd_templrep.instantiate ~eval_expr pt [ eff_params' ] c;
(* Last but not least compute the new context. Since WDialog 2.0, the
* new context is no longer returned to the caller, but the necessary
* <ui:context> elements are added to the resulting tree. The effect
* is the same: the dynamic parameters are always added to the context.
*)
(* -- currently not needed:
let lexical_params =
List.filter (fun (_,(scope,_)) -> scope = Lexical) expectparams in
*)
let dynamic_params =
D.fold
(fun n (scope,_) l -> if scope = Dynamic then n :: l else l)
prepared_expectparams
[]
in
if dynamic_params = [] then
c # extension (* The context remains unchanged *)
else begin
(* Add the dynamic parameters n1, n2, ... to the context:
* <ui:context>
* <ui:param name="n1">v1</ui:param>
* <ui:param name="n2">v2</ui:param>
* ...
* <ui:internal:sep/> (* A separator *)
* c
* </ui:context>
*)
let context_node =
uicontext # create_element
dtd
(T_element "ui:context")
[] in
let params =
List.map
(fun name ->
let pnode =
container # create_element
dtd (T_element "ui:param") ["name",name] in
pnode # set_nodes
[(D.find name eff_params)#node#orphaned_clone];
pnode
)
dynamic_params in
let sep =
container # create_element dtd (T_element "ui:internal:sep") [] in
context_node # set_nodes (params @ [sep; c]);
context_node # extension
end
(****************** INSTANTIATION FOR VERSION 2 ***********************)
val mutable prepared_from_caller = D.empty
val mutable prepared_from_context = D.empty
method private study_v2 app =
(* Prepare the template, i.e. scan it for $-variables etc. This is
* only done once.
* This method initializes [prepared_template], [ prepared_defaults], and
* [prepared_from_caller]
*)
let dtd = ( self # node : syntax_tree node) # dtd in
(* A function to extract the ui:default clauses from the list
* of subnodes. The function returns the dictionary of default values.
*)
let rec extract_defaults nodes =
match nodes with
n :: nodes' ->
( match n # node_type with
T_element "ui:default" ->
let name = n # required_string_attribute "name" in
let default = container # create_element
dtd
(T_element "ui:internal:container")
[] in
default # set_nodes
(List.map
(fun m -> m # orphaned_clone)
(n # sub_nodes));
let rest, nodes'' = extract_defaults nodes' in
if D.mem name rest then
raise(self # formal_user_error("double ui:default for parameter `" ^
name ^ "'"));
(D.add name default rest, nodes'')
| _ ->
(D.empty, nodes)
)
| [] ->
(D.empty, [])
in
if prepared_template = None then begin
(* The first subnodes of the template are usually the
* <ui:default> nodes. We do now:
* (a) extract these nodes and store their contents in
* [prepared_defaults]
* (b) extract the part after the last <ui:default> node
*)
let defaults, contents =
extract_defaults (self # node # sub_nodes) in
let from_caller =
self # node # optional_list_attribute "from-caller" in
let from_context =
self # node # optional_list_attribute "from-context" in
(* CHECK: [from_caller] and [from_context] must be disjoint *)
List.iter
(fun n ->
if List.mem n from_context then
raise(self # formal_user_error("The parameter `" ^ n ^
"' is mentioned in both from-caller and from-context"));
)
from_caller;
let tmpl_name = self # error_string in
let new_pt =
Wd_templrep.prepare_tree_with_parameters
~mk_uiencode:new_uiencode
tmpl_name
app
contents
in
(* CHECKS:
* (a) Every parameter in [new_pt] is declared in [from_caller]
* or [from_context]
* (b) Every default value in [defaults] is declared, too
*)
D.iter
(fun name _ ->
if not(List.mem name from_caller || List.mem name from_context)
then
raise(self # formal_user_error("The parameter `" ^ name ^
"' is not declared"));
)
(Wd_templrep.get_parameters new_pt);
D.iter
(fun name _ ->
if List.mem name from_context then
raise(self # formal_user_error("The context parameter `" ^ name ^
"' must not have a default value"));
if not (List.mem name from_caller) then
raise(self # formal_user_error("The parameter `" ^ name ^
"' is not declared but has a default"));
)
defaults;
prepared_from_caller <-
D.of_alist
(List.map
(fun n ->
(n,
( try Some((D.find n defaults) # extension)
with Not_found -> None
)
)
)
from_caller
);
prepared_from_context <-
D.of_alist
(List.map
(fun n -> n,())
from_context
);
prepared_template <- Some new_pt;
end
method private instantiate_v2 ?(context = D.empty) ?vars ?(params = D.empty) dlg =
(* 'context': contains the bindings of context parameters.
* 'params': contains the bindings of the parameters passed by
* ui:param.
*)
(* Get the prepared template 'pt' of type Templrep.t. If this is the first
* time the template is instantiated, we must compute 'pt'. Otherwise,
* we can use the old 'pt' value again; it is stored in the slot
* 'prepared_template'.
*)
let dtd = ( self # node : syntax_tree node) # dtd in
let pt =
match prepared_template with
Some x -> x
| None -> failwith "method [instantiate]: Template is not prepared"
in
(* Compute the effective list of parameters. This list is actually used
* for parameter replacement
*)
let eff_caller_params =
D.mapi
(fun name default ->
(* If the parameter has been passed using ui:param, it will
* always become an effective parameter.
*)
try
D.find name params
with
Not_found ->
(* Check if there is a default value. If yes, use it. *)
match default with
Some d ->
d
| None ->
(* The required parameter is missing! *)
raise(Instantiation_error
("The from-caller parameter `" ^
name ^ "' has not been passed by the caller and does not have a default value"))
)
prepared_from_caller
in
let eff_context_params =
D.mapi
(fun name _ ->
try
D.find name context
with
Not_found ->
(* Defaults are not supported, so complain: *)
raise(Instantiation_error
("The from-context parameter `" ^
name ^ "' is not defined in the current context"));
)
prepared_from_context
in
let eff_params = [ eff_caller_params; eff_context_params ] in
(* Next, we can instantiate 'pt'. We need a container that collects
* the result objects.
*)
let c = container # create_element
dtd
(T_element "ui:internal:container")
[] in
let eff_params' =
List.map
(fun pl ->
D.map
(fun node ->
make_template_parameter_from_node ~context ?vars dlg node#node)
pl
)
eff_params
in
let eval_expr = self # eval_expr dlg in
Wd_templrep.instantiate ~eval_expr pt eff_params' c;
c # extension
end
;;
(**********************************************************************)
(*** Application Tree ***)
(**********************************************************************)
class uiapplication =
object (self)
inherit application_tree
method scan_application app =
let attname = match self # major_version with
1 -> "start-object"
| _ -> "start-dialog"
in
let start_dlg_name =
match self # node # attribute attname with
Value s -> s
| _ -> assert false
in
app # set_start_dialog_name
start_dlg_name;
( let debug_list = self # node # pinstr "wd-debug-mode" in
match debug_list with
[] -> ()
| debug_pinstr :: _ ->
let style =
match debug_pinstr # value with
"fully-encoded" -> `Fully_encoded
| "partially-encoded" -> `Partially_encoded
| "" -> `Partially_encoded
| _ ->
raise(self # formal_user_error("Bad processing instruction wd-debug-mode"))
in
app # set_debug_mode true style
);
app # set_prototype_mode
(self # node # pinstr "wd-prototype-mode" <> []);
app # set_onstartup_call_handle
(self # node # pinstr "wd-onstartup-call-handle" <> []);
self # node # iter_nodes
(fun n -> n # extension # scan_application app);
try
ignore(app # dialog_declaration start_dlg_name)
with
Not_found ->
raise (self # formal_user_error ("The start-dialog of the ui:application does not exist"))
end
;;
class uidialog =
object (self)
inherit application_tree
method scan_application app =
let name =
match self # node # attribute "name" with
Value s -> s
| _ -> assert false in
let start_page_name =
match self # node # attribute "start-page" with
Value s -> s
| _ -> assert false in
let lang_variable =
try
match self # node # attribute "lang-variable" with
Value s -> Some s
| _ -> None
with
Not_found -> None
in
let obj = new Wd_dialog_decl.dialog_decl in
obj # set_name name;
obj # set_start_page start_page_name;
( match lang_variable with
Some v -> obj # set_language_variable v;
| _ -> ()
);
app # add_dialog_declaration obj;
self # node # iter_nodes
(fun n -> n # extension # scan_dialog app obj);
(* CHECKS: *)
begin try
ignore(obj # page start_page_name)
with
Not_found ->
raise (self # formal_user_error ("The start-page of the ui:dialog `" ^
name ^ "' does not exist"))
end;
begin match lang_variable with
Some v ->
begin
try
let d = obj # variable v in (* or Not_found *)
if d.var_type <> String_type then
raise (self # formal_user_error
("The lang-variable of the ui:dialog `" ^
name ^ "' is not a string variable"));
if d.var_associative then
raise (self # formal_user_error
("The lang-variable of the ui:dialog `" ^
name ^ "' is associative"));
with
Not_found ->
raise (self # formal_user_error
("The lang-variable of the ui:dialog `" ^
name ^ "' does not exist"));
end
| _ ->
()
end
end
;;
class uitemplate =
object (self)
inherit application_tree
inherit mixin_skip_output
inherit mixin_instantiate "Template"
method scan_application app =
let name =
match self # node # attribute "name" with
Value s -> s
| _ -> assert false in
let name' =
try
match self # node # attribute "xml:lang" with
Value l -> name ^ "#" ^ l
| Implied_value -> name
| _ -> assert false
with
Not_found -> name (* DTD version 1 *)
in
app # add_template name' (self : #syntax_tree :> template_type)
end
;;
class uilibtemplate =
object (self)
inherit application_tree
inherit mixin_skip_output
inherit mixin_instantiate ~force_version:2 "Template"
method scan_application app =
let name =
match self # node # attribute "name" with
Value s -> s
| _ -> assert false in
let name' =
try
match self # node # attribute "xml:lang" with
Value l -> name ^ "#" ^ l
| Implied_value -> name
| _ -> assert false
with
Not_found -> name (* DTD version 1 *)
in
app # add_template ~lib:true name' (self : #syntax_tree :> template_type)
end
;;
class uidefault =
object (self)
(* ONCE DTD VERSION 1 IS DROPPED:
inherit syntax_tree
inherit mixin_no_output
*)
(* ... until then, just inherit from uicontext, and don't output: *)
inherit uicontext
inherit mixin_no_output
end
;;
(**********************************************************************)
(*** Literal Tree ***)
(**********************************************************************)
class uistringvalue =
object (self)
inherit literal_tree
method scan_literal() =
String_value (self # node # data)
end;;
class uienumvalue =
object (self)
inherit literal_tree
method scan_literal() =
let slist = ref [] in
self # node # iter_nodes
(fun n ->
slist := !slist @
[ match n # extension # scan_literal() with
Enum_value [ s ] -> s
| _ -> assert false
]);
Enum_value !slist
end;;
class uienumitem =
object (self)
inherit literal_tree
method scan_literal() =
match self # node # attribute "internal" with
Value s -> Enum_value [ s ]
| _ -> assert false
end;;
class uidynenumvalue =
object (self)
inherit literal_tree
method scan_literal() =
let slist = ref [] in
self # node # iter_nodes
(fun n ->
slist := !slist @
[ match n # extension # scan_literal() with
Dyn_enum_value [ s,t ] -> s,t
| _ -> assert false
]);
Dyn_enum_value !slist
end;;
class uidynenumitem =
object (self)
inherit literal_tree
method scan_literal() =
let ival =
match self # node # attribute "internal" with
Value s -> s
| _ -> assert false in
let eval =
match self # node # attribute "external" with
Value s -> s
| Implied_value -> ival
| _ -> assert false in
Dyn_enum_value [ ival, eval ]
end;;
class uialistvalue =
object (self)
inherit literal_tree
method scan_literal() =
let slist = ref [] in
self # node # iter_nodes
(fun n ->
slist := !slist @
[ match n # extension # scan_literal() with
Alist_value [ s,t ] -> s,t
| _ -> assert false
]);
Alist_value !slist
end;;
class uialistitem =
object (self)
inherit literal_tree
method scan_literal() =
let index =
match self # node # attribute "index" with
Value s -> s
| _ -> assert false in
match self # node # sub_nodes with
[ single ] ->
Alist_value [ index, single # extension # scan_literal() ]
| _ ->
assert false
end;;
(**********************************************************************)
(*** Object Tree ***)
(**********************************************************************)
class uienumeration =
object (self)
inherit dialog_tree
method scan_dialog app obj =
let name =
match self # node # attribute "name" with
Value s -> s
| _ -> assert false in
let e =
{ enum_name = name;
enum_definition = [];
} in
self # node # iter_nodes
(fun n -> n # extension # scan_enumeration e);
obj # add_enumeration e
end
;;
class uienum =
object (self)
inherit syntax_tree
method scan_enumeration e =
let internal_name =
match self # node # attribute "internal" with
Value s -> s
| _ -> assert false in
let external_name =
match self # node # attribute "external" with
Value s -> s
| Implied_value -> internal_name
| _ -> assert false in
if List.mem_assoc internal_name e.enum_definition then
raise (self # formal_user_error ("In the definition of the enumerator `" ^
e.enum_name ^ "' the value `" ^
internal_name ^ "' is defined twice"))
else
e.enum_definition <- e.enum_definition @ [internal_name, external_name]
end
;;
class uivariable =
object (self)
inherit dialog_tree
method scan_dialog app obj =
let var_name =
match self # node # attribute "name" with
Value s -> s
| _ -> assert false in
let var_type_name =
match self # node # attribute "type" with
Value s -> s
| _ -> assert false in
let var_temporary =
match self # node # attribute "temporary" with
Value "yes" -> true
| Value "no" -> false
| _ -> assert false in
let var_associative =
match self # node # attribute "associative" with
Value "yes" -> true
| Value "no" -> false
| _ -> assert false in
let var_protected =
try
match self # node # attribute "protected" with
Value "yes" -> true
| Value "no" -> false
| _ -> assert false
with
Not_found -> false (* DTD version 1 *)
in
let var_type =
match var_type_name with
"string" -> String_type
| "object" when self#major_version = 1 -> Dialog_type
| "dialog" when self#major_version = 2 -> Dialog_type
| "dynamic-enumerator" -> Dyn_enum_type
| _ ->
let e =
try obj # enumeration var_type_name
with
Not_found ->
raise (self # formal_user_error ("Variable `" ^ var_name ^
"' is declared with the unknown type `" ^
var_type_name ^ "'"))
in
Enum_type e
in
let default =
match self # node # sub_nodes with
[] -> None
| [ single ] -> Some (single # extension # scan_literal())
| _ -> assert false
in
let var =
{ var_name = var_name;
var_type = var_type;
var_default = default;
var_temporary = var_temporary;
var_associative = var_associative;
var_protected = var_protected;
} in
obj # add_variable var
end
;;
class uipage =
object (self)
inherit dialog_tree
inherit mixin_instantiate "Page"
inherit mixin_skip_output as skipper
val mutable page_name = ""
val mutable page_replace = false
(* Note: ui:page is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method scan_dialog app obj =
(* "replace": A feature of the DTD version 1. In version 2,
* assume replace="yes" always
*)
let replace = self # node # optional_string_attribute "replace" in
let name = self # node # required_string_attribute "name" in
obj # add_page name (self : #syntax_tree :> syntax_tree);
page_name <- name;
page_replace <- (replace = Some "yes") || replace = None;
if page_replace then
self # study app;
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
(* page invocations can be nested (for popup pages). So we have to save
* the name of the current page and restore it later.
*)
let old_current_page = vars.current_page in
vars.current_page <- page_name;
if not page_replace then
(* The simple case: no '$' expansion within the page definition.
* We can directly output all sub nodes as HTML.
*)
skipper # to_html ?context ~vars dlg outch
else begin
(* It is allowed that '$' parameters occur in the page definition.
* We need to instantiate the definition with the default context
* as context, and to call to_html on the result.
*)
let instance =
try
self # instantiate ?context ~vars dlg
with
Instantiation_error msg ->
raise(self # runtime_error msg)
in
instance # to_html ?context ~vars dlg outch
end;
vars.current_page <- old_current_page;
end
;;
(**********************************************************************)
(*** Page Tree ***)
(**********************************************************************)
class uiform =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let env = dlg#environment in
let action_suffix =
self # node # required_string_attribute "action-suffix" in
let add_debug_mode_output outch =
(* If we are currently in debugging mode, dump the state of the object *)
let out = outch # output_string in
if env.debug_mode then begin
out "<!--\n ***************** DUMP ********************\n";
let b = Buffer.create 1024 in
let f = Format.formatter_of_buffer b in
dlg # dump f;
Format.pp_print_newline f ();
let escaped =
match env.debug_mode_style with
`Fully_encoded -> escape_html (Buffer.contents b)
| `Partially_encoded -> escape_comment (Buffer.contents b)
in
out escaped;
out "\n *******************************************\n-->"
end
in
(* There are three situations resulting in different forms:
* (1) An ordinary page is being generated.
* (2) A static popup page (for ui:popup) is being generated.
* (3) The response to a popup request (ui:server-popup) is being
* generated
*)
let out = outch # output_string in
if not vars.within_popup then begin
(* Case (1): Output the form (method POST), and generate the material
* which is embraced by the form tags.
*)
let s = sprintf
"<form method=post name=\"uiform\" action=\"%s%s\" enctype=\"multipart/form-data\" accept-charset=\"%s\" %s>\n"
(escape_html env.self_url)
(escape_html action_suffix)
(Netconversion.string_of_encoding
(dlg#application#charset :> Netconversion.encoding))
(self # other_attributes
["method"; "name"; "action"; "enctype"; "accept-charset"])
in
out s;
stdlib_to_html ?context ~vars dlg outch "wd-core-jsfunc-form";
(* The following iteration has the important side-effect that the
* "interactors" instance variable of "dlg" will be initialized.
* Because of this we must go into the children here, and not after
* the hidden fields have been printed.
*)
let n = self # node in
n # iter_nodes
(fun n' -> n' # extension # to_html ?context ~vars dlg outch);
out "<input type=hidden name=\"uiobject_session\" value=\"";
out (vars.serialize_session());
out "\">\n";
out "<input type=hidden name=\"uiobject_extra_args\" value=\"\">\n";
let s = sprintf
"<input type=hidden name=\"uiobject_visible_pages\" value=\"%s\">\n"
(escape_html (dlg # page_name)) in
out s;
out "<input type=hidden name=\"uiobject_popup_index\" value=\"\">\n";
add_debug_mode_output outch;
out "</form>\n";
(* Include now an alternate form, which is used to submit server
* popups:
* When the user submits a popup window that was generated by a
* server request, the CGI parameters of the form in the popup window
* are collected and added to the uiobject_extra_args variable in
* the uialtform. The uialtform is then submitted. The effect is
* exactly the same as if the form in the popup window had been
* submitted; however the request comes from the main window and
* the main window will display the next page (and not the popup
* window which is closed at the same time).
* There is one problem: Upload elements cannot be copied from the
* popup window to the main window, and because of this, file upload
* elements are not allowed in popup windows.
* Note that _static_ popup windows do not use uialtform. For these
* windows, the CGI parameters are copied to the uiobject_extra_args
* field of _uiform_, and not uialtform. This has the advantage that
* modifications of user input fields of the main window are also sent
* to the server instead of being discarded. -- For server popup
* windows, this technique is not possible, because of name conflicts
* of the CGI parameters.
*)
let s = sprintf
"<form name=\"uialtform\" method=\"post\" action=\"%s%s\" enctype=\"multipart/form-data\" accept-charset=\"%s\">\n"
(escape_html env.self_url)
(escape_html action_suffix)
(Netconversion.string_of_encoding
(dlg#application#charset :> Netconversion.encoding)) in
out s;
out "<input type=hidden name=\"uiobject_extra_args\" value=\"\">\n";
out "<input type=hidden name=\"uiobject_visible_pages\" value=\"\">\n";
out "</form>\n";
end
else begin
(* Cases (2) and (3) *)
let s = sprintf
"<form name=\"uiform\" \n\
onsubmit=\"opener.popup_submit(document,'%s',%s); return false;\" accept-charset=\"%s\" %s>\n"
(escape_js vars.current_page)
(if dlg # is_server_popup_request then "1" else "0")
(Netconversion.string_of_encoding
(dlg#application#charset :> Netconversion.encoding))
(self # other_attributes ["name"; "onsubmit"; "accept-charset"]) in
out s;
(* Forms in popup windows have an ONSUBMIT handler because these
* forms are never directly submitted to the server. The function
* popup_submit collects the form fields of the popup window,
* and puts them into uiobject_extra_args of the main window
* (by encoding them appropriately).
* The ONSUBMIT handler is forced to return 'false' such that the
* form of the popup window is not submitted itself.
*)
(* The following iteration has the important side-effect that the
* "interactors" instance variable of "dlg" will be initialized.
* Because of this we must go into the children here, and not after
* the hidden fields have been printed.
*)
let n = self # node in
n # iter_nodes
(fun n' -> n' # extension # to_html ?context ~vars dlg outch);
(* Only server popups: Because these popup windows are submitted
* through the uialtform of the main window, these windows must
* provide their own parameters storing the state of the object.
*
* (Static popup windows submit their forms by copying the fields
* to the uiform of the main window which already contains
* uiobject_name and uiobject_state, so it is not necessary to
* include them here.)
*)
if dlg # is_server_popup_request then begin
out "<input type=hidden name=\"uiobject_session\" value=\"";
out (vars.serialize_session());
out "\">\n";
add_debug_mode_output outch;
end;
out "</form>\n";
end
end
;;
class virtual mixin_popup_environment =
object (self)
method private print_popup_environment outch vars dlg =
(* The following functions need only be included once in the generated
* output. Furthermore, they need only be included if the page contains
* references to popup windows. So we output these function only on
* demand, and only at most once.
*)
if not vars.popup_env_initialized then begin
let page_name = dlg # page_name in
stdlib_to_html
~vars ~params:["page_name", page_name]
dlg outch "wd-core-jsfunc-popup";
vars.popup_env_initialized <- true;
end
end
;;
class uipopup =
object (self)
inherit page_tree
inherit mixin_popup_environment
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
(* Nested popup pages are not supported: *)
if vars.within_popup then
raise(self # runtime_error("Nested popups not supported"));
(* Get the page_name of the page that is included as popup page;
* and the page definition of the page:
*)
let page_name = self # node # required_string_attribute "page" in
let page =
try
dlg # declaration # page page_name
with
Not_found ->
raise(self # runtime_error("There is no such page"))
in
(* The following is quite tricky:
* The HTML code for the popup window is written into a separated buffer,
* i.e. into outch' and not outch. Later the contents of outch' will
* be converted into code that opens a new window displaying the contents
* of outch'.
* However, the generated page is not completely separated from the
* current page: The other variables passed to to_html are the same
* we are currently using. dlg, uidecl, appdecl, and context
* are exactly the same; vars is temporarily modified such that it is
* known that popup code is produced (i.e. vars.within_popup is true).
* Especially sharing dlg has an important side effect: all
* interactors occuring on the popup page are counted as if they were
* part of the main page. This means that the interactor IDs of the
* popup page do not conflict with the IDs of the main page, such that
* the form fields of both pages can be safely merged and processed in
* the same submit request.
* uidecl, appdecl are not modified while the HTML generation is in
* progress.
* Sharing context means that the template parameters are visible
* which are currently set. context is a read-only variable.
*)
let buffer' = Buffer.create 1000 in
let outch' = new Netchannels.output_buffer buffer' in
let old_within_popup = vars.within_popup in
let old_popup_env_initialized = vars.popup_env_initialized in
vars.within_popup <- true;
vars.popup_env_initialized <- false;
page # to_html ?context ~vars dlg outch';
(* Note: This updates dlg # interactors such that the interactors
* of the popup page are included into the current list of interactors
* (for the main window).
*)
vars.within_popup <- old_within_popup;
vars.popup_env_initialized <- old_popup_env_initialized;
(* Generate javascript functions managing the popup window *)
self # print_popup_environment outch vars dlg;
(* Generate a javascript function that opens a window and
* writes the contents of outch' into it.
*)
stdlib_to_html
?context ~vars
~params:[ "popup_name", page_name;
"data", Buffer.contents buffer' ]
dlg
outch
"wd-core-jsfunc-openpopup";
end
;;
class uiserverpopup =
object (self)
inherit page_tree
inherit mixin_popup_environment
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
(* Nested popup pages are not supported: *)
if vars.within_popup then
raise(self # runtime_error("Nested popups not supported"));
let env = dlg#environment in
(* Get the page_name of the page that is included as popup page;
* and the page definition of the page:
*)
let page_name = self # node # required_string_attribute "page" in
let page =
try
dlg # declaration # page page_name
with
Not_found ->
raise(self # runtime_error("There is no such page"))
in
(* Generate javascript functions managing the popup window *)
self # print_popup_environment outch vars dlg;
(* Now the HTML code for the popup page is generated. This code is
* different from the code of static popup (class uipopup), as the
* contents of the popup window are dynamically determined. This means
* that we cannot know the contents now, and we only generate code
* that performs another server request getting the contents.
*
* This request is a form that is submitted immediately. It is filled
* with several hidden fields of which some are copied from the uiform
* of the main window, and some have constant texts. The fields listed
* in duplicated_variables are copied from the main window; they contain
* the current state of the main window.
*
* Furthermore, the field uiobject_server_popup is set and contains the
* name of the page that will be displayed in the popup window.
*
* As a first step, we collect in 'popup_buffer' the HTML/Javascript code to
* perform the server request that fetches the HTML code we really want
* to see on the popup window:
*)
let popup_buffer = Buffer.create 1024 in
let popup_outch = new Netchannels.output_buffer popup_buffer in
stdlib_to_html
?context
~vars
~params:[ "popup_name", page_name;
"action", env.self_url ]
dlg
popup_outch
"wd-core-request-popup";
(* For the main window, we generate now the Javascript functions opening
* the popup window and writing the contents of 'popup_buffer' into that window
* (trigerring the server request).
*)
stdlib_to_html
?context ~vars
~params:[ "popup_name", page_name;
"data", Buffer.contents popup_buffer ]
dlg
outch
"wd-core-jsfunc-openserverpopup";
end
;;
class uidynamic =
object (self)
inherit page_tree
method private to_any ?(force_special=false) ?context ?vars dlg outch =
let vname, index = self # get_variable dlg in
let encodings =
match self # major_version with
1 ->
( match self # node # attribute "type" with
Value "text" -> [ "html" ]
| Value "html" -> [ ]
| _ -> []
)
| 2 ->
let special =
force_special || self # node # required_string_attribute "special" = "yes" in
( match self # node # attribute "enc" with
Value s ->
split s
| _ ->
[]
) @ (if special then [] else ["html"])
| _ -> assert false
in
let v = ref (self # string_variable dlg vname index) in
List.iter
(fun enc ->
let f =
try dlg # application # output_encoding enc
with
Not_found ->
raise(self#runtime_error("Unknown encoding: " ^ enc))
in
v := f !v
)
encodings;
outch # output_string !v;
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars dlg outch
method to_text ?context ?vars dlg outch =
match self # major_version with
1 -> self # to_html ?context ?vars dlg outch
| _ -> self # to_any ~force_special:true ?context ?vars dlg outch
end
;;
class uibutton =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let name = self # node # required_string_attribute "name" in
let goto = self # node # optional_string_attribute "goto" in
let label =
match self # node # attribute "label" with
Value s -> s
| Implied_value -> name
| _ -> assert false in
(* Add interactor and get 'id' *)
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some name
| _ -> assert false
in
let ia = dlg # interactors in (* needed anyway *)
let prefix, id =
match self # node # attribute "index" with
Implied_value ->
"button",
begin try
Wd_interactor.add ia.ui_buttons name "" cgi_id goto
with
Wd_interactor.Element_exists id -> id
end
| Value index ->
if cgi_id <> None then
raise(self # runtime_error("Button `" ^ name ^ "': cgi='keep' incompatible with presence of 'index' attribute"));
"xbutton",
begin try
Wd_interactor.add ia.ui_indexed_buttons name index None goto
with
Wd_interactor.Element_exists id -> id
end
| _ -> assert false
in
(* HTML: The name of the CGI parameter is "button_<id>". *)
(* ONCLICK: unfortunately, the function opener.popup_submit cannot
* figure out which button of the popup window was pressed.
* Because of this, the ONCLICK handler saves the name of the
* button.
*)
let user_onclick =
match self # node # optional_string_attribute "onclick" with
None -> ""
| Some s -> s
in
let s = sprintf
"<input type=submit name=\"%s_%s\" value=\"%s\" %s %s>"
prefix
id
(escape_html label)
(if vars.within_popup then
"onclick=\"opener.save_button_name('" ^ prefix ^ "_" ^ id ^ "'); "
^ escape_html user_onclick
^ "\""
else
if user_onclick <> "" then
"onclick=\"" ^ escape_html user_onclick ^ "\""
else
""
)
(self # other_attributes ["type"; "name"; "value"; "index";
"label"; "goto"; "cgi"; "onclick" ])
in
outch # output_string s
end
;;
class uirichbutton =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let name = self # node # required_string_attribute "name" in
let goto = self # node # optional_string_attribute "goto" in
(* Add interactor and get 'id' *)
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some name
| _ -> assert false
in
let ia = dlg # interactors in (* needed anyway *)
let prefix, id =
match self # node # attribute "index" with
Implied_value ->
"button",
begin try
Wd_interactor.add ia.ui_buttons name "" cgi_id goto
with
Wd_interactor.Element_exists id -> id
end
| Value index ->
if cgi_id <> None then
raise(self # runtime_error("Richbutton `" ^ name ^ "': cgi='keep' incompatible with presence of 'index' attribute"));
"xbutton",
begin try
Wd_interactor.add ia.ui_indexed_buttons name index None goto
with
Wd_interactor.Element_exists id -> id
end
| _ -> assert false
in
(* HTML: The name of the CGI parameter is "button_<id>". *)
(* ONCLICK: unfortunately, the function opener.popup_submit cannot
* figure out which button of the popup window was pressed.
* Because of this, the ONCLICK handler saves the name of the
* button.
*)
let user_onclick =
match self # node # optional_string_attribute "onclick" with
None -> ""
| Some s -> s
in
let s = sprintf
"<button type=\"submit\" name=\"%s_%s\" value=\"1\" %s %s>"
prefix
id
(if vars.within_popup then
"onclick=\"opener.save_button_name('" ^ prefix ^ "_" ^ id ^ "'); "
^ escape_html user_onclick
^ "\""
else
if user_onclick <> "" then
"onclick=\"" ^ escape_html user_onclick ^ "\""
else
""
)
(self # other_attributes ["name"; "type"; "index"; "value";
"goto"; "cgi"; "onclick" ])
in
outch # output_string s;
let n = self # node in
n # iter_nodes
(fun n' -> n' # extension # to_html ?context ~vars dlg outch);
outch # output_string "</button>";
end
;;
class uiimagebutton =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let name = self # node # required_string_attribute "name" in
let goto = self # node # optional_string_attribute "goto" in
let src = self # node # required_string_attribute "src" in
let align =
match self # node # attribute "align" with
Value s -> s
| Implied_value -> "BOTTOM"
| _ -> assert false in
(* Add interactor and get 'id' *)
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some name
| _ -> assert false
in
let ia = dlg # interactors in (* needed anyway *)
let prefix, id =
match self # node # attribute "index" with
Implied_value ->
"imagebutton",
begin try
Wd_interactor.add ia.ui_imagebuttons name "" cgi_id goto
with
Wd_interactor.Element_exists id -> id
end
| Value index ->
if cgi_id <> None then
raise(self # runtime_error("Imagebutton `" ^ name ^ "': cgi='keep' incompatible with presence of 'index' attribute"));
"ximagebutton",
begin try
Wd_interactor.add ia.ui_indexed_imagebuttons name index None goto
with
Wd_interactor.Element_exists id -> id
end
| _ -> assert false
in
(* HTML: The name of the CGI parameter is "imagebutton_<id>". *)
(* ONCLICK: unfortunately, the function opener.popup_submit cannot
* figure out which button of the popup window was pressed.
* Because of this, the ONCLICK handler saves the name of the
* button.
*)
let user_onclick =
match self # node # optional_string_attribute "onclick" with
None -> ""
| Some s -> s
in
let s = sprintf
"<input type=image name=\"%s_%s\" src=\"%s\" align=\"%s\" %s %s>"
prefix
id
(escape_html src)
(escape_html align)
(if vars.within_popup then
"onclick=\"opener.save_button_name('" ^ prefix ^ "_" ^ id ^ "'); "
^ escape_html user_onclick
^ "\""
else
if user_onclick <> "" then
"onclick=\"" ^ escape_html user_onclick ^ "\""
else
""
)
(self # other_attributes ["type"; "name"; "src"; "index";
"goto"; "cgi"; "align"; "onclick" ])
in
outch # output_string s
end
;;
class uianchor =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let name = self # node # required_string_attribute "name" in
let goto = self # node # optional_string_attribute "goto" in
(* Add interactor and get 'id' *)
let ia = dlg # interactors in (* needed anyway *)
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some name
| _ -> assert false
in
let prefix, (exists, id) =
match self # node # attribute "index" with
Implied_value ->
"anchor",
begin try
false, Wd_interactor.add ia.ui_anchors name "" cgi_id goto
with
Wd_interactor.Element_exists id -> true, id
end
| Value index ->
if cgi_id <> None then
raise(self # runtime_error("Anchor `" ^ name ^ "': cgi='keep' incompatible with presence of 'index' attribute"));
"xanchor",
begin try
false, Wd_interactor.add ia.ui_indexed_anchors name index None goto
with
Wd_interactor.Element_exists id -> true, id
end
| _ -> assert false
in
(* HTML: The name of the CGI parameter is "anchor_<id>". *)
let out = outch # output_string in
if not exists then
out (sprintf
"<input type=hidden name=\"%s_%s\" value=\"0\">"
prefix
id);
(* If exists: The hidden box has already been generated. *)
if vars.within_popup then
out (sprintf
"<a href=\"javascript:opener.popup_click(document,'%s','%s_%s',%s)\" %s>"
(escape_js vars.current_page)
prefix
id
(if dlg # is_server_popup_request then "1" else "0")
(self # other_attributes ["href"; "name"; "index"; "goto"; "cgi"])
)
else
out (sprintf
"<a href=\"javascript:uiform_click('%s_%s')\" %s>"
prefix
id
(self # other_attributes ["href"; "name"; "index"; "goto"; "cgi"]));
let n = self # node in
n # iter_nodes
(fun n' -> n' # extension # to_html ?context ~vars dlg outch);
out "</a>";
(*
Printf.bprintf buffer "<noscript><input type=submit name=\"%s_%s\" value=\"Go\"></noscript>"
prefix
id;
*)
(* Note: The "value" in the last input element must not be "0". *)
end
;;
class uicheckbox boxtype =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let id, vname, index = self # allocate_variable dlg in
let value = self # node # required_string_attribute "value" in
(* interactors: *)
let ia = dlg # interactors in
let pg = vars.current_page in
ia.ui_enumvars <- (vname,index,pg) :: ia.ui_enumvars;
(* HTML *)
let v =
match (dlg # variable_decl vname).var_type with
Enum_type _
| Dyn_enum_type ->
self # dyn_enum_variable dlg vname index
| String_type when boxtype = "radio" ->
let x = self # string_variable dlg vname index in
[ (x,x) ]
| _ ->
raise(Runtime_error("ui:select: bad type of variable `" ^
vname ^ "'"))
in
let checked = List.mem_assoc value v in
outch # output_string
(sprintf
"<input type=%s name=\"var_%s\" value=\"%s\" %s %s>"
boxtype
id
(escape_html value)
(if checked then "CHECKED" else "")
(self # other_attributes ["type"; "name"; "value"; "variable";
"index"; "cgi"]))
end
;;
class uiselect =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
let id, vname, index = self # allocate_variable dlg in
let multiple =
match self # node # attribute "multiple" with
Value "yes" -> true
| Value "no" -> false
| _ -> assert false in
let size =
match self # node # attribute "size" with
Value s -> "size=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
(* Interactors: *)
let ia = dlg # interactors in
let pg = vars.current_page in
ia.ui_enumvars <- (vname,index,pg) :: ia.ui_enumvars;
(* HTML: *)
let v =
match (dlg # variable_decl vname).var_type with
Enum_type _
| Dyn_enum_type ->
self # dyn_enum_variable dlg vname index
| String_type ->
if multiple then
raise(Runtime_error("ui:select is tied to the string variable `" ^
vname ^ "' but allows multiple selection"));
let x = self # string_variable dlg vname index in
[ (x,x) ]
| _ ->
raise(Runtime_error("ui:select: bad type of variable `" ^
vname ^ "'"))
in
let base_set =
try
let base,baseindex = self # get_base dlg in
self # dyn_enum_variable dlg base baseindex
with
Not_found ->
begin
match (dlg # variable_decl vname).var_type with
Enum_type e -> e.enum_definition
| Dyn_enum_type -> v
| String_type ->
raise(Runtime_error("ui:select is tied to a string variable, but a base variable is missing"))
| _ -> assert false
end
in
let out = outch # output_string in
out (sprintf
"<select name=\"var_%s\" %s %s %s>\n"
id
(if multiple then "multiple" else "")
size
(self # other_attributes ["name"; "variable"; "index"; "multiple";
"size"; "base"; "baseindex"; "cgi" ]));
List.iter
(fun (intern,extern) ->
let selected = List.mem_assoc intern v in
out (sprintf "<option value=\"%s\" %s>%s\n"
(escape_html intern)
(if selected then "selected" else "")
(escape_html extern))
)
base_set;
out "</select>"
end
;;
class uitranslate =
object (self)
inherit page_tree
method to_html ?context ?vars dlg outch =
let vtype = self # node # required_string_attribute "type" in
let intern =
match self # major_version with
1 -> self # node # required_string_attribute "intern"
| 2 -> self # node # required_string_attribute "internal"
| _ -> assert false
in
let e =
try dlg # declaration # enumeration vtype
with
Not_found ->
raise(self # runtime_error ("ui:translate does not find enumerator `" ^
vtype ^ "'"))
in
let extern =
try List.assoc intern e.enum_definition
with
Not_found ->
raise(self # runtime_error ("ui:translate does not find internal value `" ^
intern ^ "'"))
in
outch # output_string (escape_html extern)
method to_text ?context ?vars dlg outch =
self # to_html ?context ?vars dlg outch
end
;;
class uitext tagname = (* tagname = "text" or "password" *)
object (self)
inherit page_tree
method to_html ?context ?vars dlg outch =
let id, vname, index = self # allocate_variable dlg in
let maxlength =
match self # node # attribute "maxlength" with
Value s -> "maxlength=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
let size =
match self # node # attribute "size" with
Value s -> "size=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
let v = self # string_variable dlg vname index in
outch # output_string
(sprintf
"<input type=%s name=\"var_%s\" value=\"%s\" %s %s %s>"
tagname
id
(escape_html v)
maxlength
size
(self # other_attributes ["type"; "name"; "value"; "variable";
"index"; "maxlength"; "size"; "cgi"]))
end
;;
class uitextarea =
object (self)
inherit page_tree
method to_html ?context ?vars dlg outch =
let id, vname, index = self # allocate_variable dlg in
let rows =
match self # node # attribute "rows" with
Value s -> "rows=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
let cols =
match self # node # attribute "cols" with
Value s -> "cols=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
let wrap =
match self # node # attribute "wrap" with
Value s -> "wrap=\"" ^ escape_html s ^ "\""
| Implied_value -> ""
| _ -> assert false in
let v = self # string_variable dlg vname index in
outch # output_string
(sprintf
"<textarea name=\"var_%s\" %s %s %s %s>%s</textarea>"
id
rows
cols
wrap
(self # other_attributes ["name"; "variable"; "rows"; "cols";
"index"; "wrap"; "cgi"])
(escape_html v))
end
;;
class uifile =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
if vars.within_popup then begin
raise(self # runtime_error("File uploads within popups are not supported"));
end;
let name = self # node # required_string_attribute "name" in
let ui = dlg # interactors in
let cgi_id =
match self # node # required_string_attribute "cgi" with
"auto" -> None
| "keep" -> Some name
| _ -> assert false
in
let id =
try Wd_interactor.add ui.ui_uploads name "" cgi_id ()
with
Wd_interactor.Element_exists _ ->
raise(self # runtime_error("File upload element with name `" ^
name ^ "' is defined twice"))
in
outch # output_string
(sprintf "<input type=file name=\"upload_%s\" %s>"
id
(self # other_attributes ["type"; "name"; "cgi"]))
end
;;
let lookup_template dlg template_name =
(* look up the template:
* - If there is a language variable, try first
* template_name ^ "#" ^ language, then template_name
* - Otherwise only try template_name
* - raise Not_found if not found
*)
try
begin match dlg # declaration # language_variable with
None -> raise Not_found
| Some v ->
let lang = dlg # string_variable v in
dlg # application # template (template_name ^ "#" ^ lang)
(* or raise Not_found *)
end
with
Not_found ->
dlg # application # template template_name
;;
class ui_iterate_stuff =
object (self)
inherit page_tree
method private iterate ?(mode=`HTML) ?context ?vars dlg outch values =
let to_any =
match mode with
`HTML -> (fun n -> n # to_html ?context ?vars dlg outch)
| `Text -> (fun n -> n # to_text ?context ?vars dlg outch)
in
let template_name =
match self # node # attribute "template" with
Value s -> s
| _ -> assert false in
(* look up the template: *)
let template =
try lookup_template dlg template_name
with
Not_found ->
raise(self # runtime_error ("Unknown template `" ^
template_name ^ "'"))
in
(* get the parameters, and other configuration stuff *)
let base_params = ref [] in
let iter_empty = ref None in
let iter_head = ref None in
let iter_foot = ref None in
let iter_separator = ref None in
List.iter
(fun n ->
match n # node_type with
T_element "ui:param" ->
let param_name = n # required_string_attribute "name" in
base_params := (param_name, n#extension) :: !base_params
| T_element "ui:iter-empty" -> iter_empty := Some n
| T_element "ui:iter-head" -> iter_head := Some n
| T_element "ui:iter-foot" -> iter_foot := Some n
| T_element "ui:iter-separator" -> iter_separator := Some n
| _ -> ()
(* TODO: questionable. Ignore at least whitespace *)
)
( self # node # sub_nodes);
let dtd = self # node # dtd in
let data_exempl = new data_impl (new data_node) in
let new_data s = data_exempl # create_data dtd s in
if values = [] & !iter_empty <> None then begin
match !iter_empty with
Some n ->
to_any n#extension
| None ->
assert false
end
else begin
( match !iter_head with
Some n ->
to_any n#extension
| None ->
()
);
let is_first = ref true in
List.iter
(fun (intern,extern) ->
if not !is_first then
( match !iter_separator with
Some n ->
to_any n#extension
| None ->
()
);
is_first := false;
let tree_params =
!base_params @
( match self # major_version with
1 -> let intern_js = escape_js intern in
let extern_js = escape_js extern in
[ "intern", (new_data intern)#extension;
"intern_js", (new_data intern_js)#extension;
"extern", (new_data extern)#extension;
"extern_js", (new_data extern_js)#extension;
]
| 2 -> [ "int", (new_data intern)#extension;
"ext", (new_data extern)#extension;
]
| _ -> assert false
)
in
let inst_node =
try
template # instantiate ?context ?vars ~params:(D.of_alist tree_params) dlg
with
Instantiation_error msg ->
raise(self # runtime_error msg)
in
to_any inst_node
)
values;
( match !iter_foot with
Some n ->
to_any n#extension
| None ->
()
);
end
end
;;
type f_type = (* auxiliary definition for [to_any] below *)
syntax_tree_type ->
?context:syntax_tree_type dict ->
?vars:trans_vars -> dialog_type -> Netchannels.out_obj_channel ->
unit
;;
class uiuse =
object (self)
inherit page_tree
method private to_any ?context ?vars (f:f_type) dlg outch =
let template_name =
match self # node # attribute "template" with
Value s -> s
| _ -> assert false in
let template =
try lookup_template dlg template_name
with
Not_found ->
raise(self # runtime_error ("ui:use refers to unknown template `" ^
template_name ^ "'"))
in
(* get the tree parameters: *)
let tree_params =
D.of_alist
(List.map
(fun n ->
(* n: must be a "ui:param" element *)
assert (n # node_type = T_element "ui:param");
let param_name =
match n # attribute "name" with
Value s -> s
| _ -> assert false in
( param_name, n#extension )
)
( self # node # sub_nodes )
) in
let inst_node =
try
template # instantiate ?context ?vars ?params:(Some tree_params) dlg
with
Instantiation_error msg ->
raise(self # runtime_error msg)
in
f inst_node ?context ?vars dlg outch
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars (fun n -> n # to_html) dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ?context ?vars (fun n -> n # to_text) dlg outch
end
;;
class uiiterate =
object (self)
inherit ui_iterate_stuff
method private to_any ?mode ?context ?vars dlg outch =
let is_associative, vname, index = self # get_assoc_variable dlg in
let values =
if is_associative then
List.map
(fun (n,v) ->
match v with
String_value s -> n,s
| _ -> n, ""
)
(dlg # alist_variable vname)
else
match (dlg # variable_decl vname).var_type with
Dyn_enum_type ->
self # dyn_enum_variable dlg vname index
| String_type ->
let s = self # string_variable dlg vname index in
list_mapi (fun n word -> (string_of_int n),word) (split s)
| _ ->
raise(self # runtime_error("ui:iterate is not defined for this type of variable"))
in
self # iterate ?mode ?context ?vars dlg outch values
method to_html ?context ?vars dlg outch =
self # to_any ~mode:`HTML ?context ?vars dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ~mode:`Text ?context ?vars dlg outch
end
;;
class uienumerate =
object (self)
inherit ui_iterate_stuff
method private to_any ?mode ?context ?vars dlg outch =
let values =
match self # node # attribute "type" with
Value s ->
let e =
try dlg # declaration # enumeration s
with Not_found ->
raise(self # runtime_error ("ui:enumerate with unknown type `" ^
s ^ "'"))
in
begin
match self # node # attribute "variable" with
Implied_value -> ()
| _ ->
raise(self # runtime_error "ui:enumerate with both attributes 'type' and 'variable' not allowed")
end;
e.enum_definition
| Implied_value ->
let vname, index = self # get_variable dlg in
self # dyn_enum_variable dlg vname index
| _ -> assert false
in
self # iterate ?mode ?context ?vars dlg outch values
method to_html ?context ?vars dlg outch =
self # to_any ~mode:`HTML ?context ?vars dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ~mode:`Text ?context ?vars dlg outch
end
;;
type f'_type = (* auxiliary definition for [to_any] below *)
unit ->
?context:syntax_tree_type dict ->
?vars:trans_vars -> dialog_type -> Netchannels.out_obj_channel->
unit
;;
class uiifvar =
object (self)
inherit page_tree
inherit mixin_skip_output as skipper
(* Note: ui:ifvar is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method private to_any ?context ?vars (f:f'_type) dlg outch =
let get_var_value() =
let name,index = self # get_variable ~allow_assoc:true dlg in
let v = dlg # variable name in
match index with
None -> v
| Some k -> (* ==> the variable is associative *)
(match v with
Alist_value alist ->
(try List.assoc k alist
with
Not_found ->
raise(self # runtime_error("Variable `" ^ name ^ "' not defined for index value `" ^ k ^ "'"))
)
| _ -> assert false
)
in
let op = self # node # required_string_attribute "op" in
let args =
[ lazy(get_var_value());
lazy(String_value(self # node # required_string_attribute "value")) ] in
let f_op =
try dlg # application # lazy_var_function op
with
Not_found ->
raise(self#runtime_error ("No such function: " ^ op)) in
let r =
try
f_op dlg args
with
Failure msg ->
raise(self#runtime_error msg) in
let do_output =
match r with
| String_value s ->
let n =
try int_of_string s
with _ ->
raise(self#runtime_error "Return value must be boolean for ui:ifvar") in
n <> 0
| _ ->
raise(self#runtime_error "Return value must be boolean for ui:ifvar")
in
if do_output then
f () ?context ?vars dlg outch;
match vars with
Some v -> v.condition_code <- do_output;
| None -> ()
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_html) dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_text) dlg outch
end
;;
class uiif =
object (self)
inherit page_tree
inherit mixin_skip_output as skipper
(* Note: ui:if is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method private to_any ?context ?vars (f:f'_type) dlg outch =
let rec get_values n =
match self # node # optional_string_attribute ("value" ^ string_of_int n) with
| None -> []
| Some s -> s :: (get_values (n+1)) in
let op = self # node # required_string_attribute "op" in
let args =
List.map (fun s -> lazy(String_value s)) (get_values 1) in
let f_op =
try dlg # application # lazy_var_function op
with
Not_found ->
raise(self#runtime_error ("No such function: " ^ op)) in
let r =
try
f_op dlg args
with
Failure msg ->
raise(self#runtime_error msg) in
let do_output =
match r with
| String_value s ->
let n =
try int_of_string s
with _ ->
raise(self#runtime_error "Return value must be boolean for ui:if") in
n <> 0
| _ ->
raise(self#runtime_error "Return value must be boolean for ui:if")
in
if do_output then
f () ?context ?vars dlg outch;
match vars with
Some v -> v.condition_code <- do_output;
| None -> ()
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_html) dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_text) dlg outch
end
;;
class uiifexpr =
object (self)
inherit page_tree
inherit mixin_skip_output as skipper
(* Note: ui:ifexpr is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method private to_any ?context ?vars (f:f'_type) dlg outch =
let expr = self # node # required_string_attribute "expr" in
let do_output =
let n =
try int_of_string expr
with _ ->
raise(self#runtime_error "Expression must be boolean for ui:ifexpr") in
n <> 0
in
if do_output then
f () ?context ?vars dlg outch;
match vars with
Some v -> v.condition_code <- do_output;
| None -> ()
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_html) dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_text) dlg outch
end
;;
class uiiflang =
object (self)
inherit page_tree
inherit mixin_skip_output as skipper
(* Note: ui:iflang is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method private to_any ?context ?vars (f:f'_type) dlg outch =
let lang = self # node # required_string_attribute "xml:lang" in
let do_output =
match dlg # declaration # language_variable with
None -> false
| Some v ->
let lang' = dlg # string_variable v in
lang = lang'
in
if do_output then
f () ?context ?vars dlg outch;
match vars with
Some v -> v.condition_code <- do_output;
| None -> ()
method to_html ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_html) dlg outch
method to_text ?context ?vars dlg outch =
self # to_any ?context ?vars (fun () -> skipper # to_text) dlg outch
end
;;
exception Cond_exit
class uicond =
object (self)
inherit page_tree
(* Note: ui:cond is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
vars.condition_code <- false;
try
self # node # iter_nodes
(fun n ->
n # extension # to_html ?context ~vars dlg outch;
if vars.condition_code then raise Cond_exit
);
with
Cond_exit -> ()
method to_text ?context ?(vars=raise self#bad_context) dlg outch =
vars.condition_code <- false;
try
self # node # iter_nodes
(fun n ->
n # extension # to_text ?context ~vars dlg outch;
if vars.condition_code then raise Cond_exit
);
with
Cond_exit -> ()
end
;;
class uifalse =
object (self)
inherit page_tree
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
vars.condition_code <- false;
method to_text ?context ?(vars=raise self#bad_context) dlg outch =
vars.condition_code <- false;
end
;;
class uitrue =
object (self)
inherit page_tree
inherit mixin_skip_output as super
(* Note: ui:true is subject to whitespace normalization. See
* [normalize_whitespace] below.
*)
method to_html ?context ?(vars=raise self#bad_context) dlg outch =
super # to_html ?context ~vars dlg outch;
vars.condition_code <- true;
method to_text ?context ?(vars=raise self#bad_context) dlg outch =
super # to_text ?context ~vars dlg outch;
vars.condition_code <- true;
end
;;
class uispecial =
object (self)
inherit page_tree
inherit mixin_skip_output
method to_html ?context ?vars dlg outch =
(* The difference: data is not html-escaped. *)
self # to_text ?context ?vars dlg outch
end
;;
(**********************************************************************)
open Pxp_yacc
let mk_tag_map () =
let make ext = new element_impl ext in
make_spec_from_alist
~data_exemplar:
(new data_impl (new data_node))
~default_element_exemplar:
(make (new default_node))
~element_alist:
[ "ui:application", (make (new uiapplication));
"ui:object", (make (new uidialog)); (* DTD version 1.1 *)
"ui:dialog", (make (new uidialog));
"ui:template", (make (new uitemplate));
"ui:expectparam", (make (new uidefault)); (* DTD version 1.1 *)
"ui:enumeration", (make (new uienumeration));
"ui:enum", (make (new uienum));
"ui:variable", (make (new uivariable));
"ui:string-value",(make (new uistringvalue));
"ui:enum-value", (make (new uienumvalue));
"ui:enum-item", (make (new uienumitem));
"ui:dyn-enum-value", (make (new uidynenumvalue));
"ui:dyn-enum-item", (make (new uidynenumitem));
"ui:alist-value", (make (new uialistvalue));
"ui:alist-item", (make (new uialistitem));
"ui:default", (make (new uidefault));
"ui:page", (make (new uipage));
"ui:dynamic", (make (new uidynamic));
"ui:form", (make (new uiform));
"ui:popup", (make (new uipopup));
"ui:server-popup",(make (new uiserverpopup));
"ui:button", (make (new uibutton));
"ui:imagebutton", (make (new uiimagebutton));
"ui:richbutton", (make (new uirichbutton));
"ui:a", (make (new uianchor));
"ui:checkbox", (make (new uicheckbox "checkbox"));
"ui:radio", (make (new uicheckbox "radio"));
"ui:select", (make (new uiselect));
"ui:extern", (make (new uitranslate)); (* DTD version 1.1 *)
"ui:translate", (make (new uitranslate));
"ui:text", (make (new uitext "text"));
"ui:password", (make (new uitext "password"));
"ui:textarea", (make (new uitextarea));
"ui:file", (make (new uifile));
"ui:use", (make (new uiuse));
"ui:param", (make (new container));
"ui:iterate", (make (new uiiterate));
"ui:enumerate", (make (new uienumerate));
"ui:guard", (make (new uiifvar)); (* DTD version 1.1 *)
"ui:ifvar", (make (new uiifvar));
"ui:if", (make (new uiif));
"ui:ifexpr", (make (new uiifexpr));
"ui:iflang", (make (new uiiflang));
"ui:cond", (make (new uicond));
"ui:true", (make (new uitrue));
"ui:false", (make (new uifalse));
"ui:context", (make (new uicontext));
"ui:special", (make (new uispecial));
"ui:iter-empty", (make (new container));
"ui:iter-head", (make (new container));
"ui:iter-foot", (make (new container));
"ui:iter-separator", (make (new container));
"ui:encode", (make (new uiencode));
"ui:library", (make (new default_node));
"ui:libtemplate", (make (new uilibtemplate));
]
()
;;
let tag_map = ref (mk_tag_map());;
(*
let reset() =
tag_map := mk_tag_map()
;;
*)
let rec normalize_whitespace xml_preserve_space tree =
(* Removes whitespace at the following locations:
* - After the start tags <ui:template>, <ui:page>, <ui:guard>, <ui:context>,
* and before the corresponding end tags
* - After the end tags </ui:expectparam>, </ui:param>, and </ui:default>
* (but only if they occur inside of one of the elements mentioned first)
*)
let strip_left s =
let k = ref 0 in
while !k < String.length s &&
(let c = s.[ !k ] in
c = ' ' || c = '\n' || c = '\r' || c = '\t')
do
incr k
done;
if !k > 0 then
String.sub s !k (String.length s - !k)
else
s
in
let strip_right s =
let l = String.length s in
let k = ref (l-1) in
while !k >= 0 &&
(let c = s.[ !k ] in
c = ' ' || c = '\n' || c = '\r' || c = '\t')
do
decr k
done;
if !k < l-1 then
String.sub s 0 (!k + 1)
else
s
in
let visit_sub_nodes xml_preserve_space tree =
tree # iter_nodes
(fun sub ->
match sub # node_type with
| T_element _ ->
normalize_whitespace xml_preserve_space sub
| _ ->
()
);
in
match tree # node_type with
T_element "ui:template"
| T_element "ui:libtemplate"
| T_element "ui:page"
| T_element "ui:guard"
| T_element "ui:if"
| T_element "ui:ifexpr"
| T_element "ui:ifvar"
| T_element "ui:iflang"
| T_element "ui:cond"
| T_element "ui:true"
| T_element "ui:context" ->
(* Remove whitespace at the beginning of the sub list, and at the
* end. Interpret xml:space.
*)
let xml_preserve_space =
match
try tree # attribute "xml:space" with Not_found -> Implied_value
with
Value "preserve" -> true
| Value "ignore" -> false
| _ -> xml_preserve_space
in
if not xml_preserve_space then begin
let left_side_done = ref false in
let right_side = ref None in
tree # iter_nodes
(fun sub ->
match sub # node_type with
| T_data ->
if not !left_side_done then begin
let s = strip_left (sub # data) in
sub # set_data s;
if s = "" then
sub # delete
else begin
left_side_done := true;
right_side := Some sub; (* candidate for right side *)
end
end
else right_side := Some sub
| T_element "ui:expectparam" (* DTD version 1 *)
| T_element "ui:default"
| T_element "ui:param" ->
right_side := None;
normalize_whitespace xml_preserve_space sub
| T_element _ ->
left_side_done := true;
right_side := None;
normalize_whitespace xml_preserve_space sub
| T_comment ->
()
| _ ->
left_side_done := true;
right_side := None;
);
match !right_side with
None ->
()
| Some sub ->
let s = strip_right (sub # data) in
sub # set_data s;
if s = "" then sub # delete;
end
else
visit_sub_nodes xml_preserve_space tree
| T_element _ ->
let xml_preserve_space =
match
try tree # attribute "xml:space" with Not_found -> Implied_value
with
Value "preserve" -> true
| Value "ignore" -> false
| _ -> xml_preserve_space
in
visit_sub_nodes xml_preserve_space tree
| _ ->
()
;;
let rec transl_shorthand_notations n =
(* Translates <t:NAME> and <q:NAME> to <ui:use>;
* translates <p:NAME> to <ui:param>;
* translates <l:LANG> to <ui:iflang>;
* returns the new tree
*)
let transl_error n msg =
let ent,line,pos = n # position in
if line >= 1 then
raise(
Formal_user_error("Entity " ^ ent ^ ", line " ^ string_of_int line ^
", position " ^ string_of_int pos ^ ": " ^ msg))
else
raise(
Formal_user_error(msg ^
" - Sorry, cannot remember where this error occurs"));
in
let visit_subnodes n =
let changed = ref false in
let new_nodes =
List.map
(fun sub ->
let sub' = transl_shorthand_notations sub in
changed := !changed || sub <> sub';
sub'
)
n#sub_nodes in
if !changed then n # set_nodes new_nodes;
(* Call [set_nodes] only if really nodes have been exchanged.
* [set_nodes] is expensive.
*)
n
in
let transl_l eltype =
(* Translate <l:LANG>CONTENTS</l:LANG> to
* <ui:iflang xml:lang="LANG">CONTENTS</ui:iflang>
*)
let lang = String.sub eltype 2 (String.length eltype - 2) in
let n' =
Pxp_document.create_element_node
~position:n#position
~att_values:[ "xml:lang", Value lang ]
!tag_map
n#dtd
"ui:iflang"
[] in
(* Move the subnodes from n to n': *)
let subnodes = n # sub_nodes in
n # set_nodes []; (* Important! The [subnodes] are now orphaned *)
n' # set_nodes subnodes;
(* Finally descend into the tree: *)
visit_subnodes n'
in
let transl_p eltype =
(* Translate <p:NAME>CONTENTS</p:NAME> to
* <ui:param name="NAME">CONTENTS</ui:param>
*)
let name = String.sub eltype 2 (String.length eltype - 2) in
let n' =
Pxp_document.create_element_node
~position:n#position
~att_values:[ "name", Value name ]
!tag_map
n#dtd
"ui:param"
[] in
(* Move the subnodes from n to n': *)
let subnodes = n # sub_nodes in
n # set_nodes []; (* Important! The [subnodes] are now orphaned *)
n' # set_nodes subnodes;
(* Finally descend into the tree: *)
visit_subnodes n'
in
let transl_t eltype =
(* Translate <t:NAME PARAM1="VALUE1" PARAM2="VALUE2"...>CONTENTS</t:NAME> to
* <ui:use template="NAME">
* <ui:param name="PARAM1">VALUE1</ui:param>
* <ui:param name="PARAM2">VALUE2</ui:param>
* ...
* CONTENTS
* </ui:use>
* Furthermore, it is checked that the CONTENTS consist only of <p:NAME>
* nodes.
*)
let dtd = n#dtd in
let name = String.sub eltype 2 (String.length eltype - 2) in
let position = n#position in
let n' =
Pxp_document.create_element_node
~position
~att_values:[ "template", Value name ]
!tag_map
dtd
"ui:use"
[] in
(* Translate the attributes to <ui:param> nodes: *)
let att_params =
List.map
(fun (n,v) ->
let p =
Pxp_document.create_element_node
~position
~att_values:[ "name", Value n ]
!tag_map
dtd
"ui:param"
[] in
let data =
match v with
Value s -> s
| _ -> assert false
in
let d =
Pxp_document.create_data_node !tag_map dtd data in
p # set_nodes [d];
p
)
n#attributes in
(* Check whether the subnodes are valid: *)
n # iter_nodes
(fun p ->
match p # node_type with
T_element eltype ->
if String.length eltype < 2 || eltype.[0] <> 'p' ||
eltype.[1] <> ':'
then
transl_error p "This element type is not allowed here"
| T_data ->
(* The node must only consist of white space. Delete it *)
if only_whitespace (p # data) then
p # delete
else
transl_error n "Character data are not allowed in this element"
| _ ->
transl_error n "Something is not allowed here"
);
(* Move the subnodes from n to n': *)
let subnodes = n # sub_nodes in
n # set_nodes []; (* Important! The [subnodes] are now orphaned *)
n' # set_nodes (att_params @ subnodes);
(* Finally descend into the tree: *)
visit_subnodes n'
in
let transl_q eltype =
(* Translate <q:NAME PARAM1="VALUE1" PARAM2="VALUE2"...>CONTENTS</q:NAME> to
* <ui:use template="NAME">
* <ui:param name="PARAM1">VALUE1</ui:param>
* <ui:param name="PARAM2">VALUE2</ui:param>
* ...
* <ui:param name="body">CONTENTS</ui:param>
* </ui:use>
*)
let dtd = n#dtd in
let name = String.sub eltype 2 (String.length eltype - 2) in
let position = n#position in
let n' =
Pxp_document.create_element_node
~position
~att_values:[ "template", Value name ]
!tag_map
dtd
"ui:use"
[] in
(* Translate the attributes to <ui:param> nodes: *)
let att_params =
List.map
(fun (n,v) ->
let p =
Pxp_document.create_element_node
~position
~att_values:[ "name", Value n ]
!tag_map
dtd
"ui:param"
[] in
let data =
match v with
Value s -> s
| _ -> assert false
in
let d =
Pxp_document.create_data_node !tag_map dtd data in
p # set_nodes [d];
p
)
n#attributes in
(* Create the body parameter: *)
let body_param =
Pxp_document.create_element_node
~position
~att_values:[ "name", Value "body" ]
!tag_map
dtd
"ui:param"
[] in
(* Move the subnodes from n to body_param: *)
let subnodes = n # sub_nodes in
n # set_nodes []; (* Important! The [subnodes] are now orphaned *)
body_param # set_nodes subnodes;
n' # set_nodes (att_params @ [body_param]);
(* Finally descend into the tree: *)
visit_subnodes n'
in
match n # node_type with
T_element eltype ->
if String.length eltype >= 2 && eltype.[1] = ':' then begin
match eltype.[0] with
't' ->
transl_t eltype
| 'q' ->
transl_q eltype
| 'p' ->
transl_p eltype
| 'l' ->
transl_l eltype
| _ ->
visit_subnodes n
end
else
visit_subnodes n
| _ ->
n
;;
let rec transl_ui_context n =
(* Translates
* <ui:context>
* <ui:param .../>
* <ui:param .../>
* ...
* other
* </ui:context>
*
* to:
* <ui:context>
* <ui:internal:container>
* <ui:param .../>
* <ui:param .../>
* ...
* </ui:internal:container>
* other
* </ui:context>
*
* This avoids ambiguities (e.g. <ui:context><ui:param .../>$body</ui:context> -
* without the translation the replacement of $body is taken as another context
* parameter).
*
* This must happen after whitespace normalization.
*)
let visit_sub_nodes tree =
tree # iter_nodes
(fun sub ->
match sub # node_type with
| T_element _ ->
transl_ui_context sub
| _ ->
()
);
in
let rec split_list l =
match l with
| x :: l' when x#node_type = T_element "ui:param" ->
let params, non_params = split_list l' in
(x :: params, non_params)
| _ :: l' ->
( [], l )
| [] ->
( [], [] ) in
match n # node_type with
| T_element "ui:context" ->
let params, non_params = split_list n # sub_nodes in
let container =
Pxp_document.create_element_node
!tag_map
n#dtd
"ui:internal:container"
[] in
List.iter
(fun param ->
param # remove(); (* Remove from ui:context children *)
container # append_node param;
)
params;
n # insert_nodes ?pos:(Some 0) [container];
visit_sub_nodes n
| T_element _ ->
visit_sub_nodes n
| _ ->
()
;;
let restore_stdlib dtd =
let stdlib_string =
match (dtd # encoding : Pxp_types.rep_encoding :> Pxp_types.encoding) with
`Enc_iso88591 -> Wd_stdlib.stdlib_iso88591_1
| `Enc_utf8 -> Wd_stdlib.stdlib_utf8_1
| e -> failwith ("WDialog restriction: This encoding is not supported: " ^ Netconversion.string_of_encoding e)
in
let stdlib_pos = ref 0 in
try
let tree =
Pxp_marshal.subtree_from_cmd_sequence
(fun () ->
let p = !stdlib_pos in
stdlib_pos := !stdlib_pos + Marshal.total_size stdlib_string p;
Marshal.from_string stdlib_string p
)
dtd
!tag_map
in
normalize_whitespace false tree;
ignore(transl_shorthand_notations tree);
transl_ui_context tree;
tree
with
error ->
failwith ("Wd_transform.restore_stdlib: " ^ Printexc.to_string error)
;;
let string_error = string_of_exn;;
let catalog =
[ "-//NPC//DTD WDIALOG 1.1//EN", Wd_application_dtd.dtd_1;
"-//NPC//DTD WDIALOG 2.1//EN", Wd_application_dtd.dtd_2;
"-//NPC//DTD WDIALOG 2.2//EN", Wd_application_dtd.dtd_2;
"-//NPC//DTD WDIALOG 2.3//EN", Wd_application_dtd.dtd_2;
];;
let xml_parse_uiapplication charset filename =
let url = Pxp_reader.make_file_url filename in
let resolver =
new Pxp_reader.combine
[ Pxp_reader.lookup_public_id_as_string catalog;
new Pxp_reader.resolve_as_file();
]
in
try
(* reset(); *)
let doc =
parse_document_entity
{ default_config with Pxp_yacc.encoding = charset }
(ExtID (System (Neturl.string_of_url url), resolver))
!tag_map
in
if Pxp_dtd.Entity.replacement_text (doc#dtd#par_entity "major-version")
<> "1"
then begin
normalize_whitespace false doc#root;
(* The DTD version 1 did not normalize whitespace *)
ignore(transl_shorthand_notations doc#root);
transl_ui_context doc#root;
end;
doc
with
( At (_,_) | Validation_error _ | Error _ | WF_error _ |
Character_not_supported | Undeclared ) as x ->
raise (Formal_user_error (string_error x))
;;
let restore_uiapplication tree =
let app = new Wd_application.application tree#dtd in
let stdlib = restore_stdlib tree#dtd in
stdlib # root # extension # scan_application app;
tree # root # extension # scan_application app;
app # study();
app
;;
let parse_uiapplication ?(charset = `Enc_iso88591) filename =
let tree = xml_parse_uiapplication charset filename in
restore_uiapplication tree
;;
let load_uiapplication ?(charset = `Enc_iso88591) filename =
(* reset(); *)
let ch = open_in filename in
let tree = try
let warner = Pxp_yacc.default_config.Pxp_yacc.warner in
let config =
{ Pxp_yacc.default_config
with
Pxp_yacc.encoding = charset;
Pxp_yacc.accept_only_deterministic_models = false;
} in
let pubid =
(Marshal.from_channel ch : string) in
let dtd =
try
let dtd_string = List.assoc pubid catalog in
Pxp_yacc.parse_dtd_entity config (Pxp_yacc.from_string dtd_string)
with
Not_found ->
failwith ("This version of WDIALOG does not define the PUBLIC ID "
^ pubid)
in
dtd # set_id (External (Public(pubid, "")));
dtd # set_root "ui:application"; (* always the same *)
let nodes =
Pxp_marshal.subtree_from_channel
ch
dtd
!tag_map
in
let doc = new Pxp_document.document warner dtd#encoding in
doc # init_xml_version "1.0";
doc # init_root nodes (match dtd#root with Some x -> x | _ -> assert false);
close_in ch;
doc
with
any -> close_in ch; raise any
in
restore_uiapplication tree
;;
(**********************************************************************)
let to_text ?context ?vars (dlg : dialog_type) outch (node : syntax_tree_type) =
let context' =
match context with
None -> dlg # declaration # default_context
| Some c -> c in
node # to_text ~context:context' ?vars dlg outch
;;
let to_html ?context ?vars (dlg : dialog_type) outch (node : syntax_tree_type) =
let context' =
match context with
None -> dlg # declaration # default_context
| Some c -> c in
node # to_html ~context:context' ?vars dlg outch
(* TODO: (init_vars mode in_popup) *)
;;
let instantiate ?context ?params dlg (template:template_type) =
template # instantiate ?context ?params dlg
;;
let mk_use_param_node dtd name params =
let uiuse_node =
create_element_node
!tag_map
dtd
"ui:use"
[ "template", name ] in
List.iter
(fun (param_name, param_t) ->
let uiparam_node =
create_element_node
!tag_map
dtd
"ui:param"
[ "name", param_name ] in
uiparam_node # add_node (param_t # node);
uiuse_node # add_node uiparam_node;
)
params;
uiuse_node # extension
;;
let mk_text_node dtd text =
(create_data_node !tag_map dtd text) # extension
;;
let mk_html_node dtd text =
let uispecial_node =
create_element_node
!tag_map
dtd
"ui:special"
[] in
let html_node =
create_data_node !tag_map dtd text in
uispecial_node # add_node html_node;
uispecial_node # extension
;;
let concat ?sep dtd l =
let container = new_container() in
let rec dorec (c : container node) l =
match l with
[] -> ()
| [ x ] -> c # add_node (x # node)
| x :: l' ->
(* l' is not empty *)
(* If x is already an orphan, simply add it to the new tree.
* If x is not an orphan, make a copy.
*)
let y = x # node in
let y' =
try ignore(y # parent); y # orphaned_clone
with Not_found -> y
in
c # add_node y';
begin match sep with
None -> ()
| Some sep0 ->
(* Same logic for 'sep' *)
let s = sep0 # node in
let sep' =
try ignore(s # parent); s # orphaned_clone
with Not_found -> s
in
c # add_node sep';
end;
dorec c l'
in
match l with
[] -> mk_text_node dtd ""
| [ x ] -> x
| _ ->
let c =
container # create_element
dtd
(T_element "ui:internal:container")
[] in
dorec c l;
c # extension
;;
let compile ?(charset = `Enc_iso88591) filename out =
let tree = xml_parse_uiapplication charset filename in
let dtd = tree # dtd in
let id = dtd # id in
let pubid =
match id with
Some (External (Public(p,s))) -> p
| Some (External (System s)) ->
failwith "compile: needs a PUBLIC identifier of the DTD"
| Some (Derived (Public(p,s))) ->
prerr_endline "Warning: The DTD has both an internal and an external subset. The element, attribute, notation, and pi declarations of the internal subset are ignored and not included into the binary format. (Entities do not cause problems.)";
p
| Some (Derived (System s)) ->
failwith "compile: needs a PUBLIC identifier of the DTD"
| Some Internal ->
failwith "compile: needs an external DTD"
| None ->
failwith "compile: needs a DTD"
| _ ->
failwith "compile: something is wrong with the DTD"
in
Marshal.to_channel out pubid [];
Pxp_marshal.subtree_to_channel
(* ~omit_positions:true *)
out
(tree # root)
;;
let pxp_spec() = !tag_map;;
(* ======================================================================
* History:
*
* $Log: wd_transform.ml,v $
* Revision 3.26 2005-08-31 18:08:49 stolpmann
* Fix ui:ifexpr
*
* Revision 3.25 2005/08/31 14:51:31 stolpmann
* Fix in the error handling of ui:select
*
* Revision 3.24 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.23 2003/02/21 14:34:37 stolpmann
* New: enum special form for bracket expressions.
*
* Revision 3.22 2003/02/16 23:48:15 stolpmann
* Improved wd-debug-mode: there are now two styles
*
* Revision 3.21 2003/02/16 21:33:58 stolpmann
* Renamed ui:longbutton into ui:richbutton
*
* Revision 3.20 2002/11/13 02:02:50 stolpmann
* Added: op="mentions"
*
* Revision 3.19 2002/11/12 23:36:43 stolpmann
* Enhancement: ui:radio accepts string variables. ui:select
* accepts them, too, but only for single-selection boxes.
*
* Revision 3.18 2002/11/09 15:48:59 stolpmann
* Added missing ui:true and ui:false implementations.
*
* Revision 3.17 2002/11/09 11:41:19 stolpmann
* Fix: ui:select accepts dot notation. A new method
* variable_decl needs to be defined for dialogs. This method
* returns the var_decl record and interprets the dot notation.
*
* Revision 3.16 2002/11/03 21:17:48 stolpmann
* New functions: type, is_associative, default
*
* Revision 3.15 2002/11/03 19:59:39 stolpmann
* ui:iterate works now for associative variables that are not
* strings. The $ext parameter is set to the empty string.
*
* Revision 3.14 2002/10/20 19:39:17 stolpmann
* New feature: The brackets $[...] can contain expressions,
* not only variables
*
* Revision 3.13 2002/10/12 23:09:03 stolpmann
* Enhancement: ui:iterate can now iterate over strings. The
* strings are splitted into whitespace-separated words. $int is the
* index of the word >= 0, and $ext is the word itself.
*
* Revision 3.12 2002/10/12 22:17:22 stolpmann
* New element: ui:longbutton
*
* Revision 3.11 2002/09/25 00:15:40 stolpmann
* Fix for PXP-1.1.92
*
* Revision 3.10 2002/03/19 23:31:19 stolpmann
* Fix: [compile] outputs to the passed channel, not to stdout.
*
* Revision 3.9 2002/03/19 23:27:09 stolpmann
* When loading a compiled XML file, the ID and the name of the
* root element of the DTD object are set to reasonable values.
*
* Revision 3.8 2002/02/28 22:25:23 stolpmann
* Typo (ui:gurad -> ui:guard)
*
* Revision 3.7 2002/02/28 22:05:19 stolpmann
* Fix: Skipping over whitespace between <ui:expectparam> elements
* for DTD version 1
*
* Revision 3.6 2002/02/28 18:52:09 stolpmann
* Bugfix for DTD version 1
*
* Revision 3.5 2002/02/27 00:02:17 stolpmann
* Fix: Integer comparison for ui:if, ui:ifvar works now.
*
* Revision 3.4 2002/02/26 16:01:58 stolpmann
* Fix: ui:iterate and ui:enumerate work now in attribute context.
*
* Revision 3.3 2002/02/16 17:29:45 stolpmann
* mostly ocamldoc.
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:29:21 stolpmann
* Initial release at sourceforge.
*
* Revision 1.44 2002/02/07 18:49:59 gerd
* Standard library
*
* Revision 1.43 2002/02/05 18:49:55 gerd
* Fix: Empty HTML elements are printed without end tag.
* Support for the new DTD features: <?wd-debug-mode?>,
* <?wd-prototype-mode?>, <?wd-onstartup-call-handle?>, and the
* attributes "protected" and "popup".
* The CGI variable containing the session state is now
* called "uiobject_session" (instead of "uiobject_state" and
* "uiobjtect_name"). Session managers are used to serialize
* sessions.
*
* Revision 1.42 2002/01/31 23:06:39 gerd
* Revised conditional expansion (ui:if, ui:ifvar, ui:iflang,
* ui:cond).
* Added some support for internationalization (xml:lang).
*
* Revision 1.41 2002/01/30 15:15:25 gerd
* New: ~charset
* Support for ${name/enc1/enc2/...} and $[name/enc1/enc2/...]
* <ui:dynamic> with enc and special attributes
* <ui:encode>
*
* Revision 1.40 2002/01/28 02:13:55 gerd
* Added shorthand notations <t:NAME>, <q:NAME>, <p:NAME>.
* ui:dynamic uses now the enc attribute to determine the encodings.
*
* Revision 1.39 2002/01/27 19:14:20 gerd
* Revised template definitions (ui:template, ui:default, ui:context)
*
* Revision 1.38 2002/01/26 22:38:26 gerd
* Changed the type for passing parameters to templates. It is
* now syntax_tree dict instead of a simple list. Furthermore, the
* method [instantiate] no longer returns the new context. The new element
* ui:context creates the new contexts now.
*
* Revision 1.37 2002/01/24 23:37:25 gerd
* <ui:template> and <ui:page> ignore whitespace at the beginning
* and at the end of the list of subnodes.
* Templates can be studied.
* On instantiation, the special exception [Instantiation_error]
* is raised when an error happens. So the caller can reports its own
* line number.
*
* Revision 1.36 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.35 2001/04/05 12:57:18 gerd
* Changed the binary format: It does no longer contain the DTD
* textually, but only the PUBLIC identifier.
*
* Revision 1.34 2001/04/04 16:39:53 gerd
* Bugfix
*
* Revision 1.33 2001/04/04 16:22:42 gerd
* Bugfix
*
* Revision 1.32 2001/04/04 16:19:14 gerd
* Versions for the DTD.
*
* Revision 1.31 2001/04/03 14:39:21 gerd
* The parser accepts now a PUBLIC("-//NPC/DTD WDIALOG//EN","")
* ID as ID for the DTD. In this case, the built-in DTD (latest version)
* is used.
*
* Revision 1.30 2001/04/03 12:46:23 gerd
* Workaround for IE-5.5: current_popup was sometimes not set.
* This is a bug in IE-5.5, but it can be avoided by setting
* current_popup earlier when windows are opened.
*
* Revision 1.29 2001/03/13 18:30:44 gerd
* ui:expectparam has new attribute force-default.
*
* Revision 1.28 2001/02/26 18:11:50 gerd
* After some trouble: The character '%' is now considered
* as being unsafe even for the escape_js function. Even though it is
* not strictly required, this step reduces the likeliness of quoting
* errors.
*
* Revision 1.27 2001/01/15 12:28:31 gerd
* Improvement for Netscape 4.04
*
* Revision 1.26 2001/01/08 17:13:21 gerd
* Improvement: The user can now specify an onclick handler for
* ui:button and ui:imagebutton even if the button is in a popup
* dialogue. The user's handler is simply appended to the
* generated handler: onclick="generated; user"
*
* Revision 1.25 2001/01/08 11:27:12 gerd
* Fix in Javascript code for older browsers.
*
* Revision 1.24 2000/12/21 15:51:43 gerd
* ui:iterate and ui:enumerate now set the parameters intern_js
* and extern_js, too. These correspond to intern and extern, resp., but
* are Javascript-quoted.
*
* Revision 1.23 2000/12/21 15:00:37 gerd
* Server popups: The generated "open" function has now a second
* parameter which is passed back to the application. The Popup_request
* event gets this parameter. The parameter can be used freely by the
* application.
*
* Revision 1.22 2000/12/21 12:08:04 gerd
* Bugfix: Clicked submit buttons in popup windows are now passed
* back to the applications.
*
* Revision 1.21 2000/12/06 17:52:25 gerd
* New: compile
*
* Revision 1.20 2000/12/06 15:30:21 gerd
* New: mk_html_node
* Added support for the ~self_url parameter.
*
* Revision 1.19 2000/12/04 11:59:29 gerd
* Fix: The method of the uialtform form must be POST.
*
* Revision 1.18 2000/11/30 18:39:13 gerd
* Implementation of ui:server-popup.
* Beautifications, new comments.
* Several changes because parser.mli has been introduced.
*
* Revision 1.17 2000/09/26 15:53:23 gerd
* Fixed for popup dialogues.
*
* Revision 1.16 2000/09/25 16:58:39 gerd
* Fix: Setting also the ONSUBMIT handler of the popup formular.
*
* Revision 1.15 2000/09/25 16:27:21 gerd
* Javascript: document.write only invoked with small strings.
*
* Revision 1.14 2000/09/25 13:22:13 gerd
* New ui:popup element
*
* Revision 1.13 2000/09/21 15:12:34 gerd
* Updated for O'Caml 3 and PXP
*
* Revision 1.12 2000/05/15 11:46:33 gerd
* Necessary changes for uidebugger.
*
* Revision 1.11 2000/05/10 16:19:04 gerd
* Bug in uitextarea.
*
* Revision 1.10 2000/05/10 13:54:34 gerd
* Improved iterators.
*
* Revision 1.9 2000/05/10 11:12:16 gerd
* Added ui:guard.
*
* Revision 1.8 2000/05/09 16:42:56 gerd
* Many ui:xxx elements now accept undeclared attributes, and
* simply pass them to the HTML output.
*
* Revision 1.7 2000/05/09 14:26:24 gerd
* The "cgi" attribute is recognized, and the name of the CGI
* parameter is derived from it.
*
* Revision 1.6 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.5 2000/05/08 16:43:38 gerd
* Implemented the "replace" attribute of "ui:page".
* Changed the semantics of lexical parameter passing.
*
* Revision 1.4 2000/05/08 15:32:44 gerd
* Added ui:default.
* Added exceptions and functions processing default contexts.
*
* Revision 1.3 2000/05/08 10:33:18 gerd
* Changed the instantiation technique: First, there is a new class,
* "mixin_instantiate", that contains the instantiation method. Second,
* this method uses the new functionality of the Templrep module. Third,
* the core of dynamic parameters is implemented - there is a new
* "context" argument for the to_html method passing dynamic parameters.
*
* Revision 1.2 2000/04/17 10:10:52 gerd
* New Cgi module.
* File upload strongly improved.
*
* Revision 1.1 2000/04/13 17:42:58 gerd
* Initial revision.
*
*
*)
