(*
* <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_application.ml,v 3.9 2005-06-11 14:24:14 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
class application init_dtd : application_type =
object (self)
val mutable start_dialog_name =
(None : string option)
val mutable dialogs =
(Hashtbl.create 20 : (string, dialog_decl_type) Hashtbl.t)
val mutable dialog_names =
[]
val mutable templates =
(Hashtbl.create 20 : (string, template_type) Hashtbl.t)
val mutable templates_libflag =
(Hashtbl.create 20 : (string, bool) Hashtbl.t)
val mutable template_names =
[]
val mutable output_encodings =
(Hashtbl.create 10 : (string, string->string) Hashtbl.t)
val mutable var_functions =
(Hashtbl.create 10 :
(string, dialog_type -> var_value Lazy.t list -> var_value) Hashtbl.t)
val mutable dtd =
init_dtd
val mutable debug_mode =
false
val mutable debug_mode_style =
`Partially_encoded
val mutable prototype_mode =
false
val mutable onstartup_call_handle =
false
initializer
(* Add some standard encodings: *)
let enc = init_dtd # encoding in
self # add_output_encoding "html" Wd_encoding.encode_as_html;
self # add_output_encoding "pre" Wd_encoding.encode_as_pre;
self # add_output_encoding "para" Wd_encoding.encode_as_para;
self # add_output_encoding "js" Wd_encoding.encode_as_js_string;
self # add_output_encoding "jslong"
(Wd_encoding.encode_as_js_longstring ~enc);
(* Add the standard functions: *)
self # add_var_function "id" Wd_var_functions.id;
self # add_var_function "length" Wd_var_functions.length;
self # add_var_function "card" Wd_var_functions.card;
self # add_var_function "size" Wd_var_functions.size;
self # add_var_function "add" Wd_var_functions.add;
self # add_var_function "sub" Wd_var_functions.sub;
self # add_var_function "mul" Wd_var_functions.mul;
self # add_var_function "div" Wd_var_functions.div;
self # add_var_function "modulo" Wd_var_functions.modulo;
self # add_var_function "assoc" Wd_var_functions.assoc;
self # add_var_function "nth" Wd_var_functions.nth;
self # add_var_function "contains" Wd_var_functions.contains;
self # add_var_function "mentions" Wd_var_functions.mentions;
self # add_var_function "translate" Wd_var_functions.translate;
self # add_var_function "rev_translate" Wd_var_functions.rev_translate; (* legacy *)
self # add_var_function "rev-translate" Wd_var_functions.rev_translate;
self # add_var_function "eq" Wd_var_functions.eq;
self # add_var_function "ne" Wd_var_functions.ne;
self # add_var_function "match" Wd_var_functions.match_;
self # add_var_function "nomatch" Wd_var_functions.nomatch;
self # add_var_function "substring" Wd_var_functions.substring;
self # add_var_function "concat" Wd_var_functions.concat;
self # add_var_function "int-eq" Wd_var_functions.int_eq;
self # add_var_function "int-ne" Wd_var_functions.int_ne;
self # add_var_function "int-lt" Wd_var_functions.int_lt;
self # add_var_function "int-le" Wd_var_functions.int_le;
self # add_var_function "int-gt" Wd_var_functions.int_gt;
self # add_var_function "int-ge" Wd_var_functions.int_ge;
self # add_var_function "int-min" Wd_var_functions.int_min;
self # add_var_function "int-max" Wd_var_functions.int_max;
self # add_var_function "int-abs" Wd_var_functions.int_abs;
self # add_var_function "int-sign" Wd_var_functions.int_sign;
self # add_var_function "card-eq" Wd_var_functions.card_eq;
self # add_var_function "card-ne" Wd_var_functions.card_ne;
self # add_var_function "card-lt" Wd_var_functions.card_lt;
self # add_var_function "card-le" Wd_var_functions.card_le;
self # add_var_function "card-gt" Wd_var_functions.card_gt;
self # add_var_function "card-ge" Wd_var_functions.card_ge;
self # add_var_function "size-eq" Wd_var_functions.card_eq; (* legacy name *)
self # add_var_function "size-ne" Wd_var_functions.card_ne; (* legacy name *)
self # add_var_function "size-lt" Wd_var_functions.card_lt; (* legacy name *)
self # add_var_function "size-le" Wd_var_functions.card_le; (* legacy name *)
self # add_var_function "size-gt" Wd_var_functions.card_gt; (* legacy name *)
self # add_var_function "size-ge" Wd_var_functions.card_ge; (* legacy name *)
self # add_var_function "height" Wd_var_functions.height;
self # add_var_function "width" Wd_var_functions.width;
self # add_var_function "dialog-exists" Wd_var_functions.dialog_exists;
self # add_lazy_var_function "and" Wd_var_functions.and_;
self # add_lazy_var_function "or" Wd_var_functions.or_;
self # add_var_function "not" Wd_var_functions.not_;
self # add_var_function "true" Wd_var_functions.true_;
self # add_var_function "false" Wd_var_functions.false_;
self # add_lazy_var_function "if" Wd_var_functions.if_;
self # add_var_function "var" Wd_var_functions.var;
self # add_var_function "dialog" Wd_var_functions.dialog;
self # add_var_function "self" Wd_var_functions.self;
self # add_var_function "page" Wd_var_functions.page;
self # add_var_function "language" Wd_var_functions.language;
self # add_var_function "self_base_url" Wd_var_functions.self_base_url; (* legacy *)
self # add_var_function "self-base-url" Wd_var_functions.self_base_url;
self # add_var_function "session_id" Wd_var_functions.session_id; (* legacy *)
self # add_var_function "session-id" Wd_var_functions.session_id;
self # add_var_function "create_anchor_event" Wd_var_functions.create_anchor_event; (* legacy *)
self # add_var_function "create-anchor-event" Wd_var_functions.create_anchor_event;
self # add_var_function "create_xanchor_event" Wd_var_functions.create_xanchor_event;
self # add_var_function "create-xanchor-event" Wd_var_functions.create_xanchor_event; (* legacy *)
(* There are also the following, magically defined functions:
* - type
* - is_associative/is-associative
* - default
* - enum
* - words
*)
(* ------------------------ Public --------------------------- *)
method start_dialog_name =
match start_dialog_name with
Some n -> n
| None -> failwith "application # start_dialog_name"
method dialog_names =
dialog_names
method dialog_declaration obj_name =
Hashtbl.find dialogs obj_name
method template_names =
template_names
method template tmpl_name =
Hashtbl.find templates tmpl_name
method study () =
Hashtbl.iter
(fun _ t -> t # study (self :> application_type))
templates
method output_encoding name =
Hashtbl.find output_encodings name
method lazy_var_function name =
Hashtbl.find var_functions name
method var_function name =
let f = self # lazy_var_function name in
(fun dlg args -> f dlg (List.map (fun arg -> lazy arg) args))
method dtd = dtd
method charset = dtd # encoding
method debug_mode = debug_mode
method debug_mode_style = debug_mode_style
method prototype_mode = prototype_mode
method onstartup_call_handle = onstartup_call_handle
(* -------------------- Restricted use only ------------------- *)
method set_start_dialog_name n =
start_dialog_name <- Some n
method add_dialog_declaration obj =
(* fails if 'obj_name' already used *)
let obj_name = obj # name in
if Hashtbl.mem dialogs obj_name then
raise (Formal_user_error ("ui:dialog `" ^ obj_name ^
"' is declared twice"));
Hashtbl.add dialogs obj_name obj;
dialog_names <- obj_name :: dialog_names;
method add_template ?(lib = false) tmpl_name tmpl =
(* fails if 'tmpl_name' already used, but:
* a non-library template is allowed to override a library template.
*)
let old_libflag =
try
Some(Hashtbl.find templates_libflag tmpl_name)
with
Not_found -> None
in
begin match old_libflag with
Some true when not lib -> ()
| None -> ()
| _ ->
raise (Formal_user_error ("ui:template `" ^ tmpl_name ^
"' is declared twice"));
end;
Hashtbl.add templates tmpl_name tmpl;
Hashtbl.add templates_libflag tmpl_name lib;
template_names <- tmpl_name :: template_names;
method add_output_encoding enc_name enc =
(* fails if 'enc_name' already used *)
if Hashtbl.mem output_encodings enc_name then
failwith ("This output encoding already exists: " ^ enc_name );
Hashtbl.add output_encodings enc_name enc;
method add_var_function fn_name fn =
(* fails if 'fn_name' already used *)
if Hashtbl.mem var_functions fn_name then
failwith ("This variable function already exists: " ^ fn_name );
Hashtbl.add var_functions fn_name
(fun dlg lazy_args ->
let args = List.map Lazy.force lazy_args in
fn dlg args)
method add_lazy_var_function fn_name fn =
(* fails if 'fn_name' already used *)
if Hashtbl.mem var_functions fn_name then
failwith ("This variable function already exists: " ^ fn_name );
Hashtbl.add var_functions fn_name fn
method set_debug_mode b style =
debug_mode <- b;
debug_mode_style <- style
method set_prototype_mode b = prototype_mode <- b
method set_onstartup_call_handle b = onstartup_call_handle <- b
end
;;
(* ======================================================================
* History:
*
* $Log: wd_application.ml,v $
* Revision 3.9 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.8 2004/12/12 17:57:32 stolpmann
* Added <q:wd-link> and <q:wd-xlink> to generate links for
* applications that cannot use Javascript. Limited functionality, however.
* See stdlib.xml for details.
*
* Revision 3.7 2003/03/21 12:50:31 stolpmann
* Fix: encode_as_js_longstring can cope with UTF8-encoded strings
*
* Revision 3.6 2003/02/16 23:48:14 stolpmann
* Improved wd-debug-mode: there are now two styles
*
* Revision 3.5 2002/11/03 21:17:48 stolpmann
* New functions: type, is_associative, default
*
* Revision 3.4 2002/11/03 20:56:56 stolpmann
* New functions: translate, rev_translate
*
* Revision 3.3 2002/10/20 19:39:16 stolpmann
* New feature: The brackets $[...] can contain expressions,
* not only variables
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:28:59 stolpmann
* Initial release at sourceforge.
*
* Revision 1.8 2002/02/07 18:49:59 gerd
* Standard library
*
* Revision 1.7 2002/02/05 18:46:08 gerd
* New: methods [set_]debug_mode, prototype_mode, onstartup_call_handle
*
* Revision 1.6 2002/01/30 15:11:11 gerd
* The method [study] gets now the application object as argument.
*
* Revision 1.5 2002/01/28 02:12:54 gerd
* Added support for output encodings.
*
* Revision 1.4 2002/01/26 22:35:53 gerd
* Using hashtables instead of associative lists
*
* Revision 1.3 2002/01/24 23:34:54 gerd
* Implemented [study].
*
* Revision 1.2 2002/01/14 15:03:23 gerd
* Major change: Typing has been completely revised, and almost
* every tiny thing has now a new type. Also renamed a lot.
*
* Revision 1.1 2000/04/13 17:42:58 gerd
* Initial revision.
*
*
*)
