(*
* <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_var_functions.ml,v 1.7 2006-03-08 16:05:02 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
let bool_string b =
if b then
String_value "1"
else
String_value "0"
;;
let id dlg args =
match args with
| [a] -> a
| _ ->
failwith "function `id': expects exactly one argument"
;;
let size (dlg : dialog_type) args =
match args with
[a1] ->
(match a1 with
String_value s ->
let enc = (dlg#application#charset :> Pxp_types.encoding) in
let n = Netconversion.ustring_length enc s in
String_value (string_of_int n)
| Enum_value e ->
String_value (string_of_int (List.length e))
| Dyn_enum_value d ->
String_value (string_of_int (List.length d))
| Alist_value a ->
String_value (string_of_int (List.length a))
| Dialog_value _ ->
failwith "function `size': not defined for dialogs"
)
| _ ->
failwith "function `size': expects exactly one argument"
;;
let length (dlg : dialog_type) args =
match args with
[a1] ->
(match a1 with
String_value s ->
let enc = (dlg#application#charset :> Pxp_types.encoding) in
let n = Netconversion.ustring_length enc s in
String_value (string_of_int n)
| _ ->
failwith "function `length': not defined for non-strings"
)
| _ ->
failwith "function `length': expects exactly one argument"
;;
let split_re = Pcre.regexp "[ \t\r\n]+";;
let split s = Netstring_pcre.split split_re s;;
let card (dlg : dialog_type) args =
match args with
[a1] ->
(match a1 with
String_value s ->
let l = split s in
String_value (string_of_int (List.length l))
| Enum_value e ->
String_value (string_of_int (List.length e))
| Dyn_enum_value d ->
String_value (string_of_int (List.length d))
| Alist_value a ->
String_value (string_of_int (List.length a))
| Dialog_value _ ->
failwith "function `card': not defined for dialogs"
)
| _ ->
failwith "function `card': expects exactly one argument"
;;
let list_string_op name op dlg args =
match args with
[a1; a2] ->
let v1 =
match a1 with
String_value s ->
split s
| Enum_value e ->
e
| Dyn_enum_value d ->
List.map fst d
| Alist_value a ->
List.map fst a
| Dialog_value _ ->
failwith ("function `" ^ name ^ " ': not defined for dialogs")
in
let v2 =
match a2 with
String_value s ->
s
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
in
op dlg v1 v2
| _ ->
failwith ("function `" ^ name ^ "': expects exactly two arguments")
;;
let contains =
list_string_op "contains"
(fun dlg l s -> bool_string (List.mem s l)) ;;
let mentions dlg args =
match args with
[a1; a2] ->
let s =
match a2 with
String_value s ->
s
| _ ->
failwith ("function `mentions': bad type of operands")
in
( match a1 with
| Dyn_enum_value d ->
bool_string(List.mem s (List.map snd d))
| Alist_value a ->
let l =
List.flatten
(List.map
(function
(_,String_value s) -> [s]
| (_,Enum_value e) -> e
| (_,Dyn_enum_value d') -> List.map fst d' (* ??? *)
| _ ->
failwith("function `mentions': First operand has bad type")
)
a
)
in
bool_string(List.mem s l)
| _ ->
failwith ("function `mentions': bad type of operands")
)
| _ ->
failwith ("function `mentions': expects exactly two arguments")
;;
let sequential_int_operation name op dlg args =
let rec compute args =
match args with
[] ->
failwith ("function `" ^ name ^ "': expects at least one argument")
| [ r ] ->
r
| a1 :: a2 :: args' ->
( match (a1,a2) with
(String_value s1,String_value s2) ->
let n1 = int_of_string s1 in
let n2 = int_of_string s2 in
let r = String_value(string_of_int(op n1 n2)) in
compute (r :: args')
| _ ->
failwith ("function `" ^ name ^ "': operand has bad type")
)
in
compute args
;;
let add =
sequential_int_operation "add" ( + ) ;;
let sub =
sequential_int_operation "sub" ( - ) ;;
let mul =
sequential_int_operation "mul" ( * ) ;;
let div =
let divide n1 n2 =
if n2 = 0 then failwith "Division by zero" else n1/n2 in
sequential_int_operation "div" divide ;;
let modulo =
let _mod n1 n2 =
if n2 = 0 then failwith "Division by zero" else n1 mod n2 in
sequential_int_operation "modulo" _mod ;;
let alist_operation name op dlg args =
match args with
[a1; a2] ->
( match (a1,a2) with
(Alist_value alist, String_value s) ->
op alist s
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
)
| _ ->
failwith ("function `" ^ name ^ "': expects exactly two arguments")
;;
let assoc =
alist_operation "assoc"
(fun alist s ->
try List.assoc s alist
with Not_found ->
failwith "function `assoc': element not found")
;;
let nth =
alist_operation "nth"
(fun alist s ->
try snd(List.nth alist (int_of_string s))
with Failure _ ->
failwith "function `nth': element not found")
;;
let enum_operation name op dlg args =
match args with
[a1; a2] ->
( match (a1,a2) with
(Dyn_enum_value de, String_value s) ->
op de s
| (String_value t, String_value s) ->
( try
let enum = dlg # declaration # enumeration t in
op enum.enum_definition s
with
Not_found ->
failwith ("function `" ^ name ^ "': enumeration not found")
)
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
)
| _ ->
failwith ("function `" ^ name ^ "': expects exactly two arguments")
;;
let translate =
enum_operation "translate"
(fun dynenum s ->
try String_value (List.assoc s dynenum)
with Not_found ->
failwith "function `translate': element not found")
;;
let rev_translate =
enum_operation "rev-translate"
(fun dynenum s ->
let dynenum' = List.map (fun (l,r) -> (r,l)) dynenum in
try String_value (List.assoc s dynenum')
with Not_found ->
failwith "function `rev-translate': element not found")
;;
let substring (dlg : dialog_type) args =
let enc = (dlg#application#charset :> Pxp_types.encoding) in
let compute s start length =
let (k1,k2) =
if length >= 0 then (start,start+length) else (start+length,start) in
let n1 = max 0 k1 in
let n2 = min (Netconversion.ustring_length enc s) k2 in
Netconversion.ustring_sub enc n1 (n2-n1) s
in
match args with
[a1;a2] ->
( match (a1,a2) with
(String_value s1,String_value s2) ->
String_value(compute s1 (int_of_string s2) (String.length s1))
| _ ->
failwith "function `substring': bad type of operand"
)
| [a1;a2;a3] ->
( match (a1,a2,a3) with
(String_value s1,String_value s2,String_value s3) ->
String_value(compute s1 (int_of_string s2) (int_of_string s3))
| _ ->
failwith "function `substring': bad type of operand"
)
| _ ->
failwith "function `substring': expects two or three arguments"
;;
let concat dlg args =
let strings =
List.map
(function
String_value s -> s
| _ ->
failwith "function `concat': bad type of operand")
args
in
String_value(String.concat "" strings)
;;
let unary_string_operation name op dlg args =
match args with
[a1] ->
( match a1 with
(String_value s) ->
op dlg s
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
)
| _ ->
failwith ("function `" ^ name ^ "': expects exactly one argument")
;;
let binary_string_operation name op dlg args =
match args with
[a1;a2] ->
( match a1, a2 with
(String_value s1), (String_value s2) ->
op dlg s1 s2
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
)
| _ ->
failwith ("function `" ^ name ^ "': expects exactly two arguments")
;;
let rec count_height s n k =
let next_cr_or_lf = Pxp_lib.crlf_index_from s k in
if next_cr_or_lf >= 0 then begin
match s.[next_cr_or_lf] with
'\010' ->
count_height s (n+1) (next_cr_or_lf+1)
| '\013' ->
let l = String.length s in
if (next_cr_or_lf+1 < l && s.[next_cr_or_lf+1] = '\010') then
count_height s (n+1) (next_cr_or_lf+2)
else
count_height s (n+1) (next_cr_or_lf+1)
| _ ->
assert false
end
else n
;;
let height =
unary_string_operation "height"
(fun dlg s ->
String_value(string_of_int(count_height s 1 0)))
;;
let rec count_width enc s w k =
let next_cr_or_lf = Pxp_lib.crlf_index_from s k in
if next_cr_or_lf >= 0 then begin
match s.[next_cr_or_lf] with
'\010' ->
let n = Netconversion.ustring_length
enc ~range_pos:k ~range_len:(next_cr_or_lf - k) s in
let w' = max w n in
count_width enc s w' (next_cr_or_lf+1)
| '\013' ->
let n = Netconversion.ustring_length
enc ~range_pos:k ~range_len:(next_cr_or_lf - k) s in
let w' = max w n in
let l = String.length s in
if (next_cr_or_lf+1 < l && s.[next_cr_or_lf+1] = '\010') then
count_width enc s w' (next_cr_or_lf+2)
else
count_width enc s w' (next_cr_or_lf+1)
| _ ->
assert false
end
else w
;;
let width =
unary_string_operation "width"
(fun (dlg : dialog_type) s ->
let enc = (dlg#application#charset :> Pxp_types.encoding) in
String_value(string_of_int(count_width enc s 0 0)))
;;
let eq =
binary_string_operation "eq"
(fun dlg s1 s2 -> bool_string (s1 = s2)) ;;
let ne =
binary_string_operation "eq"
(fun dlg s1 s2 -> bool_string (s1 <> s2)) ;;
let compile_regexp s =
try
Pcre.regexp s
with
Pcre.Error(Pcre.BadPattern (msg, pos)) ->
failwith ("Bad regular expression, at position " ^
string_of_int pos ^ ": " ^ msg)
;;
let match_ =
binary_string_operation "match"
(fun dlg s1 s2 -> bool_string (Pcre.pmatch ~rex:(compile_regexp s2) s1)) ;;
let nomatch =
binary_string_operation "nomatch"
(fun dlg s1 s2 -> bool_string (not (Pcre.pmatch ~rex:(compile_regexp s2) s1))) ;;
let int_operation name op dlg args =
let int_args =
List.map
(fun a ->
match a with
| String_value s ->
( try int_of_string s
with _ ->
failwith ("function `" ^ name ^ "': an arg is not an integer"))
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
) args in
op dlg int_args;;
let unary_int_operation name op dlg args =
int_operation
name
(fun dlg int_args ->
match int_args with
| [i] ->
op dlg i
| _ ->
failwith ("function `" ^ name ^ "': expects exactly one argument"))
dlg
args ;;
let binary_int_operation name op dlg args =
int_operation
name
(fun dlg int_args ->
match int_args with
| [i1;i2] ->
op dlg i1 i2
| _ ->
failwith ("function `" ^ name ^ "': expects exactly two arguments"))
dlg
args ;;
let int_eq =
binary_int_operation "int-eq"
(fun dlg i1 i2 -> bool_string (i1 = i2)) ;;
let int_ne =
binary_int_operation "int-ne"
(fun dlg i1 i2 -> bool_string (i1 <> i2)) ;;
let int_lt =
binary_int_operation "int-lt"
(fun dlg i1 i2 -> bool_string (i1 < i2)) ;;
let int_le =
binary_int_operation "int-le"
(fun dlg i1 i2 -> bool_string (i1 <= i2)) ;;
let int_gt =
binary_int_operation "int-gt"
(fun dlg i1 i2 -> bool_string (i1 > i2)) ;;
let int_ge =
binary_int_operation "int-ge"
(fun dlg i1 i2 -> bool_string (i1 >= i2)) ;;
let int_abs =
unary_int_operation "int-abs"
(fun dlg i -> String_value(string_of_int(abs i))) ;;
let int_sign =
let sign n = if n = 0 then 0 else if n > 0 then 1 else (-1) in
unary_int_operation "int-sign"
(fun dlg i -> String_value(string_of_int(sign i))) ;;
let int_min =
int_operation "int-min"
(fun dlg args ->
match args with
| [] -> failwith "function `int-min': needs at least one argument"
| arg :: args' ->
String_value(string_of_int(List.fold_left min arg args'))) ;;
let int_max =
int_operation "int-max"
(fun dlg args ->
match args with
| [] -> failwith "function `int-max': needs at least one argument"
| arg :: args' ->
String_value(string_of_int(List.fold_left max arg args'))) ;;
let card_operation name op =
list_string_op name
(fun dlg l s ->
let n =
try int_of_string s
with _ -> failwith ("function `" ^ name ^ "': second arg must be an integer") in
op dlg (List.length l) n) ;;
let card_eq =
card_operation "card-eq"
(fun dlg i1 i2 -> bool_string (i1 = i2)) ;;
let card_ne =
card_operation "card-ne"
(fun dlg i1 i2 -> bool_string (i1 <> i2)) ;;
let card_lt =
card_operation "card-lt"
(fun dlg i1 i2 -> bool_string (i1 < i2)) ;;
let card_le =
card_operation "card-le"
(fun dlg i1 i2 -> bool_string (i1 <= i2)) ;;
let card_gt =
card_operation "card-gt"
(fun dlg i1 i2 -> bool_string (i1 > i2)) ;;
let card_ge =
card_operation "card-ge"
(fun dlg i1 i2 -> bool_string (i1 >= i2)) ;;
let var =
unary_string_operation "var"
(fun dlg s ->
try
dlg # variable s
with
No_such_variable msg ->
failwith ("function `var': no such variable: `" ^ msg ^ "'")
)
;;
let dialog_exists dlg args =
match args with
[a1; a2] ->
( match (a1,a2) with
(Dialog_value dlg_opt, String_value s) ->
let b =
match (dlg_opt, s) with
| Some _, "yes" -> true
| Some _, "no" -> false
| None, "yes" -> false
| None, "no" -> true
| _, _ -> failwith "function `dialog-exists': bad value of second argument" in
bool_string b
| _ ->
failwith ("function `dialog-exists': bad type of operands")
)
| [a1] ->
( match a1 with
Dialog_value dlg_opt ->
bool_string (dlg_opt <> None)
| _ ->
failwith ("function `dialog-exists': bad type of operands")
)
| _ ->
failwith ("function `dialog-exists': expects one or two arguments")
;;
let bool_operation name op dlg args =
let bool_args =
List.map
(fun a ->
lazy (
match Lazy.force a with
String_value s ->
let i =
try int_of_string s
with _ ->
failwith ("function `" ^ name ^ "': an arg is not an integer") in
i <> 0
| _ ->
failwith ("function `" ^ name ^ "': bad type of operands")
)
)
args in
op dlg bool_args
;;
let and_ =
bool_operation "and"
(fun dlg args -> bool_string (List.for_all (fun arg -> Lazy.force arg) args)) ;;
let or_ =
bool_operation "or"
(fun dlg args -> bool_string (List.exists (fun arg -> Lazy.force arg) args)) ;;
let not_ =
unary_string_operation "not"
(fun dlg s ->
let i =
try int_of_string s
with _ -> failwith ("function `not': argument is not an integer") in
bool_string (i = 0)) ;;
let if_ dlg args =
match args with
[a1; a2; a3] ->
let b =
match Lazy.force a1 with
| String_value s1 ->
let i1 =
try int_of_string s1
with _ ->
failwith ("function `if': first arg is not an integer") in
i1 <> 0
| _ ->
failwith ("function `if': bad type of first operand")
in
if b then (Lazy.force a2) else (Lazy.force a3)
| _ ->
failwith ("function `if': expects exactly three arguments")
;;
let const_operation name op (dlg:dialog_type) args =
if args <> [] then
failwith ("function `" ^ name ^ "': no arguments allowed");
op dlg
;;
let true_ =
const_operation "true" (fun dlg -> String_value "1") ;;
let false_ =
const_operation "true" (fun dlg -> String_value "0") ;;
let dialog =
const_operation "dialog"
(fun dlg -> String_value(dlg # name))
;;
let self =
const_operation "self"
(fun dlg -> Dialog_value (Some dlg))
;;
let page =
const_operation "page"
(fun dlg -> String_value(dlg # page_name))
;;
let language =
const_operation "language"
(fun dlg ->
match dlg # declaration # language_variable with
Some v ->
( try
dlg # variable v
with
No_such_variable msg ->
failwith ("function `language': no such variable: `" ^ msg ^ "'")
)
| None ->
String_value ""
)
let cat_translate (dlg : dialog_type) args =
match args with
| [ String_value s ]
| [ String_value s; _ ] -> (* Optional second arg is ignored *)
let language =
match dlg # declaration # language_variable with
| Some v ->
( try
dlg # string_variable v
with
No_such_variable msg ->
failwith ("function `cat-translate': no such variable: `" ^ msg ^ "'")
)
| None -> "" in
let s' =
try
dlg # application # lookup_message
~domain:dlg#name
~language
s
with
| Not_found_in_catalog(_,_,_) ->
(* TODO: Proper logging *)
prerr_endline("Message not found: language=" ^ language ^
" internal=" ^ s);
s in
String_value s'
| _ ->
failwith ("function `cat-translate': bad arguments");
;;
let self_base_url =
const_operation "self-base-url"
(fun dlg ->
let cgi = (dlg # environment).cgi in
let script_path = cgi # environment # cgi_script_name in
let script_name = Filename.basename script_path in
String_value(script_name)
)
;;
let session_id =
const_operation "session-id"
(fun dlg ->
String_value(dlg # session # session_id)
)
;;
let create_anchor_event =
unary_string_operation "create-anchor-event"
(fun dlg s ->
let ia = dlg # interactors in
let id = Wd_interactor.add ia.ui_anchors s "" None None in
String_value id
)
;;
let create_xanchor_event =
binary_string_operation "create-xanchor-event"
(fun dlg s1 s2 ->
let ia = dlg # interactors in
let id = Wd_interactor.add ia.ui_indexed_anchors s1 s2 None None in
String_value id
)
;;
(* ======================================================================
* History:
*
* $Log: wd_var_functions.ml,v $
* Revision 1.7 2006-03-08 16:05:02 stolpmann
* Limited support for catalogs:
*
* The syntax <ui:catalog>...</ui:catalog> is supported, and it is
* possible to define catalogs in ui files.
*
* The syntax $[m(token)] looks up the token in the current catalog.
*
* The function cat-translate is also available.
*
* ui:select has the "display" attribute.
*
* Revision 1.6 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 1.5 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 1.4 2003/06/21 12:09:08 stolpmann
* Updates because of changes in Ocamlnet 0.96
*
* Revision 1.3 2003/02/16 01:07:03 stolpmann
* size, substring, width: string positions are measured as
* the number of characters, not as the number of bytes
*
* Revision 1.2 2002/11/03 20:56:56 stolpmann
* New functions: translate, rev_translate
*
* Revision 1.1 2002/10/20 19:38:17 stolpmann
* Initial revision
*
*
*)
