This is the same option as the ocamlfind one.
.TP
.BR \-predicates\
This is the same option as the ocamlfind one.
.TP
.BR \-no-autoload
Do not load commonly used syntax extensions
(ppx_deriving, lwt, js_of_ocaml, tyxml).
.TP
.BR \-type-conv
Use type_conv syntax extensions instead of deriving one. It has no effect
if used in conjunction with \-no-autoload.
.TP
.BR \-ppopt\
Append to preprocessor invocation.
.TP
.BR \-jsopt\
Append to js_of_ocaml invocation (js_of_eliom only).
.TP
.BR \-infer\
For .eliom file, only generate the intermediate .type_mli file (eliomc and eliomopt only).
.TP
.BR \-noinfer\
For .eliom file, do not generate the intermediate .type_mli file (eliomc and eliomopt only).
.TP
.BR \-help \ or \ \-\-help
Display a short usage summary and exit.
.SH EXAMPLES
The compilation of an Eliom projects composed of a server specific file named server.ml, a client specific file named client.ml and two common files name base.eliom and main.eliom, could be achieved with the following commands:
\ \ \ \ eliomc \-a \-o appl.cma server.ml base.eliom main.eliom
.br
\ \ \ \ js_of_eliom \-o appl.js client.ml base.eliom main.eliom
To avoid recompiling the whole project each times, this could be split in multiple steps:
\ \ \ \ eliomc \-c server.ml
.br
\ \ \ \ eliomc \-c base.eliom
.br
\ \ \ \ eliomc \-c main.eliom
.br
\ \ \ \ eliomc \-a \-o appl.cma _server/server.cmo _server/base.cmo _server/main.cmo
.br
\ \ \ \ js_of_eliom \-c client.ml
.br
\ \ \ \ js_of_eliom \-c base.eliom
.br
\ \ \ \ js_of_eliom \-c main.eliom
.br
\ \ \ \ js_of_eliom \-o appl.js _client/client.cmo _client/base.cmo _client/main.cmo
.SH SEE ALSO
.BR ocamlc (1),
.BR ocamlopt (1),
.BR js_of_ocaml (1),
.BR ocamlfind (1),
.BR ocamlcp (1),
.BR ocamldep (1).
.SH AUTHOR
eliomc, js_of_eliom, eliomdep and eliomopt were written by
Gregoire Henry .
eliomdoc was written by
Charly Chevalier .
.PP
This manual page was written by Pierre Chambart .
eliom-11.1.1/pkg/topkg.ml 0000664 0000000 0000000 00000031672 14723310174 0015152 0 ustar 00root root 0000000 0000000 (*---------------------------------------------------------------------------
Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
Distributed under the BSD3 license, see license at the end of the file.
%%NAME%% release %%VERSION%%
---------------------------------------------------------------------------*)
(* Public api *)
(** Build environment access *)
module type Env = sig
val bool : string -> bool
(** [bool key] declares [key] as being a boolean key in the environment.
Specifying key=(true|false) on the command line becomes mandatory. *)
val native : bool
(** [native] is [bool "native"]. *)
val native_dynlink : bool
(** [native_dylink] is [bool "native-dynlink"] *)
end
(** Exts defines sets of file extensions. *)
module type Exts = sig
val interface : string list
(** [interface] is [[".mli"; ".cmi"; ".cmti"]] *)
val interface_opt : string list
(** [interface_opt] is [".cmx" :: interface] *)
val library : string list
(** [library] is [[".cma"; ".cmxa"; ".cmxs"; ".a"]] *)
val module_library : string list
(** [module_library] is [(interface_opt @ library)]. *)
end
(** Package description. *)
module type Pkg = sig
type builder = [`OCamlbuild | `Other of string * string]
(** The type for build tools. Either [`OCamlbuild] or an
[`Other (tool, bdir)] tool [tool] that generates its build artefacts
in [bdir]. *)
type moves
(** The type for install moves. *)
type field =
?cond:bool
-> ?exts:string list
-> ?dst:string
-> ?target:string
-> string
-> moves
(** The type for field install functions. A call
[field cond exts dst path] generates install moves as follows:
{ul
{- If [cond] is [false] (defaults to [true]), no move is generated.}
{- If [exts] is present, generates a move for each path in
the list [List.map (fun e -> path ^ e) exts].}
{- If [dst] is present this path is used as the move destination
(allows to install in subdirectories). If absent [dst] is
[Filename.basename path].} *)
val lib : field
val bin : ?auto:bool -> field
(** If [auto] is true (defaults to false) generates
[path ^ ".native"] if {!Env.native} is [true] and
[path ^ ".byte"] if {!Env.native} is [false]. *)
val sbin : ?auto:bool -> field
(** See {!bin}. *)
val toplevel : field
val share : field
val share_root : field
val etc : field
val doc : field
val misc : field
val stublibs : field
val man : field
val describe : string -> builder:builder -> moves list -> unit
(** [describe name builder moves] describes a package named [name] with
builder [builder] and install moves [moves]. *)
end
(* Implementation *)
module Topkg : sig
val cmd : [`Build | `Explain | `Help]
val env : (string * bool) list
val err_parse : string -> 'a
val err_mdef : string -> 'a
val err_miss : string -> 'a
val err_file : string -> string -> 'a
val warn_unused : string -> unit
end = struct
(* Parses the command line. The actual cmd execution occurs in the call
to Pkg.describe. *)
let err fmt =
let k _ = exit 1 in
Format.kfprintf k Format.err_formatter ("%s: " ^^ fmt ^^ "@.") Sys.argv.(0)
let err_parse a = err "argument `%s' is not of the form key=(true|false)" a
let err_mdef a = err "bool `%s' is defined more than once" a
let err_miss a = err "argument `%s=(true|false)' is missing" a
let err_file f e = err "%s: %s" f e
let warn_unused k =
Format.eprintf "%s: warning: environment key `%s` unused.@." Sys.argv.(0) k
let cmd, env =
let rec parse_env acc = function
(* not t.r. *)
| arg :: args -> (
try
(* String.cut ... *)
let len = String.length arg in
let eq = String.index arg '=' in
let bool = bool_of_string (String.sub arg (eq + 1) (len - eq - 1)) in
let key = String.sub arg 0 eq in
if key = ""
then raise Exit
else
try
ignore (List.assoc key acc);
err_mdef key
with Not_found -> parse_env ((key, bool) :: acc) args
with Invalid_argument _ | Not_found | Exit -> err_parse arg)
| [] -> acc
in
match List.tl (Array.to_list Sys.argv) with
| "explain" :: args -> `Explain, parse_env [] args
| ("help" | "-h" | "--help" | "-help") :: args -> `Help, parse_env [] args
| args -> `Build, parse_env [] args
end
module Env : sig
include Env
val get : unit -> (string * bool) list
end = struct
let env = ref []
let get () = !env
let add_bool key b = env := (key, b) :: !env
let bool key =
let b =
try List.assoc key Topkg.env
with Not_found ->
if Topkg.cmd = `Build then Topkg.err_miss key else true
in
add_bool key b; b
let native = bool "native"
let native_dynlink = bool "native-dynlink"
end
module Exts : Exts = struct
let interface = [".mli"; ".cmi"; ".cmti"]
let interface_opt = ".cmx" :: interface
let library = [".cma"; ".cmxa"; ".cmxs"; ".a"]
let module_library = interface_opt @ library
end
module Pkg : Pkg = struct
type builder = [`OCamlbuild | `Other of string * string]
type move =
{field_name : string; target : string option; source : string; dest : string}
type moves = move list
type field =
?cond:bool
-> ?exts:string list
-> ?dst:string
-> ?target:string
-> string
-> moves
let str = Printf.sprintf
let warn_unused () =
let keys = List.map fst Topkg.env in
let keys_used = List.map fst (Env.get ()) in
let unused = List.find_all (fun k -> not (List.mem k keys_used)) keys in
List.iter Topkg.warn_unused unused
let has_suffix = Filename.check_suffix
let build_command ?(exec_sep = " ") btool mvs =
let no_build = [".cmti"; ".cmt"] in
let exec = Buffer.create 1871 in
let add_target = function
| {field_name = field; source = src; dest = dst; target} ->
let target = match target with None -> src | Some s -> s in
if not (List.exists (has_suffix target) no_build)
then Buffer.add_string exec (str "%s%s" exec_sep target)
in
Buffer.add_string exec btool;
List.iter add_target mvs;
Buffer.contents exec
let split_char sep p =
let len = String.length p in
let rec split beg cur =
if cur >= len
then if cur - beg > 0 then [String.sub p beg (cur - beg)] else []
else if p.[cur] = sep
then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
else split beg (cur + 1)
in
split 0 0
let holes src dst =
let aux x =
match split_char '%' x with [x; y] -> Some (x, y) | _ -> None
in
match aux src, aux dst with
| Some (s_path, s_suffix), Some (d_path, d_suffix) ->
Some (s_path, s_suffix, d_path, d_suffix)
| None, None -> None
| Some (s_path, s_suffix), None -> Some (s_path, s_suffix, dst, s_suffix)
| _ -> assert false
let list_files bdir src dst =
match holes src dst with
| None -> [str "%s/%s" bdir src, dst]
| Some (s_path, s_suffix, d_path, d_suffix) ->
let p = bdir ^ "/" ^ s_path in
let l = Array.to_list (Sys.readdir p) in
let l = List.filter (fun f -> has_suffix f s_suffix) l in
List.map
(fun s ->
( str "%s/%s%s" bdir s_path s
, str "%s%s%s" d_path (Filename.chop_suffix s s_suffix) d_suffix ))
l
let build_install bdir mvs =
let no_build = [".cmti"; ".cmt"] in
let install = Buffer.create 1871 in
let rec add_mvs current = function
| {field_name = field; source = src; dest = dst; target} :: mvs
when field = current ->
let target = match target with None -> src | Some s -> s in
let option =
if List.exists (has_suffix target) no_build then "?" else ""
in
List.iter
(fun (src, dst) ->
Buffer.add_string install
(str "\n \"%s%s\" {\"%s\"}" option src dst))
(list_files bdir src dst);
add_mvs current mvs
| {field_name = field} :: _ as mvs ->
if current <> "" (* first *) then Buffer.add_string install " ]\n";
Buffer.add_string install (str "%s: [" field);
add_mvs field mvs
| [] -> ()
in
add_mvs "" mvs;
Buffer.add_string install " ]\n";
Buffer.contents install
let pr = Format.printf
let pr_explanation btool bdir pkg mvs =
let env = Env.get () in
let exec = build_command ~exec_sep:" \\\n " btool mvs in
let install = build_install bdir mvs in
pr "@[";
pr "Package name: %s@," pkg;
pr "Build tool: %s@," btool;
pr "Build directory: %s@," bdir;
pr "Environment:@, ";
List.iter (fun (k, v) -> pr "%s=%b@, " k v) (List.sort compare env);
pr "@,Build invocation:@,";
pr " %s@,@," exec;
pr "Install file:@,";
pr "%s@," install;
pr "@]";
()
let pr_help () =
pr "Usage example:@\n %s" Sys.argv.(0);
List.iter (fun (k, v) -> pr " %s=%b" k v) (List.sort compare (Env.get ()));
pr "@."
let build btool bdir pkg mvs =
let exec = build_command btool mvs in
let e = Sys.command exec in
if e <> 0
then exit e
else
let install = build_install bdir mvs in
let install_file = pkg ^ ".install" in
try
let oc = open_out install_file in
output_string oc install; flush oc; close_out oc
with Sys_error e -> Topkg.err_file install_file e
let mvs ?(drop_exts = []) field ?(cond = true) ?(exts = []) ?dst ?target src =
if not cond
then []
else
let mv src dst = {field_name = field; source = src; dest = dst; target} in
let expand exts s d = List.map (fun e -> mv (s ^ e) (d ^ e)) exts in
let dst =
match dst with None -> Filename.basename src | Some dst -> dst
in
let files = if exts = [] then [mv src dst] else expand exts src dst in
let keep {source = src} = not (List.exists (has_suffix src) drop_exts) in
List.find_all keep files
let lib =
let drop_exts =
if Env.native && not Env.native_dynlink
then [".cmxs"]
else if not Env.native
then [".a"; ".cmx"; ".cmxa"; ".cmxs"]
else []
in
mvs ~drop_exts "lib"
let share = mvs "share"
let share_root = mvs "share_root"
let etc = mvs "etc"
let toplevel = mvs "toplevel"
let doc = mvs "doc"
let misc = mvs "misc"
let stublibs = mvs "stublibs"
let man = mvs "man"
let bin_drops = if not Env.native then [".native"] else []
let bin_mvs field ?(auto = false) ?cond ?exts ?dst ?target src =
let src, dst =
if not auto
then src, dst
else
let dst =
match dst with
| None -> Some (Filename.basename src)
| Some _ as dst -> dst
in
let src = if Env.native then src ^ ".native" else src ^ ".byte" in
src, dst
in
mvs ~drop_exts:bin_drops field ?cond ?dst ?exts ?target src
let bin = bin_mvs "bin"
let sbin = bin_mvs "sbin"
let describe pkg ~builder mvs =
let mvs = List.sort compare (List.flatten mvs) in
let btool, bdir =
match builder with
| `OCamlbuild -> "ocamlbuild -use-ocamlfind -classic-display", "_build"
| `Other (btool, bdir) -> btool, bdir
in
match Topkg.cmd with
| `Explain -> pr_explanation btool bdir pkg mvs
| `Help -> pr_help ()
| `Build -> warn_unused (); build btool bdir pkg mvs
end
(*---------------------------------------------------------------------------
Copyright (c) 2014 Daniel C. Bünzli.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
3. Neither the name of Daniel C. Bünzli nor the names of
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
---------------------------------------------------------------------------*)
eliom-11.1.1/src/ 0000775 0000000 0000000 00000000000 14723310174 0013471 5 ustar 00root root 0000000 0000000 eliom-11.1.1/src/_tags 0000664 0000000 0000000 00000004732 14723310174 0014517 0 ustar 00root root 0000000 0000000 <{lib,tools,ocamlbuild}/**/*>:warn(+A-4-6-7@8-9@11@12-16@20@23@24@26@27@32..36-37@38-39-40@41-42@43-44@45-48-63-67@68-69-70)
true:keep_locs
:linkall
:linkall
:eliomstubs
:eliom_ppx,thread
:package(js_of_ocaml-ppx_deriving_json,lwt_ppx)
:package(js_of_ocaml-ppx)
:eliom_ppx
:package(js_of_ocaml-ppx_deriving_json,lwt_ppx)
:package(js_of_ocaml-ppx)
:thread
:package(lwt,ocsigenserver,ocsipersist,tyxml.functor)
:package(react,lwt_react,js_of_ocaml)
:package(js_of_ocaml-ppx_deriving_json)
:package(xml-light)
:eliom_ppx
:eliom_ppx
:package(js_of_ocaml-ppx_deriving_json,lwt_ppx,js_of_ocaml-lwt.logger)
:package(js_of_ocaml-ppx)
: eliom_ppx
:package(ocsigenserver.cookies,ocsigenserver.polytables,ocsigenserver.baselib.base,cohttp)
:package(js_of_ocaml.deriving)
:package(lwt_react,tyxml.functor,js_of_ocaml-tyxml,js_of_ocaml-lwt,js_of_ocaml-lwt.logger)
:package(react,js_of_ocaml,reactiveData)
:package(js_of_ocaml-ppx_deriving_json)
:package(lwt_ppx)
:thread
:package(lwt,ocsigenserver,ocsipersist,tyxml)
:I(src/lib/server)
: package(ppxlib,ppxlib.metaquot,compiler-libs.bytecomp,ppx_optcomp)
: package(ocamlbuild,js_of_ocaml-ocamlbuild)
:package(ocamlbuild,js_of_ocaml-ocamlbuild)
:package(unix,findlib)
:package(unix,str,findlib)
: with_intro(doc/client.indexdoc),subproject(client)
: with_intro(doc/server.indexdoc),subproject(server)
: with_intro(doc/ppx.indexdoc),subproject(ppx)
: manpage,man_ext(3oc),apiref
: manpage,man_ext(3os),apiref
: manpage,man_ext(3o),apiref
: manpage,man_ext(3o),apiref
<**/api.wikidocdir/index.wiki>: apiref, wikidoc
:package(reactiveData)
eliom-11.1.1/src/lib/ 0000775 0000000 0000000 00000000000 14723310174 0014237 5 ustar 00root root 0000000 0000000 eliom-11.1.1/src/lib/client/ 0000775 0000000 0000000 00000000000 14723310174 0015515 5 ustar 00root root 0000000 0000000 eliom-11.1.1/src/lib/client/dune 0000664 0000000 0000000 00000001645 14723310174 0016401 0 ustar 00root root 0000000 0000000 (library
(name eliom_client)
(public_name eliom.client)
(synopsis "Eliom: client-side")
(wrapped false)
(modes byte)
(modules_without_implementation
eliom_content_sigs
eliom_form_sigs
eliom_parameter_sigs
eliom_registration_sigs
eliom_service_sigs
eliom_shared_sigs
eliom_wrap)
(preprocess
(pps lwt_ppx js_of_ocaml-ppx js_of_ocaml-ppx_deriving_json))
(library_flags
(:standard -linkall))
(libraries
ocsigenserver.cookies
ocsigenserver.polytables
js_of_ocaml
js_of_ocaml-tyxml
js_of_ocaml-lwt
js_of_ocaml-lwt.logger
lwt_react
ocsigenserver.baselib.base
cohttp
tyxml
reactiveData)
(foreign_stubs
(language c)
(names eliom_stubs))
(js_of_ocaml
(javascript_files eliom_client.js)))
(include dune.client)
(rule
(target dune.client)
(mode promote)
(deps
(glob_files ../*)
(universe))
(action
(with-stdout-to
%{target}
(run ../../tools/gen_dune.exe --client ..))))
eliom-11.1.1/src/lib/client/dune.client 0000664 0000000 0000000 00000013764 14723310174 0017663 0 ustar 00root root 0000000 0000000 (rule (copy# ../eliom_bus.client.ml eliom_bus.ml))
(rule (copy# ../eliom_bus.client.mli eliom_bus.mli))
(rule (copy# ../eliom_client.client.ml eliom_client.ml))
(rule (copy# ../eliom_client.client.mli eliom_client.mli))
(rule (copy# ../eliom_client_base.shared.ml eliom_client_base.ml))
(rule (copy# ../eliom_client_core.client.ml eliom_client_core.ml))
(rule (target eliom_client_main.ml) (deps ../eliom_client_main.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_client_main} --impl %{deps})))))
(rule (copy# ../eliom_client_value.client.ml eliom_client_value.ml))
(rule (copy# ../eliom_client_value.client.mli eliom_client_value.mli))
(rule (copy# ../eliom_comet.client.ml eliom_comet.ml))
(rule (copy# ../eliom_comet.client.mli eliom_comet.mli))
(rule (copy# ../eliom_comet_base.shared.ml eliom_comet_base.ml))
(rule (copy# ../eliom_comet_base.shared.mli eliom_comet_base.mli))
(rule (copy# ../eliom_common.client.ml eliom_common.ml))
(rule (copy# ../eliom_common_base.shared.ml eliom_common_base.ml))
(rule (copy# ../eliom_config.client.ml eliom_config.ml))
(rule (copy# ../eliom_config.client.mli eliom_config.mli))
(rule (copy# ../eliom_content.client.mli eliom_content.mli))
(rule (target eliom_content.ml) (deps ../eliom_content.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_content} --impl %{deps})))))
(rule (copy# ../eliom_content_.client.ml eliom_content_.ml))
(rule (copy# ../eliom_content_core.client.ml eliom_content_core.ml))
(rule (copy# ../eliom_content_core.client.mli eliom_content_core.mli))
(rule (copy# ../eliom_content_sigs.shared.mli eliom_content_sigs.mli))
(rule (copy# ../eliom_cookies_base.shared.ml eliom_cookies_base.ml))
(rule (target eliom_cscache.ml) (deps ../eliom_cscache.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_cscache} --impl %{deps})))))
(rule (target eliom_cscache.mli) (deps ../eliom_cscache.eliomi)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp --intf %{deps})))))
(rule (target eliom_form.ml) (deps ../eliom_form.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_form} --impl %{deps})))))
(rule (target eliom_form.mli) (deps ../eliom_form.eliomi)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp --intf %{deps})))))
(rule (copy# ../eliom_form_sigs.shared.mli eliom_form_sigs.mli))
(rule (copy# ../eliom_lazy.client.ml eliom_lazy.ml))
(rule (copy# ../eliom_lazy.client.mli eliom_lazy.mli))
(rule (copy# ../eliom_lib.client.ml eliom_lib.ml))
(rule (copy# ../eliom_lib.client.mli eliom_lib.mli))
(rule (copy# ../eliom_lib_base.shared.ml eliom_lib_base.ml))
(rule (copy# ../eliom_lib_base.shared.mli eliom_lib_base.mli))
(rule (copy# ../eliom_parameter.client.ml eliom_parameter.ml))
(rule (copy# ../eliom_parameter.client.mli eliom_parameter.mli))
(rule (copy# ../eliom_parameter_base.shared.ml eliom_parameter_base.ml))
(rule (copy# ../eliom_parameter_sigs.shared.mli eliom_parameter_sigs.mli))
(rule (copy# ../eliom_process.client.ml eliom_process.ml))
(rule (copy# ../eliom_react.client.ml eliom_react.ml))
(rule (copy# ../eliom_react.client.mli eliom_react.mli))
(rule (copy# ../eliom_registration.client.ml eliom_registration.ml))
(rule (copy# ../eliom_registration.client.mli eliom_registration.mli))
(rule (copy# ../eliom_registration_sigs.shared.mli eliom_registration_sigs.mli))
(rule (copy# ../eliom_request.client.ml eliom_request.ml))
(rule (copy# ../eliom_request.client.mli eliom_request.mli))
(rule (copy# ../eliom_request_info.client.ml eliom_request_info.ml))
(rule (copy# ../eliom_request_info.client.mli eliom_request_info.mli))
(rule (copy# ../eliom_route.client.ml eliom_route.ml))
(rule (copy# ../eliom_route_base.shared.ml eliom_route_base.ml))
(rule (copy# ../eliom_runtime.shared.ml eliom_runtime.ml))
(rule (copy# ../eliom_runtime.shared.mli eliom_runtime.mli))
(rule (copy# ../eliom_service.client.ml eliom_service.ml))
(rule (copy# ../eliom_service.client.mli eliom_service.mli))
(rule (target eliom_service_base.ml) (deps ../eliom_service_base.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_service_base} --impl %{deps})))))
(rule (copy# ../eliom_service_sigs.shared.mli eliom_service_sigs.mli))
(rule (copy# ../eliom_shared.client.mli eliom_shared.mli))
(rule (target eliom_shared.ml) (deps ../eliom_shared.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_shared} --impl %{deps})))))
(rule (target eliom_shared_content.ml) (deps ../eliom_shared_content.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_shared_content} --impl %{deps})))))
(rule (target eliom_shared_content.mli) (deps ../eliom_shared_content.eliomi)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp --intf %{deps})))))
(rule (copy# ../eliom_shared_sigs.shared.mli eliom_shared_sigs.mli))
(rule (target eliom_tools.ml) (deps ../eliom_tools.eliom)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp -server-cmo %{cmo:../server/eliom_tools} --impl %{deps})))))
(rule (target eliom_tools.mli) (deps ../eliom_tools.eliomi)
(action
(with-stdout-to %{target}
(chdir .. (run ppx_eliom_client --as-pp --intf %{deps})))))
(rule (copy# ../eliom_types.client.ml eliom_types.ml))
(rule (copy# ../eliom_types_base.shared.ml eliom_types_base.ml))
(rule (copy# ../eliom_types_base.shared.mli eliom_types_base.mli))
(rule (copy# ../eliom_unwrap.client.ml eliom_unwrap.ml))
(rule (copy# ../eliom_unwrap.client.mli eliom_unwrap.mli))
(rule (copy# ../eliom_uri.shared.ml eliom_uri.ml))
(rule (copy# ../eliom_uri.shared.mli eliom_uri.mli))
(rule (copy# ../eliom_wrap.client.mli eliom_wrap.mli))
eliom-11.1.1/src/lib/client/eliom_client.js 0000664 0000000 0000000 00000022010 14723310174 0020511 0 ustar 00root root 0000000 0000000 // Unmarshall and unwrapping.
//Provides: caml_unwrap_value_from_string
//Requires: caml_failwith, caml_marshal_constants
//Requires: caml_int64_float_of_bits, caml_int64_of_bytes, caml_string_of_jsbytes
//Requires: caml_jsbytes_of_string, caml_callback
var caml_unwrap_value_from_string = function (){
function StringReader (s, i) { this.s = caml_jsbytes_of_string(s); this.i = i; }
StringReader.prototype = {
read8u:function () { return this.s.charCodeAt(this.i++); },
read8s:function () { return this.s.charCodeAt(this.i++) << 24 >> 24; },
read16u:function () {
var s = this.s, i = this.i;
this.i = i + 2;
return (s.charCodeAt(i) << 8) | s.charCodeAt(i + 1)
},
read16s:function () {
var s = this.s, i = this.i;
this.i = i + 2;
return (s.charCodeAt(i) << 24 >> 16) | s.charCodeAt(i + 1);
},
read32u:function () {
var s = this.s, i = this.i;
this.i = i + 4;
return ((s.charCodeAt(i) << 24) | (s.charCodeAt(i+1) << 16) |
(s.charCodeAt(i+2) << 8) | s.charCodeAt(i+3)) >>> 0;
},
read32s:function () {
var s = this.s, i = this.i;
this.i = i + 4;
return (s.charCodeAt(i) << 24) | (s.charCodeAt(i+1) << 16) |
(s.charCodeAt(i+2) << 8) | s.charCodeAt(i+3);
},
readstr:function (len) {
var i = this.i;
this.i = i + len;
return caml_string_of_jsbytes(this.s.substring(i, i + len));
}
}
function caml_float_of_bytes (a) {
return caml_int64_float_of_bits (caml_int64_of_bytes (a));
}
var late_unwrap_mark = {};
return function (apply_unwrapper, s, ofs) {
var reader = new StringReader (s, ofs);
var magic = reader.read32u ();
if (magic != 0x8495A6BE)
caml_failwith("unwrap_value: bad object "
+ window.btoa(reader.s.slice(0,1024)));
var block_len = reader.read32u ();
var num_objects = reader.read32u ();
var size_32 = reader.read32u ();
var size_64 = reader.read32u ();
var stack = [];
var intern_obj_table = new Array(num_objects+1);
var obj_counter = 1;
intern_obj_table[0] = [];
function register_sharing (anc, d, v) {
// If the value v is marked for late unwrapping, register an
// occurrence of it in anc.
if (v[0] === 0 && v.length >= 2 &&
v[v.length-1] instanceof Array &&
v[v.length-1].length == 4 &&
v[v.length-1][2] === late_unwrap_mark) {
v[v.length-1][3] = [0, [0, anc, d], v[v.length-1][3]];
}
return v;
}
function intern_rec (v0, d) {
var cst = caml_marshal_constants;
var code = reader.read8u ();
if (code >= cst.PREFIX_SMALL_INT) {
if (code >= cst.PREFIX_SMALL_BLOCK) {
var tag = code & 0xF;
var size = (code >> 4) & 0x7;
var v = [tag];
if (size == 0) return v;
intern_obj_table[obj_counter] = v;
stack.push(obj_counter++, size);
return v;
} else
return (code & 0x3F);
} else {
if (code >= cst.PREFIX_SMALL_STRING) {
var len = code & 0x1F;
var v = reader.readstr (len);
intern_obj_table[obj_counter++] = v;
return v;
} else {
switch(code) {
case cst.CODE_INT8:
return reader.read8s ();
case cst.CODE_INT16:
return reader.read16s ();
case cst.CODE_INT32:
return reader.read32s ();
case cst.CODE_INT64:
caml_failwith("unwrap_value: integer too large");
break;
case cst.CODE_SHARED8:
var ofs = reader.read8u ();
return register_sharing(v0, d, intern_obj_table[obj_counter - ofs]);
case cst.CODE_SHARED16:
var ofs = reader.read16u ();
return register_sharing(v0, d, intern_obj_table[obj_counter - ofs]);
case cst.CODE_SHARED32:
var ofs = reader.read32u ();
return register_sharing(v0, d, intern_obj_table[obj_counter - ofs]);
case cst.CODE_BLOCK32:
var header = reader.read32u ();
var tag = header & 0xFF;
var size = header >> 10;
var v = [tag];
if (size == 0) return v;
intern_obj_table[obj_counter] = v;
stack.push(obj_counter++, size);
return v;
case cst.CODE_BLOCK64:
caml_failwith ("unwrap_value: data block too large");
break;
case cst.CODE_STRING8:
var len = reader.read8u();
var v = reader.readstr (len);
intern_obj_table[obj_counter++] = v;
return v;
case cst.CODE_STRING32:
var len = reader.read32u();
var v = reader.readstr (len);
intern_obj_table[obj_counter++] = v;
return v;
case cst.CODE_DOUBLE_LITTLE:
var t = [];
for (var i = 0;i < 8;i++) t[7 - i] = reader.read8u ();
var v = caml_float_of_bytes (t);
intern_obj_table[obj_counter++] = v;
return v;
case cst.CODE_DOUBLE_BIG:
var t = [];
for (var i = 0;i < 8;i++) t[i] = reader.read8u ();
var v = caml_float_of_bytes (t);
intern_obj_table[obj_counter++] = v;
return v;
case cst.CODE_DOUBLE_ARRAY8_LITTLE:
var len = reader.read8u();
var v = [0];
intern_obj_table[obj_counter++] = v;
for (var i = 1;i <= len;i++) {
var t = [];
for (var j = 0;j < 8;j++) t[7 - j] = reader.read8u();
v[i] = caml_float_of_bytes (t);
}
return v;
case cst.CODE_DOUBLE_ARRAY8_BIG:
var len = reader.read8u();
var v = [0];
intern_obj_table[obj_counter++] = v;
for (var i = 1;i <= len;i++) {
var t = [];
for (var j = 0;j < 8;j++) t[j] = reader.read8u();
v [i] = caml_float_of_bytes (t);
}
return v;
case cst.CODE_DOUBLE_ARRAY32_LITTLE:
var len = reader.read32u();
var v = [0];
intern_obj_table[obj_counter++] = v;
for (var i = 1;i <= len;i++) {
var t = [];
for (var j = 0;j < 8;j++) t[7 - j] = reader.read8u();
v[i] = caml_float_of_bytes (t);
}
return v;
case cst.CODE_DOUBLE_ARRAY32_BIG:
var len = reader.read32u();
var v = [0];
for (var i = 1;i <= len;i++) {
var t = [];
for (var j = 0;j < 8;j++) t[j] = reader.read8u();
v [i] = caml_float_of_bytes (t);
}
return v;
case cst.CODE_CODEPOINTER:
case cst.CODE_INFIXPOINTER:
caml_failwith ("unwrap_value: code pointer");
break;
case cst.CODE_CUSTOM:
case 0x18: //cst.CODE_CUSTOM_LEN:
case 0x19: //cst.CODE_CUSTOM_FIXED:
var c, s = "";
while ((c = reader.read8u ()) != 0) s += String.fromCharCode (c);
switch(s) {
case "_j":
// Int64
var t = [];
for (var j = 0;j < 8;j++) t[j] = reader.read8u();
var v = caml_int64_of_bytes (t);
if (intern_obj_table) intern_obj_table[obj_counter++] = v;
return v;
case "_i":
// Int32
var v = reader.read32s ();
if (intern_obj_table) intern_obj_table[obj_counter++] = v;
return v;
default:
caml_failwith("input_value: unknown custom block identifier");
}
default:
caml_failwith ("unwrap_value: ill-formed message");
}
}
}
}
stack.push(0,0);
while (stack.length > 0) {
var size = stack.pop();
var ofs = stack.pop();
var v = intern_obj_table[ofs];
var d = v.length;
if (size + 1 == d) {
var ancestor = intern_obj_table[stack[stack.length-2]];
// See Eliom_wrap.ml.
if (v[0] === 0 && size >= 2 &&
v[size] instanceof Array && v[size].length == 3 &&
v[size][2] === intern_obj_table[2] /*unwrap_mark*/) {
var unwrapped_v = caml_callback(apply_unwrapper, [v[size], v]);
if (unwrapped_v === 0) {
// No unwrapper is registered, so replace the unwrap
// marker v[size] by a late_unwrap marker
// (unwrapper_id, "late_unwrap_mark")
// and register an occurrence in ancestor
v[size] =
[0, v[size][1], late_unwrap_mark,
[0, [0, ancestor, ancestor.length - 1], 0]];
} else {
v = unwrapped_v[1];
}
intern_obj_table[ofs] = v;
ancestor[ancestor.length-1] = v;
}
} else {
stack.push(ofs, size);
v[d] = intern_rec (v, d);
}
}
if(intern_obj_table[0][0].length != 3)
caml_failwith ("unwrap_value: incorrect value");
return intern_obj_table[0][0][2];
}
}();
eliom-11.1.1/src/lib/client/eliom_client.wat 0000664 0000000 0000000 00000074000 14723310174 0020676 0 ustar 00root root 0000000 0000000 (module
(import "env" "caml_failwith" (func $caml_failwith (param (ref eq))))
(import "env" "caml_init_custom_operations"
(func $caml_init_custom_operations))
(import "env" "caml_find_custom_operations"
(func $caml_find_custom_operations
(param (ref $string)) (result (ref null $custom_operations))))
(import "env" "caml_callback_2"
(func $caml_callback_2
(param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq))))
(type $block (array (mut (ref eq))))
(type $string (array (mut i8)))
(type $float (struct (field f64)))
(type $float_array (array (mut f64)))
(type $js (struct (field anyref)))
(type $compare
(func (param (ref eq)) (param (ref eq)) (param i32) (result i32)))
(type $hash
(func (param (ref eq)) (result i32)))
(type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32)))
(type $serialize
(func (param (ref eq)) (param (ref eq)) (result i32) (result i32)))
(type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32)))
(type $dup (func (param (ref eq)) (result (ref eq))))
(type $custom_operations
(struct
(field $id (ref $string))
(field $compare (ref null $compare))
(field $compare_ext (ref null $compare))
(field $hash (ref null $hash))
(field $fixed_length (ref null $fixed_length))
(field $serialize (ref null $serialize))
(field $deserialize (ref null $deserialize))
(field $dup (ref null $dup))))
(type $custom (sub (struct (field (ref $custom_operations)))))
(data $bad_length "unwrap_value: bad length")
(func (export "caml_unwrap_value_from_string")
(param $unwrapper (ref eq))
(param $vstr (ref eq)) (param $vofs (ref eq)) (result (ref eq))
(local $str (ref $string))
(local $ofs i32)
(local $s (ref $intern_state))
(local $h (ref $marshal_header))
(local.set $str (ref.cast (ref $string) (local.get $vstr)))
(local.set $ofs (i31.get_u (ref.cast (ref i31) (local.get $vofs))))
(local.set $s
(call $get_intern_state (local.get $str) (local.get $ofs)))
(local.set $h (call $parse_header (local.get $s)))
(if (i32.gt_s
(i32.add (local.get $ofs)
(i32.add (struct.get $marshal_header $data_len (local.get $h))
(i32.const 20)))
(array.len (local.get $str)))
(then
(call $caml_failwith
(array.new_data $string $bad_length
(i32.const 0) (i32.const 24)))))
(return_call $intern_rec
(local.get $unwrapper) (local.get $s) (local.get $h)))
(global $Intext_magic_number_small i32 (i32.const 0x8495A6BE))
(global $Intext_magic_number_big i32 (i32.const 0x8495A6BF))
(global $PREFIX_SMALL_BLOCK i32 (i32.const 0x80))
(global $PREFIX_SMALL_INT i32 (i32.const 0x40))
(global $PREFIX_SMALL_STRING i32 (i32.const 0x20))
(global $CODE_INT8 i32 (i32.const 0x00))
(global $CODE_INT16 i32 (i32.const 0x01))
(global $CODE_INT32 i32 (i32.const 0x02))
(global $CODE_INT64 i32 (i32.const 0x03))
(global $CODE_SHARED8 i32 (i32.const 0x04))
(global $CODE_SHARED16 i32 (i32.const 0x05))
(global $CODE_SHARED32 i32 (i32.const 0x06))
(global $CODE_BLOCK32 i32 (i32.const 0x08))
(global $CODE_BLOCK64 i32 (i32.const 0x13))
(global $CODE_STRING8 i32 (i32.const 0x09))
(global $CODE_STRING32 i32 (i32.const 0x0A))
(global $CODE_DOUBLE_BIG i32 (i32.const 0x0B))
(global $CODE_DOUBLE_LITTLE i32 (i32.const 0x0C))
(global $CODE_DOUBLE_ARRAY8_BIG i32 (i32.const 0x0D))
(global $CODE_DOUBLE_ARRAY8_LITTLE i32 (i32.const 0x0E))
(global $CODE_DOUBLE_ARRAY32_BIG i32 (i32.const 0x0F))
(global $CODE_DOUBLE_ARRAY32_LITTLE i32 (i32.const 0x07))
(global $CODE_CODEPOINTER i32 (i32.const 0x10))
(global $CODE_INFIXPOINTER i32 (i32.const 0x11))
(global $CODE_CUSTOM i32 (i32.const 0x12))
(global $CODE_CUSTOM_LEN i32 (i32.const 0x18))
(global $CODE_CUSTOM_FIXED i32 (i32.const 0x19))
;; Keep in sync with marshal.wat
(type $intern_state
(struct
(field $src (ref $string))
(field $pos (mut i32))
(field $obj_table (mut (ref null $block)))
(field $obj_counter (mut i32))))
(func $get_intern_state
(param $src (ref $string)) (param $pos i32) (result (ref $intern_state))
(struct.new $intern_state
(local.get $src) (local.get $pos) (ref.null $block)
(i32.const 0)))
(func $read8u (param $s (ref $intern_state)) (result i32)
(local $pos i32) (local $res i32)
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(local.set $res
(array.get_u $string
(struct.get $intern_state $src (local.get $s))
(local.get $pos)))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 1)))
(local.get $res))
(func $read8s (param $s (ref $intern_state)) (result i32)
(local $pos i32) (local $res i32)
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(local.set $res
(array.get_s $string
(struct.get $intern_state $src (local.get $s))
(local.get $pos)))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 1)))
(local.get $res))
(func $read16u (param $s (ref $intern_state)) (result i32)
(local $src (ref $string)) (local $pos i32) (local $res i32)
(local.set $src (struct.get $intern_state $src (local.get $s)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(local.set $res
(i32.or
(i32.shl
(array.get_u $string (local.get $src) (local.get $pos))
(i32.const 8))
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (i32.const 1)))))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 2)))
(local.get $res))
(func $read16s (param $s (ref $intern_state)) (result i32)
(local $src (ref $string)) (local $pos i32) (local $res i32)
(local.set $src (struct.get $intern_state $src (local.get $s)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(local.set $res
(i32.or
(i32.shl
(array.get_s $string (local.get $src) (local.get $pos))
(i32.const 8))
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (i32.const 1)))))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 2)))
(local.get $res))
(func $read32 (param $s (ref $intern_state)) (result i32)
(local $src (ref $string)) (local $pos i32) (local $res i32)
(local.set $src (struct.get $intern_state $src (local.get $s)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(local.set $res
(i32.or
(i32.or
(i32.shl
(array.get_u $string (local.get $src) (local.get $pos))
(i32.const 24))
(i32.shl
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (i32.const 1)))
(i32.const 16)))
(i32.or
(i32.shl
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (i32.const 2)))
(i32.const 8))
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (i32.const 3))))))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 4)))
(local.get $res))
(func $readblock (param $s (ref $intern_state)) (param $str (ref $string))
(local $len i32) (local $pos i32)
(local.set $len (array.len (local.get $str)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(array.copy $string $string
(local.get $str) (i32.const 0)
(struct.get $intern_state $src (local.get $s)) (local.get $pos)
(local.get $len))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (local.get $len))))
(func $readstr (param $s (ref $intern_state)) (result (ref $string))
(local $len i32) (local $pos i32) (local $res (ref $string))
(local $src (ref $string))
(local.set $src (struct.get $intern_state $src (local.get $s)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(loop $loop
(if (array.get_u $string (local.get $src)
(i32.add (local.get $pos) (local.get $len)))
(then
(local.set $len (i32.add (local.get $len) (i32.const 1)))
(br $loop))))
(local.set $res (array.new $string (i32.const 0) (local.get $len)))
(array.copy $string $string
(local.get $res) (i32.const 0)
(local.get $src) (local.get $pos)
(local.get $len))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.add (local.get $len) (i32.const 1))))
(local.get $res))
(func $readfloat
(param $s (ref $intern_state)) (param $code i32) (result f64)
(local $src (ref $string)) (local $pos i32) (local $res i32)
(local $d i64)
(local $i i32)
(local $v (ref eq))
(local.set $src (struct.get $intern_state $src (local.get $s)))
(local.set $pos (struct.get $intern_state $pos (local.get $s)))
(struct.set $intern_state $pos (local.get $s)
(i32.add (local.get $pos) (i32.const 8)))
(if (i32.eq (local.get $code) (global.get $CODE_DOUBLE_BIG))
(then
(loop $loop
(local.set $d
(i64.or
(i64.shl (local.get $d) (i64.const 8))
(i64.extend_i32_u
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (local.get $i))))))
(local.set $i (i32.add (local.get $i) (i32.const 1)))
(br_if $loop (i32.lt_u (local.get $i) (i32.const 8)))))
(else
(loop $loop
(local.set $d
(i64.rotr
(i64.or (local.get $d)
(i64.extend_i32_u
(array.get_u $string (local.get $src)
(i32.add (local.get $pos) (local.get $i)))))
(i64.const 8)))
(local.set $i (i32.add (local.get $i) (i32.const 1)))
(br_if $loop (i32.lt_u (local.get $i) (i32.const 8))))))
(f64.reinterpret_i64 (local.get $d)))
(func $readfloats
(param $s (ref $intern_state)) (param $code i32) (param $len i32)
(result (ref eq))
(local $dest (ref $float_array))
(local $i i32)
(local.set $code
(select (global.get $CODE_DOUBLE_BIG) (global.get $CODE_DOUBLE_LITTLE)
(i32.or
(i32.eq (local.get $code) (global.get $CODE_DOUBLE_ARRAY8_BIG))
(i32.eq (local.get $code)
(global.get $CODE_DOUBLE_ARRAY32_BIG)))))
(local.set $dest (array.new $float_array (f64.const 0) (local.get $len)))
(loop $loop
(if (i32.lt_u (local.get $i) (local.get $len))
(then
(array.set $float_array (local.get $dest) (local.get $i)
(call $readfloat (local.get $s) (local.get $code)))
(local.set $i (i32.add (local.get $i) (i32.const 1)))
(br $loop))))
(local.get $dest))
(func $register_object (param $s (ref $intern_state)) (param $v (ref eq))
(local $p i32)
(local.set $p (struct.get $intern_state $obj_counter (local.get $s)))
(array.set $block
(struct.get $intern_state $obj_table (local.get $s))
(local.get $p) (local.get $v))
(struct.set $intern_state $obj_counter (local.get $s)
(i32.add (local.get $p) (i32.const 1))))
(data $unknown_custom "unwrap_value: unknown custom block identifier")
(data $expected_size "unwrap_value: expected a fixed-size custom block")
(data $incorrect_size
"unwrap_value: incorrect length of serialized custom block")
(func $intern_custom
(param $s (ref $intern_state)) (param $code i32) (result (ref eq))
(local $ops (ref $custom_operations))
(local $expected_size i32)
(local $r (tuple (ref eq) i32))
(block $unknown
(local.set $ops
(br_on_null $unknown
(call
$caml_find_custom_operations
(call $readstr
(local.get $s)))))
(block $no_length
(if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_FIXED))
(then
(local.set $expected_size
(struct.get $fixed_length $bsize_32
(br_on_null $no_length
(struct.get $custom_operations $fixed_length
(local.get $ops))))))
(else
(if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_LEN))
(then
(local.set $expected_size (call $read32 (local.get $s)))
(struct.set $intern_state $pos (local.get $s)
(i32.add (struct.get $intern_state $pos (local.get $s))
(i32.const 8)))))))
(local.set $r
(call_ref $deserialize (local.get $s)
(struct.get $custom_operations $deserialize (local.get $ops))))
(if (i32.and
(i32.ne (tuple.extract 2 1 (local.get $r))
(local.get $expected_size))
(i32.ne (local.get $code) (global.get $CODE_CUSTOM)))
(then
(call $caml_failwith
(array.new_data $string $incorrect_size
(i32.const 0) (i32.const 57)))))
(return (tuple.extract 2 0 (local.get $r))))
(call $caml_failwith
(array.new_data $string $expected_size
(i32.const 0) (i32.const 48))))
(call $caml_failwith
(array.new_data $string $unknown_custom
(i32.const 0) (i32.const 45)))
(ref.i31 (i32.const 0)))
(data $integer_too_large "unwrap_value: integer too large")
(data $code_pointer "unwrap_value: code pointer")
(data $ill_formed "unwrap_value: ill-formed message")
(data $incorrect_value "unwrap_value: incorrect value")
(type $stack_item
(struct
(field $blk (ref $block))
(field $pos (mut i32))
(field $ofs i32)
(field $next (ref null $stack_item))))
(func $intern_rec
(param $unwrapper (ref eq))
(param $s (ref $intern_state)) (param $h (ref $marshal_header))
(result (ref eq))
(local $late_unwrap_mark (ref $block))
(local $res (ref $block)) (local $dest (ref $block))
(local $sp (ref $stack_item))
(local $code i32)
(local $header i32) (local $tag i32) (local $size i32)
(local $len i32) (local $pos i32) (local $pos' i32) (local $ofs i32)
(local $b (ref $block))
(local $str (ref $string))
(local $v (ref eq)) (local $v' (ref eq))
(call $caml_init_custom_operations)
(local.set $late_unwrap_mark (array.new_fixed $block 0))
(local.set $res (array.new_fixed $block 1 (ref.i31 (i32.const 0))))
(local.set $sp
(struct.new $stack_item
(local.get $res) (i32.const 0) (i32.const -1)
(ref.null $stack_item)))
(local.set $size (struct.get $marshal_header $num_objects (local.get $h)))
(struct.set $intern_state $obj_table (local.get $s)
(array.new $block (ref.i31 (i32.const 0)) (local.get $size)))
(local.set $v (ref.i31 (i32.const 0))) ;; keep validator happy
(block $exit
(loop $loop
(block $done
(block $read_block
(block $read_string
(block $read_double_array
(block $read_shared
(local.set $code (call $read8u (local.get $s)))
(if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_INT))
(then
(if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_BLOCK))
(then
;; Small block
(local.set $tag
(i32.and (local.get $code) (i32.const 0xF)))
(local.set $size
(i32.and (i32.shr_u (local.get $code) (i32.const 4))
(i32.const 0x7)))
(br $read_block))
(else
;; Small int
(local.set $v
(ref.i31
(i32.and (local.get $code) (i32.const 0x3F))))
(br $done))))
(else
(if (i32.ge_u (local.get $code)
(global.get $PREFIX_SMALL_STRING))
(then
(local.set $len
(i32.and (local.get $code) (i32.const 0x1F)))
(br $read_string))
(else
(block $INT8
(block $INT16
(block $INT32
(block $INT64
(block $SHARED8
(block $SHARED16
(block $SHARED32
(block $BLOCK32
(block $STRING8
(block $STRING32
(block $DOUBLE
(block $DOUBLE_ARRAY8
(block $DOUBLE_ARRAY32
(block $CODEPOINTER
(block $CUSTOM
(block $default
(br_table $INT8 $INT16 $INT32 $INT64
$SHARED8 $SHARED16 $SHARED32
$DOUBLE_ARRAY32 $BLOCK32 $STRING8
$STRING32 $DOUBLE $DOUBLE
$DOUBLE_ARRAY8 $DOUBLE_ARRAY8
$DOUBLE_ARRAY32 $CODEPOINTER
$CODEPOINTER $CUSTOM $default
$default $default $default $default
$CUSTOM $CUSTOM $default
(local.get $code)))
;; default
(call $caml_failwith
(array.new_data $string $ill_formed
(i32.const 0) (i32.const 32)))
(br $done))
;; CUSTOM
(local.set $v
(call $intern_custom (local.get $s)
(local.get $code)))
(call $register_object (local.get $s)
(local.get $v))
(br $done))
;; CODEPOINTER
(call $caml_failwith
(array.new_data $string $code_pointer
(i32.const 0) (i32.const 26)))
(br $done))
;; DOUBLE_ARRAY32
(local.set $len
(call $read32 (local.get $s)))
(br $read_double_array))
;; DOUBLE_ARRAY8
(local.set $len
(call $read8u (local.get $s)))
(br $read_double_array))
;; DOUBLE
(local.set $v
(struct.new $float
(call $readfloat
(local.get $s) (local.get $code))))
(call $register_object
(local.get $s) (local.get $v))
(br $done))
;; STRING32
(local.set $len (call $read32 (local.get $s)))
(br $read_string))
;; STRING8
(local.set $len (call $read8u (local.get $s)))
(br $read_string))
;; BLOCK32
(local.set $header (call $read32 (local.get $s)))
(local.set $tag
(i32.and (local.get $header)
(i32.const 0xFF)))
(local.set $size
(i32.shr_u (local.get $header)
(i32.const 10)))
(br $read_block))
;; SHARED32
(local.set $ofs (call $read32 (local.get $s)))
(br $read_shared))
;; SHARED16
(local.set $ofs (call $read16u (local.get $s)))
(br $read_shared))
;; SHARED8
(local.set $ofs (call $read8u (local.get $s)))
(br $read_shared))
;; INT64
(call $caml_failwith
(array.new_data $string $integer_too_large
(i32.const 0) (i32.const 31)))
(br $done))
;; INT32
(local.set $v (ref.i31 (call $read32 (local.get $s))))
(br $done))
;; INT16
(local.set $v (ref.i31 (call $read16s (local.get $s))))
(br $done))
;; INT8
(local.set $v (ref.i31 (call $read8s (local.get $s))))
(br $done))
))))
;; read_shared
(local.set $ofs
(i32.sub
(struct.get $intern_state $obj_counter (local.get $s))
(local.get $ofs)))
(local.set $v
(array.get $block
(struct.get $intern_state $obj_table (local.get $s))
(local.get $ofs)))
(br_if $done (i32.eqz (ref.test (ref $block) (local.get $v))))
(local.set $b (ref.cast (ref $block) (local.get $v)))
(local.set $len (array.len (local.get $b)))
(br_if $done (i32.lt_u (local.get $len) (i32.const 2)))
(local.set $v'
(array.get $block (local.get $b)
(i32.sub (local.get $len) (i32.const 1))))
(br_if $done (i32.eqz (ref.test (ref $block) (local.get $v'))))
(local.set $b (ref.cast (ref $block) (local.get $v')))
(br_if $done (i32.ne (array.len (local.get $b)) (i32.const 4)))
(br_if $done
(i32.eqz
(ref.eq (array.get $block (local.get $b) (i32.const 2))
(local.get $late_unwrap_mark))))
(array.set $block (local.get $b) (i32.const 3)
(array.new_fixed $block 3 (ref.i31 (i32.const 0))
(array.new_fixed $block 3 (ref.i31 (i32.const 0))
(struct.get $stack_item $blk (local.get $sp))
(ref.i31
(struct.get $stack_item $pos (local.get $sp))))
(array.get $block (local.get $b) (i32.const 3))))
(br $done))
;; read_double_array
(local.set $v
(call $readfloats
(local.get $s) (local.get $code) (local.get $len)))
(call $register_object (local.get $s) (local.get $v))
(br $done))
;; read_string
(local.set $str (array.new $string (i32.const 0) (local.get $len)))
(call $readblock (local.get $s) (local.get $str))
(local.set $v (local.get $str))
(call $register_object (local.get $s) (local.get $v))
(br $done))
;; read_block
(local.set $b
(array.new $block (ref.i31 (i32.const 0))
(i32.add (local.get $size) (i32.const 1))))
(array.set $block (local.get $b) (i32.const 0)
(ref.i31 (local.get $tag)))
(if (local.get $size)
(then
(local.set $sp
(struct.new $stack_item
(local.get $b) (i32.const 1)
(struct.get $intern_state $obj_counter (local.get $s))
(local.get $sp)))
(call $register_object (local.get $s) (local.get $b))
(br $loop)))
(local.set $v (local.get $b))
(br $done))
;; done
(loop $assign
(local.set $dest (struct.get $stack_item $blk (local.get $sp)))
(local.set $pos (struct.get $stack_item $pos (local.get $sp)))
(array.set $block (local.get $dest) (local.get $pos) (local.get $v))
(local.set $pos' (i32.add (local.get $pos) (i32.const 1)))
(struct.set $stack_item $pos (local.get $sp) (local.get $pos'))
(local.set $len (array.len (local.get $dest)))
(br_if $loop (i32.ne (local.get $pos') (local.get $len)))
(local.set $v (local.get $dest))
(local.set $ofs (struct.get $stack_item $ofs (local.get $sp)))
(local.set $sp
(br_on_null $exit (struct.get $stack_item $next (local.get $sp))))
(br_if $assign (i32.lt_u (local.get $len) (i32.const 2)))
(br_if $assign
(i32.eqz
(ref.eq (array.get $block (local.get $dest) (i32.const 0))
(ref.i31 (i32.const 0)))))
(local.set $v'
(array.get $block (local.get $dest)
(i32.sub (local.get $len) (i32.const 1))))
(br_if $assign (i32.eqz (ref.test (ref $block) (local.get $v'))))
(local.set $b (ref.cast (ref $block) (local.get $v')))
(br_if $assign (i32.ne (array.len (local.get $b)) (i32.const 3)))
(br_if $assign
(i32.eqz
(ref.eq (array.get $block (local.get $b) (i32.const 2))
(array.get $block
(struct.get $intern_state $obj_table (local.get $s))
(i32.const 1)))))
(local.set $v'
(call $caml_callback_2 (local.get $unwrapper)
(local.get $b) (local.get $dest)))
(if (ref.test (ref $block) (local.get $v'))
(then
(local.set $v
(array.get $block (ref.cast (ref $block) (local.get $v'))
(i32.const 1)))
(array.set $block
(struct.get $intern_state $obj_table (local.get $s))
(local.get $ofs) (local.get $v)))
(else
(array.set $block (local.get $dest)
(i32.sub (local.get $len) (i32.const 1))
(array.new_fixed $block 4 (ref.i31 (i32.const 0))
(array.get $block (local.get $b) (i32.const 1))
(local.get $late_unwrap_mark)
(array.new_fixed $block 3 (ref.i31 (i32.const 0))
(array.new_fixed $block 3 (ref.i31 (i32.const 0))
(struct.get $stack_item $blk (local.get $sp))
(ref.i31
(struct.get $stack_item $pos (local.get $sp))))
(ref.i31 (i32.const 0)))))))
(br $assign))))
(drop (block $incorrect_value (result (ref eq))
(local.set $b
(br_on_cast_fail $incorrect_value (ref eq) (ref $block)
(array.get $block (local.get $res) (i32.const 0))))
(if (i32.eq (array.len (local.get $b)) (i32.const 3))
(then (return (array.get $block (local.get $b) (i32.const 2)))))
(ref.i31 (i32.const 0))))
(call $caml_failwith
(array.new_data $string $incorrect_value (i32.const 0) (i32.const 29)))
(ref.i31 (i32.const 0)))
(data $too_large
"unwrap_value: object too large to be read back on a 32-bit platform")
(data $bad_object "unwrap_value: bad object")
(type $marshal_header
(struct
(field $data_len i32)
(field $num_objects i32)))
(func $parse_header
(param $s (ref $intern_state))
(result (ref $marshal_header))
(local $magic i32)
(local $data_len i32) (local $num_objects i32) (local $whsize i32)
(local.set $magic (call $read32 (local.get $s)))
(if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big))
(then
(call $caml_failwith
(array.new_data $string $too_large
(i32.const 0) (i32.const 67)))))
(if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small))
(then
(call $caml_failwith
(array.new_data $string $bad_object
(i32.const 0) (i32.const 24)))))
(local.set $data_len (call $read32 (local.get $s)))
(local.set $num_objects (call $read32 (local.get $s)))
(drop (call $read32 (local.get $s)))
(drop (call $read32 (local.get $s)))
(struct.new $marshal_header
(local.get $data_len)
(local.get $num_objects)))
)
eliom-11.1.1/src/lib/client/eliom_stubs.c 0000664 0000000 0000000 00000000267 14723310174 0020213 0 ustar 00root root 0000000 0000000 #include
#include
void caml_unwrap_value_from_string () {
fprintf(stderr, "Unimplemented Javascript primitive caml_unwrap_value_from_string!\n");
exit(1);
}
eliom-11.1.1/src/lib/client/eliommod_cookies.ml 0000664 0000000 0000000 00000017006 14723310174 0021374 0 ustar 00root root 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2010 Vincent Balat
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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 Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Js_of_ocaml
open Eliom_lib
include Eliom_cookies_base
(* CCC The tables are indexed by the hostname, not the port appear.
there are no particular reason. If needed it is possible to add it *)
let cookie_tables :
(float option * string * bool) Ocsigen_cookie_map.Map_inner.t
Ocsigen_cookie_map.Map_path.t
Jstable.t
=
Jstable.create ()
module Map (Ord : sig
type key [@@deriving json]
val compare : key -> key -> int
end) =
struct
type 'a t =
| Empty
| Node of {l : 'a t; v : Ord.key; d : 'a; r : 'a t; h : int}
[@@deriving json]
let height = function Empty -> 0 | Node {h; _} -> h
let create l x d r =
let hl = height l and hr = height r in
Node {l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1)}
let bal l x d r =
let hl = height l and hr = height r in
if hl > hr + 2
then
match l with
| Empty -> invalid_arg "Map.bal"
| Node {l = ll; v = lv; d = ld; r = lr; _} -> (
if height ll >= height lr
then create ll lv ld (create lr x d r)
else
match lr with
| Empty -> invalid_arg "Map.bal"
| Node {l = lrl; v = lrv; d = lrd; r = lrr; _} ->
create (create ll lv ld lrl) lrv lrd (create lrr x d r))
else if hr > hl + 2
then
match r with
| Empty -> invalid_arg "Map.bal"
| Node {l = rl; v = rv; d = rd; r = rr; _} -> (
if height rr >= height rl
then create (create l x d rl) rv rd rr
else
match rl with
| Empty -> invalid_arg "Map.bal"
| Node {l = rll; v = rlv; d = rld; r = rlr; _} ->
create (create l x d rll) rlv rld (create rlr rv rd rr))
else Node {l; v = x; d; r; h = (if hl >= hr then hl + 1 else hr + 1)}
let rec add x data = function
| Empty -> Node {l = Empty; v = x; d = data; r = Empty; h = 1}
| Node {l; v; d; r; h} as m ->
let c = Ord.compare x v in
if c = 0
then if d == data then m else Node {l; v = x; d = data; r; h}
else if c < 0
then
let ll = add x data l in
if l == ll then m else bal ll v d r
else
let rr = add x data r in
if r == rr then m else bal l v d rr
let rec fold f m accu =
match m with
| Empty -> accu
| Node {l; v; d; r; _} -> fold f r (f v d (fold f l accu))
let empty = Empty
end
[@@@warning "-39"]
module Map_path = Map (struct
type key = string list [@@deriving json]
let compare = compare
end)
module Map_inner = Map (struct
type key = string [@@deriving json]
let compare = compare
end)
[@@@warning "+39"]
let json_cookies =
[%json: (float option * string * bool) Map_inner.t Map_path.t]
let extern_cookies c =
Ocsigen_cookie_map.Map_path.fold
(fun path inner m ->
Map_path.add path
(Ocsigen_cookie_map.Map_inner.fold Map_inner.add inner Map_inner.empty)
m)
c Map_path.empty
let intern_cookies c =
Map_path.fold
(fun path inner m ->
Ocsigen_cookie_map.Map_path.add path
(Map_inner.fold Ocsigen_cookie_map.Map_inner.add inner
Ocsigen_cookie_map.Map_inner.empty)
m)
c Ocsigen_cookie_map.Map_path.empty
(** [in_local_storage] implements cookie substitutes for iOS WKWebView *)
let get_table ?(in_local_storage = false) = function
| None -> Ocsigen_cookie_map.Map_path.empty
| Some host ->
if in_local_storage
then
let host = Js.string (host ^ "/substitutes") in
Js.Optdef.case
Dom_html.window##.localStorage
(fun () -> Ocsigen_cookie_map.Map_path.empty)
(fun st ->
Js.Opt.case
st ## (getItem host)
(fun () -> Ocsigen_cookie_map.Map_path.empty)
(fun v ->
intern_cookies (of_json ~typ:json_cookies (Js.to_string v))))
else
Js.Optdef.get
(Jstable.find cookie_tables (Js.string host))
(fun () -> Ocsigen_cookie_map.Map_path.empty)
(** [in_local_storage] implements cookie substitutes for iOS WKWebView *)
let set_table ?(in_local_storage = false) host t =
match host with
| None -> ()
| Some host ->
if in_local_storage
then
let host = Js.string (host ^ "/substitutes") in
Js.Optdef.case
Dom_html.window##.localStorage
(fun () -> ())
(fun st ->
st
## (setItem host
(Js.string (to_json ~typ:json_cookies (extern_cookies t)))))
else Jstable.add cookie_tables (Js.string host) t
let now () =
let date = new%js Js.date_now in
Js.to_float date##getTime /. 1000.
(** [in_local_storage] implements cookie substitutes for iOS WKWebView *)
let update_cookie_table ?(in_local_storage = false) host cookies =
let now = now () in
Ocsigen_cookie_map.Map_path.iter
(fun path table ->
Ocsigen_cookie_map.Map_inner.iter
(fun name -> function
| OSet (Some exp, _, _) when exp <= now ->
set_table ~in_local_storage host
(Ocsigen_cookie_map.Poly.remove ~path name
(get_table ~in_local_storage host))
| OUnset ->
set_table ~in_local_storage host
(Ocsigen_cookie_map.Poly.remove ~path name
(get_table ~in_local_storage host))
| OSet (exp, value, secure) ->
set_table ~in_local_storage host
(Ocsigen_cookie_map.Poly.add ~path name (exp, value, secure)
(get_table ~in_local_storage host)))
table)
cookies
(** [in_local_storage] implements cookie substitutes for iOS WKWebView *)
let get_cookies_to_send ?(in_local_storage = false) host https path =
let now = now () in
Ocsigen_cookie_map.Map_path.fold
(fun cpath t cookies_to_send ->
if Url.is_prefix_skip_end_slash
(Url.remove_slash_at_beginning cpath)
(Url.remove_slash_at_beginning path)
then
Ocsigen_cookie_map.Map_inner.fold
(fun name (exp, value, secure) cookies_to_send ->
match exp with
| Some exp when exp <= now ->
set_table ~in_local_storage host
(Ocsigen_cookie_map.Poly.remove ~path:cpath name
(get_table ~in_local_storage host));
cookies_to_send
| _ ->
if (not secure) || https
then (name, value) :: cookies_to_send
else cookies_to_send)
t cookies_to_send
else cookies_to_send)
(get_table ~in_local_storage host)
[]
let make_new_session_id () =
failwith
"Cannot define anonymous coservices on client side. Ask their values to the server."
eliom-11.1.1/src/lib/client/eliommod_dom.ml 0000664 0000000 0000000 00000070434 14723310174 0020523 0 ustar 00root root 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2011 Pierre Chambart, Grégoire Henry
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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 Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
open Js_of_ocaml
open Eliom_lib
let section = Lwt_log.Section.make "eliom:dom"
let iter_nodeList nodeList f =
for i = 0 to nodeList##.length - 1 do
(* Unsafe.get is ten time faster than nodeList##item *)
f (Js.Unsafe.get nodeList i)
done
let iter_attrList (attrList : Dom.attr Dom.namedNodeMap Js.t)
(f : Dom.attr Js.t -> unit)
=
for i = 0 to attrList##.length - 1 do
(* Unsafe.get is ten time faster than nodeList##item.
Is it the same for attrList ? *)
(* let v = attrList##item(i) in *)
let v = Js.Unsafe.get attrList i in
(* IE8 provides [null] in node##attributes;
so we wrap v to be a Js.opt *)
Js.Opt.iter v f
done
(* Dummy type used in the following "test_*" functions to test the
presence of methods in various browsers. *)
class type dom_tester = object
method compareDocumentPosition : unit Js.optdef Js.prop
method querySelectorAll : unit Js.optdef Js.prop
method classList : unit Js.optdef Js.prop
method createEvent : unit Js.optdef Js.prop
method onpageshow : unit Js.optdef Js.prop
method onpagehide : unit Js.optdef Js.prop
method onhashchange : unit Js.optdef Js.prop
end
let test_querySelectorAll () =
Js.Optdef.test
(Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.querySelectorAll
let test_compareDocumentPosition () =
Js.Optdef.test
(Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.compareDocumentPosition
let test_classList () =
Js.Optdef.test
(Js.Unsafe.coerce Dom_html.document##.documentElement : dom_tester Js.t)##.classList
let test_createEvent () =
Js.Optdef.test
(Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.createEvent
let test_pageshow_pagehide () =
let tester = (Js.Unsafe.coerce Dom_html.window : dom_tester Js.t) in
Js.Optdef.test tester##.onpageshow && Js.Optdef.test tester##.onpagehide
let test_onhashchange () =
Js.Optdef.test
(Js.Unsafe.coerce Dom_html.window : dom_tester Js.t)##.onhashchange
let fast_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) =
let open Dom.DocumentPosition in
has elt1 ## (compareDocumentPosition (elt2 :> Dom.node Js.t)) contained_by
let slow_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) =
let rec check_parent n =
if Js.strict_equals n (elt1 :> Dom.node Js.t)
then true
else
match Js.Opt.to_option n##.parentNode with
| None -> false
| Some p -> check_parent p
in
check_parent (elt2 :> Dom.node Js.t)
let ancessor =
if test_compareDocumentPosition () then fast_ancessor else slow_ancessor
let fast_select_request_nodes root =
root
## (querySelectorAll
(Js.string ("." ^ Eliom_runtime.RawXML.request_node_class)))
let fast_select_nodes root =
if !Eliom_config.debug_timings
then Firebug.console ## (time (Js.string "fast_select_nodes"));
let a_nodeList : Dom_html.element Dom.nodeList Js.t =
root
## (querySelectorAll
(Js.string ("a." ^ Eliom_runtime.RawXML.ce_call_service_class)))
in
let a_nodeList : Dom_html.anchorElement Dom.nodeList Js.t =
Js.Unsafe.coerce a_nodeList
in
let form_nodeList : Dom_html.element Dom.nodeList Js.t =
root
## (querySelectorAll
(Js.string ("form." ^ Eliom_runtime.RawXML.ce_call_service_class)))
in
let form_nodeList : Dom_html.formElement Dom.nodeList Js.t =
Js.Unsafe.coerce form_nodeList
in
let process_node_nodeList =
root
## (querySelectorAll
(Js.string ("." ^ Eliom_runtime.RawXML.process_node_class)))
in
let closure_nodeList =
root
## (querySelectorAll
(Js.string ("." ^ Eliom_runtime.RawXML.ce_registered_closure_class)))
in
let attrib_nodeList =
root
## (querySelectorAll
(Js.string ("." ^ Eliom_runtime.RawXML.ce_registered_attr_class)))
in
if !Eliom_config.debug_timings
then Firebug.console ## (timeEnd (Js.string "fast_select_nodes"));
( a_nodeList
, form_nodeList
, process_node_nodeList
, closure_nodeList
, attrib_nodeList )
let slow_has_classes (node : Dom_html.element Js.t) =
let classes =
(* IE<9: className is not set after change_page; getAttribute("class")
does not work for the initial document *)
let str =
if node##.className = Js.string ""
then
Js.Opt.get
node ## (getAttribute (Js.string "class"))
(fun () -> Js.string "")
else node##.className
in
Js.str_array str ## (split (Js.string " "))
in
let found_call_service = ref false in
let found_process_node = ref false in
let found_closure = ref false in
let found_attrib = ref false in
for i = 0 to classes##.length - 1 do
found_call_service :=
Js.Optdef.strict_equals (Js.array_get classes i)
(Js.def (Js.string Eliom_runtime.RawXML.ce_call_service_class))
|| !found_call_service;
found_process_node :=
Js.Optdef.strict_equals (Js.array_get classes i)
(Js.def (Js.string Eliom_runtime.RawXML.process_node_class))
|| !found_process_node;
found_closure :=
Js.Optdef.strict_equals (Js.array_get classes i)
(Js.def (Js.string Eliom_runtime.RawXML.ce_registered_closure_class))
|| !found_closure;
found_attrib :=
Js.Optdef.strict_equals (Js.array_get classes i)
(Js.def (Js.string Eliom_runtime.RawXML.ce_registered_attr_class))
|| !found_attrib
done;
!found_call_service, !found_process_node, !found_closure, !found_attrib
let slow_has_request_class (node : Dom_html.element Js.t) =
let classes = Js.str_array node ##. className ## (split (Js.string " ")) in
let found_request_node = ref false in
for i = 0 to classes##.length - 1 do
found_request_node :=
Js.Optdef.strict_equals (Js.array_get classes i)
(Js.def (Js.string Eliom_runtime.RawXML.request_node_class))
|| !found_request_node
done;
!found_request_node
let fast_has_classes (node : Dom_html.element Js.t) =
( Js.to_bool
node ##. classList
## (contains (Js.string Eliom_runtime.RawXML.ce_call_service_class))
, Js.to_bool
node ##. classList
## (contains (Js.string Eliom_runtime.RawXML.process_node_class))
, Js.to_bool
node ##. classList
## (contains (Js.string Eliom_runtime.RawXML.ce_registered_closure_class))
, Js.to_bool
node ##. classList
## (contains (Js.string Eliom_runtime.RawXML.ce_registered_attr_class)) )
let fast_has_request_class (node : Dom_html.element Js.t) =
Js.to_bool
node ##. classList
## (contains (Js.string Eliom_runtime.RawXML.request_node_class))
let has_classes : Dom_html.element Js.t -> bool * bool * bool * bool =
if test_classList () then fast_has_classes else slow_has_classes
let has_request_class : Dom_html.element Js.t -> bool =
if test_classList () then fast_has_request_class else slow_has_request_class
let slow_select_request_nodes (root : Dom_html.element Js.t) =
let node_array = new%js Js.array_empty in
let rec traverse (node : Dom.node Js.t) =
match node##.nodeType with
| Dom.ELEMENT ->
let node = (Js.Unsafe.coerce node : Dom_html.element Js.t) in
if has_request_class node then ignore node_array ## (push node);
iter_nodeList node##.childNodes traverse
| _ -> ()
in
traverse (root :> Dom.node Js.t);
(Js.Unsafe.coerce node_array : Dom_html.element Dom.nodeList Js.t)
let slow_select_nodes (root : Dom_html.element Js.t) =
let a_array = new%js Js.array_empty in
let form_array = new%js Js.array_empty in
let node_array = new%js Js.array_empty in
let closure_array = new%js Js.array_empty in
let attrib_array = new%js Js.array_empty in
let rec traverse (node : Dom.node Js.t) =
match node##.nodeType with
| Dom.ELEMENT ->
let node = (Js.Unsafe.coerce node : Dom_html.element Js.t) in
let call_service, process_node, closure, attrib = has_classes node in
(if call_service
then
match Dom_html.tagged node with
| Dom_html.A e -> ignore a_array ## (push e)
| Dom_html.Form e -> ignore form_array ## (push e)
| _ ->
Lwt_log.raise_error_f ~section "%s element tagged as eliom link"
(Js.to_string node##.tagName));
if process_node then ignore node_array ## (push node);
if closure then ignore closure_array ## (push node);
if attrib then ignore attrib_array ## (push node);
iter_nodeList node##.childNodes traverse
| _ -> ()
in
traverse (root :> Dom.node Js.t);
( (Js.Unsafe.coerce a_array : Dom_html.anchorElement Dom.nodeList Js.t)
, (Js.Unsafe.coerce form_array : Dom_html.formElement Dom.nodeList Js.t)
, (Js.Unsafe.coerce node_array : Dom_html.element Dom.nodeList Js.t)
, (Js.Unsafe.coerce closure_array : Dom_html.element Dom.nodeList Js.t)
, (Js.Unsafe.coerce attrib_array : Dom_html.element Dom.nodeList Js.t) )
let select_nodes =
if test_querySelectorAll () then fast_select_nodes else slow_select_nodes
let select_request_nodes =
if test_querySelectorAll ()
then fast_select_request_nodes
else slow_select_request_nodes
(* createEvent for ie < 9 *)
let createEvent_ie ev_type =
let evt : #Dom_html.event Js.t =
(Js.Unsafe.coerce Dom_html.document)##createEventObject
in
(Js.Unsafe.coerce evt)##._type := (Js.string "on") ## (concat ev_type);
evt
let createEvent_normal ev_type =
let evt : #Dom_html.event Js.t =
(Js.Unsafe.coerce Dom_html.document)
## (createEvent (Js.string "HTMLEvents"))
in
let () = (Js.Unsafe.coerce evt) ## (initEvent ev_type false false) in
evt
let createEvent =
if test_createEvent () then createEvent_normal else createEvent_ie
(* DOM traversal *)
class type ['element] get_tag = object
method getElementsByTagName :
Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth
end
(* We can't use Dom_html.document##head: it is not defined in ff3.6... *)
let get_head (page : 'element #get_tag Js.t) : 'element Js.t =
Js.Opt.get
page ## (getElementsByTagName (Js.string "head")) ## (item 0)
(fun () -> Lwt_log.raise_error ~section "get_head")
let get_body (page : 'element #get_tag Js.t) : 'element Js.t =
Js.Opt.get
page ## (getElementsByTagName (Js.string "body")) ## (item 0)
(fun () -> Lwt_log.raise_error ~section "get_body")
let iter_dom_array (f : 'a -> unit)
(a :
< length : < get : int ; .. > Js.gen_prop
; item : int -> 'a Js.opt Js.meth
; .. >
Js.t)
=
let length = a##.length in
for i = 0 to length - 1 do
Js.Opt.iter a ## (item i) f
done
let copy_text t = Dom_html.document ## (createTextNode t##.data)
(* ie, ff3.6 and safari does not like setting innerHTML on html and
head nodes: we need to rebuild the HTML dom tree from the XML dom
tree received in the xhr *)
(* BEGIN IE<9 HACK:
appendChild is broken in ie:
see
http://webbugtrack.blogspot.com/2009/01/bug-143-createtextnode-doesnt-work-on.html
http://webbugtrack.blogspot.com/2007/10/bug-142-appendchild-doesnt-work-on.html
This fix appending to script element.
TODO: it is also broken when appending tr to tbody, need to find a solution
*)
let add_childrens (elt : Dom_html.element Js.t) (sons : Dom.node Js.t list) =
try List.iter (Dom.appendChild elt) sons
with exn -> (
(* this code is ie only, there are no reason for an appendChild
to fail normally *)
let concat l =
let rec concat acc = function
| [] -> acc
| t :: q ->
let txt =
match Dom.nodeType t with
| Dom.Text t -> t
| _ ->
Lwt_log.raise_error_f ~section
"add_childrens: not text node in tag %s"
(Js.to_string elt##.tagName)
in
concat acc ## (concat txt##.data) q
in
concat (Js.string "") l
in
match Dom_html.tagged elt with
| Dom_html.Script elt -> elt##.text := concat sons
| Dom_html.Style elt ->
(* we need to append the style node to something. If we
don't do that the styleSheet field is not created if we.
And we can't do it by creating it with the ie specific
document.createStyleSheet: the styleSheet field is not
initialised and it can't be set either. *)
let d = Dom_html.createHead Dom_html.document in
Dom.appendChild d elt;
(Js.Unsafe.coerce elt)##.styleSheet##.cssText := concat sons
| _ -> Lwt_log.raise_error ~section ~exn "add_childrens: can't appendChild")
(* END IE HACK *)
let copy_element (e : Dom.element Js.t)
(registered_process_node : Js.js_string Js.t -> bool) :
Dom_html.element Js.t
=
let rec aux (e : Dom.element Js.t) =
let copy = Dom_html.document ## (createElement e##.tagName) in
(* IE<9: Copy className separately, it's not updated when displayed *)
Js.Opt.iter (Dom_html.CoerceTo.element e) (fun e ->
copy##.className := e##.className);
let node_id =
Js.Opt.to_option
e ## (getAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib))
in
match node_id with
| Some id when registered_process_node id ->
Js.Opt.iter
e ## (getAttribute (Js.string "class"))
(fun classes -> copy ## (setAttribute (Js.string "class") classes));
copy
## (setAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib) id);
Some copy
| _ ->
let add_attribute a =
Js.Opt.iter (Dom.CoerceTo.attr a)
(* we don't use copy##attributes##setNameditem:
in ie 9 it fail setting types of buttons... *)
(fun a -> copy ## (setAttribute a##.name a##.value))
in
iter_dom_array add_attribute e##.attributes;
let child_copies =
List.map_filter
(fun child ->
match Dom.nodeType child with
| Dom.Text t -> Some (copy_text t :> Dom.node Js.t)
| Dom.Element child -> (aux child :> Dom.node Js.t option)
| _ -> None)
(Dom.list_of_nodeList e##.childNodes)
in
add_childrens copy child_copies;
Some copy
in
match aux e with
| None -> Lwt_log.raise_error ~section "copy_element"
| Some e -> e
let html_document (src : Dom.element Dom.document Js.t) registered_process_node
: Dom_html.element Js.t
=
let content = src##.documentElement in
match Js.Opt.to_option (Dom_html.CoerceTo.element content) with
| Some e -> (
try Dom_html.document ## (adoptNode (e :> Dom.element Js.t))
with exn -> (
Lwt_log.ign_debug ~section ~exn "can't adopt node, import instead";
try Dom_html.document ## (importNode (e :> Dom.element Js.t) Js._true)
with exn ->
Lwt_log.ign_debug ~section ~exn "can't import node, copy instead";
copy_element content registered_process_node))
| None ->
Lwt_log.ign_debug ~section
"can't adopt node, document not parsed as html. copy instead";
copy_element content registered_process_node
(** CSS preloading. *)
let spaces_re = Regexp.regexp " +"
let is_stylesheet e =
(* FIX: should eventually use Dom_html.element *)
Js.Opt.case
(Dom_html.CoerceTo.link (Js.Unsafe.coerce e))
(fun _ -> false)
(fun e ->
List.exists
(fun s -> s = "stylesheet")
(Regexp.split spaces_re (Js.to_string e##.rel))
&& e##._type == Js.string "text/css")
let basedir_re = Regexp.regexp "^(([^/?]*/)*)([^/?]*)(\\?.*)?$"
let basedir path =
match Regexp.string_match basedir_re path 0 with
| None -> "/"
| Some res -> (
match Regexp.matched_group res 1 with
| None -> (
match Regexp.matched_group res 3 with Some ".." -> "../" | _ -> "/")
| Some dir -> (
match Regexp.matched_group res 3 with
| Some ".." -> dir ^ "../"
| _ -> dir))
let fetch_linked_css e =
let rec extract acc (e : Dom.node Js.t) =
match Dom.nodeType e with
| Dom.Element e when is_stylesheet e ->
let e : Dom_html.linkElement Js.t = Js.Unsafe.coerce e in
let href = e##.href in
if Js.to_bool e##.disabled
|| e##.title##.length > 0
|| href##.length = 0
then acc
else
let href = Js.to_string href in
let css =
Eliom_request.http_get href [] Eliom_request.string_result
in
acc @ [e, (e##.media, href, css >|= snd)]
| Dom.Element e ->
let c = e##.childNodes in
let acc = ref acc in
for i = 0 to c##.length - 1 do
acc := extract !acc (Js.Opt.get c ## (item i) (fun _ -> assert false))
done;
!acc
| _ -> acc
in
extract [] (e :> Dom.node Js.t)
let url_content_raw = "([^'\\\"]([^\\\\\\)]|\\\\.)*)"
let dbl_quoted_url_raw = "\"(([^\\\\\"]|\\\\.)*)\""
let quoted_url_raw = "'(([^\\\\']|\\\\.)*)'"
let url_re =
Regexp.regexp
(Printf.sprintf "url\\s*\\(\\s*(%s|%s|%s)\\s*\\)\\s*" dbl_quoted_url_raw
quoted_url_raw url_content_raw)
let raw_url_re =
Regexp.regexp
(Printf.sprintf "\\s*(%s|%s)\\s*" dbl_quoted_url_raw quoted_url_raw)
let absolute_re = Regexp.regexp "\\s*(https?:\\/\\/|data:|file:|\\/)"
let absolute_re2 =
Regexp.regexp "['\\\"]\\s*((https?:\\/\\/|data:|file:|\\/).*)['\\\"]$"
exception Incorrect_url
let parse_absolute ~prefix href =
match Regexp.search absolute_re href 0 with
| Some (i, _) when i = 0 -> (* absolute URL -> do not rewrite *) href
| _ -> (
match Regexp.search absolute_re2 href 0 with
| Some (i, res) when i = 0 -> (
match Regexp.matched_group res 1 with
| Some href -> (* absolute URL -> do not rewrite *) href
| None -> raise Incorrect_url)
| _ -> prefix ^ href)
let parse_url ~prefix css pos =
match Regexp.search url_re css pos with
| Some (i, res) when i = pos -> (
( i + String.length (Regexp.matched_string res)
, match Regexp.matched_group res 2 with
| Some href -> parse_absolute ~prefix href
| None -> (
match Regexp.matched_group res 3 with
| Some href -> parse_absolute ~prefix href
| None -> (
match Regexp.matched_group res 4 with
| Some href -> parse_absolute ~prefix href
| None -> raise Incorrect_url)) ))
| _ -> (
match Regexp.search raw_url_re css pos with
| Some (i, res) when i = pos -> (
( i + String.length (Regexp.matched_string res)
, match Regexp.matched_group res 1 with
| Some href -> parse_absolute ~prefix href
| None -> raise Incorrect_url ))
| _ -> raise Incorrect_url)
let parse_media css pos =
let i =
try String.index_from css pos ';' with Not_found -> String.length css
in
i + 1, String.sub css pos (i - pos)
(* Look for relative URL only... *)
let url_re =
Regexp.regexp "url\\s*\\(\\s*(?!('|\")?(https?:\\/\\/|data:|file:|\\/))"
let rewrite_css_url ~prefix css pos =
let len = String.length css - pos in
let buf = Buffer.create (len + (len / 2)) in
let rec rewrite pos =
if pos < String.length css
then
match Regexp.search url_re css pos with
| None -> Buffer.add_substring buf css pos (String.length css - pos)
| Some (i, _res) -> (
Buffer.add_substring buf css pos (i - pos);
try
let i, href = parse_url ~prefix css i in
Buffer.add_string buf "url('";
Buffer.add_string buf href;
Buffer.add_string buf "')";
rewrite i
with Incorrect_url ->
Buffer.add_substring buf css i (String.length css - i))
in
rewrite pos; Buffer.contents buf
let import_re = Regexp.regexp "@import\\s*"
let rec rewrite_css ~max (media, href, css) =
try%lwt
css >>= function
| None -> Lwt.return_nil
| Some css ->
if !Eliom_config.debug_timings
then Firebug.console ## (time (Js.string ("rewrite_CSS: " ^ href)));
let%lwt imports, css =
rewrite_css_import ~max ~prefix:(basedir href) ~media css 0
in
if !Eliom_config.debug_timings
then Firebug.console ## (timeEnd (Js.string ("rewrite_CSS: " ^ href)));
Lwt.return (imports @ [media, css])
with _ -> Lwt.return [media, Printf.sprintf "@import url(%s);" href]
and rewrite_css_import ?(charset = "") ~max ~prefix ~media css pos =
match Regexp.search import_re css pos with
| None ->
(* No @import anymore, rewrite url. *)
Lwt.return ([], rewrite_css_url ~prefix css pos)
| Some (i, res) -> (
(* Found @import rule, try to preload. *)
let init = String.sub css pos (i - pos) in
let charset = if pos = 0 then init else charset in
try
let i = i + String.length (Regexp.matched_string res) in
let i, href = parse_url ~prefix css i in
let i, media' = parse_media css i in
let%lwt import =
if max = 0
then
(* Maximum imbrication of @import reached, rewrite url. *)
Lwt.return
[media, Printf.sprintf "@import url('%s') %s;\n" href media']
else if media##.length > 0 && String.length media' > 0
then
(* TODO combine media if possible...
in the mean time keep explicit import. *)
Lwt.return
[media, Printf.sprintf "@import url('%s') %s;\n" href media']
else
let media =
if media##.length > 0 then media else Js.string media'
in
let css =
Eliom_request.http_get href [] Eliom_request.string_result
in
rewrite_css ~max:(max - 1) (media, href, css >|= snd)
and imports, css =
rewrite_css_import ~charset ~max ~prefix ~media css i
in
Lwt.return (import @ imports, css)
with
| Incorrect_url -> Lwt.return ([], rewrite_css_url ~prefix css pos)
| exn ->
Lwt_log.ign_info ~section ~exn "Error while importing css";
Lwt.return ([], rewrite_css_url ~prefix css pos))
let max_preload_depth = ref 4
let build_style (e, css) =
let%lwt css = rewrite_css ~max:!max_preload_depth css in
(* lwt css = *)
Lwt_list.map_p
(fun (media, css) ->
let style = Dom_html.createStyle Dom_html.document in
style##._type := Js.string "text/css";
style##.media := media;
(* IE8: Assigning to style##innerHTML results in
"Unknown runtime error" *)
let styleSheet = Js.Unsafe.(get style (Js.string "styleSheet")) in
if Js.Optdef.test styleSheet
then Js.Unsafe.(set styleSheet (Js.string "cssText") (Js.string css))
else style##.innerHTML := Js.string css;
Lwt.return (e, (style :> Dom.node Js.t)))
css
(* IE8 doesn't allow appendChild on noscript-elements *)
(* (\* Noscript is used to group style. It's ignored by the parser when *)
(* scripting is enabled, but does not seems to be ignore when *)
(* inserted as a DOM element. *\) *)
(* let node = Dom_html.createNoscript Dom_html.document in *)
(* List.iteri (fun i x -> debug "HOC 3.%i" i; Dom.appendChild node x) css; *)
(* Lwt.return (e, node )*)
let preload_css (doc : Dom_html.element Js.t) =
if !Eliom_config.debug_timings
then Firebug.console ## (time (Js.string "preload_css (fetch+rewrite)"));
let%lwt css = Lwt_list.map_p build_style (fetch_linked_css (get_head doc)) in
let css = List.concat css in
List.iter
(fun (e, css) ->
try Dom.replaceChild (get_head doc) css e
with _ ->
(* Node was a unique node that has been removed...
in a perfect settings we won't have parsed it... *)
Lwt_log.ign_info ~section "Unique CSS skipped...")
css;
if !Eliom_config.debug_timings
then Firebug.console ## (timeEnd (Js.string "preload_css (fetch+rewrite)"));
Lwt.return_unit
(** Window scrolling *)
(* Correct scrolling information in Chromium are found
Dom_html.document##body while on Firefox they are found on
Dom_html.document##documentElement. *)
[@@@warning "-39"]
type position =
{html_top : int; html_left : int; body_top : int; body_left : int}
[@@deriving json]
[@@@warning "+39"]
let top_position = {html_top = 0; html_left = 0; body_top = 0; body_left = 0}
let createDocumentScroll () =
{ html_top = Dom_html.document##.documentElement##.scrollTop
; html_left = Dom_html.document##.documentElement##.scrollLeft
; body_top = Dom_html.document##.body##.scrollTop
; body_left = Dom_html.document##.body##.scrollLeft }
(* With firefox, the scroll position is restored before to fire the
popstate event. We maintain our own position. *)
let current_position = ref top_position
let _ =
(* HACK: Remove this when js_of_ocaml 1.1.2 or greater is released... *)
(* window##onscroll <- *)
ignore
(Dom.addEventListener Dom_html.document (Dom.Event.make "scroll")
(Dom_html.handler (fun _event ->
current_position := createDocumentScroll ();
Js._false))
Js._true
: Dom_html.event_listener_id)
let getDocumentScroll () = !current_position
let setDocumentScroll pos =
Dom_html.document##.documentElement##.scrollTop := pos.html_top;
Dom_html.document##.documentElement##.scrollLeft := pos.html_left;
Dom_html.document##.body##.scrollTop := pos.body_top;
Dom_html.document##.body##.scrollLeft := pos.body_left;
current_position := pos
(* UGLY HACK for Opera bug: Opera seem does not always take into
account the content of the base element. If we touch it like that,
it remember its presence... *)
let touch_base () =
Js.Opt.iter
(Js.Opt.bind
Dom_html.document
## (getElementById (Js.string Eliom_common_base.base_elt_id))
Dom_html.CoerceTo.base)
(fun e ->
let href = e##.href in
e##.href := href)
(* BEGIN FORMDATA HACK: This is only needed if FormData is not available in the browser.
When it will be commonly available, remove all sections marked by "FORMDATA HACK" !
Notice: this hack is used to circumvent a limitation in FF4 implementation of formdata:
if the user click on a button in a form, formdatas created in the onsubmit callback normally contains the value of the button. ( it is the behaviour of chromium )
in FF4, it is not the case: we must do this hack to find which button was clicked.
NOTICE: this may not be corrected the way we want:
see https://bugzilla.mozilla.org/show_bug.cgi?id=647231
html5 will explicitly specify that chromium behaviour is wrong...
This is implemented in:
* this file -> here and called in load_eliom_data
* Eliom_request: in send_post_form
* in js_of_ocaml, module Form: the code to emulate FormData *)
let onclick_on_body_handler event =
(match Dom_html.tagged (Dom_html.eventTarget event) with
| Dom_html.Button button -> Js.Unsafe.global##.eliomLastButton := Some button
| Dom_html.Input input when input##._type = Js.string "submit" ->
Js.Unsafe.global##.eliomLastButton := Some input
| _ -> Js.Unsafe.global##.eliomLastButton := None);
Js._true
let add_formdata_hack_onclick_handler () =
ignore
(Dom_html.addEventListener
Dom_html.window##.document##.body
Dom_html.Event.click
(Dom_html.handler onclick_on_body_handler)
Js._true
: Dom_html.event_listener_id)
(* END FORMDATA HACK *)
(** onhashchange *)
let hashchange = Dom.Event.make "hashchange"
let onhashchange f =
if test_onhashchange ()
then
ignore
(Dom.addEventListener Dom_html.window hashchange
(Dom_html.handler (fun _ ->
f Dom_html.window##.location##.hash;
Js._false))
Js._true
: Dom_html.event_listener_id)
else
let last_fragment = ref Dom_html.window##.location##.hash in
let check () =
if not (Js.equals !last_fragment Dom_html.window##.location##.hash)
then (
last_fragment := Dom_html.window##.location##.hash;
f Dom_html.window##.location##.hash)
in
ignore
Dom_html.window
## (setInterval (Js.wrap_callback check) (Js.float (0.2 *. 1000.)))
eliom-11.1.1/src/lib/client/eliommod_dom.mli 0000664 0000000 0000000 00000006507 14723310174 0020674 0 ustar 00root root 0000000 0000000 (* Ocsigen
* http://www.ocsigen.org
* Copyright (C) 2011 Pierre Chambart, Grégoire Henry
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program 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 Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(** Cross browser dom manipulation functions *)
open Js_of_ocaml
class type ['element] get_tag = object
method getElementsByTagName :
Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth
end
val get_body : 'element #get_tag Js.t -> 'element Js.t
val get_head : 'element #get_tag Js.t -> 'element Js.t
(** [select_nodes root] finds the nodes below [root]
in the page annotated to be:
* eliom links
* eliom forms
* process unique nodes
* nodes with closures ( events )
* nodes with attributes *)
val select_nodes :
Dom_html.element Js.t
-> Dom_html.anchorElement Dom.nodeList Js.t
* Dom_html.formElement Dom.nodeList Js.t
* Dom_html.element Dom.nodeList Js.t
* Dom_html.element Dom.nodeList Js.t
* Dom_html.element Dom.nodeList Js.t
val select_request_nodes :
Dom_html.element Js.t
-> Dom_html.element Dom.nodeList Js.t
(** [select_request_nodes root] finds the nodes below [root]
in the page annotated to be:
* request unique nodes *)
val ancessor : #Dom.node Js.t -> #Dom.node Js.t -> bool
(** [ancessor n1 n2] is true if [n1] is an ancessor of [n2] *)
val createEvent : Js.js_string Js.t -> #Dom_html.event Js.t
val copy_element :
Dom.element Js.t
-> (Js.js_string Js.t -> bool)
-> Dom_html.element Js.t
(** [copy_element e] creates recursively a fresh html from any xml
element avoiding browser bugs *)
val html_document :
Dom.element Dom.document Js.t
-> (Js.js_string Js.t -> bool)
-> Dom_html.element Js.t
(** Assuming [d] has a body and head element, [html_document d] will
return the same document as html *)
val preload_css : Dom_html.element Js.t -> unit Lwt.t
(** [preload_css e] downloads every css included in every link
elements that is a descendant of [e] and replace it and its linked
css by inline [