Commit 89a9232d authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Preliminary support for markup backend (and support for html5 in load_xml).

parent ae97d8df
let use () = ()
\ No newline at end of file
val use : unit -> unit
\ No newline at end of file
open Markup
open Cduce_core
let ends_with s pat =
let ls = String.length s in
let lpat = String.length pat in
ls >= lpat && pat = String.sub s (ls-lpat) lpat
let markup_load_xml otag ctag text s =
let stream, close =
if Url.is_url s then (string (Url.load_url s), ignore) else file s
in
let resolver = ref (fun _ -> None) in
let () = if ends_with s ".xhtml" then resolver := xhtml_entity in
let parser =
parse_xml
~entity:(fun s -> match !resolver s with None -> Some "" | x -> x)
~report:(fun location e ->
Cduce_loc.raise_generic
(Format.sprintf "load_xml: '%s': %s" s (Error.to_string ~location e)))
~context:`Document stream
in
iter (fun signal -> match signal with
`Start_element ((_, tag), atts) ->
if tag = "xhtml" then resolver := xhtml_entity;
otag tag (List.map (fun ((_, tag),v) -> (tag, v)) atts);
|`End_element -> ctag ""
|`Text ls -> List.iter text ls
| _ -> ()
) (signals parser);
close ()
let markup_load_html otag ctag text s =
let stream, close =
if Url.is_url s then (string (Url.load_url s), ignore) else file s
in
let parser =
parse_html
~report:(fun _ _ -> ())
~context:`Document stream
in
iter (fun signal -> match signal with
`Start_element ((_, tag), atts) ->
otag tag (List.map (fun ((_, tag),v) -> (tag, v)) atts);
|`End_element -> ctag ""
|`Text ls -> List.iter text ls
| _ -> ()
) (signals parser);
close ()
let use () =
let open Load_xml in
xml_parser := (markup_load_xml start_element_handler end_element_handler text_handler);
html_loader := (mk_load_xml (markup_load_html start_element_handler end_element_handler text_handler) ~ns:true )
let () =
Cduce_config.register ~priority:2
"markup" "Markup.ml XML and HTML parser"
use
\ No newline at end of file
...@@ -20,6 +20,11 @@ ...@@ -20,6 +20,11 @@
from from
(expat -> cduce_expat.real.ml) (expat -> cduce_expat.real.ml)
(-> cduce_expat.empty.ml)) (-> cduce_expat.empty.ml))
(select
cduce_markup.ml
from
(markup -> cduce_markup.real.ml)
(-> cduce_markup.empty.ml))
;Trickery to only include threads library when netstring is present ;Trickery to only include threads library when netstring is present
(select (select
fake_cduce_netclient.ml fake_cduce_netclient.ml
......
...@@ -38,7 +38,8 @@ depends: [ ...@@ -38,7 +38,8 @@ depends: [
("ocurl" { >= "0.9.1" } | ("ocurl" { >= "0.9.1" } |
"ocamlnet" { >= "4.1.8"}) "ocamlnet" { >= "4.1.8"})
("ocaml-expat" {>= "1.1.0" } | ("ocaml-expat" {>= "1.1.0" } |
"pxp" {>= "1.2.9"}) "pxp" {>= "1.2.9"} |
"markup" {>= "1.0.0-1"})
] ]
depopts: [ depopts: [
"ocaml-compiler-libs" {>= "v0.9.0"} "ocaml-compiler-libs" {>= "v0.9.0"}
......
...@@ -8,7 +8,8 @@ depends: [ ...@@ -8,7 +8,8 @@ depends: [
("ocurl" { >= "0.9.1" } | ("ocurl" { >= "0.9.1" } |
"ocamlnet" { >= "4.1.8"}) "ocamlnet" { >= "4.1.8"})
("ocaml-expat" {>= "1.1.0" } | ("ocaml-expat" {>= "1.1.0" } |
"pxp" {>= "1.2.9"}) "pxp" {>= "1.2.9"} |
"markup" {>= "1.0.0-1"})
] ]
depopts: [ depopts: [
"ocaml-compiler-libs" {>= "v0.9.0"} "ocaml-compiler-libs" {>= "v0.9.0"}
......
...@@ -70,7 +70,7 @@ let rec create_elt accu = function ...@@ -70,7 +70,7 @@ let rec create_elt accu = function
ns_table := old_table ns_table := old_table
| Empty -> assert false | Empty -> assert false
let start_element_handler name att = let start_element_handler name att =
if not (only_ws txt.buffer txt.pos) then if not (only_ws txt.buffer txt.pos) then
stack := String (Bytes.sub_string txt.buffer 0 txt.pos, !stack); stack := String (Bytes.sub_string txt.buffer 0 txt.pos, !stack);
txt.pos <- 0; txt.pos <- 0;
...@@ -94,11 +94,11 @@ let text_handler = add_string txt ...@@ -94,11 +94,11 @@ let text_handler = add_string txt
let xml_parser = ref (fun s -> failwith "No XML parser available") let xml_parser = ref (fun s -> failwith "No XML parser available")
let load_xml ?(ns=false) s = let mk_load_xml parser ?(ns=false) s =
try try
H.clear subst_ns; H.clear subst_ns;
keep_ns := ns; keep_ns := ns;
!xml_parser s; parser s;
match !stack with match !stack with
| Element (x,Empty) -> stack := Empty; x | Element (x,Empty) -> stack := Empty; x
| _ -> Value.failwith' "No XML stream to parse" | _ -> Value.failwith' "No XML stream to parse"
...@@ -108,6 +108,8 @@ let load_xml ?(ns=false) s = ...@@ -108,6 +108,8 @@ let load_xml ?(ns=false) s =
("Unknown namespace prefix: " ^ (U.get_str n)) ("Unknown namespace prefix: " ^ (U.get_str n))
| e -> raise e | e -> raise e
let load_xml ?(ns=false) s = mk_load_xml !xml_parser ~ns s
let load_xml_subst ?(ns=false) s subst = let load_xml_subst ?(ns=false) s subst =
H.clear subst_ns; H.clear subst_ns;
List.iter (fun (k,v) -> H.replace subst_ns k v) subst; List.iter (fun (k,v) -> H.replace subst_ns k v) subst;
......
...@@ -14,6 +14,8 @@ val only_ws : bytes -> int -> bool ...@@ -14,6 +14,8 @@ val only_ws : bytes -> int -> bool
val load_xml : ?ns:bool -> string -> Value.t val load_xml : ?ns:bool -> string -> Value.t
val mk_load_xml : (string -> unit) -> ?ns:bool -> string -> Value.t
val load_xml_subst : ?ns:bool -> string -> (Ns.Uri.t * Ns.Uri.t) list -> Value.t val load_xml_subst : ?ns:bool -> string -> (Ns.Uri.t * Ns.Uri.t) list -> Value.t
val html_loader : (string -> Value.t) ref val html_loader : (string -> Value.t) ref
......
...@@ -28,6 +28,9 @@ let xml_ns_str = "http://www.w3.org/XML/1998/namespace" ...@@ -28,6 +28,9 @@ let xml_ns_str = "http://www.w3.org/XML/1998/namespace"
let xml_ns = Uri.mk (U.mk xml_ns_str) let xml_ns = Uri.mk (U.mk xml_ns_str)
let xmlns_ns_str = "http://www.w3.org/2000/xmlns/"
let xmlns_ns = Uri.mk (U.mk xmlns_ns_str)
let xsd_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema") let xsd_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema")
let xsi_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema-instance") let xsi_ns = Uri.mk (U.mk "http://www.w3.org/2001/XMLSchema-instance")
...@@ -41,7 +44,10 @@ type table = Uri.t Table.t ...@@ -41,7 +44,10 @@ type table = Uri.t Table.t
let mktbl = List.fold_left (fun table (pr, ns) -> Table.add (U.mk pr) ns table) let mktbl = List.fold_left (fun table (pr, ns) -> Table.add (U.mk pr) ns table)
let empty_table = mktbl Table.empty [ ("", empty); ("xml", xml_ns) ] let empty_table = mktbl Table.empty [ ("", empty); ("xml", xml_ns);
("xmlns", xmlns_ns);
(xmlns_ns_str, xmlns_ns)
]
let def_table = mktbl empty_table [ ("xsd", xsd_ns); ("xsi", xsi_ns) ] let def_table = mktbl empty_table [ ("xsd", xsd_ns); ("xsi", xsi_ns) ]
...@@ -128,7 +134,7 @@ module Printer = struct ...@@ -128,7 +134,7 @@ module Printer = struct
p.prefixes <- (pr, ns) :: p.prefixes p.prefixes <- (pr, ns) :: p.prefixes
let register_ns p ns = let register_ns p ns =
if ns == xml_ns then () if ns == xml_ns || ns == xmlns_ns then ()
else else
match get_prefix p ns with match get_prefix p ns with
| { contents = Hint l } as r -> | { contents = Hint l } as r ->
...@@ -144,6 +150,7 @@ module Printer = struct ...@@ -144,6 +150,7 @@ module Printer = struct
let tag p (ns, l) = let tag p (ns, l) =
let l = U.get_str l in let l = U.get_str l in
if ns == xml_ns then "xml:" ^ l if ns == xml_ns then "xml:" ^ l
else if ns == xmlns_ns then "xmlns:" ^ l
else else
match !(get_prefix p ns) with match !(get_prefix p ns) with
| Set pr -> | Set pr ->
...@@ -154,6 +161,7 @@ module Printer = struct ...@@ -154,6 +161,7 @@ module Printer = struct
let attr p (ns, l) = let attr p (ns, l) =
let l = U.get_str l in let l = U.get_str l in
if ns == xml_ns then "xml:" ^ l if ns == xml_ns then "xml:" ^ l
else if ns == xmlns_ns then "xmlns:" ^ l
else if ns == empty then l else if ns == empty then l
else else
match !(get_prefix p ns) with match !(get_prefix p ns) with
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment