(*
* <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_cycle.ml,v 3.15 2005-06-11 14:24:14 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types
open Printf
module S = Netstring_str
let debug = false;;
(* Note debug messages:
* These are written to stderr. The Apache server adds such messages to
* the error log. Other servers (e.g. Netscape) do not do this; in this
* case it is recommended to start the CGI program with a shell script
* that redirect stderr to a log file.
*)
class empty_dialog universe name env =
object
(* An empty dialog implementation *)
inherit Wd_dialog.dialog universe name env
method prepare_page() = ()
method handle() = ()
end
;;
(* TODO: document the 'force_handle_invocation' hack.
* - Some notes:
* Normally, when the application has just been started, there is no need
* to invoke the 'handle' callback; there has been no previous user interaction
* and so the application need not to react on it. When the form is
* submitted by a Javascript handler, a similar situation happens; no
* user interaction is recognized. However, there are situations
* requiring a 'handle' invocation even in these cases; to enforce that
* the 'handle' callback is always performed, one can set the CGI variable
* 'force_handle_invocation' to a value other than "".
*)
let extended_arguments (cgi:Netcgi.cgi_activation) =
(* Return the CGI arguments plus the decoded contents of
* 'uiobject_extra_args'.
* - Some notes:
* Normally, the web browser simply posts the form containing the
* CGI parameters. This technique is simple, but it is limited because
* it must be known which parameters exist in the form at the moment
* when the form is created (by HTML elements). However, some interactions
* require that parameters must be dynamically added just before the
* form is submitted. The special CGI parameter 'uiobject_extra_args'
* can be used for this purpose: It is interpreted as url-encoded set
* of extra parameters that are added to the ordinary set of
* CGI parameters.
* From Javascript, it is a simple task to set 'uiobject_extra_args'
* because there is a function (escape) actually url-encoding its
* input.
*)
lazy begin
let cgi_args =
List.map (fun arg -> arg#name, arg) cgi # arguments in
let extra = cgi # argument_value ~default:"" "uiobject_extra_args" in
let extra' = Pcre.qreplace ~pat:"\\+" ~templ:"%2b" extra in
(* Unfortunately, the Javascript function 'escape' does not protect
* the plus character. So we do it here; otherwise '+' would be
* converted to space.
*)
let extra_decoded =
Netencoding.Url.dest_url_encoded_parameters extra' in (* TODO *)
let extra_args =
List.map
(fun (n,v) -> n, (Netcgi.Argument.simple n v))
extra_decoded in
extra_args @ cgi_args
(* Note: extra_args are returned first. Usually, this means that CGI
* parameters occuring in both lists are preferred from extra_args,
* such that the dynamically added parameters can even override the
* statical ones.
*)
end
;;
let debug_print_args cgi =
(* Dumps the real set of CGI parameters to stderr *)
prerr_endline "*** Beginning dump of CGI parameters:";
List.iter
(fun arg ->
prerr_endline (arg#name ^ "=" ^ arg#value);
)
(cgi # arguments);
prerr_endline "--- End of dump";
;;
let arg cgi n =
let args = Lazy.force (extended_arguments cgi) in
List.assoc n args
;;
let argval cgi n =
(arg cgi n) # value
;;
(*
let ( !% ) n =
(* !% "name": returns the CGI parameter called "name" as abstract value,
* or raises Not_found if it does not exist.
*)
List.assoc n (arguments())
;;
let ( !$ ) n = Cgi.arg_value (!% n)
(* !$ "name": returns the CGI parameter called "name" as string value,
* or raises Not_found if it does not exist.
*)
;;
*)
let update_variables_from_cgi cgi dlg=
(* Examines the CGI parameters for changed variable values. For example,
* if the previous page contained a text box, the variable bound to the
* box must now be updated to the value of the corresponding CGI
* parameter.
*)
let ( !$ ) = argval cgi in
let var_re = S.regexp "^var_\\(.*\\)$" in
let digits_re = S.regexp "^[0-9_]+$" in
let ia = dlg # interactors in
let dlg_name = dlg # name in
let dlg_decl = dlg # declaration in
(* Iterate over all CGI parameters and recognize the parameters whose
* name match 'var_re'. These parameters contain the new variable
* values.
* Furthermore, we must find out which variable is meant by a CGI
* parameter. If the suffix (the string following 'var_') of the
* CGI name is a number, we can look up the name of the variable in
* the interactor structure.
* If the suffix is not a number, we assume that the suffix already
* denotes the name of the variable (and that the variable is not
* associative). Note that you can force this type of CGI parameter
* by using the cgi="keep" attribute (in the XML element).
* The name_index_list is a list of (vname, (vindex, vvalue)),
* where vname is the variable name, vindex is the variable index
* (or "" if not applicable), and vvalue is the new value of the
* variable.
*
* Note: protected variables are simply ignored.
*)
let name_index_list =
List.flatten
(List.map
(fun (cgiparam,arg) ->
match S.string_match var_re cgiparam 0 with
Some r ->
let v = arg#value in
let n = S.matched_group r 1 cgiparam in
if S.string_match digits_re n 0 <> None then begin
(* The variable is passed by numerical ID *)
let (name,index,_) = Wd_interactor.lookup ia.ui_vars n in
[ name, (index,v) ]
end
else begin
(* The variable is passed by name *)
[ n, ("",v) ]
end
| None ->
[]
)
(Lazy.force(extended_arguments cgi))
)
in
(* visble_pages contains the names of the pages that were
* visible at the moment the form was submitted (i.e. the
* name of the main page and the names of the popup pages).
* When a popup window is submitted, this means that the
* fields of the form are copied to the form of the main
* window, and that the form in the main window is actually
* submitted. Consequently, not only the interactors of the
* popup window exist, but also the interactors of the main
* window.
* The variable 'uiobject_visible_pages' contains a space-separated
* list of the pages that were submitted in the last action;
* i.e. either the page name of the only visible window, or the
* page names of the main window and the popup window.
* In the following code, an interactor is only accepted
* if it occurs on a page listed in visible_pages.
*)
let visible_pages =
let v = " " ^ try !$ "uiobject_visible_pages" with Not_found -> "" in
S.split (S.regexp "[ \t]+") v
in
(* findall n0 name_index_list:
* Returns all (vindex, vvalue) pairs in name_index_list for the
* variable n0.
*)
let findall n0 l =
List.map snd (List.filter (fun (n,v) -> n=n0) l) in
(* findenums n0 name_index_page_list:
* Returns all (vindex, vvalue, page) pairs in name_index_page_list for the
* variable n0.
*)
let findenums n0 l =
List.map
(fun (a,b,c) -> b)
(List.filter (fun (n,v,pg) -> n=n0 && List.mem pg visible_pages) l) in
let definedenum n0 l =
List.exists
(fun (n,v,pg) -> n=n0 && List.mem pg visible_pages) l in
let rec unprotected_variables dlg =
(* Returns the unprotected variables of [dlg] and of subdialogs;
* names of dialog variables are not returned
*)
let dlg_decl = dlg # declaration in
let unprotected =
List.filter
(fun vname -> not (dlg_decl # variable vname).var_protected)
dlg_decl#variable_names in
(* Expand dialogs: *)
List.flatten
(List.map
(fun vname ->
if (dlg_decl # variable vname).var_type = Dialog_type then begin
match dlg # dialog_variable vname with
Some dlg' ->
let unprotected' = unprotected_variables dlg' in
List.map (fun vname' -> vname ^ "." ^ vname') unprotected'
| None ->
[] (* drop this variable *)
end
else
[vname]
)
unprotected
)
in
(* Iterate over all declared variables of the dialog, look up whether
* there are values for the variables in name_index_list, and update
* the values stored in the dialog.
*)
List.iter
(fun vname ->
let var = dlg # variable_decl vname in
(* Contains the declaration of the variable *)
let index_value_pairs = findall vname name_index_list in
(* All (vindex,vvalue) pairs for the variable 'vname' *)
let update_alist_value new_associations =
(* Update the associations of the alist variable 'vname': The
* associations in 'new_associations' are changed; the other
* associations are kept.
* The order of the old associations is retained. Totally new
* entries are appended.
*)
let old_associations = dlg # alist_variable vname in
let new_dict = Wd_dictionary.of_alist new_associations in
let new_dict' = ref Wd_dictionary.empty in
let al =
List.map
(fun (n,v) ->
try
let v' = Wd_dictionary.find n new_dict in (* or Not_found *)
new_dict' := Wd_dictionary.add n () !new_dict';
(n,v')
with
Not_found -> (n,v)
)
old_associations in
let al' = ref [] in
Wd_dictionary.iter
(fun n v ->
if not(Wd_dictionary.mem n !new_dict') then
al' := (n,v) :: !al'
)
new_dict;
dlg # set_variable vname (Alist_value (al @ !al'));
in
(* How the values from the CGI parameters are to be interpreted mainly
* depends on the type of the variable. So here is a case for every
* variable type.
*)
match var.var_type with
String_type ->
if var.var_associative then begin
(* Associative strings: The new (vindex,vvalue) pairs replace
* the existing associations from indexes to values.
* Associations for which no index has been passed by CGI
* parameter are kept as they are.
*)
let new_strings =
List.map (fun (x,s) -> x,String_value s) index_value_pairs in
update_alist_value new_strings
end
else begin
(* Non-associative strings: Set the value to one of the
* values found in name_index_list (should be
* [ name, ("", value) ] ).
*)
try
let _, v = List.assoc vname name_index_list (* or Not_found *)
in dlg # set_variable vname (String_value v)
with
Not_found -> ()
end
| Enum_type _ ->
(* Enumerators: We must only set the enumerator variables for
* which there was an interactor on the last page (otherwise
* the values of enumerators would be reset without reason).
* The list of enumerators of the last page is stored in
* ia.ui_enumvars.
*)
if var.var_associative then begin
(* Associative enumerators: Set only the associations
* occuring in ia.ui_enumvars.
*)
let relevant_index_values = findenums vname ia.ui_enumvars in
(* Only these index values must me set! *)
let new_enums =
List.map
(fun some_indexvalue ->
match some_indexvalue with
None -> assert false
| Some indexvalue ->
let values = findall indexvalue index_value_pairs in
indexvalue, Enum_value values
)
relevant_index_values in
update_alist_value new_enums
end
else begin
(* Non-associative enumerators: Set the enumerator value
* only if the name occurs in ia.ui_enumvars.
*)
if definedenum vname (ia.ui_enumvars) then begin
let values = List.map snd index_value_pairs in
dlg # set_variable vname (Enum_value values)
end
end
| Dyn_enum_type ->
(* Dynamic enumerators: Same problem as with simple enumerators;
* we must only set those enumerators occuring in the last
* page.
*)
if var.var_associative then begin
let relevant_index_values = findenums vname ia.ui_enumvars in
let new_enums =
List.map
(fun some_indexvalue ->
match some_indexvalue with
None -> assert false
| Some indexvalue ->
let values = findall indexvalue index_value_pairs in
indexvalue,
Dyn_enum_value (List.map (fun v -> v, "") values)
)
relevant_index_values in
update_alist_value new_enums
end
else begin
if definedenum vname (ia.ui_enumvars) then begin
let values = List.map snd index_value_pairs in
dlg # set_variable
vname
(Dyn_enum_value (List.map (fun v -> v, "") values))
end
end
| Dialog_type ->
(* It is not possible to set dialog variables by CGI parameters *)
()
)
(unprotected_variables dlg)
;;
exception Result of (event * string option);;
(* Used locally in get_event_from_cgi *)
let get_event_from_cgi cgi dlg =
(* Examine the CGI parameters, and search the parameter expressing the
* last event ("click").
* Return a pair (event, default_next_page) denoting the found event
* and the page that should be displayed next (unless overridden by
* the 'handle' method of the dialog).
* The 'default_next_page' may be set by the "goto" attribute of the
* interactor that caused the event; because of this, the
* default_next_page is determined in this function.
*)
let ( !$ ) = argval cgi in
let ia = dlg # interactors in
let button_re = S.regexp "^button_\\(.*\\)$" in
let xbutton_re = S.regexp "^xbutton_\\(.*\\)$" in
let anchor_re = S.regexp "^anchor_\\(.*\\)$" in
let xanchor_re = S.regexp "^xanchor_\\(.*\\)$" in
let ibuttonx_re = S.regexp "^imagebutton_\\(.*\\)\\.x$" in
let ibuttony_re = S.regexp "^imagebutton_\\(.*\\)\\.y$" in
let xibuttonx_re = S.regexp "^ximagebutton_\\(.*\\)\\.x$" in
let xibuttony_re = S.regexp "^ximagebutton_\\(.*\\)\\.y$" in
(* 'matchers': This is a list of functions which will be tried in turn
* in order to find the CGI parameter expressing the event. The functions
* have signature
* (cginame:string) * (cgivalue:string) -> event * (nextpage:string),
* i.e. they get the name of the CGI parameter and its value as input,
* and the function returns the event and the name of the next page
* if it recognizes the CGI parameter. The function may also raise Not_found
* to indicate that it does not know the kind of parameter.
* Later, every CGI parameter will be passed to every function, and the first
* function that does not raise Not_found recognizes the event, and the
* result of the function is taken as event and default next page.
*
* There is a bug in some browsers causing the following strange
* behaviour:
* When the user clicks on a ui:a anchor, the form is submitted; however
* the first submit button is also selected.
* To work around this bug, the first matchers are the anchor matchers
* and the loop searching the right CGI parameter first tries to match
* all parameters with the anchor pattern. So the anchor will be found before
* the submit button.
*)
let matchers =
[
(fun (n,arg) ->
(* Test on (non-indexed) anchor events *)
match S.string_match anchor_re n 0 with
Some r when arg#value <> "0" ->
let id_str = S.matched_group r 1 n in
let (name, _, goto) =
Wd_interactor.lookup ia.ui_anchors id_str in
(* Note: Anchor events are represented as Button, too *)
Button name, goto
| _ ->
raise Not_found
);
(fun (n,arg) ->
(* Test on indexed anchor events *)
match S.string_match xanchor_re n 0 with
Some r when arg#value <> "0" ->
let id_str = S.matched_group r 1 n in
let (name, index, goto) =
Wd_interactor.lookup ia.ui_indexed_anchors id_str in
(* Note: Anchor events are represented as Button, too *)
Indexed_button (name,index), goto
| _ ->
raise Not_found
);
(fun (n,arg) ->
(* Test on (non-indexed) button events. *)
match S.string_match button_re n 0 with
Some r ->
let id_str = S.matched_group r 1 n in
let (name, _, goto) =
Wd_interactor.lookup ia.ui_buttons id_str in
Button name, goto
| _ ->
raise Not_found
);
(fun (n,arg) ->
(* Test on indexed button events *)
match S.string_match xbutton_re n 0 with
Some r ->
let id_str = S.matched_group r 1 n in
let (name, index, goto) =
Wd_interactor.lookup ia.ui_indexed_buttons id_str in
Indexed_button(name,index), goto
| _ ->
raise Not_found
);
(fun (n,argx) ->
(* Test on (non-indexed) image buttons *)
match S.string_match ibuttonx_re n 0 with
Some r ->
let vx = argx#value in
let id_str = S.matched_group r 1 n in
let (name, _, goto) =
Wd_interactor.lookup ia.ui_imagebuttons id_str in
let ny = "imagebutton_" ^ id_str ^ ".y" in
let vy =
try !$ ny
with Not_found ->
failwith ("Cannot find CGI param " ^ ny)
in
Image_button(name, int_of_string vx, int_of_string vy), goto
| _ ->
raise Not_found
);
(fun (n,argx) ->
(* Test on indexed image buttons *)
match S.string_match xibuttonx_re n 0 with
Some r ->
let vx = argx#value in
let id_str = S.matched_group r 1 n in
let (name, index, goto) =
Wd_interactor.lookup ia.ui_indexed_imagebuttons id_str in
let ny = "ximagebutton_" ^ id_str ^ ".y" in
let vy =
try !$ ny
with Not_found ->
failwith ("Cannot find CGI param " ^ ny)
in
Indexed_image_button(name,
index,
int_of_string vx,
int_of_string vy),
goto
| _ ->
raise Not_found
);
] in
let event, default_next_page =
(* Iterate over every combination of CGI parameter and matcher function,
* and try the matcher function.
* On success, the found event is passed back using the 'Result'
* exception (to jump out of the two iterators).
*
* Note: Because of the mentioned browser bug, this loop iterates first
* over all matchers, and then over the CGI parameters; see the explanations
* above.
*)
begin try
List.iter
(fun matcher ->
List.iter
(fun (n,arg) ->
try
raise (Result (matcher (n,arg)))
(* will be caught right below *)
with
Not_found -> ()
)
(Lazy.force (extended_arguments cgi))
)
matchers;
(* If no matcher function recognizes a CGI parameter: *)
No_event, None
with
(* Catch the exception used to exit from the search loop: *)
Result (e,g) -> e,g
end
in
(event, default_next_page)
;;
(*
let printf (cgi:Netcgi_types.cgi_activation)
(arg : ('a, Buffer.t, unit) format) : 'a =
let b = Buffer.create 16 in
Printf.bprintf b arg;
cgi # output # output_buffer b
;;
*)
let default_response_header =
{ rh_status = `Ok;
rh_content_type = "text/html";
rh_cache = `Unspecified;
rh_filename = None;
rh_language = None;
rh_script_type = None;
rh_style_type = None;
rh_set_cookie = [];
rh_fields = [];
}
;;
let make_environment cgi =
{ debug_mode = false;
debug_mode_style = `Partially_encoded;
prototype_mode = false;
server_popup_mode = false;
self_url = "";
response_header = default_response_header;
cgi = cgi;
}
;;
let in_session_scope session f =
let dlg = session # dialog in
dlg # enter_session_scope session;
try
f dlg;
dlg # leave_session_scope()
with
any ->
dlg # leave_session_scope();
raise any
;;
let process_request
?(session_manager = new Wd_dialog.instant_session_manager())
?self_url
?(response_header = default_response_header)
(universe:universe_type) (cgi:Netcgi.cgi_activation) =
(* Main processing function: Interprets CGI parameters, and outputs
* the next page according to CGI.
*)
(* General note about CGI parameters:
* We must avoid to get the value of arbitrary CGI parameters, because this
* would mean that also uploaded files are loaded into memory.
*)
let ( !$ ) = argval cgi in
if debug then debug_print_args cgi;
let t0 = Unix.gettimeofday() in
let ui_pipe_ch =
(* If present, open pipe to uidebugger right at the beginning.
* Otherwise it may happen that the pipe is never closed, and the
* uidebugger hangs.
*)
try
let ui_pipe = Sys.getenv "UI_PIPE" in
Some(open_out ui_pipe)
with
Not_found -> None
in
let prototype_mode =
universe # application # prototype_mode in
(* Prototype mode: If there is no registered dialog for a declared
* dialog, an empty implementation of the dialog will be assumed.
*)
let force_handle_invocation =
universe # application # onstartup_call_handle in
(* force_handle_invocation: Forces that the 'handle' method of the
* dialog is called even if there was no previous event (e.g.
* when the application is started).
* (There is also a comment above about force_handle_invocation.)
*)
let server_popup_page =
try !$ "uiobject_server_popup" with Not_found -> "" in
let is_server_popup_request = server_popup_page <> "" in
(* server_popup_page: Is set if a popup window has been opened whose
* contents are dynamically generated (so-called "server popup windows").
* server_popup_page contains the name of the page that will be displayed
* in the popup window.
*)
let env =
{ debug_mode = universe # application # debug_mode;
debug_mode_style = universe # application # debug_mode_style;
prototype_mode = prototype_mode;
server_popup_mode = is_server_popup_request;
self_url = (match self_url with Some url -> url | None -> cgi#url());
response_header = { response_header
with rh_status = response_header.rh_status };
cgi = cgi;
}
in
if prototype_mode then begin
(* Add empty dialogs as needed: *)
List.iter
(fun name ->
(* Does the dialog with 'name' exist? *)
try ignore(universe # create env name)
with
Not_found ->
(* No: Register an empty implementation with 'name' *)
universe # register name (new empty_dialog))
(universe # application # dialog_names)
end;
(****************************** STAGE 1 *****************************)
(* First, we get the current dialog, and modify it. The current event
* must be set in this dialog; and the variables of the dialog must
* updated (from the values passed in CGI parameters).
*)
(* Decode the current session *)
let session =
try
let s = !$ "uiobject_session" in (* or raise Not_found *)
let s_obj = session_manager # unserialize universe env s in
(* Server popup request: Create a copy of the session! *)
if is_server_popup_request then
session_manager # create (s_obj # dialog)
else
s_obj
with
Not_found ->
if debug then prerr_endline "Starting with brand-new dialog!";
let n = universe # application # start_dialog_name in
let start_dlg =
try universe # create env n
with Not_found ->
raise (Runtime_error ("The start dialog has claimed to be `" ^ n ^
"'; however such a dialog has not been found in the registered universe of dialogs"))
in
session_manager # create start_dlg
in
let t1 = ref 0.0 in
in_session_scope
session
(fun dlg ->
(* If this is a server popup request, store this piece of information
* in dlg such that dlg knows that the current request comes from a new
* popup window.
*)
if is_server_popup_request then
dlg # set_server_popup_request();
if debug then begin
prerr_endline "*** Dump of initial dialog:";
dlg # dump (Format.err_formatter);
prerr_endline "\n--- End of dump";
end;
(* TODO: check here all pages, and check whether the "goto" attributes of
* all buttons are valid page names.
*)
if is_server_popup_request then begin
try
if not(dlg # declaration # page_is_declared_as_popup server_popup_page) then
raise(Runtime_error("The popup page `" ^ server_popup_page ^
"' has been requested, but this page is not declared as popup page"));
with
Not_found ->
raise(Runtime_error("The popup page `" ^ server_popup_page ^
"' has been requested, but this page does not exist"))
end;
(* Examine the CGI parameters for the current event:
* Normally, the CGI parameter describing the last "click" (anchor or
* button) is searched, and the page associated with this click is
* returned (this does get_event_from_cgi).
* However, if this request results from opening a server popup,
* the event is Popup_request.
*)
let (event, default_next_page) =
if not is_server_popup_request then
get_event_from_cgi cgi dlg (* normal case *)
else begin
let index =
try !$ "uiobject_popup_index" with Not_found -> "" in
Popup_request index, Some server_popup_page (* server popup request *)
end
in
(* Set the event in 'dlg', and set the next page in 'dlg': *)
dlg # set_event event;
begin match default_next_page with
None -> (* The default default next page is the current page: *)
dlg # set_next_page (dlg # page_name);
| Some n ->
dlg # set_next_page n
end;
(* Update variables in 'dlg' from CGI parameters:
* (Skip if this is a server popup request; such requests do not set any
* variables.)
*)
if not is_server_popup_request then
update_variables_from_cgi cgi dlg;
(****************************** STAGE 2 *****************************)
(* The 'dlg' is now ready for further processing. The 'handle' method
* of the dialog is invoked.
* The result may be
* - (a) we continue with this dialog
* - (b) we continue, but on a different page
* - (c) we change to a new dialog
*)
t1 := Unix.gettimeofday();
if event <> No_event || force_handle_invocation then begin
try
dlg # handle();
(* Case (a) *)
with
Change_dialog dlg' ->
(* Case (c) *)
(* This is illegal in a popup request, because the page displayed
* in the popup window must belong to the same dialog as the
* page in the main window.
*)
if is_server_popup_request then
raise(Runtime_error("The 'handle' method tried to change the current dialog although this is a request for a popup window"));
session # change_dialog dlg';
| Change_page pg ->
(* Case (b) *)
dlg # set_next_page pg;
end;
); (* Terminate old session scope... *)
in_session_scope
session
(fun dlg ->
(* ... because a different dialog might be in scope now! *)
let dlg_name = dlg # name in
let dlg_decl = dlg # declaration in
(****************************** STAGE 3 *****************************)
(* Now, 'dlg' denotes the dialog that displays the next page.
* The 'prepare_page' method is invoked such that the dialog
* has the chance to set further variables.
*)
let t2 = Unix.gettimeofday() in
(* Tell the dialog which page comes next: *)
dlg # init (dlg # next_page);
let t3 = Unix.gettimeofday() in
dlg # prepare_page();
(* Maybe we have to init again, because set_next_page has been called
* from prepare_page:
*)
if dlg # page_name <> dlg # next_page then (
dlg # init (dlg # next_page);
);
(****************************** STAGE 4 *****************************)
(* The state of 'dlg' is now ready such that the HTML page can be
* generated.
*)
let t4 = Unix.gettimeofday() in
(* Get the next page (as syntax_tree): *)
let page =
try (dlg # declaration) # page (dlg # page_name)
with
Not_found ->
raise (Runtime_error ("The next page `" ^ (dlg # page_name) ^
"' is not declared"))
in
let vars =
{ within_popup = is_server_popup_request;
current_page = "<outside>";
popup_env_initialized = false;
condition_code = false;
serialize_session = (fun () ->
session # commit_changes();
session # serialize;
)
}
in
let rh = env.response_header in
cgi # set_header
~status:rh.rh_status
~content_type:rh.rh_content_type
~cache:rh.rh_cache
?filename:rh.rh_filename
?language:rh.rh_language
?script_type:rh.rh_script_type
?style_type:rh.rh_style_type
~set_cookie:rh.rh_set_cookie
~fields:rh.rh_fields
();
(* Generate HTML: *)
Wd_transform.to_html
~vars
dlg
(cgi # output :> Netchannels.out_obj_channel)
page;
let want_stats =
Netstring_pcre.string_match
(Netstring_pcre.regexp "^text/html")
env.response_header.rh_content_type
0
<> None in
(* Finally, some statistics is appended: *)
if want_stats then begin
let b = Buffer.create 5000 in
let t5 = Unix.gettimeofday() in
bprintf b "\n<!-- Real time for process_request until start of output: -->\n";
bprintf b "<!-- Total time: %5.1f seconds -->\n" (t5 -. t0);
bprintf b "<!-- Initialization: %5.1f seconds -->\n" (!t1 -. t0);
bprintf b "<!-- 'handle': %5.1f seconds -->\n" (t2 -. !t1);
bprintf b "<!-- Setting up next page: %5.1f seconds -->\n" (t3 -. t2);
bprintf b "<!-- 'prepare_page': %5.1f seconds -->\n" (t4 -. t3);
bprintf b "<!-- Generation: %5.1f seconds -->\n" (t5 -. t4);
let p = Unix.times() in
bprintf b "\n<!-- Process time until start of output: -->\n";
bprintf b "<!-- User time: %5.1f seconds -->\n"
(p.Unix.tms_utime +. p.Unix.tms_cutime);
bprintf b "<!-- System time: %5.1f seconds -->\n"
(p.Unix.tms_stime +. p.Unix.tms_cstime);
let gc = Gc.stat() in
bprintf b "\n<!-- Memory consumption: -->\n";
bprintf b "<!-- Number of minor collections: %d -->\n"
(gc.Gc.minor_collections);
bprintf b "<!-- Number of major collections: %d -->\n"
(gc.Gc.major_collections);
cgi # output # output_buffer b;
end;
if env.debug_mode && want_stats then begin
(* Add 'ps' output: (Assumes Unix98 ps) *)
let ps_out =
Unix.open_process_in
("ps -l -y -p " ^ (string_of_int (Unix.getpid())) ^ " 2>/dev/null") in
try
while true do
let line = input_line ps_out in
printf "<!-- ps: %s -->\n" line
done
with End_of_file ->
ignore(Unix.close_process_in ps_out)
end;
(* If working with uidebuggger, output the new dialog state now to the
* communication pipe.
*)
(*
begin match ui_pipe_ch with
Some ch ->
output_string ch dlg_name;
output_string ch "\n";
output_string ch (Netencoding.Base64.encode (dlg # serialize));
output_string ch "\n";
close_out ch;
| None ->
()
end;
*)
);
()
;;
(* ======================================================================
* History:
*
* $Log: wd_cycle.ml,v $
* Revision 3.15 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.14 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.13 2004/08/01 18:30:33 stolpmann
* Removed dependency on Cgi.
*
* Revision 3.12 2003/03/09 17:09:12 stolpmann
* Fix: The current session is duplicated when a server popup
* request arrives
*
* Revision 3.11 2003/02/16 23:48:15 stolpmann
* Improved wd-debug-mode: there are now two styles
*
* Revision 3.10 2003/01/26 17:59:46 stolpmann
* new: Wd_cycle.make_environment
*
* Revision 3.9 2003/01/26 16:03:46 stolpmann
* It is now allowed to call [set_next_page] from [prepare_page].
*
* Revision 3.8 2003/01/15 23:04:28 stolpmann
* Statistics are only appended if output type is text/html
*
* Revision 3.7 2003/01/04 21:55:25 stolpmann
* new record response_header
*
* Revision 3.6 2002/11/09 12:19:12 stolpmann
* Fix: ui:select accepts dot notation
*
* Revision 3.5 2002/11/06 01:43:51 stolpmann
* Fix: digit_re
*
* Revision 3.4 2002/06/06 12:03:59 stolpmann
* Fix: when a popup request is received, the variable
* [within_popup] is set to [true].
* Workaround: In current versions of ocamlnet there is
* a bug in [split]. By prepending a space character to
* [visible_pages], the problematic case can be avoided.
*
* Revision 3.3 2002/02/26 16:00:42 stolpmann
* Fix: The order of associative variables is preserved if
* possible.
*
* 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.20 2002/02/11 11:14:21 gerd
* Fix: It is now possible to change the dialog of sessions (required
* for the Change_dialog exception)
*
* Revision 1.19 2002/02/05 18:51:22 gerd
* Support for session managers.
* Protected variables can no longer be set by CGI parameters.
* Popup pages must be declared with popup="yes".
*
* Revision 1.18 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.17 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.16 2001/05/21 12:54:24 gerd
* Removed debugging output: "OCaml memory in words". The
* type changed from int to float in O'Caml 3.01, and this information
* is not very useful at all.
*
* Revision 1.15 2001/01/15 12:28:52 gerd
* Fix: Added close_process_in for ps_out
*
* Revision 1.14 2000/12/21 17:08:57 gerd
* Fixed the workaround.
*
* Revision 1.13 2000/12/21 17:05:22 gerd
* Workaround for the strange behaviour of the Javascript
* 'escape' function which does not protect '+'.
*
* Revision 1.12 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.11 2000/12/06 17:52:45 gerd
* CGI arguments can be reset.
*
* Revision 1.10 2000/12/06 15:25:59 gerd
* Support for the ~self_url parameter.
*
* Revision 1.9 2000/11/30 18:39:28 gerd
* Implementation of ui:server-popup.
*
* Revision 1.8 2000/09/25 13:22:13 gerd
* New ui:popup element
*
* Revision 1.7 2000/05/15 11:46:33 gerd
* Necessary changes for uidebugger.
*
* Revision 1.6 2000/05/09 14:27:15 gerd
* Added many comments; changed the structure to make the
* concepts clearer.
* Furthermore, support for the "cgi" attribute.
*
* Revision 1.5 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.4 2000/05/08 15:30:08 gerd
* The default context is passed to the 'to_html' invocation.
*
* Revision 1.3 2000/05/08 10:34:32 gerd
* Dynamic parameters: An empty initial context is used. This
* is questionable, but currently the only possible way.
*
* 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.
*
*
*)
