(*
* <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: stubs.ml,v 3.4 2002-02-28 22:55:10 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Wd_types;;
open Perlvalues;;
(* NOTE: We still use the old names here. The term "uiobject" has the
* same meaning as "dialog".
*)
(* Perl reference counters: The procedure call conventions are as follows:
*
* - Arguments: It is the responsibility of the callee to increase the
* counter if another reference to the value is created. If you simply
* read the value of the argument, it is not necessary to increase the
* counter. If you put the value into a variable that survives the call,
* the counter must be increased. This is also necessary if you simply return
* the argument to the caller.
* It is the responsibility of the caller to decrease the counter if
* the reference is freed.
* - Result values: It is the responsibility of the caller to decrease the
* counter if the referencing variable is freed.
* It is the responsibility of the callee to increase the counter if
* values are extracted from variables that survive the call.
* Note: the newSV* functions create new values with a counter of 1, so
* if you pass them back as result you need not to first increase the
* counter.
*)
let empty_universe() =
new Wd_universe.universe
(new Wd_application.application
(new Pxp_dtd.dtd
(new Pxp_types.drop_warnings)
`Enc_iso88591
))
;;
let global_universe = ref (empty_universe()) ;;
(* The universe the Perl script uses. It will be initialized later *)
let global_universe_ready = ref false;;
(* Will be set to [true] when [global_universe] is initialized *)
let global_universe_deferred_registrations = ref [] ;;
(* Deferred [register] invocations for [global_universe] *)
let check_init() =
(* Call this function every time you access [global_universe] *)
if not !global_universe_ready then
failwith "WDialog is not yet initialized" ;;
let global_env = ref None ;;
(* The environment of the current CGI request. This variable is initialized
* by the class [special_universe] below. Okay, it's a trick.
*)
let get_global_env() =
match !global_env with
None -> assert false
| Some e -> e
;;
let global_cgi = ref None ;;
(* The current CGI activation *)
class special_universe app =
object
inherit Wd_universe.universe app as super
method create env name =
global_env := Some env;
super # create env name
end
;;
let uiobjects_list = ref [];;
let uiobjects_array = ref None;;
let uiobjects_number = ref 0;;
let uiobjects_offset = ref 0;;
(* The dialog objects that are referenced by Perl code. As reference
* an int is used. uiobjects_number contains the next free int.
* uiobjects_array contains the same as uiobjects_list, or None,
* if it is not yet initialized.
*)
let get_uiobj k =
(* Get the uiobject for an ID *)
begin match !uiobjects_array with
None ->
uiobjects_array := Some(Array.of_list(List.rev !uiobjects_list))
| Some a ->
()
end;
begin match !uiobjects_array with
None ->
assert false
| Some a ->
let n = k - !uiobjects_offset in
if n >= 0 && n < Array.length a then
fst(a.(n))
else
assert false
end
;;
let get_perlobj obj =
(* Get the Perl object of an uiobject, or raise Not_found *)
List.assoc obj !uiobjects_list
;;
class perl_uiobject init_prepare_closure_sv init_handle_closure_sv
init_self_sv
universe name env
=
object (self)
inherit Wd_dialog.dialog universe name env
val prepare_closure_sv = (init_prepare_closure_sv : scalar_value)
val handle_closure_sv = (init_handle_closure_sv : scalar_value)
val self_sv = (init_self_sv : scalar_value)
method prepare_page() =
pl_callback_1arg_noresult prepare_closure_sv self_sv;
method handle() =
let sv = pl_callback_1arg_scalar handle_closure_sv self_sv in
(* The return value is either 'undef' or the ID of the next object *)
if x_sviok sv then begin
let k = x_sviv sv in
let obj' = get_uiobj k in
svREFCNT_dec sv;
raise (Change_dialog obj')
end
(* WDialog never calls the [copy] method, so nobody calls it, so it is
* not necessary to redefine it here. (We would have to copy the Perl
* object, too.)
*)
method copy = assert false
end
;;
let make_string_sv s =
newSVpvn s (String.length s)
;;
let dest_string_sv sv =
fst(x_svpv sv)
;;
let array_of_av av =
let l = av_len av + 1 in
let init_sv = newSViv 0 in
let a = Array.create l init_sv in
for k = 0 to l-1 do
a.(k) <-
match av_fetch av k 0 with
None -> assert false
| Some x -> x
done;
svREFCNT_dec init_sv;
a
;;
let obj_id x =
string_of_int (Obj.obj ( Obj.field (Obj.repr x) 1 ) : int)
;;
let finalize_sv sv =
(* DEBUG *)
(* ( match svREFCNT sv with
0 -> prerr_endline ("Finalize: refcnt already 0 ???");
| 1 -> prerr_endline ("Finalize: expected");
| n -> prerr_endline ("Finalize: refcnt = " ^ string_of_int n)
);
*)
svREFCNT_dec sv
;;
let perl_universe_register name_sv prepare_closure_sv handle_closure_sv
create_closure_sv
=
(* Increment the ref counters because we store these values permanently in OCaml objects.
* The finalisers will decrement the counters automatically if the values are no longer
* reachable from OCaml.
*)
ignore(svREFCNT_inc(prepare_closure_sv));
ignore(svREFCNT_inc(handle_closure_sv));
ignore(svREFCNT_inc(create_closure_sv));
Gc.finalise finalize_sv prepare_closure_sv;
Gc.finalise finalize_sv handle_closure_sv;
Gc.finalise finalize_sv create_closure_sv;
let name, _ = x_svpv name_sv in
let obj_creator universe name env =
let id = !uiobjects_number in
incr uiobjects_number;
let id_sv = newSViv id in
let self_sv = pl_callback_1arg_scalar create_closure_sv id_sv in
svREFCNT_dec id_sv;
Gc.finalise finalize_sv self_sv;
let obj = new perl_uiobject prepare_closure_sv handle_closure_sv self_sv
universe name env in
uiobjects_list := (obj,self_sv) :: !uiobjects_list;
uiobjects_array := None;
obj
in
(* If [global_universe] is not yet initialized, simply put the arguments of [register]
* into [global_universe_deferred_registrations] - these [register] calls will be done
* later. This makes it possible that Perl code can register dialogs before the rest
* of the module is initialized.
*)
if !global_universe_ready then
!global_universe # register name obj_creator
else
global_universe_deferred_registrations :=
(name, obj_creator) :: !global_universe_deferred_registrations;
newSViv 1
;;
let perl_universe_create name_sv =
check_init();
let name, _ = x_svpv name_sv in
let obj = !global_universe # create (get_global_env()) name in
let sv =
try get_perlobj obj
with Not_found ->
failwith("WDialog(perl_universe_create): Cannot return the perl object of a non-Perl dialog object")
in
(* Because this sv is just another pointer, increment the counter *)
ignore(svREFCNT_inc(sv));
sv
;;
let perl_uiobject_name descr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
make_string_sv(obj # name)
;;
let perl_uiobject_page_name descr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
make_string_sv(obj # page_name)
;;
let perl_uiobject_next_page descr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
make_string_sv(obj # next_page)
;;
let perl_uiobject_set_next_page descr_sv pg_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let pg, _ = x_svpv pg_sv in
obj # set_next_page pg;
newSViv 1
;;
let av_make_dec elements =
(* Because av_make copies the passed array of elements
* the counter of the elements should be decremented
*)
let av = av_make (Array.length elements) elements in
Array.iter
(fun el -> ignore(svREFCNT_dec el))
elements;
av
;;
let perl_uiobject_page_names descr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let l = obj # page_names in
let a = Array.of_list l in
let av = av_make_dec
(Array.map make_string_sv a) in
newRV_noinc_from_av av
;;
let perl_uiobject_variable descr_sv name_sv =
let rec make_UI_Variable v =
match v with
String_value s ->
let a =
[| make_string_sv "UI::Variable::String";
make_string_sv s
|] in
newRV_noinc_from_av (av_make_dec a)
| Enum_value l ->
let a =
Array.of_list
((make_string_sv "UI::Variable::Enum")
:: (List.map make_string_sv l)) in
newRV_noinc_from_av (av_make_dec a)
| Dyn_enum_value l ->
let l' =
List.map
(fun (intern,extern) ->
let intern' = make_string_sv intern in
let extern' = make_string_sv extern in
newRV_noinc_from_av (av_make_dec [| intern'; extern' |]))
l
in
let a =
Array.of_list
((make_string_sv "UI::Variable::DynEnum")
:: l') in
newRV_noinc_from_av (av_make_dec a)
| Dialog_value None ->
let a =
[| make_string_sv "UI::Variable::Dialog";
x_sv_undef();
|] in
newRV_noinc_from_av (av_make_dec a)
| Dialog_value (Some obj) ->
let obj_sv =
try get_perlobj obj
with Not_found ->
failwith("WDialog(perl_uiobject_variablt): Cannot return the perl object of a non-Perl dialog object")
in
ignore(svREFCNT_inc(obj_sv));
let a =
[| make_string_sv "UI::Variable::Dialog";
obj_sv
|] in
newRV_noinc_from_av (av_make_dec a)
| Alist_value l ->
let l' =
List.map
(fun (key,value) ->
let key' = make_string_sv key in
let value' = make_UI_Variable value in
newRV_noinc_from_av (av_make_dec [| key'; value' |]))
l
in
let a =
Array.of_list
((make_string_sv "UI::Variable::Alist")
:: l') in
newRV_noinc_from_av (av_make_dec a)
| _ ->
failwith "perl_uiobject_variable"
in
let obj = get_uiobj (x_sviv descr_sv) in
let name, _ = x_svpv name_sv in
make_UI_Variable (obj # variable name)
;;
let perl_uiobject_string_variable descr_sv name_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name, _ = x_svpv name_sv in
make_string_sv(obj # string_variable name)
;;
(* Get variables of other types:
* There is no real advantage for special stubs; use the general-purpose
* perl_uiobject_variable instead.
*)
let perl_uiobject_set_variable descr_sv name_sv repr_sv =
let rec mkvalue r_sv =
let get av n =
let l = av_len av in
if n < 0 or n > l then
failwith "perl_uiobject_set_variable"
else
match av_fetch av n 0 with
None ->
failwith "perl_uiobject_set_variable"
| Some x ->
x
in
let av = x_AvRV r_sv in
let sv = get av 0 in
let kind = x_sviv sv in
if kind < 0 or kind > 4 then failwith "perl_uiobject_set_variable";
match kind with
0 ->
(* String *)
let rv = get av 1 in
String_value (dest_string_sv (x_SvRV rv))
| 1 ->
(* Enum *)
let av1 = x_AvRV(get av 1) in
let a = array_of_av av1 in
Enum_value
(List.map dest_string_sv (Array.to_list a))
| 2 ->
(* DynEnum *)
let av1 = x_AvRV(get av 1) in
let a = array_of_av av1 in
Dyn_enum_value
(List.map
(fun pair_rv ->
let pair_av = x_AvRV pair_rv in
dest_string_sv (get pair_av 0),
dest_string_sv (get pair_av 1))
(Array.to_list a))
| 3 ->
(* Dialog *)
let sv = get av 1 in
if x_sviok sv then begin
let id = x_sviv sv in
Dialog_value (Some (get_uiobj id))
end
else Dialog_value None
| 4 ->
(* Alist *)
let av1 = x_AvRV(get av 1) in
let a = array_of_av av1 in
Alist_value
(List.map
(fun pair_rv ->
let pair_av = x_AvRV pair_rv in
dest_string_sv (get pair_av 0),
mkvalue (get pair_av 1))
(Array.to_list a))
| _ ->
assert false
in
let obj = get_uiobj (x_sviv descr_sv) in
let name, _ = x_svpv name_sv in
let v =
try
mkvalue repr_sv
with
Not_found -> failwith "perl_uiobject_set_variable"
in
obj # set_variable name v;
newSViv 1
;;
let perl_uiobject_unset_variable descr_sv name_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name, _ = x_svpv name_sv in
obj # unset_variable name;
newSViv 1
;;
let perl_uiobject_set_string_variable descr_sv name_sv value_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name, _ = x_svpv name_sv in
let value, _ = x_svpv value_sv in
obj # set_variable name (String_value value);
newSViv 1
;;
let perl_uiobject_event descr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let e = obj # event in
let a =
match e with
Button s ->
[| "BUTTON"; s |]
| Indexed_button(s,idx) ->
[| "INDEXED_BUTTON"; s; idx |]
| Image_button(s,x,y) ->
[| "IMAGE_BUTTON"; s; string_of_int x; string_of_int y |]
| Indexed_image_button(s,idx,x,y) ->
[| "INDEXED_IMAGE_BUTTON"; s; idx; string_of_int x; string_of_int y |]
| No_event ->
[| "NO_EVENT" |]
| Popup_request s ->
[| "POPUP_REQUEST"; s |]
in
let av = av_make_dec
(Array.map make_string_sv a) in
newRV_noinc_from_av av
;;
let perl_uiobject_set_event descr_sv e_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let av = x_AvRV e_sv in
let a = Array.map dest_string_sv (array_of_av av) in
begin match a with
[| "BUTTON"; s |] ->
obj # set_event (Button s)
| [| "INDEXED_BUTTON"; s; idx |] ->
obj # set_event (Indexed_button(s,idx));
| [| "IMAGE_BUTTON"; s; x; y |] ->
obj # set_event (Image_button(s,int_of_string x,int_of_string y));
| [| "INDEXED_IMAGE_BUTTON"; s; idx; x; y |] ->
obj # set_event (Indexed_image_button
(s,idx,int_of_string x,int_of_string y));
| [| "NO_EVENT" |] ->
obj # set_event No_event;
| [| "POPUP_REQUEST"; s |] ->
obj # set_event (Popup_request s);
| _ ->
failwith "perl_uiobject_set_event"
end;
newSViv 1
;;
let perl_uiobject_init descr_sv page_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let page, _ = x_svpv page_sv in
obj # init page;
newSViv 1
;;
let perl_uiobject_upload_filename descr_sv name_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name = dest_string_sv name_sv in
try
let argopt = obj # lookup_uploaded_file name in (* or raise Not_found *)
match argopt with
None -> make_string_sv ""
| Some arg ->
begin match arg # filename with
None -> make_string_sv ""
| Some x -> make_string_sv x
end
with
Not_found -> make_string_sv ""
;;
let perl_uiobject_upload_mimetype descr_sv name_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name = dest_string_sv name_sv in
try
let argopt = obj # lookup_uploaded_file name in (* or raise Not_found *)
match argopt with
None -> make_string_sv ""
| Some arg ->
make_string_sv (arg # content_type)
with
Not_found -> make_string_sv ""
;;
let perl_uiobject_upload_sysname descr_sv name_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let name = dest_string_sv name_sv in
try
let argopt = obj # lookup_uploaded_file name in (* or raise Not_found *)
match argopt with
None -> make_string_sv ""
| Some arg ->
begin match arg # store with
`Memory -> make_string_sv ""
| `File x -> make_string_sv x
end
with
Not_found -> make_string_sv ""
;;
(* ---------------------------------------------------------------------- *)
type tt =
Tree of Wd_template.tree
| Tmpl of Wd_template.template
;;
let tt_list = ref [];;
let tt_array = ref None;;
let tt_number = ref 0;;
let tt_offset = ref 0
let perl_template_get name_sv =
check_init();
let name = dest_string_sv name_sv in
let tmpl = Wd_template.get (!global_universe#application) name in
tt_list := (Tmpl tmpl) :: !tt_list;
tt_array := None;
let k = !tt_number in
incr tt_number;
newSViv k
;;
let new_tree tr =
tt_list := (Tree tr) :: !tt_list;
tt_array := None;
let k = !tt_number in
incr tt_number;
k
;;
let get_tt k =
begin match !tt_array with
None ->
tt_array := Some(Array.of_list(List.rev !tt_list))
| Some a ->
()
end;
begin match !tt_array with
None ->
assert false
| Some a ->
let n = k - !tt_offset in
if n >= 0 && n < Array.length a then
a.(n)
else
assert false
end
;;
(* CHANGE: new descr_sv *)
let perl_template_apply descr_sv tt_id_sv params_rv =
let obj = get_uiobj (x_sviv descr_sv) in
let tt = get_tt (x_sviv tt_id_sv) in
match tt with
Tmpl tmpl ->
if x_svrok params_rv = 0 then
failwith "perl_template_apply";
let hv = x_HvRV params_rv in
let params = ref [] in
ignore(hv_iterinit hv);
begin try
while true do
let he = hv_iternext hv in (* or raise Not_found *)
let key,_ = hv_iterkey he in
let rv = hv_iterval hv he in
if x_svrok rv = 0 then
failwith "perl_template_apply";
let id = x_sviv (x_SvRV rv) in
let tt_el = get_tt id in
match tt_el with
Tmpl _ -> failwith "perl_template_apply";
| Tree tr ->
params := (key, tr) :: !params
done
with
Not_found -> ()
end;
let result = Wd_template.apply obj tmpl !params in
let k = new_tree result in
newSViv k
| Tree _ ->
failwith "perl_template_apply"
;;
let perl_template_concat sep_sv args_rv =
check_init();
let sep_tt = get_tt (x_sviv sep_sv) in
if x_svrok args_rv = 0 then
failwith "perl_template_concat";
let args_a = array_of_av (x_AvRV args_rv) in
let args =
List.map
(fun rv ->
if x_svrok rv = 0 then
failwith "perl_template_apply";
let id = x_sviv (x_SvRV rv) in
let tt = get_tt id in
match tt with
Tmpl _ -> failwith "perl_template_concat"
| Tree tr -> tr
)
(Array.to_list args_a) in
match sep_tt with
Tmpl _ -> failwith "perl_template_concat"
| Tree tr ->
let result =
Wd_template.concat (!global_universe#application) tr args in
let k = new_tree result in
newSViv k
;;
let perl_template_empty dummy =
check_init();
let result = Wd_template.empty (!global_universe#application) in
let k = new_tree result in
newSViv k
;;
let perl_template_text sv =
check_init();
let result =
Wd_template.text (!global_universe#application) (dest_string_sv sv) in
let k = new_tree result in
newSViv k
;;
let perl_template_html sv =
check_init();
let result =
Wd_template.html (!global_universe#application) (dest_string_sv sv) in
let k = new_tree result in
newSViv k
;;
let perl_template_to_string descr_sv tr_sv =
let obj = get_uiobj (x_sviv descr_sv) in
let tt = get_tt (x_sviv tr_sv) in
match tt with
Tmpl _ -> failwith "perl_template_to_string"
| Tree tr ->
let s = Wd_template.to_string obj tr in
make_string_sv s
;;
(* ---------------------------------------------------------------------- *)
let perl_cgi_param sv =
let name = dest_string_sv sv in
try
let value =
match !global_cgi with
None -> failwith "perl_cgi_param: CGI parameters not available"
| Some cgi -> (cgi # argument name) # value in
make_string_sv value
with
Not_found ->
(* x_sv_undef() *)
make_string_sv "" (* TODO: Cannot return undef *)
;;
let collect_arguments = ref [];;
let use_collected_arguments = ref false;;
let perl_cgi_add_param name_sv value_sv =
let name = dest_string_sv name_sv in
let value = dest_string_sv value_sv in
collect_arguments :=
new Netcgi.simple_argument ~ro:true name value :: !collect_arguments;
newSViv 1
;;
let perl_cgi_add_upload name_sv filename_sv mimetype_sv sysname_sv =
let name = dest_string_sv name_sv in
let filename = dest_string_sv filename_sv in
let mimetype = dest_string_sv mimetype_sv in
let sysname = dest_string_sv sysname_sv in
let qfn_buffer = Buffer.create 128 in
let qfn_ch = new Netchannels.output_buffer qfn_buffer in
Mimestring.write_value qfn_ch [ Mimestring.QString filename ];
let hdr = [ "Content-Type", mimetype;
"Content-Disposition", ("form-data; filename=" ^ Buffer.contents qfn_buffer)
] in
collect_arguments := new Netcgi.mime_argument
~work_around_backslash_bug:false
name
(new Netmime.basic_mime_header ~ro:true hdr,
`Body (new Netmime.file_mime_body ~ro:true sysname))
:: !collect_arguments;
newSViv 1
;;
let perl_cgi_set _ =
use_collected_arguments := true; (* this will remind us to use collect_arguments *)
newSViv 1
;;
(* ---------------------------------------------------------------------- *)
let perl_reset dummy_sv =
(* Forget the connections to Perl objects: *)
uiobjects_offset := !uiobjects_number;
uiobjects_list := [];
uiobjects_array := None;
tt_offset := !tt_number;
tt_list := [];
tt_array := None;
collect_arguments := [];
use_collected_arguments := false;
global_universe_ready := false;
global_universe := empty_universe();
global_universe_deferred_registrations := [];
global_env := None;
global_cgi := None;
(* DEBUG *)
(* Gc.full_major();
(* Output statistics: *)
Gc.print_stat stdout;
*)
newSViv 1
;;
let perl_setup uifile_sv =
(* Set the ui file to parse, i.e. set global_universe *)
let uifile = dest_string_sv uifile_sv in
let app =
if Filename.check_suffix uifile ".ui" then
Wd_transform.parse_uiapplication uifile
else if Filename.check_suffix uifile ".ui.bin" then
Wd_transform.load_uiapplication uifile
else
failwith "perl_setup";
in
global_universe_ready := true;
global_universe := new special_universe app;
(* Use special_universe such that global_env will be initialized *)
(* Do now the deferred registrations: *)
List.iter
(fun (name, create) ->
!global_universe # register name create
)
(List.rev !global_universe_deferred_registrations);
global_universe_deferred_registrations := [];
newSViv 1
;;
let processing name header = `Automatic ;;
(* Use the MIME header to decide whether to use `Memory or `File,
* but not the parameter name
*)
(*
let upload = "upload_" in
let l = String.length upload in
if String.length name >= l && String.sub name 0 l = upload then
`File
else
`Memory
;;
*)
let operating_type = Netcgi.buffered_transactional_optype;;
let process_request (cgi:Netcgi_types.cgi_activation)
error_closure_sv self_url_sv nocache_sv =
check_init();
let no_cache = x_sviv nocache_sv <> 0 in
let self_url = dest_string_sv self_url_sv in
let error_page estring =
let sv = pl_callback_1arg_scalar error_closure_sv
(make_string_sv estring)
in
let out = dest_string_sv sv in
svREFCNT_dec sv;
out
in
begin try
global_cgi := Some cgi;
let cache =
match cgi # request_method with
`GET -> `No_cache
| `POST -> if no_cache then `No_cache else `Unspecified
| _ -> assert false
in
cgi # set_header (*~fields:header*) ~cache ();
Wd_cycle.process_request ~self_url !global_universe cgi;
with
exc ->
cgi # output # rollback_work();
cgi # set_header ~cache:`No_cache ();
let s = error_page (Printexc.to_string exc) in
cgi # output # output_string s;
end;
cgi # output # commit_work();
cgi # finalize()
;;
let special_env() =
let env = new Netcgi_env.custom_environment() in
env # set_output_ch (new Netchannels.output_channel stdout);
env # set_input_state `Received_body;
env # setup_finished();
(env :> Netcgi_env.cgi_environment)
;;
let perl_process_request error_closure_sv self_url_sv nocache_sv =
let cgi =
if !use_collected_arguments then
let env = special_env() in
new Netcgi.custom_activation ~env ~args:!collect_arguments ~meth:`POST ~operating_type ()
else
new Netcgi.std_activation ~processing ~operating_type ()
in
process_request cgi error_closure_sv self_url_sv nocache_sv;
newSViv 1
;;
class my_output buf : Netchannels.trans_out_obj_channel =
object
inherit Netchannels.output_buffer buf
val buf = buf
method commit_work() = ()
method rollback_work() = Buffer.clear buf
end
;;
let perl_process_request_noprint error_closure_sv self_url_sv dummy_sv =
let buf = Buffer.create 65536 in
let operating_type =
`Transactional (fun _ _ -> new my_output buf) in
let cgi =
if !use_collected_arguments then
let env = special_env() in
new Netcgi.custom_activation ~env ~args:!collect_arguments ~meth:`POST ~operating_type ()
else
new Netcgi.std_activation ~processing ~operating_type ()
in
cgi # environment # set_output_state `Sent_header;
(* This prevents that netcgi sends the header *)
process_request cgi error_closure_sv self_url_sv dummy_sv;
make_string_sv (Buffer.contents buf)
;;
(* ---------------------------------------------------------------------- *)
let r1 name (f : scalar_value -> scalar_value) =
Callback.register name f;;
let r2 name (f : scalar_value -> scalar_value -> scalar_value) =
Callback.register name f;;
let r3 name (f : scalar_value -> scalar_value -> scalar_value -> scalar_value)
=
Callback.register name f;;
let r4 name (f : scalar_value -> scalar_value -> scalar_value -> scalar_value
-> scalar_value
)
=
Callback.register name f;;
let r5 name (f : scalar_value -> scalar_value -> scalar_value -> scalar_value
-> scalar_value -> scalar_value
)
=
Callback.register name f;;
r1 "perl_caml_reset" perl_reset;
r1 "perl_setup" perl_setup;
r3 "perl_process_request" perl_process_request; (* CHANGED *)
r3 "perl_process_request_noprint" perl_process_request_noprint; (* CHANGED *)
r1 "perl_uiobject_name" perl_uiobject_name;;
r1 "perl_uiobject_page_name" perl_uiobject_page_name;;
r1 "perl_uiobject_page_names" perl_uiobject_page_names;;
r1 "perl_uiobject_next_page" perl_uiobject_next_page;;
r2 "perl_uiobject_set_next_page" perl_uiobject_set_next_page;;
r2 "perl_uiobject_variable" perl_uiobject_variable;;
r2 "perl_uiobject_string_variable" perl_uiobject_string_variable;;
r3 "perl_uiobject_set_variable" perl_uiobject_set_variable;;
r3 "perl_uiobject_set_string_variable" perl_uiobject_set_string_variable;;
r2 "perl_uiobject_unset_variable" perl_uiobject_unset_variable;;
r1 "perl_uiobject_event" perl_uiobject_event;;
r2 "perl_uiobject_set_event" perl_uiobject_set_event;;
r2 "perl_uiobject_init" perl_uiobject_init;;
r2 "perl_uiobject_upload_filename" perl_uiobject_upload_filename;;
r2 "perl_uiobject_upload_mimetype" perl_uiobject_upload_mimetype;;
r2 "perl_uiobject_upload_sysname" perl_uiobject_upload_sysname;;
r4 "perl_universe_register" perl_universe_register; (* CHANGED *)
r1 "perl_universe_create" perl_universe_create;; (* CHANGED *)
r1 "perl_template_get" perl_template_get;;
r3 "perl_template_apply" perl_template_apply;; (* CHANGED *)
r2 "perl_template_concat" perl_template_concat;;
r1 "perl_template_empty" perl_template_empty;;
r1 "perl_template_text" perl_template_text;;
r1 "perl_template_html" perl_template_html;;
r2 "perl_template_to_string" perl_template_to_string;;
r1 "perl_cgi_param" perl_cgi_param;;
r2 "perl_cgi_add_param" perl_cgi_add_param;;
r4 "perl_cgi_add_upload" perl_cgi_add_upload;;
r1 "perl_cgi_set" perl_cgi_set;;
(* ======================================================================
* History:
*
* $Log: stubs.ml,v $
* Revision 3.4 2002-02-28 22:55:10 stolpmann
* New: global_cgi stores the CGI activation object.
*
* Revision 3.3 2002/02/28 18:50:44 stolpmann
* Continued with perlapi (lots of bugfixes)
*
* Revision 3.2 2002/02/14 16:24:13 stolpmann
* Added copyright notice
*
* Revision 3.1 2002/02/12 23:11:25 stolpmann
* Initial revision at sourceforge
*
* Revision 1.8 2002/01/22 17:35:32 gerd
* Fixed a lot of memory leaks.
*
* Revision 1.7 2002/01/21 14:25:36 gerd
* Changed for upcoming WDialog 2
*
* Revision 1.6 2000/12/21 15:03:26 gerd
* Updated to support the Popup_request parameter.
*
* Revision 1.5 2000/12/06 17:53:36 gerd
* Updated.
*
* Revision 1.4 2000/12/04 18:28:31 gerd
* Added the Popup_request event.
*
* Revision 1.3 2000/09/21 15:12:30 gerd
* Updated for O'Caml 3 and PXP
*
* Revision 1.2 2000/04/17 10:12:55 gerd
* Improved file upload.
* Furthermore, the traditional CGI.pm package can be used,
* if the user prefers this.
*
* Revision 1.1 2000/04/13 17:42:53 gerd
* Initial revision.
*
*
*)
