Commit 55a56acc authored by gerd's avatar gerd

ported to ocamlnet-3


git-svn-id: https://godirepo.camlcity.org/svn/wdialog/trunk@232 f54c9a64-0731-4a92-b797-30fd5898f27c
parent 536709f6
......@@ -11,7 +11,7 @@
set_defaults () {
enable_findlib=1
with_wdialog_p4=1
with_wdialog_p4=0
with_wdialog_perlguts=0
# with_wd_debugger=1
with_wd_xmlcompiler=1
......@@ -27,7 +27,7 @@ exec_suffix=""
ehelp_findlib="Enable/disable installation as findlib package"
whelp_wd_session_daemon="Include/omit the session state daemon"
whelp_wd_inmemory_session="Include/omit support for in-memory sessions"
whelp_wdialog_p4="Include/omit wdialog syntax extensions (camlp4)"
whelp_wdialog_p4="Include/omit wdialog syntax extensions (camlp4) - BROKEN"
whelp_wdialog_perlguts="Include/omit library for interfacing Perl"
#whelp_wd_debugger="Inlude/omit wdialog debugger"
whelp_wd_xmlcompiler="Include/omit wdialog XML tree compiler"
......
......@@ -11,8 +11,7 @@ OBJECTS = wd_ocamlversion.cmo \
wd_upload.cmo wd_templrep.cmo wd_application_dtd.cmo \
wd_dialog_decl.cmo wd_application.cmo wd_transform.cmo \
wd_template.cmo wd_dialog.cmo \
wd_universe.cmo wd_cycle.cmo wd_run_fcgi.cmo \
wd_run_cgi.cmo wd_run_jserv.cmo
wd_universe.cmo wd_cycle.cmo wd_run_cgi.cmo
# interfaces to include in the ocamldoc output:
INTERFACES = $(shell echo *.mli)
......
......@@ -62,7 +62,7 @@ class empty_dialog universe name env =
* 'force_handle_invocation' to a value other than "".
*)
let extended_arguments (cgi:Netcgi_types.cgi_activation) =
let extended_arguments (cgi:Netcgi.cgi_activation) =
(* Return the CGI arguments plus the decoded contents of
* 'uiobject_extra_args'.
* - Some notes:
......@@ -91,9 +91,12 @@ let extended_arguments (cgi:Netcgi_types.cgi_activation) =
Netencoding.Url.dest_url_encoded_parameters extra' in (* TODO *)
let extra_args =
List.map
(fun (n,v) -> n, new Netcgi.simple_argument n v)
(fun (n,v) ->
(new Netcgi.simple_argument n v :> Netcgi.cgi_argument))
extra_decoded in
extra_args @ cgi_args
List.map
(fun arg -> arg#name, arg)
(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
......@@ -107,8 +110,8 @@ let debug_print_args cgi =
(* Dumps the real set of CGI parameters to stderr *)
prerr_endline "*** Beginning dump of CGI parameters:";
List.iter
(fun (v,n) ->
prerr_endline (v ^ "=" ^ n#value);
(fun arg ->
prerr_endline (arg#name ^ "=" ^ arg#value);
)
(cgi # arguments);
prerr_endline "--- End of dump";
......@@ -636,7 +639,7 @@ let process_request
?(session_manager = new Wd_dialog.instant_session_manager())
?self_url
?(response_header = default_response_header)
(universe:universe_type) (cgi:Netcgi_types.cgi_activation) =
(universe:universe_type) (cgi:Netcgi.cgi_activation) =
(* Main processing function: Interprets CGI parameters, and outputs
* the next page according to CGI.
*)
......
......@@ -39,7 +39,7 @@ val process_request :
?self_url:string ->
?response_header:response_header ->
universe_type ->
Netcgi_types.cgi_activation ->
Netcgi.cgi_activation ->
unit
(** This is the main function processing requests coming from the browser.
* It expects a CGI environment, interprets the CGI variables and performs
......@@ -71,7 +71,7 @@ val process_request :
* [response_header] field of the [environment] record).
*)
val make_environment : Netcgi_types.cgi_activation -> environment
val make_environment : Netcgi.cgi_activation -> environment
(** Creates an (otherwise empty) environment with the passed CGI
* activation object.
*)
......
......@@ -64,100 +64,104 @@ let run
?session_manager
?(no_cache = true)
?(error_page = print_error)
?(cgi = new std_activation ~processing ~operating_type ())
?cgi_config
?(output_type = operating_type)
?response_header
?(reg = (fun _ -> ()))
() =
begin try
let suggested_script_file_name, suggested_url =
match script with
None ->
let script_path =
cgi # environment # cgi_script_name in
let b = Filename.basename script_path in
if b = "" then "index.cgi", "" else b, b
| Some s ->
s, Filename.basename s
in
let url =
match self_url with
None ->
"./" ^ suggested_url
| Some u ->
u
in
let ui_file_name =
match uifile with
None ->
( try
Filename.chop_extension suggested_script_file_name ^ ".ui"
with _ ->
"index.ui"
)
| Some f ->
f
in
(* Load the UI term: *)
let ui_compiled_file_name =
Filename.chop_extension ui_file_name ^ ".ui.bin" in
let app =
if Sys.file_exists ui_compiled_file_name then
Wd_transform.load_uiapplication ~charset ui_compiled_file_name
else
Wd_transform.parse_uiapplication ~charset ui_file_name
in
let cache =
match cgi # request_method with
`GET -> `No_cache
| `POST -> if no_cache then `No_cache else `Unspecified
| _ -> assert false
in
let charset_s =
Netconversion.string_of_encoding (charset :> Netconversion.encoding) in
let response_header =
match response_header with
None -> { rh_status = `Ok;
rh_content_type = "text/html; charset=" ^ charset_s;
(* Note: Some browsers (e.g. Mozilla-0.9.6) do not like
* quotes around charset
*)
rh_cache = cache;
rh_filename = None;
rh_language = None;
rh_script_type = None;
rh_style_type = None;
rh_set_cookie = [];
rh_fields = [];
}
| Some rh -> rh
in
let universe = new Wd_universe.universe app in
reg universe;
Wd_cycle.process_request ?session_manager ~self_url:url ~response_header
universe cgi;
with
exc ->
cgi # output # rollback_work();
cgi # set_header ~status:`Internal_server_error ~cache:`No_cache ();
error_page (cgi#output :> out_obj_channel) exc;
(* may raise another exception! *)
end;
cgi # output # commit_work();
cgi # finalize();
()
Netcgi_cgi.run
?config:cgi_config
~output_type
(fun cgi ->
begin try
let suggested_script_file_name, suggested_url =
match script with
None ->
let script_path =
cgi # environment # cgi_script_name in
let b = Filename.basename script_path in
if b = "" then "index.cgi", "" else b, b
| Some s ->
s, Filename.basename s
in
let url =
match self_url with
None ->
"./" ^ suggested_url
| Some u ->
u
in
let ui_file_name =
match uifile with
None ->
( try
Filename.chop_extension suggested_script_file_name ^ ".ui"
with _ ->
"index.ui"
)
| Some f ->
f
in
(* Load the UI term: *)
let ui_compiled_file_name =
Filename.chop_extension ui_file_name ^ ".ui.bin" in
let app =
if Sys.file_exists ui_compiled_file_name then
Wd_transform.load_uiapplication ~charset ui_compiled_file_name
else
Wd_transform.parse_uiapplication ~charset ui_file_name
in
let cache =
match cgi # request_method with
`GET -> `No_cache
| `POST -> if no_cache then `No_cache else `Unspecified
| _ -> assert false
in
let charset_s =
Netconversion.string_of_encoding (charset :> Netconversion.encoding) in
let response_header =
match response_header with
None -> { rh_status = `Ok;
rh_content_type = "text/html; charset=" ^ charset_s;
(* Note: Some browsers (e.g. Mozilla-0.9.6) do not like
* quotes around charset
*)
rh_cache = cache;
rh_filename = None;
rh_language = None;
rh_script_type = None;
rh_style_type = None;
rh_set_cookie = [];
rh_fields = [];
}
| Some rh -> rh
in
let universe = new Wd_universe.universe app in
reg universe;
Wd_cycle.process_request ?session_manager ~self_url:url ~response_header
universe cgi;
with
exc ->
cgi # output # rollback_work();
cgi # set_header ~status:`Internal_server_error ~cache:`No_cache ();
error_page (cgi#output :> out_obj_channel) exc;
(* may raise another exception! *)
end;
cgi # output # commit_work();
cgi # finalize();
);
;;
......
......@@ -44,7 +44,8 @@ val run :
?session_manager:session_manager_type -> (* defalt: instant_session_manager *)
?no_cache:bool -> (* default: true *)
?error_page:(out_obj_channel -> exn -> unit) -> (* default: a simple error page *)
?cgi:Netcgi_types.cgi_activation -> (* default: a [std_activation] object *)
?cgi_config:Netcgi.config ->
?output_type:Netcgi.output_type ->
?response_header:response_header -> (* default: see below *)
?reg:(universe_type -> unit) ->
unit ->
......
......@@ -121,14 +121,14 @@ type 'dlg poly_var_decl =
type response_header =
{ mutable rh_status : Netcgi_types.status;
{ mutable rh_status : Nethttp.http_status;
mutable rh_content_type : string;
mutable rh_cache : Netcgi_types.cache_control;
mutable rh_cache : Netcgi.cache_control;
mutable rh_filename : string option;
mutable rh_language : string option;
mutable rh_script_type : string option;
mutable rh_style_type : string option;
mutable rh_set_cookie : Netcgi_types.cgi_cookie list;
mutable rh_set_cookie : Nethttp.cookie list;
mutable rh_fields : (string * string list) list;
}
......@@ -146,7 +146,7 @@ type environment =
(* Web variables *)
self_url : string;
response_header : response_header;
cgi : Netcgi_types.cgi_activation;
cgi : Netcgi.cgi_activation;
}
......@@ -253,7 +253,7 @@ and virtual dialog_type =
dialog_type poly_var_value )
method set_variable : string -> dialog_type poly_var_value -> unit
method unset_variable : string -> unit
method lookup_uploaded_file : string -> Netcgi_types.cgi_argument option
method lookup_uploaded_file : string -> Netcgi.cgi_argument option
method dump : Format.formatter -> unit
method next_page : string
method set_next_page : string -> unit
......
......@@ -374,14 +374,14 @@ type 'dlg poly_var_decl =
type response_header =
{ mutable rh_status : Netcgi_types.status;
{ mutable rh_status : Nethttp.http_status;
mutable rh_content_type : string;
mutable rh_cache : Netcgi_types.cache_control;
mutable rh_cache : Netcgi.cache_control;
mutable rh_filename : string option;
mutable rh_language : string option;
mutable rh_script_type : string option;
mutable rh_style_type : string option;
mutable rh_set_cookie : Netcgi_types.cgi_cookie list;
mutable rh_set_cookie : Nethttp.cookie list;
mutable rh_fields : (string * string list) list;
}
(** This record contains the CGI header of the response. It is initialized
......@@ -407,7 +407,7 @@ type environment =
(* Web variables *)
self_url : string;
response_header : response_header;
cgi : Netcgi_types.cgi_activation;
cgi : Netcgi.cgi_activation;
}
(** This record contains data that may be different for every CGI request. The
* [debug_mode] and [prototype_mode] components are true iff the corresponding
......@@ -659,7 +659,7 @@ object ('self)
* For enumerators: the default is the empty list.
* For dialogs: the default is that the value does not exist.
*)
method lookup_uploaded_file : string -> Netcgi_types.cgi_argument option
method lookup_uploaded_file : string -> Netcgi.cgi_argument option
(** [lookup_uploaded_file name]:
* Checks whether the file upload box [name] was used. If so,
* [Some arg], where [arg] is the transporting CGI argument is returned.
......
......@@ -28,7 +28,7 @@
open Wd_types
type upload_manager = (string, Netcgi_types.cgi_argument) Hashtbl.t
type upload_manager = (string, Netcgi.cgi_argument) Hashtbl.t
let get m name =
......@@ -66,7 +66,7 @@ let init env ia =
* Due to the spec, we add an empty pseudo-argument.
*)
let arg = new Netcgi.simple_argument name "" in
Hashtbl.add m name arg
Hashtbl.add m name (arg :> Netcgi.cgi_argument)
)
ia.ui_uploads;
......
......@@ -32,7 +32,7 @@
type upload_manager
(** Manages the file upload parameters of a certain request *)
val get : upload_manager -> string -> Netcgi_types.cgi_argument
val get : upload_manager -> string -> Netcgi.cgi_argument
(** Returns the CGI argument containing the file upload information for
* the file upload box with the passed name. This name is what is
* specified in the "name" attribute of ui:file.
......
......@@ -426,7 +426,7 @@ let compile_regexp s =
try
Pcre.regexp s
with
Pcre.BadPattern (msg, pos) ->
Pcre.Error(Pcre.BadPattern (msg, pos)) ->
failwith ("Bad regular expression, at position " ^
string_of_int pos ^ ": " ^ msg)
;;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment